git.iko.soy/Idris-dev

on master help sign in

.gitignore+2

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

1616*~

1717.DS_Store

1818.hpc

19+*.orig

1920*.tix

2021.projectile

2122.dir-locals.el

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

2728test/output

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

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

31+test/runtest.exe

3032tags

3133TAGS

3234src/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+

161New in 0.10:

262============

363

INSTALL.md+8−3

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

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

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

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

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

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

68−only.

66+building Idris from source with stack.

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

68+NixOS unstable.

6969

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

7171

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

7777infrastructure. For more information about Stack please visit the

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

7979

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+

8085### System GHC

8186

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

Makefile+3−14

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

2020test: doc test_c

2121

2222test_c:

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

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

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

3024

3125test_js:

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

33−

34−test_all:

35− $(MAKE) test

36− $(MAKE) test_llvm

37− $(MAKE) test_java

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

3827

3928test_timed:

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

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

4130

4231lib_clean:

4332 $(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

1010import qualified Distribution.Simple.Setup as S

1111import qualified Distribution.Simple.Program as P

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

13+import Distribution.Compiler

1314import Distribution.PackageDescription

1415import Distribution.Text

1516

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

4546make verbosity =

4647 P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake

4748

49+#ifdef mingw32_HOST_OS

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

51+#endif

4852-- -----------------------------------------------------------------------------

4953-- Flags

5054

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

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

199203 return (Just buildinfo, [])

200204

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+

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

202220 buildStdLib

203221 buildRTS

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

247265main = defaultMainWithHooks $ simpleUserHooks

248266 { postClean = idrisClean

249267 , postConf = idrisConfigure

268+ , preBuild = idrisPreBuild

250269 , postBuild = idrisBuild

251270 , postCopy = \_ flags pkg local ->

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

benchmarks/quasigroups/Parser.idr+2

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

55

66import Solver

77

8+%access public export

9+

810ParseErr : Type

911ParseErr = String

1012

benchmarks/quasigroups/Solver.idr+2−1

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

66import Data.Vect.Quantifiers

77

88%default total

9+%access public export

910

1011Cell : Nat -> Type

1112Cell n = Maybe (Fin n)

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

3233 addLine : List Char -> List Char -> List Char

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

3435

35−instance Show (Board n) where

36+Show (Board n) where

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

3738

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

docs/conf.py+4−4

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

5959# built documents.

6060#

6161# The short X.Y version.

62−version = '0.9.19'

62+version = '0.10.1'

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

64−release = '0.9.19.1'

64+release = '0.10.1'

6565

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

6767# for a list of supported languages.

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

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

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

236236latex_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'),

239237 ('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'),

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

241241 ]

242242

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

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

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

189189

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

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

191191====================================================================

192192

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

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

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

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

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

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

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.

197200

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

199202===================================================================================

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

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

4646 using the ``UniqueType`` universe.

4747- `Partial

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

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

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

5050- Error message reflection

5151- Eliminators

5252- Label types ``'name``

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

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

303303

304304::

305305

306− public

307− abstract

306+ public export

307+ export

308308 private

309309

310310Totality

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

372372 -- Single Line

373373 {- Multiline -}

374374 ||| Docstring (goes before definition)

375−

375+

376376Multi line String literals

377377~~~~~~~~~~~~~~~~~~~~~~~~~~

378378

docs/tutorial/modules.rst+79−31

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

7575Export Modifiers

7676================

7777

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

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

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

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

82−

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

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

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

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

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

88− names are exported.

89−

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

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

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

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

94− method names.

95−

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

97− exported.

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

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

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

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

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

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

84+

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

86+ default.

87+

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

89+

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

91+

92+

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

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

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

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

97+names leaking into a module's interface.

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.

98109

99110.. note::

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

101111

102−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:

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+

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

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

104146

105147.. code-block:: idris

106148

107− module Btree

149+ module BTree

108150

109− abstract data BTree a = Leaf

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

151+ export data BTree a = Leaf

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

111153

112− abstract

154+ export

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

114156 insert x Leaf = Node Leaf x Leaf

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

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

117159

118− abstract

160+ export

119161 toList : BTree a -> List a

120162 toList Leaf = []

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

122164

123− abstract

165+ export

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

125167 toTree [] = Leaf

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

127169

170+``%access`` Directive

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

172+

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

129174directive, for example:

130175

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

132177

133178 module Btree

134179

135− %access abstract

180+ %access export

136181

137182 data BTree a = Leaf

138183 | Node (BTree a) a (BTree a)

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

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

152197

153198In 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+-------------------------------

155203

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

157205the ``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:

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

151151

152152 test/Makefile

153− test/runtest.pl

153+ test/runtest.hs

154154 test/reg001/run

155155 test/reg001/*.idr

156156 test/reg001/expected

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

163163 test/reg004/run

164164 test/reg004/*.idr

165165 test/reg004/expected

166+ test/reg005/run

167+ test/reg005/*.idr

168+ test/reg005/expected

166169 test/reg006/run

167170 test/reg006/*.idr

168171 test/reg006/expected

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

361364 test/basic016/run

362365 test/basic016/*.idr

363366 test/basic016/expected

367+ test/basic017/run

368+ test/basic017/*.idr

369+ test/basic017/expected

364370

365371 test/bignum001/run

366372 test/bignum001/*.idr

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

462468 test/ffi006/*.c

463469 test/ffi006/run

464470 test/ffi006/expected

471+ test/ffi007/*.idr

472+ test/ffi007/*.c

473+ test/ffi007/*.h

474+ test/ffi007/run

475+ test/ffi007/expected

465476

466477 test/folding001/*.idr

467478 test/folding001/run

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

587598 test/primitives003/expected

588599 test/primitives005/run

589600 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

594601 test/primitives005/expected

595602

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+

596609 test/pkg001/run

597610 test/pkg001/test.ipkg

598611 test/pkg001/*.idr

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

795808 benchmarks/trivial/sortvec.idr

796809 benchmarks/trivial/sortvec.ipkg

797810

811+ icons/idris_icon.rc

812+ icons/idris.ico

813+

798814source-repository head

799815 type: git

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

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

866882 , Idris.Elab.Transform

867883 , Idris.Elab.Value

868884 , Idris.Elab.Term

885+ , Idris.Elab.Quasiquote

869886

870887 , Idris.REPL.Browse

871888

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

886903 , Idris.Docs

887904 , Idris.Docstrings

888905 , Idris.ElabDecls

889− , Idris.ElabQuasiquote

890906 , Idris.Erasure

891907 , Idris.Error

892908 , Idris.ErrReverse

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

899915 , Idris.Interactive

900916 , Idris.Output

901917 , Idris.Parser

902− , Idris.ParseHelpers

903− , Idris.ParseOps

904− , Idris.ParseExpr

905− , Idris.ParseData

918+ , Idris.Parser.Helpers

919+ , Idris.Parser.Ops

920+ , Idris.Parser.Expr

921+ , Idris.Parser.Data

906922 , Idris.PartialEval

907923 , Idris.Primitives

908924 , Idris.ProofSearch

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

910926 , Idris.Providers

911927 , Idris.Reflection

912928 , Idris.REPL

913− , Idris.REPLParser

929+ , Idris.REPL.Parser

914930 , Idris.Transforms

915931 , Idris.TypeSearch

916932 , Idris.Unlit

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

9851001 , zip-archive > 0.2.3.5 && < 0.2.4

9861002 , safe

9871003 , fsnotify < 2.2

988− , async < 2.1

1004+ , async < 2.2

1005+

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

9901007 if impl(ghc < 7.10.3)

9911008 build-depends: zlib < 0.6.1

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

9991016 , TemplateHaskell

10001017

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

1002− ghc-options: -threaded -rtsopts

10031019

10041020 if os(linux)

10051021 cpp-options: -DLINUX

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

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

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

10481064

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+

10491083Executable idris-codegen-c

10501084 Main-is: Main.hs

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

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

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

33import Data.Morphisms

44import Control.Category

55

6−%access public

6+%access public export

77

88infixr 5 <++>

99infixr 3 ***

libs/base/Control/Catchable.idr+2

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

22

33import Control.IOExcept

44

5+%access public export

6+

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

68 throw : t -> m a

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

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

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

22

33import Data.Morphisms

44

5−%access public

5+%access public export

66

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

88 id : cat a a

libs/base/Control/IOExcept.idr+2

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

11module Control.IOExcept

22

3+%access public export

4+

35-- An IO monad with exception handling

46

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

libs/base/Control/Isomorphism.idr+1

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

44import Data.Fin

55

66%default total

7+%access public export

78

89||| An isomorphism between two types

910data Iso : Type -> Type -> Type where

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

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

11module Control.Monad.Identity

22

3−public record Identity (a : Type) where

3+%access public export

4+

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

46 constructor Id

57 runIdentity : a

68

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

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

55import Control.Monad.Writer

66import Control.Monad.Reader

77

8−%access public

8+%access public export

99

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

1111interface (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

44import Control.Monad.Identity

55import Control.Monad.Trans

66

7−%access public

7+%access public export

88

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

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

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

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

33import public Control.Monad.Identity

44import public Control.Monad.Trans

55

6−%access public

6+%access public export

77

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

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

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

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

11module Control.Monad.Trans

22

3+%access public export

4+

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

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

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

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

44import Control.Monad.Identity

55import Control.Monad.Trans

66

7−%access public

7+%access public export

88

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

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

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

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

44

55%default total

66

7−public

7+public export

88nextPow2 : Nat -> Nat

99nextPow2 Z = Z

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

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

1313 where

1414 l2x = log2NZ (S x) SIsNotZ

1515

16−public

16+public export

1717nextBytes : Nat -> Nat

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

1919

20−public

20+public export

2121machineTy : Nat -> Type

2222machineTy Z = Bits8

2323machineTy (S Z) = Bits16

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

4747getPad : Nat -> machineTy n

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

4949

50−public

50+public export

5151data Bits : Nat -> Type where

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

5353

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

9292 where

9393 pad = getPad {n=3} n

9494

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

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

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

97101 | Z = pad8' n prim__shlB8 x c

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

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

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

101105

102−public

106+public export

103107shiftLeft : Bits n -> Bits n -> Bits n

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

105109

110+public export

106111shiftRightLogical' : machineTy n -> machineTy n -> machineTy n

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

108113 | Z = prim__lshrB8 x c

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

110115 | S (S Z) = prim__lshrB32 x c

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

112117

113−public

118+public export

114119shiftRightLogical : Bits n -> Bits n -> Bits n

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

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

117122

123+public export

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

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

120126 | Z = pad8' n prim__ashrB8 x c

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

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

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

124130

125−public

131+public export

126132shiftRightArithmetic : Bits n -> Bits n -> Bits n

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

128134

135+public export

129136and' : machineTy n -> machineTy n -> machineTy n

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

131138 | Z = prim__andB8 x y

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

133140 | S (S Z) = prim__andB32 x y

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

135142

136−public

143+public export

137144and : Bits n -> Bits n -> Bits n

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

139146

147+public export

140148or' : machineTy n -> machineTy n -> machineTy n

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

142150 | Z = prim__orB8 x y

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

144152 | S (S Z) = prim__orB32 x y

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

146154

147−public

155+public export

148156or : Bits n -> Bits n -> Bits n

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

150158

159+public export

151160xor' : machineTy n -> machineTy n -> machineTy n

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

153162 | Z = prim__xorB8 x y

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

155164 | S (S Z) = prim__xorB32 x y

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

157166

158−public

167+public export

159168xor : Bits n -> Bits n -> Bits n

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

161170

171+public export

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

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

164174 | Z = pad8 n prim__addB8 x y

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

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

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

168178

169−public

179+public export

170180plus : Bits n -> Bits n -> Bits n

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

172182

183+public export

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

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

175186 | Z = pad8 n prim__subB8 x y

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

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

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

179190

180−public

191+public export

181192minus : Bits n -> Bits n -> Bits n

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

183194

195+public export

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

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

186198 | Z = pad8 n prim__mulB8 x y

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

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

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

190202

191−public

203+public export

192204times : Bits n -> Bits n -> Bits n

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

194206

195207partial

208+public export

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

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

198211 | Z = prim__sdivB8 x y

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

200213 | S (S Z) = prim__sdivB32 x y

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

202215

203−public partial

216+public export partial

204217sdiv : Bits n -> Bits n -> Bits n

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

206219

207220partial

221+public export

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

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

210224 | Z = prim__udivB8 x y

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

212226 | S (S Z) = prim__udivB32 x y

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

214228

215−public partial

229+public export partial

216230udiv : Bits n -> Bits n -> Bits n

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

218232

219−partial

233+public export partial

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

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

222236 | Z = prim__sremB8 x y

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

224238 | S (S Z) = prim__sremB32 x y

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

226240

227−public partial

241+public export partial

228242srem : Bits n -> Bits n -> Bits n

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

230244

231−partial

245+public export partial

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

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

234248 | Z = prim__uremB8 x y

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

236250 | S (S Z) = prim__uremB32 x y

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

238252

239−public partial

253+public export partial

240254urem : Bits n -> Bits n -> Bits n

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

242256

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

276290 | S (S Z) = prim__gtB32 x y

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

278292

293+public export

279294implementation Eq (Bits n) where

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

281296

297+public export

282298implementation Ord (Bits n) where

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

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

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

291307 then EQ

292308 else GT

293309

310+public export

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

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

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

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

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

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

304321

305−public

322+public export

306323complement : Bits n -> Bits n

307324complement (MkBits x) = MkBits (complement' x)

308325

309326-- TODO: Prove

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

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

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

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

313330 | (Z, Z) = believe_me x

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

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

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

323340

324−public

341+public export

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

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

327344

328−%assert_total

345+public export %assert_total

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

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

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

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

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

338355 prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad

339356

340−public

357+public export

341358intToBits : Integer -> Bits n

342359intToBits n = MkBits (intToBits' n)

343360

344361implementation Cast Integer (Bits n) where

345362 cast = intToBits

346363

364+public export

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

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

349367 | Z = prim__zextB8_BigInt x

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

351369 | S (S Z) = prim__zextB32_BigInt x

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

353371

354−public

372+public export

355373bitsToInt : Bits n -> Integer

356374bitsToInt (MkBits x) = bitsToInt' x

357375

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

377+public export

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

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

361380

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

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

394413 believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad)

395414

396−--public

415+--public export

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

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

399418

400419-- TODO: Prove

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

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

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

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

404423 | (Z, Z) = believe_me x

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

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

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

414433

415−public

434+public export

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

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

418437

419−public

438+public export

420439bitAt : Fin n -> Bits n

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

422441

423−public

442+public export

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

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

426445

427−public

446+public export

428447setBit : Fin n -> Bits n -> Bits n

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

430449

431−public

450+public export

432451unsetBit : Fin n -> Bits n -> Bits n

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

434453

libs/base/Data/Complex.idr+2

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

55

66module Data.Complex

77

8+%access public export

9+

810------------------------------ Rectangular form

911

1012infix 6 :+

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

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

11module Data.Erased

22

3−%access public

3+%access public export

44%default total

55

66||| The erasure monad.

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

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

11module Data.Fin

22

33%default total

4−%access public

4+%access public export

55

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

77|||

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

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

150150 , SubReport subErr

151151 ]

152−total

152+total export

153153finFromIntegerErrors : Err -> Maybe (List ErrorReportPart)

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

155155 = mkFinIntegerErr (TConst c) m

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

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

22

33import public Data.Vect

44

5−%access public

5+%access public export

66%default total

77

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

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

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

11module Data.List

22

3−%access public

3+%access public export

44

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

66|||

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

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

1414 |||

1515 ||| 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)

1717

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

1919 uninhabited Here impossible

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

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

22

33import Data.List

44

5+%access public export

6+

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

68|||

79||| @ P the property to be satsified

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

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

55%default total

66

77||| Integers modulo 2^n

8−public

8+public export

99data Mod2 : Nat -> Type where

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

1111

12+public export

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

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

1415

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

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

1718

18−public partial

19+public export partial

1920div : Mod2 n -> Mod2 n -> Mod2 n

2021div = modBin udiv

2122

22−public partial

23+public export partial

2324rem : Mod2 n -> Mod2 n -> Mod2 n

2425rem = modBin urem

2526

2627%assert_total

27−public

28+public export

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

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

3031

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

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

11module Data.Morphisms

22

3−%access public

3+%access public export

44

55data Morphism : Type -> Type -> Type where

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

libs/base/Data/So.idr+1

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

11module Data.So

22

33%default total

4+%access public export

45

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

67|||

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

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

11module Data.String

2−%access public

2+%access public export

33

44private

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

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

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

33import public Data.Fin

44import Language.Reflection

55

6−%access public

6+%access public export

77%default total

88

99infixr 7 ::

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

198198-- Zips and unzips

199199--------------------------------------------------------------------------------

200200

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

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

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

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

203207zipWith f [] [] = []

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

205209

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

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

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

575579 Here : Elem x (x::xs)

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

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

577581

578582||| Nothing can be in an empty Vect

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

580584noEmptyElem Here impossible

581585

586+Uninhabited (Elem x []) where

587+ uninhabited = noEmptyElem

588+

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

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

584591neitherHereNorThere xneqy xninxs Here = xneqy Refl

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

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

22

33import Data.Vect

44

5+%access public export

6+

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

68|||

79||| @ P the property to be satsified

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

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

77|||

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

99||| @ message The error to print

10−partial

10+partial export

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

1212 (message : String) ->

1313 a

libs/base/Debug/Trace.idr+1

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

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

44||| @ msg what to print

55||| @ result the final result

6+export

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

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

89

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

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

44import Language.Reflection.Elab

55import Language.Reflection.Errors

66

7+%access public export

8+

79--------------------------------------------------------

810-- Tactic construction conveniences

911--------------------------------------------------------

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

145147 showPrec d StrType = "StrType"

146148 showPrec d VoidType = "VoidType"

147149 showPrec d Forgot = "Forgot"

150+ showPrec d WorldType = "WorldType"

151+ showPrec d TheWorld = "TheWorld"

148152

149153implementation Eq NativeTy where

150154 IT8 == IT8 = True

libs/base/Syntax/PreorderReasoning.idr+2

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

11module Syntax.PreorderReasoning

22

3+%access public export

4+

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

46syntax [expr] "QED" = qed expr

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

libs/base/System.idr+1−1

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

22

33%include C "unistd.h"

44%default partial

5−%access public

5+%access public export

66

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

88||| otherwise it returns Nothing.

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

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

66

77import System

88

9+%access export

10+

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

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

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

libs/base/System/Info.idr+3

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

11module System.Info

22

33||| The Idris backend in use

4+export

45backend : String

56backend = prim__systemInfo 0

67

78||| The operating system in use.

9+export

810os : String

911os = prim__systemInfo 1

1012

1113||| The triple this program was targeted for

14+export

1215targetTriple : String

1316targetTriple = prim__systemInfo 2

libs/contrib/Classes/Verified.idr+9

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

44import Control.Algebra.Lattice

55import Control.Algebra.VectorSpace

66

7+%access public export

8+

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

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

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

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

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

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

9496

97+{- FIXME: Some maintenance required here.

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

99+-}

100+{-

101+

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

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

97104

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

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

113120

114121--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

33infixl 6 <->

44infixl 7 <.>

55

6+%access public export

67

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

89||| 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

33import Control.Algebra

44import Data.Heap

55

6+%access public export

67

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

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

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

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

77import Data.Complex

88import Data.ZZ

99

10+%access public export

1011

1112Semigroup Integer where

1213 (<+>) = (+)

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

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

22

33import Control.Algebra

44

5+%access public export

6+

57infixl 5 <#>

68infixr 2 <||>

79

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

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

44import Data.ZZ

55

66%default total

7−%access public

7+%access public export

88

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

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

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

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

77||| @ p the predicate to wait for

88||| @ f the function to repeatedly apply

99||| @ v the starting value

10−partial

10+partial export

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

1212until p f v with (p v)

1313 | False = until p f (f v)

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

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

66module Control.WellFounded

77

88%default total

9−

9+%access public export

1010

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

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

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

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

22

33import Data.Fin

44

5−%access public

5+%access public export

66%default total

77

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

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

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

11module Data.CoList

22

3−%access public

3+%access public export

44%default total

55

66||| 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

33import public Data.Vect

44

55%default total

6+%access public export

67

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

89Fun : Vect n Type -> Type -> Type

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

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

22

33import Data.Vect

44

5−%access public

5+%access public export

66%default total

77

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

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

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

77

88

99%default total

10−%access public

10+%access export

1111

12−abstract data MaxiphobicHeap : Type -> Type where

12+export data MaxiphobicHeap : Type -> Type where

1313 Empty : MaxiphobicHeap a

1414 Node : Nat -> MaxiphobicHeap a -> a -> MaxiphobicHeap a -> MaxiphobicHeap a

1515

libs/contrib/Data/Matrix.idr+1

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

55import public Data.Vect

66

77%default total

8+%access public export

89

910||| Matrix with n rows and m columns

1011Matrix : Nat -> Nat -> Type -> Type

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

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

99

1010import public Data.Matrix

1111

12−

12+%access public export

1313%default total

1414

1515infixr 2 <:> -- vector inner product

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

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

55import public Data.Matrix

66

77%default total

8+%access public export

89

910infixr 2 <:> -- vector inner product

1011infixr 2 >< -- vector outer product

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

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

22module Data.Nat.DivMod

33

44%default total

5+%access public export

56

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

78|||

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

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

88import Control.WellFounded

99

1010%default total

11−%access public

11+%access public export

1212

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

1414|||

libs/contrib/Data/Rel.idr+1

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

22

33import Data.Fun

44

5+%access public export

56

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

78Rel : Vect n Type -> Type

libs/contrib/Data/Sign.idr+2

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

11module Data.Sign

22

3+%access public export

4+

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

46data Sign = Plus | Zero | Minus

57

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

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

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

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

194194

195−abstract

195+export

196196data SortedMap : Type -> Type -> Type where

197197 Empty : Ord k => SortedMap k v

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

199199

200−public

200+export

201201empty : Ord k => SortedMap k v

202202empty = Empty

203203

204−public

204+export

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

206206lookup _ Empty = Nothing

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

208208

209−public

209+export

210210insert : k -> v -> SortedMap k v -> SortedMap k v

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

212212insert k v (M _ t) =

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

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

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

216216

217−public

217+export

218218delete : k -> SortedMap k v -> SortedMap k v

219219delete _ Empty = Empty

220220delete k (M Z t) =

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

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

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

228228

229−public

229+export

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

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

232232

233−public

233+export

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

235235toList Empty = []

236236toList (M _ t) = treeToList t

237237

238−public

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

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

241240treeMap 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

44

55-- TODO: add intersection, union, difference

66

7−abstract

7+export

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

99

10−public

10+export

1111empty : Ord k => SortedSet k

1212empty = SetWrapper Data.SortedMap.empty

1313

14−public

14+export

1515insert : k -> SortedSet k -> SortedSet k

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

1717

18−public

18+export

1919delete : k -> SortedSet k -> SortedSet k

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

2121

22−public

22+export

2323contains : k -> SortedSet k -> Bool

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

2525

26−public

26+export

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

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

2929

30−public

30+export

3131toList : SortedSet k -> List k

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

3333

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

44import Data.Sign

55

66%default total

7−%access public

7+%access public export

88

99

1010||| 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

33import Data.Rel

44import Data.Fun

55

6−%access public

6+%access public export

77

88--------------------------------------------------------------------------------

99-- Interface for decidable n-ary Relations

libs/contrib/Decidable/Order.idr+1−1

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

66import Data.Fun

77import Data.Rel

88

9−%access public

9+%access public export

1010

1111--------------------------------------------------------------------------------

1212-- Utility Lemmas

libs/contrib/Network/Cgi.idr+11−11

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

44

55%default total

66

7−public

7+public export

88Vars : Type

99Vars = List (String, String)

1010

@@ -23,7 +23,7 @@ add_Headers str st = record { Headers = Headers st ++ str } st

2323add_Output : String -> CGIInfo -> CGIInfo

2424add_Output str st = record { Output = Output st ++ str } st

2525

26−abstract

26+export

2727data CGI : Type -> Type where

2828 MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a

2929

@@ -51,32 +51,32 @@ setInfo i = MkCGI (\s => return ((), i))

5151getInfo : CGI CGIInfo

5252getInfo = MkCGI (\s => return (s, s))

5353

54−abstract

54+export

5555lift : IO a -> CGI a

5656lift op = MkCGI (\st => do { x <- op

5757 return (x, st) } )

5858

59−abstract

59+export

6060output : String -> CGI ()

6161output s = do i <- getInfo

6262 setInfo (add_Output s i)

6363

64−abstract

64+export

6565queryVars : CGI Vars

6666queryVars = do i <- getInfo

6767 return (GET i)

6868

69−abstract

69+export

7070postVars : CGI Vars

7171postVars = do i <- getInfo

7272 return (POST i)

7373

74−abstract

74+export

7575cookieVars : CGI Vars

7676cookieVars = do i <- getInfo

7777 return (Cookies i)

7878

79−abstract

79+export

8080queryVar : String -> CGI (Maybe String)

8181queryVar x = do vs <- queryVars

8282 return (lookup x vs)

@@ -89,12 +89,12 @@ getHeaders : CGI String

8989getHeaders = do i <- getInfo

9090 return (Headers i)

9191

92−abstract

92+export

9393flushHeaders : CGI ()

9494flushHeaders = do o <- getHeaders

9595 lift (putStrLn o)

9696

97−abstract

97+export

9898flush : CGI ()

9999flush = do o <- getOutput

100100 lift (putStr o)

@@ -119,7 +119,7 @@ getCgiEnv key = do

119119 val <- getEnv key

120120 return $ maybe "" id val

121121

122−abstract

122+export

123123runCGI : CGI a -> IO a

124124runCGI prog = do

125125 clen_in <- getCgiEnv "CONTENT_LENGTH"

libs/contrib/Network/Socket.idr+7−8

@@ -8,9 +8,7 @@ module IdrisNet.Socket

88%include C "sys/socket.h"

99%include C "netdb.h"

1010

11−%access public

12−

13−ByteLength : Type

11+public export ByteLength : Type

1412ByteLength = Int

1513

1614interface ToCode a where

@@ -67,8 +65,9 @@ implementation ToCode SocketType where

6765

6866data RecvStructPtr = RSPtr Ptr

6967data RecvfromStructPtr = RFPtr Ptr

70−data BufPtr = BPtr Ptr

71−data SockaddrPtr = SAPtr Ptr

68+

69+export data BufPtr = BPtr Ptr

70+export data SockaddrPtr = SAPtr Ptr

7271

7372||| Protocol Number.

7473|||

@@ -120,18 +119,18 @@ record UDPAddrInfo where

120119 remote_port : Port

121120

122121||| Frees a given pointer

123−public

122+export

124123sock_free : BufPtr -> IO ()

125124sock_free (BPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

126125

127−public

126+export

128127sockaddr_free : SockaddrPtr -> IO ()

129128sockaddr_free (SAPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

130129

131130||| Allocates an amount of memory given by the ByteLength parameter.

132131|||

133132||| Used to allocate a mutable pointer to be given to the Recv functions.

134−public

133+export

135134sock_alloc : ByteLength -> IO BufPtr

136135sock_alloc bl = map BPtr $ foreign FFI_C "idrnet_malloc" (Int -> IO Ptr) bl

137136

libs/contrib/System/Concurrency/Process.idr+10−2

@@ -4,9 +4,9 @@ module System.Concurrency.Process

44

55import System.Concurrency.Raw

66

7−%access public

7+%access public export

88

9−abstract

9+export

1010data ProcID msg = MkPID Ptr

1111

1212||| Type safe message passing programs. Parameterised over the type of

@@ -30,24 +30,29 @@ run : Process msg x -> IO x

3030run (Lift prog) = prog

3131

3232||| Get current process ID

33+export

3334myID : Process msg (ProcID msg)

3435myID = Lift (return (MkPID prim__vm))

3536

3637||| Send a message to another process

3738||| Returns whether the send was unsuccessful.

39+export

3840send : ProcID msg -> msg -> Process msg Bool

3941send (MkPID p) m = Lift (do x <- sendToThread p (prim__vm, m)

4042 return (x == 1))

4143

4244||| Return whether a message is waiting in the queue

45+export

4346msgWaiting : Process msg Bool

4447msgWaiting = Lift checkMsgs

4548

4649||| Return whether a message is waiting in the queue from a specific sender

50+export

4751msgWaitingFrom : ProcID msg -> Process msg Bool

4852msgWaitingFrom (MkPID p) = Lift (checkMsgsFrom p)

4953

5054||| Receive a message - blocks if there is no message waiting

55+export

5156recv : Process msg msg

5257recv {msg} = do (senderid, m) <- Lift get

5358 return m

@@ -55,6 +60,7 @@ recv {msg} = do (senderid, m) <- Lift get

5560 get = getMsg

5661

5762||| Receive a message from specific sender - blocks if there is no message waiting

63+export

5864recvFrom : ProcID msg -> Process msg msg

5965recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get

6066 return m

@@ -62,6 +68,7 @@ recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get

6268 get = getMsgFrom p

6369

6470||| receive a message, and return with the sender's process ID.

71+export

6572recvWithSender : Process msg (ProcID msg, msg)

6673recvWithSender {msg}

6774 = do (senderid, m) <- Lift get

@@ -69,6 +76,7 @@ recvWithSender {msg}

6976 where get : IO (Ptr, msg)

7077 get = getMsg

7178

79+export

7280create : Process msg () -> Process msg (ProcID msg)

7381create (Lift p) = do ptr <- Lift (fork p)

7482 return (MkPID ptr)

libs/contrib/contrib.ipkg+3−1

@@ -7,7 +7,9 @@ modules = Control.Algebra,

77 Control.Isomorphism.Primitives,

88 Control.Partial,

99 Control.WellFounded,

10+

1011 Classes.Verified,

12+

1113 Data.Fun, Data.Rel,

1214 Data.Hash,

1315 Data.Matrix, Data.Matrix.Algebraic, Data.Matrix.Numeric,

@@ -16,7 +18,7 @@ modules = Control.Algebra,

1618 Data.BoundedList,

1719 Data.Heap,

1820 Data.SortedMap, Data.SortedSet,

19− Data.CoList,

21+ Data.CoList, Data.Storable,

2022

2123 Decidable.Decidable, Decidable.Order,

2224

libs/effects/Effect/Default.idr+2

@@ -2,6 +2,8 @@ module Effect.Default

22

33import Data.Vect

44

5+%access public export

6+

57interface Default a where

68 default : a

79

libs/effects/Effect/Exception.idr+2

@@ -4,6 +4,8 @@ import Effects

44import System

55import Control.IOExcept

66

7+%access public export

8+

79data Exception : Type -> Effect where

810 Raise : a -> sig (Exception a) b

911

libs/effects/Effect/File.idr+5−4

@@ -4,6 +4,7 @@ module Effect.File

44import Effects

55import Control.IOExcept

66

7+%access public export

78

89||| A Dependent type to describe File Handles. File handles are

910||| parameterised with the current state of the file: Closed; Open for

@@ -63,7 +64,7 @@ data FileIO : Effect where

6364 ||| Write a string to a file.

6465 |||

6566 ||| 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)

6768

6869 ||| End of file?

6970 |||

@@ -137,11 +138,11 @@ readLine : Eff String [FILE_IO (OpenFile Read)]

137138readLine = call $ ReadLine

138139

139140||| Write a string to a file.

140−writeString : String -> Eff () [FILE_IO (OpenFile Write)]

141+writeString : String -> Eff () [FILE_IO (OpenFile WriteTruncate)]

141142writeString str = call $ WriteString str

142143

143144||| Write a line to a file.

144−writeLine : String -> Eff () [FILE_IO (OpenFile Write)]

145+writeLine : String -> Eff () [FILE_IO (OpenFile WriteTruncate)]

145146writeLine str = call $ WriteString (str ++ "\n")

146147

147148||| End of file?

@@ -175,7 +176,7 @@ writeFile : (errFunc : String -> e)

175176 -> (content : String)

176177 -> Eff (Either e ()) [FILE_IO ()]

177178writeFile errFunc fname content = do

178− case !(open fname Write) of

179+ case !(open fname WriteTruncate) of

179180 True => do

180181 writeString content

181182 close

libs/effects/Effect/Logging/Category.idr+2−2

@@ -14,7 +14,7 @@ module Effect.Logging.Category

1414import Effects

1515import public Effect.Logging.Level

1616

17−%access public

17+%access public export

1818

1919-- -------------------------------------------------------- [ Logging Resource ]

2020

@@ -147,7 +147,7 @@ logN : (Show a, Eq a) => (l : Nat)

147147 -> (cs : List a)

148148 -> (m : String)

149149 -> 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

151151 where

152152 lvl : (n ** LogLevel n)

153153 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

1515import Effects

1616import public Effect.Logging.Level

1717

18−%access public

18+%access public export

1919

2020-- ------------------------------------------------------------ [ The Resource ]

2121

@@ -84,7 +84,7 @@ log l msg = call $ Log l msg

8484||| @l The level to log.

8585||| @m The message to log.

8686logN : (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

8888 where

8989 lvl : (n ** LogLevel n)

9090 lvl = case cast {to=String} (cast {to=Int} l) of

libs/effects/Effect/Logging/Level.idr+1−1

@@ -14,7 +14,7 @@

1414||| loggers.

1515module Effect.Logging.Level

1616

17−%access public

17+%access public export

1818%default total

1919

2020-- ---------------------------------------------------- [ Log Level Definition ]

libs/effects/Effect/Memory.idr+9−3

@@ -5,13 +5,13 @@ import Control.IOExcept

55import Data.Vect

66import public Data.So

77

8−%access public

8+%access public export

99

10−abstract

10+export

1111data MemoryChunk : Nat -> Nat -> Type where

1212 CH : Ptr -> MemoryChunk size initialized

1313

14−abstract

14+export

1515data RawMemory : Effect where

1616 Allocate : (n : Nat) ->

1717 RawMemory () () (\v => MemoryChunk n 0)

@@ -102,10 +102,12 @@ implementation Handler RawMemory (IOExcept String) where

102102RAW_MEMORY : Type -> EFFECT

103103RAW_MEMORY t = MkEff t RawMemory

104104

105+export

105106allocate : (n : Nat) ->

106107 Eff () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

107108allocate size = call $ Allocate size

108109

110+export

109111initialize : {i : Nat} ->

110112 {n : Nat} ->

111113 Bits8 ->

@@ -115,9 +117,11 @@ initialize : {i : Nat} ->

115117 (\v => [RAW_MEMORY (MemoryChunk n (i + size))])

116118initialize c size prf = call $ Initialize c size prf

117119

120+export

118121free : Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

119122free = call Free

120123

124+export

121125peek : {i : Nat} ->

122126 (offset : Nat) ->

123127 (size : Nat) ->

@@ -125,6 +129,7 @@ peek : {i : Nat} ->

125129 { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8)

126130peek offset size prf = call $ Peek offset size prf

127131

132+export

128133poke : {n : Nat} ->

129134 {i : Nat} ->

130135 (offset : Nat) ->

@@ -155,6 +160,7 @@ move' src_ptr dst_offset src_offset size dst_bounds src_bounds

155160

156161data MoveDescriptor = Dst | Src

157162

163+export

158164move : {dst_size : Nat} ->

159165 {dst_init : Nat} ->

160166 {src_size : Nat} ->

libs/effects/Effect/Monad.idr+2

@@ -2,6 +2,8 @@ module Effect.Monad

22

33import Effects

44

5+%access public export

6+

57data MonadEffT : List EFFECT -> (Type -> Type) -> Type -> Type where

68 MkMonadEffT : EffM m a xs (\v => xs) -> MonadEffT xs m a

79

libs/effects/Effect/Perf.idr+1−1

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

1212import Effects

1313import Effect.Default

1414

15−%access public

15+%access public export

1616

1717-- ---------------------------------------------------- [ Timer Data Structure ]

1818

libs/effects/Effect/Random.idr+2

@@ -3,6 +3,8 @@ module Effect.Random

33import Effects

44import Data.Vect

55

6+%access public export

7+

68data Random : Effect where

79 GetRandom : sig Random Integer Integer

810 SetSeed : Integer -> sig Random () Integer

libs/effects/Effect/Select.idr+2

@@ -2,6 +2,8 @@ module Effect.Select

22

33import Effects

44

5+%access public export

6+

57data Selection : Effect where

68 Select : List a -> sig Selection a ()

79

libs/effects/Effect/State.idr+1−1

@@ -2,7 +2,7 @@ module Effect.State

22

33import Effects

44

5−%access public

5+%access public export

66

77data State : Effect where

88 Get : sig State a a

libs/effects/Effect/StdIO.idr+2

@@ -3,6 +3,8 @@ module Effect.StdIO

33import Effects

44import Control.IOExcept

55

6+%access public export

7+

68-------------------------------------------------------------

79-- IO effects internals

810-------------------------------------------------------------

libs/effects/Effect/System.idr+2

@@ -7,6 +7,8 @@ import Effects

77import System

88import Control.IOExcept

99

10+%access public export

11+

1012data System : Effect where

1113 Args : sig System (List String)

1214 Time : sig System Integer

libs/effects/Effect/Trans.idr+1−1

@@ -2,7 +2,7 @@ module Effect.Trans

22

33import Effects

44

5−%access public

5+%access public export

66

77data Trans : (Type -> Type) -> Effect where

88 Lift : m a -> sig (Trans m) a

libs/effects/Effects.idr+25−1

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

77--- Effectful computations are described as algebraic data types that

88--- explain how an effect is interpreted in some underlying context.

99

10−%access public

10+%access export

1111-- ----------------------------------------------------------------- [ Effects ]

1212||| The Effect type describes effectful computations.

1313|||

@@ -15,11 +15,13 @@ import Data.Vect

1515||| + The return type of the computation.

1616||| + The input resource.

1717||| + The computation to run on the resource given the return value.

18+public export

1819Effect : Type

1920Effect = (x : Type) -> Type -> (x -> Type) -> Type

2021

2122||| The `EFFECT` Data type describes how to promote the Effect

2223||| description into a concrete effect.

24+public export

2325%error_reverse

2426data EFFECT : Type where

2527 MkEff : Type -> Effect -> EFFECT

@@ -30,24 +32,29 @@ data EFFECT : Type where

3032-- or a dependent change. These are easily disambiguated by type.

3133

3234namespace NoResourceEffect

35+ public export

3336 sig : Effect -> Type -> Type

3437 sig e r = e r () (\v => ())

3538

3639namespace NoUpdateEffect

40+ public export

3741 sig : Effect -> (ret : Type) -> (resource : Type) -> Type

3842 sig e r e_in = e r e_in (\v => e_in)

3943

4044namespace UpdateEffect

45+ public export

4146 sig : Effect -> (ret : Type) -> (res_in : Type) -> (res_out : Type) -> Type

4247 sig e r e_in e_out = e r e_in (\v => e_out)

4348

4449namespace DepUpdateEffect

50+ public export

4551 sig : Effect ->

4652 (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type

4753 sig e r e_in e_out = e r e_in e_out

4854

4955||| Handler interfaces describe how an effect `e` is translated to the

5056||| underlying computation context `m` for execution.

57+public export

5158interface Handler (e : Effect) (m : Type -> Type) where

5259 ||| How to handle the effect.

5360 |||

@@ -77,6 +84,7 @@ syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff]

7784syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)

7885

7986-- --------------------------------------- [ Properties and Proof Construction ]

87+public export

8088data SubList : List a -> List a -> Type where

8189 SubNil : SubList [] []

8290 Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

@@ -88,21 +96,25 @@ subListId {xs = Nil} = SubNil

8896subListId {xs = x :: xs} = Keep subListId

8997

9098namespace Env

99+ public export

91100 data Env : (m : Type -> Type) -> List EFFECT -> Type where

92101 Nil : Env m Nil

93102 (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

94103

104+public export

95105data EffElem : Effect -> Type ->

96106 List EFFECT -> Type where

97107 Here : EffElem x a (MkEff a x :: xs)

98108 There : EffElem x a xs -> EffElem x a (y :: xs)

99109

100110||| make an environment corresponding to a sub-list

111+private

101112dropEnv : Env m ys -> SubList xs ys -> Env m xs

102113dropEnv [] SubNil = []

103114dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

104115dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

105116

117+public export

106118updateWith : (ys' : List a) -> (xs : List a) ->

107119 SubList ys xs -> List a

108120updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

@@ -112,6 +124,7 @@ updateWith (y :: ys) [] SubNil = y :: ys

112124updateWith [] (x :: xs) (Keep rest) = []

113125

114126||| Put things back, replacing old with new in the sub-environment

127+private

115128rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->

116129 Env m xs -> Env m (updateWith ys' xs prf)

117130rebuildEnv [] SubNil env = env

@@ -123,6 +136,7 @@ rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

123136

124137-- -------------------------------------------------- [ The Effect EDSL itself ]

125138

139+public export

126140updateResTy : (val : t) ->

127141 (xs : List EFFECT) -> EffElem e a xs -> e t a b ->

128142 List EFFECT

@@ -131,9 +145,11 @@ updateResTy val (x :: xs) (There p) n = x :: updateResTy val xs p n

131145

132146infix 5 :::, :-, :=

133147

148+public export

134149data LRes : lbl -> Type -> Type where

135150 (:=) : (x : lbl) -> res -> LRes x res

136151

152+public export

137153(:::) : lbl -> EFFECT -> EFFECT

138154(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e

139155

@@ -156,6 +172,7 @@ relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

156172||| @ x The return type of the result.

157173||| @ es The list of allowed side-effects.

158174||| @ ce Function to compute a new list of allowed side-effects.

175+public export

159176data EffM : (m : Type -> Type) -> (x : Type)

160177 -> (es : List EFFECT)

161178 -> (ce : x -> List EFFECT) -> Type where

@@ -182,27 +199,33 @@ data EffM : (m : Type -> Type) -> (x : Type)

182199

183200namespace SimpleEff

184201 -- Simple effects, no updates

202+ public export

185203 Eff : (x : Type) -> (es : List EFFECT) -> Type

186204 Eff x es = {m : Type -> Type} -> EffM m x es (\v => es)

187205

206+ public export

188207 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> Type

189208 EffT m x es = EffM m x es (\v => es)

190209

191210namespace TransEff

192211 -- Dependent effects, updates not dependent on result

212+ public export

193213 Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

194214 Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce)

195215

216+ public export

196217 EffT : (m : Type -> Type) ->

197218 (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

198219 EffT m x es ce = EffM m x es (\_ => ce)

199220

200221namespace DepEff

201222 -- Dependent effects, updates dependent on result

223+ public export

202224 Eff : (x : Type) -> (es : List EFFECT)

203225 -> (ce : x -> List EFFECT) -> Type

204226 Eff x es ce = {m : Type -> Type} -> EffM m x es ce

205227

228+ public export

206229 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT)

207230 -> (ce : x -> List EFFECT) -> Type

208231 EffT m x es ce = EffM m x es ce

@@ -271,6 +294,7 @@ execEff (val :: env) (There p) eff k

271294-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

272295-- updates can be propagated even through failing computations?

273296

297+export

274298eff : Env m xs -> EffM m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

275299eff env (Value x) k = k x env

276300eff env (prog `EBind` c) k

libs/prelude/Builtins.idr+41−19

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

11%unqualified

22

3−%access public

3+%access public export

44%default total

55

66||| The canonical single-element type, also known as the trivially

@@ -37,23 +37,31 @@ namespace Builtins

3737 %used MkUPair a

3838 %used MkUPair b

3939

40− ||| Dependent pairs

40+ ||| Dependent pairs aid in the construction of dependent types by

41+ ||| providing evidence that some value resides in the type.

4142 |||

42− ||| Dependent pairs represent existential quantification - they consist of a

43− ||| witness for the existential claim and a proof that the property holds for

44− ||| it. Another way to see dependent pairs is as just data - for instance, the

45− ||| length of a vector paired with that vector.

43+ ||| Formally, speaking, dependent pairs represent existential

44+ ||| quantification - they consist of a witness for the existential

45+ ||| claim and a proof that the property holds for it.

4646 |||

47− ||| @ a the type of the witness

48− ||| @ P the type of the proof

49− data Sigma : (a : Type) -> (P : a -> Type) -> Type where

50− MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P

47+ ||| @a the value to place in the type.

48+ ||| @P the dependent type that requires the value.

49+ data DPair : (a : Type) -> (P : a -> Type) -> Type where

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`."

5159

5260||| The empty type, also known as the trivially false proposition.

5361|||

54−||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope.

55−%elim data Void : Type where

56−

62+||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope.

63+%elim data Void : Type where

64+

5765||| The eliminator for the `Void` type.

5866void : Void -> a

5967-- We can't define void yet. We can't define a function with no clauses without

@@ -155,13 +163,13 @@ assert_total x = x

155163

156164||| Subvert the type checker. This function is abstract, so it will not reduce in

157165||| 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

159167believe_me : a -> b

160168believe_me x = prim__believe_me _ _ x

161169

162170||| Subvert the type checker. This function *will* reduce in the type checker.

163171||| Use it with extreme care - it can result in segfaults or worse!

164−public %assert_total

172+public export %assert_total

165173really_believe_me : a -> b

166174really_believe_me x = prim__believe_me _ _ x

167175

@@ -174,9 +182,9 @@ Float = Double

174182-- Pointers as external primitive; there's no literals for these, so no

175183-- need for them to be part of the compiler.

176184

177−abstract data Ptr : Type

178−abstract data ManagedPtr : Type

179−abstract data CData : Type

185+export data Ptr : Type

186+export data ManagedPtr : Type

187+export data CData : Type

180188

181189%extern prim__readFile : prim__WorldType -> Ptr -> String

182190%extern prim__writeFile : prim__WorldType -> Ptr -> String -> Int

@@ -191,4 +199,18 @@ abstract data CData : Type

191199%extern prim__eqManagedPtr : ManagedPtr -> ManagedPtr -> Int

192200%extern prim__registerPtr : Ptr -> Int -> ManagedPtr

193201

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

33import Builtins

44import Prelude.Basics

55import Prelude.Bool

6−import Prelude.Classes

6+import Prelude.Interfaces

77import Prelude.Either

88import Prelude.List

99import Prelude.Nat

1010import Prelude.Maybe

1111

12+%access public export

13+

1214--------------------------------------------------------------------------------

1315-- Utility lemmas

1416--------------------------------------------------------------------------------

@@ -141,7 +143,7 @@ implementation DecEq a => DecEq (List a) where

141143 decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil)

142144 decEq (x :: xs) (y :: ys) with (decEq x y)

143145 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

145147 decEq (x :: xs) (x :: ys) | (Yes Refl) | (No p) = No (\eq => lemma_x_eq_xs_neq Refl p eq)

146148 decEq (x :: xs) (y :: ys) | No p with (decEq xs ys)

147149 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

211213 where primitiveEq : x = y

212214 primitiveEq = believe_me (Refl {x})

213215 postulate primitiveNotEq : x = y -> Void

214−

215−

216−

libs/prelude/IO.idr+92−30

@@ -3,25 +3,24 @@

33import Builtins

44import Prelude.List

55

6−%access public

6+%access export

77

88||| Idris's primitive IO, for building abstractions on top of

9−abstract

109data PrimIO : Type -> Type where

1110 Prim__IO : a -> PrimIO a

1211

1312||| A token representing the world, for use in `IO`

14−abstract data World = TheWorld prim__WorldType

13+data World = TheWorld prim__WorldType

1514

16−private

1715world : World -> prim__WorldType

1816world (TheWorld w) = w

1917

20−abstract WorldRes : Type -> Type

18+WorldRes : Type -> Type

2119WorldRes x = x

2220

2321||| An FFI specifier, which describes how a particular compiler

2422||| backend handles foreign function calls.

23+public export

2524record FFI where

2625 constructor MkFFI

2726 ||| A family describing which types are available in the FFI

@@ -35,10 +34,10 @@ record FFI where

3534

3635||| The IO type, parameterised over the FFI that is available within

3736||| it.

38−abstract

3937data IO' : (lang : FFI) -> Type -> Type where

4038 MkIO : (World -> PrimIO (WorldRes a)) -> IO' lang a

4139

40+public export

4241data FTy : FFI -> List Type -> Type -> Type where

4342 FRet : ffi_types f t -> FTy f xs (IO' f t)

4443 FFun : ffi_types f s -> FTy f (s :: xs) t -> FTy f xs (s -> t)

@@ -47,15 +46,16 @@ namespace ForeignEnv

4746 data FEnv : FFI -> List Type -> Type where

4847 Nil : FEnv f []

4948 (::) : (ffi_types f t, t) -> FEnv f xs -> FEnv f (t :: xs)

50−

49+

5150ForeignPrimType : (xs : List Type) -> FEnv ffi xs -> Type -> Type

5251ForeignPrimType {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

5453 = (ffi_types ffi x, x) -> ForeignPrimType xs env t

5554

5655%inline

57−applyEnv : (env : FEnv ffi xs) ->

58− ForeignPrimType xs env t ->

56+private

57+applyEnv : (env : FEnv ffi xs) ->

58+ ForeignPrimType xs env t ->

5959 World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t

6060applyEnv [] f = f

6161applyEnv (x@(_, _) :: xs) f = applyEnv xs (f x)

@@ -66,7 +66,8 @@ mkForeignPrim : {xs : _} -> {ffi : _} -> {env : FEnv ffi xs} -> {t : Type} ->

6666-- explicit here.

6767

6868%inline

69−foreign_prim : (f : FFI) ->

69+private

70+foreign_prim : (f : FFI) ->

7071 (fname : ffi_fn f) -> FTy f xs ty -> FEnv f xs -> ty

7172foreign_prim f fname (FRet y) env

7273 = MkIO (\w => applyEnv env mkForeignPrim w fname y)

@@ -91,25 +92,21 @@ foreign : (f : FFI) -> (fname : ffi_fn f) -> (ty : Type) ->

9192 {auto fty : FTy f [] ty} -> ty

9293foreign ffi fname ty {fty} = foreign_prim ffi fname fty []

9394

94−abstract

9595prim_io_bind : PrimIO a -> (a -> PrimIO b) -> PrimIO b

9696prim_io_bind (Prim__IO v) k = k v

9797

9898unsafePerformPrimIO : PrimIO a -> a

9999-- compiled as primitive

100100

101−abstract

102101prim_io_return : a -> PrimIO a

103102prim_io_return x = Prim__IO x

104103

105−abstract

106104io_bind : IO' l a -> (a -> IO' l b) -> IO' l b

107105io_bind (MkIO fn) k

108106 = MkIO (\w => prim_io_bind (fn w)

109107 (\ b => case k b of

110108 MkIO fkb => fkb w))

111109

112−abstract

113110io_return : a -> IO' l a

114111io_return x = MkIO (\w => prim_io_return x)

115112

@@ -131,27 +128,32 @@ prim_read : IO' l String

131128prim_read = MkIO (\w => prim_io_return (prim__readString (world w)))

132129

133130prim_write : String -> IO' l Int

134−prim_write s

131+prim_write s

135132 = MkIO (\w => prim_io_return (prim__writeString (world w) s))

136133

137134prim_fread : Ptr -> IO' l String

138135prim_fread h = MkIO (\w => prim_io_return (prim__readFile (world w) h))

139136

140137prim_fwrite : Ptr -> String -> IO' l Int

141−prim_fwrite h s

138+prim_fwrite h s

142139 = MkIO (\w => prim_io_return (prim__writeFile (world w) h s))

143140

144141--------- The C FFI

145142namespace FFI_C

143+ public export

146144 data Raw : Type -> Type where

147145 -- code generated can assume it's compiled just as 't'

148146 MkRaw : (x : t) -> Raw t

149147

150− -- Tell erasure analysis not to erase the argument

151− %used MkRaw x

148+ public export

149+ data CFnPtr : Type -> Type where

150+ MkCFnPtr : (x : t) -> CFnPtr t

151+

152152

153− ||| Supported C integer types

154− data C_IntTypes : Type -> Type where

153+ mutual

154+ ||| Supported C integer types

155+ public export

156+ data C_IntTypes : Type -> Type where

155157 C_IntChar : C_IntTypes Char

156158 C_IntNative : C_IntTypes Int

157159 C_IntBits8 : C_IntTypes Bits8

@@ -159,29 +161,44 @@ namespace FFI_C

159161 C_IntBits32 : C_IntTypes Bits32

160162 C_IntBits64 : C_IntTypes Bits64

161163

162− ||| Supported C foreign types

163− data C_Types : Type -> Type where

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+

170+ ||| Supported C foreign types

171+ public export

172+ data C_Types : Type -> Type where

164173 C_Str : C_Types String

165174 C_Float : C_Types Double

166175 C_Ptr : C_Types Ptr

167176 C_MPtr : C_Types ManagedPtr

168177 C_Unit : C_Types ()

169178 C_Any : C_Types (Raw a)

179+ C_FnT : C_FnTypes t -> C_Types (CFnPtr t)

170180 C_IntT : C_IntTypes i -> C_Types i

171181 C_CData : C_Types CData

172182

173− ||| A descriptor for the C FFI. See the constructors of `C_Types`

174− ||| and `C_IntTypes` for the concrete types that are available.

183+ ||| A descriptor for the C FFI. See the constructors of `C_Types`

184+ ||| and `C_IntTypes` for the concrete types that are available.

175185 %error_reverse

176− FFI_C : FFI

177− FFI_C = MkFFI C_Types String String

186+ public export

187+ FFI_C : FFI

188+ FFI_C = MkFFI C_Types String String

178189

179190||| 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

181192%error_reverse

193+public export

194+

182195IO : (res : Type) -> Type

183196IO = IO' FFI_C

184197

198+ -- Tell erasure analysis not to erase the argument

199+%used MkRaw x

200+%used MkCFnPtr x

201+

185202-- Cannot be relaxed as is used by type providers and they expect IO a

186203-- in the first argument.

187204run__provider : IO a -> PrimIO a

@@ -208,18 +225,22 @@ namespace IO

208225

209226-- Supported JS foreign types

210227mutual

228+ public export

211229 data JsFn : Type -> Type where

212230 MkJsFn : (x : t) -> JsFn t

213231

232+ public export

214233 data JS_IntTypes : Type -> Type where

215234 JS_IntChar : JS_IntTypes Char

216235 JS_IntNative : JS_IntTypes Int

217236

237+ public export

218238 data JS_FnTypes : Type -> Type where

219239 JS_Fn : JS_Types s -> JS_FnTypes t -> JS_FnTypes (s -> t)

220240 JS_FnIO : JS_Types t -> JS_FnTypes (IO' l t)

221241 JS_FnBase : JS_Types t -> JS_FnTypes t

222242

243+ public export

223244 data JS_Types : Type -> Type where

224245 JS_Str : JS_Types String

225246 JS_Float : JS_Types Double

@@ -237,10 +258,12 @@ mutual

237258||| JavaScript code snippets, into which the arguments are substituted

238259||| for the placeholders `%0`, `%1`, etc.

239260%error_reverse

261+public export

240262FFI_JS : FFI

241263FFI_JS = MkFFI JS_Types String String

242264

243265%error_reverse

266+public export

244267JS_IO : Type -> Type

245268JS_IO = IO' FFI_JS

246269

@@ -250,10 +273,12 @@ JS_IO = IO' FFI_JS

250273namespace FFI_Export

251274-- It's just like Data.List.Elem, but we don't need all the other stuff

252275-- that comes with it, just a proof that a data type is defined.

276+ public export

253277 data DataDefined : Type -> List (Type, s) -> s -> Type where

254278 DHere : DataDefined x ((x, t) :: xs) t

255279 DThere : DataDefined x xs t -> DataDefined x (y :: xs) t

256280

281+ public export

257282 data FFI_Base : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

258283 FFI_ExpType : {n : ffi_data f} -> (def : DataDefined t xs n) -> FFI_Base f xs t

259284 FFI_Prim : (prim : ffi_types f t) -> FFI_Base f xs t

@@ -262,6 +287,7 @@ namespace FFI_Export

262287 %used FFI_ExpType def

263288 %used FFI_Prim prim

264289

290+ public export

265291 data FFI_Exportable : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

266292 FFI_IO : (b : FFI_Base f xs t) -> FFI_Exportable f xs (IO' f t)

267293 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

272298 %used FFI_Fun a

273299 %used FFI_Ret b

274300

301+ public export

275302 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) ->

277304 (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} ->

279306 (es : FFI_Export f h xs) -> FFI_Export f h xs

280307 End : FFI_Export f h xs

281308

@@ -287,3 +314,38 @@ namespace FFI_Export

287314%used Fun es

288315%used Fun prf

289316

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

99import Prelude.Nat

1010import Prelude.Traversable

1111

12−%access public

12+%access public export

1313

1414||| A source location in an Idris file

1515record SourceLocation where

@@ -80,7 +80,7 @@ data Const = I Int | BI Integer | Fl Double | Ch Char | Str String

8080 | WorldType | TheWorld

8181%name Const c, c'

8282

83−abstract interface ReflConst (a : Type) where

83+export interface ReflConst (a : Type) where

8484 toConst : a -> Const

8585

8686implementation ReflConst Int where

@@ -110,7 +110,7 @@ implementation ReflConst Bits32 where

110110implementation ReflConst Bits64 where

111111 toConst = B64

112112

113−implicit

113+implicit export

114114reflectConstant: (ReflConst a) => a -> Const

115115reflectConstant = toConst

116116

libs/prelude/Language/Reflection/Elab.idr+54−2

@@ -16,6 +16,8 @@ import Prelude.Monad

1616import Prelude.Nat

1717import Language.Reflection

1818

19+%access public export

20+

1921data Fixity = Infixl Nat | Infixr Nat | Infix Nat | Prefix Nat

2022

2123||| Erasure annotations reflect Idris's idea of what is intended to be

@@ -100,7 +102,7 @@ record Datatype where

100102 constructors : List (TTName, List CtorArg, Raw)

101103

102104||| A reflected elaboration script.

103−abstract

105+export

104106data Elab : Type -> Type where

105107 -- obligatory control stuff

106108 Prim__PureElab : a -> Elab a

@@ -164,7 +166,7 @@ data Elab : Type -> Type where

164166-------------

165167-- Public API

166168-------------

167−%access public

169+%access public export

168170namespace Tactics

169171 implementation Functor Elab where

170172 map f t = Prim__BindElab t (\x => Prim__PureElab (f x))

@@ -186,31 +188,38 @@ namespace Tactics

186188 x >>= f = Prim__BindElab x f

187189

188190 ||| Halt elaboration with an error

191+ export

189192 fail : List ErrorReportPart -> Elab a

190193 fail err = Prim__Fail err

191194

192195 ||| Look up the lexical binding at the focused hole. Fails if no holes are present.

196+ export

193197 getEnv : Elab (List (TTName, Binder TT))

194198 getEnv = Prim__Env

195199

196200 ||| Get the name and type of the focused hole. Fails if not holes are present.

201+ export

197202 getGoal : Elab (TTName, TT)

198203 getGoal = Prim__Goal

199204

200205 ||| Get the hole queue, in order.

206+ export

201207 getHoles : Elab (List TTName)

202208 getHoles = Prim__Holes

203209

204210 ||| If the current hole contains a guess, return it. Otherwise, fail.

211+ export

205212 getGuess : Elab TT

206213 getGuess = Prim__Guess

207214

208215 ||| Look up the types of every overloading of a name.

216+ export

209217 lookupTy : TTName -> Elab (List (TTName, NameType, TT))

210218 lookupTy n = Prim__LookupTy n

211219

212220 ||| Get the type of a fully-qualified name. Fail if it doesn not

213221 ||| resolve uniquely.

222+ export

214223 lookupTyExact : TTName -> Elab (TTName, NameType, TT)

215224 lookupTyExact n = case !(lookupTy n) of

216225 [res] => return res

@@ -219,12 +228,14 @@ namespace Tactics

219228

220229 ||| Find the reflected representation of all datatypes whose names

221230 ||| are overloadings of some name.

231+ export

222232 lookupDatatype : TTName -> Elab (List Datatype)

223233 lookupDatatype n = Prim__LookupDatatype n

224234

225235 ||| Find the reflected representation of a datatype, given its

226236 ||| fully-qualified name. Fail if the name does not uniquely resolve

227237 ||| to a datatype.

238+ export

228239 lookupDatatypeExact : TTName -> Elab Datatype

229240 lookupDatatypeExact n = case !(lookupDatatype n) of

230241 [res] => return res

@@ -233,12 +244,14 @@ namespace Tactics

233244

234245 ||| Find the reflected function definition of all functions whose names

235246 ||| are overloadings of some name.

247+ export

236248 lookupFunDefn : TTName -> Elab (List (FunDefn TT))

237249 lookupFunDefn n = Prim__LookupFunDefn n

238250

239251 ||| Find the reflected function definition of a function, given its

240252 ||| fully-qualified name. Fail if the name does not uniquely resolve

241253 ||| to a function.

254+ export

242255 lookupFunDefnExact : TTName -> Elab (FunDefn TT)

243256 lookupFunDefnExact n = case !(lookupFunDefn n) of

244257 [res] => return res

@@ -246,11 +259,13 @@ namespace Tactics

246259 xs => fail [TextPart "More than one function named", NamePart n]

247260

248261 ||| Get the argument specification for each overloading of a name.

262+ export

249263 lookupArgs : TTName -> Elab (List (TTName, List FunArg, Raw))

250264 lookupArgs n = Prim__LookupArgs n

251265

252266 ||| Get the argument specification for a name. Fail if the name does

253267 ||| not uniquely resolve.

268+ export

254269 lookupArgsExact : TTName -> Elab (TTName, List FunArg, Raw)

255270 lookupArgsExact n = case !(lookupArgs n) of

256271 [res] => return res

@@ -261,6 +276,7 @@ namespace Tactics

261276 |||

262277 ||| @ env the environment within which to check the type

263278 ||| @ tm the term to check

279+ export

264280 check : (env : List (TTName, Binder TT)) -> (tm : Raw) -> Elab (TT, TT)

265281 check env tm = Prim__Check env tm

266282

@@ -269,15 +285,18 @@ namespace Tactics

269285 |||

270286 ||| **NB**: the generated name is unique _for this run of the

271287 ||| elaborator_. Do not assume that they are globally unique.

288+ export

272289 gensym : (hint : String) -> Elab TTName

273290 gensym hint = Prim__Gensym hint

274291

275292 ||| Substitute a guess into a hole.

293+ export

276294 solve : Elab ()

277295 solve = Prim__Solve

278296

279297 ||| Place a term into a hole, unifying its type. Fails if the focus

280298 ||| is not a hole.

299+ export

281300 fill : Raw -> Elab ()

282301 fill tm = Prim__Fill tm

283302

@@ -295,6 +314,7 @@ namespace Tactics

295314 ||| @ argSpec instructions for finding the arguments to the term,

296315 ||| where the Boolean states whether or not to attempt to solve

297316 ||| the argument by unification.

317+ export

298318 apply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

299319 apply tm argSpec = map snd <$> Prim__Apply tm argSpec

300320

@@ -313,6 +333,7 @@ namespace Tactics

313333 ||| where the Boolean states whether or not to attempt to solve

314334 ||| the argument by matching.

315335

336+ export

316337 matchApply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

317338 matchApply tm argSpec = map snd <$> Prim__Apply tm argSpec

318339

@@ -320,11 +341,13 @@ namespace Tactics

320341 ||| exist.

321342 |||

322343 ||| @ hole the hole to focus on

344+ export

323345 focus : (hole : TTName) -> Elab ()

324346 focus hole = Prim__Focus hole

325347

326348 ||| Send the currently-focused hole to the end of the hole queue and

327349 ||| focus on the next hole.

350+ export

328351 unfocus : TTName -> Elab ()

329352 unfocus hole = Prim__Unfocus hole

330353

@@ -336,6 +359,7 @@ namespace Tactics

336359 ||| binding, or else the scopes of the generated terms won't make

337360 ||| sense. This tactic creates a new hole of the proper form, and

338361 ||| points the old hole at it.

362+ export

339363 attack : Elab ()

340364 attack = Prim__Attack

341365

@@ -344,6 +368,7 @@ namespace Tactics

344368 ||| The new hole will be focused, and the previously-focused hole

345369 ||| will be immediately after it in the hole queue. Because this

346370 ||| tactic introduces a new binding, you may need to `attack` first.

371+ export

347372 claim : TTName -> Raw -> Elab ()

348373 claim n ty = Prim__Claim n ty

349374

@@ -352,6 +377,7 @@ namespace Tactics

352377 ||| `attack`).

353378 |||

354379 ||| @ n the name to use for the argument

380+ export

355381 intro : (n : TTName) -> Elab ()

356382 intro n = Prim__Intro (Just n)

357383

@@ -361,6 +387,7 @@ namespace Tactics

361387 |||

362388 ||| Requires that the hole be immediately under its binder (use

363389 ||| `attack` if it might not be).

390+ export

364391 intro' : Elab ()

365392 intro' = Prim__Intro Nothing

366393

@@ -369,10 +396,12 @@ namespace Tactics

369396 |||

370397 ||| Requires that the hole be immediately under its binder (use

371398 ||| `attack` if it might not be).

399+ export

372400 forall : TTName -> Raw -> Elab ()

373401 forall n ty = Prim__Forall n ty

374402

375403 ||| Convert a hole into a pattern variable.

404+ export

376405 patvar : TTName -> Elab ()

377406 patvar n = Prim__PatVar n

378407

@@ -380,6 +409,7 @@ namespace Tactics

380409 |||

381410 ||| Requires that the hole be immediately under its binder (use

382411 ||| `attack` if it might not be).

412+ export

383413 patbind : TTName -> Elab ()

384414 patbind n = Prim__PatBind n

385415

@@ -391,10 +421,12 @@ namespace Tactics

391421 ||| @ n the name to let bind

392422 ||| @ ty the type of the term to be let-bound

393423 ||| @ tm the term to be bound

424+ export

394425 letbind : (n : TTName) -> (ty, tm : Raw) -> Elab ()

395426 letbind n ty tm = Prim__LetBind n ty tm

396427

397428 ||| Normalise the goal.

429+ export

398430 compute : Elab ()

399431 compute = Prim__Compute

400432

@@ -402,12 +434,14 @@ namespace Tactics

402434 |||

403435 ||| @ env the environment in which to compute (get one of these from `getEnv`)

404436 ||| @ term the term to normalise

437+ export

405438 normalise : (env : List (TTName, Binder TT)) -> (term : TT) -> Elab TT

406439 normalise env term = Prim__Normalise env term

407440

408441 ||| Reduce a closed term to weak-head normal form

409442 |||

410443 ||| @ term the term to reduce

444+ export

411445 whnf : (term : TT) -> Elab TT

412446 whnf term = Prim__Whnf term

413447

@@ -417,6 +451,7 @@ namespace Tactics

417451 ||| @ env a lexical environment to compare the terms in (see `getEnv`)

418452 ||| @ term1 the first term to convert

419453 ||| @ term2 the second term to convert

454+ export

420455 convertsInEnv : (env : List (TTName, Binder TT)) -> (term1, term2 : TT) -> Elab ()

421456 convertsInEnv env term1 term2 = Prim__Converts env term1 term2

422457

@@ -424,14 +459,17 @@ namespace Tactics

424459 |||

425460 ||| @ term1 the first term to convert

426461 ||| @ term2 the second term to convert

462+ export

427463 converts : (term1, term2 : TT) -> Elab ()

428464 converts term1 term2 = convertsInEnv !getEnv term1 term2

429465

430466 ||| Find the source context for the elaboration script

467+ export

431468 getSourceLocation : Elab SourceLocation

432469 getSourceLocation = Prim__SourceLocation

433470

434471 ||| Attempt to solve the current goal with the source code location

472+ export

435473 sourceLocation : Elab ()

436474 sourceLocation = do loc <- getSourceLocation

437475 fill (quote loc)

@@ -442,6 +480,7 @@ namespace Tactics

442480 |||

443481 ||| The namespace is represented as a reverse-order list of strings,

444482 ||| just as in the representation of names.

483+ export

445484 currentNamespace : Elab (List String)

446485 currentNamespace = Prim__Namespace

447486

@@ -455,16 +494,19 @@ namespace Tactics

455494 ||| Because this tactic internally introduces a `let` binding, it

456495 ||| requires that the hole be immediately under its binder (use

457496 ||| `attack` if it might not be).

497+ export

458498 rewriteWith : Raw -> Elab ()

459499 rewriteWith rule = Prim__Rewrite rule

460500

461501 ||| Add a type declaration to the global context.

502+ export

462503 declareType : TyDecl -> Elab ()

463504 declareType decl = Prim__DeclareType decl

464505

465506 ||| Define a function in the global context. The function must have

466507 ||| already been declared, either in ordinary Idris code or using

467508 ||| `declareType`.

509+ export

468510 defineFunction : FunDefn Raw -> Elab ()

469511 defineFunction defun = Prim__DefineFunction defun

470512

@@ -472,12 +514,14 @@ namespace Tactics

472514 |||

473515 ||| @ ifaceName the name of the interface for which an implementation is being registered

474516 ||| @ instName the name of the definition to use in implementation search

517+ export

475518 addInstance : (ifaceName, instName : TTName) -> Elab ()

476519 addInstance ifaceName instName = Prim__AddInstance ifaceName instName

477520

478521 ||| Determine whether a name denotes an interface.

479522 |||

480523 ||| @ name a name that might denote an interface.

524+ export

481525 isTCName : (name : TTName) -> Elab Bool

482526 isTCName name = Prim__IsTCName name

483527

@@ -485,10 +529,12 @@ namespace Tactics

485529 |||

486530 ||| @ fn the name of the definition being elaborated (to prevent Idris

487531 ||| from looping)

532+ export

488533 resolveTC : (fn : TTName) -> Elab ()

489534 resolveTC fn = Prim__ResolveTC fn

490535

491536 ||| Use Idris's internal proof search.

537+ export

492538 search : Elab ()

493539 search = Prim__Search 100 []

494540

@@ -496,6 +542,7 @@ namespace Tactics

496542 |||

497543 ||| @ depth the search depth

498544 ||| @ hints additional names to try

545+ export

499546 search' : (depth : Int) -> (hints : List TTName) -> Elab ()

500547 search' depth hints = Prim__Search depth hints

501548

@@ -505,6 +552,7 @@ namespace Tactics

505552 ||| if the string is not a valid operator.

506553 |||

507554 ||| @ operator the operator string to look up

555+ export

508556 operatorFixity : (operator : String) -> Elab Fixity

509557 operatorFixity operator = Prim__Fixity operator

510558

@@ -512,6 +560,7 @@ namespace Tactics

512560 |||

513561 ||| This is intended for elaboration script developers, not for

514562 ||| end-users. Use `fail` for final scripts.

563+ export

515564 debug : Elab a

516565 debug = Prim__Debug []

517566

@@ -522,18 +571,21 @@ namespace Tactics

522571 ||| end-users. Use `fail` for final scripts.

523572 |||

524573 ||| @ msg the message to display

574+ export

525575 debugMessage : (msg : List ErrorReportPart) -> Elab a

526576 debugMessage msg = Prim__Debug msg

527577

528578 ||| Create a new top-level metavariable to solve the current hole.

529579 |||

530580 ||| @ name the name for the top-level variable

581+ export

531582 metavar : (name : TTName) -> Elab ()

532583 metavar name = Prim__Metavar name

533584

534585 ||| Recursively invoke the reflected elaborator with some goal.

535586 |||

536587 ||| The result is the final term and its type.

588+ export

537589 runElab : Raw -> Elab () -> Elab (TT, TT)

538590 runElab goal script = Prim__RecursiveElab goal script

539591

libs/prelude/Language/Reflection/Errors.idr+2

@@ -8,6 +8,8 @@ import Prelude.Bool

88import Prelude.List

99import Prelude.Maybe

1010

11+%access public export

12+

1113data Err = Msg String

1214 | InternalMsg String

1315 | CantUnify Bool TT TT Err (List (TTName, TT)) Int

libs/prelude/Prelude.idr+7−7

@@ -6,7 +6,7 @@ import public IO

66import public Prelude.Algebra

77import public Prelude.Basics

88import public Prelude.Bool

9−import public Prelude.Classes

9+import public Prelude.Interfaces

1010import public Prelude.Cast

1111import public Prelude.Nat

1212import public Prelude.List

@@ -33,7 +33,7 @@ import public Language.Reflection

3333import public Language.Reflection.Elab

3434import public Language.Reflection.Errors

3535

36−%access public

36+%access public export

3737%default total

3838

3939-- Things that can't be elsewhere for import cycle reasons

@@ -210,7 +210,7 @@ Enum Int where

210210Enum Char where

211211 toNat c = toNat (ord c)

212212 fromNat n = chr (fromNat n)

213−

213+

214214 pred c = fromNat (pred (toNat c))

215215

216216syntax "[" [start] ".." [end] "]"

@@ -264,13 +264,13 @@ while t b = do v <- t

264264------- Some error rewriting

265265

266266%language ErrorReflection

267−

267+

268268private

269269cast_part : TT -> ErrorReportPart

270270cast_part (P Bound n t) = TextPart "unknown type"

271271cast_part x = TermPart x

272−

273−%error_handler

272+

273+%error_handler export

274274cast_error : Err -> Maybe (List ErrorReportPart)

275275cast_error (CantResolve `(Cast ~x ~y))

276276 = Just [TextPart "Can't cast from",

@@ -280,8 +280,8 @@ cast_error (CantResolve `(Cast ~x ~y))

280280cast_error _ = Nothing

281281

282282%error_handler

283+export

283284num_error : Err -> Maybe (List ErrorReportPart)

284285num_error (CantResolve `(Num ~x))

285286 = Just [TermPart x, TextPart "is not a numeric type"]

286287num_error _ = Nothing

287−

libs/prelude/Prelude/Algebra.idr+1−1

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

44

55infixl 6 <+>

66

7−%access public

7+%access public export

88

99--------------------------------------------------------------------------------

1010-- A modest interface hierarchy

libs/prelude/Prelude/Applicative.idr+3−1

@@ -4,10 +4,12 @@ import Builtins

44

55import Prelude.Basics

66import Prelude.Bool

7−import Prelude.Classes

7+import Prelude.Interfaces

88import Prelude.Foldable

99import Prelude.Functor

1010

11+%access public export

12+

1113---- Applicative functors/Idioms

1214

1315infixl 2 <*>

libs/prelude/Prelude/Basics.idr+6−4

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

11module Prelude.Basics

22

33import Builtins

4−

4+

5+%access public export

6+

57Not : Type -> Type

68Not a = a -> Void

79

@@ -51,9 +53,9 @@ data Dec : Type -> Type where

5153

5254 ||| The case where the property holds

5355 ||| @ prf the proof

54− Yes : {A : Type} -> (prf : A) -> Dec A

56+ Yes : (prf : prop) -> Dec prop

5557

5658 ||| The case where the property holding would be a contradiction

57− ||| @ contra a demonstration that A would be a contradiction

58− No : {A : Type} -> (contra : A -> Void) -> Dec A

59+ ||| @ contra a demonstration that prop would be a contradiction

60+ No : (contra : prop -> Void) -> Dec prop

5961

libs/prelude/Prelude/Bits.idr+2−2

@@ -6,13 +6,13 @@ import Prelude.Basics

66import Prelude.Bool

77import Prelude.Cast

88import Prelude.Chars

9−import Prelude.Classes

9+import Prelude.Interfaces

1010import Prelude.Foldable

1111import Prelude.Nat

1212import Prelude.List

1313import Prelude.Strings

1414

15−%access public

15+%access public export

1616%default total

1717

1818b8ToString : Bits8 -> String

libs/prelude/Prelude/Bool.idr+2

@@ -4,6 +4,8 @@ import Builtins

44

55import Prelude.Uninhabited

66

7+%access public export

8+

79||| Boolean Data Type

810%case data Bool = False | True

911

libs/prelude/Prelude/Cast.idr+2

@@ -3,6 +3,8 @@ module Prelude.Cast

33import Prelude.Bool

44import public Builtins

55

6+%access public export

7+

68||| Interface for transforming an instance of a data type to another type.

79interface Cast from to where

810 ||| Perform a cast operation.

libs/prelude/Prelude/Chars.idr+3−3

@@ -2,11 +2,13 @@ module Prelude.Chars

22-- Functions operating over Chars

33

44import Prelude.Bool

5−import Prelude.Classes

5+import Prelude.Interfaces

66import Prelude.List

77import Prelude.Cast

88import Builtins

99

10+%access public export

11+

1012||| Convert the number to its ASCII equivalent.

1113chr : Int -> Char

1214chr x = if (x >= 0 && x < 0x110000)

@@ -74,5 +76,3 @@ isHexDigit x = elem (toUpper x) hexChars where

7476||| Returns true if the character is an octal digit.

7577isOctDigit : Char -> Bool

7678isOctDigit 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

22

33import Builtins

4−import Prelude.Classes

4+import Prelude.Interfaces

55

6−%access public

6+%access public export

77%default total

88

99%include C "math.h"

1010%lib C "m"

1111

1212pi : Double

13−pi = 3.14159265358979323846

13+pi = 3.14159265358979323846

1414

1515euler : Double

1616euler = 2.7182818284590452354

@@ -59,5 +59,3 @@ floor x = prim__floatFloor x

5959

6060ceiling : Double -> Double

6161ceiling x = prim__floatCeil x

62−

63−

libs/prelude/Prelude/Either.idr+3−1

@@ -4,10 +4,12 @@ import Builtins

44

55import Prelude.Basics

66import Prelude.Bool

7−import Prelude.Classes

7+import Prelude.Interfaces

88import Prelude.Maybe

99import Prelude.List

1010

11+%access public export

12+

1113||| A sum type

1214%elim data Either : (a, b : Type) -> Type where

1315 ||| One possibility of the sum, conventionally used to represent errors

libs/prelude/Prelude/File.idr+60−20

@@ -9,15 +9,15 @@ import Prelude.Strings

99import Prelude.Cast

1010import Prelude.Bool

1111import Prelude.Basics

12−import Prelude.Classes

12+import Prelude.Interfaces

1313import Prelude.Either

1414import Prelude.Show

1515import IO

1616

17−%access public

17+%access public export

1818

1919||| A file handle

20−abstract

20+export

2121data File : Type where

2222 FHandle : (p : Ptr) -> File

2323

@@ -39,7 +39,7 @@ strError err = unsafePerformIO -- yeah, yeah...

3939 (foreign FFI_C "idris_showerror" (Int -> IO String) err)

4040

4141getFileError : IO FileError

42−getFileError = do MkRaw err <- foreign FFI_C "idris_mkFileError"

42+getFileError = do MkRaw err <- foreign FFI_C "idris_mkFileError"

4343 (Ptr -> IO (Raw FileError)) prim__vm

4444 return err

4545

@@ -49,25 +49,31 @@ Show FileError where

4949 show (GenericFileError errno) = strError errno

5050

5151||| Standard input

52+export

5253stdin : File

5354stdin = FHandle prim__stdin

5455

5556||| Standard output

57+export

5658stdout : File

5759stdout = FHandle prim__stdout

5860

5961||| Standard output

62+export

6063stderr : File

6164stderr = FHandle prim__stderr

6265

66+private

6367do_ferror : Ptr -> IO Int

6468do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h

6569

70+export

6671ferror : File -> IO Bool

6772ferror (FHandle h) = do err <- do_ferror h

6873 return (not (err == 0))

6974

7075||| Call the RTS's file opening function

76+private

7177do_fopen : String -> String -> IO Ptr

7278do_fopen f m

7379 = foreign FFI_C "fileOpen" (String -> String -> IO Ptr) f m

@@ -75,6 +81,7 @@ do_fopen f m

7581||| Open a file

7682||| @ f the filename

7783||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

84+export

7885fopen : (f : String) -> (m : String) -> IO (Either FileError File)

7986fopen f m = do h <- do_fopen f m

8087 if !(nullPtr h)

@@ -83,60 +90,83 @@ fopen f m = do h <- do_fopen f m

8390 else return (Right (FHandle h))

8491

8592||| Check whether a file handle is actually a null pointer

93+export

8694validFile : File -> IO Bool

8795validFile (FHandle h) = do x <- nullPtr h

8896 return (not x)

8997

9098||| Modes for opening files

91−data Mode = Read | Write | ReadWrite

99+data Mode = Read | WriteTruncate | Append | ReadWrite | ReadWriteTruncate | ReadAppend

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+"

92112

93113||| Open a file

94114||| @ 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

96117openFile : (f : String) -> (m : Mode) -> IO (Either FileError File)

97−openFile f m = fopen f (modeStr m) where

98− modeStr Read = "r"

99− modeStr Write = "w"

100− modeStr ReadWrite = "r+"

118+openFile f m = fopen f (modeStr m)

119+

120+||| Open a file using C11 extended modes.

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"

101126

127+private

102128do_fclose : Ptr -> IO ()

103129do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h

104130

131+export

105132closeFile : File -> IO ()

106133closeFile (FHandle h) = do_fclose h

107134

135+private

108136do_fread : Ptr -> IO' l String

109137do_fread h = prim_fread h

110138

139+export

111140fgetc : File -> IO (Either FileError Char)

112141fgetc (FHandle h) = do let c = cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h)

113142 if !(ferror (FHandle h))

114143 then return (Left FileReadError)

115144 else return (Right c)

116145

146+export

117147fflush : File -> IO ()

118148fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h

119149

150+private

120151do_popen : String -> String -> IO Ptr

121152do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m

122153

154+export

123155popen : String -> Mode -> IO (Either FileError File)

124156popen f m = do ptr <- do_popen f (modeStr m)

125157 if !(nullPtr ptr)

126158 then do err <- getFileError

127159 return (Left err)

128160 else return (Right (FHandle ptr))

129− where

130− modeStr Read = "r"

131− modeStr Write = "w"

132− modeStr ReadWrite = "r+"

133161

162+export

134163pclose : File -> IO ()

135164pclose (FHandle h) = foreign FFI_C "pclose" (Ptr -> IO ()) h

136165

137166-- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String))

138167-- prim__vm h

139168

169+export

140170fread : File -> IO (Either FileError String)

141171fread (FHandle h) = do str <- do_fread h

142172 if !(ferror (FHandle h))

@@ -145,56 +175,65 @@ fread (FHandle h) = do str <- do_fread h

145175

146176||| Read a line from a file

147177||| @h a file handle which must be open for reading

178+export

148179fGetLine : (h : File) -> IO (Either FileError String)

149180fGetLine = fread

150181

151182%deprecate fread "Use fGetLine instead"

152183

184+private

153185do_fwrite : Ptr -> String -> IO (Either FileError ())

154186do_fwrite h s = do res <- prim_fwrite h s

155187 if (res /= 0)

156188 then do errno <- getErrno

157− if errno == 0

189+ if errno == 0

158190 then return (Left FileWriteError)

159191 else do err <- getFileError

160192 return (Left err)

161193 else return (Right ())

162194

195+export

163196fwrite : File -> String -> IO (Either FileError ())

164197fwrite (FHandle h) s = do_fwrite h s

165198

166199||| Write a line to a file

167200||| @h a file handle which must be open for writing

168201||| @str the line to write to the file

202+export

169203fPutStr : (h : File) -> (str : String) -> IO (Either FileError ())

170204fPutStr (FHandle h) s = do_fwrite h s

171205

206+export

172207fPutStrLn : File -> String -> IO (Either FileError ())

173208fPutStrLn (FHandle h) s = do_fwrite h (s ++ "\n")

174209

175210%deprecate fwrite "Use fPutStr instead"

176211

212+private

177213do_feof : Ptr -> IO Int

178214do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h

179215

180216||| Check if a file handle has reached the end

217+export

181218fEOF : File -> IO Bool

182219fEOF (FHandle h) = do eof <- do_feof h

183220 return (not (eof == 0))

184221

185222||| Check if a file handle has reached the end

223+export

186224feof : File -> IO Bool

187225feof = fEOF

188226

189227%deprecate feof "Use fEOF instead"

190228

229+export

191230fpoll : File -> IO Bool

192231fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h

193232 return (p > 0)

194233

195234||| Read the contents of a file into a string

196−partial -- might be reading something infinitely long like /dev/null ...

197−covering

235+partial -- might be reading something infinitely long like /dev/null ...

236+covering export

198237readFile : String -> IO (Either FileError String)

199238readFile fn = do Right h <- openFile fn Read

200239 | Left err => return (Left err)

@@ -212,10 +251,11 @@ readFile fn = do Right h <- openFile fn Read

212251 else return (Right contents)

213252

214253||| Write a string to a file

215−writeFile : (filepath : String) -> (contents : String) ->

254+export

255+writeFile : (filepath : String) -> (contents : String) ->

216256 IO (Either FileError ())

217257writeFile fn contents = do

218− Right h <- openFile fn Write | Left err => return (Left err)

219− Right () <- fPutStr h contents | Left err => return (Left err)

258+ Right h <- openFile fn WriteTruncate | Left err => return (Left err)

259+ Right () <- fPutStr h contents | Left err => return (Left err)

220260 closeFile h

221261 return (Right ())

libs/prelude/Prelude/Foldable.idr+4−5

@@ -3,15 +3,15 @@ module Prelude.Foldable

33import Builtins

44import Prelude.Bool

55import Prelude.Basics

6−import Prelude.Classes

6+import Prelude.Interfaces

77import Prelude.Algebra

88

9−%access public

9+%access public export

1010%default total

1111

1212interface Foldable (t : Type -> Type) where

13− foldr : (elt -> acc -> acc) -> acc -> t elt -> acc

14− foldl : (acc -> elt -> acc) -> acc -> t elt -> acc

13+ foldr : (elem -> acc -> acc) -> acc -> t elem -> acc

14+ foldl : (acc -> elem -> acc) -> acc -> t elem -> acc

1515 foldl f z t = foldr (flip (.) . flip f) id t z

1616

1717||| Combine each element of a structure into a monoid

@@ -54,4 +54,3 @@ sum = foldr (+) 0

5454||| Multiply together all elements of a structure

5555product : (Foldable t, Num a) => t a -> a

5656product = foldr (*) 1

57−

libs/prelude/Prelude/Functor.idr+7−5

@@ -2,21 +2,23 @@ module Prelude.Functor

22

33import Prelude.Basics

44

5+%access public export

6+

57||| Functors allow a uniform action over a parameterised type.

68||| @ f a parameterised type

79interface Functor (f : Type -> Type) where

810 ||| Apply a function across everything of type 'a' in a

911 ||| parameterised type

1012 ||| @ f the parameterised type

11− ||| @ m the function to apply

12− map : (m : a -> b) -> f a -> f b

13+ ||| @ func the function to apply

14+ map : (func : a -> b) -> f a -> f b

1315

1416infixl 4 <$>

1517

1618||| An infix alias for `map`, applying a function across everything of

1719||| type 'a' in a parameterised type

1820||| @ f the parameterised type

19−||| @ m the function to apply

20−(<$>) : Functor f => (m : a -> b) -> f a -> f b

21−m <$> x = map m x

21+||| @ func the function to apply

22+(<$>) : Functor f => (func : a -> b) -> f a -> f b

23+func <$> x = map func x

2224

libs/prelude/Prelude/Interactive.idr+18−19

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

11||| Various helper functions for creating simple interactive systems.

2−|||

2+|||

33||| These are mostly intended for helping with teaching, in that they will allow

44||| the easy creation of interactive programs without needing to teach IO

55||| or Effects first, but they also capture some common patterns of interactive

@@ -10,7 +10,7 @@ import Builtins

1010import Prelude.List

1111import Prelude.File

1212import Prelude.Bool

13−import Prelude.Classes

13+import Prelude.Interfaces

1414import Prelude.Strings

1515import Prelude.Chars

1616import Prelude.Show

@@ -21,7 +21,7 @@ import Prelude.Either

2121import Prelude.Monad

2222import IO

2323

24−%access public

24+%access public export

2525

2626---- some basic io

2727

@@ -115,19 +115,19 @@ getArgs = do n <- numArgs

115115||| @ onEOF the function to run on reaching end of file, returning a String

116116||| to output

117117partial

118−processHandle : File ->

118+processHandle : File ->

119119 (state : a) ->

120− (onRead : a -> String -> (String, a)) ->

121− (onEOF : a -> String) ->

120+ (onRead : a -> String -> (String, a)) ->

121+ (onEOF : a -> String) ->

122122 IO ()

123−processHandle h acc onRead onEOF

123+processHandle h acc onRead onEOF

124124 = if !(fEOF h)

125125 then putStr (onEOF acc)

126126 else do Right x <- fGetLine h

127127 | Left err => putStr (onEOF acc)

128128 let (out, acc') = onRead acc x

129129 putStr out

130− processHandle h acc' onRead onEOF

130+ processHandle h acc' onRead onEOF

131131

132132||| Process input from the standard input stream, while maintaining a state.

133133||| @ state the input state

@@ -136,34 +136,33 @@ processHandle h acc onRead onEOF

136136||| @ onEOI the function to run on reaching end of input, returning a String

137137||| to output

138138partial

139−processStdin : (state : a) ->

140− (onRead : a -> String -> (String, a)) ->

139+processStdin : (state : a) ->

140+ (onRead : a -> String -> (String, a)) ->

141141 (onEOI : a -> String) -> IO ()

142142processStdin = processHandle stdin

143143

144144||| A basic read-eval-print loop, maintaining a state

145145||| @ state the input state

146−||| @ prompt the prompt to show

146+||| @ prompt the prompt to show

147147||| @ onInput the function to run on reading input, returning a String to

148148||| output and a new state. Returns Nothing if the repl should exit

149149partial

150−replWith : (state : a) -> (prompt : String) ->

150+replWith : (state : a) -> (prompt : String) ->

151151 (onInput : a -> String -> Maybe (String, a)) -> IO ()

152−replWith acc prompt fn

152+replWith acc prompt fn

153153 = do putStr prompt

154154 x <- getLine

155155 case fn acc x of

156− Just (out, acc') => do putStr out

156+ Just (out, acc') => do putStr out

157157 replWith acc' prompt fn

158158 Nothing => return ()

159159

160160||| A basic read-eval-print loop

161−||| @ prompt the prompt to show

161+||| @ prompt the prompt to show

162162||| @ onInput the function to run on reading input, returning a String to

163−||| output

163+||| output

164164partial

165−repl : (prompt : String) ->

165+repl : (prompt : String) ->

166166 (onInput : String -> String) -> IO ()

167−repl prompt fn

167+repl prompt fn

168168 = 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

22

33import Builtins

44import Prelude.Basics

55import Prelude.Bool

66

7+%access public export

8+

79-- Numerical Operator Precedence

810infixl 5 ==, /=

911infixl 6 <, <=, >, >=

@@ -57,7 +59,7 @@ Eq Bool where

5759 True == False = False

5860 False == True = False

5961 False == False = True

60−

62+

6163(Eq a, Eq b) => Eq (a, b) where

6264 (==) (a, c) (b, d) = (a == b) && (c == d)

6365

@@ -357,7 +359,7 @@ divB8 x y = case y == 0 of

357359modB8 : Bits8 -> Bits8 -> Bits8

358360modB8 x y = case y == 0 of

359361 False => prim__sremB8 x y

360−

362+

361363Integral Bits8 where

362364 div = divB8

363365 mod = modB8

@@ -372,8 +374,8 @@ modB16 x y = case y == 0 of

372374 False => prim__sremB16 x y

373375

374376Integral Bits16 where

375− div = divB16

376− mod = modB16

377+ div = divB16

378+ mod = modB16

377379

378380-- ------------------------------------------------------------------ [ Bits32 ]

379381divB32 : Bits32 -> Bits32 -> Bits32

@@ -385,8 +387,8 @@ modB32 x y = case y == 0 of

385387 False => prim__sremB32 x y

386388

387389Integral Bits32 where

388− div = divB32

389− mod = modB32

390+ div = divB32

391+ mod = modB32

390392

391393-- ------------------------------------------------------------------ [ Bits64 ]

392394divB64 : Bits64 -> Bits64 -> Bits64

@@ -398,7 +400,5 @@ modB64 x y = case y == 0 of

398400 False => prim__sremB64 x y

399401

400402Integral Bits64 where

401− div = divB64

402− mod = modB64

403−

404−

403+ div = divB64

404+ mod = modB64

libs/prelude/Prelude/List.idr+5−6

@@ -5,14 +5,14 @@ import Builtins

55import Prelude.Algebra

66import Prelude.Basics

77import Prelude.Bool

8−import Prelude.Classes

8+import Prelude.Interfaces

99import Prelude.Foldable

1010import Prelude.Functor

1111import Prelude.Maybe

1212import Prelude.Uninhabited

1313import Prelude.Nat

1414

15−%access public

15+%access public export

1616%default total

1717

1818infix 5 \\

@@ -174,7 +174,7 @@ init' [] = Nothing

174174init' (x::xs) =

175175 case xs of

176176 [] => Just []

177− y::ys =>

177+ y::ys =>

178178 case init' $ y::ys of

179179 Nothing => Nothing

180180 Just j => Just $ x :: j

@@ -305,7 +305,7 @@ zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

305305||| @ z the third list

306306zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) ->

307307 (z : List c) -> List d

308−zipWith3 f _ [] (z::zs) = []

308+zipWith3 f _ [] (z::zs) = []

309309zipWith3 f _ (y::ys) [] = []

310310zipWith3 f [] (y::ys) _ = []

311311zipWith3 f (x::xs) [] _ = []

@@ -761,7 +761,7 @@ mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a

761761mergeBy order [] right = right

762762mergeBy order left [] = left

763763mergeBy order (x::xs) (y::ys) =

764− if order x y == LT

764+ if order x y == LT

765765 then x :: mergeBy order xs (y::ys)

766766 else y :: mergeBy order (x::xs) ys

767767

@@ -888,4 +888,3 @@ foldlAsFoldr f z t = foldr (flip (.) . flip f) id t z

888888foldlMatchesFoldr : (f : b -> a -> b) -> (q : b) -> (xs : List a) -> foldl f q xs = foldlAsFoldr f q xs

889889foldlMatchesFoldr f q [] = Refl

890890foldlMatchesFoldr 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

55import Prelude.Basics

66import Prelude.Bool

77import Prelude.Cast

8−import Prelude.Classes

8+import Prelude.Interfaces

99import Prelude.Foldable

1010

11−%access public

11+%access public export

1212%default total

1313

1414||| 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

88import Prelude.Basics

99import IO

1010

11−%access public

11+%access public export

1212

1313infixl 5 >>=

1414

libs/prelude/Prelude/Nat.idr+18−19

@@ -6,10 +6,10 @@ import Prelude.Algebra

66import Prelude.Basics

77import Prelude.Bool

88import Prelude.Cast

9−import Prelude.Classes

9+import Prelude.Interfaces

1010import Prelude.Uninhabited

1111

12−%access public

12+%access public export

1313%default total

1414

1515||| Natural numbers: unbounded, unsigned integers which can be pattern

@@ -224,9 +224,9 @@ record Multiplicative where

224224

225225||| A wrapper for Nat that specifies the semigroup and monad implementations that use (+)

226226record Additive where

227− constructor GetAdditive

227+ constructor GetAdditive

228228 _ : Nat

229−

229+

230230Semigroup Multiplicative where

231231 (<+>) left right = GetMultiplicative $ left' * right'

232232 where

@@ -424,7 +424,7 @@ total plusCommutative : (left : Nat) -> (right : Nat) ->

424424plusCommutative Z right = rewrite plusZeroRightNeutral right in Refl

425425plusCommutative (S left) right =

426426 let inductiveHypothesis = plusCommutative left right in

427− rewrite inductiveHypothesis in

427+ rewrite inductiveHypothesis in

428428 rewrite plusSuccRightSucc right left in Refl

429429

430430total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

@@ -450,21 +450,21 @@ total plusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->

450450plusLeftCancel Z right right' p = p

451451plusLeftCancel (S left) right right' p =

452452 let inductiveHypothesis = plusLeftCancel left right right' in

453− inductiveHypothesis (succInjective _ _ p)

453+ inductiveHypothesis (succInjective _ _ p)

454454

455455total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) ->

456456 (p : left + right = left' + right) -> left = left'

457457plusRightCancel left left' Z p = rewrite sym (plusZeroRightNeutral left) in

458458 rewrite sym (plusZeroRightNeutral left') in

459− p

459+ p

460460plusRightCancel left left' (S right) p =

461− plusRightCancel left left' right

462− (succInjective _ _ (rewrite plusSuccRightSucc left right in

461+ plusRightCancel left left' right

462+ (succInjective _ _ (rewrite plusSuccRightSucc left right in

463463 rewrite plusSuccRightSucc left' right in p))

464464

465465total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) ->

466466 (p : left + right = left) -> right = Z

467−plusLeftLeftRightZero Z right p = p

467+plusLeftLeftRightZero Z right p = p

468468plusLeftLeftRightZero (S left) right p =

469469 plusLeftLeftRightZero left right (succInjective _ _ p)

470470

@@ -481,7 +481,7 @@ total multRightSuccPlus : (left : Nat) -> (right : Nat) ->

481481multRightSuccPlus Z right = Refl

482482multRightSuccPlus (S left) right =

483483 let inductiveHypothesis = multRightSuccPlus left right in

484− rewrite inductiveHypothesis in

484+ rewrite inductiveHypothesis in

485485 rewrite plusAssociative left right (mult left right) in

486486 rewrite plusAssociative right left (mult left right) in

487487 rewrite plusCommutative right left in

@@ -493,11 +493,11 @@ multLeftSuccPlus left right = Refl

493493

494494total multCommutative : (left : Nat) -> (right : Nat) ->

495495 left * right = right * left

496−multCommutative Z right = rewrite multZeroRightZero right in Refl

496+multCommutative Z right = rewrite multZeroRightZero right in Refl

497497multCommutative (S left) right =

498498 let inductiveHypothesis = multCommutative left right in

499499 rewrite inductiveHypothesis in

500− rewrite multRightSuccPlus right left in

500+ rewrite multRightSuccPlus right left in

501501 Refl

502502

503503total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

@@ -505,7 +505,7 @@ total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right :

505505multDistributesOverPlusRight Z centre right = Refl

506506multDistributesOverPlusRight (S left) centre right =

507507 let inductiveHypothesis = multDistributesOverPlusRight left centre right in

508− rewrite inductiveHypothesis in

508+ rewrite inductiveHypothesis in

509509 rewrite plusAssociative (plus centre (mult left centre)) right (mult left right) in

510510 rewrite sym (plusAssociative centre (mult left centre) right) in

511511 rewrite plusCommutative (mult left centre) right in

@@ -527,7 +527,7 @@ total multAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

527527multAssociative Z centre right = Refl

528528multAssociative (S left) centre right =

529529 let inductiveHypothesis = multAssociative left centre right in

530− rewrite inductiveHypothesis in

530+ rewrite inductiveHypothesis in

531531 rewrite multDistributesOverPlusLeft centre (mult left centre) right in

532532 Refl

533533

@@ -619,7 +619,7 @@ powerSuccPowerLeft base exp = Refl

619619

620620total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->

621621 (power base exp) * (power base exp') = power base (exp + exp')

622−multPowerPowerPlus base Z exp' =

622+multPowerPowerPlus base Z exp' =

623623 rewrite sym (plusZeroRightNeutral (power base exp')) in Refl

624624multPowerPowerPlus base (S exp) exp' =

625625 let inductiveHypothesis = multPowerPowerPlus base exp exp' in

@@ -651,7 +651,7 @@ total powerPowerMultPower : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->

651651powerPowerMultPower base exp Z = rewrite multZeroRightZero exp in Refl

652652powerPowerMultPower base exp (S exp') =

653653 let inductiveHypothesis = powerPowerMultPower base exp exp' in

654− rewrite inductiveHypothesis in

654+ rewrite inductiveHypothesis in

655655 rewrite multRightSuccPlus exp exp' in

656656 rewrite sym (multPowerPowerPlus base exp (mult exp exp')) in

657657 Refl

@@ -664,7 +664,7 @@ total minusSuccPred : (left : Nat) -> (right : Nat) ->

664664 minus left (S right) = pred (minus left right)

665665minusSuccPred Z right = Refl

666666minusSuccPred (S left) Z =

667− rewrite minusZeroRight left in Refl

667+ rewrite minusZeroRight left in Refl

668668minusSuccPred (S left) (S right) =

669669 let inductiveHypothesis = minusSuccPred left right in

670670 rewrite inductiveHypothesis in Refl

@@ -782,4 +782,3 @@ sucMinL (S l) = cong (sucMinL l)

782782total sucMinR : (l : Nat) -> minimum l (S l) = l

783783sucMinR Z = Refl

784784sucMinR (S l) = cong (sucMinR l)

785−

libs/prelude/Prelude/Pairs.idr+15−7

@@ -2,7 +2,7 @@ module Prelude.Pairs

22

33import Builtins

44

5−%access public

5+%access public export

66%default total

77

88swap : (a, b) -> (b, a)

@@ -14,7 +14,7 @@ using (a : Type, P : a -> Type)

1414 data Exists : (P : a -> Type) -> Type where

1515 Evidence : .(x : a) -> (pf : P x) -> Exists P

1616

17− ||| Dependent pair where the second field is erased.

17+ ||| Dependent pair where the second field is erased.

1818 data Subset : (a : Type) -> (P : a -> Type) -> Type where

1919 Element : (x : a) -> .(pf : P x) -> Subset a P

2020

@@ -34,12 +34,20 @@ using (a : Type, P : a -> Type)

3434 getProof : (x : Subset a P) -> P (getWitness x)

3535 getProof (Element x pf) = pf

3636

37− namespace Sigma

38− getWitness : Sigma a P -> a

39− getWitness (x ** pf) = x

37+ namespace DPair

38+ fst : DPair a P -> a

39+ fst (x ** pf) = x

4040

41− getProof : (x : Sigma a P) -> P (getWitness x)

42− getProof (x ** pf) = pf

41+ snd : (x : DPair a P) -> P (fst x)

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`."

4351

4452 -- Polymorphic (class-based) projections have been removed

4553 -- because type-directed name disambiguation works better.

libs/prelude/Prelude/Providers.idr+3−1

@@ -4,8 +4,10 @@ import Prelude.Functor

44import Prelude.Applicative

55import Prelude.Monad

66

7+%access public export

8+

79||| Type providers must build one of these in an IO computation.

8−public

10+public export

911data Provider : (a : Type) -> Type where

1012 ||| Return a term to be spliced in

1113 ||| @ x the term to be spliced (i.e. the proof)

libs/prelude/Prelude/Show.idr+4−3

@@ -7,13 +7,15 @@ import Prelude.Bits

77import Prelude.Bool

88import Prelude.Cast

99import Prelude.Chars

10−import Prelude.Classes

10+import Prelude.Interfaces

1111import Prelude.List

1212import Prelude.Maybe

1313import Prelude.Either

1414import Prelude.Nat

1515import Prelude.Strings

1616

17+%access public export

18+

1719%default total

1820

1921||| The precedence of an Idris operator or syntactic context.

@@ -190,6 +192,5 @@ Show a => Show (Maybe a) where

190192 showPrec d (Left x) = showCon d "Left" $ showArg x

191193 showPrec d (Right x) = showCon d "Right" $ showArg x

192194

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

194196 show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"

195−

libs/prelude/Prelude/Stream.idr+7−3

@@ -9,7 +9,7 @@ import Prelude.Monad

99import Prelude.Nat

1010import Prelude.List

1111

12−%access public

12+%access public export

1313%default total

1414

1515||| An infinite stream

@@ -62,8 +62,12 @@ index : Nat -> Stream a -> a

6262index Z (x::xs) = x

6363index (S k) (x::xs) = index k xs

6464

65−||| Combine two streams element-wise using a function

66−zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c

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

70+zipWith : (f : a -> b -> c) -> (xs : Stream a) -> (ys : Stream b) -> Stream c

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

6872

6973||| 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

88import Prelude.Bool

99import Prelude.Chars

1010import Prelude.Cast

11−import Prelude.Classes

11+import Prelude.Interfaces

1212import Prelude.Either

1313import Prelude.Foldable

1414import Prelude.Functor

@@ -17,6 +17,8 @@ import Prelude.Nat

1717import Prelude.Monad

1818import Decidable.Equality

1919

20+%access public export

21+

2022partial

2123foldr1 : (a -> a -> a) -> List a -> a

2224foldr1 _ [x] = x

@@ -112,7 +114,7 @@ strTail' x p = assert_total $ prim__strTail x

112114-- we need the 'believe_me' because the operations are primitives

113115strM : (x : String) -> StrM x

114116strM x with (decEq (not (x == "")) True)

115− strM x | (Yes p) = really_believe_me $

117+ strM x | (Yes p) = really_believe_me $

116118 StrCons (assert_total (strHead' x p))

117119 (assert_total (strTail' x p))

118120 strM x | (No p) = really_believe_me StrNil

@@ -364,4 +366,3 @@ partial

364366nullStr : String -> IO Bool

365367nullStr p = do ok <- foreign FFI_C "isNull" (String -> IO Int) p

366368 return (ok /= 0)

367−

libs/prelude/Prelude/Traversable.idr+2

@@ -7,6 +7,8 @@ import Prelude.Applicative

77import Prelude.Foldable

88import Prelude.Functor

99

10+%access public export

11+

1012traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()

1113traverse_ f = foldr ((*>) . f) (pure ())

1214

libs/prelude/Prelude/Uninhabited.idr+2

@@ -5,6 +5,8 @@ module Prelude.Uninhabited

55

66import Builtins

77

8+%access public export

9+

810||| A canonical proof that some type is empty

911interface Uninhabited t where

1012 ||| 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"

44modules = Builtins, Prelude, IO,

55

66 Prelude.Algebra, Prelude.Basics, Prelude.Bool, Prelude.Cast,

7− Prelude.Classes, Prelude.Nat, Prelude.List,

7+ Prelude.Interfaces, Prelude.Nat, Prelude.List,

88 Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either,

99 Prelude.Strings, Prelude.Chars, Prelude.Show, Prelude.Functor,

1010 Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,

@@ -14,4 +14,3 @@ modules = Builtins, Prelude, IO,

1414 Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab,

1515

1616 Decidable.Equality

17−

libs/pruviloj/Pruviloj/Core.idr+2

@@ -5,6 +5,8 @@ module Pruviloj.Core

55

66import Language.Reflection.Utils

77

8+%access public export

9+

810||| Run something for effects, throwing away the return value

911ignore : Functor f => f a -> f ()

1012ignore x = map (const ()) x

libs/pruviloj/Pruviloj/Derive/DecEq.idr+1−1

@@ -133,7 +133,7 @@ mkRhs fn fam k =

133133||| equality.

134134|||

135135||| @ fn the name of the function whose type has been declared

136−abstract partial -- because of mkRhs

136+export partial -- because of mkRhs

137137deriveDecEq : (fn : TTName) -> Elab ()

138138deriveDecEq fn =

139139 do (_, Ref, sig') <- lookupTyExact fn

libs/pruviloj/Pruviloj/Derive/Eliminators.idr+1−1

@@ -248,7 +248,7 @@ getElimClauses info elimn ctors =

248248 in traverse (\(i, con) => getElimClause info elimn methodCount con i)

249249 (enumerate ctors)

250250

251−abstract

251+export

252252deriveElim : (tyn, elimn : TTName) -> Elab ()

253253deriveElim tyn elimn =

254254 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

6767

6868||| Solve a goal of the form `(C1 x1 x2 ... xn = C2 x1 x2 ... xn) ->

6969||| Void` for disjoint constructors `C1` and `C2`.

70−public covering

70+public export covering

7171disjoint : Elab ()

7272disjoint =

7373 do compute

libs/pruviloj/Pruviloj/Induction.idr+1−1

@@ -125,7 +125,7 @@ makeMotive info sub subjTy goal =

125125

126126||| Perform induction on some expression to solve the current

127127||| goal. Return a list of new holes to be solved.

128−public

128+public export

129129induction : Raw -> Elab (List TTName)

130130induction subj =

131131 do g <- goalType

libs/pruviloj/Pruviloj/Injective.idr+1−1

@@ -92,7 +92,7 @@ countBinders _ = Z

9292|||

9393||| @ tm the equality to exploit injectivity on

9494||| @ n the name at which to bind the result

95−covering public

95+covering public export

9696injective : (tm : Raw) -> (n : TTName) -> Elab ()

9797injective tm n =

9898 do (_, ty) <- check !getEnv tm

libs/pruviloj/Pruviloj/Internals.idr+2

@@ -7,6 +7,8 @@ import Pruviloj.Renamers

77

88import Data.Vect

99

10+%access public export

11+

1012||| Get the name of a reflected type constructor argument.

1113tyConArgName : TyConArg -> TTName

1214tyConArgName (TyConParameter a) = name a

libs/pruviloj/Pruviloj/Internals/TyConInfo.idr+1−1

@@ -6,7 +6,7 @@ import Pruviloj.Renamers

66

77import Language.Reflection.Utils

88

9−

9+%access public export

1010

1111||| A representation of a type constructor in which all argument names

1212||| are made unique and they are separated into params and then

libs/pruviloj/Pruviloj/Renamers.idr+2

@@ -2,6 +2,8 @@ module Pruviloj.Renamers

22

33import Language.Reflection.Utils

44

5+%access public export

6+

57||| A renamer keeps track of names to be substituted

68Renamer : Type

79Renamer = TTName -> Maybe TTName

rts/idris_bitstring.c+35

@@ -822,3 +822,38 @@ VAL idris_b64T32(VM *vm, VAL a) {

822822 return cl;

823823}

824824

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);

126126VAL idris_b64T16(VM *vm, VAL a);

127127VAL idris_b64T32(VM *vm, VAL a);

128128

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+

129139#endif

rts/idris_rts.c+25−5

@@ -80,6 +80,14 @@ VM* idris_vm() {

8080 return vm;

8181}

8282

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+

8391void close_vm(VM* vm) {

8492 terminate(vm);

8593}

@@ -116,7 +124,7 @@ Stats terminate(VM* vm) {

116124 pthread_mutex_destroy(&(vm -> inbox_block));

117125 pthread_cond_destroy(&(vm -> inbox_waiting));

118126#endif

119− // free(vm);

127+ // free(vm);

120128 // Set the VM as inactive, so that if any message gets sent to it

121129 // it will not get there, rather than crash the entire system.

122130 // (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) {

444452 *(((uint8_t*)ptr) + offset) = data;

445453}

446454

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+

447467void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {

448468 memmove(dest + dest_offset, src + src_offset, size);

449469}

@@ -819,12 +839,12 @@ int idris_sendMessage(VM* sender, VM* dest, VAL msg) {

819839 }

820840

821841 pthread_mutex_lock(&(dest->inbox_lock));

822−

842+

823843 if (dest->inbox_write >= dest->inbox_end) {

824844 // FIXME: This is obviously bad in the long run. This should

825845 // either block, make the inbox bigger, or return an error code,

826846 // or possibly make it user configurable

827− fprintf(stderr, "Inbox full");

847+ fprintf(stderr, "Inbox full");

828848 exit(-1);

829849 }

830850

@@ -850,7 +870,7 @@ VM* idris_checkMessages(VM* vm) {

850870

851871VM* idris_checkMessagesFrom(VM* vm, VM* sender) {

852872 Msg* msg;

853−

873+

854874 for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {

855875 if (sender == NULL || msg->sender == sender) {

856876 return msg->sender;

@@ -884,7 +904,7 @@ VM* idris_checkMessagesTimeout(VM* vm, int delay) {

884904

885905Msg* idris_getMessageFrom(VM* vm, VM* sender) {

886906 Msg* msg;

887−

907+

888908 for (msg = vm->inbox; msg < vm->inbox_write; ++msg) {

889909 if (sender == NULL || msg->sender == sender) {

890910 return msg;

rts/idris_rts.h+7−1

@@ -144,6 +144,9 @@ CData cdata_manage(void * data, CDataFinalizer * finalizer);

144144// Create a new VM

145145VM* init_vm(int stack_size, size_t heap_size,

146146 int max_threads);

147+

148+// Get the VM for the current thread

149+VM* get_vm(void);

147150// Initialise thread-local data for this VM

148151void init_threaddata(VM *vm);

149152// Clean up a VM once it's no longer needed

@@ -336,9 +339,12 @@ VAL idris_castStrFloat(VM* vm, VAL i);

336339

337340// Raw memory manipulation

338341void 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);

339343uint8_t idris_peek(void* ptr, i_int offset);

340344void 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);

342348

343349// String primitives

344350VAL idris_concat(VM* vm, VAL l, VAL r);

samples/tutorial/interp.idr+1−1

@@ -33,7 +33,7 @@ using (G : Vect n Ty)

3333 Expr G c

3434 If : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

3535

36− interp : Env G -> [static] (e : Expr G t) -> interpTy t

36+ interp : Env G -> %static (e : Expr G t) -> interpTy t

3737 interp env (Var i) = lookup i env

3838 interp env (Val x) = x

3939 interp env (Lam sc) = \x => interp (x :: env) sc

src/IRTS/CodegenC.hs+184−24

@@ -13,7 +13,7 @@ import Util.System

1313import Numeric

1414import Data.Char

1515import Data.Bits

16−import Data.List (intercalate)

16+import Data.List (intercalate, nubBy)

1717import System.Process

1818import System.Exit

1919import System.IO

@@ -48,19 +48,20 @@ codegenC' :: [(Name, SDecl)] ->

4848 [String] -> -- extra object files

4949 [String] -> -- extra compiler flags (libraries)

5050 [String] -> -- extra compiler flags (anything)

51− [ExportIFace] ->

51+ [ExportIFace] ->

5252 Bool -> -- interfaces too (so make a .o instead)

5353 DbgLevel ->

5454 IO ()

5555codegenC' defs out exec incs objs libs flags exports iface dbg

5656 = do -- print defs

5757 let bc = map toBC defs

58+ let wrappers = genWrappers bc

5859 let h = concatMap toDecl (map fst bc)

5960 let cc = concatMap (uncurry toC) bc

6061 let hi = concatMap ifaceC (concatMap getExp exports)

6162 d <- getDataDir

6263 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 ++

6465 (if (exec == Executable) then mprog else hi)

6566 case exec of

6667 MavenProject -> putStrLn ("FAILURE: output type not supported")

@@ -81,10 +82,10 @@ codegenC' defs out exec incs objs libs flags exports iface dbg

8182 "-I."] ++ objs ++ envFlags ++

8283 (if (exec == Executable) then [] else ["-c"]) ++

8384 [tmpn] ++

84− (if not iface then concatMap words libFlags else []) ++

85− concatMap words incFlags ++

86− (if not iface then concatMap words libs else []) ++

87− concatMap words flags ++

85+ (if not iface then libFlags else []) ++

86+ incFlags ++

87+ (if not iface then libs else []) ++

88+ flags ++

8889 ["-o", out]

8990-- putStrLn (show args)

9091 exit <- rawSystem comp args

@@ -153,7 +154,7 @@ showCStr s = '"' : foldr ((++) . showChar) "\"" s

153154 headHex h (length bytes) : map toHex bytes

154155 where

155156 split acc 0 = acc

156− split acc x = let xbits = x .&. 0x3f

157+ split acc x = let xbits = x .&. 0x3f

157158 xrest = shiftR x 6 in

158159 split (xbits : acc) xrest

159160

@@ -185,7 +186,7 @@ bcc i (ASSIGNCONST l c)

185186 -- if it's a type constant, we won't use it, but equally it shouldn't

186187 -- report an error. These might creep into generated for various reasons

187188 -- (especially if erasure is disabled).

188− mkConst c | isTypeConst c = "MKINT(42424242)"

189+ mkConst c | isTypeConst c = "MKINT(42424242)"

189190 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"

190191

191192bcc 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"

317318bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

318319bcc i STOREOLD = indent i ++ "STOREOLD;\n"

319320bcc 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"

320332bcc i (FOREIGNCALL l rty (FStr fn) args)

321333 = indent i ++

322334 c_irts (toFType rty) (creg l ++ " = ")

323335 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

324− where fcall (t, arg) = irts_c (toFType t) (creg arg)

325336bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

326337bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

327338-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"

328339

340+fcall (t, arg) = irts_c (toFType t) (creg arg)

329341-- Deconstruct the Foreign type in the defunctionalised expression and build

330342-- a foreign type description for c_irts and irts_c

331−toAType (FCon i)

343+toAType (FCon i)

332344 | i == sUN "C_IntChar" = ATInt ITChar

333345 | i == sUN "C_IntNative" = ATInt ITNative

334346 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)

@@ -337,19 +349,27 @@ toAType (FCon i)

337349 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)

338350toAType t = error (show t ++ " not defined in toAType")

339351

340−toFType (FCon c)

352+toFType (FCon c)

341353 | c == sUN "C_Str" = FString

342354 | c == sUN "C_Float" = FArith ATFloat

343355 | c == sUN "C_Ptr" = FPtr

344356 | c == sUN "C_MPtr" = FManagedPtr

345357 | c == sUN "C_CData" = FCData

346358 | c == sUN "C_Unit" = FUnit

347−toFType (FApp c [_,ity])

359+toFType (FApp c [_,ity])

348360 | c == sUN "C_IntT" = FArith (toAType ity)

349−toFType (FApp c [_])

361+ | c == sUN "C_FnT" = toFunType ity

362+toFType (FApp c [_])

350363 | c == sUN "C_Any" = FAny

351364toFType t = FAny

352365

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+

353373c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

354374c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x

355375c_irts (FArith (ATInt (ITFixed ity))) l x

@@ -361,6 +381,8 @@ c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"

361381c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

362382c_irts FCData l x = l ++ "MKCDATA(vm, " ++ x ++ ")"

363383c_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"

364386

365387irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"

366388irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x

@@ -373,6 +395,14 @@ irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"

373395irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

374396irts_c FCData x = "GETCDATA(" ++ x ++ ")"

375397irts_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 ++ ")"

376406

377407bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

378408

@@ -554,7 +584,7 @@ doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

554584doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

555585

556586doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"

557−doOp v LWriteStr [_,s]

587+doOp v LWriteStr [_,s]

558588 = v ++ "MKINT((i_int)(idris_writeStr(stdout"

559589 ++ ",GETSTR("

560590 ++ creg s ++ "))))"

@@ -580,10 +610,10 @@ doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"

580610doOp v LNoOp args = v ++ creg (last args)

581611

582612-- Pointer primitives (declared as %extern in Builtins.idr)

583−doOp v (LExternal rf) [_,x]

613+doOp v (LExternal rf) [_,x]

584614 | rf == sUN "prim__readFile"

585615 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

586−doOp v (LExternal wf) [_,x,s]

616+doOp v (LExternal wf) [_,x,s]

587617 | wf == sUN "prim__writeFile"

588618 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x

589619 ++ "),GETSTR("

@@ -594,15 +624,38 @@ doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"

594624doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"

595625

596626doOp 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"

598628 = 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"

600630 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"

601631doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"

602632 = 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 ++"))"

604656doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"

605657

658+

606659flUnOp :: String -> String -> String

607660flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

608661

@@ -613,7 +666,7 @@ flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

613666ifaceC :: Export -> String

614667ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

615668ifaceC (ExportFun n cn ret args)

616− = ctype ret ++ " " ++ cdesc cn ++

669+ = ctype ret ++ " " ++ cdesc cn ++

617670 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"

618671 ++ mkBody n (zip argNames args) ret ++ "}\n\n"

619672 where showArgs [] = ""

@@ -626,7 +679,7 @@ mkBody n as t = indent 1 ++ "INITFRAME;\n" ++

626679 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++

627680 push 0 as ++ call n ++ retval t

628681 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)

630683 ("TOP(" ++ show i ++ ") = ") n

631684 ++ ";\n" ++ push (i + 1) ts

632685

@@ -692,7 +745,7 @@ hdr_guard x = "__" ++ map hchar x

692745hdr_export :: Export -> String

693746hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

694747hdr_export (ExportFun n cn ret args)

695− = ctype ret ++ " " ++ cdesc cn ++

748+ = ctype ret ++ " " ++ cdesc cn ++

696749 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"

697750 where showArgs [] = ""

698751 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++

@@ -700,5 +753,112 @@ hdr_export (ExportFun n cn ret args)

700753

701754 argNames = zipWith (++) (repeat "arg") (map show [0..])

702755

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

703838

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

33import Idris.Core.TT

44import IRTS.Simplified

55import IRTS.Defunctionalise

6−import IRTS.Lang

7−

8−import Control.Exception

9−import Data.Word

10−import System.Environment

116

127data DbgLevel = NONE | DEBUG | TRACE deriving Eq

138data OutputType = Raw | Object | Executable | MavenProject deriving (Eq, Show)

149

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−

2010-- Everything which might be needed in a code generator - a CG can choose which

2111-- level of Decls to generate code from (simplified, defunctionalised or merely

2212-- 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)

462462 = do let l' = toFDesc l

463463 r' <- irTerm vs env r

464464 return (l', r')

465− splitArg _ = ifail "Badly formed foreign function call"

465+ splitArg _ = ifail $ "Badly formed foreign function call"

466466

467467 toFDesc (Constant (Str str)) = FStr str

468468 toFDesc tm

src/IRTS/System.hs+9−25

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

11{-# LANGUAGE CPP #-}

22module IRTS.System(getDataFileName, getDataDir, getTargetDir,getCC,getLibFlags,getIdrisLibDir,

3− getIncFlags, getEnvFlags, getMvn,getExecutablePom, version) where

3+ getIncFlags, getEnvFlags, version) where

44

5−import Util.System

65import Data.List.Split

76

87import Control.Applicative ((<$>))

@@ -17,28 +16,18 @@ import Paths_idris (version)

1716import Paths_idris

1817#endif

1918

19+overrideDataDirWith :: String -> IO FilePath

20+overrideDataDirWith envVar = do envValue <- lookupEnv envVar

21+ maybe getDataDir return envValue

22+

2023getCC :: IO String

21−getCC = fromMaybe "gcc" <$> environment "IDRIS_CC"

24+getCC = fromMaybe "gcc" <$> lookupEnv "IDRIS_CC"

2225

2326getEnvFlags :: IO [String]

24−getEnvFlags = maybe [] (splitOn " ") <$> environment "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)

27+getEnvFlags = maybe [] (splitOn " ") <$> lookupEnv "IDRIS_CFLAGS"

3928

4029getTargetDir :: IO String

41−getTargetDir = environment "TARGET" >>= maybe getDataDir return

30+getTargetDir = overrideDataDirWith "TARGET"

4231

4332#if defined(FREEBSD) || defined(DRAGONFLY)

4433extraLib = ["-L/usr/local/lib"]

@@ -56,9 +45,7 @@ getLibFlags = do dir <- getDataDir

5645 return $ ["-L" ++ (dir </> "rts"),

5746 "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"]

5847

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"

6249

6350#if defined(FREEBSD) || defined(DRAGONFLY)

6451extraInclude = ["-I/usr/local/include"]

@@ -67,6 +54,3 @@ extraInclude = []

6754#endif

6855getIncFlags = do dir <- getDataDir

6956 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 })

118118ist_callgraph :: Name -> Field IState CGInfo

119119ist_callgraph n =

120120 maybe_default CGInfo

121− { argsdef = [], calls = [], scg = []

122− , argsused = [], usedpos = []

121+ { calls = [], scg = [], usedpos = []

123122 }

124123 . ctxt_lookup n

125124 . Field idris_callgraph (\v ist -> ist{ idris_callgraph = v })

126125

127−-- some fields of the CGInfo record

128126cg_usedpos :: Field CGInfo [(Int, [UsageReason])]

129127cg_usedpos = Field usedpos (\v cg -> cg{ usedpos = v })

130128

131−

132129-- Commandline flags

133130--------------------

134131

src/Idris/AbsSyntax.hs+99−46

@@ -77,7 +77,7 @@ addDyLib libs = do i <- getIState

7777 (\_ -> return Nothing)) $ libs

7878 case msum handle of

7979 Nothing -> return (Right $ "Could not load dynamic alternatives \"" ++

80− concat (intersperse "," libs) ++ "\"")

80+ intercalate "," libs ++ "\"")

8181 Just x -> do putIState $ i { idris_dynamic_libs = x:ls }

8282 return (Left x)

8383 where findDyLib :: [DynamicLib] -> String -> Maybe DynamicLib

@@ -96,6 +96,33 @@ addAutoImport fp = do i <- getIState

9696 put (i { idris_options = opts { opt_autoImport =

9797 fp : opt_autoImport opts } } )

9898

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+

99126addHdr :: Codegen -> String -> Idris ()

100127addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i }

101128

@@ -180,6 +207,11 @@ setAccessibility n a

180207 let ctxt = setAccess n a (tt_ctxt i)

181208 putIState $ i { tt_ctxt = ctxt }

182209

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+

183215setTotality :: Name -> Totality -> Idris ()

184216setTotality n a

185217 = do i <- getIState

@@ -203,8 +235,7 @@ getCoercionsTo i ty =

203235 findCoercions t (n : ns) =

204236 let ps = case lookupTy n (tt_ctxt i) of

205237 [ty'] -> case unApply (getRetTy (normalise (tt_ctxt i) [] ty')) of

206− (t', _) ->

207− if t == t' then [n] else []

238+ (t', _) -> [n | t == t']

208239 _ -> [] in

209240 ps ++ findCoercions t ns

210241

@@ -213,6 +244,14 @@ addToCG n cg

213244 = do i <- getIState

214245 putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) }

215246

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+

216255addTyInferred :: Name -> Idris ()

217256addTyInferred n

218257 = do i <- getIState

@@ -228,7 +267,7 @@ addTyInfConstraints fc ts = do logLvl 2 $ "TI missing: " ++ show ts

228267 findMVApps x y

229268 = do let (fx, argsx) = unApply x

230269 let (fy, argsy) = unApply y

231− if (not (fx == fy))

270+ if (fx /= fy)

232271 then do

233272 tryAddMV fx y

234273 tryAddMV fy x

@@ -309,7 +348,7 @@ allNames :: [Name] -> Name -> Idris [Name]

309348allNames ns n | n `elem` ns = return []

310349allNames ns n = do i <- getIState

311350 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')

313352 return (nub (n : concat more))

314353 _ -> return [n]

315354

@@ -341,11 +380,6 @@ getNameHints i n =

341380 [ns] -> ns

342381 _ -> []

343382

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−

349383addDeprecated :: Name -> String -> Idris ()

350384addDeprecated n reason = do i <- getIState

351385 putIState $ i { idris_deprecated = addDef n reason (idris_deprecated i) }

@@ -439,7 +473,8 @@ addIBC ibc@(IBCDef n)

439473addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }

440474

441475clearIBC :: Idris ()

442−clearIBC = do i <- getIState; putIState $ i { ibc_write = [] }

476+clearIBC = do i <- getIState; putIState $ i { ibc_write = [],

477+ idris_inmodule = S.empty }

443478

444479resetNameIdx :: Idris ()

445480resetNameIdx = do i <- getIState

@@ -738,6 +773,16 @@ logLevel :: Idris Int

738773logLevel = do i <- getIState

739774 return (opt_logLevel (idris_options i))

740775

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+

741786setErrContext :: Bool -> Idris ()

742787setErrContext t = do i <- getIState

743788 let opts = idris_options i

@@ -1024,7 +1069,7 @@ logLvlCats cs l str = do

10241069 runIO . hPutStrLn h $ convSExp "log" good n

10251070 where

10261071 inCat :: [LogCat] -> [LogCat] -> Bool

1027− inCat cs cats = or $ map (\x -> elem x cats) cs

1072+ inCat cs cats = any (`elem` cats) cs

10281073

10291074cmdOptType :: Opt -> Idris Bool

10301075cmdOptType x = do i <- getIState

@@ -1101,25 +1146,25 @@ expandParams dec ps ns infs tm = en 0 tm

11011146 | n `nselem` ns = PQuote (Var (dec n))

11021147 en 0 (PApp fc (PInferRef fc' hl n) as)

11031148 | 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))

11051150 en 0 (PApp fc (PRef fc' hl n) as)

11061151 | 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))

11081153 | 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))

11101155 en 0 (PAppBind fc (PRef fc' hl n) as)

11111156 | 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))

11131158 | 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))

11151160 en 0 (PRef fc hl n)

11161161 | 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)

11181163 | 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)

11201165 en 0 (PInferRef fc hl n)

11211166 | 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)

11231168 en 0 (PApp fc f as) = PApp fc (en 0 f) (map (fmap (en 0)) as)

11241169 en 0 (PAppBind fc f as) = PAppBind fc (en 0 f) (map (fmap (en 0)) as)

11251170 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)

11911236 removeBound lhs ns = ns \\ nub (bnames lhs)

11921237

11931238 bnames (PRef _ _ n) = [n]

1194− bnames (PApp _ _ args) = concatMap bnames (map getTm args)

1239+ bnames (PApp _ _ args) = concatMap (bnames . getTm) args

11951240 bnames (PPair _ _ _ l r) = bnames l ++ bnames r

11961241 bnames (PDPair _ _ _ l Placeholder r) = bnames l ++ bnames r

11971242 bnames _ = []

@@ -1227,10 +1272,10 @@ expandParamsD rhs ist dec ps ns (PClass doc info f cs n nfc params pDocs fds dec

12271272 (map (expandParamsD rhs ist dec ps ns) decls)

12281273 cn

12291274 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)

12311276 = PInstance doc argDocs info f

12321277 (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)

1233− n

1278+ acc n

12341279 nfc

12351280 (map (expandParams dec ps ns []) params)

12361281 (expandParams dec ps ns [] ty)

@@ -1258,9 +1303,9 @@ getPriority i tm = 1 -- pri tm

12581303 pri (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))

12591304 pri (PTrue _ _) = 0

12601305 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)))

1262− pri (PAppBind _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

1263− pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as)))

1306+ pri (PApp _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))

1307+ pri (PAppBind _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))

1308+ pri (PCase _ f as) = max 1 (max (pri f) (foldr (max . pri . snd) 0 as))

12641309 pri (PTyped l r) = pri l

12651310 pri (PPair _ _ _ l r) = max 1 (max (pri l) (pri r))

12661311 pri (PDPair _ _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

@@ -1277,11 +1322,11 @@ addStatics n tm ptm =

12771322 let paramnames

12781323 = nub $ case lookupCtxtExact n (idris_fninfo ist) of

12791324 Just p -> getNamesFrom 0 (fn_params p) tm ++

1280− concatMap (getParamNames ist) (map snd statics)

1281− _ -> concatMap (getParamNames ist) (map snd statics)

1325+ concatMap (getParamNames ist . snd) statics

1326+ _ -> concatMap (getParamNames ist . snd) statics

12821327

1283− let stnames = nub $ concatMap freeArgNames (map snd statics)

1284− let dnames = (nub $ concatMap freeArgNames (map snd dynamics))

1328+ let stnames = nub $ concatMap (freeArgNames . snd) statics

1329+ let dnames = (nub $ concatMap (freeArgNames . snd) dynamics)

12851330 \\ paramnames

12861331 -- also get the arguments which are 'uniquely inferrable' from

12871332 -- statics (see sec 4.2 of "Scrapping Your Inefficient Engine")

@@ -1290,7 +1335,7 @@ addStatics n tm ptm =

12901335 filter (\x -> not (elem x dnames)) stnames

12911336 let stpos = staticList statics' tm

12921337 i <- getIState

1293− when (not (null statics)) $

1338+ unless (null statics) $

12941339 logLvl 3 $ "Statics for " ++ show n ++ " " ++ show tm ++ "\n"

12951340 ++ showTmImpls ptm ++ "\n"

12961341 ++ show statics ++ "\n" ++ show dynamics

@@ -1376,7 +1421,7 @@ addUsingConstraints syn fc t

13761421 | otherwise = doAdd cs ns t

13771422

13781423 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)

13801425

13811426 getConstraints (PPi (Constraint _ _) _ _ c sc)

13821427 = getcapp c ++ getConstraints sc

@@ -1395,10 +1440,14 @@ addUsingConstraints syn fc t

13951440addUsingImpls :: SyntaxInfo -> Name -> FC -> PTerm -> Idris PTerm

13961441addUsingImpls syn n fc t

13971442 = do ist <- getIState

1398− let ns = implicitNamesIn (map iname uimpls) ist t

1443+ autoimpl <- getAutoImpls

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+

13991448 let badnames = filter (\n -> not (implicitable n) &&

14001449 n `notElem` (map iname uimpls)) ns

1401− when (not (null badnames)) $

1450+ unless (null badnames) $

14021451 throwError (At fc (Elaborating "type of " n Nothing

14031452 (NoSuchVariable (head badnames))))

14041453 let cs = getArgnames t -- get already bound names

@@ -1481,15 +1530,19 @@ implicit info syn n ptm = implicit' info syn [] n ptm

14811530implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

14821531implicit' info syn ignore n ptm

14831532 = do i <- getIState

1484− let (tm', impdata) = implicitise syn ignore i ptm

1485− defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

1486−-- let (tm'', spos) = findStatics i tm'

1487− putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1488− addIBC (IBCImp n)

1489− logLvl 5 ("Implicit " ++ show n ++ " " ++ show impdata)

1490−-- i <- get

1491−-- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1492− return tm'

1533+ auto <- getAutoImpls

1534+ if not auto

1535+ then return ptm

1536+ else do

1537+ let (tm', impdata) = implicitise syn ignore i ptm

1538+ defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

1539+ -- let (tm'', spos) = findStatics i tm'

1540+ putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1541+ addIBC (IBCImp n)

1542+ logLvl 5 ("Implicit " ++ show n ++ " " ++ show impdata)

1543+ -- i <- get

1544+ -- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1545+ return tm'

14931546 where

14941547 -- Detect unknown names in default arguments and throw error if found.

14951548 defaultArgCheck :: [Name] -> [PArg] -> Idris ()

@@ -1534,12 +1587,12 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

15341587 -- Find names in argument position in a type, suitable for implicit

15351588 -- binding

15361589 -- 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

15381591 implNamesIn uv t = namesIn uv ist t

15391592

1540− imps top env (PApp _ f as)

1593+ imps top env ty@(PApp _ f as)

15411594 = do (decls, ns) <- get

1542− let isn = concatMap (namesIn uvars ist) (map getTm as)

1595+ let isn = nub (implNamesIn uvars ty)

15431596 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

15441597 imps top env (PPi (Imp l _ _ _) n _ ty sc)

15451598 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

src/Idris/AbsSyntaxTree.hs+468−460

@@ -94,6 +94,7 @@ data IOption = IOption {

9494 , opt_printdepth :: Maybe Int

9595 , opt_evaltypes :: Bool -- ^ normalise types in :t

9696 , opt_desugarnats :: Bool

97+ , opt_autoimpls :: Bool

9798 } deriving (Show, Eq)

9899

99100defaultOpts = IOption { opt_logLevel = 0

@@ -121,6 +122,7 @@ defaultOpts = IOption { opt_logLevel = 0

121122 , opt_printdepth = Just 5000

122123 , opt_evaltypes = True

123124 , opt_desugarnats = False

125+ , opt_autoimpls = True

124126 }

125127

126128data PPOption = PPOption {

@@ -194,7 +196,6 @@ data IState = IState {

194196 -- ^ list of lhs/rhs, and a list of missing clauses

195197 idris_flags :: Ctxt [FnOpt],

196198 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

197− idris_calledgraph :: Ctxt [Name],

198199 idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]),

199200 idris_moduledocs :: Ctxt (Docstring DocTerm),

200201 -- ^ module documentation is saved in a special MN so the context

@@ -235,7 +236,7 @@ data IState = IState {

235236 brace_stack :: [Maybe Int],

236237 lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

237238 idris_parsedSpan :: Maybe FC,

238− hide_list :: [(Name, Maybe Accessibility)],

239+ hide_list :: Ctxt Accessibility,

239240 default_access :: Accessibility,

240241 default_total :: Bool,

241242 ibc_write :: [IBCWrite],

@@ -262,7 +263,9 @@ data IState = IState {

262263 idris_exports :: [Name], -- ^ Functions with ExportList

263264 idris_highlightedRegions :: [(FC, OutputAnnotation)], -- ^ Highlighting information to output

264265 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)

266269 }

267270

268271-- Required for parsers library, and therefore trifecta

@@ -279,11 +282,10 @@ deriving instance NFData SizeChange

279282type SCGEntry = (Name, [Maybe (Int, SizeChange)])

280283type UsageReason = (Name, Int) -- fn_name, its_arg_number

281284

282−data CGInfo = CGInfo { argsdef :: [Name],

283− calls :: [(Name, [[Name]])],

285+data CGInfo = CGInfo { calls :: [Name],

284286 scg :: [SCGEntry],

285− argsused :: [Name],

286− usedpos :: [(Int, [UsageReason])] }

287+ usedpos :: [(Int, [UsageReason])]

288+ }

287289 deriving Show

288290{-!

289291deriving instance Binary CGInfo

@@ -348,12 +350,13 @@ idrisInit = IState initContext S.empty []

348350 emptyContext emptyContext emptyContext emptyContext

349351 emptyContext emptyContext emptyContext emptyContext

350352 emptyContext emptyContext emptyContext emptyContext

351− emptyContext emptyContext

353+ emptyContext

352354 [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] []

353− [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []

355+ [] [] Nothing [] Nothing [] [] Nothing Nothing emptyContext Hidden False [] Nothing [] []

354356 (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty

355357 AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []

356− emptyContext

358+ emptyContext S.empty M.empty

359+

357360

358361-- | The monad for the main REPL - reading and processing files and updating

359362-- global state (hence the IO inner monad).

@@ -631,13 +634,17 @@ is_scoped :: Plicity -> Maybe ImplicitInfo

631634is_scoped (Imp _ _ _ s) = s

632635is_scoped _ = Nothing

633636

634−impl = Imp [] Dynamic False (Just (Impl False True))

635−forall_imp = Imp [] Dynamic False (Just (Impl False False))

637+impl = Imp [] Dynamic False (Just (Impl False True))

638+

639+forall_imp = Imp [] Dynamic False (Just (Impl False False))

636640forall_constraint = Imp [] Dynamic False (Just (Impl True False))

637−expl = Exp [] Dynamic False

638−expl_param = Exp [] Dynamic True

639−constraint = Constraint [] Static

640−tacimpl t = TacImp [] Dynamic t

641+

642+expl = Exp [] Dynamic False

643+expl_param = Exp [] Dynamic True

644+

645+constraint = Constraint [] Static

646+

647+tacimpl t = TacImp [] Dynamic t

641648

642649data FnOpt = Inlinable -- always evaluate when simplifying

643650 | TotalFn | PartialFn | CoveringFn

@@ -695,7 +702,7 @@ data PDecl' t

695702 FC -- Record name precise location

696703 [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span

697704 [(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

699706 (Maybe (Name, FC)) -- Optional constructor name and location

700707 (Docstring (Either Err t)) -- Constructor doc

701708 SyntaxInfo -- Constructor SyntaxInfo

@@ -717,6 +724,7 @@ data PDecl' t

717724 [(Name, Docstring (Either Err t))] -- Parameter docs

718725 SyntaxInfo

719726 FC [(Name, t)] -- constraints

727+ Accessibility

720728 Name -- class

721729 FC -- precise location of class

722730 [t] -- parameters

@@ -756,6 +764,7 @@ data Directive = DLib Codegen String |

756764 DErrorHandlers Name FC Name FC [(Name, FC)] |

757765 DLanguage LanguageExt |

758766 DDeprecate Name String |

767+ DAutoImplicits Bool |

759768 DUsed FC Name Name

760769

761770-- | 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

875884 (map (mapPDeclFC f g) body)

876885 (fmap (\(n, nfc) -> (n, g nfc)) ctor)

877886 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) =

879888 PInstance doc paramDocs syn (f fc)

880889 (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)

882891 (mapPTermFC f g instTy)

883892 instN

884893 (map (mapPDeclFC f g) body)

@@ -918,7 +927,7 @@ declared (PParams _ _ ds) = concatMap declared ds

918927declared (PNamespace _ _ ds) = concatMap declared ds

919928declared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

920929declared (PClass _ _ _ _ n _ _ _ _ ms cn cd) = n : (map fst (maybeToList cn) ++ concatMap declared ms)

921−declared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

930+declared (PInstance _ _ _ _ _ _ _ _ _ _ _ _) = []

922931declared (PDSL n _) = [n]

923932declared (PSyntax _ _) = []

924933declared (PMutual _ ds) = concatMap declared ds

@@ -927,39 +936,39 @@ declared _ = []

927936

928937-- get the names declared, not counting nested parameter blocks

929938tldeclared :: PDecl -> [Name]

930−tldeclared (PFix _ _ _) = []

931−tldeclared (PTy _ _ _ _ _ n _ t) = [n]

932−tldeclared (PPostulate _ _ _ _ _ _ n t) = [n]

933−tldeclared (PClauses _ _ n _) = [] -- not a declaration

934−tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

939+tldeclared (PFix _ _ _) = []

940+tldeclared (PTy _ _ _ _ _ n _ t) = [n]

941+tldeclared (PPostulate _ _ _ _ _ _ n t) = [n]

942+tldeclared (PClauses _ _ n _) = [] -- not a declaration

943+tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

935944tldeclared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

936945 where fstt (_, _, a, _, _, _, _) = a

937−tldeclared (PParams _ _ ds) = []

938−tldeclared (PMutual _ ds) = concatMap tldeclared ds

939−tldeclared (PNamespace _ _ ds) = concatMap tldeclared ds

940−tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)

941−tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

942−tldeclared _ = []

946+tldeclared (PParams _ _ ds) = []

947+tldeclared (PMutual _ ds) = concatMap tldeclared ds

948+tldeclared (PNamespace _ _ ds) = concatMap tldeclared ds

949+tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)

950+tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _ _) = []

951+tldeclared _ = []

943952

944953defined :: PDecl -> [Name]

945−defined (PFix _ _ _) = []

946−defined (PTy _ _ _ _ _ n _ t) = []

947−defined (PPostulate _ _ _ _ _ _ n t) = []

948−defined (PClauses _ _ n _) = [n] -- not a declaration

949−defined (PCAF _ n _) = [n]

950−defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

954+defined (PFix _ _ _) = []

955+defined (PTy _ _ _ _ _ n _ t) = []

956+defined (PPostulate _ _ _ _ _ _ n t) = []

957+defined (PClauses _ _ n _) = [n] -- not a declaration

958+defined (PCAF _ n _) = [n]

959+defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

951960 where fstt (_, _, a, _, _, _, _) = a

952−defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = []

953−defined (PParams _ _ ds) = concatMap defined ds

954−defined (PNamespace _ _ ds) = concatMap defined ds

955−defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

956−defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)

957−defined (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

958−defined (PDSL n _) = [n]

959−defined (PSyntax _ _) = []

960−defined (PMutual _ ds) = concatMap defined ds

961−defined (PDirective _) = []

962−defined _ = []

961+defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = []

962+defined (PParams _ _ ds) = concatMap defined ds

963+defined (PNamespace _ _ ds) = concatMap defined ds

964+defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

965+defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)

966+defined (PInstance _ _ _ _ _ _ _ _ _ _ _ _) = []

967+defined (PDSL n _) = [n]

968+defined (PSyntax _ _) = []

969+defined (PMutual _ ds) = concatMap defined ds

970+defined (PDirective _) = []

971+defined _ = []

963972

964973updateN :: [(Name, Name)] -> Name -> Name

965974updateN ns n | Just n' <- lookup n ns = n'

@@ -1040,33 +1049,33 @@ data PAltType = ExactlyOne Bool -- ^ flag sets whether delay is allowed

10401049-- general-purpose FCs, and the second transforms those that are used

10411050-- for semantic source highlighting, so they can be treated specially.

10421051mapPTermFC :: (FC -> FC) -> (FC -> FC) -> PTerm -> PTerm

1043−mapPTermFC f g (PQuote q) = PQuote q

1044−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

1046−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)

1048−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)

1050−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)

1052−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)

1054−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)

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)

1057−mapPTermFC f g (PTrue fc info) = PTrue (f fc) info

1058−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)

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)

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)

1062−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)

1064−mapPTermFC f g (PHidden t) = PHidden (mapPTermFC f g t)

1065−mapPTermFC f g (PType fc) = PType (f fc)

1066−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)

1068−mapPTermFC f g (PConstant fc c) = PConstant (f fc) c

1069−mapPTermFC f g Placeholder = Placeholder

1052+mapPTermFC f g (PQuote q) = PQuote q

1053+mapPTermFC f g (PRef fc fcs n) = PRef (g fc) (map g fcs) n

1054+mapPTermFC f g (PInferRef fc fcs n) = PInferRef (g fc) (map g fcs) n

1055+mapPTermFC f g (PPatvar fc n) = PPatvar (g fc) n

1056+mapPTermFC f g (PLam fc n fc' t1 t2) = PLam (f fc) 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)

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)

1059+mapPTermFC f g (PTyped t1 t2) = PTyped (mapPTermFC f g t1) (mapPTermFC f g t2)

1060+mapPTermFC f g (PApp fc t args) = PApp (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)

1061+mapPTermFC f g (PAppImpl t1 impls) = PAppImpl (mapPTermFC f g t1) impls

1062+mapPTermFC f g (PAppBind fc t args) = PAppBind (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)

1063+mapPTermFC f g (PMatchApp fc n) = PMatchApp (f fc) n

1064+mapPTermFC f g (PIfThenElse fc t1 t2 t3) = PIfThenElse (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)

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)

1066+mapPTermFC f g (PTrue fc info) = PTrue (f fc) info

1067+mapPTermFC f g (PResolveTC fc) = PResolveTC (f fc)

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)

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)

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)

1071+mapPTermFC f g (PAs fc n t) = PAs (f fc) n (mapPTermFC f g t)

1072+mapPTermFC f g (PAlternative ns ty ts) = PAlternative ns ty (map (mapPTermFC f g) ts)

1073+mapPTermFC f g (PHidden t) = PHidden (mapPTermFC f g t)

1074+mapPTermFC f g (PType fc) = PType (f fc)

1075+mapPTermFC f g (PUniverse u) = PUniverse u

1076+mapPTermFC f g (PGoal fc t1 n t2) = PGoal (f fc) (mapPTermFC f g t1) n (mapPTermFC f g t2)

1077+mapPTermFC f g (PConstant fc c) = PConstant (f fc) c

1078+mapPTermFC f g Placeholder = Placeholder

10701079mapPTermFC f g (PDoBlock dos) = PDoBlock (map mapPDoFC dos)

10711080 where mapPDoFC (DoExp fc t) = DoExp (f fc) (mapPTermFC f g t)

10721081 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)

10741083 DoBindP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (map (\(l,r)-> (mapPTermFC f g l, mapPTermFC f g r)) alts)

10751084 mapPDoFC (DoLet fc n nfc t1 t2) = DoLet (f fc) n (g nfc) (mapPTermFC f g t1) (mapPTermFC f g t2)

10761085 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)

1078−mapPTermFC f g (PReturn fc) = PReturn (f fc)

1079−mapPTermFC f g (PMetavar fc n) = PMetavar (g fc) n

1080−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)

1082−mapPTermFC f g (PElabError err) = PElabError err

1083−mapPTermFC f g PImpossible = PImpossible

1084−mapPTermFC f g (PCoerced t) = PCoerced (mapPTermFC f g t)

1085−mapPTermFC f g (PDisamb msg t) = PDisamb msg (mapPTermFC f g t)

1086−mapPTermFC f g (PUnifyLog t) = PUnifyLog (mapPTermFC f g t)

1087−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)

1089−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

1091−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)

1086+mapPTermFC f g (PIdiom fc t) = PIdiom (f fc) (mapPTermFC f g t)

1087+mapPTermFC f g (PReturn fc) = PReturn (f fc)

1088+mapPTermFC f g (PMetavar fc n) = PMetavar (g fc) n

1089+mapPTermFC f g (PProof tacs) = PProof (map (fmap (mapPTermFC f g)) tacs)

1090+mapPTermFC f g (PTactics tacs) = PTactics (map (fmap (mapPTermFC f g)) tacs)

1091+mapPTermFC f g (PElabError err) = PElabError err

1092+mapPTermFC f g PImpossible = PImpossible

1093+mapPTermFC f g (PCoerced t) = PCoerced (mapPTermFC f g t)

1094+mapPTermFC f g (PDisamb msg t) = PDisamb msg (mapPTermFC f g t)

1095+mapPTermFC f g (PUnifyLog t) = PUnifyLog (mapPTermFC f g t)

1096+mapPTermFC f g (PNoImplicits t) = PNoImplicits (mapPTermFC f g t)

1097+mapPTermFC f g (PQuasiquote t1 t2) = PQuasiquote (mapPTermFC f g t1) (fmap (mapPTermFC f g) t2)

1098+mapPTermFC f g (PUnquote t) = PUnquote (mapPTermFC f g t)

1099+mapPTermFC f g (PRunElab fc tm ns) = PRunElab (f fc) (mapPTermFC f g tm) ns

1100+mapPTermFC f g (PConstSugar fc tm) = PConstSugar (g fc) (mapPTermFC f g tm)

1101+mapPTermFC f g (PQuoteName n x fc) = PQuoteName n x (g fc)

10931102

10941103{-!

10951104dg instance Binary PTerm

@@ -1098,28 +1107,27 @@ deriving instance NFData PTerm

10981107

10991108mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

11001109mapPT f t = f (mpt t) where

1101− 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)

1103− 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)

1105− (fmap (mapPT f) g)

1106− 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)

1108− 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)

1110− 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)

1110+ mpt (PLam fc n nfc t s) = PLam fc 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)

1112+ mpt (PLet fc n nfc ty v s) = PLet fc n nfc (mapPT f ty) (mapPT f v) (mapPT f s)

1113+ mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s) (fmap (mapPT f) g)

1114+ mpt (PApp fc t as) = PApp 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)

1116+ mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os)

1117+ mpt (PIfThenElse fc c t e) = PIfThenElse fc (mapPT f c) (mapPT f t) (mapPT f e)

1118+ mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r)

1119+ mpt (PPair fc hls p l r) = PPair fc hls p (mapPT f l) (mapPT f r)

11121120 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)

1114− mpt (PHidden t) = PHidden (mapPT f t)

1115− mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds)

1116− mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

1117− mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

1118− mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

1119− mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)

1120− mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

1121− mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

1122− mpt x = x

1121+ mpt (PAlternative ns a as) = PAlternative ns a (map (mapPT f) as)

1122+ mpt (PHidden t) = PHidden (mapPT f t)

1123+ mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds)

1124+ mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

1125+ mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

1126+ mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

1127+ mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)

1128+ mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

1129+ mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

1130+ mpt x = x

11231131

11241132

11251133data PTactic' t = Intro [Name] | Intros | Focus Name

@@ -1160,39 +1168,39 @@ deriving instance Binary PTactic'

11601168deriving instance NFData PTactic'

11611169!-}

11621170instance Sized a => Sized (PTactic' a) where

1163− size (Intro nms) = 1 + size nms

1164− size Intros = 1

1165− size (Focus nm) = 1 + size nm

1166− size (Refine nm bs) = 1 + size nm + length bs

1167− size (Rewrite t) = 1 + size t

1168− size (Induction t) = 1 + size t

1169− size (LetTac nm t) = 1 + size nm + size t

1170− size (Exact t) = 1 + size t

1171− size Compute = 1

1172− size Trivial = 1

1173− size Solve = 1

1174− size Attack = 1

1175− size ProofState = 1

1176− size ProofTerm = 1

1177− size Undo = 1

1178− size (Try l r) = 1 + size l + size r

1179− size (TSeq l r) = 1 + size l + size r

1180− size (ApplyTactic t) = 1 + size t

1181− size (Reflect t) = 1 + size t

1182− size (Fill t) = 1 + size t

1183− size Qed = 1

1184− size Abandon = 1

1185− size Skip = 1

1186− size (TFail ts) = 1 + size ts

1187− size SourceFC = 1

1188− size DoUnify = 1

1189− size (CaseTac x) = 1 + size x

1190− size (Equiv t) = 1 + size t

1191− size (Claim x y) = 1 + size x + size y

1192− size Unfocus = 1

1193− size (MatchRefine x) = 1 + size x

1171+ size (Intro nms) = 1 + size nms

1172+ size Intros = 1

1173+ size (Focus nm) = 1 + size nm

1174+ size (Refine nm bs) = 1 + size nm + length bs

1175+ size (Rewrite t) = 1 + size t

1176+ size (Induction t) = 1 + size t

1177+ size (LetTac nm t) = 1 + size nm + size t

1178+ size (Exact t) = 1 + size t

1179+ size Compute = 1

1180+ size Trivial = 1

1181+ size Solve = 1

1182+ size Attack = 1

1183+ size ProofState = 1

1184+ size ProofTerm = 1

1185+ size Undo = 1

1186+ size (Try l r) = 1 + size l + size r

1187+ size (TSeq l r) = 1 + size l + size r

1188+ size (ApplyTactic t) = 1 + size t

1189+ size (Reflect t) = 1 + size t

1190+ size (Fill t) = 1 + size t

1191+ size Qed = 1

1192+ size Abandon = 1

1193+ size Skip = 1

1194+ size (TFail ts) = 1 + size ts

1195+ size SourceFC = 1

1196+ size DoUnify = 1

1197+ size (CaseTac x) = 1 + size x

1198+ size (Equiv t) = 1 + size t

1199+ size (Claim x y) = 1 + size x + size y

1200+ size Unfocus = 1

1201+ size (MatchRefine x) = 1 + size x

11941202 size (LetTacTy x y z) = 1 + size x + size y + size z

1195− size TCInstance = 1

1203+ size TCInstance = 1

11961204

11971205type PTactic = PTactic' PTerm

11981206

@@ -1208,11 +1216,11 @@ deriving instance NFData PDo'

12081216!-}

12091217

12101218instance Sized a => Sized (PDo' a) where

1211− 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

1213− 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

1215− size (DoLetP fc l r) = 1 + size fc + size l + size r

1219+ size (DoExp fc t) = 1 + size fc + size t

1220+ size (DoBind fc nm nfc t) = 1 + size fc + size nm + size nfc + size t

1221+ size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts

1222+ size (DoLet fc nm nfc l r) = 1 + size fc + size nm + size l + size r

1223+ size (DoLetP fc l r) = 1 + size fc + size l + size r

12161224

12171225type PDo = PDo' PTerm

12181226

@@ -1244,10 +1252,10 @@ data ArgOpt = AlwaysShow | HideDisplay | InaccessibleArg | UnknownImp

12441252 deriving (Show, Eq, Data, Typeable)

12451253

12461254instance Sized a => Sized (PArg' a) where

1247− size (PImp p _ l nm trm) = 1 + size nm + size trm

1248− 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

1250− size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

1255+ size (PImp p _ l nm trm) = 1 + size nm + size trm

1256+ size (PExp p l nm trm) = 1 + size nm + size trm

1257+ size (PConstraint p l nm trm) = 1 + size nm +size nm + size trm

1258+ size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

12511259

12521260{-!

12531261deriving instance Binary PArg'

@@ -1255,43 +1263,43 @@ deriving instance NFData PArg'

12551263!-}

12561264

12571265pimp n t mach = PImp 1 mach [] n t

1258−pexp t = PExp 1 [] (sMN 0 "arg") t

1259−pconst t = PConstraint 1 [] (sMN 0 "carg") t

1266+pexp t = PExp 1 [] (sMN 0 "arg") t

1267+pconst t = PConstraint 1 [] (sMN 0 "carg") t

12601268ptacimp n s t = PTacImplicit 2 [] n s t

12611269

12621270type PArg = PArg' PTerm

12631271

12641272-- | Get the highest FC in a term, if one exists

12651273highestFC :: PTerm -> Maybe FC

1266−highestFC (PQuote _) = Nothing

1267−highestFC (PRef fc _ _) = Just fc

1268−highestFC (PInferRef fc _ _) = Just fc

1269−highestFC (PPatvar fc _) = Just fc

1270−highestFC (PLam fc _ _ _ _) = Just fc

1271−highestFC (PPi _ _ _ _ _) = Nothing

1272−highestFC (PLet fc _ _ _ _ _) = Just fc

1273−highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty

1274−highestFC (PApp fc _ _) = Just fc

1275−highestFC (PAppBind fc _ _) = Just fc

1276−highestFC (PMatchApp fc _) = Just fc

1277−highestFC (PCase fc _ _) = Just fc

1278−highestFC (PIfThenElse fc _ _ _) = Just fc

1279−highestFC (PTrue fc _) = Just fc

1280−highestFC (PResolveTC fc) = Just fc

1281−highestFC (PRewrite fc _ _ _) = Just fc

1282−highestFC (PPair fc _ _ _ _) = Just fc

1283−highestFC (PDPair fc _ _ _ _ _) = Just fc

1284−highestFC (PAs fc _ _) = Just fc

1274+highestFC (PQuote _) = Nothing

1275+highestFC (PRef fc _ _) = Just fc

1276+highestFC (PInferRef fc _ _) = Just fc

1277+highestFC (PPatvar fc _) = Just fc

1278+highestFC (PLam fc _ _ _ _) = Just fc

1279+highestFC (PPi _ _ _ _ _) = Nothing

1280+highestFC (PLet fc _ _ _ _ _) = Just fc

1281+highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty

1282+highestFC (PApp fc _ _) = Just fc

1283+highestFC (PAppBind fc _ _) = Just fc

1284+highestFC (PMatchApp fc _) = Just fc

1285+highestFC (PCase fc _ _) = Just fc

1286+highestFC (PIfThenElse fc _ _ _) = Just fc

1287+highestFC (PTrue fc _) = Just fc

1288+highestFC (PResolveTC fc) = Just fc

1289+highestFC (PRewrite fc _ _ _) = Just fc

1290+highestFC (PPair fc _ _ _ _) = Just fc

1291+highestFC (PDPair fc _ _ _ _ _) = Just fc

1292+highestFC (PAs fc _ _) = Just fc

12851293highestFC (PAlternative _ _ args) =

12861294 case mapMaybe highestFC args of

12871295 [] -> Nothing

12881296 (fc:_) -> Just fc

1289−highestFC (PHidden _) = Nothing

1290−highestFC (PType fc) = Just fc

1291−highestFC (PUniverse _) = Nothing

1292−highestFC (PGoal fc _ _ _) = Just fc

1293−highestFC (PConstant fc _) = Just fc

1294−highestFC Placeholder = Nothing

1297+highestFC (PHidden _) = Nothing

1298+highestFC (PType fc) = Just fc

1299+highestFC (PUniverse _) = Nothing

1300+highestFC (PGoal fc _ _ _) = Just fc

1301+highestFC (PConstant fc _) = Just fc

1302+highestFC Placeholder = Nothing

12951303highestFC (PDoBlock lines) =

12961304 case map getDoFC lines of

12971305 [] -> Nothing

@@ -1303,23 +1311,23 @@ highestFC (PDoBlock lines) =

13031311 getDoFC (DoLet fc nm nfc l r) = fc

13041312 getDoFC (DoLetP fc l r) = fc

13051313

1306−highestFC (PIdiom fc _) = Just fc

1307−highestFC (PReturn fc) = Just fc

1308−highestFC (PMetavar fc _) = Just fc

1309−highestFC (PProof _) = Nothing

1310−highestFC (PTactics _) = Nothing

1311−highestFC (PElabError _) = Nothing

1312−highestFC PImpossible = Nothing

1313−highestFC (PCoerced tm) = highestFC tm

1314−highestFC (PDisamb _ opts) = highestFC opts

1315−highestFC (PUnifyLog tm) = highestFC tm

1316−highestFC (PNoImplicits tm) = highestFC tm

1317−highestFC (PQuasiquote _ _) = Nothing

1318−highestFC (PUnquote tm) = highestFC tm

1319−highestFC (PQuoteName _ _ fc) = Just fc

1320−highestFC (PRunElab fc _ _) = Just fc

1321−highestFC (PConstSugar fc _) = Just fc

1322−highestFC (PAppImpl t _) = highestFC t

1314+highestFC (PIdiom fc _) = Just fc

1315+highestFC (PReturn fc) = Just fc

1316+highestFC (PMetavar fc _) = Just fc

1317+highestFC (PProof _) = Nothing

1318+highestFC (PTactics _) = Nothing

1319+highestFC (PElabError _) = Nothing

1320+highestFC PImpossible = Nothing

1321+highestFC (PCoerced tm) = highestFC tm

1322+highestFC (PDisamb _ opts) = highestFC opts

1323+highestFC (PUnifyLog tm) = highestFC tm

1324+highestFC (PNoImplicits tm) = highestFC tm

1325+highestFC (PQuasiquote _ _) = Nothing

1326+highestFC (PUnquote tm) = highestFC tm

1327+highestFC (PQuoteName _ _ fc) = Just fc

1328+highestFC (PRunElab fc _ _) = Just fc

1329+highestFC (PConstSugar fc _) = Just fc

1330+highestFC (PAppImpl t _) = highestFC t

13231331

13241332-- Type class data

13251333

@@ -1397,11 +1405,11 @@ data Syntax = Rule [SSymbol] PTerm SynContext

13971405

13981406syntaxNames :: Syntax -> [Name]

13991407syntaxNames (Rule syms _ _) = mapMaybe ename syms

1400− where ename (Keyword n) = Just n

1401− ename _ = Nothing

1408+ where ename (Keyword n) = Just n

1409+ ename _ = Nothing

14021410syntaxNames (DeclRule syms _) = mapMaybe ename syms

1403− where ename (Keyword n) = Just n

1404− ename _ = Nothing

1411+ where ename (Keyword n) = Just n

1412+ ename _ = Nothing

14051413

14061414syntaxSymbols :: Syntax -> [SSymbol]

14071415syntaxSymbols (Rule ss _ _) = ss

@@ -1434,9 +1442,9 @@ updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules

14341442 where

14351443 newRules = sortBy (ruleSort `on` syntaxSymbols) (rules ++ sr)

14361444

1437− ruleSort [] [] = EQ

1438− ruleSort [] _ = LT

1439− ruleSort _ [] = GT

1445+ ruleSort [] [] = EQ

1446+ ruleSort [] _ = LT

1447+ ruleSort _ [] = GT

14401448 ruleSort (s1:ss1) (s2:ss2) =

14411449 case symCompare s1 s2 of

14421450 EQ -> ruleSort ss1 ss2

@@ -1444,25 +1452,25 @@ updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules

14441452

14451453 -- Better than creating Ord instance for SSymbol since

14461454 -- in general this ordering does not really make sense.

1447− symCompare (Keyword n1) (Keyword n2) = compare n1 n2

1448− symCompare (Keyword _) _ = LT

1449− symCompare (Symbol _) (Keyword _) = GT

1450− symCompare (Symbol s1) (Symbol s2) = compare s1 s2

1451− symCompare (Symbol _) _ = LT

1452− symCompare (Binding _) (Keyword _) = GT

1453− symCompare (Binding _) (Symbol _) = GT

1454− symCompare (Binding b1) (Binding b2) = compare b1 b2

1455− symCompare (Binding _) _ = LT

1456− symCompare (Expr _) (Keyword _) = GT

1457− symCompare (Expr _) (Symbol _) = GT

1458− symCompare (Expr _) (Binding _) = GT

1459− symCompare (Expr e1) (Expr e2) = compare e1 e2

1460− symCompare (Expr _) _ = LT

1461− symCompare (SimpleExpr _) (Keyword _) = GT

1462− symCompare (SimpleExpr _) (Symbol _) = GT

1463− symCompare (SimpleExpr _) (Binding _) = GT

1464− symCompare (SimpleExpr _) (Expr _) = GT

1465− symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2

1455+ symCompare (Keyword n1) (Keyword n2) = compare n1 n2

1456+ symCompare (Keyword _) _ = LT

1457+ symCompare (Symbol _) (Keyword _) = GT

1458+ symCompare (Symbol s1) (Symbol s2) = compare s1 s2

1459+ symCompare (Symbol _) _ = LT

1460+ symCompare (Binding _) (Keyword _) = GT

1461+ symCompare (Binding _) (Symbol _) = GT

1462+ symCompare (Binding b1) (Binding b2) = compare b1 b2

1463+ symCompare (Binding _) _ = LT

1464+ symCompare (Expr _) (Keyword _) = GT

1465+ symCompare (Expr _) (Symbol _) = GT

1466+ symCompare (Expr _) (Binding _) = GT

1467+ symCompare (Expr e1) (Expr e2) = compare e1 e2

1468+ symCompare (Expr _) _ = LT

1469+ symCompare (SimpleExpr _) (Keyword _) = GT

1470+ symCompare (SimpleExpr _) (Symbol _) = GT

1471+ symCompare (SimpleExpr _) (Binding _) = GT

1472+ symCompare (SimpleExpr _) (Expr _) = GT

1473+ symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2

14661474

14671475initDSL = DSL (PRef f [] (sUN ">>="))

14681476 (PRef f [] (sUN "return"))

@@ -1534,10 +1542,10 @@ getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc

15341542getInferTerm (App _ (App _ _ _) tm) = tm

15351543getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)

15361544

1537−getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

1538− where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

1539− toTy (PVar t) = PVTy t

1540− toTy b = b

1545+getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

1546+ where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

1547+ toTy (PVar t) = PVTy t

1548+ toTy b = b

15411549getInferType (App _ (App _ _ ty) _) = ty

15421550

15431551

@@ -1562,9 +1570,9 @@ pairCon = sNS (sUN "MkPair") ["Builtins"]

15621570upairTy = sNS (sUN "UPair") ["Builtins"]

15631571upairCon = sNS (sUN "MkUPair") ["Builtins"]

15641572

1565−eqTy = sUN "="

1573+eqTy = sUN "="

15661574eqCon = sUN "Refl"

1567−eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

1575+eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

15681576 "The propositional equality type. A proof that `x` = `y`." ++

15691577 "\n\n" ++

15701578 "To use such a proof, pattern-match on it, and the two equal things will " ++

@@ -1607,8 +1615,8 @@ modDocName :: Name

16071615modDocName = sMN 0 "ModuleDocs"

16081616

16091617-- Defined in builtins.idr

1610−sigmaTy = sNS (sUN "Sigma") ["Builtins"]

1611−sigmaCon = sNS (sUN "MkSigma") ["Builtins"]

1618+sigmaTy = sNS (sUN "DPair") ["Builtins"]

1619+sigmaCon = sNS (sUN "MkDPair") ["Builtins"]

16121620

16131621piBind :: [(Name, PTerm)] -> PTerm -> PTerm

16141622piBind = piBindp expl

@@ -1648,11 +1656,11 @@ annotationColour ist (AnnConst c) =

16481656 in Just $ if constIsType c

16491657 then typeColour theme

16501658 else dataColour theme

1651−annotationColour ist (AnnData _ _) = Just $ dataColour (idris_colourTheme ist)

1652−annotationColour ist (AnnType _ _) = Just $ typeColour (idris_colourTheme ist)

1653−annotationColour ist (AnnBoundName _ True) = Just $ implicitColour (idris_colourTheme ist)

1659+annotationColour ist (AnnData _ _) = Just $ dataColour (idris_colourTheme ist)

1660+annotationColour ist (AnnType _ _) = Just $ typeColour (idris_colourTheme ist)

1661+annotationColour ist (AnnBoundName _ True) = Just $ implicitColour (idris_colourTheme ist)

16541662annotationColour 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)

16561664annotationColour ist (AnnName n _ _ _) =

16571665 let ctxt = tt_ctxt ist

16581666 theme = idris_colourTheme ist

@@ -1738,7 +1746,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

17381746

17391747 st =

17401748 case s of

1741− Static -> text "[static]" <> space

1749+ Static -> text "%static" <> space

17421750 _ -> empty

17431751 prettySe d p bnd (PPi (Imp l s _ fa) n _ ty sc)

17441752 | ppopt_impl ppo =

@@ -1749,12 +1757,12 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

17491757 where

17501758 st =

17511759 case s of

1752− Static -> text "[static]" <> space

1760+ Static -> text "%static" <> space

17531761 _ -> empty

17541762 prettySe d p bnd (PPi (Constraint _ _) n _ ty sc) =

17551763 depth d . bracket p startPrec $

17561764 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) =

17581766 lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>

17591767 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc

17601768 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

17911799 [x] -> group (opName True <$> group (prettySe (decD d) startPrec bnd (getTm x)))

17921800 [l,r] -> let precedence = maybe (startPrec - 1) prec f

17931801 in depth d . bracket p precedence $ inFix (getTm l) (getTm r)

1794− (l@(PExp _ _ _ _) : r@(PExp _ _ _ _) : rest) ->

1802+ (l@(PExp{}) : r@(PExp{}) : rest) ->

17951803 depth d . bracket p funcAppPrec $

17961804 enclose lparen rparen (inFix (getTm l) (getTm r)) <+>

17971805 align (group (vsep (map (prettyArgS d bnd) rest)))

@@ -1842,20 +1850,20 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

18421850 -- disambiguation on PDPair.

18431851 vars tm = filter noNS (allNamesIn tm)

18441852 noNS (NS _ _) = False

1845− noNS _ = True

1853+ noNS _ = True

18461854

18471855 prettySe d p bnd (PIfThenElse _ c t f) =

18481856 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

18501858 , kwd "then" <+> prettySe (decD d) startPrec bnd t

18511859 , kwd "else" <+> prettySe (decD d) startPrec bnd f

18521860 ]

1853− prettySe d p bnd (PHidden tm) = text "." <> prettySe (decD d) funcAppPrec bnd tm

1854− prettySe d p bnd (PResolveTC _) = kwd "%instance"

1855− prettySe d p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1856− prettySe d p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

1861+ prettySe d p bnd (PHidden tm) = text "." <> prettySe (decD d) funcAppPrec bnd tm

1862+ prettySe d p bnd (PResolveTC _) = kwd "%instance"

1863+ prettySe d p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1864+ prettySe d p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

18571865 prettySe d p bnd (PTrue _ TypeOrTerm) = text "()"

1858− prettySe d p bnd (PRewrite _ l r _) =

1866+ prettySe d p bnd (PRewrite _ l r _) =

18591867 depth d . bracket p startPrec $

18601868 text "rewrite" <+> prettySe (decD d) (startPrec + 1) bnd l <+> text "in" <+> prettySe (decD d) startPrec bnd r

18611869 prettySe d p bnd (PTyped l r) =

@@ -1865,9 +1873,9 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

18651873 align . group . vsep . punctuate (ann comma) $

18661874 map (prettySe (decD d) startPrec bnd) elts

18671875 where ann = case pun of

1868− TypeOrTerm -> id

1869− IsType -> annName pairTy

1870− IsTerm -> annName pairCon

1876+ TypeOrTerm -> id

1877+ IsType -> annName pairTy

1878+ IsTerm -> annName pairCon

18711879 prettySe d p bnd (PDPair _ _ pun l t r) =

18721880 depth d $

18731881 annotated lparen <>

@@ -1876,30 +1884,32 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

18761884 prettySe (decD d) startPrec (addBinding bnd) r <>

18771885 annotated rparen

18781886 where annotated = case pun of

1879− IsType -> annName sigmaTy

1880− IsTerm -> annName sigmaCon

1881− TypeOrTerm -> id

1887+ IsType -> annName sigmaTy

1888+ IsTerm -> annName sigmaCon

1889+ TypeOrTerm -> id

18821890 (left, addBinding) = case (l, pun) of

18831891 (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)

18851893 prettySe d p bnd (PAlternative ns a as) =

18861894 lparen <> text "|" <> prettyAs <> text "|" <> rparen

18871895 where

18881896 prettyAs =

1889− foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (depth d . prettySe (decD d) startPrec bnd) as

1890− 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)

1892− prettySe d p bnd (PConstant _ c) = annotate (AnnConst c) (text (show c))

1897+ foldr ((\ l r -> l <+> text "," <+> r) .

1898+ depth d . prettySe (decD d) startPrec bnd)

1899+ empty as

1900+ prettySe d p bnd (PType _) = annotate (AnnType "Type" "The type of types") $ text "Type"

1901+ prettySe d p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u)

1902+ prettySe d p bnd (PConstant _ c) = annotate (AnnConst c) (text (show c))

18931903 -- XXX: add pretty for tactics

1894− prettySe d p bnd (PProof ts) =

1904+ prettySe d p bnd (PProof ts) =

18951905 kwd "proof" <+> lbrace <> ellipsis <> rbrace

1896− prettySe d p bnd (PTactics ts) =

1906+ prettySe d p bnd (PTactics ts) =

18971907 kwd "tactics" <+> lbrace <> ellipsis <> rbrace

1898− 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"

1900− prettySe d p bnd PImpossible = kwd "impossible"

1901− prettySe d p bnd Placeholder = text "_"

1902− prettySe d p bnd (PDoBlock dos) =

1908+ prettySe d p bnd (PMetavar _ n) = annotate (AnnName n (Just MetavarOutput) Nothing Nothing) $ text "?" <> pretty n

1909+ prettySe d p bnd (PReturn f) = kwd "return"

1910+ prettySe d p bnd PImpossible = kwd "impossible"

1911+ prettySe d p bnd Placeholder = text "_"

1912+ prettySe d p bnd (PDoBlock dos) =

19031913 bracket p startPrec $

19041914 kwd "do" <+> align (vsep (map (group . align . hang 2) (ppdo bnd dos)))

19051915 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

19211931 text "no pretty printer for pattern-matching do binding" :

19221932 ppdo bnd dos

19231933 ppdo _ [] = []

1924− prettySe d p bnd (PCoerced t) = prettySe d p bnd t

1925− prettySe d p bnd (PElabError s) = pretty s

1934+ prettySe d p bnd (PCoerced t) = prettySe d p bnd t

1935+ prettySe d p bnd (PElabError s) = pretty s

19261936 -- 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 ")"

19281938 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

1930− prettySe d p bnd (PQuoteName n res _) = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end

1939+ prettySe d p bnd (PUnquote t) = text "~" <> prettySe (decD d) p bnd t

1940+ prettySe d p bnd (PQuoteName n res _) = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end

19311941 where start = if res then "`{" else "`{{"

19321942 end = if res then "}" else "}}"

1933− prettySe d p bnd (PRunElab _ tm _) =

1943+ prettySe d p bnd (PRunElab _ tm _) =

19341944 bracket p funcAppPrec . group . align . hang 2 $

19351945 text "%runElab" <$>

19361946 prettySe (decD d) funcAppPrec bnd tm

1937− 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"

1947+ prettySe d p bnd (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless

1948+ prettySe d p bnd _ = text "missing pretty-printer for term"

19401949

19411950 prettyBindingOf :: Name -> Bool -> Doc OutputAnnotation

19421951 prettyBindingOf n imp = annotate (AnnBoundName n imp) (text (display n))

19431952 where display (UN n) = T.unpack n

19441953 display (MN _ n) = T.unpack n

19451954 -- 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

19471956 display n = show n

19481957

1949− prettyArgS d bnd (PImp _ _ _ n tm) = prettyArgSi d bnd (n, tm)

1950− prettyArgS d bnd (PExp _ _ _ tm) = prettyArgSe d bnd tm

1951− prettyArgS d bnd (PConstraint _ _ _ tm) = prettyArgSc d bnd tm

1952− prettyArgS d bnd (PTacImplicit _ _ n _ tm) = prettyArgSti d bnd (n, tm)

1958+ prettyArgS d bnd (PImp _ _ _ n tm) = prettyArgSi d bnd (n, tm)

1959+ prettyArgS d bnd (PExp _ _ _ tm) = prettyArgSe d bnd tm

1960+ prettyArgS d bnd (PConstraint _ _ _ tm) = prettyArgSc d bnd tm

1961+ prettyArgS d bnd (PTacImplicit _ _ n _ tm) = prettyArgSti d bnd (n, tm)

19531962

1954− 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

1956− prettyArgSc d bnd val = lbrace <> lbrace <> prettySe (decD d) startPrec bnd val <> rbrace <> rbrace

1963+ prettyArgSe d bnd arg = prettySe d (funcAppPrec + 1) bnd arg

1964+ prettyArgSi d bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

1965+ prettyArgSc d bnd val = lbrace <> lbrace <> prettySe (decD d) startPrec bnd val <> rbrace <> rbrace

19571966 prettyArgSti d bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

19581967

19591968 annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

19601969 annName n = annotate (AnnName n Nothing Nothing Nothing)

19611970

19621971 opStr :: Name -> String

1963− opStr (NS n _) = opStr n

1964− opStr (UN n) = T.unpack n

1972+ opStr (NS n _) = opStr n

1973+ opStr (UN n) = T.unpack n

19651974

19661975 slist' :: Maybe Int -> Int -> [(Name, Bool)] -> PTerm -> Maybe [Doc OutputAnnotation]

19671976 slist' (Just d) _ _ _ | d <= 0 = Nothing

@@ -2023,7 +2032,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

20232032 ellipsis = text "..."

20242033

20252034 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

20272036

20282037 decD = fmap (\x -> x - 1)

20292038

@@ -2038,7 +2047,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

20382047-- | Strip away namespace information

20392048basename :: Name -> Name

20402049basename (NS n _) = basename n

2041−basename n = n

2050+basename n = n

20422051

20432052-- | Determine whether a name was the one inserted for a hole or

20442053-- guess by the delaborator

@@ -2058,15 +2067,15 @@ prettyName

20582067 -> Name -- ^^ the name to pprint

20592068 -> Doc OutputAnnotation

20602069prettyName infixParen showNS bnd n

2061− | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"

2062− | (UN n') <- n, T.unpack n' == "_" = text "_"

2063− | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName

2064− | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName

2070+ | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"

2071+ | (UN n') <- n, T.unpack n' == "_" = text "_"

2072+ | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName

2073+ | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName

20652074 where fullName = text nameSpace <> parenthesise (text (baseName n))

2066− baseName (UN n) = T.unpack n

2067− baseName (NS n ns) = baseName n

2068− baseName (MN i s) = T.unpack s

2069− baseName other = show other

2075+ baseName (UN n) = T.unpack n

2076+ baseName (NS n ns) = baseName n

2077+ baseName (MN i s) = T.unpack s

2078+ baseName other = show other

20702079 nameSpace = case n of

20712080 (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else ""

20722081 _ -> ""

@@ -2081,13 +2090,13 @@ showCImp ppo (PClause _ n l ws r w)

20812090 = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r

20822091 <+> text "where" <+> text (show w)

20832092 where

2084− showWs [] = empty

2093+ showWs [] = empty

20852094 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

20862095showCImp ppo (PWith _ n l ws r pn w)

20872096 = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

20882097 <+> braces (text (show w))

20892098 where

2090− showWs [] = empty

2099+ showWs [] = empty

20912100 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

20922101

20932102

@@ -2099,43 +2108,43 @@ showDImp ppo (PDatadecl n nfc ty cons)

20992108showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

21002109showDecls o ds = vsep (map (showDeclImp o) ds)

21012110

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))

21032112showDeclImp 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" <+>

21052114 indent 2 (vsep (map (showCImp o) cs))

2106−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)

2108−showDeclImp o (PNamespace n fc ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

2115+showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d

2116+showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)

2117+showDeclImp o (PNamespace n fc ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

21092118showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

21102119showDeclImp o (PClass _ _ _ cs n _ ps _ _ ds _ _)

21112120 = 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)

21132122 = text "implementation" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

21142123showDeclImp _ _ = text "..."

21152124-- showDeclImp (PImport o) = "import " ++ o

21162125

21172126getImps :: [PArg] -> [(Name, PTerm)]

21182127getImps [] = []

2119−getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

2120−getImps (_ : xs) = getImps xs

2128+getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

2129+getImps (_ : xs) = getImps xs

21212130

21222131getExps :: [PArg] -> [PTerm]

21232132getExps [] = []

2124−getExps (PExp _ _ _ tm : xs) = tm : getExps xs

2125−getExps (_ : xs) = getExps xs

2133+getExps (PExp _ _ _ tm : xs) = tm : getExps xs

2134+getExps (_ : xs) = getExps xs

21262135

21272136getShowArgs :: [PArg] -> [PArg]

21282137getShowArgs [] = []

21292138getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs

21302139getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs

21312140 | PImp _ _ _ _ tm <- e

2132− , containsHole tm = e : getShowArgs xs

2141+ , containsHole tm = e : getShowArgs xs

21332142getShowArgs (_ : xs) = getShowArgs xs

21342143

21352144getConsts :: [PArg] -> [PTerm]

2136−getConsts [] = []

2145+getConsts [] = []

21372146getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

2138−getConsts (_ : xs) = getConsts xs

2147+getConsts (_ : xs) = getConsts xs

21392148

21402149getAll :: [PArg] -> [PTerm]

21412150getAll = map getTm

@@ -2149,13 +2158,13 @@ showName :: Maybe IState -- ^^ the Idris state, for information about names an

21492158 -> Name -- ^^ the term to show

21502159 -> String

21512160showName ist bnd ppo colour n = case ist of

2152− Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

2153− Nothing -> showbasic n

2161+ Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

2162+ Nothing -> showbasic n

21542163 where name = if ppopt_impl ppo then show n else showbasic n

2155− showbasic n@(UN _) = showCG n

2156− showbasic (MN i s) = str s

2157− showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

2158− showbasic (SN s) = show s

2164+ showbasic n@(UN _) = showCG n

2165+ showbasic (MN i s) = str s

2166+ showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

2167+ showbasic (SN s) = show s

21592168 fst3 (x, _, _) = x

21602169 colourise n t = let ctxt' = fmap tt_ctxt ist in

21612170 case ctxt' of

@@ -2187,42 +2196,42 @@ showTmOpts opt = flip (displayS . renderPretty 1.0 10000000 . prettyImp opt) ""

21872196

21882197

21892198instance Sized PTerm where

2190− size (PQuote rawTerm) = size rawTerm

2191− size (PRef fc _ name) = size name

2192− 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

2194− 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

2196− size (PApp fc name args) = 1 + size args

2197− size (PAppBind fc name args) = 1 + size args

2198− size (PCase fc trm bdy) = 1 + size trm + size bdy

2199− size (PIfThenElse fc c t f) = 1 + sum (map size [c, t, f])

2200− size (PTrue fc _) = 1

2201− size (PResolveTC fc) = 1

2202− size (PRewrite fc left right _) = 1 + size left + size right

2203− size (PPair fc _ _ left right) = 1 + size left + size right

2204− size (PDPair fs _ _ left ty right) = 1 + size left + size ty + size right

2205− size (PAlternative _ a alts) = 1 + size alts

2206− size (PHidden hidden) = size hidden

2207− size (PUnifyLog tm) = size tm

2208− size (PDisamb _ tm) = size tm

2209− size (PNoImplicits tm) = size tm

2210− size (PType _) = 1

2211− size (PUniverse _) = 1

2212− size (PConstant fc const) = 1 + size fc + size const

2213− size Placeholder = 1

2214− size (PDoBlock dos) = 1 + size dos

2215− size (PIdiom fc term) = 1 + size term

2216− size (PReturn fc) = 1

2217− size (PMetavar _ name) = 1

2218− size (PProof tactics) = size tactics

2219− size (PElabError err) = size err

2220− size PImpossible = 1

2221− size _ = 0

2199+ size (PQuote rawTerm) = size rawTerm

2200+ size (PRef fc _ name) = size name

2201+ size (PLam fc name _ ty bdy) = 1 + size ty + size bdy

2202+ size (PPi plicity name fc ty bdy) = 1 + size ty + size fc + size bdy

2203+ size (PLet fc name nfc ty def bdy) = 1 + size ty + size def + size bdy

2204+ size (PTyped trm ty) = 1 + size trm + size ty

2205+ size (PApp fc name args) = 1 + size args

2206+ size (PAppBind fc name args) = 1 + size args

2207+ size (PCase fc trm bdy) = 1 + size trm + size bdy

2208+ size (PIfThenElse fc c t f) = 1 + sum (map size [c, t, f])

2209+ size (PTrue fc _) = 1

2210+ size (PResolveTC fc) = 1

2211+ size (PRewrite fc left right _) = 1 + size left + size right

2212+ size (PPair fc _ _ left right) = 1 + size left + size right

2213+ size (PDPair fs _ _ left ty right) = 1 + size left + size ty + size right

2214+ size (PAlternative _ a alts) = 1 + size alts

2215+ size (PHidden hidden) = size hidden

2216+ size (PUnifyLog tm) = size tm

2217+ size (PDisamb _ tm) = size tm

2218+ size (PNoImplicits tm) = size tm

2219+ size (PType _) = 1

2220+ size (PUniverse _) = 1

2221+ size (PConstant fc const) = 1 + size fc + size const

2222+ size Placeholder = 1

2223+ size (PDoBlock dos) = 1 + size dos

2224+ size (PIdiom fc term) = 1 + size term

2225+ size (PReturn fc) = 1

2226+ size (PMetavar _ name) = 1

2227+ size (PProof tactics) = size tactics

2228+ size (PElabError err) = size err

2229+ size PImpossible = 1

2230+ size _ = 0

22222231

22232232getPArity :: PTerm -> Int

2224−getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

2225−getPArity _ = 0

2233+getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

2234+getPArity _ = 0

22262235

22272236-- Return all names, free or globally bound, in the given term.

22282237

@@ -2230,31 +2239,30 @@ allNamesIn :: PTerm -> [Name]

22302239allNamesIn tm = nub $ ni 0 [] tm

22312240 where -- TODO THINK added niTacImp, but is it right?

22322241 ni 0 env (PRef _ _ n)

2233− | not (n `elem` env) = [n]

2234− ni 0 env (PPatvar _ n) = [n]

2235− ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2236− ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2237− ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env) (map snd os)

2238− 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

2240− 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

2242− ni 0 env (PHidden tm) = ni 0 env tm

2243− 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

2245− 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

2247− 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

2249− ni 0 env (PAlternative ns a ls) = concatMap (ni 0 env) ls

2250− ni 0 env (PUnifyLog tm) = ni 0 env tm

2251− ni 0 env (PDisamb _ tm) = ni 0 env tm

2252− 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

2242+ | not (n `elem` env) = [n]

2243+ ni 0 env (PPatvar _ n) = [n]

2244+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2245+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2246+ ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env . snd) os

2247+ ni 0 env (PIfThenElse _ c t f) = ni 0 env c ++ ni 0 env t ++ ni 0 env f

2248+ ni 0 env (PLam fc n _ ty sc) = 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

2250+ ni 0 env (PLet _ n _ ty val sc) = ni 0 env ty ++ ni 0 env val ++ ni 0 (n:env) sc

2251+ ni 0 env (PHidden tm) = ni 0 env tm

2252+ ni 0 env (PRewrite _ 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

2254+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2255+ ni 0 env (PDPair _ _ _ (PRef _ _ n) Placeholder r) = n : ni 0 env r

2256+ ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2257+ ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

2258+ ni 0 env (PAlternative ns a ls) = concatMap (ni 0 env) ls

2259+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2260+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2261+ ni 0 env (PNoImplicits tm) = ni 0 env tm

22562262

2257− ni i env tm = concatMap (ni i env) (children tm)

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

2265+ ni i env tm = concatMap (ni i env) (children tm)

22582266

22592267 niTacImp i env (TacImp _ _ scr) = ni i env scr

22602268 niTacImp _ _ _ = []

@@ -2265,32 +2273,32 @@ boundNamesIn :: PTerm -> [Name]

22652273boundNamesIn tm = S.toList (ni 0 S.empty tm)

22662274 where -- TODO THINK Added niTacImp, but is it right?

22672275 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)

2269− 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)

2271− 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

2273− 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

2275− 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

2277− ni 0 set (PPair _ _ _ l r) = ni 0 (ni 0 set l) r

2276+ ni 0 set (PApp _ 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)

2278+ ni 0 set (PCase _ c os) = niTms 0 (ni 0 set c) (map snd os)

2279+ ni 0 set (PIfThenElse _ c t f) = niTms 0 set [c, t, f]

2280+ ni 0 set (PLam fc n _ ty sc) = S.insert n $ ni 0 (ni 0 set ty) 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

2282+ ni 0 set (PPi p n _ ty sc) = niTacImp 0 (S.insert n $ ni 0 (ni 0 set ty) sc) p

2283+ ni 0 set (PRewrite _ l r _) = ni 0 (ni 0 set l) r

2284+ ni 0 set (PTyped l r) = ni 0 (ni 0 set l) r

2285+ ni 0 set (PPair _ _ _ l r) = ni 0 (ni 0 set l) r

22782286 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

2280− ni 0 set (PAlternative ns a as) = niTms 0 set as

2281− ni 0 set (PHidden tm) = ni 0 set tm

2282− ni 0 set (PUnifyLog tm) = ni 0 set tm

2283− ni 0 set (PDisamb _ tm) = ni 0 set tm

2284− ni 0 set (PNoImplicits tm) = ni 0 set tm

2287+ ni 0 set (PDPair _ _ _ l t r) = ni 0 (ni 0 (ni 0 set l) t) r

2288+ ni 0 set (PAlternative ns a as) = niTms 0 set as

2289+ ni 0 set (PHidden tm) = ni 0 set tm

2290+ ni 0 set (PUnifyLog tm) = ni 0 set tm

2291+ ni 0 set (PDisamb _ tm) = ni 0 set tm

2292+ ni 0 set (PNoImplicits tm) = ni 0 set tm

22852293

2286− 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

2294+ ni i set (PQuasiquote tm ty) = ni (i + 1) set tm `S.union` maybe S.empty (ni i set) ty

2295+ ni i set (PUnquote tm) = ni (i - 1) set tm

22882296

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)

22902298

22912299 niTms :: Int -> S.Set Name -> [PTerm] -> S.Set Name

2292− niTms i set [] = set

2293− niTms i set (x : xs) = niTms i (ni i set x) xs

2300+ niTms i set [] = set

2301+ niTms i set (x : xs) = niTms i (ni i set x) xs

22942302

22952303 niTacImp i set (TacImp _ _ scr) = ni i set scr

22962304 niTacImp i set _ = set

@@ -2306,18 +2314,18 @@ implicitNamesIn uvars ist tm

23062314 addFn n = do (imps, fns) <- get

23072315 put (imps, n: fns)

23082316

2309− notCAF [] = False

2317+ notCAF [] = False

23102318 notCAF (PExp _ _ _ _ : _) = True

2311− notCAF (_ : xs) = notCAF xs

2319+ notCAF (_ : xs) = notCAF xs

23122320

23132321 notHidden (n, _) = case getAccessibility n of

2314− Hidden -> False

2315− _ -> True

2322+ Hidden -> False

2323+ _ -> True

23162324

23172325 getAccessibility n

23182326 = case lookupDefAccExact n False (tt_ctxt ist) of

2319− Just (n,t) -> t

2320− _ -> Public

2327+ Just (n,t) -> t

2328+ _ -> Public

23212329

23222330 ni 0 env (PRef _ _ n@(NS _ _))

23232331 | not (n `elem` env)

@@ -2327,44 +2335,44 @@ implicitNamesIn uvars ist tm

23272335 | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n

23282336 ni 0 env (PApp _ f@(PRef _ _ n) as)

23292337 | n `elem` uvars = do ni 0 env f

2330− mapM_ (ni 0 env) (map getTm as)

2338+ mapM_ (ni 0 env . getTm) as

23312339 | otherwise = do case lookupTy n (tt_ctxt ist) of

2332− [] -> return ()

2333− _ -> addFn n

2334− mapM_ (ni 0 env) (map getTm as)

2340+ [] -> return ()

2341+ _ -> addFn n

2342+ mapM_ (ni 0 env . getTm) as

23352343 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

23372345 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

23392347 ni 0 env (PCase _ c os) = do ni 0 env c

23402348 -- 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

23422350 (imps, fns) <- get

23432351 put ([] ,[])

2344− mapM_ (ni 0 env) (map fst os)

2352+ mapM_ (ni 0 env . fst) os

23452353 (impsfst, _) <- get

23462354 put (nub imps \\ nub impsfst, fns)

2347− 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

2349− 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

2351− 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

2353− 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

2355− ni 0 env t

2356− ni 0 env r

2357− ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as

2358− ni 0 env (PHidden tm) = ni 0 env tm

2359− ni 0 env (PUnifyLog tm) = ni 0 env tm

2360− ni 0 env (PDisamb _ tm) = ni 0 env tm

2361− ni 0 env (PNoImplicits tm) = ni 0 env tm

2355+ ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f]

2356+ ni 0 env (PLam fc 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

2358+ ni 0 env (PRewrite _ 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

2360+ ni 0 env (PPair _ _ _ l r) = do ni 0 env l; ni 0 env r

2361+ ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = do ni 0 env t; ni 0 (n:env) r

2362+ ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l

2363+ ni 0 env t

2364+ ni 0 env r

2365+ ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as

2366+ ni 0 env (PHidden tm) = ni 0 env tm

2367+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2368+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2369+ ni 0 env (PNoImplicits tm) = ni 0 env tm

23622370

23632371 ni i env (PQuasiquote tm ty) = do ni (i + 1) env tm

23642372 maybe (return ()) (ni i env) ty

23652373 ni i env (PUnquote tm) = ni (i - 1) env tm

23662374

2367− ni i env tm = mapM_ (ni i env) (children tm)

2375+ ni i env tm = mapM_ (ni i env) (children tm)

23682376

23692377-- Return names which are free in the given term.

23702378namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

@@ -2373,32 +2381,32 @@ namesIn uvars ist tm = nub $ ni 0 [] tm

23732381 ni 0 env (PRef _ _ n)

23742382 | not (n `elem` env)

23752383 = case lookupTy n (tt_ctxt ist) of

2376− [] -> [n]

2377− _ -> if n `elem` (map fst uvars) then [n] else []

2378− ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2379− ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2380− ni 0 env (PCase _ c os) = ni 0 env c ++

2384+ [] -> [n]

2385+ _ -> [n | n `elem` (map fst uvars)]

2386+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2387+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2388+ ni 0 env (PCase _ c os) = ni 0 env c ++

23812389 -- names in 'os', not counting the names bound in the cases

2382− (nub (concatMap (ni 0 env) (map snd os))

2383− \\ nub (concatMap (ni 0 env) (map fst os)))

2384− ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2390+ (nub (concatMap (ni 0 env . snd) os)

2391+ \\ nub (concatMap (ni 0 env . fst) os))

2392+ ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

23852393 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

2387− 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

2389− ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2394+ ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2395+ ni 0 env (PRewrite _ 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

2397+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

23902398 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

23922400 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2393− ni 0 env (PHidden tm) = ni 0 env tm

2394− ni 0 env (PUnifyLog tm) = ni 0 env tm

2395− ni 0 env (PDisamb _ tm) = ni 0 env tm

2396− ni 0 env (PNoImplicits tm) = ni 0 env tm

2401+ ni 0 env (PHidden tm) = ni 0 env tm

2402+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2403+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2404+ ni 0 env (PNoImplicits tm) = ni 0 env tm

23972405

2398− 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

2406+ ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2407+ ni i env (PUnquote tm) = ni (i - 1) env tm

24002408

2401− ni i env tm = concatMap (ni i env) (children tm)

2409+ ni i env tm = concatMap (ni i env) (children tm)

24022410

24032411 niTacImp i env (TacImp _ _ scr) = ni i env scr

24042412 niTacImp _ _ _ = []

@@ -2413,27 +2421,27 @@ usedNamesIn vars ist tm = nub $ ni 0 [] tm

24132421 = case lookupDefExact n (tt_ctxt ist) of

24142422 Nothing -> [n]

24152423 _ -> []

2416− ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2417− ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2418− ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env) (map snd os)

2419− 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

2421− 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

2423− 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

2424+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2425+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2426+ ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env . snd) os

2427+ ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2428+ ni 0 env (PLam fc n _ ty sc) = 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

2430+ ni 0 env (PRewrite _ 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

2432+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

24252433 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

24272435 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2428− ni 0 env (PHidden tm) = ni 0 env tm

2429− ni 0 env (PUnifyLog tm) = ni 0 env tm

2430− ni 0 env (PDisamb _ tm) = ni 0 env tm

2431− ni 0 env (PNoImplicits tm) = ni 0 env tm

2436+ ni 0 env (PHidden tm) = ni 0 env tm

2437+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2438+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2439+ ni 0 env (PNoImplicits tm) = ni 0 env tm

24322440

2433− 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

2441+ ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2442+ ni i env (PUnquote tm) = ni (i - 1) env tm

24352443

2436− ni i env tm = concatMap (ni i env) (children tm)

2444+ ni i env tm = concatMap (ni i env) (children tm)

24372445

24382446 niTacImp i env (TacImp _ _ scr) = ni i env scr

24392447 niTacImp _ _ _ = []

src/Idris/CaseSplit.hs+3−2

@@ -77,7 +77,7 @@ split n t'

7777 logElab 1 ("New patterns " ++ showSep ", "

7878 (map showTmImpls splits))

7979 let newPats_in = zipWith (replaceVar ctxt n) splits (repeat t)

80− logElab 4 ("Working from " ++ show t)

80+ logElab 4 ("Working from " ++ showTmImpls t)

8181 logElab 4 ("Trying " ++ showSep "\n"

8282 (map (showTmImpls) newPats_in))

8383 newPats_in <- mapM elabNewPat newPats_in

@@ -227,7 +227,8 @@ elabNewPat t = idrisCatch (do (tm, ty) <- elabVal recinfo ELHS t

227227 i <- getIState

228228 return (True, delab i tm))

229229 (\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

231232 return (False, t))

232233

233234findPats :: IState -> Type -> [PTerm]

src/Idris/Colours.hs+6−6

@@ -47,9 +47,9 @@ defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True False True

4747mkSGR :: IdrisColour -> [SGR]

4848mkSGR (IdrisColour c v u b i) =

4949 fg c ++

50− (if u then [SetUnderlining SingleUnderline] else []) ++

51− (if b then [SetConsoleIntensity BoldIntensity] else []) ++

52− (if i then [SetItalicized True] else [])

50+ [SetUnderlining SingleUnderline | u] ++

51+ [SetConsoleIntensity BoldIntensity | b] ++

52+ [SetItalicized True | i]

5353 where

5454 fg Nothing = []

5555 fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]

@@ -71,9 +71,9 @@ hEndColourise h _ = hSetSGR h [Reset]

7171colouriseWithSTX :: IdrisColour -> String -> String

7272colouriseWithSTX (IdrisColour c v u b i) str = setSGRCode sgr ++ "\STX" ++ str ++ setSGRCode [Reset] ++ "\STX"

7373 where sgr = fg c ++

74− (if u then [SetUnderlining SingleUnderline] else []) ++

75− (if b then [SetConsoleIntensity BoldIntensity] else []) ++

76− (if i then [SetItalicized True] else [])

74+ [SetUnderlining SingleUnderline | u] ++

75+ [SetConsoleIntensity BoldIntensity | b] ++

76+ [SetItalicized True | i]

7777 fg Nothing = []

7878 fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]

7979

src/Idris/Completion.hs+6−6

@@ -9,10 +9,10 @@ import Idris.AbsSyntaxTree

99import Idris.Help

1010import Idris.Imports (installedPackages)

1111import Idris.Colours

12−import Idris.ParseHelpers(opChars)

13−import qualified Idris.ParseExpr (constants, tactics)

14−import Idris.ParseExpr (TacticArg (..))

15−import Idris.REPLParser (allHelp, setOptions)

12+import Idris.Parser.Helpers(opChars)

13+import qualified Idris.Parser.Expr (constants, tactics)

14+import Idris.Parser.Expr (TacticArg (..))

15+import Idris.REPL.Parser (allHelp, setOptions)

1616import Control.Monad.State.Strict

1717

1818import Data.List

@@ -26,7 +26,7 @@ import System.Console.ANSI (Color)

2626commands = [ n | (names, _, _) <- allHelp ++ extraHelp, n <- names ]

2727

2828tacticArgs :: [(String, Maybe TacticArg)]

29−tacticArgs = [ (name, args) | (names, args, _) <- Idris.ParseExpr.tactics

29+tacticArgs = [ (name, args) | (names, args, _) <- Idris.Parser.Expr.tactics

3030 , name <- names ]

3131tactics = map fst tacticArgs

3232

@@ -48,7 +48,7 @@ names = do i <- get

4848 let ctxt = tt_ctxt i

4949 return . nub $

5050 mapMaybe (nameString . fst) (ctxtAlist ctxt) ++

51− "Type" : map fst Idris.ParseExpr.constants

51+ "Type" : map fst Idris.Parser.Expr.constants

5252

5353metavars :: Idris [String]

5454metavars = do i <- get

src/Idris/Core/CaseTree.hs+2−2

@@ -152,10 +152,10 @@ findCalls sc topargs = nub $ nu' topargs sc where

152152 nua ps (SucCase _ sc) = nu' ps sc

153153 nua ps (DefaultCase sc) = nu' ps sc

154154

155− nut ps (P Ref n _) | n `elem` ps = []

155+ nut ps (P _ n _) | n `elem` ps = []

156156 | otherwise = [(n, [])] -- tmp

157157 nut ps fn@(App _ f a)

158− | (P Ref n _, args) <- unApply fn

158+ | (P _ n _, args) <- unApply fn

159159 = if n `elem` ps then nut ps f ++ nut ps a

160160 else [(n, map argNames args)] ++ concatMap (nut ps) args

161161 | (P (TCon _ _) n _, _) <- unApply fn = []

src/Idris/Core/Evaluate.hs+13−10

@@ -12,7 +12,7 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC,

1212 addDatatype, addCasedef, simplifyCasedef, addOperator,

1313 lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact,

1414 lookupP, lookupP_all, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,

15− mapDefCtxt,

15+ mapDefCtxt,

1616 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName,

1717 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,

1818 isUniverse) where

@@ -247,18 +247,16 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

247247 | otherwise

248248 = do (u, ntimes) <- usable spec n ntimes_in

249249 if u then

250− do let val = lookupDefAcc n (spec || atRepl) ctxt

250+ do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt

251251 case val of

252252 [(Function _ tm, _)] | sUN "assert_total" `elem` stk ->

253253 ev ntimes (n:stk) True env tm

254254 [(Function _ tm, Public)] ->

255255 ev ntimes (n:stk) True env tm

256− [(Function _ tm, Hidden)] ->

257− ev ntimes (n:stk) True env tm

258256 [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty

259257 return $ VP nt n vty

260258 [(CaseOp ci _ _ _ _ cd, acc)]

261− | (acc /= Frozen || sUN "assert_total" `elem` stk) &&

259+ | (acc == Public || sUN "assert_total" `elem` stk) &&

262260 null (fst (cases_totcheck cd)) -> -- unoptimised version

263261 let (ns, tree) = getCases cd in

264262 if blockSimplify ci n stk

@@ -319,7 +317,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

319317 evApply ntimes' stk top env [l',t',arg'] d'

320318 -- Treat "assert_total" specially, as long as it's defined!

321319 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,

323321 at == txt "assert_total" && not simpl

324322 = ev ntimes (n : stk) top env arg

325323 ev ntimes stk top env (App _ f a)

@@ -347,7 +345,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

347345 = apply ntimes stk top env f args

348346

349347 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

351349 case val of

352350 [(CaseOp ci _ _ _ _ cd, acc)] ->

353351 let (ns, tree) = getCases cd in

@@ -373,10 +371,10 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

373371 | otherwise

374372 = do (u, ntimes) <- usable spec n ntimes_in

375373 if u then

376− do let val = lookupDefAcc n (spec || atRepl) ctxt

374+ do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt

377375 case val of

378376 [(CaseOp ci _ _ _ _ cd, acc)]

379− | acc /= Frozen || sUN "assert_total" `elem` stk ->

377+ | acc == Public || sUN "assert_total" `elem` stk ->

380378 -- unoptimised version

381379 let (ns, tree) = getCases cd in

382380 if blockSimplify ci n stk

@@ -746,11 +744,16 @@ instance Show Def where

746744-- Hidden => doesn't reduce and invisible to type checker

747745

748746data Accessibility = Public | Frozen | Hidden

749− deriving (Show, Eq)

747+ deriving (Eq, Ord)

750748{-!

751749deriving instance NFData Accessibility

752750!-}

753751

752+instance Show Accessibility where

753+ show Public = "public export"

754+ show Frozen = "export"

755+ show Hidden = "private"

756+

754757-- | The result of totality checking

755758data Totality = Total [Int] -- ^ well-founded arguments

756759 | Productive -- ^ productive

src/Idris/Core/ProofState.hs+10−1

@@ -206,6 +206,14 @@ mergeSolutions env ns = merge [] ns

206206 merge acc ns

207207 | otherwise = merge ((n, t): acc) ns

208208

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+

209217unify' :: Context -> Env ->

210218 (TT Name, Maybe Provenance) ->

211219 (TT Name, Maybe Provenance) ->

@@ -242,7 +250,8 @@ unify' ctxt env (topx, xfrom) (topy, yfrom) =

242250 -- problem for each.

243251 uns <- mergeSolutions env (u' ++ ns)

244252 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

246255 let (notu', probs_notu) = mergeNotunified env (holes ps) (notu ++ notunified ps)

247256 traceWhen (unifylog ps)

248257 ("Now solved: " ++ show ns' ++

src/Idris/Core/TT.hs+1−1

@@ -588,7 +588,7 @@ tcname (SN (MethodN _)) = True

588588tcname (SN (ParentN _ _)) = True

589589tcname _ = False

590590

591−implicitable (NS n _) = implicitable n

591+implicitable (NS n _) = False

592592implicitable (UN xs) | T.null xs = False

593593 | otherwise = isLower (T.head xs) || T.head xs == '_'

594594implicitable (MN _ x) = not (tnull x) && thead x /= '_'

src/Idris/Coverage.hs+3−1

@@ -135,6 +135,7 @@ validCoverageCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)

135135 = case (unApply topx, unApply topy) of

136136 ((P _ x _, _), (P _ y _, _)) -> x == y

137137 _ -> False

138+validCoverageCase ctxt (InfiniteUnify _ _ _) = False

138139validCoverageCase ctxt (CantConvert _ _ _) = False

139140validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e

140141validCoverageCase ctxt (Elaborating _ _ _ e) = validCoverageCase ctxt e

@@ -313,7 +314,7 @@ checkAllCovering fc done top n | not (n `elem` done)

313314 [Partial _] ->

314315 case lookupCtxt n (idris_callgraph i) of

315316 [cg] -> mapM_ (checkAllCovering fc (n : done) top)

316− (map fst (calls cg))

317+ (calls cg)

317318 _ -> return ()

318319 x -> return () -- stop if total

319320checkAllCovering _ _ _ _ = return ()

@@ -474,6 +475,7 @@ buildSCG (_, n) = do

474475 let newscg = buildSCG' ist (rights pats) args

475476 logCoverage 5 $ "SCG is: " ++ show newscg

476477 addToCG n ( cg { scg = newscg } )

478+ _ -> return () -- CG comes from a type declaration only

477479 [] -> logCoverage 5 $ "Could not build SCG for " ++ show n ++ "\n"

478480 x -> error $ "buildSCG: " ++ show (n, x)

479481

src/Idris/DeepSeq.hs+9−7

@@ -199,7 +199,8 @@ instance NFData IOption where

199199 opt_optimise

200200 opt_printdepth

201201 opt_evaltypes

202− opt_desugarnats) =

202+ opt_desugarnats

203+ opt_autoimpls) =

203204 rnf opt_logLevel

204205 `seq` rnf opt_typecase

205206 `seq` rnf opt_typeintype

@@ -224,6 +225,7 @@ instance NFData IOption where

224225 `seq` rnf opt_printdepth

225226 `seq` rnf opt_evaltypes

226227 `seq` rnf opt_desugarnats

228+ `seq` rnf opt_autoimpls

227229 `seq` ()

228230

229231instance NFData LanguageExt where

@@ -365,9 +367,9 @@ instance NFData LogCat where

365367 rnf _ = ()

366368

367369instance NFData CGInfo where

368− rnf (CGInfo x1 x2 x3 x4 x5)

370+ rnf (CGInfo x1 x2 x3)

369371 = rnf x1 `seq`

370− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

372+ rnf x2 `seq` rnf x3 `seq` ()

371373

372374instance NFData Fixity where

373375 rnf (Infixl x1) = rnf x1 `seq` ()

@@ -466,7 +468,7 @@ instance (NFData t) => NFData (PDecl' t) where

466468 rnf x9 `seq`

467469 rnf x10 `seq`

468470 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)

470472 = rnf x1 `seq`

471473 rnf x2 `seq`

472474 rnf x3 `seq`

@@ -475,7 +477,7 @@ instance (NFData t) => NFData (PDecl' t) where

475477 rnf x6 `seq`

476478 rnf x7 `seq`

477479 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` ()

479481 rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

480482 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

481483 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -696,8 +698,8 @@ instance NFData IState where

696698 rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20

697699 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40

698700 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)

700702 = 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`

701703 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`

702704 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) =

317317 flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)

318318 flagUnique t = t

319319pprintErr' i (CantSolveGoal x env) =

320− text "Can't solve goal " <>

320+ text "Can't find a value of type " <>

321321 indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delabSugared i x))) <>

322322 if (opt_errContext (idris_options i)) then line <> showSc i env else empty

323323pprintErr' i (UnifyScope n out tm env) =

src/Idris/Directives.hs+6−2

@@ -21,8 +21,10 @@ directiveAction (DLink cgn obj) = do dirs <- allImportDirs

2121 addIBC (IBCObj cgn obj) -- just name, search on loading ibc

2222 addObjectFile cgn o

2323

24−directiveAction (DFlag cgn flag) = do addIBC (IBCCGFlag cgn flag)

25− addFlag cgn flag

24+directiveAction (DFlag cgn flag) = do

25+ let flags = words flag

26+ mapM_ (\f -> addIBC (IBCCGFlag cgn f)) flags

27+ mapM_ (addFlag cgn) flags

2628

2729directiveAction (DInclude cgn hdr) = do addHdr cgn hdr

2830 addIBC (IBCHeader cgn hdr)

@@ -68,6 +70,8 @@ directiveAction (DDeprecate n reason)

6870 = do n' <- disambiguate n

6971 addDeprecated n' reason

7072 addIBC (IBCDeprecate n' reason)

73+directiveAction (DAutoImplicits b)

74+ = setAutoImpls b

7175directiveAction (DUsed fc fn arg) = addUsedName fc fn arg

7276

7377disambiguate :: Name -> Idris Name

src/Idris/Docs.hs+3−3

@@ -19,7 +19,7 @@ import Data.Maybe

1919import Data.List

2020import qualified Data.Text as T

2121

22−-- TODO: Only include names with public/abstract accessibility

22+-- TODO: Only include names with public/export accessibility

2323--

2424-- Issue #1573 on the Issue tracker.

2525-- https://github.com/idris-lang/Idris-dev/issues/1573

@@ -319,8 +319,8 @@ docClass n ci

319319 namedInst n@(UN _) = Just n

320320 namedInst _ = Nothing

321321

322− getDInst (PInstance _ _ _ _ _ _ _ _ t _ _) = Just t

323− getDInst _ = Nothing

322+ getDInst (PInstance _ _ _ _ _ _ _ _ _ t _ _) = Just t

323+ getDInst _ = Nothing

324324

325325 isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ _ nm) args'))

326326 = 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

138138

139139 -- TODO: probably should normalise

140140 checkDefaultSuperclassInstance :: PDecl -> Idris ()

141− checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n _ ps _ _ _)

141+ checkDefaultSuperclassInstance (PInstance _ _ _ fc cs _ n _ ps _ _ _)

142142 = do when (not $ null cs) . tclift

143143 $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))

144144 i <- getIState

@@ -184,7 +184,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

184184

185185 tydecl (PTy _ _ _ _ _ _ _ _) = True

186186 tydecl _ = False

187− instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _) = True

187+ instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _ _) = True

188188 instdecl _ = False

189189 clause (PClauses _ _ _ _) = True

190190 clause _ = False

src/Idris/Elab/Clause.hs+32−18

@@ -80,10 +80,11 @@ elabClauses info' fc opts n_in cs =

8080 let atys = map snd (getArgTys fty)

8181 cs_elab <- mapM (elabClause info opts)

8282 (zip [0..] cs)

83+ ctxt <- getContext

8384 -- pats_raw is the version we'll work with at compile time:

8485 -- no simplification or PE

8586 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

8788 logElab 3 $ "Elaborated patterns:\n" ++ show pats_raw

8889

8990 solveDeferred n

@@ -93,6 +94,7 @@ elabClauses info' fc opts n_in cs =

9394 addIBC (IBCOpt n)

9495

9596 ist <- getIState

97+ ctxt <- getContext

9698 -- Don't apply rules if this is a partial evaluation definition,

9799 -- or we'll make something that just runs itself!

98100 let tpats = case specNames opts of

@@ -103,7 +105,7 @@ elabClauses info' fc opts n_in cs =

103105 -- RHS

104106 pe_tm <- doPartialEval ist tpats

105107 let pats_pe = if petrans

106− then map (simple_lhs (tt_ctxt ist)) pe_tm

108+ then map (simple_lhs ctxt) pe_tm

107109 else pats_raw

108110

109111 let tcase = opt_typecase (idris_options ist)

@@ -183,7 +185,8 @@ elabClauses info' fc opts n_in cs =

183185 -- pdef' is the version that gets compiled for run-time,

184186 -- so we start from the partially evaluated version

185187 pdef_in' <- applyOpts $ map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) pdef_pe

186− let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'

188+ ctxt <- getContext

189+ let pdef' = map (simple_rt ctxt) pdef_in'

187190

188191 logElab 5 $ "After data structure transformations:\n" ++ show pdef'

189192

@@ -241,24 +244,28 @@ elabClauses info' fc opts n_in cs =

241244 ctxt

242245 setContext ctxt'

243246 addIBC (IBCDef n)

247+ addDefinedName n

244248 setTotality n tot

245249 when (not reflect && PEGenerated `notElem` opts) $

246250 do totcheck (fc, n)

247251 defer_totcheck (fc, n)

248252 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

249253 i <- getIState

250− case lookupDef n (tt_ctxt i) of

254+ ctxt <- getContext

255+ case lookupDef n ctxt of

251256 (CaseOp _ _ _ _ _ cd : _) ->

252− let (scargs, sc) = cases_compiletime cd

253− (scargs', sc') = cases_runtime cd in

254− do let calls = findCalls sc' scargs'

255− let used = findUsedArgs sc' scargs'

257+ let (scargs, sc) = cases_compiletime cd in

258+ do let calls = map fst $ findCalls sc scargs

256259 -- let scg = buildSCG i sc scargs

257260 -- 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

260− addToCG n cg

261− addToCalledG n (nub (map fst calls)) -- plus names in type!

261+ logElab 2 $ "Called names: " ++ show calls

262+ -- if the definition is public, make sure

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

262269 addIBC (IBCCG n)

263270 _ -> return ()

264271 return ()

@@ -353,11 +360,12 @@ elabPE info fc caller r =

353360 mkSpecialised :: (Name, [(PEArgType, Term)]) -> Idris [(Term, Term)]

354361 mkSpecialised specapp_in = do

355362 ist <- getIState

363+ ctxt <- getContext

356364 let (specTy, specapp) = getSpecTy ist specapp_in

357365 let (n, newnm, specdecl) = getSpecClause ist specapp

358366 let lhs = pe_app specdecl

359367 let rhs = pe_def specdecl

360− let undef = case lookupDefExact newnm (tt_ctxt ist) of

368+ let undef = case lookupDefExact newnm ctxt of

361369 Nothing -> True

362370 _ -> False

363371 logElab 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))

@@ -370,7 +378,7 @@ elabPE info fc caller r =

370378 let cgns' = filter (\x -> x /= n &&

371379 notStatic ist x) cgns

372380 -- 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

374382 [Total _] -> 65536

375383 [Productive] -> 16

376384 _ -> 1

@@ -485,7 +493,7 @@ checkPossible info fc tcgen fname lhs_in

485493 processTacticDecls info newDecls

486494 sendHighlighting highlights

487495 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

489497 OK _ -> return True

490498 err -> return False

491499 -- 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

558566 (Msg "unexpected patterns outside of \"with\" block")))

559567

560568 -- 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

562570 [t] -> t

563571 _ -> error "Can't happen (elabClause function type)"

564572 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

602610

603611 -- If we're inferring metavariables in the type, don't recheck,

604612 -- because we're only doing this to try to work out those metavariables

613+ ctxt <- getContext

605614 (clhs_c, clhsty) <- if not inf

606615 then recheckC_borrowing False (PEGenerated `notElem` opts)

607616 [] fc id [] lhs_tm

@@ -627,6 +636,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

627636 logElab 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

628637 -- Elaborate where block

629638 ist <- getIState

639+ ctxt <- getContext

640+

630641 windex <- getName

631642 let decls = nub (concatMap declared whereblock)

632643 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

635646 -- Unique arguments must be passed to the where block explicitly

636647 -- (since we can't control "usage" easlily otherwise). Remove them

637648 -- from newargs here

638− let uniqargs = findUnique (tt_ctxt ist) [] lhs_tm

649+ let uniqargs = findUnique ctxt [] lhs_tm

639650 let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all

640651

641652 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)

798809 -- pattern bindings

799810 i <- getIState

800811 -- 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

802813 [t] -> t

803814 _ -> error "Can't happen (elabClause function type)"

804815 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)

819830 processTacticDecls info newDecls

820831 sendHighlighting highlights

821832

833+ ctxt <- getContext

822834 let lhs_tm = orderPats (getInferTerm lhs')

823835 let lhs_ty = getInferType lhs'

824836 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)

852864 addDeferred def''

853865 mapM_ (elabCaseBlock info opts) is

854866 logElab 5 ("Checked wval " ++ show wval')

867+

868+ ctxt <- getContext

855869 (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')

856870 let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)

857871 let cwvalN = explicitNames (normalise ctxt [] cwval)

src/Idris/Elab/Instance.hs+8−4

@@ -55,13 +55,14 @@ elabInstance :: ElabInfo -> SyntaxInfo ->

5555 [(Name, Docstring (Either Err PTerm))] ->

5656 ElabWhat -> -- phase

5757 FC -> [(Name, PTerm)] -> -- constraints

58+ Accessibility ->

5859 Name -> -- the class

5960 FC -> -- precise location of class name

6061 [PTerm] -> -- class parameters (i.e. instance)

6162 PTerm -> -- full instance type

6263 Maybe Name -> -- explicit name

6364 [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

6566 i <- getIState

6667 (n, ci) <- case lookupCtxtName n (idris_classes i) of

6768 [c] -> return c

@@ -70,6 +71,9 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

7071 (CantResolveAlts (map fst cs))

7172 let constraint = PApp fc (PRef fc [] n) (map pexp ps)

7273 let iname = mkiname n (namespace info) ps expn

74+ putIState (i { hide_list = addDef iname acc (hide_list i) })

75+ i <- getIState

76+

7377 let emptyclass = null (class_methods ci)

7478 when (what /= EDefns) $ do

7579 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

159163 Just m -> sNS (SN (sInstanceN n' (map show ps'))) m

160164 Just nm -> nm

161165

162− substInstance ips pnames (PInstance doc argDocs syn _ cs 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

166+ substInstance ips pnames (PInstance doc argDocs syn _ cs acc n nfc ps t expn ds)

167+ = PInstance doc argDocs syn fc cs acc n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds

164168

165− isOverlapping i (PInstance doc argDocs syn _ _ n nfc ps t expn _)

169+ isOverlapping i (PInstance doc argDocs syn _ _ _ n nfc ps t expn _)

166170 = case lookupCtxtName n (idris_classes i) of

167171 [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in

168172 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

22

33import Idris.Core.Elaborate hiding (Tactic(..))

44import Idris.Core.TT

@@ -171,5 +171,3 @@ extractUnquotes n (PRunElab fc tm ns)

171171extractUnquotes n (PConstSugar fc tm)

172172 = extractUnquotes n tm

173173extractUnquotes n x = return (x, []) -- no subterms!

174−

175−

src/Idris/Elab/Record.hs+1−1

@@ -17,7 +17,7 @@ import Idris.DeepSeq

1717import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

1818import IRTS.Lang

1919

20−import Idris.ParseExpr (tryFullExpr)

20+import Idris.Parser.Expr (tryFullExpr)

2121

2222import Idris.Elab.Type

2323import Idris.Elab.Data

src/Idris/Elab/Term.hs+10−10

@@ -20,7 +20,7 @@ import Idris.Core.Typecheck (check, recheck, converts, isType)

2020import Idris.Core.WHNF (whnf)

2121import Idris.Coverage (buildSCG, checkDeclTotality, genClauses, recoverableCoverage, validCoverageCase)

2222import Idris.ErrReverse (errReverse)

23−import Idris.ElabQuasiquote (extractUnquotes)

23+import Idris.Elab.Quasiquote (extractUnquotes)

2424import Idris.Elab.Utils

2525import Idris.Reflection

2626import qualified Util.Pretty as U

@@ -236,6 +236,7 @@ elab ist info emode opts fn tm

236236 pattern = emode == ELHS

237237 intransform = emode == ETransLHS

238238 bindfree = emode == ETyDecl || emode == ELHS || emode == ETransLHS

239+ autoimpls = opt_autoimpls (idris_options ist)

239240

240241 get_delayed_elab est =

241242 let ds = delayed_elab est in

@@ -614,7 +615,8 @@ elab ist info emode opts fn tm

614615 [] -> False

615616 _ -> True

616617 bindable (NS _ _) = False

617− bindable n = implicitable n

618+ bindable (MN _ _) = True

619+ bindable n = implicitable n && autoimpls

618620 elab' ina _ f@(PInferRef fc hls n) = elab' ina (Just fc) (PApp NoFC f [])

619621 elab' ina fc' tm@(PRef fc hls n)

620622 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

@@ -2476,8 +2478,10 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

24762478 OK hs -> return hs

24772479

24782480 -- 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

24792483 ctxt <- getContext

2480− let results = map (normalise ctxt []) (map fst handlers)

2484+ let results = map (normaliseAll ctxt []) (map fst handlers)

24812485 logElab 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

24822486

24832487 -- 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 =

25492553 -- we refer to, so that if they aren't total, the whole

25502554 -- thing won't be.

25512555 let (scargs, sc) = cases_compiletime cd

2552− (scargs', sc') = cases_runtime cd

2553− calls = 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− addToCG n cg

2558− addToCalledG n (nub (map fst calls))

2556+ calls = map fst $ findCalls sc scargs

2557+ in do logElab 2 $ "Called names in reflected elab: " ++ show calls

2558+ addCalls n calls

25592559 addIBC $ IBCCG n

25602560 Just _ -> return () -- TODO throw internal error

25612561 Nothing -> return ()

src/Idris/Elab/Type.hs+13

@@ -102,6 +102,18 @@ buildType info syn fc opts n ty' = do

102102 logElab 3 ("Implicit " ++ show n ++ " " ++ show impls)

103103 addIBC (IBCImp n)

104104

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+

105117 when (Constructor `notElem` opts) $ do

106118 let pnames = getParamsInType i [] impls cty

107119 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

163175 let usety = if norm then nty' else nty

164176 ds <- checkDef fc iderr [(n, (-1, Nothing, usety, []))]

165177 addIBC (IBCDef n)

178+ addDefinedName n

166179 let ds' = map (\(n, (i, top, fam, ns)) -> (n, (i, top, fam, ns, True))) ds

167180 addDeferred ds'

168181 setFlags n opts'

src/Idris/Elab/Utils.hs+16

@@ -314,3 +314,19 @@ mkStaticTy ns (PPi p n fc ty sc)

314314 | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)

315315 | otherwise = PPi p n fc ty (mkStaticTy ns sc)

316316mkStaticTy 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)

242242 | what /= EDefns

243243 = do logElab 1 $ "Elaborating class " ++ show n

244244 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)

246246 = 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

248248elabDecl' what info (PRecord doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn)

249249 = do logElab 1 $ "Elaborating record " ++ show name

250250 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 @@

33

44module Idris.IBC (loadIBC, loadPkgIndex,

55 writeIBC, writePkgIndex,

6− hasValidIBCVersion) where

6+ hasValidIBCVersion, IBCPhase(..)) where

77

88import Idris.Core.Evaluate

99import Idris.Core.TT

@@ -40,10 +40,18 @@ import System.Directory

4040import Codec.Archive.Zip

4141

4242ibcVersion :: 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)

4451

4552data IBCFile = IBCFile { ver :: Word16,

4653 sourcefile :: FilePath,

54+ ibc_reachablenames :: ![Name],

4755 ibc_imports :: ![(Bool, FilePath)],

4856 ibc_importdirs :: ![FilePath],

4957 ibc_implicits :: ![(Name, [PArg])],

@@ -62,13 +70,10 @@ data IBCFile = IBCFile { ver :: Word16,

6270 ibc_cgflags :: ![(Codegen, String)],

6371 ibc_dynamic_libs :: ![String],

6472 ibc_hdrs :: ![(Codegen, String)],

65− ibc_access :: ![(Name, Accessibility)],

66− ibc_total :: ![(Name, Totality)],

6773 ibc_totcheckfail :: ![(FC, String)],

6874 ibc_flags :: ![(Name, [FnOpt])],

6975 ibc_fninfo :: ![(Name, FnInfo)],

7076 ibc_cg :: ![(Name, CGInfo)],

71− ibc_defs :: ![(Name, Def)],

7277 ibc_docstrings :: ![(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))],

7378 ibc_moduledocs :: ![(Name, Docstring D.DocTerm)],

7479 ibc_transforms :: ![(Name, (Term, Term))],

@@ -87,7 +92,10 @@ data IBCFile = IBCFile { ver :: Word16,

8792 ibc_usage :: ![(Name, Int)],

8893 ibc_exports :: ![Name],

8994 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)]

9199 }

92100 deriving Show

93101{-!

@@ -95,7 +103,7 @@ deriving instance Binary IBCFile

95103!-}

96104

97105initIBC :: IBCFile

98−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] []

106+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] [] [] [] []

99107

100108hasValidIBCVersion :: FilePath -> Idris Bool

101109hasValidIBCVersion fp = do

@@ -106,8 +114,9 @@ hasValidIBCVersion fp = do

106114 return (ver == ibcVersion)

107115

108116loadIBC :: Bool -- ^ True = reexport, False = make everything private

117+ -> IBCPhase

109118 -> FilePath -> Idris ()

110−loadIBC reexport fp

119+loadIBC reexport phase fp

111120 = do imps <- getImported

112121 let redo = case lookup fp imps of

113122 Nothing -> True

@@ -118,15 +127,16 @@ loadIBC reexport fp

118127 case toArchiveOrFail archiveFile of

119128 Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"

120129 ++ "Please clean and rebuild it."

121− Right archive -> do process reexport archive fp

130+ Right archive -> do process reexport phase archive fp

122131 addImported reexport fp

132+-- dumpTT

123133

124134-- | Load an entire package from its index file

125135loadPkgIndex :: String -> Idris ()

126136loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir

127137 addImportDir (ddir </> pkg)

128138 fp <- findPkgIndex pkg

129− loadIBC True fp

139+ loadIBC True IBC_Building fp

130140

131141

132142makeEntry :: (Binary b) => String -> [b] -> Maybe Entry

@@ -156,13 +166,10 @@ entries i = catMaybes [Just $ toEntry "ver" 0 (encode $ ver i),

156166 makeEntry "ibc_cgflags" (ibc_cgflags i),

157167 makeEntry "ibc_dynamic_libs" (ibc_dynamic_libs i),

158168 makeEntry "ibc_hdrs" (ibc_hdrs i),

159− makeEntry "ibc_access" (ibc_access i),

160− makeEntry "ibc_total" (ibc_total i),

161169 makeEntry "ibc_totcheckfail" (ibc_totcheckfail i),

162170 makeEntry "ibc_flags" (ibc_flags i),

163171 makeEntry "ibc_fninfo" (ibc_fninfo i),

164172 makeEntry "ibc_cg" (ibc_cg i),

165− makeEntry "ibc_defs" (ibc_defs i),

166173 makeEntry "ibc_docstrings" (ibc_docstrings i),

167174 makeEntry "ibc_moduledocs" (ibc_moduledocs i),

168175 makeEntry "ibc_transforms" (ibc_transforms i),

@@ -181,7 +188,10 @@ entries i = catMaybes [Just $ toEntry "ver" 0 (encode $ ver i),

181188 makeEntry "ibc_usage" (ibc_usage i),

182189 makeEntry "ibc_exports" (ibc_exports i),

183190 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)]

185195

186196writeArchive :: FilePath -> IBCFile -> Idris ()

187197writeArchive 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

315325 Just e -> return $! (force . decode . fromEntry) e

316326

317327process :: Bool -- ^ Reexporting

328+ -> IBCPhase

318329 -> Archive -> FilePath -> Idris ()

319−process reexp i fn = do

330+process reexp phase i fn = do

320331 ver <- getEntry 0 "ver" i

321332 when (ver /= ibcVersion) $ do

322333 logIBC 1 "ibc out of date"

@@ -328,7 +339,7 @@ process reexp i fn = do

328339 srcok <- runIO $ doesFileExist source

329340 when srcok $ timestampOlder source fn

330341 pImportDirs =<< getEntry [] "ibc_importdirs" i

331− pImports reexp =<< getEntry [] "ibc_imports" i

342+ pImports reexp phase =<< getEntry [] "ibc_imports" i

332343 pImps =<< getEntry [] "ibc_implicits" i

333344 pFixes =<< getEntry [] "ibc_fixes" i

334345 pStatics =<< getEntry [] "ibc_statics" i

@@ -345,12 +356,9 @@ process reexp i fn = do

345356 pCGFlags =<< getEntry [] "ibc_cgflags" i

346357 pDyLibs =<< getEntry [] "ibc_dynamic_libs" i

347358 pHdrs =<< getEntry [] "ibc_hdrs" i

348− pDefs reexp =<< getEntry [] "ibc_defs" i

349359 pPatdefs =<< getEntry [] "ibc_patdefs" i

350− pAccess reexp =<< getEntry [] "ibc_access" i

351360 pFlags =<< getEntry [] "ibc_flags" i

352361 pFnInfo =<< getEntry [] "ibc_fninfo" i

353− pTotal =<< getEntry [] "ibc_total" i

354362 pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i

355363 pCG =<< getEntry [] "ibc_cg" i

356364 pDocs =<< getEntry [] "ibc_docstrings" i

@@ -371,6 +379,9 @@ process reexp i fn = do

371379 pExports =<< getEntry [] "ibc_exports" i

372380 pAutoHints =<< getEntry [] "ibc_autohints" i

373381 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

374385

375386timestampOlder :: FilePath -> FilePath -> Idris ()

376387timestampOlder src ibc = do srct <- runIO $ getModificationTime src

@@ -404,8 +415,8 @@ pDeprecate ns = mapM_ (\(n,reason) -> addDeprecated n reason) ns

404415pImportDirs :: [FilePath] -> Idris ()

405416pImportDirs fs = mapM_ addImportDir fs

406417

407−pImports :: Bool -> [(Bool, FilePath)] -> Idris ()

408−pImports reexp fs

418+pImports :: Bool -> IBCPhase -> [(Bool, FilePath)] -> Idris ()

419+pImports reexp phase fs

409420 = do mapM_ (\(re, f) ->

410421 do i <- getIState

411422 ibcsd <- valIBCSubDir i

@@ -414,6 +425,9 @@ pImports reexp fs

414425-- if (f `elem` imported i)

415426-- then logLvl 1 $ "Already read " ++ f

416427 putIState (i { imported = f : imported i })

428+ let phase' = case phase of

429+ IBC_REPL _ -> IBC_REPL False

430+ p -> p

417431 case fp of

418432 LIDR fn -> do

419433 logIBC 1 $ "Failed at " ++ fn

@@ -421,7 +435,7 @@ pImports reexp fs

421435 IDR fn -> do

422436 logIBC 1 $ "Failed at " ++ fn

423437 ifail "Must be an ibc"

424− IBC fn src -> loadIBC (reexp && re) fn)

438+ IBC fn src -> loadIBC (reexp && re) phase' fn)

425439 fs

426440

427441pImps :: [(Name, [PArg])] -> Idris ()

@@ -520,10 +534,7 @@ pDefs reexp ds

520534 _ -> do logIBC 1 $ "SOLVING " ++ show n

521535 solveDeferred n

522536 updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

523−-- logLvl 1 $ "Added " ++ show (n, d')

524− if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n

525− setAccessibility n Hidden

526− else logIBC 1 $ "Exporting " ++ show n) ds

537+ ) ds

527538 where

528539 updateDef (CaseOp c t args o s cd)

529540 = do o' <- mapM updateOrig o

@@ -537,11 +548,9 @@ pDefs reexp ds

537548 return $ Right (l', r')

538549

539550 updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

540− = do t' <- updateSC t

541− c' <- updateSC c

542− i' <- updateSC i

551+ = do c' <- updateSC c

543552 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')

545554

546555 updateSC (Case t n alts) = do alts' <- mapM updateAlt alts

547556 return (Case t n alts')

@@ -562,19 +571,28 @@ pDefs reexp ds

562571 updateAlt (DefaultCase t) = do t' <- updateSC t

563572 return (DefaultCase t')

564573

565− update (P t n ty) = do n' <- getSymbol n

566− return $ P t n' ty

567− update (App s f a) = liftM2 (App s) (update f) (update a)

568− update (Bind n b sc) = do b' <- updateB b

569− sc' <- update sc

570− return $ Bind n b' sc'

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+

583+ update' (P t n ty) = do n' <- getSymbol n

584+ return $ P t n' ty

585+ update' (App s f a) = liftM2 (App s) (update' f) (update' a)

586+ update' (Bind n b sc) = do b' <- updateB b

587+ sc' <- update sc

588+ return $ Bind n b' sc'

571589 where

572− updateB (Let t v) = liftM2 Let (update t) (update v)

573− updateB b = do ty' <- update (binderTy b)

590+ updateB (Let t v) = liftM2 Let (update' t) (update' v)

591+ updateB b = do ty' <- update' (binderTy b)

574592 return (b { binderTy = ty' })

575− update (Proj t i) = do t' <- update t

576− return $ Proj t' i

577− update t = return t

593+ update' (Proj t i) = do t' <- update' t

594+ return $ Proj t' i

595+ update' t = return t

578596

579597pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris ()

580598pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds

@@ -584,12 +602,22 @@ pMDocs ds = mapM_ (\ (n, d) -> updateIState (\i ->

584602 i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds

585603

586604pAccess :: Bool -- ^ Reexporting?

605+ -> IBCPhase

587606 -> [(Name, Accessibility)] -> Idris ()

588−pAccess reexp ds

607+pAccess reexp phase ds

589608 = mapM_ (\ (n, a_in) ->

590609 do let a = if reexp then a_in else Hidden

591610 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

593621

594622pFlags :: [(Name, [FnOpt])] -> Idris ()

595623pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds

@@ -753,18 +781,14 @@ instance Binary SizeChange where

753781 _ -> error "Corrupted binary data for SizeChange"

754782

755783instance Binary CGInfo where

756− put (CGInfo x1 x2 x3 x4 x5)

784+ put (CGInfo x1 x2 x3)

757785 = do put x1

758− put x2

759786-- put x3 -- Already used SCG info for totality check

760− put x4

761− put x5

787+ put x3

762788 get

763789 = do x1 <- get

764− x2 <- get

765− x4 <- get

766− x5 <- get

767− return (CGInfo x1 x2 [] x4 x5)

790+ x3 <- get

791+ return (CGInfo x1 [] x3)

768792

769793instance Binary CaseType where

770794 put x = case x of

@@ -883,13 +907,13 @@ instance Binary Def where

883907 put x2

884908 -- all primitives just get added at the start, don't write

885909 Operator x1 x2 x3 -> do return ()

886− CaseOp x1 x2 x2a x3 x3a x4 -> do putWord8 3

887− put x1

888− put x2

889− put x2a

890− put x3

891− -- no x3a

892− put x4

910+ -- no need to add/load original patterns, because they're not

911+ -- used again after totality checking

912+ CaseOp x1 x2 x3 _ _ x4 -> do putWord8 3

913+ put x1

914+ put x2

915+ put x3

916+ put x4

893917 get

894918 = do i <- getWord8

895919 case i of

@@ -903,10 +927,10 @@ instance Binary Def where

903927 3 -> do x1 <- get

904928 x2 <- get

905929 x3 <- get

906− x4 <- get

930+-- x4 <- get

907931 -- x3 <- get always []

908932 x5 <- get

909− return (CaseOp x1 x2 x3 x4 [] x5)

933+ return (CaseOp x1 x2 x3 [] [] x5)

910934 _ -> error "Corrupted binary data for Def"

911935

912936instance Binary Accessibility where

@@ -1235,7 +1259,7 @@ instance (Binary t) => Binary (PDecl' t) where

12351259 put x10

12361260 put x11

12371261 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 ->

12391263 do putWord8 8

12401264 put x1

12411265 put x2

@@ -1248,6 +1272,7 @@ instance (Binary t) => Binary (PDecl' t) where

12481272 put x9

12491273 put x10

12501274 put x11

1275+ put x12

12511276 PDSL x1 x2 -> do putWord8 9

12521277 put x1

12531278 put x2

@@ -1362,7 +1387,8 @@ instance (Binary t) => Binary (PDecl' t) where

13621387 x9 <- get

13631388 x10 <- get

13641389 x11 <- get

1365− return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

1390+ x12 <- get

1391+ return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)

13661392 9 -> do x1 <- get

13671393 x2 <- get

13681394 return (PDSL x1 x2)

src/Idris/IdrisDoc.hs+1−1

@@ -10,7 +10,7 @@ import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),

1010import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,

1111 Accessibility (..), isDConName, isFnName,

1212 isTConName)

13−import Idris.ParseHelpers (opChars)

13+import Idris.Parser.Helpers (opChars)

1414import Idris.AbsSyntax

1515import Idris.Docs

1616import Idris.Docstrings (nullDocstring)

src/Idris/Interactive.hs+74−42

@@ -76,7 +76,7 @@ addClauseFrom fn updatefile l n = do

7676 getIndent i n xs | take 9 xs == "instance " = i

7777 getIndent i n xs | take (length n) xs == n = i

7878 getIndent i n (x : xs) = getIndent (i + 1) n xs

79−

79+

8080 getAppName (PApp _ r _) = getAppName r

8181 getAppName (PRef _ _ r) = r

8282 getAppName (PTyped n _) = getAppName n

@@ -120,7 +120,7 @@ addMissing fn updatefile l n

120120 if updatefile

121121 then do let fb = fn ++ "~"

122122 runIO $ writeSource fb (unlines (before ++ nonblank)

123− ++ extras ++

123+ ++ extras ++

124124 (if null extras then ""

125125 else "\n" ++ unlines rest))

126126 runIO $ copyFile fb fn

@@ -193,7 +193,7 @@ makeCase fn updatefile l n

193193 case findSubstr ('?':n) line of

194194 Just (before, pos, after) ->

195195 [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 ' ') ++

197197 "case_val => ?" ++ n ++ (if b then ")" else "")

198198 ++ after]

199199 Nothing -> fail "No such metavariable"

@@ -208,7 +208,7 @@ makeCase fn updatefile l n

208208

209209 findSubstr n xs = findSubstr' [] 0 n xs

210210

211− findSubstr' acc i n xs | take (length n) xs == n

211+ findSubstr' acc i n xs | take (length n) xs == n

212212 = Just (reverse acc, i, drop (length n) xs)

213213 findSubstr' acc i n [] = Nothing

214214 findSubstr' acc i n (x : xs) = findSubstr' (x : acc) (i + 1) n xs

@@ -217,7 +217,7 @@ makeCase fn updatefile l n

217217

218218

219219

220−doProofSearch :: FilePath -> Bool -> Bool ->

220+doProofSearch :: FilePath -> Bool -> Bool ->

221221 Int -> Name -> [Name] -> Maybe Int -> Idris ()

222222doProofSearch fn updatefile rec l n hints Nothing

223223 = doProofSearch fn updatefile rec l n hints (Just 20)

@@ -230,7 +230,7 @@ doProofSearch fn updatefile rec l n hints (Just depth)

230230 [] -> return n

231231 ns -> ierror (CantResolveAlts ns)

232232 i <- getIState

233− let (top, envlen, psnames, _)

233+ let (top, envlen, psnames, _)

234234 = case lookup mn (idris_metavars i) of

235235 Just (t, e, ns, False) -> (t, e, ns, False)

236236 _ -> (Nothing, 0, [], True)

@@ -238,7 +238,7 @@ doProofSearch fn updatefile rec l n hints (Just depth)

238238 let body t = PProof [Try (TSeq Intros (ProofSearch rec False depth t psnames hints))

239239 (ProofSearch rec False depth t psnames hints)]

240240 let def = PClause fc mn (PRef fc [] mn) [] (body top) []

241− newmv <- idrisCatch

241+ newmv_pre <- idrisCatch

242242 (do elabDecl' EAll recinfo (PClauses fc [] mn [def])

243243 (tm, ty) <- elabVal recinfo ERHS (PRef fc [] mn)

244244 ctxt <- getContext

@@ -249,10 +249,11 @@ doProofSearch fn updatefile rec l n hints (Just depth)

249249 (dropCtxt envlen

250250 (delab i (fst (specialise ctxt [] [(mn, 1)] tm))))))

251251 (\e -> return ("?" ++ show n))

252+ let newmv = guessBrackets False tyline (show n) newmv_pre

252253 if updatefile then

253254 do let fb = fn ++ "~"

254255 runIO $ writeSource fb (unlines before ++

255− updateMeta False tyline (show n) newmv ++ "\n"

256+ updateMeta tyline (show n) newmv ++ "\n"

256257 ++ unlines later)

257258 runIO $ copyFile fb fn

258259 else iPrintResult newmv

@@ -270,18 +271,34 @@ doProofSearch fn updatefile rec l n hints (Just depth)

270271 nsroot (SN (WhereN _ _ n)) = nsroot n

271272 nsroot n = n

272273

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

274289 | length cs >= length n

275290 = case splitAt (length n) cs of

276291 (mv, c:cs) ->

277292 if ((isSpace c || c == ')' || c == '}') && mv == n)

278− then addBracket brack new ++ (c : cs)

279− else '?' : mv ++ c : updateMeta True cs n new

293+ then addBracket brack new

294+ else guessBrackets True cs n new

280295 (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv

281−updateMeta brack ('=':cs) n new = '=':updateMeta False cs n new

282−updateMeta brack (c:cs) n new

283− = c : updateMeta (brack || not (isSpace c)) cs n new

284−updateMeta brack [] 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

299+guessBrackets brack (c:cs) n new

300+ = guessBrackets (brack || not (isSpace c)) cs n new

301+guessBrackets brack [] n new = ""

285302

286303checkProv line n = isProv' False line n

287304 where

@@ -291,7 +308,7 @@ checkProv line n = isProv' False line n

291308 isProv' _ ('}':cs) n = isProv' True cs n

292309 isProv' p (_:cs) n = isProv' p cs n

293310 isProv' _ [] n = False

294−

311+

295312addBracket False new = new

296313addBracket True new@('(':xs) | last xs == ')' = new

297314addBracket True new | any isSpace new = '(' : new ++ ")"

@@ -305,7 +322,7 @@ makeLemma fn updatefile l n

305322

306323 -- if the name is in braces, rather than preceded by a ?, treat it

307324 -- as a lemma in a provisional definition

308−

325+

309326 let isProv = checkProv tyline (show n)

310327

311328 ctxt <- getContext

@@ -320,13 +337,14 @@ makeLemma fn updatefile l n

320337

321338 if (not isProv) then do

322339 let skip = guessImps i (tt_ctxt i) mty

323− let classes = guessClasses i (tt_ctxt i) mty

340+ let impty = stripMNBind skip margs (delab i mty)

341+ let classes = guessClasses i (tt_ctxt i) [] (allNamesIn impty) mty

324342

325− let lem = show n ++ " : " ++

343+ let lem = show n ++ " : " ++

326344 constraints i classes mty ++

327345 showTmOpts (defaultPPOption { ppopt_pinames = True })

328− (stripMNBind skip margs (delab i mty))

329− let lem_app = show n ++ appArgs skip margs mty

346+ impty

347+ let lem_app = guessBrackets False tyline (show n) (show n ++ appArgs skip margs mty)

330348

331349 if updatefile then

332350 do let fb = fn ++ "~"

@@ -362,19 +380,26 @@ makeLemma fn updatefile l n

362380 where getIndent s = length (takeWhile isSpace s)

363381

364382 appArgs skip 0 _ = ""

365− appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc)

383+ appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc)

366384 | (thead c /= '_' && n `notElem` skip)

367385 = " " ++ show n ++ appArgs skip (i - 1) sc

368386 appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc

369387 appArgs skip i _ = ""

370388

371− stripMNBind _ args t | args <= 0 = t

372− stripMNBind skip args (PPi b n@(UN c) _ ty sc)

389+ stripMNBind _ args t | args <= 0 = stripImp t

390+ stripMNBind skip args (PPi b n@(UN c) _ ty sc)

373391 | n `notElem` skip ||

374392 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)

376394 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

378403

379404 constraints :: IState -> [Name] -> Type -> String

380405 constraints i [] ty = ""

@@ -382,7 +407,7 @@ makeLemma fn updatefile l n

382407 constraints i ns ty = "(" ++ showSep ", " (showConstraints i ns ty) ++ ") => "

383408

384409 showConstraints i ns (Bind n (Pi _ ty _) sc)

385− | n `elem` ns = show (delab i ty) :

410+ | n `elem` ns = show (delab i ty) :

386411 showConstraints i ns (substV (P Bound n Erased) sc)

387412 | otherwise = showConstraints i ns (substV (P Bound n Erased) sc)

388413 showConstraints _ _ _ = []

@@ -393,10 +418,10 @@ makeLemma fn updatefile l n

393418 -- Also, make type class instances implicit

394419 guessImps :: IState -> Context -> Term -> [Name]

395420 -- 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)

397422 = n : guessImps ist ctxt sc

398423 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)

400425 = n : guessImps ist ctxt sc

401426 | isClass ist ty

402427 = n : guessImps ist ctxt sc

@@ -404,22 +429,29 @@ makeLemma fn updatefile l n

404429 | ignoreName n = n : guessImps ist ctxt sc

405430 | otherwise = guessImps ist ctxt sc

406431 guessImps ist ctxt _ = []

407−

432+

408433 paramty (TType _) = True

409434 paramty (Bind _ (Pi _ (TType _) _) sc) = paramty sc

410435 paramty _ = False

411−

436+

412437 -- TMP HACK unusable name so don't lift

413438 ignoreName n = case show n of

414439 "_aX" -> True

415440 _ -> False

416441

417− guessClasses :: IState -> Context -> Term -> [Name]

418− guessClasses ist ctxt (Bind n (Pi _ ty _) sc)

419− | isParamClass ist ty

420− = n : guessClasses ist ctxt sc

421− | otherwise = guessClasses ist ctxt sc

422− guessClasses ist ctxt _ = []

442+ guessClasses :: IState -> Context -> [Name] -> [Name] -> Term -> [Name]

443+ guessClasses ist ctxt binders usednames (Bind n (Pi _ ty _) sc)

444+ | isParamClass ist ty && any (\x -> elem x usednames)

445+ (paramNames binders ty)

446+ = n : guessClasses ist ctxt (n : binders) usednames sc

447+ | otherwise = guessClasses ist ctxt (n : binders) usednames sc

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

423455

424456 isClass ist t

425457 | (P _ n _, args) <- unApply t

@@ -427,7 +459,7 @@ makeLemma fn updatefile l n

427459 Just _ -> True

428460 _ -> False

429461 | otherwise = False

430−

462+

431463 isParamClass ist t

432464 | (P _ n _, args) <- unApply t

433465 = case lookupCtxtExact n (idris_classes ist) of

@@ -443,18 +475,18 @@ makeLemma fn updatefile l n

443475 isConName f ctxt = any (guarded ctxt n) args

444476-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows

445477-- | 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)

447479 = guarded ctxt n t || guarded ctxt n sc

448480 guarded ctxt n _ = False

449481

450482 blank = all isSpace

451483

452484 addLem before tyline lem lem_app later

453− = let (bef_end, blankline : bef_start)

485+ = let (bef_end, blankline : bef_start)

454486 = case span (not . blank) (reverse before) of

455487 (bef, []) -> (bef, "" : [])

456488 x -> x

457− mvline = updateMeta False tyline (show n) lem_app in

489+ mvline = updateMeta tyline (show n) lem_app in

458490 unlines $ reverse bef_start ++

459491 [blankline, lem, blankline] ++

460492 reverse bef_end ++ mvline : later

@@ -464,6 +496,6 @@ makeLemma fn updatefile l n

464496 = case span (not . blank) later of

465497 (bef, []) -> (bef, "" : [])

466498 x -> x in

467− unlines $ before ++ tyline :

499+ unlines $ before ++ tyline :

468500 (later_bef ++ [blankline, lem_app, blankline] ++

469501 later_end)

src/Idris/Parser.hs+63−53

@@ -1,10 +1,10 @@

11{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

22{-# OPTIONS_GHC -O0 #-}

33module Idris.Parser(module Idris.Parser,

4− module Idris.ParseExpr,

5− module Idris.ParseData,

6− module Idris.ParseHelpers,

7− module Idris.ParseOps) where

4+ module Idris.Parser.Expr,

5+ module Idris.Parser.Data,

6+ module Idris.Parser.Helpers,

7+ module Idris.Parser.Ops) where

88

99import Prelude hiding (pi)

1010

@@ -35,10 +35,10 @@ import Idris.Unlit

3535import Idris.Providers

3636import Idris.Output

3737

38−import Idris.ParseHelpers

39−import Idris.ParseOps

40−import Idris.ParseExpr

41−import Idris.ParseData

38+import Idris.Parser.Helpers

39+import Idris.Parser.Ops

40+import Idris.Parser.Expr

41+import Idris.Parser.Data

4242

4343import Idris.Docstrings hiding (Unchecked)

4444

@@ -211,7 +211,7 @@ internalDecl syn

211211 declBody continue)

212212 <|> fail "End of readable input"

213213 where declBody :: Bool -> IdrisParser [PDecl]

214− declBody b =

214+ declBody b =

215215 try (instance_ True syn)

216216 <|> declBody' b

217217 <|> using_ syn

@@ -337,8 +337,8 @@ declExtension syn ns rules =

337337 (map (updateNs ns) ds)

338338 (updateRecCon ns cname)

339339 cdocs

340− updateNs ns (PInstance docs pdocs s fc cs cn fc' ps ity ni ds)

341− = PInstance docs pdocs s fc cs (updateB ns cn) fc'

340+ updateNs ns (PInstance docs pdocs s fc cs acc cn fc' ps ity ni ds)

341+ = PInstance docs pdocs s fc cs acc (updateB ns cn) fc'

342342 ps ity (fmap (updateB ns) ni)

343343 (map (updateNs ns) ds)

344344 updateNs ns (PMutual fc ds) = PMutual fc (map (updateNs ns) ds)

@@ -502,7 +502,9 @@ syntaxRule syn

502502 body' <- fixBind ((n,n'):rens) body

503503 return $ PLam fc n' nfc ty' body'

504504 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)

506508 | otherwise =

507509 do ty' <- fixBind rens argTy

508510 n' <- gensym n

@@ -521,6 +523,10 @@ syntaxRule syn

521523 return $ PLet fc n' nfc ty' val' body'

522524 fixBind rens (PMatchApp fc n) | Just n' <- lookup n rens =

523525 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

524530 fixBind rens x = descendM (fixBind rens) x

525531

526532 gensym :: Name -> IdrisParser Name

@@ -584,7 +590,7 @@ fnDecl' syn = checkFixity $

584590 then [TotalFn]

585591 else []

586592 opts <- fnOpts initOpts

587− acc <- optional accessibility

593+ acc <- accessibility

588594 opts' <- fnOpts opts

589595 (n_in, nfc) <- fnName

590596 let n = expandNS syn n_in

@@ -698,7 +704,7 @@ postulate syn = do (doc, ext)

698704 then [TotalFn]

699705 else []

700706 opts <- fnOpts initOpts

701− acc <- optional accessibility

707+ acc <- accessibility

702708 opts' <- fnOpts opts

703709 (n_in, nfc) <- fnName

704710 let n = expandNS syn n_in

@@ -856,7 +862,7 @@ Class ::=

856862class_ :: SyntaxInfo -> IdrisParser [PDecl]

857863class_ syn = do (doc, argDocs, acc)

858864 <- try (do (doc, argDocs) <- docstring syn

859− acc <- optional accessibility

865+ acc <- accessibility

860866 classKeyword

861867 return (doc, argDocs, acc))

862868 fc <- getFC

@@ -873,15 +879,12 @@ class_ syn = do (doc, argDocs, acc)

873879 where

874880 fundeps :: IdrisParser [(Name, FC)]

875881 fundeps = do lchar '|'; sepBy name (lchar ',')

876−

882+

877883 classKeyword :: IdrisParser ()

878884 classKeyword = reservedHL "interface"

879885 <|> do reservedHL "class"

880886 fc <- getFC

881− ist <- get

882− put ist { parserWarnings =

883− (fc, Msg "The 'class' keyword is deprecated. Use 'interface' instead.")

884− : parserWarnings ist }

887+ parserWarning fc Nothing (Msg "The 'class' keyword is deprecated. Use 'interface' instead.")

885888

886889 carg :: IdrisParser (Name, FC, PTerm)

887890 carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'

@@ -903,8 +906,9 @@ InstanceName ::= '[' Name ']';

903906@

904907-}

905908instance_ :: Bool -> SyntaxInfo -> IdrisParser [PDecl]

906−instance_ kwopt syn

907− = do (doc, argDocs)

909+instance_ kwopt syn

910+ = do acc <- accessibility

911+ (doc, argDocs)

908912 <- try (docstring syn <* if kwopt then optional instanceKeyword

909913 else do instanceKeyword

910914 return (Just ()))

@@ -917,7 +921,7 @@ instance_ kwopt syn

917921 let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)

918922 let t = bindList (PPi constraint) cs sc

919923 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]

921925 <?> "implementation declaration"

922926 where instanceName :: IdrisParser Name

923927 instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'

@@ -928,11 +932,7 @@ instance_ kwopt syn

928932 instanceKeyword = reservedHL "implementation"

929933 <|> do reservedHL "instance"

930934 fc <- getFC

931− ist <- get

932− put ist { parserWarnings =

933− (fc, Msg "The 'instance' keyword is deprecated. Use 'implementation' (or omit it) instead.")

934− : parserWarnings ist }

935−

935+ parserWarning fc Nothing (Msg "The 'instance' keyword is deprecated. Use 'implementation' (or omit it) instead.")

936936

937937-- | Parse a docstring

938938docstring :: SyntaxInfo

@@ -1321,7 +1321,10 @@ directive syn = do try (lchar '%' *> reserved "lib")

13211321 return [PDirective (DHide n)]

13221322 <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName []

13231323 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 }

13251328 return [PDirective (DAccess acc)]

13261329 <|> do try (lchar '%' *> reserved "default"); tot <- totality

13271330 i <- get

@@ -1353,7 +1356,12 @@ directive syn = do try (lchar '%' *> reserved "lib")

13531356 fn <- fst <$> fnName

13541357 arg <- fst <$> iName []

13551358 return [PDirective (DUsed fc fn arg)]

1359+ <|> do try (lchar '%' *> reserved "auto_implicits")

1360+ b <- on_off

1361+ return [PDirective (DAutoImplicits b)]

13561362 <?> "directive"

1363+ where on_off = do reserved "on"; return True

1364+ <|> do reserved "off"; return False

13571365

13581366pLangExt :: IdrisParser LanguageExt

13591367pLangExt = (reserved "TypeProviders" >> return TypeProviders)

@@ -1491,14 +1499,23 @@ parseImports fname input

14911499 [(FC, OutputAnnotation)], IState)

14921500 imports = do whiteSpace

14931501 (mdoc, mname, annots) <- moduleHeader

1494− ps <- many import_

1502+ ps_exp <- many import_

14951503 mrk <- mark

14961504 isEof <- lookAheadMatches eof

14971505 let mrk' = if isEof

14981506 then Nothing

14991507 else Just mrk

15001508 i <- get

1509+ -- add Builtins and Prelude, unless options say

1510+ -- not to

1511+ let ps = ps_exp -- imp "Builtins" : imp "Prelude" : ps_exp

15011512 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+

15021519 addPath :: [(FC, OutputAnnotation)] -> FilePath -> [(FC, OutputAnnotation)]

15031520 addPath [] _ = []

15041521 addPath ((fc, AnnNamespace ns Nothing) : annots) path =

@@ -1556,17 +1573,17 @@ parseProg syn fname input mrk

15561573 return (ds, i')

15571574

15581575{- | Load idris module and show error if something wrong happens -}

1559−loadModule :: FilePath -> Idris (Maybe String)

1560−loadModule f

1561− = idrisCatch (loadModule' f)

1576+loadModule :: FilePath -> IBCPhase -> Idris (Maybe String)

1577+loadModule f phase

1578+ = idrisCatch (loadModule' f phase)

15621579 (\e -> do setErrSpan (getErrSpan e)

15631580 ist <- getIState

15641581 iWarn (getErrSpan e) $ pprintErr ist e

15651582 return Nothing)

15661583

15671584{- | Load idris module -}

1568−loadModule' :: FilePath -> Idris (Maybe String)

1569−loadModule' f

1585+loadModule' :: FilePath -> IBCPhase -> Idris (Maybe String)

1586+loadModule' f phase

15701587 = do i <- getIState

15711588 let file = takeWhile (/= ' ') f

15721589 ibcsd <- valIBCSubDir i

@@ -1580,7 +1597,7 @@ loadModule' f

15801597 IDR fn -> loadSource False fn Nothing

15811598 LIDR fn -> loadSource True fn Nothing

15821599 IBC fn src ->

1583− idrisCatch (loadIBC True fn)

1600+ idrisCatch (loadIBC True phase fn)

15841601 (\c -> do logParser 1 $ fn ++ " failed " ++ pshow i c

15851602 case src of

15861603 IDR sfn -> loadSource False sfn Nothing

@@ -1588,18 +1605,18 @@ loadModule' f

15881605 return $ Just file

15891606

15901607{- | Load idris code from file -}

1591−loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()

1592−loadFromIFile reexp i@(IBC fn src) maxline

1608+loadFromIFile :: Bool -> IBCPhase -> IFileType -> Maybe Int -> Idris ()

1609+loadFromIFile reexp phase i@(IBC fn src) maxline

15931610 = do logParser 1 $ "Skipping " ++ getSrcFile i

1594− idrisCatch (loadIBC reexp fn)

1611+ idrisCatch (loadIBC reexp phase fn)

15951612 (\err -> ierror $ LoadingFailed fn err)

15961613 where

15971614 getSrcFile (IDR fn) = fn

15981615 getSrcFile (LIDR fn) = fn

15991616 getSrcFile (IBC f src) = getSrcFile src

16001617

1601−loadFromIFile _ (IDR fn) maxline = loadSource' False fn maxline

1602−loadFromIFile _ (LIDR fn) maxline = loadSource' True fn maxline

1618+loadFromIFile _ _ (IDR fn) maxline = loadSource' False fn maxline

1619+loadFromIFile _ _ (LIDR fn) maxline = loadSource' True fn maxline

16031620

16041621{-| Load idris source code and show error if something wrong happens -}

16051622loadSource' :: Bool -> FilePath -> Maybe Int -> Idris ()

@@ -1630,7 +1647,7 @@ loadSource lidr f toline

16301647 LIDR fn -> ifail $ "No ibc for " ++ f

16311648 IDR fn -> ifail $ "No ibc for " ++ f

16321649 IBC fn src ->

1633− do loadIBC True fn

1650+ do loadIBC True IBC_Building fn

16341651 let srcFn = case src of

16351652 IDR fn -> Just fn

16361653 LIDR fn -> Just fn

@@ -1760,7 +1777,7 @@ loadSource lidr f toline

17601777 clearHighlights

17611778 i <- getIState

17621779 putIState (i { default_total = def_total,

1763− hide_list = [] })

1780+ hide_list = emptyContext })

17641781 return ()

17651782 where

17661783 namespaces :: [String] -> [PDecl] -> [PDecl]

@@ -1790,16 +1807,9 @@ loadSource lidr f toline

17901807 parsedDocs ist = annotCode (tryFullExpr syn ist) docs

17911808

17921809{- | Adds names to hide list -}

1793−addHides :: [(Name, Maybe Accessibility)] -> Idris ()

1810+addHides :: Ctxt Accessibility -> Idris ()

17941811addHides xs = do i <- getIState

17951812 let defh = default_access i

1796− let (hs, as) = partition isNothing xs

1797− unless (null as) $

1798− mapM_ doHide

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

1813+ mapM_ doHide (toAlist xs)

1814+ where doHide (n, a) = do setAccessibility n a

18051815 addIBC (IBCAccess n a)

src/Idris/ParseData.hs → src/Idris/Parser/Data.hsrenamed+12−12

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

11{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−module Idris.ParseData where

2+module Idris.Parser.Data where

33

44import Prelude hiding (pi)

55

@@ -12,9 +12,9 @@ import qualified Text.Parser.Char as Chr

1212import qualified Text.Parser.Token.Highlight as Hi

1313

1414import Idris.AbsSyntax

15−import Idris.ParseHelpers

16−import Idris.ParseOps

17−import Idris.ParseExpr

15+import Idris.Parser.Helpers

16+import Idris.Parser.Ops

17+import Idris.Parser.Expr

1818import Idris.DSL

1919

2020import Idris.Core.TT

@@ -48,7 +48,7 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

4848 let doc' = annotCode (tryFullExpr syn ist) doc

4949 paramDocs' = [ (n, annotCode (tryFullExpr syn ist) d)

5050 | (n, d) <- paramDocs ]

51− acc <- optional accessibility

51+ acc <- accessibility

5252 opts <- dataOpts []

5353 co <- recordI

5454 return (doc', paramDocs', acc, opts ++ co))

@@ -59,8 +59,9 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

5959 syn_namespace syn }

6060 params <- manyTill (recordParameter rsyn) (reservedHL "where")

6161 (fields, cname, cdoc) <- indentedBlockS $ recordBody rsyn tyn

62+ let fnames = map (expandNS rsyn) (mapMaybe getName fields)

6263 case cname of

63− Just cn' -> accData acc tyn [fst cn']

64+ Just cn' -> accData acc tyn (fst cn' : fnames)

6465 Nothing -> return ()

6566 return $ PRecord doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc syn

6667 <?> "record type declaration"

@@ -70,6 +71,9 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

7071 ++ getRecNames syn sc

7172 getRecNames _ _ = []

7273

74+ getName (Just (n, _), _, _, _) = Just n

75+ getName _ = Nothing

76+

7377 toFreeze :: Maybe Accessibility -> Maybe Accessibility

7478 toFreeze (Just Frozen) = Just Hidden

7579 toFreeze x = x

@@ -167,11 +171,7 @@ dataOpts opts

167171 <|> return opts

168172 <?> "data options"

169173 where warnElim fc =

170− do ist <- get

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 }

174+ parserWarning fc (Just NoElimDeprecationWarnings) (Msg "The 'class' keyword is deprecated. Use 'interface' instead.")

175175

176176{- | Parses a data type declaration

177177Data ::= DocComment? Accessibility? DataI DefaultEliminator FnName TypeSig ExplicitTypeDataRest?

@@ -192,7 +192,7 @@ data_ :: SyntaxInfo -> IdrisParser PDecl

192192data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

193193 (doc, argDocs) <- option noDocs docComment

194194 pushIndent

195− acc <- optional accessibility

195+ acc <- accessibility

196196 elim <- dataOpts []

197197 co <- dataI

198198 ist <- get

src/Idris/ParseExpr.hs → src/Idris/Parser/Expr.hsrenamed+19−20

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

11{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, TupleSections #-}

2−module Idris.ParseExpr where

2+module Idris.Parser.Expr where

33

44import Prelude hiding (pi)

55

@@ -12,8 +12,8 @@ import qualified Text.Parser.Char as Chr

1212import qualified Text.Parser.Token.Highlight as Hi

1313

1414import Idris.AbsSyntax

15−import Idris.ParseHelpers

16−import Idris.ParseOps

15+import Idris.Parser.Helpers

16+import Idris.Parser.Ops

1717import Idris.DSL

1818

1919import Idris.Core.TT

@@ -161,7 +161,7 @@ extension syn ns rules =

161161 extensionSymbol (Symbol s) = do fc <- symbolFC s

162162 highlightP fc AnnKeyword

163163 return Nothing

164−

164+

165165 flatten :: PTerm -> PTerm -- flatten application

166166 flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))

167167 flatten t = t

@@ -252,7 +252,7 @@ updateSynMatch = update

252252

253253 updTacImp ns (TacImp o st scr) = TacImp o st (update ns scr)

254254 updTacImp _ x = x

255−

255+

256256 dropn :: Name -> [(Name, a)] -> [(Name, a)]

257257 dropn n [] = []

258258 dropn n ((x,t) : xs) | n == x = xs

@@ -333,11 +333,7 @@ caseOption syn = do lhs <- expr (syn { inPattern = True })

333333

334334warnTacticDeprecation :: FC -> IdrisParser ()

335335warnTacticDeprecation 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.")

341337

342338{- | Parses a proof block

343339@

@@ -480,7 +476,7 @@ bracketed' open syn =

480476 <|> try (do l <- simpleExpr syn

481477 op <- option Nothing (do o <- operator

482478 lchar ')'

483− return (Just o))

479+ return (Just o))

484480 fc0 <- getFC

485481 case op of

486482 Nothing -> bracketedExpr syn open l

@@ -588,7 +584,7 @@ runElab syn = do (FC fn (sl, sc) kwEnd) <- try (lchar '%' *> reservedFC "runElab

588584 return $ PRunElab fc tm (syn_namespace syn)

589585 <?> "new-style tactics expression"

590586

591−{- | Parses a disambiguation expression

587+{- | Parses a disambiguation expression

592588Disamb ::=

593589 '%' 'disamb' NameList Expr

594590 ;

@@ -1010,7 +1006,7 @@ Pi' ::=

10101006@

10111007 -}

10121008

1013−bindsymbol opts st syn

1009+bindsymbol opts st syn

10141010 = do symbol "->"

10151011 return (Exp opts st False)

10161012

@@ -1019,7 +1015,7 @@ explicitPi opts st syn

10191015 binder <- bindsymbol opts st syn

10201016 sc <- expr syn

10211017 return (bindList (PPi binder) xt sc)

1022−

1018+

10231019autoImplicit opts st syn

10241020 = do kw <- reservedFC "auto"

10251021 when (st == Static) $ fail "auto implicits can not be static"

@@ -1029,7 +1025,7 @@ autoImplicit opts st syn

10291025 sc <- expr syn

10301026 highlightP kw AnnKeyword

10311027 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)

10331029

10341030defaultImplicit opts st syn = do

10351031 kw <- reservedFC "default"

@@ -1055,7 +1051,7 @@ normalImplicit opts st syn = do

10551051 constraint)

10561052 else (Imp opts st False (Just (Impl False False)),

10571053 Imp opts st False (Just (Impl True False)))

1058− return (bindList (PPi im) xt

1054+ return (bindList (PPi im) xt

10591055 (bindList (PPi cl) cs sc))

10601056

10611057implicitPi opts st syn =

@@ -1389,7 +1385,11 @@ Static ::=

13891385@

13901386-}

13911387static :: 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

13931393 <|> return Dynamic

13941394 <?> "static modifier"

13951395

@@ -1443,7 +1443,7 @@ data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n

14431443-- https://github.com/idris-lang/Idris-dev/issues/1766

14441444-- | A list of available tactics and their argument requirements

14451445tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]

1446−tactics =

1446+tactics =

14471447 [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)

14481448 do ns <- sepBy (spaced (fst <$> name)) (lchar ','); return $ Intro ns)

14491449 , noArgs ["intros"] Intros

@@ -1527,7 +1527,7 @@ tactics =

15271527 imp :: IdrisParser Bool

15281528 imp = do lchar '?'; return False

15291529 <|> do lchar '_'; return True

1530−

1530+

15311531

15321532tactic :: SyntaxInfo -> IdrisParser PTactic

15331533tactic syn = choice [ do choice (map reserved names); parser syn

@@ -1550,4 +1550,3 @@ fullTactic :: SyntaxInfo -> IdrisParser PTactic

15501550fullTactic syn = do t <- tactic syn

15511551 eof

15521552 return t

1553−

src/Idris/ParseHelpers.hs → src/Idris/Parser/Helpers.hsrenamed+47−14

@@ -2,12 +2,12 @@

22#if !(MIN_VERSION_base(4,8,0))

33{-# LANGUAGE OverlappingInstances #-}

44#endif

5−module Idris.ParseHelpers where

5+module Idris.Parser.Helpers where

66

77import Prelude hiding (pi)

88

99import 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)

1111import Text.Parser.LookAhead

1212import Text.Parser.Expression

1313import qualified Text.Parser.Token as Tok

@@ -105,6 +105,14 @@ reportParserWarnings = do ist <- getIState

105105 parserWarnings ist)

106106 clearParserWarnings

107107

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+

108116{- * Space, comments and literals (token/lexing like parsers) -}

109117

110118-- | Consumes any simple whitespace (any character which satisfies Char.isSpace)

@@ -246,9 +254,9 @@ idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved

246254 "case", "of", "total", "partial", "mutual",

247255 "infix", "infixl", "infixr", "rewrite",

248256 "where", "with", "syntax", "proof", "postulate",

249− "using", "namespace", "class", "instance",

257+ "using", "namespace", "class", "instance",

250258 "interface", "implementation", "parameters",

251− "public", "private", "abstract", "implicit",

259+ "public", "private", "export", "abstract", "implicit",

252260 "quoteGoal", "constructor",

253261 "if", "then", "else"]

254262

@@ -612,22 +620,47 @@ notOpenBraces = do ist <- get

612620 hasNothing = any isNothing

613621

614622{- | Parses an accessibilty modifier (e.g. public, private) -}

615−accessibility :: IdrisParser Accessibility

616−accessibility = do reserved "public"; return Public

617− <|> do reserved "abstract"; return Frozen

623+accessibility' :: IdrisParser Accessibility

624+accessibility'

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

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

618644 <|> do reserved "private"; return Hidden

619645 <?> "accessibility modifier"

620646

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+

621654-- | Adds accessibility option for function

622−addAcc :: Name -> Maybe Accessibility -> IdrisParser ()

655+addAcc :: Name -> Accessibility -> IdrisParser ()

623656addAcc 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) })

625658

626659{- | Add accessbility option for data declarations

627660 (works for classes too - 'abstract' means the data/class is visible but members not) -}

628−accData :: Maybe Accessibility -> Name -> [Name] -> IdrisParser ()

629−accData (Just Frozen) n ns = do addAcc n (Just Frozen)

630− mapM_ (\n -> addAcc n (Just Hidden)) ns

661+accData :: Accessibility -> Name -> [Name] -> IdrisParser ()

662+accData Frozen n ns = do addAcc n Public -- so that it can be used in public definitions

663+ mapM_ (\n -> addAcc n Hidden) ns -- so that they are invisible

631664accData a n ns = do addAcc n a

632665 mapM_ (`addAcc` a) ns

633666

@@ -662,7 +695,7 @@ collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds

662695collect (PNamespace ns fc ps : ds) = PNamespace ns fc (collect ps) : collect ds

663696collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')

664697 = 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')

666− = PInstance doc argDocs f s cs n nfc ps t en (collect ds) : collect ds'

698+collect (PInstance doc argDocs f s cs acc n nfc ps t en ds : ds')

699+ = PInstance doc argDocs f s cs acc n nfc ps t en (collect ds) : collect ds'

667700collect (d : ds) = d : collect ds

668701collect [] = []

src/Idris/ParseOps.hs → src/Idris/Parser/Ops.hsrenamed+2−3

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

11{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−module Idris.ParseOps where

2+module Idris.Parser.Ops where

33

44import Prelude hiding (pi)

55

@@ -12,7 +12,7 @@ import qualified Text.Parser.Char as Chr

1212import qualified Text.Parser.Token.Highlight as Hi

1313

1414import Idris.AbsSyntax

15−import Idris.ParseHelpers

15+import Idris.Parser.Helpers

1616

1717import Idris.Core.TT

1818

@@ -170,4 +170,3 @@ fixityType = do reserved "infixl"; return Infixl

170170 <|> do reserved "infix"; return InfixN

171171 <|> do reserved "prefix"; return PrefixN

172172 <?> "fixity type"

173−

src/Idris/ProofSearch.hs+31−33

@@ -48,13 +48,13 @@ trivialHoles psnames ok elab ist

4848 then try' (elab (PRef (fileFC "prf") [] x))

4949 (tryAll xs) True

5050 else tryAll xs

51−

51+

5252 holesOK hs ap@(App _ _ _)

5353 | (P _ n _, args) <- unApply ap

5454 = holeArgsOK hs n 0 args

5555 holesOK hs (App _ f a) = holesOK hs f && holesOK hs a

5656 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) &&

5858 holesOK hs sc

5959 holesOK hs _ = True

6060

@@ -85,8 +85,8 @@ trivialTCs ok elab ist

8585 then try' (elab (PRef (fileFC "prf") [] x))

8686 (tryAll xs) True

8787 else tryAll xs

88−

89− tcArg env ty

88+

89+ tcArg env ty

9090 | (P _ n _, args) <- unApply (getRetTy (normalise (tt_ctxt ist) env ty))

9191 = case lookupCtxtExact n (idris_classes ist) of

9292 Just _ -> True

@@ -98,7 +98,7 @@ trivialTCs ok elab ist

9898 = holeArgsOK hs n 0 args

9999 holesOK hs (App _ f a) = holesOK hs f && holesOK hs a

100100 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) &&

102102 holesOK hs sc

103103 holesOK hs _ = True

104104

@@ -111,16 +111,16 @@ cantSolveGoal :: ElabD a

111111cantSolveGoal = do g <- goal

112112 env <- get_env

113113 lift $ tfail $

114− CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env)

114+ CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env)

115115

116−proofSearch :: Bool -> -- recursive search (False for 'refine')

116+proofSearch :: Bool -> -- recursive search (False for 'refine')

117117 Bool -> -- invoked from a tactic proof. If so, making

118118 -- new metavariables is meaningless, and there shoudl

119119 -- be an error reported instead.

120120 Bool -> -- ambiguity ok

121121 Bool -> -- defer on failure

122122 Int -> -- maximum depth

123− (PTerm -> ElabD ()) -> Maybe Name -> Name ->

123+ (PTerm -> ElabD ()) -> Maybe Name -> Name ->

124124 [Name] ->

125125 [Name] ->

126126 IState -> ElabD ()

@@ -131,7 +131,7 @@ proofSearch False fromProver ambigok deferonfail depth elab _ nroot psnames [fn]

131131 tryAllFns all_imps

132132 where

133133 -- if nothing worked, make a new metavariable

134− tryAllFns [] | fromProver = cantSolveGoal

134+ tryAllFns [] | fromProver = cantSolveGoal

135135 tryAllFns [] = do attack; defer [] nroot; solve

136136 tryAllFns (f : fs) = try' (tryFn f) (tryAllFns fs) True

137137

@@ -142,20 +142,20 @@ proofSearch False fromProver ambigok deferonfail depth elab _ nroot psnames [fn]

142142 (match_apply (Var f) imps) True

143143 ps' <- get_probs

144144-- when (length ps < length ps') $ fail "Can't apply constructor"

145− -- Make metavariables for new holes

145+ -- Make metavariables for new holes

146146 hs' <- get_holes

147147 ptm <- get_term

148148 if fromProver then cantSolveGoal

149149 else do

150150 mapM_ (\ h -> do focus h

151− attack; defer [] nroot; solve)

151+ attack; defer [] nroot; solve)

152152 (hs' \\ hs)

153153-- (filter (\ (x, y) -> not x) (zip (map fst imps) args))

154154 solve

155155

156156 isImp (PImp p _ _ _ _) = (True, p)

157157 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

159159 = do compute

160160 ty <- goal

161161 hs <- get_holes

@@ -172,7 +172,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

172172 (autoArg (sUN "auto"))

173173 else autoArg (sUN "auto") -- not enough info in the type yet

174174 where

175− findInferredTy (t : _) = elab (delab ist (toUN t))

175+ findInferredTy (t : _) = elab (delab ist (toUN t))

176176

177177 cantsolve (InternalMsg _) = True

178178 cantsolve (CantSolveGoal _ _) = True

@@ -185,12 +185,12 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

185185 conArgsOK ty

186186 = let (f, as) = unApply ty in

187187 case f of

188− P _ n _ ->

188+ P _ n _ ->

189189 let autohints = case lookupCtxtExact n (idris_autohints ist) of

190190 Nothing -> []

191191 Just hs -> hs in

192192 case lookupCtxtExact n (idris_datatypes ist) of

193− Just t -> do rs <- mapM (conReady as)

193+ Just t -> do rs <- mapM (conReady as)

194194 (autohints ++ con_names t)

195195 return (and rs)

196196 Nothing -> -- local variable, go for it

@@ -199,7 +199,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

199199 _ -> typeNotSearchable ty

200200

201201 conReady :: [Term] -> Name -> ElabD Bool

202− conReady as n

202+ conReady as n

203203 = case lookupTyExact n (tt_ctxt ist) of

204204 Just ty -> do let (_, cs) = unApply (getRetTy ty)

205205 -- if any metavariables in 'as' correspond to

@@ -223,7 +223,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

223223 inHS hs (P _ n _) = n `elem` hs

224224 isHS _ _ = False

225225

226− toUN t@(P nt (MN i n) ty)

226+ toUN t@(P nt (MN i n) ty)

227227 | ('_':xs) <- str n = t

228228 | otherwise = P nt (UN n) ty

229229 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

239239 psRec :: Bool -> Int -> [Name] -> S.Set Type -> ElabD ()

240240 psRec _ 0 locs tys | fromProver = cantSolveGoal

241241 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

243243 psRec True d locs tys

244244 = do compute

245245 ty <- goal

@@ -248,11 +248,11 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

248248 try' (try' (trivialHoles psnames [] elab ist)

249249 (resolveTC False False 20 ty nroot elab ist)

250250 True)

251− (try' (try' (resolveByCon (d - 1) locs tys')

251+ (try' (try' (resolveByCon (d - 1) locs tys')

252252 (resolveByLocals (d - 1) locs tys')

253253 True)

254254 -- if all else fails, make a new metavariable

255− (if fromProver

255+ (if fromProver

256256 then fail "cantSolveGoal"

257257 else do attack; defer [] nroot; solve) True) True

258258

@@ -269,7 +269,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

269269 = do t <- goal

270270 let (f, _) = unApply t

271271 case f of

272− P _ n _ ->

272+ P _ n _ ->

273273 do let autohints = case lookupCtxtExact n (idris_autohints ist) of

274274 Nothing -> []

275275 Just hs -> hs

@@ -292,26 +292,26 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

292292 tryLocals d locs tys env

293293

294294 tryLocals d locs tys [] = fail "Locals failed"

295− tryLocals d locs tys ((x, t) : xs)

295+ tryLocals d locs tys ((x, t) : xs)

296296 | 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)

298298 (tryLocals d locs tys xs) True

299299

300300 tryCons d locs tys [] = fail "Constructors failed"

301− tryCons d locs tys (c : cs)

301+ tryCons d locs tys (c : cs)

302302 = try' (tryCon d locs tys c) (tryCons d locs tys cs) True

303303

304− tryLocal d locs tys n t

304+ tryLocal d locs tys n t

305305 = do let a = getPArity (delab ist (binderTy t))

306306 tryLocalArg d locs tys n a

307307

308308 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

310310 = simple_app False (tryLocalArg d locs tys n (i - 1))

311311 (psRec True d locs tys) "proof search local apply"

312312

313313 -- Like type class resolution, but searching with constructors

314− tryCon d locs tys n =

314+ tryCon d locs tys n =

315315 do ty <- goal

316316 let imps = case lookupCtxtExact n (idris_implicits ist) of

317317 Nothing -> []

@@ -341,7 +341,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

341341 (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."]

342342 _ -> []

343343

344−-- In interactive mode, only search for things if there is some

344+-- In interactive mode, only search for things if there is some

345345-- index to help pick a relevant constructor

346346checkConstructor :: IState -> [Name] -> ElabD ()

347347checkConstructor ist [] = return ()

@@ -397,7 +397,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

397397 _ -> []

398398

399399 traceWhen ulog ("Resolving class " ++ show g ++ "\nin" ++ show env ++ "\n" ++ show okholes) $

400− try' (trivialTCs okholes elab ist)

400+ try' (trivialTCs okholes elab ist)

401401 (do addDefault t tc ttypes

402402 let stk = map fst (filter snd $ elab_stack ist)

403403 let insts = findInstances ist t

@@ -432,7 +432,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

432432 tcDetArgsOK _ _ _ [] = Just []

433433

434434 isMeta :: [Name] -> Term -> Bool

435− isMeta ns (P _ n _) = n `elem` ns

435+ isMeta ns (P _ n _) = n `elem` ns

436436 isMeta _ _ = False

437437

438438 notHole hs (P _ n _, c)

@@ -449,7 +449,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

449449 chaser (NS n _) = chaser n

450450 chaser _ = False

451451

452− numclass = sNS (sUN "Num") ["Classes","Prelude"]

452+ numclass = sNS (sUN "Num") ["Interfaces","Prelude"]

453453

454454 addDefault t num@(P _ nc _) [P Bound a _] | nc == numclass && defaultOn

455455 = do focus a

@@ -530,5 +530,3 @@ findInstances ist t

530530 where accessible n = case lookupDefAccExact n False (tt_ctxt ist) of

531531 Just (_, Hidden) -> False

532532 _ -> True

533−

534−

src/Idris/REPL.hs+25−21

@@ -8,10 +8,10 @@ module Idris.REPL(getClient, getPkg, getPkgCheck, getPkgClean, getPkgMkDoc,

88import Idris.AbsSyntax

99import Idris.ASTUtils

1010import Idris.Apropos (apropos, aproposModules)

11−import Idris.REPLParser

12−import Idris.ElabDecls

11+import Idris.REPL.Parser

1312import Idris.Erasure

1413import Idris.Error

14+import Idris.IBC

1515import Idris.ErrReverse

1616import Idris.Delaborate

1717import Idris.Docstrings (Docstring, overview, renderDocstring, renderDocTerm)

@@ -38,6 +38,7 @@ import Idris.IBC (loadPkgIndex, writePkgIndex)

3838

3939import Idris.REPL.Browse (namesInNS, namespacesInNS)

4040

41+import Idris.ElabDecls

4142import Idris.Elab.Type

4243import Idris.Elab.Clause

4344import Idris.Elab.Data

@@ -690,9 +691,9 @@ reload orig inputs = do

690691

691692watch :: IState -> [FilePath] -> Idris (Maybe [FilePath])

692693watch orig inputs = do

693− let inputSet = S.fromList inputs

694− let dirs = nub $ map takeDirectory inputs

695694 resp <- runIO $ do

695+ let dirs = nub $ map takeDirectory inputs

696+ inputSet <- fmap S.fromList $ mapM canonicalizePath inputs

696697 signal <- newEmptyMVar

697698 withManager $ \mgr -> do

698699 forM_ dirs $ \dir ->

@@ -735,7 +736,7 @@ processInput cmd orig inputs efile

735736 return (Just mod)

736737 Success (Right (ModImport f)) ->

737738 do clearErr

738− fmod <- loadModule f

739+ fmod <- loadModule f (IBC_REPL True)

739740 return (Just (inputs ++ maybe [] (:[]) fmod))

740741 Success (Right Edit) -> do -- takeMVar stvar

741742 edit efile orig

@@ -817,7 +818,7 @@ process fn Warranty = iPrintResult warranty

817818process fn (ChangeDirectory f)

818819 = do runIO $ setCurrentDirectory f

819820 return ()

820−process fn (ModImport f) = do fmod <- loadModule f

821+process fn (ModImport f) = do fmod <- loadModule f (IBC_REPL True)

821822 case fmod of

822823 Just pr -> isetPrompt pr

823824 Nothing -> iPrintError $ "Can't find import " ++ f

@@ -901,8 +902,8 @@ process fn (NewDefn decls) = do

901902 fixClauses :: PDecl' t -> PDecl' t

902903 fixClauses (PClauses fc opts _ css@(clause:cs)) =

903904 PClauses fc opts (getClauseName clause) css

904− fixClauses (PInstance doc argDocs syn fc constraints cls nfc parms ty instName decls) =

905− PInstance doc argDocs syn fc constraints cls nfc parms ty instName (map fixClauses decls)

905+ fixClauses (PInstance doc argDocs syn fc constraints acc cls nfc parms ty instName decls) =

906+ PInstance doc argDocs syn fc constraints acc cls nfc parms ty instName (map fixClauses decls)

906907 fixClauses decl = decl

907908

908909process fn (Undefine names) = undefine names

@@ -1089,7 +1090,7 @@ process fn (DebugInfo n)

10891090 when (not (null di)) $ iputStrLn (show di)

10901091 let imps = lookupCtxt n (idris_implicits i)

10911092 when (not (null imps)) $ iputStrLn (show imps)

1092− let d = lookupDef n (tt_ctxt i)

1093+ let d = lookupDefAcc n False (tt_ctxt i)

10931094 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

10941095 let cg = lookupCtxtName n (idris_callgraph i)

10951096 i <- getIState

@@ -1238,12 +1239,15 @@ process fn (Compile codegen f)

12381239 iPrintError $ "Invalid filename for compiler output \"" ++ f ++"\""

12391240 | otherwise = do opts <- getCmdLine

12401241 let iface = Interface `elem` opts

1242+ let mainname = sNS (sUN "main") ["Main"]

1243+

12411244 m <- if iface then return Nothing else

12421245 do (m', _) <- elabVal recinfo ERHS

12431246 (PApp fc (PRef fc [] (sUN "run__IO"))

1244− [pexp $ PRef fc [] (sNS (sUN "main") ["Main"])])

1247+ [pexp $ PRef fc [] mainname])

12451248 return (Just m')

12461249 ir <- compile codegen f m

1250+

12471251 i <- getIState

12481252 runIO $ generate codegen (fst (head (idris_imported i))) ir

12491253 where fc = fileFC "main"

@@ -1559,7 +1563,7 @@ loadInputs inputs toline -- furthest line to read in input source files

15591563 logParser 1 ("MODULE TREE : " ++ show modTree)

15601564 logParser 1 ("RELOAD: " ++ show ifiles)

15611565 when (not (all ibc ifiles) || loadCode) $

1562− tryLoad False (filter (not . ibc) ifiles)

1566+ tryLoad False IBC_Building (filter (not . ibc) ifiles)

15631567 -- return the files that need rechecking

15641568 return (input, ifiles))

15651569 ninputs

@@ -1570,7 +1574,8 @@ loadInputs inputs toline -- furthest line to read in input source files

15701574 Nothing ->

15711575 do putIState $!! ist { idris_tyinfodata = tidata }

15721576 ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))

1573− tryLoad True (mapMaybe id ibcfiles)

1577+-- logLvl 0 $ "Loading from " ++ show ibcfiles

1578+ tryLoad True (IBC_REPL True) (mapMaybe id ibcfiles)

15741579 _ -> return ()

15751580 exports <- findExports

15761581

@@ -1590,9 +1595,9 @@ loadInputs inputs toline -- furthest line to read in input source files

15901595 iWarn emptyFC $ pprintErr i e

15911596 return [])

15921597 where -- load all files, stop if any fail

1593− tryLoad :: Bool -> [IFileType] -> Idris ()

1594− tryLoad keepstate [] = warnTotality >> return ()

1595− tryLoad keepstate (f : fs)

1598+ tryLoad :: Bool -> IBCPhase -> [IFileType] -> Idris ()

1599+ tryLoad keepstate phase [] = warnTotality >> return ()

1600+ tryLoad keepstate phase (f : fs)

15961601 = do ist <- getIState

15971602 let maxline

15981603 = case toline of

@@ -1605,7 +1610,7 @@ loadInputs inputs toline -- furthest line to read in input source files

16051610 then Just l

16061611 else Nothing

16071612 _ -> Nothing

1608− loadFromIFile True f maxline

1613+ loadFromIFile True phase f maxline

16091614 inew <- getIState

16101615 -- FIXME: Save these in IBC to avoid this hack! Need to

16111616 -- preserve it all from source inputs

@@ -1623,7 +1628,7 @@ loadInputs inputs toline -- furthest line to read in input source files

16231628 ist <- getIState

16241629 putIState $!! ist { idris_tyinfodata = tidata,

16251630 idris_patdefs = patdefs }

1626− tryLoad keepstate fs

1631+ tryLoad keepstate phase fs

16271632

16281633 ibc (IBC _ _) = True

16291634 ibc _ = False

@@ -1727,13 +1732,12 @@ idrisMain opts =

17271732 addPkgDir "base"

17281733 mapM_ addPkgDir pkgdirs

17291734 elabPrims

1730− when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins"

1735+ when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins" (IBC_REPL True)

17311736 addAutoImport "Builtins"

17321737 return ()

1733− when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"

1738+ when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude" (IBC_REPL True)

17341739 addAutoImport "Prelude"

17351740 return ()

1736−

17371741 when (runrepl && not idesl) initScript

17381742

17391743 nobanner <- getNoBanner

@@ -1794,7 +1798,7 @@ idrisMain opts =

17941798 when (runrepl && not idesl) $ do

17951799-- clearOrigPats

17961800 startServer port orig mods

1797− runInputT (replSettings (Just historyFile)) $ repl orig mods efile

1801+ runInputT (replSettings (Just historyFile)) $ repl (force orig) mods efile

17981802 let idesock = IdemodeSocket `elem` opts

17991803 when (idesl) $ idemodeStart idesock orig inputs

18001804 ok <- noErrors

src/Idris/REPLParser.hs → src/Idris/REPL/Parser.hsrenamed+1−1

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

11

2−module Idris.REPLParser (parseCmd, help, allHelp, setOptions) where

2+module Idris.REPL.Parser (parseCmd, help, allHelp, setOptions) where

33

44import System.FilePath ((</>))

55import System.Console.ANSI (Color(..))

src/Idris/Reflection.hs+4−4

@@ -364,10 +364,10 @@ reifyArithTy (P _ n _) | n == reflm "ATDouble" = return ATFloat

364364reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)

365365

366366reifyNativeTy :: Term -> ElabD NativeTy

367−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

368−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

369−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

370−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

367+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

368+reifyNativeTy (P _ n _) | n == reflm "IT16" = return IT16

369+reifyNativeTy (P _ n _) | n == reflm "IT32" = return IT32

370+reifyNativeTy (P _ n _) | n == reflm "IT64" = return IT64

371371reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x

372372

373373reifyIntTy :: Term -> ElabD IntTy

src/Pkg/PParser.hs+3−3

@@ -5,11 +5,11 @@

55module Pkg.PParser where

66

77import Text.Trifecta hiding (span, charLiteral, natural, symbol, char, string, whiteSpace)

8−

8+import qualified Text.PrettyPrint.ANSI.Leijen as PP

99import Idris.Core.TT

1010import Idris.REPL

1111import Idris.AbsSyntaxTree

12−import Idris.ParseHelpers hiding (stringLiteral)

12+import Idris.Parser.Helpers hiding (stringLiteral)

1313import Idris.CmdOptions

1414

1515import Control.Monad.State.Strict

@@ -51,7 +51,7 @@ parseDesc :: FilePath -> IO PkgDesc

5151parseDesc fp = do

5252 p <- readFile fp

5353 case runparser pPkg defaultPkg fp p of

54− Failure err -> fail (show err)

54+ Failure err -> fail (show $ PP.plain err)

5555 Success x -> return x

5656

5757pPkg :: PParser PkgDesc

src/Pkg/Package.hs+1−1

@@ -142,7 +142,7 @@ documentPkg fp =

142142 setCurrentDirectory pkgDir

143143 let run l = runExceptT . execStateT l

144144 load [] = return ()

145− load (f:fs) = do loadModule f; load fs

145+ load (f:fs) = do loadModule f IBC_Building; load fs

146146 loader = do idrisMain opts; addImportDir (sourcedir pkgdesc); load fs

147147 idrisInstance <- run loader idrisInit

148148 setCurrentDirectory cd

src/Util/System.hs−4

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

22module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows,

33 writeSource, writeSourceText, readSource,

44 setupBundledCC, isATTY) where

5−

65-- System helper functions.

76

87import Control.Exception as CE

@@ -32,9 +31,6 @@ import System.Environment (getEnv, setEnv, getExecutablePath)

3231catchIO :: IO a -> (IOError -> IO a) -> IO a

3332catchIO = CE.catch

3433

35−throwIO :: IOError -> IO a

36−throwIO = CE.throw

37−

3834isWindows :: Bool

3935isWindows = os `elem` ["win32", "mingw32", "cygwin32"]

4036

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

22packages:

33- '.'

44flags:

@@ -11,3 +11,6 @@ extra-deps:

1111- cheapskate-0.1.0.4

1212- hscurses-1.4.2.0

1313- 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)

22

33TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

44

55test: $(TESTS)

66

7−%.test:

8− @perl ./runtest.pl $(patsubst %.test,%,$@)

97

10−test_js:

11− @perl ./runtest.pl without primitives005 sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 --codegen node

8+info: runtest

9+ @./runtest all

1210

13−update:

14− /usr/bin/env perl ./runtest.pl all -u

11+%.test: runtest

12+ @./runtest $(patsubst %.test,%,$@) -q

1513

16−diff:

17− /usr/bin/env perl ./runtest.pl all -d

14+test_js: runtest

15+ @./runtest without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 ffi007 primitives005 opts --codegen node

1816

19−time:

20− /usr/bin/env perl ./runtest.pl all -t

17+update: runtest

18+ @./runtest all -u

19+

20+diff: runtest

21+ @./runtest all -d

22+

23+time: runtest

24+ @./runtest all -t

2125

2226distclean:

23− rm -f *~

24− rm -f */output

27+ @rm runtest

28+ @rm -f *~

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 @@

11#!/usr/bin/env bash

2−idris $@ reg005.idr -o reg005

3−idris $@ basic001a.idr -o basic001a

2+${IDRIS:-idris} $@ reg005.idr -o reg005

3+${IDRIS:-idris} $@ basic001a.idr -o basic001a

44./reg005

55./basic001a

66rm -f reg005 basic001a *.ibc

test/basic002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 test006.idr -o test006

2+${IDRIS:-idris} $@ --nocolour --consolewidth 80 test006.idr -o test006

33./test006

44rm -f test006 test006.ibc

test/basic003/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test027.idr -o test027

2+${IDRIS:-idris} $@ test027.idr -o test027

33./test027

44rm -f test027 *.ibc

test/basic004/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test016.idr -o test016

2+${IDRIS:-idris} $@ test016.idr -o test016

33./test016

44rm -f test016 *.ibc

test/basic005/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test019.lidr -o test019

2+${IDRIS:-idris} $@ test019.lidr -o test019

33./test019

44rm -f test019 *.ibc

test/basic006/run+2−2

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

11#!/usr/bin/env bash

22

3−idris --consolewidth 80 $@ test020.idr -o test020

4−idris --consolewidth 80 $@ test020a.idr --check --nocolor

3+${IDRIS:-idris} --consolewidth 80 $@ test020.idr -o test020

4+${IDRIS:-idris} --consolewidth 80 $@ test020a.idr --check --nocolor

55./test020

66rm -f test020 *.ibc

test/basic007/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ -o test033 test033.idr

2+${IDRIS:-idris} $@ -o test033 test033.idr

33./test033

44rm -f *.ibc test033

test/basic008/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test036.idr -o test036

2+${IDRIS:-idris} $@ test036.idr -o test036

33./test036

44rm -f test036 *.ibc

test/basic009/A.idr+1

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

11module A

22

3+public export

34num : Nat

45num = 0

test/basic009/B/C.idr+1

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

11module B.C

22

3+public export

34num : Nat

45num = 1

test/basic009/run+3−3

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

11#!/usr/bin/env bash

22

3−idris --consolewidth 80 $@ Main.idr --nocolour --check && echo MAIN-PASS

4−idris --consolewidth 80 $@ Faulty.idr --nocolour --check && echo FAULTY-PASS

5−idris --consolewidth 80 $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS

3+${IDRIS:-idris} --consolewidth 80 $@ Main.idr --nocolour --check && echo MAIN-PASS

4+${IDRIS:-idris} --consolewidth 80 $@ Faulty.idr --nocolour --check && echo FAULTY-PASS

5+${IDRIS:-idris} --consolewidth 80 $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS

66

77

88rm -f *.ibc B/*.ibc

test/basic011/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ basic011.idr -p contrib -o basic011

2+${IDRIS:-idris} $@ basic011.idr -p contrib -o basic011

33./basic011

44rm -f basic011 *.ibc

test/basic012/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ basic012.idr -o basic012

2+${IDRIS:-idris} $@ basic012.idr -o basic012

33./basic012

44rm -f basic012 *.ibc

test/basic013/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ basic013.idr -o basic013

2+${IDRIS:-idris} $@ basic013.idr -o basic013

33./basic013

44rm -f basic013 *.ibc

test/basic014/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ basic014.idr --check

2+${IDRIS:-idris} $@ basic014.idr --check

33rm -f *.ibc

test/basic015/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ basic015.idr -o basic015

2+${IDRIS:-idris} $@ basic015.idr -o basic015

33./basic015

44rm -f basic015 *.ibc

test/basic016/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ CycleA.idr --consolewidth 80 --nocolour --check

2+${IDRIS:-idris} $@ CycleA.idr --consolewidth 80 --nocolour --check

33rm -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 @@

11#!/usr/bin/env bash

2−idris $@ bignum001.idr -o bignum001

2+${IDRIS:-idris} $@ bignum001.idr -o bignum001

33./bignum001

44rm -f bignum001 *.ibc

test/bignum002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ bignum002.idr -o bignum002

2+${IDRIS:-idris} $@ bignum002.idr -o bignum002

33./bignum002

44rm -f bignum002 *.ibc

test/bounded001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ bounded001.idr -o bounded001

2+${IDRIS:-idris} $@ bounded001.idr -o bounded001

33./bounded001

44rm -f bounded001 *.ibc

test/classes001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --quiet --nocolour --consolewidth 70 ClassName.idr < input

2+${IDRIS:-idris} $@ --quiet --nocolour --consolewidth 70 ClassName.idr < input

33rm -f bounded001 *.ibc

test/corecords001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ corecords001.idr -o corecords001

2+${IDRIS:-idris} $@ corecords001.idr -o corecords001

33./corecords001

44rm -f corecords001 corecords001.ibc

test/corecords002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ corecords002.idr -o corecords002

2+${IDRIS:-idris} $@ corecords002.idr -o corecords002

33./corecords002

44rm -f corecords002 corecords002.ibc

test/delab001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --quiet --nocolor delab001.idr < input

2+${IDRIS:-idris} $@ --quiet --nocolor delab001.idr < input

33rm -f *.ibc

test/disambig002/disambig002.idr+10−12

@@ -6,7 +6,7 @@ Dec0 : Type -> Type

66Dec0 = Dec

77

88Dec1 : {A : Type} -> (P : A -> Type) -> Type

9−Dec1 {A} P = (a : A) -> Dec0 (P a)

9+Dec1 {A} P = (a : A) -> Dec0 (P a)

1010

1111Unique : Type -> Type

1212Unique t = (p : t) -> (q : t) -> p = q

@@ -53,8 +53,8 @@ namespace Finite

5353filterTag : {A : Type} ->

5454 {P : A -> Type} ->

5555 Dec1 P ->

56− Vect n A ->

57− Sigma Nat (\ m => Vect m (Sigma A P))

56+ Vect n A ->

57+ DPair Nat (\ m => Vect m (DPair A P))

5858filterTag d1P Nil = (_ ** Nil)

5959filterTag d1P (a :: as) with (filterTag d1P as)

6060 | (_ ** tail) with (d1P a)

@@ -66,7 +66,7 @@ toVect : {A : Type} ->

6666 {P : A -> Type} ->

6767 Finite A ->

6868 Dec1 P ->

69− (n : Nat ** Vect n (Sigma A P))

69+ (n : Nat ** Vect n (DPair A P))

7070toVect fA d1P = filterTag d1P (toVect fA)

7171

7272sigmaUniqueLemma1 : {A : Type} ->

@@ -74,16 +74,14 @@ sigmaUniqueLemma1 : {A : Type} ->

7474 Unique1 {t0 = A} P ->

7575 (a : A) ->

7676 (p : P a) ->

77− (ss : Vect n (Sigma A P)) ->

78− Elem a (map getWitness ss) ->

77+ (ss : Vect n (DPair A P)) ->

78+ Elem a (map fst ss) ->

7979 Elem (a ** p) ss

8080

8181toVectComplete : {A : Type} ->

8282 {P : A -> Type} ->

83− (fA : Finite A) ->

84− (d1P : Dec1 P) ->

83+ (fA : Finite A) ->

84+ (d1P : Dec1 P) ->

8585 Unique1 {t0 = A} P ->

86− (s : Sigma A P) ->

87− Elem s (getProof (toVect fA d1P))

88−

89−

86+ (s : DPair A P) ->

87+ Elem s (snd (toVect fA d1P))

test/disambig002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ disambig002.idr --check

2+${IDRIS:-idris} $@ disambig002.idr --check

33rm -f *.ibc

test/docs001/run+1−1

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

11#!/usr/bin/env bash

2−idris --quiet --nocolor --consolewidth 80 docs001.idr < input

2+${IDRIS:-idris} --quiet --nocolor --consolewidth 80 docs001.idr < input

33rm *.ibc

test/docs002/run+1−1

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

11#!/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

33rm *.ibc

test/docs003/expected+1−1

@@ -5,7 +5,7 @@ Parameters:

55 f -- a parameterised type

66

77Methods:

8− map : Functor f => (m : a -> b) -> f a -> f b

8+ map : Functor f => (func : a -> b) -> f a -> f b

99 Apply a function across everything of type 'a' in a

1010 parameterised type

1111

test/docs003/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 --quiet --nocolor docs003.idr < input

2+${IDRIS:-idris} --consolewidth 80 --quiet --nocolor docs003.idr < input

33rm *.ibc

test/docs004/run+1−1

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

11#!/usr/bin/env bash

2−idris --quiet --nocolor --consolewidth 80 docs004.idr < input

2+${IDRIS:-idris} --quiet --nocolor --consolewidth 80 docs004.idr < input

33rm *.ibc

test/dsl001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test001.idr -o test001

2+${IDRIS:-idris} $@ test001.idr -o test001

33./test001

44rm -f test001 test001.ibc

test/dsl001/test001.idr+1−1

@@ -45,7 +45,7 @@ using (G : Vect n Ty)

4545 index_next = Pop

4646

4747 total

48− interp : Env G -> [static] (e : Expr G t) -> interpTy t

48+ interp : Env G -> %static (e : Expr G t) -> interpTy t

4949 interp env (Var i) = lookup i env

5050 interp env (Val x) = x

5151 interp env (Lam sc) = \x => interp (x :: env) sc

test/dsl002/Resimp.idr+3−1

@@ -3,6 +3,8 @@ module Resimp

33import public Data.Vect

44import public Data.Fin

55

6+%access public export

7+

68-- IO operations which read a resource

79data Reader : Type -> Type where

810 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)

122124 ioret : a -> IO a

123125 ioret = return

124126

125− interp : Env gam -> [static] (e : Res gam gam' t) ->

127+ interp : Env gam -> %static (e : Res gam gam' t) ->

126128 (Env gam' -> interpTy t -> IO u) -> IO u

127129

128130 interp env (Let val scope) k

test/dsl002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test014.idr -o test014

2+${IDRIS:-idris} $@ test014.idr -o test014

33./test014

44rm -f test014 Resimp.ibc test014.ibc

test/dsl003/run+1−1

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

11#!/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

33rm -f *.ibc

test/dsl004/run+3−3

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

11#!/usr/bin/env bash

2−idris $@ Door0.idr --check

3−idris $@ Door1.idr --check

4−idris $@ Door2.idr --check

2+${IDRIS:-idris} $@ Door0.idr --check

3+${IDRIS:-idris} $@ Door1.idr --check

4+${IDRIS:-idris} $@ Door2.idr --check

55rm -f *.ibc

test/effects001/run+2−2

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

11#!/usr/bin/env bash

2−idris -p effects $@ test021.idr -o test021

3−idris -p effects $@ test021a.idr -o test021a

2+${IDRIS:-idris} -p effects $@ test021.idr -o test021

3+${IDRIS:-idris} -p effects $@ test021a.idr -o test021a

44./test021

55./test021a

66rm -f test021 test021a *.ibc

test/effects002/run+1−1

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

11#!/usr/bin/env bash

2−idris -p effects $@ test025.idr -o test025

2+${IDRIS:-idris} -p effects $@ test025.idr -o test025

33./test025

44rm -f test025 *.ibc

test/effects003/VectMissing.idr+1−3

@@ -3,9 +3,7 @@ module VectMissing

33import Data.Fin

44import Data.Vect

55

6−implementation Uninhabited (Elem x []) where

7− uninhabited Here impossible

8−

6+export

97shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a

108shrink (x :: ys) Here = ys

119shrink (y :: []) (There p) = absurd p

test/effects003/run+1−1

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

11#!/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

33./hangman < input

44rm -f hangman *.ibc

test/effects004/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ effects004.idr -o effects004 -p effects

2+${IDRIS:-idris} $@ effects004.idr -o effects004 -p effects

33./effects004 < input

44rm -f effects004 *.ibc

test/effects005/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ defaultLogger.idr -o default -p effects

2+${IDRIS:-idris} $@ defaultLogger.idr -o default -p effects

33./default

4−idris $@ categoryLogger.idr -o category -p effects

4+${IDRIS:-idris} $@ categoryLogger.idr -o category -p effects

55./category

66rm -f default category *.ibc

test/error001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test002.idr --check --noprelude --consolewidth 70

2+${IDRIS:-idris} $@ test002.idr --check --noprelude --consolewidth 70

33rm -f *.ibc

test/error002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test031.idr -o test031

2+${IDRIS:-idris} $@ test031.idr -o test031

33./test031

44rm -f test031 *.ibc

test/error003/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ ErrorReflection.idr --nocolour --check

2+${IDRIS:-idris} --consolewidth 80 $@ ErrorReflection.idr --nocolour --check

33rm -f *.ibc

test/error004/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ FunErrTest.idr --nocolour --check

2+${IDRIS:-idris} --consolewidth 80 $@ FunErrTest.idr --nocolour --check

33rm -f *.ibc

test/error005/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check --nocolour error005.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check --nocolour error005.idr

33rm -f *.ibc

test/error006/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check --nocolour WithPatsNoWith.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check --nocolour WithPatsNoWith.idr

33rm -f *.ibc

test/ffi001/run+1−1

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

11#!/usr/bin/env bash

2−idris --quiet --nocolour test022.idr --exec main

2+${IDRIS:-idris} --quiet --nocolour test022.idr --exec main

33rm -f *.ibc

test/ffi002/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 --quiet test023.idr -o test023

2+${IDRIS:-idris} --consolewidth 80 --quiet test023.idr -o test023

33rm -f test023 *.ibc

test/ffi003/run+1−1

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

11#!/usr/bin/env bash

2−idris --quiet --nocolour test024.idr --exec main < input

2+${IDRIS:-idris} --quiet --nocolour test024.idr --exec main < input

33rm -f *.ibc

test/ffi004/run+1−1

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

11#!/usr/bin/env bash

2−idris --quiet --nocolour --check test026.idr

2+${IDRIS:-idris} --quiet --nocolour --check test026.idr

33rm -f *.ibc

test/ffi005/run+1−1

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

11#!/usr/bin/env bash

22

3−idris $@ Postulate.idr -o postulate

3+${IDRIS:-idris} $@ Postulate.idr -o postulate

44./postulate

55rm -f postulate *.ibc

test/ffi006/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ ffi006.idr --interface -o ffi006.o

2+${IDRIS:-idris} $@ ffi006.idr --interface -o ffi006.o

33${CC:=cc} ffi006.c ffi006.o `idris --include` `idris --link` -o ffi006

44./ffi006

55rm -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 @@

11#!/usr/bin/env bash

2−idris $@ folding001.idr -o folding001

2+${IDRIS:-idris} $@ folding001.idr -o folding001

33./folding001

44rm -f folding001 *.ibc

test/idrisdoc001/run+1−1

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

11#!/usr/bin/env bash

22# 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

44rm -rf *.ibc *_doc

test/idrisdoc002/TestFunctions.idr+2−1

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

11module TestFunctions

22

33||| Test function

4+public export

45test : ()

5−test = ()

6+test = ()

test/idrisdoc002/run+1−1

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

11#!/usr/bin/env bash

22# Tests that documentation is generated for functions

3−idris --mkdoc test_functions.ipkg

3+${IDRIS:-idris} --mkdoc test_functions.ipkg

44[ -d test_functions_doc ] && echo "Functions are documented"

55rm -rf *.ibc *_doc

test/idrisdoc003/TestDatatypes.idr+2−1

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

11module TestDatatypes

22

33||| This is another test

4+public export

45data Test : Type where

56 ||| Test constructor

6− ATest : Test

7+ ATest : Test

test/idrisdoc003/run+1−1

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

11#!/usr/bin/env bash

22# Tests that documentation is generated for data types

3−idris --mkdoc test_datatypes.ipkg

3+${IDRIS:-idris} --mkdoc test_datatypes.ipkg

44[ -d test_datatypes_doc ] && echo "Data types are documented"

55rm -rf *.ibc *_doc

test/idrisdoc004/TestTypeclasses.idr+1

@@ -3,6 +3,7 @@ module TestTypeclasses

33||| This is a test

44|||

55||| @ a Test arg

6+public export

67interface Test a where

78 ||| Test function

89 test : a -> Int

test/idrisdoc004/run+1−1

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

11#!/usr/bin/env bash

22# Tests that documentation is generated for typeclasses

3−idris --mkdoc test_typeclasses.ipkg

3+${IDRIS:-idris} --mkdoc test_typeclasses.ipkg

44[ -d test_typeclasses_doc ] && echo "Typeclasses are documented"

55rm -rf *.ibc *_doc

test/idrisdoc005/TestTracing.idr+2−1

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

11module TestTracing

22

3+public export

34test : Bool

4−test = True

5+test = True

test/idrisdoc005/run+1−1

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

11#!/usr/bin/env bash

22# Tests that references to other namespaces are traced

3−idris --mkdoc test_tracing.ipkg

3+${IDRIS:-idris} --mkdoc test_tracing.ipkg

44[ -f test_tracing_doc/docs/TestTracing.html ] && echo "TestTracing: Check"

55[ -f test_tracing_doc/docs/Prelude.Bool.html ] && echo "Prelude.Bool: Check"

66rm -rf *.ibc *_doc

test/idrisdoc006/A/fully/Qualified/NAME.idr+2−2

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

11module A.fully.Qualified.NAME

22

33||| This is another test

4−data Test : Type where

4+public export data Test : Type where

55 ||| Test constructor

6− ATest : Test

6+ ATest : Test

test/idrisdoc006/B.idr+2−1

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

11module B

22

33||| Test function

4+public export

45test : ()

5−test = ()

6+test = ()

test/idrisdoc006/run+2−2

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

11#!/usr/bin/env bash

22# Tests that documentation properly is merged with existent.

3−idris --mkdoc package_a.ipkg

3+${IDRIS:-idris} --mkdoc package_a.ipkg

44[ -f test_merge_doc/IdrisDoc ] && echo "IdrisDoc file written"

5−idris --mkdoc package_b.ipkg

5+${IDRIS:-idris} --mkdoc package_b.ipkg

66ls -1p test_merge_doc/docs

77if grep -q "href\\=\"docs/A.fully.Qualified.NAME\\.html\"" test_merge_doc/index.html; then

88 echo A.fully.Qualified.NAME is in the index

test/idrisdoc007/run+1−1

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

11#!/usr/bin/env bash

22# Tests that documentation only is written when safe

33mkdir do_not_delete_doc

4−idris --mkdoc package.ipkg > nowhere

4+${IDRIS:-idris} --mkdoc package.ipkg > nowhere

55echo Exit status \(expects 1\): $?

66rm -rf do_not_delete_doc *.ibc nowhere

test/idrisdoc008/Abstract.idr+2−2

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

11module Abstract

22

3−abstract

3+export

44frozen : ()

5−frozen = ()

5+frozen = ()

test/idrisdoc008/Visible.idr+2−2

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

11module Visible

22

3−public

3+public export

44visible : ()

5−visible = ()

5+visible = ()

test/idrisdoc008/run+1−1

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

11#!/usr/bin/env bash

22# Tests that documentation is generated for both public and abstract members.

3−idris --mkdoc visibility.ipkg

3+${IDRIS:-idris} --mkdoc visibility.ipkg

44[ -f visibility_doc/docs/Abstract.html ] && echo "Abstract members are documented"

55[ -f visibility_doc/docs/Visible.html ] && echo "Public members are documented"

66rm -rf *.ibc *_doc

test/idrisdoc009/Test.idr+2

@@ -23,6 +23,8 @@

2323module Test

2424import Data.Complex

2525

26+%access public export

27+

2628myplus : Nat -> Nat -> Nat

2729myplus Z j = j

2830myplus (S k) j = S (myplus k j)

test/idrisdoc009/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --nocolour --quiet Test.idr < input

2+${IDRIS:-idris} $@ --nocolour --quiet Test.idr < input

33rm -f *.ibc

test/interactive001/run+1−1

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

11#!/usr/bin/env bash

2−idris --quiet test032.idr < input

2+${IDRIS:-idris} --quiet test032.idr < input

33rm -f *.ibc

test/interactive002/expected+1−1

@@ -5,6 +5,6 @@ Nat

55Vect (n + m) a

66Nat

77Nat

8−S n

8+(S n)

99String

1010()

test/interactive002/run+1−1

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

11#!/usr/bin/env bash

2−idris --quiet interactive002.idr < input

2+${IDRIS:-idris} --quiet interactive002.idr < input

33rm -f *.ibc

test/interactive003/run+1−1

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

11#!/usr/bin/env bash

2−idris --quiet interactive003.idr < input

2+${IDRIS:-idris} --quiet interactive003.idr < input

33rm -f *.ibc

test/interactive004/expected+1−1

@@ -1,2 +1,2 @@

11plus ?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 @@

11#!/usr/bin/env bash

2−idris --quiet interactive004.idr < input

2+${IDRIS:-idris} --quiet interactive004.idr < input

33rm -f *.ibc

test/interactive005/run+1−1

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

11#!/usr/bin/env bash

2−idris --nocolour --quiet interactive005.idr --consolewidth 70 < input

2+${IDRIS:-idris} --nocolour --quiet interactive005.idr --consolewidth 70 < input

33rm -f *.ibc

44rm -f hello.bytecode

55rm -f hello

test/interactive006/run+1−1

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

11#!/usr/bin/env bash

2−idris --quiet --port 5000 interactive006.idr < input

2+${IDRIS:-idris} --quiet --port 5000 interactive006.idr < input

33rm -f *.ibc

test/interactive007/run+1−1

@@ -1,2 +1,2 @@

11#!/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 @@

11#!/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 @@

11#!/usr/bin/env bash

2−idris --quiet interactive009.idr < input

2+${IDRIS:-idris} --quiet interactive009.idr < input

33rm -f *.ibc

test/interactive010/expected+3−3

@@ -1,12 +1,12 @@

11Prelude.List.(++) : List a -> List a -> List a

22Prelude.Strings.(++) : String -> String -> String

3−a is not an implicit argument of Prelude.Classes./

3+a is not an implicit argument of Prelude.Interfaces./

44Usage is :doc <functionname>

55Usage is :wc <functionname>

66Usage 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}

88

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}

1010(input):1:1: error: expected: ":",

1111 dependent type signature,

1212 end of input

test/interactive010/run+1−1

@@ -1,2 +1,2 @@

11#!/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 @@

11#!/usr/bin/env bash

2−idris --quiet interactive011.idr < input

2+${IDRIS:-idris} --quiet interactive011.idr < input

33rm -f *.ibc

test/interactive012/run+1−1

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 70 --quiet interactive012.idr < input

2+${IDRIS:-idris} --nocolour --consolewidth 70 --quiet interactive012.idr < input

33rm -f *.ibc

test/io001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test004.idr -o test004

2+${IDRIS:-idris} $@ test004.idr -o test004

33./test004

44rm -f test004 test004.ibc testfile

test/io001/test004.idr+1−1

@@ -17,7 +17,7 @@ dumpFile fn = do { Right h <- openFile fn Read

1717 closeFile h }

1818

1919main : IO ()

20−main = do { Right h <- openFile "testfile" Write

20+main = do { Right h <- openFile "testfile" WriteTruncate

2121 fPutStr h "Hello!\nWorld!\n...\n3\n4\nLast line\n"

2222 closeFile h

2323 putStrLn "Reading testfile"

test/io002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test008.idr -o test008

2+${IDRIS:-idris} $@ test008.idr -o test008

33./test008

44rm -f test008 test008.ibc

test/io003/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ test018.idr -p contrib -o test018

3−idris $@ test018a.idr -p contrib -o test018a

2+${IDRIS:-idris} $@ test018.idr -p contrib -o test018

3+${IDRIS:-idris} $@ test018a.idr -p contrib -o test018a

44./test018

55#./test018a

66rm -f test018 test018a *.ibc

test/literate001/Lit.lidr+2−2

@@ -2,12 +2,12 @@

22

33Test some string primitives while we're at it

44

5−> st : String

5+> export st : String

66> st = "abcdefg"

77

88Literate main program

99

10−> main : IO ()

10+> export main : IO ()

1111> main = do { putStrLn (show (strHead st))

1212> putStrLn (show (strIndex st 3))

1313> putStrLn (strCons 'z' st)

test/literate001/run+2−2

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ test003a.lidr --check

3−idris --consolewidth 80 $@ test003.lidr -o test003

2+${IDRIS:-idris} --consolewidth 80 $@ test003a.lidr --check

3+${IDRIS:-idris} --consolewidth 80 $@ test003.lidr -o test003

44./test003

55rm -f test003 test003.ibc Lit.ibc

test/meta001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --check --nocolour --consolewidth 70 Finite.idr

2+${IDRIS:-idris} $@ --check --nocolour --consolewidth 70 Finite.idr

33rm -f *.ibc

test/meta002/AgdaStyleReflection.idr+94−9

@@ -2,6 +2,10 @@

22||| Idris's reflected elaboration. Requires handling type class

33||| resolution and implicit arguments - some of the same features as

44||| 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.

59module AgdaStyleReflection

610

711

@@ -11,6 +15,7 @@ import Pruviloj

1115%default total

1216

1317

18+

1419||| Function arguments as provided at the application site

1520record Arg a where

1621 constructor MkArg

@@ -20,6 +25,10 @@ record Arg a where

2025implementation Functor Arg where

2126 map f (MkArg plic x) = MkArg plic (f x)

2227

28+implementation Show a => Show (Arg a) where

29+ showPrec d (MkArg plic x) = showCon d "MkArg" $ showArg plic ++ showArg x

30+

31+

2332||| Reflected terms, in the tradition of Agda's reflection library

2433data Term

2534 = Var Nat (List (Arg Term))

@@ -37,6 +46,41 @@ unApply tm = unApply' tm []

3746 unApply' (RApp f x) xs = unApply' f (x::xs)

3847 unApply' notApp xs = (notApp, xs)

3948

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+

4084||| Quote a reflected Idris term to a Term in some induced local context

4185covering

4286quoteTerm' : List TTName -> Raw -> Elab Term

@@ -183,16 +227,39 @@ covering

183227spliceTerm : Term -> Elab ()

184228spliceTerm = spliceTerm' []

185229

186−||| Lift an Agda-style tactic into an Idris-style tactic

230+syntax "splice" [tm] = %runElab (spliceTerm tm)

231+

187232covering

188−quoteGoalImpl : (Term -> Term) -> Elab ()

189−quoteGoalImpl f = do compute

190− g <- goalType >>= quoteTerm

191− spliceTerm (f g)

233+quoteGoalImpl : TTName -> Elab ()

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 ()

256+tacticImpl tac = do g <- goalType >>= quoteTerm

257+ AgdaStyleReflection.spliceTerm (tac g)

258+

259+syntax "tactic" [tacticCode] =

260+ %runElab (tacticImpl tacticCode)

192261

193−syntax "quoteGoal" {x} "in" [expr] = %runElab (quoteGoalImpl (\x => expr))

194262

195−syntax "tactic" [expr] = %runElab (quoteGoalImpl expr)

196263

197264

198265

@@ -231,12 +298,30 @@ covering

231298trivial : (goal : Term) -> Term

232299trivial = perhaps . trivial'

233300

234−foo : (Nat, (), Nat, Either (() -> ()) Void)

235−foo = quoteGoal x in trivial x

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

304+--foo : (Nat, (), Either Void Nat, Nat -> ())

305+--foo = quoteGoal g in splice (trivial g)

236306

307+

308+-- WORKS because "tactic" takes care of the sequencing of operations

237309bar : (Nat, (), Either Void Nat, Nat -> ())

238310bar = tactic trivial

239311

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+

240325-- When checking right hand side of baz:

241326-- PROOF SEARCH FAILURE is not defined.

242327baz : (Nat, Void)

test/meta002/Tacs.idr+4−5

@@ -208,7 +208,7 @@ namespace STLC

208208

209209 -- Now we put this hole variable into our sigma constructor

210210 -- 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 []))

212212 solve

213213 focus tmH

214214 mkTerm [] tm

@@ -287,18 +287,17 @@ namespace STLC

287287 apply `(UnitCon {env=~(Var envH)})

288288 []

289289 solve

290− testElab : Sigma Ty (Tm [])

290+ testElab : DPair Ty (Tm [])

291291 testElab = %runElab (elaborateSTLC (App (Lam "x" UnitCon) UnitCon))

292292

293− testElab2 : Sigma Ty (Tm [])

293+ testElab2 : DPair Ty (Tm [])

294294 testElab2 = %runElab (elaborateSTLC (App (Lam "x" (Var 0)) UnitCon))

295295

296296 -- Doesn't work! :-)

297− testElab3 : Sigma Ty (Tm [])

297+ testElab3 : DPair Ty (Tm [])

298298 testElab3 = %runElab (elaborateSTLC (App (Lam "x" (App (Var 0) (Var 0)))

299299 (Lam "x" (App (Var 0) (Var 0)))))

300300 -- Error is:

301301 -- Tacs.idr line 247 col 14:

302302 -- When elaborating right hand side of testElab3:

303303 -- Unifying ty and Tacs.STLC.ARR ty t would lead to infinite value

304−

test/meta002/expected+2−2

@@ -1,9 +1,9 @@

11Tacs.idr:298:15:

22When checking right hand side of testElab3 with expected type

3− Sigma Ty (Tm [])

3+ DPair Ty (Tm [])

44

55Unifying ty and ARR ty t would lead to infinite value

6−AgdaStyleReflection.idr:243:5:

6+AgdaStyleReflection.idr:328:5:

77When checking right hand side of baz with expected type

88 (Nat, Void)

99

test/meta002/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ -p pruviloj --nocolour --check --consolewidth 70 Tacs.idr

3−idris $@ -p pruviloj --nocolour --check --consolewidth 70 AgdaStyleReflection.idr

2+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 Tacs.idr

3+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 AgdaStyleReflection.idr

44# Disabled due to excess memory consumption

55# idris $@ -p pruviloj --nocolour --check --consolewidth 70 Deriving.idr

66rm -f *.ibc

test/meta003/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --nocolour --check --consolewidth 70 BadDef.idr

2+${IDRIS:-idris} $@ --nocolour --check --consolewidth 70 BadDef.idr

33rm -f *.ibc

test/meta004/run+1−1

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

11#!/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

33rm -f *.ibc

test/mktest.pl+1−1

@@ -13,7 +13,7 @@ chdir($test);

1313open(FOO,">run");

1414

1515print 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";

1717print FOO "./$test\n";print FOO "rm -f $test *.ibc\n";

1818

1919close(FOO);

test/pkg001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --build test.ipkg

2+${IDRIS:-idris} $@ --build test.ipkg

33rm -f *.ibc

test/pkg002/run+1−1

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

11#!/usr/bin/env bash

22### Test: IPKG executable names can be any namespaced identifier.

3−idris $@ --build test.ipkg

3+${IDRIS:-idris} $@ --build test.ipkg

44rm -f *.ibc

55rm -f some.namespaced.identifier

test/pkg003/run+1−1

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

11#!/usr/bin/env bash

22### Test: IPKG executable names can be a quoted string

33### containing a valid filename.

4−idris $@ --build test.ipkg

4+${IDRIS:-idris} $@ --build test.ipkg

55rm -f *.ibc

66rm -f 'quoting-allows-hyphens and spaces and fun stuff!'

test/pkg004/expected+3−3

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

1−Uncaught error: user error (test.ipkg:10:1: error: filename

1+Uncaught error: user error (test.ipkg:9:1: error: filename

22 must contain no directory

33 component, expected: space

4−<EOF>

5−^ )

4+<EOF>

5+^ )

test/pkg004/run+1−1

@@ -2,5 +2,5 @@

22### Test: IPKG executable names CANNOT include a directory separator.

33# TODO: Verify that a name like "a/b\c" is rejected by both *NIX and Windows

44# (assuming these tests get run on Windows).

5−idris $@ --consolewidth 80 --nobanner --nocolor --build test.ipkg

5+${IDRIS:-idris} $@ --build test.ipkg

66rm -f *.ibc

test/pkg004/test.ipkg−1

@@ -2,7 +2,6 @@ package test

22

33modules = Main

44

5−

65opts = "--warnpartial --warnreach --nocolour --quiet --consolewidth 80"

76

87main = Main

test/primitives001/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ test005.idr -o test005

2+${IDRIS:-idris} $@ test005.idr -o test005

33./test005

4−idris $@ substring.idr -o substring

4+${IDRIS:-idris} $@ substring.idr -o substring

55./substring < input

66rm -f test005 substring *.ibc

test/primitives003/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ -o test038 test038.idr --nocolour

2+${IDRIS:-idris} $@ -o test038 test038.idr --nocolour

33./test038

44rm -f test038 *.ibc

55

test/primitives004-disabled/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ -o primitives004 primitives004.idr --nocolour

2+${IDRIS:-idris} $@ -o primitives004 primitives004.idr --nocolour

33./primitives004

44rm -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 @@

11#!/usr/bin/env bash

2−idris $@ test029.idr --consolewidth 80 --nocolour --check test029

2+${IDRIS:-idris} $@ test029.idr --consolewidth 80 --nocolour --check test029

33rm -f *.ibc

test/proof002/Reflect.idr+3−4

@@ -2,6 +2,7 @@ module Reflect

22

33import Decidable.Equality

44

5+%access public export

56%default total

67

78using (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))

4344 let (yl ** (yr, yprf)) = expr_r ey in

4445 appRExpr _ _ xr yr xprf yprf

4546 where

46− appRExpr : (xs', ys' : List a) ->

47+ appRExpr : (xs', ys' : List a) ->

4748 {G : List (List a)} -> {xs, ys : List a} ->

4849 RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->

4950 (ws' ** (RExpr G ws', xs' ++ ys' = ws'))

@@ -205,6 +206,4 @@ Reflect.bp1 = proof {

205206-- prover.

206207

207208syntax AssocProof [ty] = quoteGoal x by reflectEq ty [] in

208− getJust (prove (getProof x)) ItIsJust

209−

210−

209+ getJust (prove (snd x)) ItIsJust

test/proof002/expected+4−4

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

1−Reflect.idr:173:21-26:

1+Reflect.idr:174:21-26:

22This style of tactic proof is deprecated. See %runElab for the replacement.

3−Reflect.idr:182:21-26:

3+Reflect.idr:183:21-26:

44This style of tactic proof is deprecated. See %runElab for the replacement.

5−Reflect.idr:190:15-20:

5+Reflect.idr:191:15-20:

66This style of tactic proof is deprecated. See %runElab for the replacement.

77test030a.idr:12:26-14:1:

88When checking right hand side of testReflect1 with expected type

@@ -12,7 +12,7 @@ When checking an application of function Reflect.getJust:

1212 Type mismatch between

1313 IsJust (Just x1) (Type of ItIsJust)

1414 and

15− IsJust (prove (getProof x)) (Expected type)

15+ IsJust (prove (snd x)) (Expected type)

1616

1717 Specifically:

1818 Type mismatch between

test/proof002/run+2−2

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ test030.idr --check --nocolour

3−idris --consolewidth 80 $@ test030a.idr --check --nocolour

2+${IDRIS:-idris} --consolewidth 80 $@ test030.idr --check --nocolour

3+${IDRIS:-idris} --consolewidth 80 $@ test030a.idr --check --nocolour

44rm -f *.ibc

test/proof002/test030.idr−1

@@ -10,4 +10,3 @@ total

1010testReflect1 : (xs, ys : List a) ->

1111 ((xs ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs)))

1212testReflect1 {a} xs ys = AssocProof a

13−

test/proof003/Parity.idr+2

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

11module Parity

22

3+%access public export

4+

35data Parity : Nat -> Type where

46 Even : {n : Nat} -> Parity (n + n)

57 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:

22This style of tactic proof is deprecated. See %runElab for the replacement.

3−Parity.idr:22:18-23:

3+Parity.idr:24:18-23:

44This style of tactic proof is deprecated. See %runElab for the replacement.

55test015.idr:88:15-20:

66This style of tactic proof is deprecated. See %runElab for the replacement.

test/proof003/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test015.idr --nocolour --consolewidth 80 -o test015

2+${IDRIS:-idris} $@ test015.idr --nocolour --consolewidth 80 -o test015

33./test015

44rm -f test015 Parity.ibc test015.ibc

test/proof004/run+1−1

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

11#!/usr/bin/env bash

2−idris --check $@ test035.idr

2+${IDRIS:-idris} --check $@ test035.idr

33rm -f *.ibc

test/proof005/run+1−1

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

11#!/usr/bin/env bash

2−idris --check $@ DefaultArgSubstitutionSuccess.idr

2+${IDRIS:-idris} --check $@ DefaultArgSubstitutionSuccess.idr

33rm -f *.ibc

test/proof006/run+1−1

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

11#!/usr/bin/env bash

2−idris --check $@ DefaultArgSubstitutionSyntax.idr

2+${IDRIS:-idris} --check $@ DefaultArgSubstitutionSyntax.idr

33rm -f *.ibc

test/proof007/run+1−1

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check $@ DefaultArgUnknownName.idr

2+${IDRIS:-idris} --nocolour --consolewidth 80 --check $@ DefaultArgUnknownName.idr

33rm -f *.ibc

test/proof008/run+1−1

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check $@ ClaimAndUnfocus.idr

2+${IDRIS:-idris} --nocolour --consolewidth 80 --check $@ ClaimAndUnfocus.idr

33rm -f *.ibc

test/proof009/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --consolewidth 70 --quiet proof009.idr < input

2+${IDRIS:-idris} $@ --consolewidth 70 --quiet proof009.idr < input

33rm -f *.ibc

test/proof010/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ proof010.idr -o proof010

2+${IDRIS:-idris} $@ proof010.idr -o proof010

33./proof010

44rm -f proof010 *.ibc

test/proofsearch001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --check proofsearch001.idr

2+${IDRIS:-idris} $@ --check proofsearch001.idr

33rm -f *.ibc

test/proofsearch002/Process.idr+1−1

@@ -3,7 +3,7 @@ module Process

33import System.Concurrency.Raw

44import public Data.List -- public, to get proof search machinery

55

6−%access public

6+%access public export

77

88-- Process IDs are parameterised by their interface. A request of type

99-- 'iface t' will get a response of type 't'

test/proofsearch002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --check proofsearch002.idr

2+${IDRIS:-idris} $@ --check proofsearch002.idr

33rm -f *.ibc

test/proofsearch003/run+1−1

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

11#!/usr/bin/env bash

2−idris --check proofsearch003.idr

2+${IDRIS:-idris} --check proofsearch003.idr

33rm -f *.ibc

test/pruviloj001/run+1−1

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

11#!/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

33rm -f *.ibc

test/quasiquote001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ QuasiquoteBasics.idr -o quasiquote001

2+${IDRIS:-idris} $@ QuasiquoteBasics.idr -o quasiquote001

33./quasiquote001

44rm -f quasiquote001 *.ibc

test/quasiquote002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ GoalQQuote.idr -o quasiquote002

2+${IDRIS:-idris} $@ GoalQQuote.idr -o quasiquote002

33./quasiquote002

44rm -f quasiquote002 *.ibc

test/quasiquote003/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check NoInfer.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check NoInfer.idr

33rm -f *.ibc

test/quasiquote004/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check --nocolour Quasiquote004.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check --nocolour Quasiquote004.idr

33rm -f *.ibc

test/quasiquote005/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --check --nocolour Quasiquote005.idr

2+${IDRIS:-idris} $@ --check --nocolour Quasiquote005.idr

33rm -f *.ibc

test/quasiquote006/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr

2+${IDRIS:-idris} $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr

33rm -f *.ibc

test/records001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test011.idr -o test011

2+${IDRIS:-idris} $@ test011.idr -o test011

33./test011

44rm -f test011 test011.ibc

test/records002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ record002.idr -o record002

2+${IDRIS:-idris} $@ record002.idr -o record002

33./record002

44rm -f record002 *.ibc

test/records003/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ records003.idr -o records003

2+${IDRIS:-idris} $@ records003.idr -o records003

33./records003

44rm -f records003 *.ibc

test/records004/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ records004.idr -o records004

2+${IDRIS:-idris} $@ records004.idr -o records004

33./records004

44rm -f records004 *.ibc

test/reg001/reg001.idr+13−14

@@ -37,7 +37,7 @@ filterTagP {n = S m} p (a :: as) q with (p a)

3737 **

3838 ((a ** believe_me Oh)

3939 ::

40− (fst (getProof (filterTagP p as (believe_me Oh)))),

40+ (fst (snd (filterTagP p as (believe_me Oh)))),

4141 Oh

4242 )

4343 )

@@ -95,7 +95,7 @@ mytranspose (x :: y :: xs)

9595

9696using (A : Type, B : A->Type, C : Type)

9797 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)

9999

100100

101101m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->

@@ -144,7 +144,7 @@ X : Nat -> Type

144144X t = (c : Nat ** So (c < 5))

145145

146146column : X t -> Nat

147−column = getWitness

147+column = fst

148148

149149data Action = Left | Ahead | Right

150150

@@ -161,31 +161,31 @@ isSubsetOf : Set univ => univ -> univ -> Type

161161isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)

162162

163163interface Set univ => HasPower univ where

164− Powerset : (a : univ) ->

165− Sigma univ (\Pa => (c : univ) ->

164+ Powerset : (a : univ) ->

165+ DPair univ (\Pa => (c : univ) ->

166166 (isSubsetOf c a) -> member c Pa)

167167

168168powerset : HasPower univ => univ -> univ

169−powerset {univ} a = getWitness (Powerset a)

169+powerset {univ} a = fst (Powerset a)

170170

171171mapFilter : (alpha -> beta) ->

172− (alpha -> Bool) ->

173− Vect n alpha ->

172+ (alpha -> Bool) ->

173+ Vect n alpha ->

174174 (n : Nat ** Vect n beta)

175175mapFilter f p Nil = (_ ** Nil)

176176mapFilter 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)))

178178 | False = mapFilter f p as

179179

180180hVectEx1 : HVect [String, List Nat, Nat, (Nat, Nat)]

181181hVectEx1 = ["Hello",[1,2,3],42,(0,10)]

182−

182+

183183vecfoo : HVect [String, List Nat, Nat, (Nat, Nat)]

184184vecfoo = put (S (S Z)) hVectEx1

185185

186186foom : Monad m => Int -> m Int

187−foom = pure

188−

187+foom = pure

188+

189189bar : IO ()

190190bar = case foom 5 of

191191 Nothing => print 42

@@ -193,7 +193,7 @@ bar = case foom 5 of

193193

194194Max : (Nat -> Type) -> Type

195195Max p = (Nat , (k : Nat) -> p k -> Nat)

196−

196+

197197maxEquiv : Max p -> (n1 : Nat) -> p n1 -> Nat

198198maxEquiv a n1 pr1 = snd a n1 pr1

199199

@@ -207,4 +207,3 @@ data Kappa : (r : Rho) -> Type where K : Kappa r

207207kappa : Kappa (rho r) -> Kappa (rho r)

208208kappa {r} k = k' where -- k' : Kappa (rho r)

209209 k' = k

210−

test/reg001/run+1−1

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

11#!/usr/bin/env bash

2−idris reg001.idr --check

2+${IDRIS:-idris} reg001.idr --check

33rm -rf reg001.ibc

44

test/reg002/run+1−1

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

11#!/usr/bin/env bash

2−idris reg012.idr -o reg012

2+${IDRIS:-idris} reg012.idr -o reg012

33./reg012

44rm -f reg012 *.ibc

test/reg003/run+2−2

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 --check reg003.idr

3−idris --consolewidth 80 --check reg003a.idr

2+${IDRIS:-idris} --consolewidth 80 --check reg003.idr

3+${IDRIS:-idris} --consolewidth 80 --check reg003a.idr

44rm -f *.ibc

test/reg004/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg004.idr -o reg004

2+${IDRIS:-idris} $@ reg004.idr -o reg004

33./reg004

44rm -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 @@

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg006.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ reg006.idr --check

33rm -f *.ibc

test/reg007/A.lidr+1−1

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

11> module A

22

3−> n : Nat

3+> public export n : Nat

44> n = ?lala

55

test/reg007/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 --nocolour --check $@ reg007.lidr

2+${IDRIS:-idris} --consolewidth 80 --nocolour --check $@ reg007.lidr

33rm -f *.ibc

test/reg010/run+1−1

@@ -1,2 +1,2 @@

11#!/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 @@

11#!/usr/bin/env bash

2−idris $@ reg013.idr -o reg013

2+${IDRIS:-idris} $@ reg013.idr -o reg013

33./reg013

44rm -f reg013 *.ibc

test/reg016/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg016.idr -o reg016

2+${IDRIS:-idris} $@ reg016.idr -o reg016

33./reg016

44rm -f reg016 *.ibc

test/reg017/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 reg017.idr -o reg017

2+${IDRIS:-idris} $@ --nocolour --consolewidth 80 reg017.idr -o reg017

33./reg017

44rm -f reg017 *.ibc

test/reg018/run+4−4

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg018a.idr --check

3−idris --consolewidth 80 $@ reg018b.idr --check

4−idris --consolewidth 80 $@ reg018c.idr --check

5−idris --consolewidth 80 $@ reg018d.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ reg018a.idr --check

3+${IDRIS:-idris} --consolewidth 80 $@ reg018b.idr --check

4+${IDRIS:-idris} --consolewidth 80 $@ reg018c.idr --check

5+${IDRIS:-idris} --consolewidth 80 $@ reg018d.idr --check

66rm *.ibc

test/reg020/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg020.idr -o reg020

2+${IDRIS:-idris} $@ reg020.idr -o reg020

33./reg020

44rm -f reg020 *.ibc

test/reg023/run+1−1

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ reg023.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ reg023.idr --check

33rm -f *.ibc

test/reg024/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg024.idr -o reg024

2+${IDRIS:-idris} $@ reg024.idr -o reg024

33./reg024

44rm -f reg024 *.ibc

test/reg025/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg025.idr -o reg025

2+${IDRIS:-idris} $@ reg025.idr -o reg025

33./reg025

44rm -f reg025 *.ibc

test/reg027/run+2−2

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg027.idr -o reg027

2+${IDRIS:-idris} --consolewidth 80 $@ reg027.idr -o reg027

33./reg027

4−idris --consolewidth 80 $@ reg027a.idr --check

4+${IDRIS:-idris} --consolewidth 80 $@ reg027a.idr --check

55rm -f reg027 *.ibc

test/reg028/run+2−2

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg028.idr --check

3−idris --consolewidth 80 $@ reg028a.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ reg028.idr --check

3+${IDRIS:-idris} --consolewidth 80 $@ reg028a.idr --check

44rm -f *.ibc

test/reg029/run+2−2

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

11#!/usr/bin/env bash

22

3−idris $@ reg029.idr -o reg029

3+${IDRIS:-idris} $@ reg029.idr -o reg029

44unset IDRIS_REG029_NONEXISTENT_VAR

55export IDRIS_REG029_EXISTENT_VAR='exists!'

66

@@ -12,6 +12,6 @@ else

1212 javac -cp reg029:. Reg029Wrapper.java

1313 java -cp reg029:. Reg029Wrapper

1414fi

15−idris $@ reg029.idr --execute

15+${IDRIS:-idris} $@ reg029.idr --execute

1616rm -f reg029 *.ibc *.class

1717

test/reg031/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg031.idr -o reg031

2+${IDRIS:-idris} $@ reg031.idr -o reg031

33./reg031

44rm -f *.ibc reg031

test/reg032/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test028.idr -o test028

2+${IDRIS:-idris} $@ test028.idr -o test028

33./test028

44rm -f test028 test028.ibc

test/reg034/run+1−1

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check reg034.idr

2+${IDRIS:-idris} --nocolour --consolewidth 80 --check reg034.idr

33rm -f reg034 *.ibc

test/reg035/run+3−3

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check reg035.idr

3−idris --nocolour --consolewidth 80 --check reg035a.lidr

4−idris --nocolour --consolewidth 80 --check reg035b.idr

2+${IDRIS:-idris} --nocolour --consolewidth 80 --check reg035.idr

3+${IDRIS:-idris} --nocolour --consolewidth 80 --check reg035a.lidr

4+${IDRIS:-idris} --nocolour --consolewidth 80 --check reg035b.idr

55rm -f *.ibc

test/reg036/run+1−1

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

11#!/usr/bin/env bash

2−idris --check reg036.idr

2+${IDRIS:-idris} --check reg036.idr

33rm -f reg036 *.ibc

test/reg037/run+1−1

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

11#!/usr/bin/env bash

2−idris --check reg037.idr

2+${IDRIS:-idris} --check reg037.idr

33rm -f reg037 *.ibc

test/reg038/run+1−1

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

11#!/usr/bin/env bash

2−idris --check reg038.idr

2+${IDRIS:-idris} --check reg038.idr

33rm -f *.ibc

test/reg040/run+1−1

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

11#!/usr/bin/env bash

22

3−idris --warnreach reg040.idr -o reg040

3+${IDRIS:-idris} --warnreach reg040.idr -o reg040

44./reg040

55

66rm -f reg040 *.ibc

test/reg041/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ --quiet ott.idr -e example

3−idris $@ showu.idr -o reg040

2+${IDRIS:-idris} $@ --quiet ott.idr -e example

3+${IDRIS:-idris} $@ showu.idr -o reg040

44./reg040

55rm -f reg040 *.ibc

test/reg042/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg042 -o reg042 --warnreach

2+${IDRIS:-idris} $@ reg042 -o reg042 --warnreach

33./reg042

44rm -f reg042 *.ibc

test/reg044/run+1−1

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 reg044.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 reg044.idr --check

33rm -f *.ibc

test/reg045/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg045.idr -o reg045

2+${IDRIS:-idris} $@ reg045.idr -o reg045

33./reg045

44rm -f reg045 *.ibc

test/reg046/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg046.idr --check

2+${IDRIS:-idris} $@ reg046.idr --check

33rm -f reg046 *.ibc

test/reg047/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ reg047.idr --check --nobuiltins

3−idris $@ reg047a.idr --check

2+${IDRIS:-idris} $@ reg047.idr --check --nobuiltins

3+${IDRIS:-idris} $@ reg047a.idr --check

44rm -f *.ibc

test/reg048/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg048.idr -p contrib -o reg048

2+${IDRIS:-idris} $@ reg048.idr -p contrib -o reg048

33./reg048

44rm -f reg048 *.ibc

test/reg049/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 --nocolour --check $@ reg049.idr

2+${IDRIS:-idris} --consolewidth 80 --nocolour --check $@ reg049.idr

33rm -f *.ibc

test/reg050/run+3−3

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

11#!/usr/bin/env bash

2−idris --nocolour --check $@ working.idr

3−idris --nocolour --check $@ badbangop.idr

4−idris --nocolour --check $@ baddoublebang.idr

2+${IDRIS:-idris} --nocolour --check $@ working.idr

3+${IDRIS:-idris} --nocolour --check $@ badbangop.idr

4+${IDRIS:-idris} --nocolour --check $@ baddoublebang.idr

55rm -f *.ibc

test/reg051-disabled/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg051.idr --check

2+${IDRIS:-idris} $@ reg051.idr --check

33rm -f *.ibc

test/reg052/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ -o reg052 reg052.idr

2+${IDRIS:-idris} $@ -o reg052 reg052.idr

33./reg052

44rm -f reg052 *.ibc

test/reg053/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --check four.idr

2+${IDRIS:-idris} $@ --check four.idr

33rm -f *.ibc

test/reg054/run+1−1

@@ -1,2 +1,2 @@

11#!/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 @@

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ reg055.idr --check

3−idris --nocolour --consolewidth 80 $@ reg055a.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ reg055.idr --check

3+${IDRIS:-idris} --nocolour --consolewidth 80 $@ reg055a.idr --check

44rm -f *.ibc

55

test/reg056/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg056.idr -o reg056

2+${IDRIS:-idris} --consolewidth 80 $@ reg056.idr -o reg056

33rm -f *.ibc

test/reg057/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg057.idr --check

2+${IDRIS:-idris} $@ reg057.idr --check

33rm -f *.ibc

test/reg058/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ implicits.idr --check

3−idris $@ implicits2.idr --check

2+${IDRIS:-idris} $@ implicits.idr --check

3+${IDRIS:-idris} $@ implicits2.idr --check

44

55rm -f *.ibc

test/reg059/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg059.idr --check

2+${IDRIS:-idris} $@ reg059.idr --check

33rm -f *.ibc

test/reg060/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg060.idr --check

2+${IDRIS:-idris} $@ reg060.idr --check

33rm -f *.ibc

test/reg061/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ Capture.idr --check

2+${IDRIS:-idris} $@ Capture.idr --check

33rm -f *.ibc

test/reg062/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ reg062.idr --check --nocolour

3−idris $@ reg062.lidr --check --nocolour

2+${IDRIS:-idris} $@ reg062.idr --check --nocolour

3+${IDRIS:-idris} $@ reg062.lidr --check --nocolour

44rm -f *.ibc

test/reg063/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ Cmp.idr --check --nocolour --quiet

2+${IDRIS:-idris} $@ Cmp.idr --check --nocolour --quiet

33rm *.ibc

test/reg064/reg064.idr+6−7

@@ -1,9 +1,8 @@

1−sigmaEq2 : {A : Type} ->

2− {P : A -> Type} ->

3− {s1: Sigma A P} ->

4− {s2: Sigma A P} ->

5− getWitness s1 = getWitness s2 ->

6− getProof s1 = getProof s2 ->

1+sigmaEq2 : {A : Type} ->

2+ {P : A -> Type} ->

3+ {s1: DPair A P} ->

4+ {s2: DPair A P} ->

5+ fst s1 = fst s2 ->

6+ snd s1 = snd s2 ->

77 s1 = s2

88sigmaEq2 {A} {P} {s1 = (x ** prf)} {s2 = (x ** prf)} Refl Refl = Refl

9−

test/reg064/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg064.idr --check

2+${IDRIS:-idris} $@ reg064.idr --check

33rm -f *.ibc

test/reg065/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg065.idr --check

2+${IDRIS:-idris} $@ reg065.idr --check

33rm -f *.ibc

test/reg066/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ reg066.idr --check --nocolor

2+${IDRIS:-idris} $@ reg066.idr --check --nocolor

33rm -f *.ibc

test/reg067/run+1−1

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

11#!/usr/bin/env bash

22rm -f *.ibc reg067

3−idris $@ reg067.idr -o reg067 --warnreach

3+${IDRIS:-idris} $@ reg067.idr -o reg067 --warnreach

44./reg067

55rm -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 @@

11#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 SourceLoc.idr -o sourceLocation001

2+${IDRIS:-idris} $@ --nocolour --consolewidth 80 SourceLoc.idr -o sourceLocation001

33./sourceLocation001

44rm -f sourceLocation001 *.ibc

test/sugar001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test007.idr -o test007

2+${IDRIS:-idris} $@ test007.idr -o test007

33./test007

44rm -f test007 test007.ibc

test/sugar002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test009.idr -o test009

2+${IDRIS:-idris} $@ test009.idr -o test009

33./test009

44rm -f test009 test009.ibc

test/sugar003/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ test013.idr -o test013

2+${IDRIS:-idris} $@ test013.idr -o test013

33./test013

44rm -f test013 test013.ibc

test/sugar004/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ sugar004.idr -o sugar004

2+${IDRIS:-idris} $@ sugar004.idr -o sugar004

33./sugar004

44./sugar004 42

55./sugar004 42 100

test/sugar005/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ As.idr -o sugar005

2+${IDRIS:-idris} $@ As.idr -o sugar005

33./sugar005

44rm -f sugar005 *.ibc

test/syntax001/expected+2−2

@@ -2,7 +2,7 @@ Syntax.idr:6:7-9:1:

22When checking right hand side of foo with expected type

33 Nat

44

5−When checking an application of function Prelude.Classes.+:

5+When checking an application of function Prelude.Interfaces.+:

66 Type mismatch between

77 String (Type of "argh")

88 and

@@ -11,7 +11,7 @@ SyntaxTest.idr:5:7-6:1:

1111When checking right hand side of foo with expected type

1212 Nat

1313

14−When checking an application of function Prelude.Classes.+:

14+When checking an application of function Prelude.Interfaces.+:

1515 Type mismatch between

1616 String (Type of "argh")

1717 and

test/syntax001/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ Syntax.idr --nocolour --consolewidth 80 --check

3−idris $@ SyntaxTest.idr --nocolour --consolewidth 80 --check

2+${IDRIS:-idris} $@ Syntax.idr --nocolour --consolewidth 80 --check

3+${IDRIS:-idris} $@ SyntaxTest.idr --nocolour --consolewidth 80 --check

44rm -f *.ibc

test/syntax002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ syntax002.idr -o syntax002

2+${IDRIS:-idris} $@ syntax002.idr -o syntax002

33./syntax002

44rm -f syntax002 *.ibc

test/tactics001/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --check Tactics.idr

2+${IDRIS:-idris} $@ --check Tactics.idr

33rm -f *.ibc

test/totality001/run+3−3

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check test010.idr

3−idris --consolewidth 80 $@ --check test010a.idr

4−idris --consolewidth 80 $@ --check test010b.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check test010.idr

3+${IDRIS:-idris} --consolewidth 80 $@ --check test010a.idr

4+${IDRIS:-idris} --consolewidth 80 $@ --check test010b.idr

55

66rm -f *.ibc

test/totality002/run+3−3

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check test017.idr

3−idris --consolewidth 80 $@ --check test017a.idr

4−idris --consolewidth 80 $@ --check test017b.idr

2+${IDRIS:-idris} --consolewidth 80 $@ --check test017.idr

3+${IDRIS:-idris} --consolewidth 80 $@ --check test017a.idr

4+${IDRIS:-idris} --consolewidth 80 $@ --check test017b.idr

55rm -f *.ibc

test/totality003/run+2−2

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ totality003.idr --check

3−idris --nocolour --consolewidth 80 $@ totality003a.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ totality003.idr --check

3+${IDRIS:-idris} --nocolour --consolewidth 80 $@ totality003a.idr --check

44rm -f *.ibc

test/totality004/run+2−2

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ totality004.idr -o totality004

2+${IDRIS:-idris} --consolewidth 80 $@ totality004.idr -o totality004

33./totality004

4−idris --consolewidth 80 $@ --check totality004a.idr

4+${IDRIS:-idris} --consolewidth 80 $@ --check totality004a.idr

55rm -f totality004 *.ibc

test/totality005/run+2−2

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

11#!/usr/bin/env bash

2−idris $@ totality005.idr --total --check

3−idris $@ totality005.idr -o totality005

2+${IDRIS:-idris} $@ totality005.idr --total --check

3+${IDRIS:-idris} $@ totality005.idr -o totality005

44./totality005

55rm -f totality005 *.ibc

test/totality006/run+3−3

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ totality006.idr --check

3−idris --consolewidth 80 $@ totality006a.idr --check

4−idris --consolewidth 80 $@ totality006b.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ totality006.idr --check

3+${IDRIS:-idris} --consolewidth 80 $@ totality006a.idr --check

4+${IDRIS:-idris} --consolewidth 80 $@ totality006b.idr --check

55rm -f *.ibc

test/totality007/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --build totality.ipkg

2+${IDRIS:-idris} $@ --build totality.ipkg

33rm -f src/*.ibc

test/totality008/run+1−1

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

11#!/usr/bin/env bash

2−idris --consolewidth 80 $@ totality008.idr --check

2+${IDRIS:-idris} --consolewidth 80 $@ totality008.idr --check

33rm -f *.ibc

test/totality009/run+2−2

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

11#!/usr/bin/env bash

22OPTS="--consolewidth infinite --nocolour"

3−idris "$@" $OPTS --check TestLambdaImpossible

4−idris "$@" $OPTS --check --warnpartial TestLambdaPossible

3+${IDRIS:-idris} "$@" $OPTS --check TestLambdaImpossible

4+${IDRIS:-idris} "$@" $OPTS --check --warnpartial TestLambdaPossible

55rm -f *.ibc

test/totality010/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ totality010.idr --nocolour --consolewidth 80 --check

2+${IDRIS:-idris} $@ totality010.idr --nocolour --consolewidth 80 --check

33rm -f *.ibc

test/tutorial001/run+1−1

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

11#!/usr/bin/env bash

2−idris --check tutorial001.idr

2+${IDRIS:-idris} --check tutorial001.idr

33rm -f *.ibc

test/tutorial002/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 tutorial002.idr --check

2+${IDRIS:-idris} $@ --nocolour --consolewidth 80 tutorial002.idr --check

33rm -f *.ibc

test/tutorial003/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ tutorial003.idr --check

2+${IDRIS:-idris} $@ tutorial003.idr --check

33rm -f *.ibc

test/tutorial004/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ tutorial004.idr --check --nocolour --consolewidth 80

2+${IDRIS:-idris} $@ tutorial004.idr --check --nocolour --consolewidth 80

33rm -f *.ibc

test/tutorial005/run+1−1

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

11#!/usr/bin/env bash

2−idris $@ tutorial005.idr --check

2+${IDRIS:-idris} $@ tutorial005.idr --check

33rm -f *.ibc

test/tutorial006/run+3−3

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ tutorial006a.idr --check

3−idris --nocolour --consolewidth 80 $@ tutorial006b.idr --check

4−idris --nocolour --consolewidth 80 $@ tutorial006c.idr -p effects --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ tutorial006a.idr --check

3+${IDRIS:-idris} --nocolour --consolewidth 80 $@ tutorial006b.idr --check

4+${IDRIS:-idris} --nocolour --consolewidth 80 $@ tutorial006c.idr -p effects --check

55rm -f *.ibc

test/unique001/run+6−6

@@ -1,9 +1,9 @@

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ unique001.idr -o unique001

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001.idr -o unique001

33./unique001

4−idris --nocolour --consolewidth 80 $@ unique001a.idr --check

5−idris --nocolour --consolewidth 80 $@ unique001b.idr --check

6−idris --nocolour --consolewidth 80 $@ unique001c.idr --check

7−idris --nocolour --consolewidth 80 $@ unique001d.idr --check

8−idris --nocolour --consolewidth 80 $@ unique001e.idr --check

4+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001a.idr --check

5+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001b.idr --check

6+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001c.idr --check

7+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001d.idr --check

8+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique001e.idr --check

99rm -f unique001 *.ibc

test/unique001/unique001c.idr−4

@@ -44,7 +44,3 @@ data MPair : AnyType -> AnyType -> AnyType where

4444

4545ndup : {a : UniqueType} -> a -> UPair a a

4646ndup {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 @@

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ unique002.idr --check

3−idris --nocolour --consolewidth 80 $@ unique002a.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique002.idr --check

3+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique002a.idr --check

44rm -f *.ibc

test/unique003/run+1−1

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

11#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ unique003.idr --check

2+${IDRIS:-idris} --nocolour --consolewidth 80 $@ unique003.idr --check

33rm -f *.ibc