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

@@ -1,3 +1,92 @@

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+Effects

27+-------

28+

29+* Effects can now be given in any order in effect lists (there is no need

30+for the ordering to be preserved in sub lists of effects)

31+

32+Elaborator reflection updates

33+-----------------------------

34+

35+* Datatypes can now be defined from elaborator reflection:

36+ - declareDatatype adds the type constructor declaration to the context

37+ - defineDatatype adds the constructors to the datatype

38+ - To declare an inductive-recursive family, declare the types of the

39+ function and the type constructor before defining the pattern-match

40+ cases and constructors.

41+

42+Minor language changes

43+----------------------

44+

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

46+ other annotations.

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

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

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

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

51+

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

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

54+

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

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

57+ implicitly bound).

58+

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

60+

61+ using (xs : Vect _ _)

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

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

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

65+

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

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

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

69+

70+ using (xs : Vect n a)

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

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

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

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

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

76+* File Modes expanded: Append, ReadWriteTruncate, and ReadAppend added,

77+ Write is deprecated and renamed to WriteTruncate.

78+* C11 Extended Mode variations added to File Modes.

79+* More flexible holes.

80+ Holes can now depend on other holes in a term (such as implicit arguments

81+ which may be inferred from the definition of the hole).

82+* Programs with holes can now be compiled.

83+ Attempting to evaluate an expression with a hole results in a run time error.

84+

85+External Dependencies

86+---------------------

87+

88+* Curses has been removed as an external dependancy.

89+

190New in 0.10:

291============

392

CONTRIBUTORS+1

@@ -32,6 +32,7 @@ Jan de Muijnck-Hughes

3232Tom Prince

3333raichoo

3434Philip Rasmussen

35+Aistis Raulinaitis

3536Reynir Reynisson

3637Adam Sandberg Eriksson

3738Seo Sanghyeon

Dockerfilenew file+6

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

1+FROM haskell:7

2+RUN cabal update

3+ADD . Idris-dev

4+WORKDIR Idris-dev

5+RUN make

6+WORKDIR ..

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

config.mk+9−2

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

1−CC ?=cc

2−AR ?=ar

1+ifneq (, $(findstring MSYS, $(shell uname -a)))

2+ ifeq (cc,$(CC))

3+ # In MSYS2, when using the mingw version of gcc, there is no cc -> gcc

4+ # symlink. We can't use ?= here because CC is set implicitly to cc.

5+ # Cross compiling users can set CC to their cross compiler.

6+ CC =gcc

7+ endif

8+endif

9+

310RANLIB ?=ranlib

411

512CABAL :=cabal

custom.mk-alldeps+1−1

@@ -1 +1 @@

1−CABALFLAGS += -f LLVM -f FFI -f curses --disable-documentation --disable-profiling --disable-library-profiling

1+CABALFLAGS += -f GMP -f FFI --disable-documentation --disable-profiling --disable-library-profiling

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.3'

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

64−release = '0.9.19.1'

64+release = '0.10.3'

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/effects/simpleeff.rst+11−10

@@ -578,16 +578,17 @@ this simply by updating the type of ``eval`` to include ``STDIO``.

578578

579579 eval : Expr -> Eff Integer [STDIO, EXCEPTION String, RND, STATE Env]

580580

581−Note that using ``STDIO`` will restrict the number of contexts in

582−which ``eval`` can be ``run`` to those which support ``STDIO``, such

583−as ``IO``. Once effect lists get longer, it can be a good idea instead

584−to encapsulate sets of effects in a type synonym. This is achieved as

585−follows, simply by defining a function which computes a type, since

586−types are first class in Idris:

581+.. note:: Using ``STDIO`` will restrict the number of contexts in

582+ which ``eval`` can be ``run`` to those which support

583+ ``STDIO``, such as ``IO``. Once effect lists get longer, it

584+ can be a good idea instead to encapsulate sets of effects in

585+ a type synonym. This is achieved as follows, simply by

586+ defining a function which computes a type, since types are

587+ first class in Idris:

587588

588−.. code-block:: idris

589+ .. code-block:: idris

589590

590− EvalEff : Type -> Type

591− EvalEff t = Eff t [STDIO, EXCEPTION String, RND, STATE Env]

591+ EvalEff : Type -> Type

592+ EvalEff t = Eff t [STDIO, EXCEPTION String, RND, STATE Env]

592593

593− eval : Expr -> EvalEff Integer

594+ eval : Expr -> EvalEff Integer

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 error, 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/elaborator-reflection.rst+4−4

@@ -37,8 +37,8 @@ For example, the following script constructs the identity function at type ``Nat

3737.. code-block:: idris

3838

3939 idNat : Nat -> Nat

40− idNat = %runElab (do intro (Just (UN "x"))

41− fill (Var (UN "x"))

40+ idNat = %runElab (do intro `{{x}}

41+ fill (Var `{{x}})

4242 solve)

4343

4444

@@ -57,8 +57,8 @@ We can generate identity functions at any concrete type using the same script:

5757.. code-block:: idris

5858

5959 mkId : Elab ()

60− mkId = do intro (Just (UN "x"))

61− fill (Var (UN "x"))

60+ mkId = do intro `{{x}}

61+ fill (Var `{{x}})

6262 solve

6363

6464 idNat : Nat -> Nat

docs/reference/ffi.rst+94−13

@@ -80,24 +80,40 @@ For C, this is:

8080.. code-block:: idris

8181

8282 ||| Supported C integer types

83+ public export

8384 data C_IntTypes : Type -> Type where

84− C_IntChar : C_IntTypes Char

85− C_IntNative : C_IntTypes Int

86− ... -- more integer types

85+ C_IntChar : C_IntTypes Char

86+ C_IntNative : C_IntTypes Int

87+ C_IntBits8 : C_IntTypes Bits8

88+ C_IntBits16 : C_IntTypes Bits16

89+ C_IntBits32 : C_IntTypes Bits32

90+ C_IntBits64 : C_IntTypes Bits64

91+

92+ ||| Supported C function types

93+ public export

94+ data C_FnTypes : Type -> Type where

95+ C_Fn : C_Types s -> C_FnTypes t -> C_FnTypes (s -> t)

96+ C_FnIO : C_Types t -> C_FnTypes (IO' FFI_C t)

97+ C_FnBase : C_Types t -> C_FnTypes t

8798

8899 ||| Supported C foreign types

100+ public export

89101 data C_Types : Type -> Type where

90− C_Str : C_Types String

91− C_Float : C_Types Float

92− C_Ptr : C_Types Ptr

93− C_MPtr : C_Types ManagedPtr

94− C_Unit : C_Types ()

95− C_Any : C_Types (Raw a)

96− C_IntT : C_IntTypes i -> C_Types i

97−

102+ C_Str : C_Types String

103+ C_Float : C_Types Double

104+ C_Ptr : C_Types Ptr

105+ C_MPtr : C_Types ManagedPtr

106+ C_Unit : C_Types ()

107+ C_Any : C_Types (Raw a)

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

109+ C_IntT : C_IntTypes i -> C_Types i

110+

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

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

113+ %error_reverse

114+ public export

98115 FFI_C : FFI

99− FFI_C = MkFFI C_Types

100− String -- the name of the C function

116+ FFI_C = MkFFI C_Types String String

101117

102118Foreign calls

103119=============

@@ -135,6 +151,71 @@ example a shorthand for calling external JavaScript functions:

135151 {auto fty : FTy FFI_JS [] ty} -> ty

136152 jscall fname ty = foreign FFI_JS fname ty

137153

154+C callbacks

155+-----------

156+It is possible to pass an Idris function to a C function taking a function

157+pointer by using ``CFnPtr`` in the function type. The Idris function is passed

158+to ``MkCFnPtr`` in the arguments. The example below shows declaring the C standard

159+library function ``qsort`` which takes a pointer to a comparison function.

160+

161+.. code-block:: idris

162+

163+ myComparer : Ptr -> Ptr -> Int

164+ myComparer = ...

165+

166+ qsort : Ptr -> Int -> Int -> IO ()

167+ test2 data elems elsize = foreign FFI_C "qsort"

168+ (Ptr -> Int -> Int -> CFnPtr (Ptr -> Ptr -> Int) -> IO ())

169+ data elems elsize (MkCFnPtr myComparer)

170+

171+There are a few limitations to callbacks in the C FFI. The foreign function can't

172+take the function to make a callback of as an argument. This will give a

173+compilation error:

174+

175+.. code-block:: idris

176+

177+ -- This does not work

178+ example : (Int -> ()) -> IO ()

179+ example f = foreign FFI_C "callbacker" (CFnPtr (Int -> ()) -> IO ()) f

180+

181+The other big limitation is that it doesn't support IO functions. Use

182+``unsafePerformIO`` to wrap them.

183+

184+There are two special function names:

185+``%wrapper`` returns the function pointer that wraps an Idris function. This

186+is useful if the function pointer isn't taken by a C function directly but

187+should be inserted into a data structure. A foreign declaration using

188+``%wrapper`` must return ``IO Ptr``.

189+

190+.. code-block:: idris

191+

192+ -- this returns the C function pointer to a qsort comparer

193+ example_wrapper : IO Ptr

194+ example_wrapper = foreign FFI_C "%wrapper" (CFnPtr (Ptr -> Ptr -> Int) -> IO Ptr)

195+ (MkCFnPtr myComparer)

196+

197+``%dynamic`` calls a C function pointer with some arguments. This is useful if

198+a C function returns or data structure contains a C function pointer, for example

199+structs of function pointers are common in object-oriented C such as in COM or the

200+Linux kernel. The function type contains an extra ``Ptr`` at the start for the

201+function pointer. ``%dynamic`` can be seen as a pseudo-function that calls the

202+function in the first argument, passing the remaining arguments to it.

203+

204+.. code-block:: idris

205+

206+ -- we have a pointer to a function with the signature int f(int), call it

207+ example_dynamic : Ptr -> Int -> IO Int

208+ example_dynamic fn x = foreign FFI_C "%dynamic" (Ptr -> Int -> IO Int) fn x

209+

210+If the foreign name is prefixed by a ``&``, it is treated as a pointer to the

211+global variable with the following name. The type must be just ``IO Ptr``.

212+

213+.. code-block:: idris

214+

215+ -- access the global variable errno

216+ errno : IO Ptr

217+ errno = foreign FFI_C "&errno" (IO Ptr)

218+

138219FFI implementation

139220------------------

140221

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/misc.rst+108−1

@@ -100,6 +100,113 @@ follows:

100100 (x :: qsort (assert_smaller (x :: xs) (filter (>= x) xs))))

101101

102102

103+C heap

104+======

105+

106+Idris has two heaps where objects can be allocated:

107+

108++--------------------------------------+---------------------------------------+

109+| FP heap | C heap |

110++======================================+=======================================+

111+| Cheney-collected | Mark-and-sweep-collected |

112++--------------------------------------+---------------------------------------+

113+| Garbage collections touches only | Garbage collection has to traverse |

114+| live objects. | all registered items. |

115++--------------------------------------+---------------------------------------+

116+| Ideal for FP-style rapid allocation | Ideal for C-style allocation of a few |

117+| of lots of small short-lived pieces | big buffers. |

118+| of memory, such as data constructors.| |

119++--------------------------------------+---------------------------------------+

120+| Finalizers are impossible to support | Items have finalizers that are called |

121+| reasonably. | on deallocation. |

122++--------------------------------------+---------------------------------------+

123+| Data is copied all the time (when | Copying does not happen. |

124+| collecting garbage, modifying data, | |

125+| registering managed pointers, etc.) | |

126++--------------------------------------+---------------------------------------+

127+| Contains objects of various types. | Contains C heap items: ``(void *)`` |

128+| | pointers with finalizers. A finalizer |

129+| | is a routine that deallocates the |

130+| | resources associated with the item. |

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

132+| Fixed set of object types. | The data pointer may point |

133+| | to anything, as long as the finalizer |

134+| | cleans up correctly. |

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

136+| Not suitable for C resources and | Suitable for C resources and arbitrary|

137+| arbitrary pointers. | pointers. |

138++--------------------------------------+---------------------------------------+

139+| Values form a compact memory block. | Items are kept in a linked list. |

140++--------------------------------------+---------------------------------------+

141+| Any Idris value, most notably | Items represented by the |

142+| ``ManagedPtr``. | Idris type ``CData``. |

143++--------------------------------------+---------------------------------------+

144+| Data of ``ManagedPtr`` allocated | Data allocated in C, pointer copied |

145+| in C, buffer then copied into the FP | into the C heap. |

146+| heap. | |

147++--------------------------------------+---------------------------------------+

148+| Allocation and reallocation not | Allocated and reallocate freely in C, |

149+| possible from C code (without having | registering the allocated items |

150+| a reference to the VM). Everything | in the FFI. |

151+| is copied instead. | |

152++--------------------------------------+---------------------------------------+

153+

154+The FP heap is the primary heap. It may contain values of type ``CData``,

155+which are references to items in the C heap. A C heap item contains

156+a ``(void *)`` pointer and the corresponding finalizer. Once a C heap item

157+is no longer referenced from the FP heap, it is marked as unused and

158+the next GC sweep will call its finalizer and deallocate it.

159+

160+There is no Idris interface for ``CData`` other than its type and FFI.

161+

162+Usage from C code

163+-----------------

164+

165+* Although not enforced in code, ``CData`` is meant to be opaque

166+ and non-RTS code (such as libraries or C bindings) should

167+ access only its ``(void *)`` field called ``data``.

168+

169+* Feel free to mutate both the pointer ``data`` (eg. after calling ``realloc``)

170+ and the memory it points to. However, keep in mind

171+ that this must not break Idris's referential transparency.

172+

173+* **WARNING!** If you call ``cdata_allocate`` or ``cdata_manage``,

174+ the resulting ``CData`` object *must* be returned from your

175+ FFI function so that it is inserted in the C heap by the RTS.

176+ Otherwise the memory will be leaked.

177+

178+.. code:: idris

179+

180+ some_allocating_fun : Int -> IO CData

181+ some_allocating_fun i = foreign FFI_C "some_allocating_fun" (Int -> IO CData) i

182+

183+ other_fun : CData -> Int -> IO Int

184+ other_fun cd i = foreign FFI_C "other_fun" (CData -> Int -> IO Int) cd i

185+

186+.. code:: cpp

187+

188+ #include "idris_rts.h"

189+

190+ static void finalizer(void * data)

191+ {

192+ MyStruct * ptr = (MyStruct *) data;

193+ free_something(ptr->something);

194+ free(ptr);

195+ }

196+

197+ CData some_allocating_fun(int arg)

198+ {

199+ void * data = (void *) malloc(...);

200+ // ...

201+ return cdata_manage(data, finalizer);

202+ }

203+

204+ int other_fun(CData cd, int arg)

205+ {

206+ int result = foo(cd->data);

207+ return result;

208+ }

209+

103210Preorder reasoning

104211==================

105212

@@ -118,7 +225,7 @@ Here is an example:

118225 (a * b * c) ={ sym (multAssociative a b c) }=

119226 (a * (b * c)) ={ cong (multCommutative b c) }=

120227 (a * (c * b)) ={ multAssociative a c b }=

121− (a * c * b) ={ cong {f = (*b)} (multCommutative a c) }=

228+ (a * c * b) ={ cong {f = (* b)} (multCommutative a c) }=

122229 (c * a * b) QED

123230

124231Note that the parentheses are required -- only a simple expression can

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

@@ -287,7 +287,11 @@ return type. For example, consider

287287 zeros (S k) = 0 :: (zeros k)

288288

289289In this example, the return type is ``Vect n Int`` which is an

290−expression which depends on the input parameter ``n``. ### Anonymous

290+expression which depends on the input parameter ``n``.

291+

292+Anonymous

293+~~~~~~~~~

294+

291295Arguments in anonymous functions are separated by comma.

292296

293297::

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

303307

304308::

305309

306− public

307− abstract

310+ public export

311+ export

308312 private

309313

310314Totality

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

372376 -- Single Line

373377 {- Multiline -}

374378 ||| Docstring (goes before definition)

375−

379+

376380Multi line String literals

377381~~~~~~~~~~~~~~~~~~~~~~~~~~

378382

docs/reference/uniqueness-types.rst+2−2

@@ -34,7 +34,7 @@ declare the type of unique lists as follows:

3434

3535.. code-block:: idris

3636

37− data UList : Type -> UniqueType

37+ data UList : Type -> UniqueType where

3838 Nil : UList a

3939 (::) : a -> UList a -> UList a

4040

@@ -94,7 +94,7 @@ since it would embed a unique value in a possible non-unique value:

9494

9595.. code-block:: idris

9696

97− data BadList : UniqueType -> Type

97+ data BadList : UniqueType -> Type where

9898 Nil : {a : UniqueType} -> BadList a

9999 (::) : {a : UniqueType} -> a -> BadList a -> BadList a

100100

docs/tutorial/interp.rst+4−4

@@ -28,7 +28,7 @@ calculated just like any other value:

2828.. code-block:: idris

2929

3030 interpTy : Ty -> Type

31− interpTy TyInt = Int

31+ interpTy TyInt = Integer

3232 interpTy TyBool = Bool

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

3434

@@ -62,7 +62,7 @@ The full representation of expressions is:

6262

6363 data Expr : Vect n Ty -> Ty -> Type where

6464 Var : HasType i G t -> Expr G t

65− Val : (x : Int) -> Expr G TyInt

65+ Val : (x : Integer) -> Expr G TyInt

6666 Lam : Expr (a :: G) t -> Expr G (TyFun a t)

6767 App : Expr G (TyFun a t) -> Expr G a -> Expr G t

6868 Op : (interpTy a -> interpTy b -> interpTy c) ->

@@ -115,7 +115,7 @@ A value carries a concrete representation of an integer:

115115

116116.. code-block:: idris

117117

118− Val : (x : Int) -> Expr G TyInt

118+ Val : (x : Integer) -> Expr G TyInt

119119

120120A lambda creates a function. In the scope of a function of type ``a ->

121121t``, there is a new local variable of type ``a``, which is expressed

@@ -270,7 +270,7 @@ function on user input:

270270 main : IO ()

271271 main = do putStr "Enter a number: "

272272 x <- getLine

273− print (interp [] fact (cast x))

273+ printLn (interp [] fact (cast x))

274274

275275Here, ``cast`` is an overloaded function which converts a value from

276276one type to another if possible. Here, it converts a string to an

docs/tutorial/introduction.rst+1−1

@@ -39,7 +39,7 @@ function, which concatenates vectors:

3939This tutorial introduces Idris, a general purpose functional

4040programming language with dependent types. The goal of the Idris

4141project is to build a dependently typed language suitable for

42−verifiable *systems* programming. To this end, Idris is a compiled

42+verifiable general purpose programming. To this end, Idris is a compiled

4343language which aims to generate efficient executable code. It also has

4444a lightweight foreign function interface which allows easy interaction

4545with external ``C`` libraries.

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:

docs/tutorial/typesfuns.rst+21−4

@@ -137,8 +137,9 @@ Unlike Haskell, there is no restriction on whether types and function

137137names must begin with a capital letter or not. Function names

138138(``plus`` and ``mult`` above), data constructors (``Z``, ``S``,

139139``Nil`` and ``::``) and type constructors (``Nat`` and ``List``) are

140−all part of the same namespace. We can test these functions at the

141−Idris prompt:

140+all part of the same namespace. By convention, however,

141+data types and constructor names typically begin with a capital letter.

142+We can test these functions at the Idris prompt:

142143

143144::

144145

@@ -494,9 +495,20 @@ vector. For example:

494495 testVec : Vect 4 Int

495496 testVec = 3 :: 4 :: 5 :: 6 :: Nil

496497

497− inVect : IsElem 5 testVec

498+ inVect : IsElem 5 Main.testVec

498499 inVect = There (There Here)

499500

501+

502+.. important:: Implicit Arguments and Scope

503+

504+ Within the type signature the typechecker will treat all variables

505+ that start with an lowercase letter **and** are not applied to

506+ something else as an implicit variable. To get the above code

507+ example to compile you will need to provide a qualified name for

508+ ``testVec``. In the example above, we have assumed that the code

509+ lives within the ``Main`` module.

510+

511+

500512If the same implicit arguments are being used a lot, it can make a

501513definition difficult to read. To avoid this problem, a ``using`` block

502514gives the types and ordering of any implicit arguments which can

@@ -509,6 +521,8 @@ appear within the block:

509521 Here : IsElem x (x :: xs)

510522 There : IsElem x xs -> IsElem x (y :: xs)

511523

524+

525+

512526Note: Declaration Order and ``mutual`` blocks

513527~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

514528

@@ -582,7 +596,7 @@ example for reading and writing files, including:

582596

583597 openFile : (f : String) -> (m : Mode) -> IO (Either FileError File)

584598 closeFile : File -> IO ()

585−

599+

586600 fGetLine : (h : File) -> IO (Either FileError String)

587601 fPutStr : (h : File) -> (str : String) -> IO (Either FileError ())

588602 fEOF : File -> IO Bool

@@ -959,6 +973,9 @@ updated):

959973The syntax ``record { field = val, ... }`` generates a function which

960974updates the given fields in a record.

961975

976+Each record is defined in its own namespace, which means that field names

977+can be reused in multiple records.

978+

962979Records, and fields within records, can have dependent types. Updates

963980are allowed to change the type of a field, provided that the result is

964981well-typed.

icons/idris_icon.rcnew file+1

@@ -0,0 +1 @@

1+0 ICON "idris.ico"

idris-tutorial.pdf

Binary file not shown.

idris.cabal+73−18

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

11Name: idris

2−Version: 0.10

2+Version: 0.10.3

33License: BSD3

44License-file: LICENSE

55Author: Edwin Brady

@@ -124,6 +124,8 @@ Extra-source-files:

124124

125125 libs/contrib/contrib.ipkg

126126 libs/contrib/Makefile

127+ libs/contrib/*.idr

128+ libs/contrib/CFFI/*.idr

127129 libs/contrib/Classes/*.idr

128130 libs/contrib/Control/*.idr

129131 libs/contrib/Control/Isomorphism/*.idr

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

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

151153

152154 test/Makefile

153− test/runtest.pl

155+ test/runtest.hs

154156 test/reg001/run

155157 test/reg001/*.idr

156158 test/reg001/expected

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

163165 test/reg004/run

164166 test/reg004/*.idr

165167 test/reg004/expected

168+ test/reg005/run

169+ test/reg005/*.idr

170+ test/reg005/expected

166171 test/reg006/run

167172 test/reg006/*.idr

168173 test/reg006/expected

@@ -311,6 +316,15 @@ Extra-source-files:

311316 test/reg067/run

312317 test/reg067/*.idr

313318 test/reg067/expected

319+ test/reg068/run

320+ test/reg068/*.idr

321+ test/reg068/expected

322+ test/reg069/run

323+ test/reg069/*.idr

324+ test/reg069/expected

325+ test/reg070/run

326+ test/reg070/*.idr

327+ test/reg070/expected

314328

315329 test/basic001/run

316330 test/basic001/*.idr

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

361375 test/basic016/run

362376 test/basic016/*.idr

363377 test/basic016/expected

378+ test/basic017/run

379+ test/basic017/*.idr

380+ test/basic017/expected

364381

365382 test/bignum001/run

366383 test/bignum001/*.idr

@@ -462,6 +479,16 @@ Extra-source-files:

462479 test/ffi006/*.c

463480 test/ffi006/run

464481 test/ffi006/expected

482+ test/ffi007/*.idr

483+ test/ffi007/*.c

484+ test/ffi007/*.h

485+ test/ffi007/run

486+ test/ffi007/expected

487+ test/ffi008/*.idr

488+ test/ffi008/*.c

489+ test/ffi008/*.h

490+ test/ffi008/run

491+ test/ffi008/expected

465492

466493 test/folding001/*.idr

467494 test/folding001/run

@@ -585,6 +612,17 @@ Extra-source-files:

585612 test/primitives003/run

586613 test/primitives003/*.idr

587614 test/primitives003/expected

615+ test/primitives005/run

616+ test/primitives005/*.idr

617+ test/primitives005/expected

618+

619+ test/primitives006/run

620+ test/primitives006/array.c

621+ test/primitives006/array.h

622+ test/primitives006/load-test.idr

623+ test/primitives006/Data/Bytes.idr

624+ test/primitives006/Data/ByteArray.idr

625+ test/primitives006/expected

588626

589627 test/pkg001/run

590628 test/pkg001/test.ipkg

@@ -728,6 +766,9 @@ Extra-source-files:

728766 test/totality010/run

729767 test/totality010/*.idr

730768 test/totality010/expected

769+ test/totality011/run

770+ test/totality011/*.lidr

771+ test/totality011/expected

731772

732773 test/tutorial001/run

733774 test/tutorial001/*.idr

@@ -788,6 +829,9 @@ Extra-source-files:

788829 benchmarks/trivial/sortvec.idr

789830 benchmarks/trivial/sortvec.ipkg

790831

832+ icons/idris_icon.rc

833+ icons/idris.ico

834+

791835source-repository head

792836 type: git

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

@@ -802,11 +846,6 @@ Flag GMP

802846 Default: False

803847 manual: True

804848

805−Flag curses

806− Description: Use Curses to get the screen width

807− Default: False

808− manual: True

809−

810849-- This flag determines whether to show Git hashes in version strings

811850-- Defaults to True because Hackage is a source release

812851Flag release

@@ -859,6 +898,7 @@ Library

859898 , Idris.Elab.Transform

860899 , Idris.Elab.Value

861900 , Idris.Elab.Term

901+ , Idris.Elab.Quasiquote

862902

863903 , Idris.REPL.Browse

864904

@@ -879,7 +919,6 @@ Library

879919 , Idris.Docs

880920 , Idris.Docstrings

881921 , Idris.ElabDecls

882− , Idris.ElabQuasiquote

883922 , Idris.Erasure

884923 , Idris.Error

885924 , Idris.ErrReverse

@@ -892,10 +931,10 @@ Library

892931 , Idris.Interactive

893932 , Idris.Output

894933 , Idris.Parser

895− , Idris.ParseHelpers

896− , Idris.ParseOps

897− , Idris.ParseExpr

898− , Idris.ParseData

934+ , Idris.Parser.Helpers

935+ , Idris.Parser.Ops

936+ , Idris.Parser.Expr

937+ , Idris.Parser.Data

899938 , Idris.PartialEval

900939 , Idris.Primitives

901940 , Idris.ProofSearch

@@ -903,7 +942,7 @@ Library

903942 , Idris.Providers

904943 , Idris.Reflection

905944 , Idris.REPL

906− , Idris.REPLParser

945+ , Idris.REPL.Parser

907946 , Idris.Transforms

908947 , Idris.TypeSearch

909948 , Idris.Unlit

@@ -965,6 +1004,7 @@ Library

9651004 , pretty < 1.2

9661005 , process < 1.3

9671006 , split < 0.3

1007+ , terminal-size < 0.4

9681008 , text >=1.2.1.0 && < 1.3

9691009 , time >= 1.4 && < 1.6

9701010 , transformers < 0.5

@@ -978,7 +1018,8 @@ Library

9781018 , zip-archive > 0.2.3.5 && < 0.2.4

9791019 , safe

9801020 , fsnotify < 2.2

981− , async < 2.1

1021+ , async < 2.2

1022+

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

9831024 if impl(ghc < 7.10.3)

9841025 build-depends: zlib < 0.6.1

@@ -992,7 +1033,6 @@ Library

9921033 , TemplateHaskell

9931034

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

995− ghc-options: -threaded -rtsopts

9961036

9971037 if os(linux)

9981038 cpp-options: -DLINUX

@@ -1016,9 +1056,6 @@ Library

10161056 build-depends: libffi < 0.2

10171057 extra-libraries: gmp

10181058 cpp-options: -DIDRIS_GMP

1019− if flag(curses)

1020− build-depends: hscurses < 1.5

1021− cpp-options: -DCURSES

10221059 if flag(freestanding)

10231060 other-modules: Target_idris

10241061 cpp-options: -DFREESTANDING

@@ -1039,6 +1076,24 @@ Executable idris

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

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

10411078

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

1080+ Type: exitcode-stdio-1.0

1081+ Main-is: runtest.hs

1082+ hs-source-dirs: test

1083+

1084+ Build-depends: idris

1085+ , base

1086+ , containers

1087+ , process

1088+ , time

1089+ , filepath

1090+ , directory

1091+ , haskeline >= 0.7

1092+ , transformers

1093+

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

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

1096+

10421097Executable idris-codegen-c

10431098 Main-is: Main.hs

10441099 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+2−2

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

@@ -54,7 +54,7 @@ gets f = do s <- get

5454

5555||| The State monad. See the MonadState interface

5656State : Type -> Type -> Type

57−State s a = StateT s Identity a

57+State = \s, a => StateT s Identity a

5858

5959||| Unwrap a State monad computation.

6060runState : StateT s Identity a -> s -> (a, s)

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+49−30

@@ -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 : [static] {n : Nat} -> 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' : [static] {n : Nat} -> 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 : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

105109

110+public export

106111shiftRightLogical' : [static] {n : Nat} -> 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 : [static] {n : Nat} -> 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' : [static] {n : Nat} -> 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 : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

128134

135+public export

129136and' : [static] {n : Nat} -> machineTy n -> machineTy n -> machineTy n

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

131138 | Z = prim__andB8 x y

@@ -133,7 +140,7 @@ 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 : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

139146

@@ -144,7 +151,7 @@ or' {n=n} x y with (n)

144151 | S (S Z) = prim__orB32 x y

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

146153

147−public

154+public export

148155or : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

150157

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

155162 | S (S Z) = prim__xorB32 x y

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

157164

158−public

165+public export

159166xor : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

161168

169+public export

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

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

164172 | Z = pad8 n prim__addB8 x y

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

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

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

168176

169−public

177+public export

170178plus : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

172180

181+public export

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

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

175184 | Z = pad8 n prim__subB8 x y

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

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

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

179188

180−public

189+public export

181190minus : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

183192

193+public export

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

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

186196 | Z = pad8 n prim__mulB8 x y

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

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

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

190200

191−public

201+public export

192202times : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

194204

195205partial

206+public export

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

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

198209 | Z = prim__sdivB8 x y

@@ -200,23 +211,24 @@ sdiv' {n=n} x y with (nextBytes n)

200211 | S (S Z) = prim__sdivB32 x y

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

202213

203−public partial

214+public export partial

204215sdiv : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

206217

207218partial

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

219+public export

220+udiv' : [static] {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

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

210222 | Z = prim__udivB8 x y

211223 | S Z = prim__udivB16 x y

212224 | S (S Z) = prim__udivB32 x y

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

214226

215−public partial

227+public export partial

216228udiv : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

218230

219−partial

231+public export partial

220232srem' : [static] {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

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

222234 | Z = prim__sremB8 x y

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

224236 | S (S Z) = prim__sremB32 x y

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

226238

227−public partial

239+public export partial

228240srem : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

230242

231−partial

243+public export partial

232244urem' : [static] {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

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

234246 | Z = prim__uremB8 x y

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

236248 | S (S Z) = prim__uremB32 x y

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

238250

239−public partial

251+public export partial

240252urem : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

242254

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

276288 | S (S Z) = prim__gtB32 x y

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

278290

291+public export

279292implementation Eq (Bits n) where

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

281294

295+public export

282296implementation Ord (Bits n) where

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

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

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

291305 then EQ

292306 else GT

293307

308+public export

294309complement' : [static] {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n)

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

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

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

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

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

304319

305−public

320+public export

306321complement : [static] {n : Nat} -> Bits n -> Bits n

307322complement (MkBits x) = MkBits (complement' x)

308323

@@ -321,12 +336,14 @@ zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

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

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

323338

324−public

339+public export

325340zeroExtend : [static] {n : Nat} -> [static] {m : Nat} -> Bits n -> Bits (n+m)

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

327342

343+public export

328344%assert_total

329345intToBits' : [static] {n : Nat} -> Integer -> machineTy (nextBytes n)

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

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

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

332349 prim__lshrB8 (prim__shlB8 (prim__truncBigInt_B8 x) pad) pad

@@ -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 : [static] {n : Nat} -> Integer -> Bits n

342359intToBits n = MkBits (intToBits' n)

343360

344361implementation Cast Integer (Bits n) where

345362 cast = intToBits

346363

364+public export

347365bitsToInt' : [static] {n : Nat} -> machineTy (nextBytes n) -> Integer

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

349367 | Z = prim__zextB8_BigInt x

@@ -351,7 +369,7 @@ 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 : [static] {n : Nat} -> Bits n -> Integer

356374bitsToInt (MkBits x) = bitsToInt' x

357375

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

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

394412 believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad)

395413

396−--public

414+--public export

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

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

399417

400418-- TODO: Prove

419+public export

401420%assert_total -- can't verify coverage of with block

402421trunc' : [static] {m : Nat} -> [static] {n : Nat} -> machineTy (nextBytes (m+n)) -> machineTy (nextBytes n)

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

@@ -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 : [static] {m : Nat} -> [static] {n : Nat} -> Bits (m+n) -> Bits n

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

418437

419−public

438+public export

420439bitAt : [static] {n : Nat} -> Fin n -> Bits n

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

422441

423−public

442+public export

424443getBit : [static] {n : Nat} -> Fin n -> Bits n -> Bool

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

426445

427−public

446+public export

428447setBit : [static] {n : Nat} -> Fin n -> Bits n -> Bits n

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

430449

431−public

450+public export

432451unsetBit : [static] {n : Nat} -> 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+28−11

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

@@ -38,17 +40,30 @@ getUName (UN n) = Just n

3840getUName (NS n ns) = getUName n

3941getUName _ = Nothing

4042

41−total

42−unApply : TT -> (TT, List TT)

43−unApply t = unA t []

44− where unA : TT -> List TT -> (TT, List TT)

45− unA (App fn arg) args = unA fn (arg::args)

46− unA tm args = (tm, args)

43+namespace TT

44+ total

45+ unApply : TT -> (TT, List TT)

46+ unApply t = unA t []

47+ where unA : TT -> List TT -> (TT, List TT)

48+ unA (App fn arg) args = unA fn (arg::args)

49+ unA tm args = (tm, args)

50+

51+ total

52+ mkApp : Foldable f => TT -> f TT -> TT

53+ mkApp f args = foldl App f args

54+

55+namespace Raw

56+ total

57+ unApply : Raw -> (Raw, List Raw)

58+ unApply tm = unApply' tm []

59+ where unApply' : Raw -> List Raw -> (Raw, List Raw)

60+ unApply' (RApp f x) xs = unApply' f (x::xs)

61+ unApply' notApp xs = (notApp, xs)

62+

63+ total

64+ mkApp : Foldable f => Raw -> f Raw -> Raw

65+ mkApp f args = foldl RApp f args

4766

48−total

49−mkApp : TT -> List TT -> TT

50−mkApp tm [] = tm

51−mkApp tm (a::as) = mkApp (App tm a) as

5267

5368total

5469binderTy : Binder t -> t

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

145160 showPrec d StrType = "StrType"

146161 showPrec d VoidType = "VoidType"

147162 showPrec d Forgot = "Forgot"

163+ showPrec d WorldType = "WorldType"

164+ showPrec d TheWorld = "TheWorld"

148165

149166implementation Eq NativeTy where

150167 IT8 == IT8 = True

@@ -299,7 +316,7 @@ implementation Show Err where

299316 showPrec d (CantMatch tm) = showCon d "CantMatch" $ showArg tm

300317 showPrec d (NoTypeDecl n) = showCon d "NoTypeDecl" $ showArg n

301318 showPrec d (NotInjective tm tm' x) = showCon d "NotInjective" $ showArg tm ++ showArg tm'

302− showPrec d (CantResolve tm) = showCon d "CantResolve" $ showArg tm

319+ showPrec d (CantResolve tm e) = showCon d "CantResolve" $ showArg tm ++ showArg e

303320 showPrec d (InvalidTCArg n tm) = showCon d "InvalidTCName" $ showArg n ++ showArg tm

304321 showPrec d (CantResolveAlts xs) = showCon d "CantResolveAlts" $ showArg xs

305322 showPrec d (NoValidAlts xs) = showCon d "NoValidAlts" $ showArg xs

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/CFFI.idrnew file+4

@@ -0,0 +1,4 @@

1+module CFFI

2+

3+import public CFFI.Types

4+import public CFFI.Memory

libs/contrib/CFFI/Memory.idrnew file+94

@@ -0,0 +1,94 @@

1+||| Machinery for interfacing with C.

2+module CFFI.Memory

3+

4+import CFFI.Types

5+import Data.Vect

6+

7+%include C "memory.h"

8+

9+%access public export

10+%default partial

11+

12+

13+data CPtr = CPt Ptr Int

14+

15+implicit toCPtr : Ptr -> CPtr

16+toCPtr p = CPt p 0

17+

18+implicit toPtr : CPtr -> Ptr

19+toPtr (CPt p 0) = p

20+toPtr (CPt p o) = prim__ptrOffset p o

21+

22+||| Import of malloc from the C standard library.

23+malloc : Int -> IO Ptr

24+malloc size = foreign FFI_C "malloc" (Int -> IO Ptr) size

25+

26+||| Import of free from the C standard library.

27+mfree : Ptr -> IO ()

28+mfree ptr = foreign FFI_C "free" (Ptr -> IO ()) ptr

29+

30+||| Allocate enough memory to hold an instance of a C typr

31+alloc : Composite -> IO CPtr

32+alloc t = return $ CPt !(malloc (sizeOf t)) 0

33+

34+||| Free memory allocated with alloc

35+free : CPtr -> IO ()

36+free (CPt p _ ) = mfree p

37+

38+||| Perform an IO action with memory that is freed afterwards

39+withAlloc : Composite -> (CPtr -> IO ()) -> IO ()

40+withAlloc t f = do m <- alloc t

41+ f m

42+ free m

43+

44+infixl 1 ~~>

45+||| Perform an IO action with memory that is freed afterwards

46+(~~>) : Composite-> (CPtr -> IO ()) -> IO ()

47+(~~>) = withAlloc

48+

49+||| Read from memory

50+peek : (t: CType) -> CPtr -> IO (translate t)

51+peek I8 (CPt p o) = prim_peek8 p o

52+peek I16 (CPt p o) = prim_peek16 p o

53+peek I32 (CPt p o) = prim_peek32 p o

54+peek I64 (CPt p o) = prim_peek64 p o

55+peek FLOAT (CPt p o) = prim_peekSingle p o

56+peek DOUBLE (CPt p o) = prim_peekDouble p o

57+peek PTR (CPt p o) = prim_peekPtr p o

58+

59+||| Write to memory

60+poke : (t : CType) -> CPtr -> translate t -> IO ()

61+poke I8 (CPt p o) x = do _ <- prim_poke8 p o x

62+ return ()

63+poke I16 (CPt p o) x = do _ <- prim_poke16 p o x

64+ return ()

65+poke I32 (CPt p o) x = do _ <- prim_poke32 p o x

66+ return ()

67+poke I64 (CPt p o) x = do _ <- prim_poke64 p o x

68+ return ()

69+poke PTR (CPt p o) x = do _ <- prim_pokePtr p o x

70+ return ()

71+poke FLOAT (CPt p o) x = do _ <- prim_pokeSingle p o x

72+ return ()

73+poke DOUBLE (CPt p o) x = do _ <- prim_pokeDouble p o x

74+ return ()

75+

76+||| Update memory with a function.

77+update : (t: CType) -> CPtr -> (translate t -> translate t) -> IO ()

78+update ty cp f = do val <- peek ty cp

79+ out <- return $ f val

80+ poke ty cp out

81+

82+||| Get a pointer to a field in a composite value

83+field : Composite -> Nat -> CPtr -> CPtr

84+field arr@(ARRAY n t) i (CPt p o) = CPt p (o + offset arr i)

85+field un@(UNION xs) i (CPt p o) = CPt p o

86+field st@(STRUCT xs) i (CPt p o) = CPt p (o + offset st i)

87+field ps@(PACKEDSTRUCT xs) i (CPt p o) = CPt p (o + offset ps i)

88+field (T t) Z p = p

89+

90+infixl 10 #

91+

92+||| Get a pointer to a field in a composite value

93+(#) : Composite -> Nat -> CPtr -> CPtr

94+(#) = field

libs/contrib/CFFI/Types.idrnew file+159

@@ -0,0 +1,159 @@

1+||| Types for interfacing with C.

2+||| This file should be kept free from IO.

3+module CFFI.Types

4+

5+import Data.Vect

6+import Debug.Error

7+

8+%access public export

9+%default partial

10+

11+||| An universe of C types.

12+data CType = I8 | I16 | I32 | I64 | FLOAT | DOUBLE | PTR

13+

14+||| Composites of C types

15+data Composite = T CType | ARRAY Int Composite | STRUCT (List Composite) | UNION (List Composite)

16+ | PACKEDSTRUCT (List Composite)

17+

18+||| Implicit conversion of primitive C types to composites

19+implicit mkComposite : CType -> Composite

20+mkComposite x = T x

21+

22+Show CType where

23+ show I8 = "I8"

24+ show I16 = "I16"

25+ show I32 = "I32"

26+ show I64 = "I64"

27+ show FLOAT = "FLOAT"

28+ show DOUBLE = "DOUBLE"

29+ show PTR = "PTR"

30+

31+Show Composite where

32+ show (T ct) = show ct

33+ show (ARRAY n t) = "ARRAY " ++ show n ++ " " ++ show t

34+ show (STRUCT xs) = "STRUCT " ++ show xs

35+ show (UNION xs) = "UNION " ++ show xs

36+ show (PACKEDSTRUCT xs) = "PACKEDSTRUCT " ++ show xs

37+

38+||| What Idris type the C type is marshalled to

39+translate : CType -> Type

40+translate I8 = Bits8

41+translate I16 = Bits16

42+translate I32 = Bits32

43+translate I64 = Bits64

44+translate FLOAT = Double

45+translate DOUBLE = Double

46+translate PTR = Ptr

47+

48+mutual

49+ private

50+ sizeOfCT : CType -> Int

51+ sizeOfCT I8 = 1

52+ sizeOfCT I16 = 2

53+ sizeOfCT I32 = 4

54+ sizeOfCT I64 = 8

55+ sizeOfCT FLOAT = 4

56+ sizeOfCT DOUBLE = 8

57+ sizeOfCT PTR = prim__sizeofPtr

58+

59+ ||| Size of value of the type in bytes

60+ export

61+ sizeOf : Composite -> Int

62+ sizeOf (T ct) = sizeOfCT ct

63+ sizeOf (ARRAY n t) = n * sizeOf t

64+ sizeOf (STRUCT xs) = sizeOfStruct xs

65+ sizeOf (UNION xs) = foldl (\acc, x =>max acc $ sizeOf x) 0 xs

66+ sizeOf (PACKEDSTRUCT xs) = foldl (\acc, x => acc + sizeOf x) 0 xs

67+

68+ private

69+ alignOfCT : CType -> Int

70+ alignOfCT I8 = 1

71+ alignOfCT I16 = 2

72+ alignOfCT I32 = 4

73+ alignOfCT I64 = prim__sizeofPtr

74+ alignOfCT FLOAT = 4

75+ alignOfCT DOUBLE = prim__sizeofPtr

76+ alignOfCT PTR = prim__sizeofPtr

77+

78+ ||| Alignment requirement of the type

79+ export

80+ alignOf : Composite -> Int

81+ alignOf (T t) = alignOfCT t

82+ alignOf (ARRAY n t) = alignOf t

83+ alignOf (STRUCT xs) = foldl (\acc, x => max acc $ alignOf x) 0 xs

84+ alignOf (UNION xs) = foldl (\acc, x => max acc $ alignOf x) 0 xs

85+ alignOf (PACKEDSTRUCT xs) = 1

86+

87+ private

88+ pad : Int -> Int -> Int

89+ pad pos align = let c = pos `mod` align in if c == 0 then 0 else align - c

90+

91+ private

92+ nextOffset : Composite -> Int -> Int

93+ nextOffset ty pos = pos + pad pos (alignOf ty)

94+

95+ private

96+ offsetsStruct : List Composite -> List Int

97+ offsetsStruct xs = offsets' xs 0

98+ where

99+ offsets' : List Composite -> Int -> List Int

100+ offsets' [] _ = []

101+ offsets' (x::xs) pos = (nextOffset x pos)::(offsets' xs (nextOffset x pos + sizeOf x))

102+

103+ private

104+ sizeOfStruct : List Composite -> Int

105+ sizeOfStruct xs = sizeStruct' xs 0 1

106+ where

107+ sizeStruct' : List Composite -> Int -> Int -> Int

108+ sizeStruct' [] pos maxAlign = pos + (pad pos maxAlign)

109+ sizeStruct' (x::xs) pos maxAlign = sizeStruct' xs (nextOffset x pos + sizeOf x)

110+ (max maxAlign (alignOf x))

111+

112+||| Number of fields in a composite type

113+export

114+fields : Composite -> Nat

115+fields (STRUCT xs) = length xs

116+fields (PACKEDSTRUCT xs) = length xs

117+fields (UNION xs) = length xs

118+fields (ARRAY n _) = toNat n

119+fields (T _) = 1

120+

121+private

122+offsetsPacked : List Composite -> List Int

123+offsetsPacked xs = offsets' xs [] 0

124+ where

125+ offsets' : List Composite -> List Int -> Int -> List Int

126+ offsets' [] acc _ = reverse acc

127+ offsets' (x::xs) acc pos = offsets' xs (pos::acc) (sizeOf x)

128+

129+private

130+indexOrFail : Nat -> List a -> a

131+indexOrFail i xs = case index' i xs of

132+ Just x => x

133+ Nothing => error "Out of bounds access"

134+

135+||| The offset of a firld in a composite type

136+export

137+offset : Composite -> Nat -> Int

138+offset (STRUCT xs) i = indexOrFail i (offsetsStruct xs)

139+offset (PACKEDSTRUCT xs) i = indexOrFail i (offsetsPacked xs)

140+offset (ARRAY _ t) i = sizeOf t * toIntNat i

141+offset (T _) _ = 0

142+

143+||| All offsets of a composite type

144+export

145+offsets : Composite -> List Int

146+offsets (STRUCT xs) = offsetsStruct xs

147+offsets (PACKEDSTRUCT xs) = offsetsPacked xs

148+offsets (UNION xs) = replicate (length xs) 0

149+offsets (ARRAY n t) = [ x*sizeOf t | x <- [0..n-1]]

150+offsets (T _) = [0]

151+

152+||| The type of a field in a composite type.

153+export

154+fieldType : Composite -> Nat -> Composite

155+fieldType (STRUCT xs@(y::_)) i = indexOrFail i xs

156+fieldType (PACKEDSTRUCT xs@(y::_)) i = indexOrFail i xs

157+fieldType (UNION xs@(y::_)) i = indexOrFail i xs

158+fieldType (ARRAY n t) _ = t

159+fieldType t _ = t

libs/contrib/Classes/Verified.idr+10−1

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

@@ -12,7 +14,7 @@ import Control.Algebra.VectorSpace

1214-- and Monoid).

1315

1416interface Functor f => VerifiedFunctor (f : Type -> Type) where

15− functorIdentity : {a : Type} -> (x : f a) -> map id x = id x

17+ functorIdentity : {a : Type} -> (x : f a) -> map Basics.id x = Basics.id x

1618 functorComposition : {a : Type} -> {b : Type} -> (x : f a) ->

1719 (g1 : a -> b) -> (g2 : b -> c) ->

1820 map (g2 . g1) x = (map g2 . map g1) x

@@ -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+6−2

@@ -1,13 +1,17 @@

11package contrib

22

33opts = "--nobasepkgs --total -i ../prelude -i ../base"

4−modules = Control.Algebra,

4+modules = CFFI, CFFI.Types, CFFI.Memory,

5+

6+ Control.Algebra,

57 Control.Algebra.Lattice, Control.Algebra.VectorSpace,

68 Control.Algebra.NumericInstances,

79 Control.Isomorphism.Primitives,

810 Control.Partial,

911 Control.WellFounded,

12+

1013 Classes.Verified,

14+

1115 Data.Fun, Data.Rel,

1216 Data.Hash,

1317 Data.Matrix, Data.Matrix.Algebraic, Data.Matrix.Numeric,

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

1620 Data.BoundedList,

1721 Data.Heap,

1822 Data.SortedMap, Data.SortedSet,

19− Data.CoList,

23+ Data.CoList, Data.Storable,

2024

2125 Decidable.Decidable, Decidable.Order,

2226

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+116−33

@@ -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,53 +84,119 @@ syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff]

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

7885

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

87+

88+public export

89+data SubElem : a -> List a -> Type where

90+ Z : SubElem a (a :: as)

91+ S : SubElem a as -> SubElem a (b :: as)

92+

93+public export

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

81− SubNil : SubList [] []

82− Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

83− Drop : SubList xs ys -> SubList xs (x :: ys)

95+ SubNil : SubList [] xs

96+ InList : SubElem x ys -> SubList xs ys -> SubList (x :: xs) ys

97+

98+Uninhabited (SubElem x []) where

99+ uninhabited Z impossible

100+ uninhabited (S _) impossible

101+

102+-- Some useful hints for proof construction in polymorphic programs

103+%hint

104+public export total

105+dropFirst : SubList xs ys -> SubList xs (x :: ys)

106+dropFirst SubNil = SubNil

107+dropFirst (InList el sub) = InList (S el) (dropFirst sub)

108+

109+%hint

110+public export total

111+subListId : (xs : List a) -> SubList xs xs

112+subListId [] = SubNil

113+subListId (x :: xs) = InList Z (dropFirst (subListId xs))

114+

115+public export total

116+inSuffix : SubElem x ys -> SubList xs ys -> SubElem x (zs ++ ys)

117+inSuffix {zs = []} el sub = el

118+inSuffix {zs = (x :: xs)} el sub = S (inSuffix el sub)

119+

120+%hint

121+public export total

122+dropPrefix : SubList xs ys -> SubList xs (zs ++ ys)

123+dropPrefix SubNil = SubNil

124+dropPrefix (InList el sub) = InList (inSuffix el sub) (dropPrefix sub)

125+

126+public export total

127+inPrefix : SubElem x ys -> SubList xs ys -> SubElem x (ys ++ zs)

128+inPrefix {zs = []} {ys} el sub

129+ = rewrite appendNilRightNeutral ys in el

130+inPrefix {zs = (x :: xs)} Z sub = Z

131+inPrefix {zs = (x :: xs)} (S y) sub = S (inPrefix y SubNil)

84132

85133%hint

86−subListId : SubList xs xs

87−subListId {xs = Nil} = SubNil

88−subListId {xs = x :: xs} = Keep subListId

134+public export total

135+dropSuffix : SubList xs ys -> SubList xs (ys ++ zs)

136+dropSuffix SubNil = SubNil

137+dropSuffix (InList el sub) = InList (inPrefix el sub) (dropSuffix sub)

89138

90139namespace Env

140+ public export

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

92− Nil : Env m Nil

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

94−

95−data EffElem : Effect -> Type ->

96− List EFFECT -> Type where

97− Here : EffElem x a (MkEff a x :: xs)

98− There : EffElem x a xs -> EffElem x a (y :: xs)

142+ Nil : Env m Nil

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

144+

145+namespace EffElem

146+ public export

147+ data EffElem : Effect -> Type ->

148+ List EFFECT -> Type where

149+ Here : EffElem x a (MkEff a x :: xs)

150+ There : EffElem x a xs -> EffElem x a (y :: xs)

151+

152+total envElem : SubElem x xs -> Env m xs -> Env m [x]

153+envElem Z (x :: xs) = [x]

154+envElem (S k) (x :: xs) = envElem k xs

99155

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

101−dropEnv : Env m ys -> SubList xs ys -> Env m xs

157+total dropEnv : Env m ys -> SubList xs ys -> Env m xs

102158dropEnv [] SubNil = []

103−dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

104−dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

105−

106−updateWith : (ys' : List a) -> (xs : List a) ->

107− SubList ys xs -> List a

108−updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

109−updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest

110−updateWith [] [] SubNil = []

111−updateWith (y :: ys) [] SubNil = y :: ys

112−updateWith [] (x :: xs) (Keep rest) = []

159+dropEnv [] (InList idx rest) = absurd idx

160+dropEnv (y::ys) SubNil = []

161+dropEnv e@(y::ys) (InList idx rest) =

162+ let [x] = envElem idx e

163+ in x :: dropEnv e rest

164+

165+public export

166+total updateAt : (idx : SubElem x' xs) -> (a:Type) -> List EFFECT -> List EFFECT

167+updateAt Z a [] = []

168+updateAt Z a ((MkEff b eff) :: xs) = (MkEff a eff) :: xs

169+updateAt (S k) a [] = []

170+updateAt (S k) a (x :: xs) = x :: updateAt k a xs

171+

172+public export

173+total updateWith : (ys' : List EFFECT) -> (xs : List EFFECT) ->

174+ SubList ys xs -> List EFFECT

175+updateWith [] xs sl = xs

176+updateWith (y :: ys) xs SubNil = xs

177+updateWith ((MkEff a f) :: ys) xs (InList idx rest) = updateAt idx a (updateWith ys xs rest)

178+

179+public export

180+total replaceEnvAt : (x : a) -> (idx : SubElem x' xs) -> Env m ys ->

181+ Env m (updateAt idx a ys)

182+replaceEnvAt x Z [] = []

183+replaceEnvAt x Z (y :: ys) = x :: ys

184+replaceEnvAt x (S k) [] = []

185+replaceEnvAt x (S k) (y :: ys) = y :: replaceEnvAt x k ys

113186

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

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

188+public export

189+total rebuildEnv : {ys':List EFFECT} -> Env m ys' -> (prf : SubList ys xs) ->

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

117−rebuildEnv [] SubNil env = env

118−rebuildEnv (x :: xs) SubNil env = x :: xs

119−rebuildEnv [] (Keep rest) (y :: env) = []

120−rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

121−rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

122−

191+rebuildEnv [] SubNil env = env

192+rebuildEnv (x :: xs) SubNil env = env

193+rebuildEnv [] (InList w s) env = env

194+rebuildEnv (x :: xs) (InList idx rest) env = replaceEnvAt x idx (rebuildEnv xs rest env)

123195

124196-- -------------------------------------------------- [ The Effect EDSL itself ]

125197

126−updateResTy : (val : t) ->

198+public export

199+total updateResTy : (val : t) ->

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

128201 List EFFECT

129202updateResTy {b} val (MkEff a e :: xs) Here n = (MkEff (b val) e) :: xs

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

131204

132205infix 5 :::, :-, :=

133206

207+public export

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

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

136210

211+public export

137212(:::) : lbl -> EFFECT -> EFFECT

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

139214

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

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

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

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

234+public export

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

160236 -> (es : List EFFECT)

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

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

182258

183259namespace SimpleEff

184260 -- Simple effects, no updates

261+ public export

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

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

187264

265+ public export

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

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

190268

191269namespace TransEff

192270 -- Dependent effects, updates not dependent on result

271+ public export

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

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

195274

275+ public export

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

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

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

199279

200280namespace DepEff

201281 -- Dependent effects, updates dependent on result

282+ public export

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

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

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

205286

287+ public export

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

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

208290 EffT m x es ce = EffM m x es ce

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

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

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

273355

356+export

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

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

276359eff env (prog `EBind` c) k

libs/prelude/Builtins.idr+48−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

@@ -85,7 +93,7 @@ replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y

8593replace Refl prf = prf

8694

8795||| Symmetry of propositional equality

88−sym : {l:a} -> {r:a} -> l = r -> r = l

96+sym : {left:a} -> {right:a} -> left = right -> right = left

8997sym Refl = Refl

9098

9199||| Transitivity of propositional equality

@@ -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,8 +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

185+export data Ptr : Type

186+export data ManagedPtr : Type

187+export data CData : Type

179188

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

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

@@ -190,4 +199,24 @@ abstract data ManagedPtr : Type

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

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

192201

193−

202+-- primitives for accessing memory.

203+%extern prim__asPtr : ManagedPtr -> Ptr

204+%extern prim__sizeofPtr : Int

205+%extern prim__ptrOffset : Ptr -> Int -> Ptr

206+%extern prim__peek8 : prim__WorldType -> Ptr -> Int -> Bits8

207+%extern prim__peek16 : prim__WorldType -> Ptr -> Int -> Bits16

208+%extern prim__peek32 : prim__WorldType -> Ptr -> Int -> Bits32

209+%extern prim__peek64 : prim__WorldType -> Ptr -> Int -> Bits64

210+

211+%extern prim__poke8 : prim__WorldType -> Ptr -> Int -> Bits8 -> Int

212+%extern prim__poke16 : prim__WorldType -> Ptr -> Int -> Bits16 -> Int

213+%extern prim__poke32 : prim__WorldType -> Ptr -> Int -> Bits32 -> Int

214+%extern prim__poke64 : prim__WorldType -> Ptr -> Int -> Bits64 -> Int

215+

216+%extern prim__peekPtr : prim__WorldType -> Ptr -> Int -> Ptr

217+%extern prim__pokePtr : prim__WorldType -> Ptr -> Int -> Ptr -> Int

218+

219+%extern prim__peekDouble : prim__WorldType -> Ptr -> Int -> Double

220+%extern prim__pokeDouble : prim__WorldType -> Ptr -> Int -> Double -> Int

221+%extern prim__peekSingle : prim__WorldType -> Ptr -> Int -> Double

222+%extern prim__pokeSingle : prim__WorldType -> Ptr -> Int -> Double -> 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+109−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,28 +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

181+ C_CData : C_Types CData

171182

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

173− ||| 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.

174185 %error_reverse

175− FFI_C : FFI

176− FFI_C = MkFFI C_Types String String

186+ public export

187+ FFI_C : FFI

188+ FFI_C = MkFFI C_Types String String

177189

178190||| Interactive programs, describing I/O actions and returning a value.

179−||| @res The result type of the program

191+||| @res The result type of the program

180192%error_reverse

193+public export

194+

181195IO : (res : Type) -> Type

182196IO = IO' FFI_C

183197

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

199+%used MkRaw x

200+%used MkCFnPtr x

201+

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

185203-- in the first argument.

186204run__provider : IO a -> PrimIO a

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

207225

208226-- Supported JS foreign types

209227mutual

228+ public export

210229 data JsFn : Type -> Type where

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

212231

232+ public export

213233 data JS_IntTypes : Type -> Type where

214234 JS_IntChar : JS_IntTypes Char

215235 JS_IntNative : JS_IntTypes Int

216236

237+ public export

217238 data JS_FnTypes : Type -> Type where

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

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

220241 JS_FnBase : JS_Types t -> JS_FnTypes t

221242

243+ public export

222244 data JS_Types : Type -> Type where

223245 JS_Str : JS_Types String

224246 JS_Float : JS_Types Double

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

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

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

238260%error_reverse

261+public export

239262FFI_JS : FFI

240263FFI_JS = MkFFI JS_Types String String

241264

242265%error_reverse

266+public export

243267JS_IO : Type -> Type

244268JS_IO = IO' FFI_JS

245269

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

249273namespace FFI_Export

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

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

276+ public export

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

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

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

255280

281+ public export

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

257283 FFI_ExpType : {n : ffi_data f} -> (def : DataDefined t xs n) -> FFI_Base f xs t

258284 FFI_Prim : (prim : ffi_types f t) -> FFI_Base f xs t

@@ -261,6 +287,7 @@ namespace FFI_Export

261287 %used FFI_ExpType def

262288 %used FFI_Prim prim

263289

290+ public export

264291 data FFI_Exportable : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

265292 FFI_IO : (b : FFI_Base f xs t) -> FFI_Exportable f xs (IO' f t)

266293 FFI_Fun : (b : FFI_Base f xs s) -> (a : FFI_Exportable f xs t) -> FFI_Exportable f xs (s -> t)

@@ -271,10 +298,11 @@ namespace FFI_Export

271298 %used FFI_Fun a

272299 %used FFI_Ret b

273300

301+ public export

274302 data FFI_Export : (f : FFI) -> String -> List (Type, ffi_data f) -> Type where

275− Data : (x : Type) -> (n : ffi_data f) ->

303+ Data : (x : Type) -> (n : ffi_data f) ->

276304 (es : FFI_Export f h ((x, n) :: xs)) -> FFI_Export f h xs

277− 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} ->

278306 (es : FFI_Export f h xs) -> FFI_Export f h xs

279307 End : FFI_Export f h xs

280308

@@ -286,3 +314,54 @@ namespace FFI_Export

286314%used Fun es

287315%used Fun prf

288316

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

352+

353+prim_peekDouble : Ptr -> Int -> IO Double

354+prim_peekDouble ptr offset = MkIO (\w => prim_io_return (prim__peekDouble (world w) ptr offset))

355+

356+prim_pokeDouble : Ptr -> Int -> Double -> IO Int

357+prim_pokeDouble ptr offset val = MkIO (\w => prim_io_return (

358+ prim__pokeDouble (world w) ptr offset val))

359+

360+||| Single precision floats are marshalled to Doubles

361+prim_peekSingle : Ptr -> Int -> IO Double

362+prim_peekSingle ptr offset = MkIO (\w => prim_io_return (prim__peekSingle (world w) ptr offset))

363+

364+||| Single precision floats are marshalled to Doubles

365+prim_pokeSingle : Ptr -> Int -> Double -> IO Int

366+prim_pokeSingle ptr offset val = MkIO (\w => prim_io_return (

367+ prim__pokeSingle (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+98−5

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

@@ -55,11 +57,11 @@ data TyConArg =

5557 ||| Indices are not uniform

5658 TyConIndex FunArg

5759

58−||| A type declaration

60+||| A type declaration for a function or datatype

5961record TyDecl where

6062 constructor Declare

6163

62− ||| The name of the function being declared.

64+ ||| The fully-qualified name of the function or datatype being declared.

6365 name : TTName

6466

6567 ||| Each argument is in the scope of the names of previous arguments.

@@ -81,6 +83,34 @@ record FunDefn a where

8183 clauses : List (FunClause a)

8284

8385

86+||| A constructor to be associated with a new datatype.

87+record ConstructorDefn where

88+ constructor Constructor

89+

90+ ||| The name of the constructor. The name must _not_ be qualified -

91+ ||| that is, it should begin with the `UN` or `MN` constructors.

92+ name : TTName

93+

94+ ||| The constructor arguments. Idris will infer which arguments are

95+ ||| datatype parameters.

96+ arguments : List FunArg

97+

98+ ||| The specific type constructed by the constructor.

99+ returnType : Raw

100+

101+

102+||| A definition of a datatype to be added during an elaboration script.

103+record DataDefn where

104+ constructor DefineDatatype

105+ ||| The name of the datatype being defined. It must be

106+ ||| fully-qualified, and it must have been previously declared as a

107+ ||| datatype.

108+ name : TTName

109+

110+ ||| A list of constructors for the datatype.

111+ constructors : List ConstructorDefn

112+

113+

84114data CtorArg = CtorParameter FunArg | CtorField FunArg

85115

86116||| A reflected datatype definition

@@ -100,7 +130,7 @@ record Datatype where

100130 constructors : List (TTName, List CtorArg, Raw)

101131

102132||| A reflected elaboration script.

103−abstract

133+export

104134data Elab : Type -> Type where

105135 -- obligatory control stuff

106136 Prim__PureElab : a -> Elab a

@@ -149,6 +179,8 @@ data Elab : Type -> Type where

149179

150180 Prim__DeclareType : TyDecl -> Elab ()

151181 Prim__DefineFunction : FunDefn Raw -> Elab ()

182+ Prim__DeclareDatatype : TyDecl -> Elab ()

183+ Prim__DefineDatatype : DataDefn -> Elab ()

152184 Prim__AddInstance : TTName -> TTName -> Elab ()

153185 Prim__IsTCName : TTName -> Elab Bool

154186

@@ -164,7 +196,7 @@ data Elab : Type -> Type where

164196-------------

165197-- Public API

166198-------------

167−%access public

199+%access public export

168200namespace Tactics

169201 implementation Functor Elab where

170202 map f t = Prim__BindElab t (\x => Prim__PureElab (f x))

@@ -186,31 +218,38 @@ namespace Tactics

186218 x >>= f = Prim__BindElab x f

187219

188220 ||| Halt elaboration with an error

221+ export

189222 fail : List ErrorReportPart -> Elab a

190223 fail err = Prim__Fail err

191224

192225 ||| Look up the lexical binding at the focused hole. Fails if no holes are present.

226+ export

193227 getEnv : Elab (List (TTName, Binder TT))

194228 getEnv = Prim__Env

195229

196230 ||| Get the name and type of the focused hole. Fails if not holes are present.

231+ export

197232 getGoal : Elab (TTName, TT)

198233 getGoal = Prim__Goal

199234

200235 ||| Get the hole queue, in order.

236+ export

201237 getHoles : Elab (List TTName)

202238 getHoles = Prim__Holes

203239

204240 ||| If the current hole contains a guess, return it. Otherwise, fail.

241+ export

205242 getGuess : Elab TT

206243 getGuess = Prim__Guess

207244

208245 ||| Look up the types of every overloading of a name.

246+ export

209247 lookupTy : TTName -> Elab (List (TTName, NameType, TT))

210248 lookupTy n = Prim__LookupTy n

211249

212250 ||| Get the type of a fully-qualified name. Fail if it doesn not

213251 ||| resolve uniquely.

252+ export

214253 lookupTyExact : TTName -> Elab (TTName, NameType, TT)

215254 lookupTyExact n = case !(lookupTy n) of

216255 [res] => return res

@@ -219,12 +258,14 @@ namespace Tactics

219258

220259 ||| Find the reflected representation of all datatypes whose names

221260 ||| are overloadings of some name.

261+ export

222262 lookupDatatype : TTName -> Elab (List Datatype)

223263 lookupDatatype n = Prim__LookupDatatype n

224264

225265 ||| Find the reflected representation of a datatype, given its

226266 ||| fully-qualified name. Fail if the name does not uniquely resolve

227267 ||| to a datatype.

268+ export

228269 lookupDatatypeExact : TTName -> Elab Datatype

229270 lookupDatatypeExact n = case !(lookupDatatype n) of

230271 [res] => return res

@@ -233,12 +274,14 @@ namespace Tactics

233274

234275 ||| Find the reflected function definition of all functions whose names

235276 ||| are overloadings of some name.

277+ export

236278 lookupFunDefn : TTName -> Elab (List (FunDefn TT))

237279 lookupFunDefn n = Prim__LookupFunDefn n

238280

239281 ||| Find the reflected function definition of a function, given its

240282 ||| fully-qualified name. Fail if the name does not uniquely resolve

241283 ||| to a function.

284+ export

242285 lookupFunDefnExact : TTName -> Elab (FunDefn TT)

243286 lookupFunDefnExact n = case !(lookupFunDefn n) of

244287 [res] => return res

@@ -246,11 +289,13 @@ namespace Tactics

246289 xs => fail [TextPart "More than one function named", NamePart n]

247290

248291 ||| Get the argument specification for each overloading of a name.

292+ export

249293 lookupArgs : TTName -> Elab (List (TTName, List FunArg, Raw))

250294 lookupArgs n = Prim__LookupArgs n

251295

252296 ||| Get the argument specification for a name. Fail if the name does

253297 ||| not uniquely resolve.

298+ export

254299 lookupArgsExact : TTName -> Elab (TTName, List FunArg, Raw)

255300 lookupArgsExact n = case !(lookupArgs n) of

256301 [res] => return res

@@ -261,6 +306,7 @@ namespace Tactics

261306 |||

262307 ||| @ env the environment within which to check the type

263308 ||| @ tm the term to check

309+ export

264310 check : (env : List (TTName, Binder TT)) -> (tm : Raw) -> Elab (TT, TT)

265311 check env tm = Prim__Check env tm

266312

@@ -269,15 +315,18 @@ namespace Tactics

269315 |||

270316 ||| **NB**: the generated name is unique _for this run of the

271317 ||| elaborator_. Do not assume that they are globally unique.

318+ export

272319 gensym : (hint : String) -> Elab TTName

273320 gensym hint = Prim__Gensym hint

274321

275322 ||| Substitute a guess into a hole.

323+ export

276324 solve : Elab ()

277325 solve = Prim__Solve

278326

279327 ||| Place a term into a hole, unifying its type. Fails if the focus

280328 ||| is not a hole.

329+ export

281330 fill : Raw -> Elab ()

282331 fill tm = Prim__Fill tm

283332

@@ -295,6 +344,7 @@ namespace Tactics

295344 ||| @ argSpec instructions for finding the arguments to the term,

296345 ||| where the Boolean states whether or not to attempt to solve

297346 ||| the argument by unification.

347+ export

298348 apply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

299349 apply tm argSpec = map snd <$> Prim__Apply tm argSpec

300350

@@ -313,18 +363,21 @@ namespace Tactics

313363 ||| where the Boolean states whether or not to attempt to solve

314364 ||| the argument by matching.

315365

366+ export

316367 matchApply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

317− matchApply tm argSpec = map snd <$> Prim__Apply tm argSpec

368+ matchApply tm argSpec = map snd <$> Prim__MatchApply tm argSpec

318369

319370 ||| Move the focus to the specified hole. Fails if the hole does not

320371 ||| exist.

321372 |||

322373 ||| @ hole the hole to focus on

374+ export

323375 focus : (hole : TTName) -> Elab ()

324376 focus hole = Prim__Focus hole

325377

326378 ||| Send the currently-focused hole to the end of the hole queue and

327379 ||| focus on the next hole.

380+ export

328381 unfocus : TTName -> Elab ()

329382 unfocus hole = Prim__Unfocus hole

330383

@@ -336,6 +389,7 @@ namespace Tactics

336389 ||| binding, or else the scopes of the generated terms won't make

337390 ||| sense. This tactic creates a new hole of the proper form, and

338391 ||| points the old hole at it.

392+ export

339393 attack : Elab ()

340394 attack = Prim__Attack

341395

@@ -344,6 +398,7 @@ namespace Tactics

344398 ||| The new hole will be focused, and the previously-focused hole

345399 ||| will be immediately after it in the hole queue. Because this

346400 ||| tactic introduces a new binding, you may need to `attack` first.

401+ export

347402 claim : TTName -> Raw -> Elab ()

348403 claim n ty = Prim__Claim n ty

349404

@@ -352,6 +407,7 @@ namespace Tactics

352407 ||| `attack`).

353408 |||

354409 ||| @ n the name to use for the argument

410+ export

355411 intro : (n : TTName) -> Elab ()

356412 intro n = Prim__Intro (Just n)

357413

@@ -361,6 +417,7 @@ namespace Tactics

361417 |||

362418 ||| Requires that the hole be immediately under its binder (use

363419 ||| `attack` if it might not be).

420+ export

364421 intro' : Elab ()

365422 intro' = Prim__Intro Nothing

366423

@@ -369,10 +426,12 @@ namespace Tactics

369426 |||

370427 ||| Requires that the hole be immediately under its binder (use

371428 ||| `attack` if it might not be).

429+ export

372430 forall : TTName -> Raw -> Elab ()

373431 forall n ty = Prim__Forall n ty

374432

375433 ||| Convert a hole into a pattern variable.

434+ export

376435 patvar : TTName -> Elab ()

377436 patvar n = Prim__PatVar n

378437

@@ -380,6 +439,7 @@ namespace Tactics

380439 |||

381440 ||| Requires that the hole be immediately under its binder (use

382441 ||| `attack` if it might not be).

442+ export

383443 patbind : TTName -> Elab ()

384444 patbind n = Prim__PatBind n

385445

@@ -391,10 +451,12 @@ namespace Tactics

391451 ||| @ n the name to let bind

392452 ||| @ ty the type of the term to be let-bound

393453 ||| @ tm the term to be bound

454+ export

394455 letbind : (n : TTName) -> (ty, tm : Raw) -> Elab ()

395456 letbind n ty tm = Prim__LetBind n ty tm

396457

397458 ||| Normalise the goal.

459+ export

398460 compute : Elab ()

399461 compute = Prim__Compute

400462

@@ -402,12 +464,14 @@ namespace Tactics

402464 |||

403465 ||| @ env the environment in which to compute (get one of these from `getEnv`)

404466 ||| @ term the term to normalise

467+ export

405468 normalise : (env : List (TTName, Binder TT)) -> (term : TT) -> Elab TT

406469 normalise env term = Prim__Normalise env term

407470

408471 ||| Reduce a closed term to weak-head normal form

409472 |||

410473 ||| @ term the term to reduce

474+ export

411475 whnf : (term : TT) -> Elab TT

412476 whnf term = Prim__Whnf term

413477

@@ -417,6 +481,7 @@ namespace Tactics

417481 ||| @ env a lexical environment to compare the terms in (see `getEnv`)

418482 ||| @ term1 the first term to convert

419483 ||| @ term2 the second term to convert

484+ export

420485 convertsInEnv : (env : List (TTName, Binder TT)) -> (term1, term2 : TT) -> Elab ()

421486 convertsInEnv env term1 term2 = Prim__Converts env term1 term2

422487

@@ -424,14 +489,17 @@ namespace Tactics

424489 |||

425490 ||| @ term1 the first term to convert

426491 ||| @ term2 the second term to convert

492+ export

427493 converts : (term1, term2 : TT) -> Elab ()

428494 converts term1 term2 = convertsInEnv !getEnv term1 term2

429495

430496 ||| Find the source context for the elaboration script

497+ export

431498 getSourceLocation : Elab SourceLocation

432499 getSourceLocation = Prim__SourceLocation

433500

434501 ||| Attempt to solve the current goal with the source code location

502+ export

435503 sourceLocation : Elab ()

436504 sourceLocation = do loc <- getSourceLocation

437505 fill (quote loc)

@@ -442,6 +510,7 @@ namespace Tactics

442510 |||

443511 ||| The namespace is represented as a reverse-order list of strings,

444512 ||| just as in the representation of names.

513+ export

445514 currentNamespace : Elab (List String)

446515 currentNamespace = Prim__Namespace

447516

@@ -455,29 +524,45 @@ namespace Tactics

455524 ||| Because this tactic internally introduces a `let` binding, it

456525 ||| requires that the hole be immediately under its binder (use

457526 ||| `attack` if it might not be).

527+ export

458528 rewriteWith : Raw -> Elab ()

459529 rewriteWith rule = Prim__Rewrite rule

460530

461531 ||| Add a type declaration to the global context.

532+ export

462533 declareType : TyDecl -> Elab ()

463534 declareType decl = Prim__DeclareType decl

464535

465536 ||| Define a function in the global context. The function must have

466537 ||| already been declared, either in ordinary Idris code or using

467538 ||| `declareType`.

539+ export

468540 defineFunction : FunDefn Raw -> Elab ()

469541 defineFunction defun = Prim__DefineFunction defun

470542

543+ ||| Declare a datatype in the global context. This step only

544+ ||| establishes the type constructor; use `defineDatatype` to give

545+ ||| it constructors.

546+ export

547+ declareDatatype : TyDecl -> Elab ()

548+ declareDatatype decl = Prim__DeclareDatatype decl

549+

550+ export

551+ defineDatatype : DataDefn -> Elab ()

552+ defineDatatype defn = Prim__DefineDatatype defn

553+

471554 ||| Register a new implementation for interface resolution.

472555 |||

473556 ||| @ ifaceName the name of the interface for which an implementation is being registered

474557 ||| @ instName the name of the definition to use in implementation search

558+ export

475559 addInstance : (ifaceName, instName : TTName) -> Elab ()

476560 addInstance ifaceName instName = Prim__AddInstance ifaceName instName

477561

478562 ||| Determine whether a name denotes an interface.

479563 |||

480564 ||| @ name a name that might denote an interface.

565+ export

481566 isTCName : (name : TTName) -> Elab Bool

482567 isTCName name = Prim__IsTCName name

483568

@@ -485,10 +570,12 @@ namespace Tactics

485570 |||

486571 ||| @ fn the name of the definition being elaborated (to prevent Idris

487572 ||| from looping)

573+ export

488574 resolveTC : (fn : TTName) -> Elab ()

489575 resolveTC fn = Prim__ResolveTC fn

490576

491577 ||| Use Idris's internal proof search.

578+ export

492579 search : Elab ()

493580 search = Prim__Search 100 []

494581

@@ -496,6 +583,7 @@ namespace Tactics

496583 |||

497584 ||| @ depth the search depth

498585 ||| @ hints additional names to try

586+ export

499587 search' : (depth : Int) -> (hints : List TTName) -> Elab ()

500588 search' depth hints = Prim__Search depth hints

501589

@@ -505,6 +593,7 @@ namespace Tactics

505593 ||| if the string is not a valid operator.

506594 |||

507595 ||| @ operator the operator string to look up

596+ export

508597 operatorFixity : (operator : String) -> Elab Fixity

509598 operatorFixity operator = Prim__Fixity operator

510599

@@ -512,6 +601,7 @@ namespace Tactics

512601 |||

513602 ||| This is intended for elaboration script developers, not for

514603 ||| end-users. Use `fail` for final scripts.

604+ export

515605 debug : Elab a

516606 debug = Prim__Debug []

517607

@@ -522,18 +612,21 @@ namespace Tactics

522612 ||| end-users. Use `fail` for final scripts.

523613 |||

524614 ||| @ msg the message to display

615+ export

525616 debugMessage : (msg : List ErrorReportPart) -> Elab a

526617 debugMessage msg = Prim__Debug msg

527618

528619 ||| Create a new top-level metavariable to solve the current hole.

529620 |||

530621 ||| @ name the name for the top-level variable

622+ export

531623 metavar : (name : TTName) -> Elab ()

532624 metavar name = Prim__Metavar name

533625

534626 ||| Recursively invoke the reflected elaborator with some goal.

535627 |||

536628 ||| The result is the final term and its type.

629+ export

537630 runElab : Raw -> Elab () -> Elab (TT, TT)

538631 runElab goal script = Prim__RecursiveElab goal script

539632

libs/prelude/Language/Reflection/Errors.idr+3−1

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

@@ -28,7 +30,7 @@ data Err = Msg String

2830 | CantMatch TT

2931 | NoTypeDecl TTName

3032 | NotInjective TT TT TT

31− | CantResolve TT

33+ | CantResolve TT Err

3234 | InvalidTCArg TTName TT

3335 | CantResolveAlts (List TTName)

3436 | NoValidAlts (List TTName)

libs/prelude/Prelude.idr+9−9

@@ -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,15 +264,15 @@ 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)

275−cast_error (CantResolve `(Cast ~x ~y))

275+cast_error (CantResolve `(Cast ~x ~y) _)

276276 = Just [TextPart "Can't cast from",

277277 cast_part x,

278278 TextPart "to",

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

284−num_error (CantResolve `(Num ~x))

285+num_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+62−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,35 +39,43 @@ 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

4646Show FileError where

47+ show FileReadError = "File Read Error"

48+ show FileWriteError = "File Write Error"

4749 show FileNotFound = "File Not Found"

4850 show PermissionDenied = "Permission Denied"

4951 show (GenericFileError errno) = strError errno

5052

5153||| Standard input

54+export

5255stdin : File

5356stdin = FHandle prim__stdin

5457

5558||| Standard output

59+export

5660stdout : File

5761stdout = FHandle prim__stdout

5862

5963||| Standard output

64+export

6065stderr : File

6166stderr = FHandle prim__stderr

6267

68+private

6369do_ferror : Ptr -> IO Int

6470do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h

6571

72+export

6673ferror : File -> IO Bool

6774ferror (FHandle h) = do err <- do_ferror h

6875 return (not (err == 0))

6976

7077||| Call the RTS's file opening function

78+private

7179do_fopen : String -> String -> IO Ptr

7280do_fopen f m

7381 = foreign FFI_C "fileOpen" (String -> String -> IO Ptr) f m

@@ -75,6 +83,7 @@ do_fopen f m

7583||| Open a file

7684||| @ f the filename

7785||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

86+export

7887fopen : (f : String) -> (m : String) -> IO (Either FileError File)

7988fopen f m = do h <- do_fopen f m

8089 if !(nullPtr h)

@@ -83,60 +92,83 @@ fopen f m = do h <- do_fopen f m

8392 else return (Right (FHandle h))

8493

8594||| Check whether a file handle is actually a null pointer

95+export

8696validFile : File -> IO Bool

8797validFile (FHandle h) = do x <- nullPtr h

8898 return (not x)

8999

90100||| Modes for opening files

91−data Mode = Read | Write | ReadWrite

101+data Mode = Read | WriteTruncate | Append | ReadWrite | ReadWriteTruncate | ReadAppend

102+

103+Write : Mode

104+Write = WriteTruncate

105+%deprecate Write "Please use WriteTruncate instead."

106+

107+modeStr : Mode -> String

108+modeStr Read = "r"

109+modeStr WriteTruncate = "w"

110+modeStr Append = "a"

111+modeStr ReadWrite = "r+"

112+modeStr ReadWriteTruncate = "w+"

113+modeStr ReadAppend = "a+"

92114

93115||| Open a file

94116||| @ f the filename

95−||| @ m the mode; either Read, Write, or ReadWrite

117+||| @ m the mode; either Read, WriteTruncate, Append, ReadWrite, ReadWriteTruncate, or ReadAppend

118+export

96119openFile : (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+"

120+openFile f m = fopen f (modeStr m)

121+

122+||| Open a file using C11 extended modes.

123+||| @ f the filename

124+||| @ m the mode; either Read, WriteTruncate, Append, ReadWrite, ReadWriteTruncate, or ReadAppend

125+export

126+openFileX : (f : String) -> (m : Mode) -> IO (Either FileError File)

127+openFileX f m = fopen f $ modeStr m ++ "x"

101128

129+private

102130do_fclose : Ptr -> IO ()

103131do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h

104132

133+export

105134closeFile : File -> IO ()

106135closeFile (FHandle h) = do_fclose h

107136

137+private

108138do_fread : Ptr -> IO' l String

109139do_fread h = prim_fread h

110140

141+export

111142fgetc : File -> IO (Either FileError Char)

112143fgetc (FHandle h) = do let c = cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h)

113144 if !(ferror (FHandle h))

114145 then return (Left FileReadError)

115146 else return (Right c)

116147

148+export

117149fflush : File -> IO ()

118150fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h

119151

152+private

120153do_popen : String -> String -> IO Ptr

121154do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m

122155

156+export

123157popen : String -> Mode -> IO (Either FileError File)

124158popen f m = do ptr <- do_popen f (modeStr m)

125159 if !(nullPtr ptr)

126160 then do err <- getFileError

127161 return (Left err)

128162 else return (Right (FHandle ptr))

129− where

130− modeStr Read = "r"

131− modeStr Write = "w"

132− modeStr ReadWrite = "r+"

133163

164+export

134165pclose : File -> IO ()

135166pclose (FHandle h) = foreign FFI_C "pclose" (Ptr -> IO ()) h

136167

137168-- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String))

138169-- prim__vm h

139170

171+export

140172fread : File -> IO (Either FileError String)

141173fread (FHandle h) = do str <- do_fread h

142174 if !(ferror (FHandle h))

@@ -145,56 +177,65 @@ fread (FHandle h) = do str <- do_fread h

145177

146178||| Read a line from a file

147179||| @h a file handle which must be open for reading

180+export

148181fGetLine : (h : File) -> IO (Either FileError String)

149182fGetLine = fread

150183

151184%deprecate fread "Use fGetLine instead"

152185

186+private

153187do_fwrite : Ptr -> String -> IO (Either FileError ())

154188do_fwrite h s = do res <- prim_fwrite h s

155189 if (res /= 0)

156190 then do errno <- getErrno

157− if errno == 0

191+ if errno == 0

158192 then return (Left FileWriteError)

159193 else do err <- getFileError

160194 return (Left err)

161195 else return (Right ())

162196

197+export

163198fwrite : File -> String -> IO (Either FileError ())

164199fwrite (FHandle h) s = do_fwrite h s

165200

166201||| Write a line to a file

167202||| @h a file handle which must be open for writing

168203||| @str the line to write to the file

204+export

169205fPutStr : (h : File) -> (str : String) -> IO (Either FileError ())

170206fPutStr (FHandle h) s = do_fwrite h s

171207

208+export

172209fPutStrLn : File -> String -> IO (Either FileError ())

173210fPutStrLn (FHandle h) s = do_fwrite h (s ++ "\n")

174211

175212%deprecate fwrite "Use fPutStr instead"

176213

214+private

177215do_feof : Ptr -> IO Int

178216do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h

179217

180218||| Check if a file handle has reached the end

219+export

181220fEOF : File -> IO Bool

182221fEOF (FHandle h) = do eof <- do_feof h

183222 return (not (eof == 0))

184223

185224||| Check if a file handle has reached the end

225+export

186226feof : File -> IO Bool

187227feof = fEOF

188228

189229%deprecate feof "Use fEOF instead"

190230

231+export

191232fpoll : File -> IO Bool

192233fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h

193234 return (p > 0)

194235

195236||| Read the contents of a file into a string

196−partial -- might be reading something infinitely long like /dev/null ...

197−covering

237+partial -- might be reading something infinitely long like /dev/null ...

238+covering export

198239readFile : String -> IO (Either FileError String)

199240readFile fn = do Right h <- openFile fn Read

200241 | Left err => return (Left err)

@@ -212,10 +253,11 @@ readFile fn = do Right h <- openFile fn Read

212253 else return (Right contents)

213254

214255||| Write a string to a file

215−writeFile : (filepath : String) -> (contents : String) ->

256+export

257+writeFile : (filepath : String) -> (contents : String) ->

216258 IO (Either FileError ())

217259writeFile fn contents = do

218− Right h <- openFile fn Write | Left err => return (Left err)

219− Right () <- fPutStr h contents | Left err => return (Left err)

260+ Right h <- openFile fn WriteTruncate | Left err => return (Left err)

261+ Right () <- fPutStr h contents | Left err => return (Left err)

220262 closeFile h

221263 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+12−4

@@ -8,22 +8,30 @@ import Prelude.Applicative

88import Prelude.Basics

99import IO

1010

11−%access public

11+%access public export

1212

1313infixl 5 >>=

1414

1515interface Applicative m => Monad (m : Type -> Type) where

16+ ||| Also called `bind`.

1617 (>>=) : m a -> ((result : a) -> m b) -> m b

1718

18−||| Also called `join` or mu

19−flatten : Monad m => m (m a) -> m a

20−flatten a = a >>= id

19+ ||| Also called `flatten` or mu

20+ join : m (m a) -> m a

21+

22+ -- default implementations

23+ (>>=) x f = join (f <$> x)

24+ join x = x >>= id

2125

2226||| For compatibility with Haskell. Note that monads are **not** free to

2327||| define `return` and `pure` differently!

2428return : Monad m => a -> m a

2529return = pure

2630

31+flatten : Monad m => m (m a) -> m a

32+flatten = join

33+%deprecate flatten "Please use `join`, which is the standard name."

34+

2735-- Annoyingly, these need to be here, so that we can use them in other

2836-- Prelude modules other than the top level.

2937

libs/prelude/Prelude/Nat.idr+19−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

@@ -341,6 +341,7 @@ partial

341341divCeil : Nat -> Nat -> Nat

342342divCeil x (S y) = divCeilNZ x (S y) SIsNotZ

343343

344+partial

344345Integral Nat where

345346 div = divNat

346347 mod = modNat

@@ -424,7 +425,7 @@ total plusCommutative : (left : Nat) -> (right : Nat) ->

424425plusCommutative Z right = rewrite plusZeroRightNeutral right in Refl

425426plusCommutative (S left) right =

426427 let inductiveHypothesis = plusCommutative left right in

427− rewrite inductiveHypothesis in

428+ rewrite inductiveHypothesis in

428429 rewrite plusSuccRightSucc right left in Refl

429430

430431total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

@@ -450,21 +451,21 @@ total plusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->

450451plusLeftCancel Z right right' p = p

451452plusLeftCancel (S left) right right' p =

452453 let inductiveHypothesis = plusLeftCancel left right right' in

453− inductiveHypothesis (succInjective _ _ p)

454+ inductiveHypothesis (succInjective _ _ p)

454455

455456total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) ->

456457 (p : left + right = left' + right) -> left = left'

457458plusRightCancel left left' Z p = rewrite sym (plusZeroRightNeutral left) in

458459 rewrite sym (plusZeroRightNeutral left') in

459− p

460+ p

460461plusRightCancel left left' (S right) p =

461− plusRightCancel left left' right

462− (succInjective _ _ (rewrite plusSuccRightSucc left right in

462+ plusRightCancel left left' right

463+ (succInjective _ _ (rewrite plusSuccRightSucc left right in

463464 rewrite plusSuccRightSucc left' right in p))

464465

465466total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) ->

466467 (p : left + right = left) -> right = Z

467−plusLeftLeftRightZero Z right p = p

468+plusLeftLeftRightZero Z right p = p

468469plusLeftLeftRightZero (S left) right p =

469470 plusLeftLeftRightZero left right (succInjective _ _ p)

470471

@@ -481,7 +482,7 @@ total multRightSuccPlus : (left : Nat) -> (right : Nat) ->

481482multRightSuccPlus Z right = Refl

482483multRightSuccPlus (S left) right =

483484 let inductiveHypothesis = multRightSuccPlus left right in

484− rewrite inductiveHypothesis in

485+ rewrite inductiveHypothesis in

485486 rewrite plusAssociative left right (mult left right) in

486487 rewrite plusAssociative right left (mult left right) in

487488 rewrite plusCommutative right left in

@@ -493,11 +494,11 @@ multLeftSuccPlus left right = Refl

493494

494495total multCommutative : (left : Nat) -> (right : Nat) ->

495496 left * right = right * left

496−multCommutative Z right = rewrite multZeroRightZero right in Refl

497+multCommutative Z right = rewrite multZeroRightZero right in Refl

497498multCommutative (S left) right =

498499 let inductiveHypothesis = multCommutative left right in

499500 rewrite inductiveHypothesis in

500− rewrite multRightSuccPlus right left in

501+ rewrite multRightSuccPlus right left in

501502 Refl

502503

503504total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

@@ -505,7 +506,7 @@ total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right :

505506multDistributesOverPlusRight Z centre right = Refl

506507multDistributesOverPlusRight (S left) centre right =

507508 let inductiveHypothesis = multDistributesOverPlusRight left centre right in

508− rewrite inductiveHypothesis in

509+ rewrite inductiveHypothesis in

509510 rewrite plusAssociative (plus centre (mult left centre)) right (mult left right) in

510511 rewrite sym (plusAssociative centre (mult left centre) right) in

511512 rewrite plusCommutative (mult left centre) right in

@@ -527,7 +528,7 @@ total multAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

527528multAssociative Z centre right = Refl

528529multAssociative (S left) centre right =

529530 let inductiveHypothesis = multAssociative left centre right in

530− rewrite inductiveHypothesis in

531+ rewrite inductiveHypothesis in

531532 rewrite multDistributesOverPlusLeft centre (mult left centre) right in

532533 Refl

533534

@@ -619,7 +620,7 @@ powerSuccPowerLeft base exp = Refl

619620

620621total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->

621622 (power base exp) * (power base exp') = power base (exp + exp')

622−multPowerPowerPlus base Z exp' =

623+multPowerPowerPlus base Z exp' =

623624 rewrite sym (plusZeroRightNeutral (power base exp')) in Refl

624625multPowerPowerPlus base (S exp) exp' =

625626 let inductiveHypothesis = multPowerPowerPlus base exp exp' in

@@ -651,7 +652,7 @@ total powerPowerMultPower : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->

651652powerPowerMultPower base exp Z = rewrite multZeroRightZero exp in Refl

652653powerPowerMultPower base exp (S exp') =

653654 let inductiveHypothesis = powerPowerMultPower base exp exp' in

654− rewrite inductiveHypothesis in

655+ rewrite inductiveHypothesis in

655656 rewrite multRightSuccPlus exp exp' in

656657 rewrite sym (multPowerPowerPlus base exp (mult exp exp')) in

657658 Refl

@@ -664,7 +665,7 @@ total minusSuccPred : (left : Nat) -> (right : Nat) ->

664665 minus left (S right) = pred (minus left right)

665666minusSuccPred Z right = Refl

666667minusSuccPred (S left) Z =

667− rewrite minusZeroRight left in Refl

668+ rewrite minusZeroRight left in Refl

668669minusSuccPred (S left) (S right) =

669670 let inductiveHypothesis = minusSuccPred left right in

670671 rewrite inductiveHypothesis in Refl

@@ -782,4 +783,3 @@ sucMinL (S l) = cong (sucMinL l)

782783total sucMinR : (l : Nat) -> minimum l (S l) = l

783784sucMinR Z = Refl

784785sucMinR (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+4−1

@@ -1,11 +1,14 @@

11module Prelude.Providers

22

3+import Prelude.Basics

34import Prelude.Functor

45import Prelude.Applicative

56import Prelude.Monad

67

8+%access public export

9+

710||| Type providers must build one of these in an IO computation.

8−public

11+public export

912data Provider : (a : Type) -> Type where

1013 ||| Return a term to be spliced in

1114 ||| @ 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−10

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

@@ -24,16 +26,6 @@ updateTyConArgTy f (TyConParameter a) =

2426updateTyConArgTy f (TyConIndex a) =

2527 TyConIndex (record {type = f (type a) } a)

2628

27−unApply : Raw -> (Raw, List Raw)

28−unApply tm = unApply' tm []

29− where unApply' : Raw -> List Raw -> (Raw, List Raw)

30− unApply' (RApp f x) xs = unApply' f (x::xs)

31− unApply' notApp xs = (notApp, xs)

32−

33−mkApp : Raw -> List Raw -> Raw

34−mkApp f [] = f

35−mkApp f (x :: xs) = mkApp (RApp f x) xs

36−

3729||| Grab the binders from around a term, alpha-converting to make

3830||| their names unique

3931partial

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

main/Main.hs+41−44

@@ -4,12 +4,10 @@ import System.Console.Haskeline

44import System.IO

55import System.Environment

66import System.Exit

7−import System.FilePath ((</>), addTrailingPathSeparator)

87import System.Directory

98

109import Data.Maybe

1110import Data.Version

12−import Control.Monad.Trans.State.Strict ( execStateT, get, put )

1311import Control.Monad ( when )

1412

1513import Idris.Core.TT

@@ -44,66 +42,65 @@ main = do opts <- runArgParser

4442

4543runIdris :: [Opt] -> Idris ()

4644runIdris opts = do

47− runIO setupBundledCC

48− when (ShowLoggingCats `elem` opts) $ runIO showLoggingCats

49− when (ShowIncs `elem` opts) $ runIO showIncs

50− when (ShowLibs `elem` opts) $ runIO showLibs

51− when (ShowLibdir `elem` opts) $ runIO showLibdir

52− when (ShowPkgs `elem` opts) $ runIO showPkgs

53− case opt getClient opts of

54− [] -> return ()

55− (c:_) -> do setVerbose False

56− setQuiet True

57− runIO $ runClient (getPort opts) c

58− runIO $ exitWith ExitSuccess

59− case opt getPkgCheck opts of

60− [] -> return ()

61− fs -> do runIO $ mapM_ (checkPkg (WarnOnly `elem` opts) True) fs

62− runIO $ exitWith ExitSuccess

63− case opt getPkgClean opts of

64− [] -> return ()

65− fs -> do runIO $ mapM_ cleanPkg fs

66− runIO $ exitWith ExitSuccess

67− case opt getPkgMkDoc opts of -- IdrisDoc

68− [] -> return ()

69− fs -> do runIO $ mapM_ documentPkg fs

70− runIO $ exitWith ExitSuccess

71− case opt getPkgTest opts of

72− [] -> return ()

73− fs -> do runIO $ mapM_ testPkg fs

74− runIO $ exitWith ExitSuccess

75− case opt getPkg opts of

76− [] -> case opt getPkgREPL opts of

77− [] -> idrisMain opts

78− [f] -> replPkg f

79− _ -> ifail "Too many packages"

80− fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs

45+ runIO setupBundledCC

46+ when (ShowLoggingCats `elem` opts) $ runIO showLoggingCats

47+ when (ShowIncs `elem` opts) $ runIO showIncs

48+ when (ShowLibs `elem` opts) $ runIO showLibs

49+ when (ShowLibdir `elem` opts) $ runIO showLibdir

50+ when (ShowPkgs `elem` opts) $ runIO showPkgs

51+ case opt getClient opts of

52+ [] -> return ()

53+ (c:_) -> do setVerbose False

54+ setQuiet True

55+ runIO $ runClient (getPort opts) c

56+ runIO exitSuccess

57+ case opt getPkgCheck opts of

58+ [] -> return ()

59+ fs -> do runIO $ mapM_ (checkPkg (WarnOnly `elem` opts) True) fs

60+ runIO exitSuccess

61+ case opt getPkgClean opts of

62+ [] -> return ()

63+ fs -> do runIO $ mapM_ cleanPkg fs

64+ runIO exitSuccess

65+ case opt getPkgMkDoc opts of -- IdrisDoc

66+ [] -> return ()

67+ fs -> do runIO $ mapM_ documentPkg fs

68+ runIO exitSuccess

69+ case opt getPkgTest opts of

70+ [] -> return ()

71+ fs -> do runIO $ mapM_ testPkg fs

72+ runIO exitSuccess

73+ case opt getPkg opts of

74+ [] -> case opt getPkgREPL opts of

75+ [] -> idrisMain opts

76+ [f] -> replPkg f

77+ _ -> ifail "Too many packages"

78+ fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs

8179

8280showver :: IO b

8381showver = do putStrLn $ "Idris version " ++ ver

84− exitWith ExitSuccess

82+ exitSuccess

8583

8684showLibs :: IO b

8785showLibs = do libFlags <- getLibFlags

8886 putStrLn $ unwords libFlags

89− exitWith ExitSuccess

87+ exitSuccess

9088

9189showLibdir :: IO b

92−showLibdir = do dir <- getIdrisLibDir

93− putStrLn dir

94− exitWith ExitSuccess

90+showLibdir = do putStrLn =<< getIdrisLibDir

91+ exitSuccess

9592

9693showIncs :: IO b

9794showIncs = do incFlags <- getIncFlags

9895 putStrLn $ unwords incFlags

99− exitWith ExitSuccess

96+ exitSuccess

10097

10198-- | List idris packages installed

10299showPkgs :: IO b

103100showPkgs = do mapM putStrLn =<< installedPackages

104− exitWith ExitSuccess

101+ exitSuccess

105102

106103showLoggingCats :: IO b

107104showLoggingCats = do

108105 putStrLn loggingCatsStr

109− exitWith ExitSuccess

106+ exitSuccess

rts/getline.c+32−31

@@ -38,40 +38,41 @@

3838ssize_t

3939getdelim(char **buf, size_t *bufsiz, int delimiter, FILE *fp)

4040{

41− char *ptr, *eptr;

41+ char *ptr, *eptr;

4242

43−

44− if (*buf == NULL || *bufsiz == 0) {

45− *bufsiz = BUFSIZ;

46− if ((*buf = malloc(*bufsiz)) == NULL)

47− return -1;

48− }

49−

50− for (ptr = *buf, eptr = *buf + *bufsiz;;) {

51− int c = fgetc(fp);

52− if (c == -1) {

53− if (feof(fp))

54− return ptr == *buf ? -1 : ptr - *buf;

55− else

56− return -1;

43+ if (*buf == NULL || *bufsiz == 0) {

44+ *bufsiz = BUFSIZ;

45+ if ((*buf = malloc(*bufsiz)) == NULL)

46+ return -1;

5747 }

58− *ptr++ = c;

59− if (c == delimiter) {

60− *ptr = '\0';

61− return ptr - *buf;

62− }

63− if (ptr + 2 >= eptr) {

64− char *nbuf;

65− size_t nbufsiz = *bufsiz * 2;

66− ssize_t d = ptr - *buf;

67− if ((nbuf = realloc(*buf, nbufsiz)) == NULL)

68− return -1;

69− *buf = nbuf;

70− *bufsiz = nbufsiz;

71− eptr = nbuf + nbufsiz;

72− ptr = nbuf + d;

48+

49+ for (ptr = *buf, eptr = *buf + *bufsiz;;) {

50+ int c = fgetc(fp);

51+ if (c == -1) {

52+ if (feof(fp)) {

53+ *ptr = '\0';

54+ return ptr - *buf;

55+ } else {

56+ return -1;

57+ }

58+ }

59+ *ptr++ = c;

60+ if (c == delimiter) {

61+ *ptr = '\0';

62+ return ptr - *buf;

63+ }

64+ if (ptr + 2 >= eptr) {

65+ char *nbuf;

66+ size_t nbufsiz = *bufsiz * 2;

67+ ssize_t d = ptr - *buf;

68+ if ((nbuf = realloc(*buf, nbufsiz)) == NULL)

69+ return -1;

70+ *buf = nbuf;

71+ *bufsiz = nbufsiz;

72+ eptr = nbuf + nbufsiz;

73+ ptr = nbuf + d;

74+ }

7375 }

74− }

7576}

7677

7778ssize_t

rts/idris_bitstring.c+121−86

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

55VAL idris_b8CopyForGC(VM *vm, VAL a) {

66 uint8_t A = a->info.bits8;

77 VAL cl = allocate(sizeof(Closure), 1);

8− SETTY(cl, BITS8);

8+ SETTY(cl, CT_BITS8);

99 cl->info.bits8 = A;

1010 return cl;

1111}

@@ -13,7 +13,7 @@ VAL idris_b8CopyForGC(VM *vm, VAL a) {

1313VAL idris_b16CopyForGC(VM *vm, VAL a) {

1414 uint16_t A = a->info.bits16;

1515 VAL cl = allocate(sizeof(Closure), 1);

16− SETTY(cl, BITS16);

16+ SETTY(cl, CT_BITS16);

1717 cl->info.bits16 = A;

1818 return cl;

1919}

@@ -21,7 +21,7 @@ VAL idris_b16CopyForGC(VM *vm, VAL a) {

2121VAL idris_b32CopyForGC(VM *vm, VAL a) {

2222 uint32_t A = a->info.bits32;

2323 VAL cl = allocate(sizeof(Closure), 1);

24− SETTY(cl, BITS32);

24+ SETTY(cl, CT_BITS32);

2525 cl->info.bits32 = A;

2626 return cl;

2727}

@@ -29,7 +29,7 @@ VAL idris_b32CopyForGC(VM *vm, VAL a) {

2929VAL idris_b64CopyForGC(VM *vm, VAL a) {

3030 uint64_t A = a->info.bits64;

3131 VAL cl = allocate(sizeof(Closure), 1);

32− SETTY(cl, BITS64);

32+ SETTY(cl, CT_BITS64);

3333 cl->info.bits64 = A;

3434 return cl;

3535}

@@ -37,7 +37,7 @@ VAL idris_b64CopyForGC(VM *vm, VAL a) {

3737VAL idris_b8(VM *vm, VAL a) {

3838 uint8_t A = GETINT(a);

3939 VAL cl = allocate(sizeof(Closure), 0);

40− SETTY(cl, BITS8);

40+ SETTY(cl, CT_BITS8);

4141 cl->info.bits8 = (uint8_t) A;

4242 return cl;

4343}

@@ -45,7 +45,7 @@ VAL idris_b8(VM *vm, VAL a) {

4545VAL idris_b16(VM *vm, VAL a) {

4646 uint16_t A = GETINT(a);

4747 VAL cl = allocate(sizeof(Closure), 0);

48− SETTY(cl, BITS16);

48+ SETTY(cl, CT_BITS16);

4949 cl->info.bits16 = (uint16_t) A;

5050 return cl;

5151}

@@ -53,7 +53,7 @@ VAL idris_b16(VM *vm, VAL a) {

5353VAL idris_b32(VM *vm, VAL a) {

5454 uint32_t A = GETINT(a);

5555 VAL cl = allocate(sizeof(Closure), 0);

56− SETTY(cl, BITS32);

56+ SETTY(cl, CT_BITS32);

5757 cl->info.bits32 = (uint32_t) A;

5858 return cl;

5959}

@@ -61,7 +61,7 @@ VAL idris_b32(VM *vm, VAL a) {

6161VAL idris_b64(VM *vm, VAL a) {

6262 uint64_t A = GETINT(a);

6363 VAL cl = allocate(sizeof(Closure), 0);

64− SETTY(cl, BITS64);

64+ SETTY(cl, CT_BITS64);

6565 cl->info.bits64 = (uint64_t) A;

6666 return cl;

6767}

@@ -72,28 +72,28 @@ VAL idris_castB32Int(VM *vm, VAL a) {

7272

7373VAL idris_b8const(VM *vm, uint8_t a) {

7474 VAL cl = allocate(sizeof(Closure), 0);

75− SETTY(cl, BITS8);

75+ SETTY(cl, CT_BITS8);

7676 cl->info.bits8 = a;

7777 return cl;

7878}

7979

8080VAL idris_b16const(VM *vm, uint16_t a) {

8181 VAL cl = allocate(sizeof(Closure), 0);

82− SETTY(cl, BITS16);

82+ SETTY(cl, CT_BITS16);

8383 cl->info.bits16 = a;

8484 return cl;

8585}

8686

8787VAL idris_b32const(VM *vm, uint32_t a) {

8888 VAL cl = allocate(sizeof(Closure), 0);

89− SETTY(cl, BITS32);

89+ SETTY(cl, CT_BITS32);

9090 cl->info.bits32 = a;

9191 return cl;

9292}

9393

9494VAL idris_b64const(VM *vm, uint64_t a) {

9595 VAL cl = allocate(sizeof(Closure), 0);

96− SETTY(cl, BITS64);

96+ SETTY(cl, CT_BITS64);

9797 cl->info.bits64 = a;

9898 return cl;

9999}

@@ -102,7 +102,7 @@ VAL idris_b8Plus(VM *vm, VAL a, VAL b) {

102102 uint8_t A = a->info.bits8;

103103 uint8_t B = b->info.bits8;

104104 VAL cl = allocate(sizeof(Closure), 0);

105− SETTY(cl, BITS8);

105+ SETTY(cl, CT_BITS8);

106106 cl->info.bits8 = A + B;

107107 return cl;

108108}

@@ -111,7 +111,7 @@ VAL idris_b8Minus(VM *vm, VAL a, VAL b) {

111111 uint8_t A = a->info.bits8;

112112 uint8_t B = b->info.bits8;

113113 VAL cl = allocate(sizeof(Closure), 0);

114− SETTY(cl, BITS8);

114+ SETTY(cl, CT_BITS8);

115115 cl->info.bits8 = A - B;

116116 return cl;

117117}

@@ -120,7 +120,7 @@ VAL idris_b8Times(VM *vm, VAL a, VAL b) {

120120 uint8_t A = a->info.bits8;

121121 uint8_t B = b->info.bits8;

122122 VAL cl = allocate(sizeof(Closure), 0);

123− SETTY(cl, BITS8);

123+ SETTY(cl, CT_BITS8);

124124 cl->info.bits8 = A * B;

125125 return cl;

126126}

@@ -129,7 +129,7 @@ VAL idris_b8UDiv(VM *vm, VAL a, VAL b) {

129129 uint8_t A = a->info.bits8;

130130 uint8_t B = b->info.bits8;

131131 VAL cl = allocate(sizeof(Closure), 0);

132− SETTY(cl, BITS8);

132+ SETTY(cl, CT_BITS8);

133133 cl->info.bits8 = A / B;

134134 return cl;

135135}

@@ -138,7 +138,7 @@ VAL idris_b8SDiv(VM *vm, VAL a, VAL b) {

138138 uint8_t A = a->info.bits8;

139139 uint8_t B = b->info.bits8;

140140 VAL cl = allocate(sizeof(Closure), 0);

141− SETTY(cl, BITS8);

141+ SETTY(cl, CT_BITS8);

142142 cl->info.bits8 = (uint8_t) (((int8_t) A) / ((int8_t) B));

143143 return cl;

144144}

@@ -147,7 +147,7 @@ VAL idris_b8URem(VM *vm, VAL a, VAL b) {

147147 uint8_t A = a->info.bits8;

148148 uint8_t B = b->info.bits8;

149149 VAL cl = allocate(sizeof(Closure), 0);

150− SETTY(cl, BITS8);

150+ SETTY(cl, CT_BITS8);

151151 cl->info.bits8 = A % B;

152152 return cl;

153153}

@@ -156,7 +156,7 @@ VAL idris_b8SRem(VM *vm, VAL a, VAL b) {

156156 uint8_t A = a->info.bits8;

157157 uint8_t B = b->info.bits8;

158158 VAL cl = allocate(sizeof(Closure), 0);

159− SETTY(cl, BITS8);

159+ SETTY(cl, CT_BITS8);

160160 cl->info.bits8 = (uint8_t) (((int8_t) A) % ((int8_t) B));

161161 return cl;

162162}

@@ -184,7 +184,7 @@ VAL idris_b8Gte(VM *vm, VAL a, VAL b) {

184184VAL idris_b8Compl(VM *vm, VAL a) {

185185 uint8_t A = a->info.bits8;

186186 VAL cl = allocate(sizeof(Closure), 0);

187− SETTY(cl, BITS8);

187+ SETTY(cl, CT_BITS8);

188188 cl->info.bits8 = ~ A;

189189 return cl;

190190}

@@ -193,7 +193,7 @@ VAL idris_b8And(VM *vm, VAL a, VAL b) {

193193 uint8_t A = a->info.bits8;

194194 uint8_t B = b->info.bits8;

195195 VAL cl = allocate(sizeof(Closure), 0);

196− SETTY(cl, BITS8);

196+ SETTY(cl, CT_BITS8);

197197 cl->info.bits8 = A & B;

198198 return cl;

199199}

@@ -202,7 +202,7 @@ VAL idris_b8Or(VM *vm, VAL a, VAL b) {

202202 uint8_t A = a->info.bits8;

203203 uint8_t B = b->info.bits8;

204204 VAL cl = allocate(sizeof(Closure), 0);

205− SETTY(cl, BITS8);

205+ SETTY(cl, CT_BITS8);

206206 cl->info.bits8 = A | B;

207207 return cl;

208208}

@@ -211,7 +211,7 @@ VAL idris_b8Xor(VM *vm, VAL a, VAL b) {

211211 uint8_t A = a->info.bits8;

212212 uint8_t B = b->info.bits8;

213213 VAL cl = allocate(sizeof(Closure), 0);

214− SETTY(cl, BITS8);

214+ SETTY(cl, CT_BITS8);

215215 cl->info.bits8 = A ^ B;

216216 return cl;

217217}

@@ -220,7 +220,7 @@ VAL idris_b8Shl(VM *vm, VAL a, VAL b) {

220220 uint8_t A = a->info.bits8;

221221 uint8_t B = b->info.bits8;

222222 VAL cl = allocate(sizeof(Closure), 0);

223− SETTY(cl, BITS8);

223+ SETTY(cl, CT_BITS8);

224224 cl->info.bits8 = A << B;

225225 return cl;

226226}

@@ -229,7 +229,7 @@ VAL idris_b8LShr(VM *vm, VAL a, VAL b) {

229229 uint8_t A = a->info.bits8;

230230 uint8_t B = b->info.bits8;

231231 VAL cl = allocate(sizeof(Closure), 0);

232− SETTY(cl, BITS8);

232+ SETTY(cl, CT_BITS8);

233233 cl->info.bits8 = A >> B;

234234 return cl;

235235}

@@ -238,7 +238,7 @@ VAL idris_b8AShr(VM *vm, VAL a, VAL b) {

238238 uint8_t A = a->info.bits8;

239239 uint8_t B = b->info.bits8;

240240 VAL cl = allocate(sizeof(Closure), 0);

241− SETTY(cl, BITS8);

241+ SETTY(cl, CT_BITS8);

242242 cl->info.bits8 = (uint8_t) (((int8_t) A) >> ((int8_t) B));

243243 return cl;

244244}

@@ -247,7 +247,7 @@ VAL idris_b16Plus(VM *vm, VAL a, VAL b) {

247247 uint16_t A = a->info.bits16;

248248 uint16_t B = b->info.bits16;

249249 VAL cl = allocate(sizeof(Closure), 0);

250− SETTY(cl, BITS16);

250+ SETTY(cl, CT_BITS16);

251251 cl->info.bits16 = A + B;

252252 return cl;

253253}

@@ -256,7 +256,7 @@ VAL idris_b16Minus(VM *vm, VAL a, VAL b) {

256256 uint16_t A = a->info.bits16;

257257 uint16_t B = b->info.bits16;

258258 VAL cl = allocate(sizeof(Closure), 0);

259− SETTY(cl, BITS16);

259+ SETTY(cl, CT_BITS16);

260260 cl->info.bits16 = A - B;

261261 return cl;

262262}

@@ -265,7 +265,7 @@ VAL idris_b16Times(VM *vm, VAL a, VAL b) {

265265 uint16_t A = a->info.bits16;

266266 uint16_t B = b->info.bits16;

267267 VAL cl = allocate(sizeof(Closure), 0);

268− SETTY(cl, BITS16);

268+ SETTY(cl, CT_BITS16);

269269 cl->info.bits16 = A * B;

270270 return cl;

271271}

@@ -274,7 +274,7 @@ VAL idris_b16UDiv(VM *vm, VAL a, VAL b) {

274274 uint16_t A = a->info.bits16;

275275 uint16_t B = b->info.bits16;

276276 VAL cl = allocate(sizeof(Closure), 0);

277− SETTY(cl, BITS16);

277+ SETTY(cl, CT_BITS16);

278278 cl->info.bits16 = A / B;

279279 return cl;

280280}

@@ -283,7 +283,7 @@ VAL idris_b16SDiv(VM *vm, VAL a, VAL b) {

283283 uint16_t A = a->info.bits16;

284284 uint16_t B = b->info.bits16;

285285 VAL cl = allocate(sizeof(Closure), 0);

286− SETTY(cl, BITS16);

286+ SETTY(cl, CT_BITS16);

287287 cl->info.bits16 = (uint16_t) (((int16_t) A) / ((int16_t) B));

288288 return cl;

289289}

@@ -292,7 +292,7 @@ VAL idris_b16URem(VM *vm, VAL a, VAL b) {

292292 uint16_t A = a->info.bits16;

293293 uint16_t B = b->info.bits16;

294294 VAL cl = allocate(sizeof(Closure), 0);

295− SETTY(cl, BITS16);

295+ SETTY(cl, CT_BITS16);

296296 cl->info.bits16 = A % B;

297297 return cl;

298298}

@@ -301,7 +301,7 @@ VAL idris_b16SRem(VM *vm, VAL a, VAL b) {

301301 uint16_t A = a->info.bits16;

302302 uint16_t B = b->info.bits16;

303303 VAL cl = allocate(sizeof(Closure), 0);

304− SETTY(cl, BITS16);

304+ SETTY(cl, CT_BITS16);

305305 cl->info.bits16 = (uint16_t) (((int16_t) A) % ((int16_t) B));

306306 return cl;

307307}

@@ -329,7 +329,7 @@ VAL idris_b16Gte(VM *vm, VAL a, VAL b) {

329329VAL idris_b16Compl(VM *vm, VAL a) {

330330 uint16_t A = a->info.bits16;

331331 VAL cl = allocate(sizeof(Closure), 0);

332− SETTY(cl, BITS16);

332+ SETTY(cl, CT_BITS16);

333333 cl->info.bits16 = ~ A;

334334 return cl;

335335}

@@ -338,7 +338,7 @@ VAL idris_b16And(VM *vm, VAL a, VAL b) {

338338 uint16_t A = a->info.bits16;

339339 uint16_t B = b->info.bits16;

340340 VAL cl = allocate(sizeof(Closure), 0);

341− SETTY(cl, BITS16);

341+ SETTY(cl, CT_BITS16);

342342 cl->info.bits16 = A & B;

343343 return cl;

344344}

@@ -347,7 +347,7 @@ VAL idris_b16Or(VM *vm, VAL a, VAL b) {

347347 uint16_t A = a->info.bits16;

348348 uint16_t B = b->info.bits16;

349349 VAL cl = allocate(sizeof(Closure), 0);

350− SETTY(cl, BITS16);

350+ SETTY(cl, CT_BITS16);

351351 cl->info.bits16 = A | B;

352352 return cl;

353353}

@@ -356,7 +356,7 @@ VAL idris_b16Xor(VM *vm, VAL a, VAL b) {

356356 uint16_t A = a->info.bits16;

357357 uint16_t B = b->info.bits16;

358358 VAL cl = allocate(sizeof(Closure), 0);

359− SETTY(cl, BITS16);

359+ SETTY(cl, CT_BITS16);

360360 cl->info.bits16 = A ^ B;

361361 return cl;

362362}

@@ -365,7 +365,7 @@ VAL idris_b16Shl(VM *vm, VAL a, VAL b) {

365365 uint16_t A = a->info.bits16;

366366 uint16_t B = b->info.bits16;

367367 VAL cl = allocate(sizeof(Closure), 0);

368− SETTY(cl, BITS16);

368+ SETTY(cl, CT_BITS16);

369369 cl->info.bits16 = A << B;

370370 return cl;

371371}

@@ -374,7 +374,7 @@ VAL idris_b16LShr(VM *vm, VAL a, VAL b) {

374374 uint16_t A = a->info.bits16;

375375 uint16_t B = b->info.bits16;

376376 VAL cl = allocate(sizeof(Closure), 0);

377− SETTY(cl, BITS16);

377+ SETTY(cl, CT_BITS16);

378378 cl->info.bits16 = A >> B;

379379 return cl;

380380}

@@ -383,7 +383,7 @@ VAL idris_b16AShr(VM *vm, VAL a, VAL b) {

383383 uint16_t A = a->info.bits16;

384384 uint16_t B = b->info.bits16;

385385 VAL cl = allocate(sizeof(Closure), 0);

386− SETTY(cl, BITS16);

386+ SETTY(cl, CT_BITS16);

387387 cl->info.bits16 = (uint16_t) (((int16_t) A) >> ((int16_t) B));

388388 return cl;

389389}

@@ -392,7 +392,7 @@ VAL idris_b32Plus(VM *vm, VAL a, VAL b) {

392392 uint32_t A = a->info.bits32;

393393 uint32_t B = b->info.bits32;

394394 VAL cl = allocate(sizeof(Closure), 0);

395− SETTY(cl, BITS32);

395+ SETTY(cl, CT_BITS32);

396396 cl->info.bits32 = A + B;

397397 return cl;

398398}

@@ -401,7 +401,7 @@ VAL idris_b32Minus(VM *vm, VAL a, VAL b) {

401401 uint32_t A = a->info.bits32;

402402 uint32_t B = b->info.bits32;

403403 VAL cl = allocate(sizeof(Closure), 0);

404− SETTY(cl, BITS32);

404+ SETTY(cl, CT_BITS32);

405405 cl->info.bits32 = A - B;

406406 return cl;

407407}

@@ -410,7 +410,7 @@ VAL idris_b32Times(VM *vm, VAL a, VAL b) {

410410 uint32_t A = a->info.bits32;

411411 uint32_t B = b->info.bits32;

412412 VAL cl = allocate(sizeof(Closure), 0);

413− SETTY(cl, BITS32);

413+ SETTY(cl, CT_BITS32);

414414 cl->info.bits32 = A * B;

415415 return cl;

416416}

@@ -419,7 +419,7 @@ VAL idris_b32UDiv(VM *vm, VAL a, VAL b) {

419419 uint32_t A = a->info.bits32;

420420 uint32_t B = b->info.bits32;

421421 VAL cl = allocate(sizeof(Closure), 0);

422− SETTY(cl, BITS32);

422+ SETTY(cl, CT_BITS32);

423423 cl->info.bits32 = A / B;

424424 return cl;

425425}

@@ -428,7 +428,7 @@ VAL idris_b32SDiv(VM *vm, VAL a, VAL b) {

428428 uint32_t A = a->info.bits32;

429429 uint32_t B = b->info.bits32;

430430 VAL cl = allocate(sizeof(Closure), 0);

431− SETTY(cl, BITS32);

431+ SETTY(cl, CT_BITS32);

432432 cl->info.bits32 = (uint32_t) (((int32_t) A) / ((int32_t) B));

433433 return cl;

434434}

@@ -437,7 +437,7 @@ VAL idris_b32URem(VM *vm, VAL a, VAL b) {

437437 uint32_t A = a->info.bits32;

438438 uint32_t B = b->info.bits32;

439439 VAL cl = allocate(sizeof(Closure), 0);

440− SETTY(cl, BITS32);

440+ SETTY(cl, CT_BITS32);

441441 cl->info.bits32 = A % B;

442442 return cl;

443443}

@@ -446,7 +446,7 @@ VAL idris_b32SRem(VM *vm, VAL a, VAL b) {

446446 uint32_t A = a->info.bits32;

447447 uint32_t B = b->info.bits32;

448448 VAL cl = allocate(sizeof(Closure), 0);

449− SETTY(cl, BITS32);

449+ SETTY(cl, CT_BITS32);

450450 cl->info.bits32 = (uint32_t) (((int32_t) A) % ((int32_t) B));

451451 return cl;

452452}

@@ -474,7 +474,7 @@ VAL idris_b32Gte(VM *vm, VAL a, VAL b) {

474474VAL idris_b32Compl(VM *vm, VAL a) {

475475 uint32_t A = a->info.bits32;

476476 VAL cl = allocate(sizeof(Closure), 0);

477− SETTY(cl, BITS32);

477+ SETTY(cl, CT_BITS32);

478478 cl->info.bits32 = ~ A;

479479 return cl;

480480}

@@ -483,7 +483,7 @@ VAL idris_b32And(VM *vm, VAL a, VAL b) {

483483 uint32_t A = a->info.bits32;

484484 uint32_t B = b->info.bits32;

485485 VAL cl = allocate(sizeof(Closure), 0);

486− SETTY(cl, BITS32);

486+ SETTY(cl, CT_BITS32);

487487 cl->info.bits32 = A & B;

488488 return cl;

489489}

@@ -492,7 +492,7 @@ VAL idris_b32Or(VM *vm, VAL a, VAL b) {

492492 uint32_t A = a->info.bits32;

493493 uint32_t B = b->info.bits32;

494494 VAL cl = allocate(sizeof(Closure), 0);

495− SETTY(cl, BITS32);

495+ SETTY(cl, CT_BITS32);

496496 cl->info.bits32 = A | B;

497497 return cl;

498498}

@@ -501,7 +501,7 @@ VAL idris_b32Xor(VM *vm, VAL a, VAL b) {

501501 uint32_t A = a->info.bits32;

502502 uint32_t B = b->info.bits32;

503503 VAL cl = allocate(sizeof(Closure), 0);

504− SETTY(cl, BITS32);

504+ SETTY(cl, CT_BITS32);

505505 cl->info.bits32 = A ^ B;

506506 return cl;

507507}

@@ -510,7 +510,7 @@ VAL idris_b32Shl(VM *vm, VAL a, VAL b) {

510510 uint32_t A = a->info.bits32;

511511 uint32_t B = b->info.bits32;

512512 VAL cl = allocate(sizeof(Closure), 0);

513− SETTY(cl, BITS32);

513+ SETTY(cl, CT_BITS32);

514514 cl->info.bits32 = A << B;

515515 return cl;

516516}

@@ -519,7 +519,7 @@ VAL idris_b32LShr(VM *vm, VAL a, VAL b) {

519519 uint32_t A = a->info.bits32;

520520 uint32_t B = b->info.bits32;

521521 VAL cl = allocate(sizeof(Closure), 0);

522− SETTY(cl, BITS32);

522+ SETTY(cl, CT_BITS32);

523523 cl->info.bits32 = A >> B;

524524 return cl;

525525}

@@ -528,7 +528,7 @@ VAL idris_b32AShr(VM *vm, VAL a, VAL b) {

528528 uint32_t A = a->info.bits32;

529529 uint32_t B = b->info.bits32;

530530 VAL cl = allocate(sizeof(Closure), 0);

531− SETTY(cl, BITS32);

531+ SETTY(cl, CT_BITS32);

532532 cl->info.bits32 = (uint32_t) (((int32_t)A) >> ((int32_t)B));

533533 return cl;

534534}

@@ -537,7 +537,7 @@ VAL idris_b64Plus(VM *vm, VAL a, VAL b) {

537537 uint64_t A = a->info.bits64;

538538 uint64_t B = b->info.bits64;

539539 VAL cl = allocate(sizeof(Closure), 0);

540− SETTY(cl, BITS64);

540+ SETTY(cl, CT_BITS64);

541541 cl->info.bits64 = A + B;

542542 return cl;

543543}

@@ -546,7 +546,7 @@ VAL idris_b64Minus(VM *vm, VAL a, VAL b) {

546546 uint64_t A = a->info.bits64;

547547 uint64_t B = b->info.bits64;

548548 VAL cl = allocate(sizeof(Closure), 0);

549− SETTY(cl, BITS64);

549+ SETTY(cl, CT_BITS64);

550550 cl->info.bits64 = A - B;

551551 return cl;

552552}

@@ -555,7 +555,7 @@ VAL idris_b64Times(VM *vm, VAL a, VAL b) {

555555 uint64_t A = a->info.bits64;

556556 uint64_t B = b->info.bits64;

557557 VAL cl = allocate(sizeof(Closure), 0);

558− SETTY(cl, BITS64);

558+ SETTY(cl, CT_BITS64);

559559 cl->info.bits64 = A * B;

560560 return cl;

561561}

@@ -564,7 +564,7 @@ VAL idris_b64UDiv(VM *vm, VAL a, VAL b) {

564564 uint64_t A = a->info.bits64;

565565 uint64_t B = b->info.bits64;

566566 VAL cl = allocate(sizeof(Closure), 0);

567− SETTY(cl, BITS64);

567+ SETTY(cl, CT_BITS64);

568568 cl->info.bits64 = A / B;

569569 return cl;

570570}

@@ -573,7 +573,7 @@ VAL idris_b64SDiv(VM *vm, VAL a, VAL b) {

573573 uint64_t A = a->info.bits64;

574574 uint64_t B = b->info.bits64;

575575 VAL cl = allocate(sizeof(Closure), 0);

576− SETTY(cl, BITS64);

576+ SETTY(cl, CT_BITS64);

577577 cl->info.bits64 = (uint64_t) (((int64_t) A) / ((int64_t) B));

578578 return cl;

579579}

@@ -582,7 +582,7 @@ VAL idris_b64URem(VM *vm, VAL a, VAL b) {

582582 uint64_t A = a->info.bits64;

583583 uint64_t B = b->info.bits64;

584584 VAL cl = allocate(sizeof(Closure), 0);

585− SETTY(cl, BITS64);

585+ SETTY(cl, CT_BITS64);

586586 cl->info.bits64 = A % B;

587587 return cl;

588588}

@@ -591,7 +591,7 @@ VAL idris_b64SRem(VM *vm, VAL a, VAL b) {

591591 uint64_t A = a->info.bits64;

592592 uint64_t B = b->info.bits64;

593593 VAL cl = allocate(sizeof(Closure), 0);

594− SETTY(cl, BITS64);

594+ SETTY(cl, CT_BITS64);

595595 cl->info.bits64 = (uint64_t) (((int64_t) A) % ((int64_t) B));

596596 return cl;

597597}

@@ -619,7 +619,7 @@ VAL idris_b64Gte(VM *vm, VAL a, VAL b) {

619619VAL idris_b64Compl(VM *vm, VAL a) {

620620 uint64_t A = a->info.bits64;

621621 VAL cl = allocate(sizeof(Closure), 0);

622− SETTY(cl, BITS64);

622+ SETTY(cl, CT_BITS64);

623623 cl->info.bits64 = ~ A;

624624 return cl;

625625}

@@ -628,7 +628,7 @@ VAL idris_b64And(VM *vm, VAL a, VAL b) {

628628 uint64_t A = a->info.bits64;

629629 uint64_t B = b->info.bits64;

630630 VAL cl = allocate(sizeof(Closure), 0);

631− SETTY(cl, BITS64);

631+ SETTY(cl, CT_BITS64);

632632 cl->info.bits64 = A & B;

633633 return cl;

634634}

@@ -637,7 +637,7 @@ VAL idris_b64Or(VM *vm, VAL a, VAL b) {

637637 uint64_t A = a->info.bits64;

638638 uint64_t B = b->info.bits64;

639639 VAL cl = allocate(sizeof(Closure), 0);

640− SETTY(cl, BITS64);

640+ SETTY(cl, CT_BITS64);

641641 cl->info.bits64 = A | B;

642642 return cl;

643643}

@@ -646,7 +646,7 @@ VAL idris_b64Xor(VM *vm, VAL a, VAL b) {

646646 uint64_t A = a->info.bits64;

647647 uint64_t B = b->info.bits64;

648648 VAL cl = allocate(sizeof(Closure), 0);

649− SETTY(cl, BITS64);

649+ SETTY(cl, CT_BITS64);

650650 cl->info.bits64 = A ^ B;

651651 return cl;

652652}

@@ -655,7 +655,7 @@ VAL idris_b64Shl(VM *vm, VAL a, VAL b) {

655655 uint64_t A = a->info.bits64;

656656 uint64_t B = b->info.bits64;

657657 VAL cl = allocate(sizeof(Closure), 0);

658− SETTY(cl, BITS64);

658+ SETTY(cl, CT_BITS64);

659659 cl->info.bits64 = A << B;

660660 return cl;

661661}

@@ -664,7 +664,7 @@ VAL idris_b64LShr(VM *vm, VAL a, VAL b) {

664664 uint64_t A = a->info.bits64;

665665 uint64_t B = b->info.bits64;

666666 VAL cl = allocate(sizeof(Closure), 0);

667− SETTY(cl, BITS64);

667+ SETTY(cl, CT_BITS64);

668668 cl->info.bits64 = A >> B;

669669 return cl;

670670}

@@ -673,7 +673,7 @@ VAL idris_b64AShr(VM *vm, VAL a, VAL b) {

673673 uint64_t A = a->info.bits64;

674674 uint64_t B = b->info.bits64;

675675 VAL cl = allocate(sizeof(Closure), 0);

676− SETTY(cl, BITS64);

676+ SETTY(cl, CT_BITS64);

677677 cl->info.bits64 = (uint64_t) (((int64_t) A) >> ((int64_t) B));

678678 return cl;

679679}

@@ -681,7 +681,7 @@ VAL idris_b64AShr(VM *vm, VAL a, VAL b) {

681681VAL idris_b8Z16(VM *vm, VAL a) {

682682 uint8_t A = a->info.bits8;

683683 VAL cl = allocate(sizeof(Closure), 0);

684− SETTY(cl, BITS16);

684+ SETTY(cl, CT_BITS16);

685685 cl->info.bits16 = (uint16_t) A;

686686 return cl;

687687}

@@ -689,7 +689,7 @@ VAL idris_b8Z16(VM *vm, VAL a) {

689689VAL idris_b8Z32(VM *vm, VAL a) {

690690 uint8_t A = a->info.bits8;

691691 VAL cl = allocate(sizeof(Closure), 0);

692− SETTY(cl, BITS32);

692+ SETTY(cl, CT_BITS32);

693693 cl->info.bits32 = (uint32_t) A;

694694 return cl;

695695}

@@ -697,7 +697,7 @@ VAL idris_b8Z32(VM *vm, VAL a) {

697697VAL idris_b8Z64(VM *vm, VAL a) {

698698 uint8_t A = a->info.bits8;

699699 VAL cl = allocate(sizeof(Closure), 0);

700− SETTY(cl, BITS64);

700+ SETTY(cl, CT_BITS64);

701701 cl->info.bits64 = (uint64_t) A;

702702 return cl;

703703}

@@ -705,7 +705,7 @@ VAL idris_b8Z64(VM *vm, VAL a) {

705705VAL idris_b8S16(VM *vm, VAL a) {

706706 uint8_t A = a->info.bits8;

707707 VAL cl = allocate(sizeof(Closure), 0);

708− SETTY(cl, BITS16);

708+ SETTY(cl, CT_BITS16);

709709 cl->info.bits16 = (uint16_t) (int16_t) (int8_t) A;

710710 return cl;

711711}

@@ -713,7 +713,7 @@ VAL idris_b8S16(VM *vm, VAL a) {

713713VAL idris_b8S32(VM *vm, VAL a) {

714714 uint8_t A = a->info.bits8;

715715 VAL cl = allocate(sizeof(Closure), 0);

716− SETTY(cl, BITS32);

716+ SETTY(cl, CT_BITS32);

717717 cl->info.bits32 = (uint32_t) (int32_t) (int8_t) A;

718718 return cl;

719719}

@@ -721,7 +721,7 @@ VAL idris_b8S32(VM *vm, VAL a) {

721721VAL idris_b8S64(VM *vm, VAL a) {

722722 uint8_t A = a->info.bits8;

723723 VAL cl = allocate(sizeof(Closure), 0);

724− SETTY(cl, BITS64);

724+ SETTY(cl, CT_BITS64);

725725 cl->info.bits64 = (uint64_t) (int64_t) (int8_t) A;

726726 return cl;

727727}

@@ -729,7 +729,7 @@ VAL idris_b8S64(VM *vm, VAL a) {

729729VAL idris_b16Z32(VM *vm, VAL a) {

730730 uint16_t A = a->info.bits16;

731731 VAL cl = allocate(sizeof(Closure), 0);

732− SETTY(cl, BITS32);

732+ SETTY(cl, CT_BITS32);

733733 cl->info.bits32 = (uint32_t) A;

734734 return cl;

735735}

@@ -737,7 +737,7 @@ VAL idris_b16Z32(VM *vm, VAL a) {

737737VAL idris_b16Z64(VM *vm, VAL a) {

738738 uint16_t A = a->info.bits16;

739739 VAL cl = allocate(sizeof(Closure), 0);

740− SETTY(cl, BITS64);

740+ SETTY(cl, CT_BITS64);

741741 cl->info.bits64 = (uint64_t) A;

742742 return cl;

743743}

@@ -745,7 +745,7 @@ VAL idris_b16Z64(VM *vm, VAL a) {

745745VAL idris_b16S32(VM *vm, VAL a) {

746746 uint16_t A = a->info.bits16;

747747 VAL cl = allocate(sizeof(Closure), 0);

748− SETTY(cl, BITS32);

748+ SETTY(cl, CT_BITS32);

749749 cl->info.bits32 = (uint32_t) (int32_t) (int16_t) A;

750750 return cl;

751751}

@@ -753,7 +753,7 @@ VAL idris_b16S32(VM *vm, VAL a) {

753753VAL idris_b16S64(VM *vm, VAL a) {

754754 uint16_t A = a->info.bits16;

755755 VAL cl = allocate(sizeof(Closure), 0);

756− SETTY(cl, BITS64);

756+ SETTY(cl, CT_BITS64);

757757 cl->info.bits64 = (uint64_t) (int64_t) (int16_t) A;

758758 return cl;

759759}

@@ -761,7 +761,7 @@ VAL idris_b16S64(VM *vm, VAL a) {

761761VAL idris_b16T8(VM *vm, VAL a) {

762762 uint16_t A = a->info.bits16;

763763 VAL cl = allocate(sizeof(Closure), 0);

764− SETTY(cl, BITS8);

764+ SETTY(cl, CT_BITS8);

765765 cl->info.bits8 = (uint8_t) A;

766766 return cl;

767767}

@@ -769,7 +769,7 @@ VAL idris_b16T8(VM *vm, VAL a) {

769769VAL idris_b32Z64(VM *vm, VAL a) {

770770 uint32_t A = a->info.bits32;

771771 VAL cl = allocate(sizeof(Closure), 0);

772− SETTY(cl, BITS64);

772+ SETTY(cl, CT_BITS64);

773773 cl->info.bits64 = (uint64_t) A;

774774 return cl;

775775}

@@ -777,7 +777,7 @@ VAL idris_b32Z64(VM *vm, VAL a) {

777777VAL idris_b32S64(VM *vm, VAL a) {

778778 uint32_t A = a->info.bits32;

779779 VAL cl = allocate(sizeof(Closure), 0);

780− SETTY(cl, BITS64);

780+ SETTY(cl, CT_BITS64);

781781 cl->info.bits64 = (uint64_t) (int64_t) (int32_t) A;

782782 return cl;

783783}

@@ -785,7 +785,7 @@ VAL idris_b32S64(VM *vm, VAL a) {

785785VAL idris_b32T8(VM *vm, VAL a) {

786786 uint32_t A = a->info.bits32;

787787 VAL cl = allocate(sizeof(Closure), 0);

788− SETTY(cl, BITS8);

788+ SETTY(cl, CT_BITS8);

789789 cl->info.bits8 = (uint8_t) A;

790790 return cl;

791791}

@@ -793,7 +793,7 @@ VAL idris_b32T8(VM *vm, VAL a) {

793793VAL idris_b32T16(VM *vm, VAL a) {

794794 uint32_t A = a->info.bits32;

795795 VAL cl = allocate(sizeof(Closure), 0);

796− SETTY(cl, BITS16);

796+ SETTY(cl, CT_BITS16);

797797 cl->info.bits16 = (uint16_t) A;

798798 return cl;

799799}

@@ -801,7 +801,7 @@ VAL idris_b32T16(VM *vm, VAL a) {

801801VAL idris_b64T8(VM *vm, VAL a) {

802802 uint64_t A = a->info.bits64;

803803 VAL cl = allocate(sizeof(Closure), 0);

804− SETTY(cl, BITS8);

804+ SETTY(cl, CT_BITS8);

805805 cl->info.bits8 = (uint8_t) A;

806806 return cl;

807807}

@@ -809,7 +809,7 @@ VAL idris_b64T8(VM *vm, VAL a) {

809809VAL idris_b64T16(VM *vm, VAL a) {

810810 uint64_t A = a->info.bits64;

811811 VAL cl = allocate(sizeof(Closure), 0);

812− SETTY(cl, BITS16);

812+ SETTY(cl, CT_BITS16);

813813 cl->info.bits16 = (uint16_t) A;

814814 return cl;

815815}

@@ -817,8 +817,43 @@ VAL idris_b64T16(VM *vm, VAL a) {

817817VAL idris_b64T32(VM *vm, VAL a) {

818818 uint64_t A = a->info.bits64;

819819 VAL cl = allocate(sizeof(Closure), 0);

820− SETTY(cl, BITS32);

820+ SETTY(cl, CT_BITS32);

821821 cl->info.bits32 = (uint32_t) 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_gc.c+24−17

@@ -10,7 +10,7 @@ VAL copy(VM* vm, VAL x) {

1010 return x;

1111 }

1212 switch(GETTY(x)) {

13− case CON:

13+ case CT_CON:

1414 ar = CARITY(x);

1515 if (ar == 0 && CTAG(x) < 256) {

1616 return x;

@@ -21,49 +21,53 @@ VAL copy(VM* vm, VAL x) {

2121 }

2222 }

2323 break;

24− case FLOAT:

24+ case CT_FLOAT:

2525 cl = MKFLOATc(vm, x->info.f);

2626 break;

27− case STRING:

27+ case CT_STRING:

2828 cl = MKSTRc(vm, x->info.str);

2929 break;

30− case STROFFSET:

30+ case CT_STROFFSET:

3131 cl = MKSTROFFc(vm, x->info.str_offset);

3232 break;

33− case BIGINT:

33+ case CT_BIGINT:

3434 cl = MKBIGMc(vm, x->info.ptr);

3535 break;

36− case PTR:

36+ case CT_PTR:

3737 cl = MKPTRc(vm, x->info.ptr);

3838 break;

39− case MANAGEDPTR:

39+ case CT_MANAGEDPTR:

4040 cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);

4141 break;

42− case BITS8:

42+ case CT_BITS8:

4343 cl = idris_b8CopyForGC(vm, x);

4444 break;

45− case BITS16:

45+ case CT_BITS16:

4646 cl = idris_b16CopyForGC(vm, x);

4747 break;

48− case BITS32:

48+ case CT_BITS32:

4949 cl = idris_b32CopyForGC(vm, x);

5050 break;

51− case BITS64:

51+ case CT_BITS64:

5252 cl = idris_b64CopyForGC(vm, x);

5353 break;

54− case FWD:

54+ case CT_FWD:

5555 return x->info.ptr;

56− case RAWDATA:

56+ case CT_RAWDATA:

5757 {

5858 size_t size = x->info.size + sizeof(Closure);

5959 cl = allocate(size, 0);

6060 memcpy(cl, x, size);

6161 }

6262 break;

63+ case CT_CDATA:

64+ cl = MKCDATAc(vm, x->info.c_heap_item);

65+ c_heap_mark_item(x->info.c_heap_item);

66+ break;

6367 default:

6468 break;

6569 }

66− SETTY(x, FWD);

70+ SETTY(x, CT_FWD);

6771 x->info.ptr = cl;

6872 return cl;

6973}

@@ -76,16 +80,16 @@ void cheney(VM *vm) {

7680 while(scan < vm->heap.next) {

7781 size_t inc = *((size_t*)scan);

7882 VAL heap_item = (VAL)(scan+sizeof(size_t));

79− // If it's a CON or STROFFSET, copy its arguments

83+ // If it's a CT_CON or CT_STROFFSET, copy its arguments

8084 switch(GETTY(heap_item)) {

81− case CON:

85+ case CT_CON:

8286 ar = ARITY(heap_item);

8387 for(i = 0; i < ar; ++i) {

8488 VAL newptr = copy(vm, heap_item->info.c.args[i]);

8589 heap_item->info.c.args[i] = newptr;

8690 }

8791 break;

88− case STROFFSET:

92+ case CT_STROFFSET:

8993 heap_item->info.str_offset->str

9094 = copy(vm, heap_item->info.str_offset->str);

9195 break;

@@ -133,6 +137,9 @@ void idris_gc(VM* vm) {

133137 vm->heap.size += vm->heap.growth;

134138 }

135139

140+ // finally, sweep the C heap

141+ c_heap_sweep(&vm->c_heap);

142+

136143 STATS_LEAVE_GC(vm->stats, vm->heap.size, vm->heap.next - vm->heap.heap)

137144 HEAP_CHECK(vm)

138145}

rts/idris_gmp.c+31−18

@@ -33,7 +33,7 @@ VAL MKBIGC(VM* vm, char* val) {

3333 mpz_init(*bigint);

3434 mpz_set_str(*bigint, val, 10);

3535

36− SETTY(cl, BIGINT);

36+ SETTY(cl, CT_BIGINT);

3737 cl -> info.ptr = (void*)bigint;

3838

3939 return cl;

@@ -50,7 +50,7 @@ VAL MKBIGM(VM* vm, void* big) {

5050 mpz_init(*bigint);

5151 mpz_set(*bigint, *((mpz_t*)big));

5252

53− SETTY(cl, BIGINT);

53+ SETTY(cl, CT_BIGINT);

5454 cl -> info.ptr = (void*)bigint;

5555

5656 return cl;

@@ -66,7 +66,7 @@ VAL MKBIGMc(VM* vm, void* big) {

6666

6767 mpz_init_set(*bigint, *((mpz_t*)big));

6868

69− SETTY(cl, BIGINT);

69+ SETTY(cl, CT_BIGINT);

7070 cl -> info.ptr = (void*)bigint;

7171

7272 return cl;

@@ -82,7 +82,7 @@ VAL MKBIGUI(VM* vm, unsigned long val) {

8282

8383 mpz_init_set_ui(*bigint, val);

8484

85− SETTY(cl, BIGINT);

85+ SETTY(cl, CT_BIGINT);

8686 cl -> info.ptr = (void*)bigint;

8787

8888 return cl;

@@ -98,7 +98,7 @@ VAL MKBIGSI(VM* vm, signed long val) {

9898

9999 mpz_init_set_si(*bigint, val);

100100

101− SETTY(cl, BIGINT);

101+ SETTY(cl, CT_BIGINT);

102102 cl -> info.ptr = (void*)bigint;

103103

104104 return cl;

@@ -116,14 +116,14 @@ VAL GETBIG(VM * vm, VAL x) {

116116 mpz_init(*bigint);

117117 mpz_set_si(*bigint, GETINT(x));

118118

119− SETTY(cl, BIGINT);

119+ SETTY(cl, CT_BIGINT);

120120 cl -> info.ptr = (void*)bigint;

121121

122122 return cl;

123123 } else {

124124 idris_doneAlloc();

125125 switch(GETTY(x)) {

126− case FWD:

126+ case CT_FWD:

127127 return GETBIG(vm, x->info.ptr);

128128 default:

129129 return x;

@@ -139,7 +139,7 @@ VAL bigAdd(VM* vm, VAL x, VAL y) {

139139 idris_doneAlloc();

140140 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

141141 mpz_add(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

142− SETTY(cl, BIGINT);

142+ SETTY(cl, CT_BIGINT);

143143 cl -> info.ptr = (void*)bigint;

144144 return cl;

145145}

@@ -152,7 +152,7 @@ VAL bigSub(VM* vm, VAL x, VAL y) {

152152 idris_doneAlloc();

153153 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

154154 mpz_sub(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

155− SETTY(cl, BIGINT);

155+ SETTY(cl, CT_BIGINT);

156156 cl -> info.ptr = (void*)bigint;

157157 return cl;

158158}

@@ -165,7 +165,7 @@ VAL bigMul(VM* vm, VAL x, VAL y) {

165165 idris_doneAlloc();

166166 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

167167 mpz_mul(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

168− SETTY(cl, BIGINT);

168+ SETTY(cl, CT_BIGINT);

169169 cl -> info.ptr = (void*)bigint;

170170 return cl;

171171}

@@ -178,7 +178,7 @@ VAL bigDiv(VM* vm, VAL x, VAL y) {

178178 idris_doneAlloc();

179179 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

180180 mpz_tdiv_q(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

181− SETTY(cl, BIGINT);

181+ SETTY(cl, CT_BIGINT);

182182 cl -> info.ptr = (void*)bigint;

183183 return cl;

184184}

@@ -191,7 +191,7 @@ VAL bigMod(VM* vm, VAL x, VAL y) {

191191 idris_doneAlloc();

192192 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

193193 mpz_mod(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

194− SETTY(cl, BIGINT);

194+ SETTY(cl, CT_BIGINT);

195195 cl -> info.ptr = (void*)bigint;

196196 return cl;

197197}

@@ -204,7 +204,7 @@ VAL bigAnd(VM* vm, VAL x, VAL y) {

204204 idris_doneAlloc();

205205 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

206206 mpz_and(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

207− SETTY(cl, BIGINT);

207+ SETTY(cl, CT_BIGINT);

208208 cl -> info.ptr = (void*)bigint;

209209 return cl;

210210}

@@ -217,7 +217,7 @@ VAL bigOr(VM* vm, VAL x, VAL y) {

217217 idris_doneAlloc();

218218 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

219219 mpz_ior(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

220− SETTY(cl, BIGINT);

220+ SETTY(cl, CT_BIGINT);

221221 cl -> info.ptr = (void*)bigint;

222222 return cl;

223223}

@@ -230,7 +230,7 @@ VAL bigShiftLeft(VM* vm, VAL x, VAL y) {

230230 idris_doneAlloc();

231231 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

232232 mpz_mul_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));

233− SETTY(cl, BIGINT);

233+ SETTY(cl, CT_BIGINT);

234234 cl -> info.ptr = (void*)bigint;

235235 return cl;

236236}

@@ -244,7 +244,7 @@ VAL bigLShiftRight(VM* vm, VAL x, VAL y) {

244244 idris_doneAlloc();

245245 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

246246 mpz_fdiv_q_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));

247− SETTY(cl, BIGINT);

247+ SETTY(cl, CT_BIGINT);

248248 cl -> info.ptr = (void*)bigint;

249249 return cl;

250250}

@@ -257,7 +257,7 @@ VAL bigAShiftRight(VM* vm, VAL x, VAL y) {

257257 idris_doneAlloc();

258258 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

259259 mpz_fdiv_q_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));

260− SETTY(cl, BIGINT);

260+ SETTY(cl, CT_BIGINT);

261261 cl -> info.ptr = (void*)bigint;

262262 return cl;

263263}

@@ -473,7 +473,7 @@ VAL idris_castFloatBig(VM* vm, VAL f) {

473473

474474 mpz_init_set_d(*bigint, val);

475475

476− SETTY(cl, BIGINT);

476+ SETTY(cl, CT_BIGINT);

477477 cl -> info.ptr = (void*)bigint;

478478

479479 return cl;

@@ -488,3 +488,16 @@ VAL idris_castBigStr(VM* vm, VAL i) {

488488 return MKSTR(vm, str);

489489}

490490

491+// Get 64 bits out of a big int with special handling

492+// for systems that have 32-bit longs which needs two limbs to

493+// fill that.

494+uint64_t idris_truncBigB64(const mpz_t bi) {

495+ if (sizeof(mp_limb_t) == 8) {

496+ return mpz_get_ui(bi);

497+ }

498+ int64_t out = mpz_get_ui(bi);

499+ if (bi->_mp_size > 1 ) {

500+ out |= (uint64_t)bi->_mp_d[1] << 32;

501+ }

502+ return out;

503+}

rts/idris_gmp.h+2

@@ -43,6 +43,8 @@ VAL idris_bigOr(VM* vm, VAL x, VAL y);

4343VAL idris_bigShiftLeft(VM* vm, VAL x, VAL y);

4444VAL idris_bigShiftRight(VM* vm, VAL x, VAL y);

4545

46+uint64_t idris_truncBigB64(const mpz_t bi);

47+

4648#define GETMPZ(x) *((mpz_t*)((x)->info.ptr))

4749

4850#endif

rts/idris_heap.c+105−5

@@ -1,12 +1,112 @@

11#include "idris_heap.h"

22#include "idris_rts.h"

3+#include "idris_gc.h"

34

45#include <stdlib.h>

56#include <stddef.h>

67#include <stdio.h>

8+#include <assert.h>

79

10+static void c_heap_free_item(CHeap * heap, CHeapItem * item)

11+{

12+ assert(item->size <= heap->size);

13+ heap->size -= item->size;

14+

15+ // fix links

16+ if (item->next != NULL)

17+ {

18+ item->next->prev_next = item->prev_next;

19+ }

20+ *(item->prev_next) = item->next;

21+

22+ // free payload

23+ item->finalizer(item->data);

24+

25+ // free item struct

26+ free(item);

27+}

28+

29+CHeapItem * c_heap_create_item(void * data, size_t size, CDataFinalizer * finalizer)

30+{

31+ CHeapItem * item = (CHeapItem *) malloc(sizeof(CHeapItem));

32+

33+ item->data = data;

34+ item->size = size;

35+ item->finalizer = finalizer;

36+ item->is_used = false;

37+ item->next = NULL;

38+ item->prev_next = NULL;

39+

40+ return item;

41+}

42+

43+void c_heap_insert_if_needed(VM * vm, CHeap * heap, CHeapItem * item)

44+{

45+ if (item->prev_next != NULL) return; // already inserted

46+

47+ if (heap->first != NULL)

48+ {

49+ heap->first->prev_next = &item->next;

50+ }

51+

52+ item->prev_next = &heap->first;

53+ item->next = heap->first;

54+

55+ heap->first = item;

56+

57+ // at this point, links are done; let's calculate sizes

58+

59+ heap->size += item->size;

60+ if (heap->size >= heap->gc_trigger_size)

61+ {

62+ item->is_used = true; // don't collect what we're inserting

63+ idris_gc(vm);

64+ }

65+}

66+

67+void c_heap_mark_item(CHeapItem * item)

68+{

69+ item->is_used = true;

70+}

71+

72+void c_heap_sweep(CHeap * heap)

73+{

74+ CHeapItem * p = heap->first;

75+ while (p != NULL)

76+ {

77+ if (p->is_used)

78+ {

79+ p->is_used = false;

80+ p = p->next;

81+ }

82+ else

83+ {

84+ CHeapItem * unused_item = p;

85+ p = p->next;

86+

87+ c_heap_free_item(heap, unused_item);

88+ }

89+ }

90+

91+ heap->gc_trigger_size = C_HEAP_GC_TRIGGER_SIZE(heap->size);

92+}

93+

94+void c_heap_init(CHeap * heap)

95+{

96+ heap->first = NULL;

97+ heap->size = 0;

98+ heap->gc_trigger_size = C_HEAP_GC_TRIGGER_SIZE(heap->size);

99+}

100+

101+void c_heap_destroy(CHeap * heap)

102+{

103+ while (heap->first != NULL)

104+ {

105+ c_heap_free_item(heap, heap->first); // will update heap->first via the backward link

106+ }

107+}

8108

9−/* Used for initializing the heap. */

109+/* Used for initializing the FP heap. */

10110void alloc_heap(Heap * h, size_t heap_size, size_t growth, char * old)

11111{

12112 char * mem = malloc(heap_size);

@@ -86,7 +186,7 @@ void heap_check_pointers(Heap * heap) {

86186 VAL heap_item = (VAL)(scan + sizeof(size_t));

87187

88188 switch(GETTY(heap_item)) {

89− case CON:

189+ case CT_CON:

90190 {

91191 int ar = ARITY(heap_item);

92192 int i = 0;

@@ -107,7 +207,7 @@ void heap_check_pointers(Heap * heap) {

107207 if (!(ptr < heap_item)) {

108208 fprintf(stderr,

109209 "RTS ERROR: heap unidirectionality broken:" \

110− "<CON %p> <FIELD %p>\n",

210+ "<CT_CON %p> <FIELD %p>\n",

111211 heap_item, ptr);

112212 exit(EXIT_FAILURE);

113213 }

@@ -116,9 +216,9 @@ void heap_check_pointers(Heap * heap) {

116216 }

117217 break;

118218 }

119− case FWD:

219+ case CT_FWD:

120220 // Check for artifacts after cheney gc.

121− fprintf(stderr, "RTS ERROR: FWD in working heap.\n");

221+ fprintf(stderr, "RTS ERROR: CT_FWD in working heap.\n");

122222 exit(EXIT_FAILURE);

123223 break;

124224 default:

rts/idris_heap.h+82

@@ -1,8 +1,90 @@

11#ifndef _IDRIS_HEAP_H

22#define _IDRIS_HEAP_H

33

4+#include <stdbool.h>

45#include <stddef.h>

56

7+/* *** C heap ***

8+ * Objects with finalizers. Mark&sweep-collected.

9+ *

10+ * The C heap is implemented as a doubly linked list

11+ * of pointers coupled with their finalizers.

12+ */

13+

14+struct VM;

15+

16+#define C_HEAP_GC_TRIGGER_SIZE(heap_size) \

17+ (heap_size < 2048 \

18+ ? 4096 \

19+ : 2 * heap_size \

20+ )

21+

22+typedef void CDataFinalizer(void *);

23+

24+typedef struct CHeapItem {

25+ /// Payload.

26+ void * data;

27+

28+ /// Size of the item, in bytes.

29+ /// This does not have to be a precise size. It is used to assess

30+ /// whether the heap needs garbage collection.

31+ size_t size;

32+

33+ /// Finalizer that will be called on the payload pointer.

34+ /// Its job is to deallocate all associated resources,

35+ /// including the memory pointed to by `data` (if any).

36+ CDataFinalizer * finalizer;

37+

38+ /// The mark bit set by the FP heap traversal,

39+ /// cleared by C heap sweep.

40+ bool is_used;

41+

42+ /// Next item in the C heap.

43+ struct CHeapItem * next;

44+

45+ /// Pointer to the previous next-pointer.

46+ struct CHeapItem ** prev_next;

47+} CHeapItem;

48+

49+typedef struct CHeap {

50+ /// The first item in the heap. NULL if the heap is empty.

51+ CHeapItem * first;

52+

53+ /// Total size of the heap. (Sum of sizes of items.)

54+ /// This may not be a precise size since individual items'

55+ /// sizes may be just estimates.

56+ size_t size;

57+

58+ /// When heap reaches this size, GC will be triggered.

59+ size_t gc_trigger_size;

60+} CHeap;

61+

62+/// Create a C heap.

63+void c_heap_init(CHeap * c_heap);

64+

65+/// Destroy the given C heap. Will not deallocate the given pointer.

66+/// Will call finalizers & deallocate all blocks in the heap.

67+void c_heap_destroy(CHeap * c_heap);

68+

69+/// Insert the given item into the heap if it's not there yet.

70+/// The VM pointer is needed because this operation may trigger GC.

71+void c_heap_insert_if_needed(struct VM * vm, CHeap * c_heap, CHeapItem * item);

72+

73+/// Mark the given item as used.

74+void c_heap_mark_item(CHeapItem * item);

75+

76+/// Sweep the C heap, finalizing and freeing unused blocks.

77+void c_heap_sweep(CHeap * c_heap);

78+

79+/// Create a C heap item from its payload, size estimate, and finalizer.

80+/// The size does not have to be precise but it should roughly reflect

81+/// how big the item is for GC to work effectively.

82+CHeapItem * c_heap_create_item(void * data, size_t size, CDataFinalizer * finalizer);

83+

84+/* *** Idris heap **

85+ * Objects without finalizers. Cheney-collected.

86+ */

87+

688typedef struct {

789 char* next; // Next allocated chunk. Should always (heap <= next < end).

890 char* heap; // Point to bottom of heap

rts/idris_rts.c+126−50

@@ -35,6 +35,8 @@ VM* init_vm(int stack_size, size_t heap_size,

3535

3636 alloc_heap(&(vm->heap), heap_size, heap_size, NULL);

3737

38+ c_heap_init(&vm->c_heap);

39+

3840 vm->ret = NULL;

3941 vm->reg1 = NULL;

4042#ifdef HAS_PTHREAD

@@ -78,13 +80,29 @@ VM* idris_vm() {

7880 return vm;

7981}

8082

83+VM* get_vm(void) {

84+#ifdef HAS_PTHREAD

85+ init_threadkeys();

86+ return pthread_getspecific(vm_key);

87+#else

88+ return global_vm;

89+#endif

90+}

91+

8192void close_vm(VM* vm) {

8293 terminate(vm);

8394}

8495

85−void init_threadkeys() {

8696#ifdef HAS_PTHREAD

97+void create_key() {

8798 pthread_key_create(&vm_key, (void*)free_key);

99+}

100+#endif

101+

102+void init_threadkeys() {

103+#ifdef HAS_PTHREAD

104+ static pthread_once_t key_once = PTHREAD_ONCE_INIT;

105+ pthread_once(&key_once, create_key);

88106#endif

89107}

90108

@@ -108,12 +126,13 @@ Stats terminate(VM* vm) {

108126#endif

109127 free(vm->valstack);

110128 free_heap(&(vm->heap));

129+ c_heap_destroy(&(vm->c_heap));

111130#ifdef HAS_PTHREAD

112131 pthread_mutex_destroy(&(vm -> inbox_lock));

113132 pthread_mutex_destroy(&(vm -> inbox_block));

114133 pthread_cond_destroy(&(vm -> inbox_waiting));

115134#endif

116− // free(vm);

135+ // free(vm);

117136 // Set the VM as inactive, so that if any message gets sent to it

118137 // it will not get there, rather than crash the entire system.

119138 // (TODO: We really need to be cleverer than this if we're going to

@@ -124,6 +143,17 @@ Stats terminate(VM* vm) {

124143 return stats;

125144}

126145

146+CData cdata_allocate(size_t size, CDataFinalizer finalizer)

147+{

148+ void * data = (void *) malloc(size);

149+ return cdata_manage(data, size, finalizer);

150+}

151+

152+CData cdata_manage(void * data, size_t size, CDataFinalizer finalizer)

153+{

154+ return c_heap_create_item(data, size, finalizer);

155+}

156+

127157void idris_requireAlloc(size_t size) {

128158#ifdef HAS_PTHREAD

129159 VM* vm = pthread_getspecific(vm_key);

@@ -158,7 +188,7 @@ int space(VM* vm, size_t size) {

158188

159189void* idris_alloc(size_t size) {

160190 Closure* cl = (Closure*) allocate(sizeof(Closure)+size, 0);

161− SETTY(cl, RAWDATA);

191+ SETTY(cl, CT_RAWDATA);

162192 cl->info.size = size;

163193 return (void*)cl+sizeof(Closure);

164194}

@@ -223,7 +253,7 @@ void* allocate(size_t size, int outerlock) {

223253void* allocCon(VM* vm, int arity, int outer) {

224254 Closure* cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*arity,

225255 outer);

226− SETTY(cl, CON);

256+ SETTY(cl, CT_CON);

227257

228258 cl -> info.c.arity = arity;

229259// cl -> info.c.tag = 42424242;

@@ -234,7 +264,7 @@ void* allocCon(VM* vm, int arity, int outer) {

234264

235265VAL MKFLOAT(VM* vm, double val) {

236266 Closure* cl = allocate(sizeof(Closure), 0);

237− SETTY(cl, FLOAT);

267+ SETTY(cl, CT_FLOAT);

238268 cl -> info.f = val;

239269 return cl;

240270}

@@ -248,7 +278,7 @@ VAL MKSTR(VM* vm, const char* str) {

248278 }

249279 Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +

250280 sizeof(char)*len, 0);

251− SETTY(cl, STRING);

281+ SETTY(cl, CT_STRING);

252282 cl -> info.str = (char*)cl + sizeof(Closure);

253283 if (str == NULL) {

254284 cl->info.str = NULL;

@@ -264,9 +294,25 @@ char* GETSTROFF(VAL stroff) {

264294 return (root->str->info.str + root->offset);

265295}

266296

297+VAL MKCDATA(VM* vm, CHeapItem * item) {

298+ c_heap_insert_if_needed(vm, &vm->c_heap, item);

299+ Closure* cl = allocate(sizeof(Closure), 0);

300+ SETTY(cl, CT_CDATA);

301+ cl->info.c_heap_item = item;

302+ return cl;

303+}

304+

305+VAL MKCDATAc(VM* vm, CHeapItem * item) {

306+ c_heap_insert_if_needed(vm, &vm->c_heap, item);

307+ Closure* cl = allocate(sizeof(Closure), 1);

308+ SETTY(cl, CT_CDATA);

309+ cl->info.c_heap_item = item;

310+ return cl;

311+}

312+

267313VAL MKPTR(VM* vm, void* ptr) {

268314 Closure* cl = allocate(sizeof(Closure), 0);

269− SETTY(cl, PTR);

315+ SETTY(cl, CT_PTR);

270316 cl -> info.ptr = ptr;

271317 return cl;

272318}

@@ -274,7 +320,7 @@ VAL MKPTR(VM* vm, void* ptr) {

274320VAL MKMPTR(VM* vm, void* ptr, size_t size) {

275321 Closure* cl = allocate(sizeof(Closure) +

276322 sizeof(ManagedPtr) + size, 0);

277− SETTY(cl, MANAGEDPTR);

323+ SETTY(cl, CT_MANAGEDPTR);

278324 cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

279325 cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

280326 memcpy(cl->info.mptr->data, ptr, size);

@@ -284,7 +330,7 @@ VAL MKMPTR(VM* vm, void* ptr, size_t size) {

284330

285331VAL MKFLOATc(VM* vm, double val) {

286332 Closure* cl = allocate(sizeof(Closure), 1);

287− SETTY(cl, FLOAT);

333+ SETTY(cl, CT_FLOAT);

288334 cl -> info.f = val;

289335 return cl;

290336}

@@ -292,7 +338,7 @@ VAL MKFLOATc(VM* vm, double val) {

292338VAL MKSTRc(VM* vm, char* str) {

293339 Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +

294340 sizeof(char)*strlen(str)+1, 1);

295− SETTY(cl, STRING);

341+ SETTY(cl, CT_STRING);

296342 cl -> info.str = (char*)cl + sizeof(Closure);

297343

298344 strcpy(cl -> info.str, str);

@@ -301,7 +347,7 @@ VAL MKSTRc(VM* vm, char* str) {

301347

302348VAL MKPTRc(VM* vm, void* ptr) {

303349 Closure* cl = allocate(sizeof(Closure), 1);

304− SETTY(cl, PTR);

350+ SETTY(cl, CT_PTR);

305351 cl -> info.ptr = ptr;

306352 return cl;

307353}

@@ -309,7 +355,7 @@ VAL MKPTRc(VM* vm, void* ptr) {

309355VAL MKMPTRc(VM* vm, void* ptr, size_t size) {

310356 Closure* cl = allocate(sizeof(Closure) +

311357 sizeof(ManagedPtr) + size, 1);

312− SETTY(cl, MANAGEDPTR);

358+ SETTY(cl, CT_MANAGEDPTR);

313359 cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

314360 cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

315361 memcpy(cl->info.mptr->data, ptr, size);

@@ -319,28 +365,28 @@ VAL MKMPTRc(VM* vm, void* ptr, size_t size) {

319365

320366VAL MKB8(VM* vm, uint8_t bits8) {

321367 Closure* cl = allocate(sizeof(Closure), 1);

322− SETTY(cl, BITS8);

368+ SETTY(cl, CT_BITS8);

323369 cl -> info.bits8 = bits8;

324370 return cl;

325371}

326372

327373VAL MKB16(VM* vm, uint16_t bits16) {

328374 Closure* cl = allocate(sizeof(Closure), 1);

329− SETTY(cl, BITS16);

375+ SETTY(cl, CT_BITS16);

330376 cl -> info.bits16 = bits16;

331377 return cl;

332378}

333379

334380VAL MKB32(VM* vm, uint32_t bits32) {

335381 Closure* cl = allocate(sizeof(Closure), 1);

336− SETTY(cl, BITS32);

382+ SETTY(cl, CT_BITS32);

337383 cl -> info.bits32 = bits32;

338384 return cl;

339385}

340386

341387VAL MKB64(VM* vm, uint64_t bits64) {

342388 Closure* cl = allocate(sizeof(Closure), 1);

343− SETTY(cl, BITS64);

389+ SETTY(cl, CT_BITS64);

344390 cl -> info.bits64 = bits64;

345391 return cl;

346392}

@@ -382,18 +428,18 @@ void dumpVal(VAL v) {

382428 return;

383429 }

384430 switch(GETTY(v)) {

385− case CON:

431+ case CT_CON:

386432 printf("%d[", TAG(v));

387433 for(i = 0; i < ARITY(v); ++i) {

388434 dumpVal(v->info.c.args[i]);

389435 }

390436 printf("] ");

391437 break;

392− case STRING:

438+ case CT_STRING:

393439 printf("STR[%s]", v->info.str);

394440 break;

395− case FWD:

396− printf("FWD ");

441+ case CT_FWD:

442+ printf("CT_FWD ");

397443 dumpVal((VAL)(v->info.ptr));

398444 break;

399445 default:

@@ -414,6 +460,36 @@ void idris_poke(void* ptr, i_int offset, uint8_t data) {

414460 *(((uint8_t*)ptr) + offset) = data;

415461}

416462

463+

464+VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset) {

465+ void** addr = GETPTR(ptr) + GETINT(offset);

466+ return MKPTR(vm, *addr);

467+}

468+

469+VAL idris_pokePtr(VAL ptr, VAL offset, VAL data) {

470+ void** addr = GETPTR(ptr) + GETINT(offset);

471+ *addr = GETPTR(data);

472+ return MKINT(0);

473+}

474+

475+VAL idris_peekDouble(VM* vm, VAL ptr, VAL offset) {

476+ return MKFLOAT(vm, *(double*)(GETPTR(ptr) + GETINT(offset)));

477+}

478+

479+VAL idris_pokeDouble(VAL ptr, VAL offset, VAL data) {

480+ *(double*)(GETPTR(ptr) + GETINT(offset)) = GETFLOAT(data);

481+ return MKINT(0);

482+}

483+

484+VAL idris_peekSingle(VM* vm, VAL ptr, VAL offset) {

485+ return MKFLOAT(vm, *(float*)(GETPTR(ptr) + GETINT(offset)));

486+}

487+

488+VAL idris_pokeSingle(VAL ptr, VAL offset, VAL data) {

489+ *(float*)(GETPTR(ptr) + GETINT(offset)) = GETFLOAT(data);

490+ return MKINT(0);

491+}

492+

417493void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {

418494 memmove(dest + dest_offset, src + src_offset, size);

419495}

@@ -421,7 +497,7 @@ void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i

421497VAL idris_castIntStr(VM* vm, VAL i) {

422498 int x = (int) GETINT(i);

423499 Closure* cl = allocate(sizeof(Closure) + sizeof(char)*16, 0);

424− SETTY(cl, STRING);

500+ SETTY(cl, CT_STRING);

425501 cl -> info.str = (char*)cl + sizeof(Closure);

426502 sprintf(cl -> info.str, "%d", x);

427503 return cl;

@@ -432,25 +508,25 @@ VAL idris_castBitsStr(VM* vm, VAL i) {

432508 ClosureType ty = i->ty;

433509

434510 switch (ty) {

435− case BITS8:

511+ case CT_BITS8:

436512 // max length 8 bit unsigned int str 3 chars (256)

437513 cl = allocate(sizeof(Closure) + sizeof(char)*4, 0);

438514 cl->info.str = (char*)cl + sizeof(Closure);

439515 sprintf(cl->info.str, "%" PRIu8, (uint8_t)i->info.bits8);

440516 break;

441− case BITS16:

517+ case CT_BITS16:

442518 // max length 16 bit unsigned int str 5 chars (65,535)

443519 cl = allocate(sizeof(Closure) + sizeof(char)*6, 0);

444520 cl->info.str = (char*)cl + sizeof(Closure);

445521 sprintf(cl->info.str, "%" PRIu16, (uint16_t)i->info.bits16);

446522 break;

447− case BITS32:

523+ case CT_BITS32:

448524 // max length 32 bit unsigned int str 10 chars (4,294,967,295)

449525 cl = allocate(sizeof(Closure) + sizeof(char)*11, 0);

450526 cl->info.str = (char*)cl + sizeof(Closure);

451527 sprintf(cl->info.str, "%" PRIu32, (uint32_t)i->info.bits32);

452528 break;

453− case BITS64:

529+ case CT_BITS64:

454530 // max length 64 bit unsigned int str 20 chars (18,446,744,073,709,551,615)

455531 cl = allocate(sizeof(Closure) + sizeof(char)*21, 0);

456532 cl->info.str = (char*)cl + sizeof(Closure);

@@ -461,7 +537,7 @@ VAL idris_castBitsStr(VM* vm, VAL i) {

461537 exit(EXIT_FAILURE);

462538 }

463539

464− SETTY(cl, STRING);

540+ SETTY(cl, CT_STRING);

465541 return cl;

466542}

467543

@@ -476,7 +552,7 @@ VAL idris_castStrInt(VM* vm, VAL i) {

476552

477553VAL idris_castFloatStr(VM* vm, VAL i) {

478554 Closure* cl = allocate(sizeof(Closure) + sizeof(char)*32, 0);

479− SETTY(cl, STRING);

555+ SETTY(cl, CT_STRING);

480556 cl -> info.str = (char*)cl + sizeof(Closure);

481557 snprintf(cl -> info.str, 32, "%.16g", GETFLOAT(i));

482558 return cl;

@@ -492,7 +568,7 @@ VAL idris_concat(VM* vm, VAL l, VAL r) {

492568 // dumpVal(l);

493569 // printf("\n");

494570 Closure* cl = allocate(sizeof(Closure) + strlen(ls) + strlen(rs) + 1, 0);

495− SETTY(cl, STRING);

571+ SETTY(cl, CT_STRING);

496572 cl -> info.str = (char*)cl + sizeof(Closure);

497573 strcpy(cl -> info.str, ls);

498574 strcat(cl -> info.str, rs);

@@ -538,7 +614,7 @@ VAL idris_strHead(VM* vm, VAL str) {

538614

539615VAL MKSTROFFc(VM* vm, StrOffset* off) {

540616 Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 1);

541− SETTY(cl, STROFFSET);

617+ SETTY(cl, CT_STROFFSET);

542618 cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure));

543619

544620 cl->info.str_offset->str = off->str;

@@ -552,7 +628,7 @@ VAL idris_strTail(VM* vm, VAL str) {

552628 // gc moves str

553629 if (space(vm, sizeof(Closure) + sizeof(StrOffset))) {

554630 Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 0);

555− SETTY(cl, STROFFSET);

631+ SETTY(cl, CT_STROFFSET);

556632 cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure));

557633

558634 int offset = 0;

@@ -580,7 +656,7 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) {

580656 if ((xval & 0x80) == 0) { // ASCII char

581657 Closure* cl = allocate(sizeof(Closure) +

582658 strlen(xstr) + 2, 0);

583− SETTY(cl, STRING);

659+ SETTY(cl, CT_STRING);

584660 cl -> info.str = (char*)cl + sizeof(Closure);

585661 cl -> info.str[0] = (char)(GETINT(x));

586662 strcpy(cl -> info.str+1, xstr);

@@ -588,7 +664,7 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) {

588664 } else {

589665 char *init = idris_utf8_fromChar(xval);

590666 Closure* cl = allocate(sizeof(Closure) + strlen(init) + strlen(xstr) + 1, 0);

591− SETTY(cl, STRING);

667+ SETTY(cl, CT_STRING);

592668 cl -> info.str = (char*)cl + sizeof(Closure);

593669 strcpy(cl -> info.str, init);

594670 strcat(cl -> info.str, xstr);

@@ -606,7 +682,7 @@ VAL idris_substr(VM* vm, VAL offset, VAL length, VAL str) {

606682 char *start = idris_utf8_advance(GETSTR(str), GETINT(offset));

607683 char *end = idris_utf8_advance(start, GETINT(length));

608684 Closure* newstr = allocate(sizeof(Closure) + (end - start) +1, 0);

609− SETTY(newstr, STRING);

685+ SETTY(newstr, CT_STRING);

610686 newstr -> info.str = (char*)newstr + sizeof(Closure);

611687 memcpy(newstr -> info.str, start, end - start);

612688 *(newstr -> info.str + (end - start) + 1) = '\0';

@@ -617,7 +693,7 @@ VAL idris_strRev(VM* vm, VAL str) {

617693 char *xstr = GETSTR(str);

618694 Closure* cl = allocate(sizeof(Closure) +

619695 strlen(xstr) + 1, 0);

620− SETTY(cl, STRING);

696+ SETTY(cl, CT_STRING);

621697 cl->info.str = (char*)cl + sizeof(Closure);

622698 idris_utf8_rev(xstr, cl->info.str);

623699 return cl;

@@ -700,7 +776,7 @@ VAL doCopyTo(VM* vm, VAL x) {

700776 return x;

701777 }

702778 switch(GETTY(x)) {

703− case CON:

779+ case CT_CON:

704780 ar = CARITY(x);

705781 if (ar == 0 && CTAG(x) < 256) { // globally allocated

706782 cl = x;

@@ -714,34 +790,34 @@ VAL doCopyTo(VM* vm, VAL x) {

714790 }

715791 }

716792 break;

717− case FLOAT:

793+ case CT_FLOAT:

718794 cl = MKFLOATc(vm, x->info.f);

719795 break;

720− case STRING:

796+ case CT_STRING:

721797 cl = MKSTRc(vm, x->info.str);

722798 break;

723− case BIGINT:

799+ case CT_BIGINT:

724800 cl = MKBIGMc(vm, x->info.ptr);

725801 break;

726− case PTR:

802+ case CT_PTR:

727803 cl = MKPTRc(vm, x->info.ptr);

728804 break;

729− case MANAGEDPTR:

805+ case CT_MANAGEDPTR:

730806 cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);

731807 break;

732− case BITS8:

808+ case CT_BITS8:

733809 cl = idris_b8CopyForGC(vm, x);

734810 break;

735− case BITS16:

811+ case CT_BITS16:

736812 cl = idris_b16CopyForGC(vm, x);

737813 break;

738− case BITS32:

814+ case CT_BITS32:

739815 cl = idris_b32CopyForGC(vm, x);

740816 break;

741− case BITS64:

817+ case CT_BITS64:

742818 cl = idris_b64CopyForGC(vm, x);

743819 break;

744− case RAWDATA:

820+ case CT_RAWDATA:

745821 {

746822 size_t size = x->info.size + sizeof(Closure);

747823 cl = allocate(size, 0);

@@ -789,12 +865,12 @@ int idris_sendMessage(VM* sender, VM* dest, VAL msg) {

789865 }

790866

791867 pthread_mutex_lock(&(dest->inbox_lock));

792−

868+

793869 if (dest->inbox_write >= dest->inbox_end) {

794870 // FIXME: This is obviously bad in the long run. This should

795871 // either block, make the inbox bigger, or return an error code,

796872 // or possibly make it user configurable

797− fprintf(stderr, "Inbox full");

873+ fprintf(stderr, "Inbox full");

798874 exit(-1);

799875 }

800876

@@ -820,7 +896,7 @@ VM* idris_checkMessages(VM* vm) {

820896

821897VM* idris_checkMessagesFrom(VM* vm, VM* sender) {

822898 Msg* msg;

823−

899+

824900 for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {

825901 if (sender == NULL || msg->sender == sender) {

826902 return msg->sender;

@@ -854,7 +930,7 @@ VM* idris_checkMessagesTimeout(VM* vm, int delay) {

854930

855931Msg* idris_getMessageFrom(VM* vm, VM* sender) {

856932 Msg* msg;

857−

933+

858934 for (msg = vm->inbox; msg < vm->inbox_write; ++msg) {

859935 if (sender == NULL || msg->sender == sender) {

860936 return msg;

@@ -951,7 +1027,7 @@ void init_nullaries() {

9511027 nullary_cons = malloc(256 * sizeof(VAL));

9521028 for(i = 0; i < 256; ++i) {

9531029 cl = malloc(sizeof(Closure));

954− SETTY(cl, CON);

1030+ SETTY(cl, CT_CON);

9551031 cl->info.c.tag_arity = i << 8;

9561032 nullary_cons[i] = cl;

9571033 }

rts/idris_rts.h+59−14

@@ -25,9 +25,9 @@

2525

2626// Closures

2727typedef enum {

28− CON, INT, BIGINT, FLOAT, STRING, STROFFSET,

29− BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,

30− MANAGEDPTR, RAWDATA

28+ CT_CON, CT_INT, CT_BIGINT, CT_FLOAT, CT_STRING, CT_STROFFSET,

29+ CT_BITS8, CT_BITS16, CT_BITS32, CT_BITS64, CT_UNIT, CT_PTR, CT_FWD,

30+ CT_MANAGEDPTR, CT_RAWDATA, CT_CDATA

3131} ClosureType;

3232

3333typedef struct Closure *VAL;

@@ -67,20 +67,21 @@ typedef struct Closure {

6767 uint32_t bits32;

6868 uint64_t bits64;

6969 ManagedPtr* mptr;

70+ CHeapItem* c_heap_item;

7071 size_t size;

7172 } info;

7273} Closure;

7374

74−struct VM_t;

75+struct VM;

7576

7677struct Msg_t {

77− struct VM_t* sender;

78+ struct VM* sender;

7879 VAL msg;

7980};

8081

8182typedef struct Msg_t Msg;

8283

83−struct VM_t {

84+struct VM {

8485 int active; // 0 if no longer running; keep for message passing

8586 // TODO: If we're going to have lots of concurrent threads,

8687 // we really need to be cleverer than this!

@@ -90,6 +91,7 @@ struct VM_t {

9091 VAL* valstack_base;

9192 VAL* stack_max;

9293

94+ CHeap c_heap;

9395 Heap heap;

9496#ifdef HAS_PTHREAD

9597 pthread_mutex_t inbox_lock;

@@ -110,11 +112,44 @@ struct VM_t {

110112 VAL reg1;

111113};

112114

113−typedef struct VM_t VM;

115+typedef struct VM VM;

116+

117+

118+/* C data interface: allocation on the C heap.

119+ *

120+ * Although not enforced in code, CData is meant to be opaque

121+ * and non-RTS code (such as libraries or C bindings) should

122+ * access only its (void *) field called "data".

123+ *

124+ * Feel free to mutate cd->data; the heap does not care

125+ * about its particular value. However, keep in mind

126+ * that it must not break Idris's referential transparency.

127+ *

128+ * If you call cdata_allocate or cdata_manage, the resulting

129+ * CData object *must* be returned from your FFI function so

130+ * that it is inserted in the C heap. Otherwise the memory

131+ * will be leaked.

132+ */

133+

134+/// C data block. Contains (void * data).

135+typedef CHeapItem * CData;

136+

137+/// Allocate memory, returning the corresponding C data block.

138+CData cdata_allocate(size_t size, CDataFinalizer * finalizer);

139+

140+/// Wrap a pointer as a C data block.

141+/// The size should be an estimate of how much memory, in bytes,

142+/// is associated with the pointer. This estimate need not be absolutely precise

143+/// but it is necessary for GC to work effectively.

144+CData cdata_manage(void * data, size_t size, CDataFinalizer * finalizer);

145+

114146

115147// Create a new VM

116148VM* init_vm(int stack_size, size_t heap_size,

117149 int max_threads);

150+

151+// Get the VM for the current thread

152+VM* get_vm(void);

118153// Initialise thread-local data for this VM

119154void init_threaddata(VM *vm);

120155// Clean up a VM once it's no longer needed

@@ -147,16 +182,17 @@ typedef void(*func)(VM*, VAL*);

147182#define GETPTR(x) (((VAL)(x))->info.ptr)

148183#define GETMPTR(x) (((VAL)(x))->info.mptr->data)

149184#define GETFLOAT(x) (((VAL)(x))->info.f)

185+#define GETCDATA(x) (((VAL)(x))->info.c_heap_item)

150186

151187#define GETBITS8(x) (((VAL)(x))->info.bits8)

152188#define GETBITS16(x) (((VAL)(x))->info.bits16)

153189#define GETBITS32(x) (((VAL)(x))->info.bits32)

154190#define GETBITS64(x) (((VAL)(x))->info.bits64)

155191

156−#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity >> 8 : (-1)) )

157−#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) )

192+#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_CON ? (x)->info.c.tag_arity >> 8 : (-1)) )

193+#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) )

158194

159−// Already checked it's a CON

195+// Already checked it's a CT_CON

160196#define CTAG(x) (((x)->info.c.tag_arity) >> 8)

161197#define CARITY(x) ((x)->info.c.tag_arity & 0x000000ff)

162198

@@ -176,7 +212,7 @@ typedef intptr_t i_int;

176212#define MKINT(x) ((void*)((x)<<1)+1)

177213#define GETINT(x) ((i_int)(x)>>1)

178214#define ISINT(x) ((((i_int)x)&1) == 1)

179−#define ISSTR(x) (GETTY(x) == STRING)

215+#define ISSTR(x) (GETTY(x) == CT_STRING)

180216

181217#define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1)))

182218#define UINTOP(op,x,y) MKINT((i_int)((((uintptr_t)x)>>1) op (((uintptr_t)y)>>1)))

@@ -207,6 +243,7 @@ VAL MKB8(VM* vm, uint8_t b);

207243VAL MKB16(VM* vm, uint16_t b);

208244VAL MKB32(VM* vm, uint32_t b);

209245VAL MKB64(VM* vm, uint64_t b);

246+VAL MKCDATA(VM* vm, CHeapItem * item);

210247

211248// following versions don't take a lock when allocating

212249VAL MKFLOATc(VM* vm, double val);

@@ -214,6 +251,7 @@ VAL MKSTROFFc(VM* vm, StrOffset* off);

214251VAL MKSTRc(VM* vm, char* str);

215252VAL MKPTRc(VM* vm, void* ptr);

216253VAL MKMPTRc(VM* vm, void* ptr, size_t size);

254+VAL MKCDATAc(VM* vm, CHeapItem * item);

217255

218256char* GETSTROFF(VAL stroff);

219257

@@ -245,12 +283,12 @@ void idris_free(void* ptr, size_t size);

245283

246284#define allocCon(cl, vm, t, a, o) \

247285 cl = allocate(sizeof(Closure) + sizeof(VAL)*a, o); \

248− SETTY(cl, CON); \

286+ SETTY(cl, CT_CON); \

249287 cl->info.c.tag_arity = ((t) << 8) | (a);

250288

251289#define updateCon(cl, old, t, a) \

252290 cl = old; \

253− SETTY(cl, CON); \

291+ SETTY(cl, CT_CON); \

254292 cl->info.c.tag_arity = ((t) << 8) | (a);

255293

256294#define NULL_CON(x) nullary_cons[x]

@@ -304,9 +342,16 @@ VAL idris_castStrFloat(VM* vm, VAL i);

304342

305343// Raw memory manipulation

306344void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size);

345+void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);

307346uint8_t idris_peek(void* ptr, i_int offset);

308347void idris_poke(void* ptr, i_int offset, uint8_t data);

309−void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);

348+

349+VAL idris_peekPtr(VM* vm, VAL ptr, VAL offset);

350+VAL idris_pokePtr(VAL ptr, VAL offset, VAL data);

351+VAL idris_peekDouble(VM* vm, VAL ptr, VAL offset);

352+VAL idris_pokeDouble(VAL ptr, VAL offset, VAL data);

353+VAL idris_peekSingle(VM* vm, VAL ptr, VAL offset);

354+VAL idris_pokeSingle(VAL ptr, VAL offset, VAL data);

310355

311356// String primitives

312357VAL 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+208−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")

@@ -74,6 +75,7 @@ codegenC' defs out exec incs objs libs flags exports iface dbg

7475 libFlags <- getLibFlags

7576 incFlags <- getIncFlags

7677 envFlags <- getEnvFlags

78+ let stackFlag = if isWindows then ["-Wl,--stack,16777216"] else []

7779 let args = [gccDbg dbg] ++

7880 gccFlags iface ++

7981 -- # Any flags defined here which alter the RTS API must also be added to config.mk

@@ -81,10 +83,10 @@ codegenC' defs out exec incs objs libs flags exports iface dbg

8183 "-I."] ++ objs ++ envFlags ++

8284 (if (exec == Executable) then [] else ["-c"]) ++

8385 [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 ++

86+ (if not iface then libFlags else []) ++

87+ incFlags ++

88+ (if not iface then libs else []) ++

89+ flags ++ stackFlag ++

8890 ["-o", out]

8991-- putStrLn (show args)

9092 exit <- rawSystem comp args

@@ -153,7 +155,7 @@ showCStr s = '"' : foldr ((++) . showChar) "\"" s

153155 headHex h (length bytes) : map toHex bytes

154156 where

155157 split acc 0 = acc

156− split acc x = let xbits = x .&. 0x3f

158+ split acc x = let xbits = x .&. 0x3f

157159 xrest = shiftR x 6 in

158160 split (xbits : acc) xrest

159161

@@ -185,7 +187,7 @@ bcc i (ASSIGNCONST l c)

185187 -- if it's a type constant, we won't use it, but equally it shouldn't

186188 -- report an error. These might creep into generated for various reasons

187189 -- (especially if erasure is disabled).

188− mkConst c | isTypeConst c = "MKINT(42424242)"

190+ mkConst c | isTypeConst c = "MKINT(42424242)"

189191 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"

190192

191193bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

@@ -317,18 +319,29 @@ bcc i (TOPBASE n) = indent i ++ "TOPBASE(" ++ show n ++ ");\n"

317319bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

318320bcc i STOREOLD = indent i ++ "STOREOLD;\n"

319321bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

322+bcc i (FOREIGNCALL l rty (FStr fn@('&':name)) [])

323+ = indent i ++

324+ c_irts (toFType rty) (creg l ++ " = ") fn ++ ";\n"

325+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%wrapper"

326+ = indent i ++

327+ c_irts (toFType rty) (creg l ++ " = ")

328+ ("_idris_get_wrapper(" ++ creg (snd x) ++ ")") ++ ";\n"

329+bcc i (FOREIGNCALL l rty (FStr fn) (x:xs)) | fn == "%dynamic"

330+ = indent i ++ c_irts (toFType rty) (creg l ++ " = ")

331+ ("(*(" ++ cFnSig "" rty xs ++ ") GETPTR(" ++ creg (snd x) ++ "))" ++

332+ "(" ++ showSep "," (map fcall xs) ++ ")") ++ ";\n"

320333bcc i (FOREIGNCALL l rty (FStr fn) args)

321334 = indent i ++

322335 c_irts (toFType rty) (creg l ++ " = ")

323336 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

324− where fcall (t, arg) = irts_c (toFType t) (creg arg)

325337bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

326338bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

327339-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"

328340

341+fcall (t, arg) = irts_c (toFType t) (creg arg)

329342-- Deconstruct the Foreign type in the defunctionalised expression and build

330343-- a foreign type description for c_irts and irts_c

331−toAType (FCon i)

344+toAType (FCon i)

332345 | i == sUN "C_IntChar" = ATInt ITChar

333346 | i == sUN "C_IntNative" = ATInt ITNative

334347 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)

@@ -337,18 +350,27 @@ toAType (FCon i)

337350 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)

338351toAType t = error (show t ++ " not defined in toAType")

339352

340−toFType (FCon c)

353+toFType (FCon c)

341354 | c == sUN "C_Str" = FString

342355 | c == sUN "C_Float" = FArith ATFloat

343356 | c == sUN "C_Ptr" = FPtr

344357 | c == sUN "C_MPtr" = FManagedPtr

358+ | c == sUN "C_CData" = FCData

345359 | c == sUN "C_Unit" = FUnit

346−toFType (FApp c [_,ity])

360+toFType (FApp c [_,ity])

347361 | c == sUN "C_IntT" = FArith (toAType ity)

348−toFType (FApp c [_])

362+ | c == sUN "C_FnT" = toFunType ity

363+toFType (FApp c [_])

349364 | c == sUN "C_Any" = FAny

350365toFType t = FAny

351366

367+toFunType (FApp c [_,ity])

368+ | c == sUN "C_FnBase" = FFunction

369+ | c == sUN "C_FnIO" = FFunctionIO

370+toFunType (FApp c [_,_,_,ity])

371+ | c == sUN "C_Fn" = toFunType ity

372+toFunType _ = FAny

373+

352374c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

353375c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x

354376c_irts (FArith (ATInt (ITFixed ity))) l x

@@ -358,7 +380,10 @@ c_irts FUnit l x = x

358380c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

359381c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"

360382c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

383+c_irts FCData l x = l ++ "MKCDATA(vm, " ++ x ++ ")"

361384c_irts FAny l x = l ++ x

385+c_irts FFunction l x = error "Return of function from foreign call is not supported"

386+c_irts FFunctionIO l x = error "Return of function from foreign call is not supported"

362387

363388irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"

364389irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x

@@ -369,7 +394,16 @@ irts_c FUnit x = x

369394irts_c FPtr x = "GETPTR(" ++ x ++ ")"

370395irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"

371396irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

397+irts_c FCData x = "GETCDATA(" ++ x ++ ")"

372398irts_c FAny x = x

399+irts_c FFunctionIO x = wrapped x

400+irts_c FFunction x = wrapped x

401+

402+cFnSig name rty [] = ctype rty ++ " (*" ++ name ++ ")(void) "

403+cFnSig name rty args = ctype rty ++ " (*" ++ name ++ ")("

404+ ++ showSep "," (map (ctype . fst) args) ++ ") "

405+

406+wrapped x = "_idris_get_wrapper(" ++ x ++ ")"

373407

374408bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

375409

@@ -527,6 +561,8 @@ doOp v (LTrunc (ITFixed from) ITNative) [x]

527561 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"

528562doOp v (LTrunc (ITFixed from) ITChar) [x]

529563 = doOp v (LTrunc (ITFixed from) ITNative) [x]

564+doOp v (LTrunc ITBig (ITFixed IT64)) [x]

565+ = v ++ "idris_b64const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : idris_truncBigB64(GETMPZ(" ++ creg x ++ ")))"

530566doOp v (LTrunc ITBig (ITFixed to)) [x]

531567 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"

532568doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]

@@ -551,7 +587,7 @@ doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

551587doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

552588

553589doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"

554−doOp v LWriteStr [_,s]

590+doOp v LWriteStr [_,s]

555591 = v ++ "MKINT((i_int)(idris_writeStr(stdout"

556592 ++ ",GETSTR("

557593 ++ creg s ++ "))))"

@@ -577,10 +613,10 @@ doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"

577613doOp v LNoOp args = v ++ creg (last args)

578614

579615-- Pointer primitives (declared as %extern in Builtins.idr)

580−doOp v (LExternal rf) [_,x]

616+doOp v (LExternal rf) [_,x]

581617 | rf == sUN "prim__readFile"

582618 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

583−doOp v (LExternal wf) [_,x,s]

619+doOp v (LExternal wf) [_,x,s]

584620 | wf == sUN "prim__writeFile"

585621 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x

586622 ++ "),GETSTR("

@@ -591,15 +627,49 @@ doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"

591627doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"

592628

593629doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"

594−doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"

630+doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqPtr"

595631 = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"

596−doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"

632+doOp v (LExternal eqp) [x, y] | eqp == sUN "prim__eqManagedPtr"

597633 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"

598634doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"

599635 = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"

600−

636+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek8"

637+ = v ++ "idris_peekB8(vm," ++ creg p ++ "," ++ creg o ++")"

638+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke8"

639+ = v ++ "idris_pokeB8(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

640+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek16"

641+ = v ++ "idris_peekB16(vm," ++ creg p ++ "," ++ creg o ++")"

642+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke16"

643+ = v ++ "idris_pokeB16(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

644+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek32"

645+ = v ++ "idris_peekB32(vm," ++ creg p ++ "," ++ creg o ++")"

646+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke32"

647+ = v ++ "idris_pokeB32(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

648+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peek64"

649+ = v ++ "idris_peekB64(vm," ++ creg p ++ "," ++ creg o ++")"

650+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__poke64"

651+ = v ++ "idris_pokeB64(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

652+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekPtr"

653+ = v ++ "idris_peekPtr(vm," ++ creg p ++ "," ++ creg o ++")"

654+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokePtr"

655+ = v ++ "idris_pokePtr(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

656+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeDouble"

657+ = v ++ "idris_pokeDouble(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

658+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekDouble"

659+ = v ++ "idris_peekDouble(vm," ++ creg p ++ "," ++ creg o ++")"

660+doOp v (LExternal pk) [_, p, o, x] | pk == sUN "prim__pokeSingle"

661+ = v ++ "idris_pokeSingle(" ++ creg p ++ "," ++ creg o ++ "," ++ creg x ++ ")"

662+doOp v (LExternal pk) [_, p, o] | pk == sUN "prim__peekSingle"

663+ = v ++ "idris_peekSingle(vm," ++ creg p ++ "," ++ creg o ++")"

664+doOp v (LExternal pk) [] | pk == sUN "prim__sizeofPtr"

665+ = v ++ "MKINT(sizeof(void*))"

666+doOp v (LExternal mpt) [p] | mpt == sUN "prim__asPtr"

667+ = v ++ "MKPTR(vm, GETMPTR("++ creg p ++"))"

668+doOp v (LExternal offs) [p, n] | offs == sUN "prim__ptrOffset"

669+ = v ++ "MKPTR(vm, GETPTR(" ++ creg p ++ ") + GETINT(" ++ creg n ++ "))"

601670doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"

602671

672+

603673flUnOp :: String -> String -> String

604674flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

605675

@@ -610,7 +680,7 @@ flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

610680ifaceC :: Export -> String

611681ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

612682ifaceC (ExportFun n cn ret args)

613− = ctype ret ++ " " ++ cdesc cn ++

683+ = ctype ret ++ " " ++ cdesc cn ++

614684 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"

615685 ++ mkBody n (zip argNames args) ret ++ "}\n\n"

616686 where showArgs [] = ""

@@ -623,7 +693,7 @@ mkBody n as t = indent 1 ++ "INITFRAME;\n" ++

623693 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++

624694 push 0 as ++ call n ++ retval t

625695 where push i [] = ""

626− push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)

696+ push i ((n, t) : ts) = indent 1 ++ c_irts (toFType t)

627697 ("TOP(" ++ show i ++ ") = ") n

628698 ++ ";\n" ++ push (i + 1) ts

629699

@@ -689,7 +759,7 @@ hdr_guard x = "__" ++ map hchar x

689759hdr_export :: Export -> String

690760hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

691761hdr_export (ExportFun n cn ret args)

692− = ctype ret ++ " " ++ cdesc cn ++

762+ = ctype ret ++ " " ++ cdesc cn ++

693763 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"

694764 where showArgs [] = ""

695765 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++

@@ -697,5 +767,119 @@ hdr_export (ExportFun n cn ret args)

697767

698768 argNames = zipWith (++) (repeat "arg") (map show [0..])

699769

770+------------------ Callback wrapper generation ----------------

771+-- Generate callback wrappers and a function to select the

772+-- correct wrapper function to pass.

773+-- TODO: This is limited to functions that are specified in

774+-- the foreign call. Otherwise we would have to generate wrappers for all

775+-- functions with correct arity or do flow analysis

776+-- to find all possible inputs to the foreign call.

777+genWrappers :: [(Name, [BC])] -> String

778+genWrappers bcs = let

779+ tags = nubBy (\x y -> snd x == snd y) $ concatMap (getCallback . snd) bcs

780+ in

781+ case tags of

782+ [] -> ""

783+ t -> concatMap genWrapper t ++ genDispatcher t

784+

785+genDispatcher :: [(FDesc, Int)] -> String

786+genDispatcher tags = "void* _idris_get_wrapper(VAL con)\n" ++

787+ "{\n" ++

788+ indent 1 ++ "switch(TAG(con)) {\n" ++

789+ concatMap makeSwitch tags ++

790+ indent 1 ++ "}\n" ++

791+ indent 1 ++ "fprintf(stderr, \"No wrapper for callback\");\n" ++

792+ indent 1 ++ "exit(-1);\n" ++

793+ "}\n\n"

794+ where

795+ makeSwitch (_, tag) =

796+ indent 1 ++ "case " ++ show tag ++ ":\n" ++

797+ indent 2 ++ "return (void*) &" ++ wrapperName tag ++ ";\n"

798+

799+genWrapper :: (FDesc, Int) -> String

800+genWrapper (desc, tag) | (toFType desc) == FFunctionIO =

801+ error $ "Cannot create C callbacks for IO functions, wrap them with unsafePerformIO.\n"

802+genWrapper (desc, tag) = ret ++ " " ++ wrapperName tag ++ "(" ++

803+ renderArgs argList ++")\n" ++

804+ "{\n" ++

805+ (if ret /= "void" then indent 1 ++ ret ++ " ret;\n" else "") ++

806+ indent 1 ++ "VM* vm = get_vm();\n" ++

807+ indent 1 ++ "if (vm == NULL) {\n" ++

808+ indent 2 ++ "vm = idris_vm();\n" ++

809+ indent 1 ++ "}\n" ++

810+ indent 1 ++ "INITFRAME;\n" ++

811+ indent 1 ++ "RESERVE(" ++ show (len + 1) ++ ");\n" ++

812+ indent 1 ++ "allocCon(REG1, vm, " ++ show tag ++ ",0 , 0);\n" ++

813+ indent 1 ++ "TOP(0) = REG1;\n" ++

814+ applyArgs argList ++

815+ if ret /= "void"

816+ then indent 1 ++ "ret = " ++ irts_c (toFType ft) "RVAL" ++ ";\n"

817+ ++ indent 1 ++ "return ret;\n}\n\n"

818+ else "}\n\n"

819+ where

820+ (ret, ft) = rty desc

821+ argList = zip (args desc) [0..]

822+ len = length argList

823+

824+ applyArgs (x:y:xs) = push 1 [x] ++

825+ indent 1 ++ "STOREOLD;\n" ++

826+ indent 1 ++ "BASETOP(0);\n" ++

827+ indent 1 ++ "ADDTOP(2);\n" ++

828+ indent 1 ++ "CALL(_idris__123_APPLY0_125_);\n" ++

829+ indent 1 ++ "TOP(0)=REG1;\n" ++

830+ applyArgs (y:xs)

831+ applyArgs x = push 1 x ++

832+ indent 1 ++ "STOREOLD;\n" ++

833+ indent 1 ++ "BASETOP(0);\n" ++

834+ indent 1 ++ "ADDTOP(" ++ show (length x + 1) ++ ");\n" ++

835+ indent 1 ++ "CALL(_idris__123_APPLY0_125_);\n"

836+ renderArgs [] = "void"

837+ renderArgs [((s, _), n)] = s ++ " a" ++ (show n)

838+ renderArgs (((s, _), n):xs) = s ++ " a" ++ (show n) ++ ", " ++

839+ renderArgs xs

840+ rty (FApp c [_,ty])

841+ | c == sUN "C_FnBase" = (ctype ty, ty)

842+ | c == sUN "C_FnIO" = (ctype ty, ty)

843+ | c == sUN "C_FnT" = rty ty

844+ rty (FApp c [_,_,ty,fn])

845+ | c == sUN "C_Fn" = rty fn

846+ rty x = ("", x)

847+ args (FApp c [_,ty])

848+ | c == sUN "C_FnBase" = []

849+ | c == sUN "C_FnIO" = []

850+ | c == sUN "C_FnT" = args ty

851+ args (FApp c [_,_,ty,fn])

852+ | toFType ty == FUnit = []

853+ | c == sUN "C_Fn" = (ctype ty, ty) : args fn

854+ args _ = []

855+ push i [] = ""

856+ push i (((c, t), n) : ts) = indent 1 ++ c_irts (toFType t)

857+ ("TOP(" ++ show i ++ ") = ") ("a" ++ show n)

858+ ++ ";\n" ++ push (i + 1) ts

700859

701−

860+wrapperName :: Int -> String

861+wrapperName tag = "_idris_wrapper_" ++ show tag

862+

863+getCallback :: [BC] -> [(FDesc, Int)]

864+getCallback bc = getCallback' (reverse bc)

865+ where

866+ getCallback' (x:xs) = case hasCallback x of

867+ [] -> getCallback' xs

868+ cbs -> case findCons cbs xs of

869+ [] -> error "Idris function couldn't be wrapped."

870+ x -> x

871+ getCallback' [] = []

872+ findCons (c:cs) xs = findCon c xs ++ findCons cs xs

873+ findCons [] _ = []

874+ findCon c ((MKCON l loc tag args):xs) | snd c == l = [(fst c, tag)]

875+ findCon c (_:xs) = findCon c xs

876+ findCon c [] = []

877+

878+hasCallback :: BC -> [(FDesc, Reg)]

879+hasCallback (FOREIGNCALL l rty (FStr fn) args) = filter isFn args

880+ where

881+ isFn (desc,_) = case toFType desc of

882+ FFunction -> True

883+ FFunctionIO -> True

884+ _ -> False

885+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+8−2

@@ -18,6 +18,7 @@ import Idris.AbsSyntaxTree

1818import Idris.ASTUtils

1919import Idris.Erasure

2020import Idris.Error

21+import Idris.Output

2122

2223import Debug.Trace

2324

@@ -112,7 +113,9 @@ compile codegen f mtm

112113 where checkMVs = do i <- getIState

113114 case map fst (idris_metavars i) \\ primDefs of

114115 [] -> return ()

115− ms -> ifail $ "There are undefined holes: " ++ show ms

116+ ms -> do iputStrLn $ "WARNING: There are incomplete holes:\n " ++ show ms

117+ iputStrLn "\nEvaluation of any of these will crash at run time."

118+ return ()

116119 checkTotality = do i <- getIState

117120 case idris_totcheckfail i of

118121 [] -> return ()

@@ -227,6 +230,9 @@ irTerm :: Vars -> [Name] -> Term -> Idris LExp

227230irTerm vs env tm@(App _ f a) = do

228231 ist <- getIState

229232 case unApply tm of

233+ (P _ n _, args)

234+ | n `elem` map fst (idris_metavars ist) \\ primDefs

235+ -> return $ LError $ "ABORT: Attempt to evaluate hole " ++ show n

230236 (P _ (UN m) _, args)

231237 | m == txt "mkForeignPrim"

232238 -> doForeign vs env (reverse (drop 4 args)) -- drop implicits

@@ -462,7 +468,7 @@ doForeign vs env (ret : fname : world : args)

462468 = do let l' = toFDesc l

463469 r' <- irTerm vs env r

464470 return (l', r')

465− splitArg _ = ifail "Badly formed foreign function call"

471+ splitArg _ = ifail $ "Badly formed foreign function call"

466472

467473 toFDesc (Constant (Str str)) = FStr str

468474 toFDesc tm

src/IRTS/Lang.hs+9−7

@@ -17,10 +17,11 @@ data LVar = Loc Int | Glob Name

1717 deriving (Show, Eq)

1818

1919-- ASSUMPTION: All variable bindings have unique names here

20+-- Constructors commented as lifted are not present in the LIR provided to the different backends.

2021data LExp = LV LVar

2122 | LApp Bool LExp [LExp] -- True = tail call

2223 | LLazyApp Name [LExp] -- True = tail call

23− | LLazyExp LExp

24+ | LLazyExp LExp -- lifted out before compiling

2425 | LForce LExp -- make sure Exp is evaluted

2526 | LLet Name LExp LExp -- name just for pretty printing

2627 | LLam [Name] LExp -- lambda, lifted out before compiling

@@ -99,6 +100,7 @@ data FType = FArith ArithTy

99100 | FUnit

100101 | FPtr

101102 | FManagedPtr

103+ | FCData

102104 | FAny

103105 deriving (Show, Eq)

104106

@@ -132,7 +134,7 @@ data LiftState = LS Name Int [(Name, LDecl)]

132134

133135lname (NS n x) i = NS (lname n i) x

134136lname (UN n) i = MN i n

135−lname x i = sMN i (show x ++ "_lam")

137+lname x i = sMN i (showCG x ++ "_lam")

136138

137139liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

138140liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs

@@ -215,7 +217,7 @@ allocUnique defs (n, LFun opts fn args e)

215217 -- Keep track of 'updatable' names in the state, i.e. names whose heap

216218 -- entry may be reused, along with the arity which was there

217219 findUp :: LExp -> State [(Name, Int)] LExp

218− findUp (LApp t (LV (Glob n)) as)

220+ findUp (LApp t (LV (Glob n)) as)

219221 | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,

220222 ar == length as

221223 = findUp (LCon Nothing i n as)

@@ -241,7 +243,7 @@ allocUnique defs (n, LFun opts fn args e)

241243 findUp (LOp o es) = LOp o <$> mapM findUp es

242244 findUp (LCase Updatable e@(LV (Glob n)) as)

243245 = LCase Updatable e <$> mapM (doUpAlt n) as

244− findUp (LCase t e as)

246+ findUp (LCase t e as)

245247 = LCase t <$> findUp e <*> mapM findUpAlt as

246248 findUp t = return t

247249

@@ -252,7 +254,7 @@ allocUnique defs (n, LFun opts fn args e)

252254 findUpAlt (LConstCase i rhs) = LConstCase i <$> findUp rhs

253255 findUpAlt (LDefaultCase rhs) = LDefaultCase <$> findUp rhs

254256

255− doUpAlt n (LConCase i t args rhs)

257+ doUpAlt n (LConCase i t args rhs)

256258 = do avail <- get

257259 put ((n, length args) : avail)

258260 rhs' <- findUp rhs

@@ -282,7 +284,7 @@ usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e

282284usedIn env (LLam ns e) = usedIn (env \\ ns) e

283285usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in

284286 case v of

285− Nothing -> rest

287+ Nothing -> rest

286288 Just (Glob n) -> usedArg env n ++ rest

287289usedIn env (LProj t i) = usedIn env t

288290usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts

@@ -329,7 +331,7 @@ instance Show LExp where

329331 Updatable -> "! "

330332 fmt [] = ""

331333 fmt [alt]

332− = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt

334+ = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt

333335 fmt (alt:as)

334336 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ". ") alt

335337 ++ "\n" ++ fmt as

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+125−77

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

@@ -611,7 +646,7 @@ addDeferredTyCon = addDeferred' (TCon 0 0)

611646

612647-- | Save information about a name that is not yet defined

613648addDeferred' :: NameType

614− -> [(Name, (Int, Maybe Name, Type, [Name], Bool))]

649+ -> [(Name, (Int, Maybe Name, Type, [Name], Bool, Bool))]

615650 -- ^ The Name is the name being made into a metavar,

616651 -- the Int is the number of vars that are part of a

617652 -- putative proof context, the Maybe Name is the

@@ -620,10 +655,11 @@ addDeferred' :: NameType

620655 -- allowed

621656 -> Idris ()

622657addDeferred' nt ns

623− = do mapM_ (\(n, (i, _, t, _, _)) -> updateContext (addTyDecl n nt (tidyNames S.empty t))) ns

658+ = do mapM_ (\(n, (i, _, t, _, _, _)) -> updateContext (addTyDecl n nt (tidyNames S.empty t))) ns

624659 mapM_ (\(n, _) -> when (not (n `elem` primDefs)) $ addIBC (IBCMetavar n)) ns

625660 i <- getIState

626− putIState $ i { idris_metavars = map (\(n, (i, top, _, ns, isTopLevel)) -> (n, (top, i, ns, isTopLevel))) ns ++

661+ putIState $ i { idris_metavars = map (\(n, (i, top, _, ns, isTopLevel, isDefinable)) ->

662+ (n, (top, i, ns, isTopLevel, isDefinable))) ns ++

627663 idris_metavars i }

628664 where

629665 -- 'tidyNames' is to generate user accessible names in case they are

@@ -636,9 +672,13 @@ addDeferred' nt ns

636672 Bind n' b $ tidyNames (S.insert n' used) sc

637673 tidyNames used b = b

638674

639−solveDeferred :: Name -> Idris ()

640−solveDeferred n = do i <- getIState

641− putIState $ i { idris_metavars =

675+solveDeferred :: FC -> Name -> Idris ()

676+solveDeferred fc n

677+ = do i <- getIState

678+ case lookup n (idris_metavars i) of

679+ Just (_, _, _, _, False) ->

680+ throwError $ At fc $ Msg ("Can't define hole " ++ show n ++ " as it depends on other holes")

681+ _ -> putIState $ i { idris_metavars =

642682 filter (\(n', _) -> n/=n')

643683 (idris_metavars i),

644684 ibc_write =

@@ -738,6 +778,16 @@ logLevel :: Idris Int

738778logLevel = do i <- getIState

739779 return (opt_logLevel (idris_options i))

740780

781+setAutoImpls :: Bool -> Idris ()

782+setAutoImpls b = do i <- getIState

783+ let opts = idris_options i

784+ let opt' = opts { opt_autoimpls = b }

785+ putIState $ i { idris_options = opt' }

786+

787+getAutoImpls :: Idris Bool

788+getAutoImpls = do i <- getIState

789+ return (opt_autoimpls (idris_options i))

790+

741791setErrContext :: Bool -> Idris ()

742792setErrContext t = do i <- getIState

743793 let opts = idris_options i

@@ -1024,7 +1074,7 @@ logLvlCats cs l str = do

10241074 runIO . hPutStrLn h $ convSExp "log" good n

10251075 where

10261076 inCat :: [LogCat] -> [LogCat] -> Bool

1027− inCat cs cats = or $ map (\x -> elem x cats) cs

1077+ inCat cs cats = any (`elem` cats) cs

10281078

10291079cmdOptType :: Opt -> Idris Bool

10301080cmdOptType x = do i <- getIState

@@ -1101,25 +1151,25 @@ expandParams dec ps ns infs tm = en 0 tm

11011151 | n `nselem` ns = PQuote (Var (dec n))

11021152 en 0 (PApp fc (PInferRef fc' hl n) as)

11031153 | n `nselem` ns = PApp fc (PInferRef fc' hl (dec n))

1104− (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))

11051155 en 0 (PApp fc (PRef fc' hl n) as)

11061156 | n `elem` infs = PApp fc (PInferRef fc' hl (dec n))

1107− (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))

11081158 | n `nselem` ns = PApp fc (PRef fc' hl (dec n))

1109− (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))

11101160 en 0 (PAppBind fc (PRef fc' hl n) as)

11111161 | n `elem` infs = PAppBind fc (PInferRef fc' hl (dec n))

1112− (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))

1162+ (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))

11131163 | n `nselem` ns = PAppBind fc (PRef fc' hl (dec n))

1114− (map (pexp . (PRef fc hl)) (map fst ps) ++ (map (fmap (en 0)) as))

1164+ (map ((pexp . (PRef fc hl)) . fst) ps ++ (map (fmap (en 0)) as))

11151165 en 0 (PRef fc hl n)

11161166 | n `elem` infs = PApp fc (PInferRef fc hl (dec n))

1117− (map (pexp . (PRef fc hl)) (map fst ps))

1167+ (map ((pexp . (PRef fc hl)) . fst) ps)

11181168 | n `nselem` ns = PApp fc (PRef fc hl (dec n))

1119− (map (pexp . (PRef fc hl)) (map fst ps))

1169+ (map ((pexp . (PRef fc hl)) . fst) ps)

11201170 en 0 (PInferRef fc hl n)

11211171 | n `nselem` ns = PApp fc (PInferRef fc hl (dec n))

1122− (map (pexp . (PRef fc hl)) (map fst ps))

1172+ (map ((pexp . (PRef fc hl)) . fst) ps)

11231173 en 0 (PApp fc f as) = PApp fc (en 0 f) (map (fmap (en 0)) as)

11241174 en 0 (PAppBind fc f as) = PAppBind fc (en 0 f) (map (fmap (en 0)) as)

11251175 en 0 (PCase fc c os) = PCase fc (en 0 c) (map (pmap (en 0)) os)

@@ -1191,7 +1241,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

11911241 removeBound lhs ns = ns \\ nub (bnames lhs)

11921242

11931243 bnames (PRef _ _ n) = [n]

1194− bnames (PApp _ _ args) = concatMap bnames (map getTm args)

1244+ bnames (PApp _ _ args) = concatMap (bnames . getTm) args

11951245 bnames (PPair _ _ _ l r) = bnames l ++ bnames r

11961246 bnames (PDPair _ _ _ l Placeholder r) = bnames l ++ bnames r

11971247 bnames _ = []

@@ -1227,10 +1277,10 @@ expandParamsD rhs ist dec ps ns (PClass doc info f cs n nfc params pDocs fds dec

12271277 (map (expandParamsD rhs ist dec ps ns) decls)

12281278 cn

12291279 cd

1230−expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs n nfc params ty cn decls)

1280+expandParamsD rhs ist dec ps ns (PInstance doc argDocs info f cs acc opts n nfc params ty cn decls)

12311281 = PInstance doc argDocs info f

12321282 (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)

1233− n

1283+ acc opts n

12341284 nfc

12351285 (map (expandParams dec ps ns []) params)

12361286 (expandParams dec ps ns [] ty)

@@ -1258,9 +1308,9 @@ getPriority i tm = 1 -- pri tm

12581308 pri (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))

12591309 pri (PTrue _ _) = 0

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

1311+ pri (PApp _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))

1312+ pri (PAppBind _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))

1313+ pri (PCase _ f as) = max 1 (max (pri f) (foldr (max . pri . snd) 0 as))

12641314 pri (PTyped l r) = pri l

12651315 pri (PPair _ _ _ l r) = max 1 (max (pri l) (pri r))

12661316 pri (PDPair _ _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

@@ -1277,11 +1327,11 @@ addStatics n tm ptm =

12771327 let paramnames

12781328 = nub $ case lookupCtxtExact n (idris_fninfo ist) of

12791329 Just p -> getNamesFrom 0 (fn_params p) tm ++

1280− concatMap (getParamNames ist) (map snd statics)

1281− _ -> concatMap (getParamNames ist) (map snd statics)

1330+ concatMap (getParamNames ist . snd) statics

1331+ _ -> concatMap (getParamNames ist . snd) statics

12821332

1283− let stnames = nub $ concatMap freeArgNames (map snd statics)

1284− let dnames = (nub $ concatMap freeArgNames (map snd dynamics))

1333+ let stnames = nub $ concatMap (freeArgNames . snd) statics

1334+ let dnames = (nub $ concatMap (freeArgNames . snd) dynamics)

12851335 \\ paramnames

12861336 -- also get the arguments which are 'uniquely inferrable' from

12871337 -- statics (see sec 4.2 of "Scrapping Your Inefficient Engine")

@@ -1290,7 +1340,7 @@ addStatics n tm ptm =

12901340 filter (\x -> not (elem x dnames)) stnames

12911341 let stpos = staticList statics' tm

12921342 i <- getIState

1293− when (not (null statics)) $

1343+ unless (null statics) $

12941344 logLvl 3 $ "Statics for " ++ show n ++ " " ++ show tm ++ "\n"

12951345 ++ showTmImpls ptm ++ "\n"

12961346 ++ show statics ++ "\n" ++ show dynamics

@@ -1376,7 +1426,7 @@ addUsingConstraints syn fc t

13761426 | otherwise = doAdd cs ns t

13771427

13781428 mkConst c args = PApp fc (PRef fc [] c)

1379− (map (\n -> PExp 0 [] (sMN 0 "carg") (PRef fc [] n)) args)

1429+ (map (PExp 0 [] (sMN 0 "carg") . PRef fc []) args)

13801430

13811431 getConstraints (PPi (Constraint _ _) _ _ c sc)

13821432 = getcapp c ++ getConstraints sc

@@ -1395,10 +1445,14 @@ addUsingConstraints syn fc t

13951445addUsingImpls :: SyntaxInfo -> Name -> FC -> PTerm -> Idris PTerm

13961446addUsingImpls syn n fc t

13971447 = do ist <- getIState

1398− let ns = implicitNamesIn (map iname uimpls) ist t

1448+ autoimpl <- getAutoImpls

1449+ let ns_in = implicitNamesIn (map iname uimpls) ist t

1450+ let ns = if autoimpl then ns_in

1451+ else filter (\n -> n `elem` (map iname uimpls)) ns_in

1452+

13991453 let badnames = filter (\n -> not (implicitable n) &&

14001454 n `notElem` (map iname uimpls)) ns

1401− when (not (null badnames)) $

1455+ unless (null badnames) $

14021456 throwError (At fc (Elaborating "type of " n Nothing

14031457 (NoSuchVariable (head badnames))))

14041458 let cs = getArgnames t -- get already bound names

@@ -1481,15 +1535,19 @@ implicit info syn n ptm = implicit' info syn [] n ptm

14811535implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

14821536implicit' info syn ignore n ptm

14831537 = 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'

1538+ auto <- getAutoImpls

1539+ if not auto

1540+ then return ptm

1541+ else do

1542+ let (tm', impdata) = implicitise syn ignore i ptm

1543+ defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

1544+ -- let (tm'', spos) = findStatics i tm'

1545+ putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1546+ addIBC (IBCImp n)

1547+ logLvl 5 ("Implicit " ++ show n ++ " " ++ show impdata)

1548+ -- i <- get

1549+ -- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1550+ return tm'

14931551 where

14941552 -- Detect unknown names in default arguments and throw error if found.

14951553 defaultArgCheck :: [Name] -> [PArg] -> Idris ()

@@ -1534,12 +1592,12 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

15341592 -- Find names in argument position in a type, suitable for implicit

15351593 -- binding

15361594 -- Not the function position, but do everything else...

1537− implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv) (map getTm args)

1538− implNamesIn uv t = namesIn uv ist t

1595+ implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv . getTm) args

1596+ implNamesIn uv t = implicitNamesIn (map fst uv) ist t

15391597

1540− imps top env (PApp _ f as)

1598+ imps top env ty@(PApp _ f as)

15411599 = do (decls, ns) <- get

1542− let isn = concatMap (namesIn uvars ist) (map getTm as)

1600+ let isn = nub (implNamesIn uvars ty)

15431601 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

15441602 imps top env (PPi (Imp l _ _ _) n _ ty sc)

15451603 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

@@ -1644,9 +1702,9 @@ addImpl' inpat env infns imp_meths ist ptm

16441702 ai :: Bool -> Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm

16451703 ai inpat qq env ds (PRef fc fcs f)

16461704 | f `elem` infns = PInferRef fc fcs f

1647− | not (f `elem` map fst env) = handleErr $ aiFn topname inpat inpat qq imp_meths ist fc f fc ds [] []

1705+ | not (f `elem` map fst env) = handleErr $ aiFn topname inpat inpat qq imp_meths ist fc f fc ds []

16481706 ai inpat qq env ds (PHidden (PRef fc hl f))

1649− | not (f `elem` map fst env) = PHidden (handleErr $ aiFn topname inpat False qq imp_meths ist fc f fc ds [] [])

1707+ | not (f `elem` map fst env) = PHidden (handleErr $ aiFn topname inpat False qq imp_meths ist fc f fc ds [])

16501708 ai inpat qq env ds (PRewrite fc l r g)

16511709 = let l' = ai inpat qq env ds l

16521710 r' = ai inpat qq env ds r

@@ -1675,9 +1733,8 @@ addImpl' inpat env infns imp_meths ist ptm

16751733 ai inpat qq env ds (PApp fc ftm@(PRef ffc hl f) as)

16761734 | f `elem` infns = ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as)

16771735 | not (f `elem` map fst env)

1678− = let as' = map (fmap (ai inpat qq env ds)) as

1679− asdotted' = map (fmap (ai False qq env ds)) as in

1680− handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as' asdotted'

1736+ = let as' = map (fmap (ai inpat qq env ds)) as in

1737+ handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as'

16811738 | Just (Just ty) <- lookup f env =

16821739 let as' = map (fmap (ai inpat qq env ds)) as

16831740 arity = getPArity ty in

@@ -1750,9 +1807,8 @@ aiFn :: Name -> Bool -> Bool -> Bool

17501807 -> Name -- ^ function being applied

17511808 -> FC -> [[T.Text]]

17521809 -> [PArg] -- ^ initial arguments (if in a pattern)

1753− -> [PArg] -- ^ initial arguments (if in an expression)

17541810 -> Either Err PTerm

1755−aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _

1811+aiFn topname inpat True qq imp_meths ist fc f ffc ds []

17561812 | inpat && implicitable f && unqualified f = Right $ PPatvar ffc f

17571813 | otherwise

17581814 = case lookupDef f (tt_ctxt ist) of

@@ -1762,7 +1818,7 @@ aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _

17621818 if (not (vname f) || tcname f

17631819 || any (conCaf (tt_ctxt ist)) ialts)

17641820-- any constructor alts || any allImp ialts))

1765− then aiFn topname inpat False qq imp_meths ist fc f ffc ds [] [] -- use it as a constructor

1821+ then aiFn topname inpat False qq imp_meths ist fc f ffc ds [] -- use it as a constructor

17661822 else Right $ PPatvar ffc f

17671823 where imp (PExp _ _ _ _) = False

17681824 imp _ = True

@@ -1780,9 +1836,9 @@ aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _

17801836 vname (UN n) = True -- non qualified

17811837 vname _ = False

17821838

1783−aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp

1839+aiFn topname inpat expat qq imp_meths ist fc f ffc ds as

17841840 | f `elem` primNames = Right $ PApp fc (PRef ffc [ffc] f) as

1785−aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp

1841+aiFn topname inpat expat qq imp_meths ist fc f ffc ds as

17861842 -- This is where namespaces get resolved by adding PAlternative

17871843 = do let ns = lookupCtxtName f (idris_implicits ist)

17881844 let nh = filter (\(n, _) -> notHidden n) ns

@@ -1791,24 +1847,15 @@ aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp

17911847 x -> x

17921848 case ns' of

17931849 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))

1794− (insertImpl ns (chooseArgs f' as asexp))

1850+ (insertImpl ns as)

17951851 [] -> if f `elem` (map fst (idris_metavars ist))

17961852 then Right $ PApp fc (PRef ffc [ffc] f) as

17971853 else Right $ mkPApp fc (length as) (PRef ffc [ffc] f) as

17981854 alts -> Right $

17991855 PAlternative [] (ExactlyOne True) $

18001856 map (\(f', ns) -> mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))

1801− (insertImpl ns (chooseArgs f' as asexp))) alts

1857+ (insertImpl ns as)) alts

18021858 where

1803− -- choose whether to treat the arguments as patterns or expressions

1804− -- if 'f' is a defined function, treat as expression, otherwise do the default.

1805− -- This is so any names which later go under a PHidden are treated

1806− -- as function names rather than bound pattern variables

1807− chooseArgs f as asexp | isConName f (tt_ctxt ist) = as

1808− | f == topname = as

1809− | Nothing <- lookupDefExact f (tt_ctxt ist) = as

1810− | otherwise = asexp

1811−

18121859 -- if the name is in imp_meths, we should actually refer to the bound

18131860 -- name rather than the global one after expanding implicits

18141861 isImpName f f' | f `elem` imp_meths = f

@@ -1823,6 +1870,7 @@ aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp

18231870

18241871 notHidden n = case getAccessibility n of

18251872 Hidden -> False

1873+ Private -> False

18261874 _ -> True

18271875

18281876 getAccessibility n

@@ -1854,9 +1902,9 @@ aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp

18541902 case find n imps [] of

18551903 Just (tm, imps') ->

18561904 PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given imps'

1857− Nothing -> let ph = if f `elem` imp_meths then PRef fc [] n else Placeholder in

1858− PImp p True l n ph :

1859− insImpAcc (M.insert n ph pnas) ps given imps

1905+ Nothing ->

1906+ PImp p True l n Placeholder :

1907+ insImpAcc (M.insert n Placeholder pnas) ps given imps

18601908 insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given imps =

18611909 let sc = addImpl imp_meths ist (substMatches (M.toList pnas) sc') in

18621910 case find n imps [] of

src/Idris/AbsSyntaxTree.hs+478−463

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

@@ -210,12 +211,14 @@ data IState = IState {

210211 idris_name :: Int,

211212 idris_lineapps :: [((FilePath, Int), PTerm)],

212213 -- ^ Full application LHS on source line

213− idris_metavars :: [(Name, (Maybe Name, Int, [Name], Bool))],

214+ idris_metavars :: [(Name, (Maybe Name, Int, [Name], Bool, Bool))],

214215 -- ^ The currently defined but not proven metavariables. The Int

215216 -- is the number of vars to display as a context, the Maybe Name

216217 -- is its top-level function, the [Name] is the list of local variables

217− -- available for proof search and the Bool is whether :p is

218− -- allowed

218+ -- available for proof search and the Bools are whether :p is

219+ -- allowed, and whether the variable is definable at all

220+ -- (Metavariables are not definable if they are applied in a term which

221+ -- still has hole bindings)

219222 idris_coercions :: [Name],

220223 idris_errRev :: [(Term, Term)],

221224 syntax_rules :: SyntaxRules,

@@ -235,7 +238,7 @@ data IState = IState {

235238 brace_stack :: [Maybe Int],

236239 lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

237240 idris_parsedSpan :: Maybe FC,

238− hide_list :: [(Name, Maybe Accessibility)],

241+ hide_list :: Ctxt Accessibility,

239242 default_access :: Accessibility,

240243 default_total :: Bool,

241244 ibc_write :: [IBCWrite],

@@ -262,7 +265,9 @@ data IState = IState {

262265 idris_exports :: [Name], -- ^ Functions with ExportList

263266 idris_highlightedRegions :: [(FC, OutputAnnotation)], -- ^ Highlighting information to output

264267 idris_parserHighlights :: [(FC, OutputAnnotation)], -- ^ Highlighting information from the parser

265− idris_deprecated :: Ctxt String -- ^ Deprecated names and explanation

268+ idris_deprecated :: Ctxt String, -- ^ Deprecated names and explanation

269+ idris_inmodule :: S.Set Name, -- ^ Names defined in current module

270+ idris_ttstats :: M.Map Term (Int, Term)

266271 }

267272

268273-- Required for parsers library, and therefore trifecta

@@ -279,11 +284,10 @@ deriving instance NFData SizeChange

279284type SCGEntry = (Name, [Maybe (Int, SizeChange)])

280285type UsageReason = (Name, Int) -- fn_name, its_arg_number

281286

282−data CGInfo = CGInfo { argsdef :: [Name],

283− calls :: [(Name, [[Name]])],

287+data CGInfo = CGInfo { calls :: [Name],

284288 scg :: [SCGEntry],

285− argsused :: [Name],

286− usedpos :: [(Int, [UsageReason])] }

289+ usedpos :: [(Int, [UsageReason])]

290+ }

287291 deriving Show

288292{-!

289293deriving instance Binary CGInfo

@@ -348,12 +352,13 @@ idrisInit = IState initContext S.empty []

348352 emptyContext emptyContext emptyContext emptyContext

349353 emptyContext emptyContext emptyContext emptyContext

350354 emptyContext emptyContext emptyContext emptyContext

351− emptyContext emptyContext

355+ emptyContext

352356 [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] []

353− [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []

357+ [] [] Nothing [] Nothing [] [] Nothing Nothing emptyContext Private False [] Nothing [] []

354358 (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty

355359 AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []

356− emptyContext

360+ emptyContext S.empty M.empty

361+

357362

358363-- | The monad for the main REPL - reading and processing files and updating

359364-- global state (hence the IO inner monad).

@@ -631,13 +636,17 @@ is_scoped :: Plicity -> Maybe ImplicitInfo

631636is_scoped (Imp _ _ _ s) = s

632637is_scoped _ = Nothing

633638

634−impl = Imp [] Dynamic False (Just (Impl False True))

635−forall_imp = Imp [] Dynamic False (Just (Impl False False))

639+impl = Imp [] Dynamic False (Just (Impl False True))

640+

641+forall_imp = Imp [] Dynamic False (Just (Impl False False))

636642forall_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

643+

644+expl = Exp [] Dynamic False

645+expl_param = Exp [] Dynamic True

646+

647+constraint = Constraint [] Static

648+

649+tacimpl t = TacImp [] Dynamic t

641650

642651data FnOpt = Inlinable -- always evaluate when simplifying

643652 | TotalFn | PartialFn | CoveringFn

@@ -695,7 +704,7 @@ data PDecl' t

695704 FC -- Record name precise location

696705 [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span

697706 [(Name, Docstring (Either Err t))] -- Param Docs

698− [((Maybe (Name, FC)), Plicity, t, Maybe (Docstring (Either Err t)))] -- Fields

707+ [(Maybe (Name, FC), Plicity, t, Maybe (Docstring (Either Err t)))] -- Fields

699708 (Maybe (Name, FC)) -- Optional constructor name and location

700709 (Docstring (Either Err t)) -- Constructor doc

701710 SyntaxInfo -- Constructor SyntaxInfo

@@ -717,6 +726,8 @@ data PDecl' t

717726 [(Name, Docstring (Either Err t))] -- Parameter docs

718727 SyntaxInfo

719728 FC [(Name, t)] -- constraints

729+ Accessibility

730+ FnOpts

720731 Name -- class

721732 FC -- precise location of class

722733 [t] -- parameters

@@ -756,6 +767,7 @@ data Directive = DLib Codegen String |

756767 DErrorHandlers Name FC Name FC [(Name, FC)] |

757768 DLanguage LanguageExt |

758769 DDeprecate Name String |

770+ DAutoImplicits Bool |

759771 DUsed FC Name Name

760772

761773-- | A set of instructions for things that need to happen in IState

@@ -763,6 +775,9 @@ data Directive = DLib Codegen String |

763775data RDeclInstructions = RTyDeclInstrs Name FC [PArg] Type

764776 | RClausesInstrs Name [([(Name, Term)], Term, Term)]

765777 | RAddInstance Name Name

778+ | RDatatypeDeclInstrs Name [PArg]

779+ | RDatatypeDefnInstrs Name Type [(Name, [PArg], Type)]

780+ -- ^ Datatype, constructors

766781

767782-- | For elaborator state

768783data EState = EState {

@@ -875,10 +890,10 @@ mapPDeclFC f g (PClass doc syn fc constrs n nfc params paramDocs det body ctor c

875890 (map (mapPDeclFC f g) body)

876891 (fmap (\(n, nfc) -> (n, g nfc)) ctor)

877892 ctorDoc

878−mapPDeclFC f g (PInstance doc paramDocs syn fc constrs cn cnfc params instTy instN body) =

893+mapPDeclFC f g (PInstance doc paramDocs syn fc constrs cn acc opts cnfc params instTy instN body) =

879894 PInstance doc paramDocs syn (f fc)

880895 (map (\(constrN, constrT) -> (constrN, mapPTermFC f g constrT)) constrs)

881− cn (g cnfc) (map (mapPTermFC f g) params)

896+ cn acc opts (g cnfc) (map (mapPTermFC f g) params)

882897 (mapPTermFC f g instTy)

883898 instN

884899 (map (mapPDeclFC f g) body)

@@ -918,7 +933,7 @@ declared (PParams _ _ ds) = concatMap declared ds

918933declared (PNamespace _ _ ds) = concatMap declared ds

919934declared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

920935declared (PClass _ _ _ _ n _ _ _ _ ms cn cd) = n : (map fst (maybeToList cn) ++ concatMap declared ms)

921−declared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

936+declared (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = []

922937declared (PDSL n _) = [n]

923938declared (PSyntax _ _) = []

924939declared (PMutual _ ds) = concatMap declared ds

@@ -927,39 +942,39 @@ declared _ = []

927942

928943-- get the names declared, not counting nested parameter blocks

929944tldeclared :: 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)

945+tldeclared (PFix _ _ _) = []

946+tldeclared (PTy _ _ _ _ _ n _ t) = [n]

947+tldeclared (PPostulate _ _ _ _ _ _ n t) = [n]

948+tldeclared (PClauses _ _ n _) = [] -- not a declaration

949+tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

935950tldeclared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

936951 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 _ = []

952+tldeclared (PParams _ _ ds) = []

953+tldeclared (PMutual _ ds) = concatMap tldeclared ds

954+tldeclared (PNamespace _ _ ds) = concatMap tldeclared ds

955+tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)

956+tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = []

957+tldeclared _ = []

943958

944959defined :: 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

960+defined (PFix _ _ _) = []

961+defined (PTy _ _ _ _ _ n _ t) = []

962+defined (PPostulate _ _ _ _ _ _ n t) = []

963+defined (PClauses _ _ n _) = [n] -- not a declaration

964+defined (PCAF _ n _) = [n]

965+defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

951966 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 _ = []

967+defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = []

968+defined (PParams _ _ ds) = concatMap defined ds

969+defined (PNamespace _ _ ds) = concatMap defined ds

970+defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

971+defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)

972+defined (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = []

973+defined (PDSL n _) = [n]

974+defined (PSyntax _ _) = []

975+defined (PMutual _ ds) = concatMap defined ds

976+defined (PDirective _) = []

977+defined _ = []

963978

964979updateN :: [(Name, Name)] -> Name -> Name

965980updateN ns n | Just n' <- lookup n ns = n'

@@ -1040,33 +1055,33 @@ data PAltType = ExactlyOne Bool -- ^ flag sets whether delay is allowed

10401055-- general-purpose FCs, and the second transforms those that are used

10411056-- for semantic source highlighting, so they can be treated specially.

10421057mapPTermFC :: (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

1058+mapPTermFC f g (PQuote q) = PQuote q

1059+mapPTermFC f g (PRef fc fcs n) = PRef (g fc) (map g fcs) n

1060+mapPTermFC f g (PInferRef fc fcs n) = PInferRef (g fc) (map g fcs) n

1061+mapPTermFC f g (PPatvar fc n) = PPatvar (g fc) n

1062+mapPTermFC f g (PLam fc n fc' t1 t2) = PLam (f fc) n (g fc') (mapPTermFC f g t1) (mapPTermFC f g t2)

1063+mapPTermFC f g (PPi plic n fc t1 t2) = PPi plic n (g fc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1064+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)

1065+mapPTermFC f g (PTyped t1 t2) = PTyped (mapPTermFC f g t1) (mapPTermFC f g t2)

1066+mapPTermFC f g (PApp fc t args) = PApp (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)

1067+mapPTermFC f g (PAppImpl t1 impls) = PAppImpl (mapPTermFC f g t1) impls

1068+mapPTermFC f g (PAppBind fc t args) = PAppBind (f fc) (mapPTermFC f g t) (map (fmap (mapPTermFC f g)) args)

1069+mapPTermFC f g (PMatchApp fc n) = PMatchApp (f fc) n

1070+mapPTermFC f g (PIfThenElse fc t1 t2 t3) = PIfThenElse (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (mapPTermFC f g t3)

1071+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)

1072+mapPTermFC f g (PTrue fc info) = PTrue (f fc) info

1073+mapPTermFC f g (PResolveTC fc) = PResolveTC (f fc)

1074+mapPTermFC f g (PRewrite fc t1 t2 t3) = PRewrite (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (fmap (mapPTermFC f g) t3)

1075+mapPTermFC f g (PPair fc hls info t1 t2) = PPair (f fc) (map g hls) info (mapPTermFC f g t1) (mapPTermFC f g t2)

1076+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)

1077+mapPTermFC f g (PAs fc n t) = PAs (f fc) n (mapPTermFC f g t)

1078+mapPTermFC f g (PAlternative ns ty ts) = PAlternative ns ty (map (mapPTermFC f g) ts)

1079+mapPTermFC f g (PHidden t) = PHidden (mapPTermFC f g t)

1080+mapPTermFC f g (PType fc) = PType (f fc)

1081+mapPTermFC f g (PUniverse u) = PUniverse u

1082+mapPTermFC f g (PGoal fc t1 n t2) = PGoal (f fc) (mapPTermFC f g t1) n (mapPTermFC f g t2)

1083+mapPTermFC f g (PConstant fc c) = PConstant (f fc) c

1084+mapPTermFC f g Placeholder = Placeholder

10701085mapPTermFC f g (PDoBlock dos) = PDoBlock (map mapPDoFC dos)

10711086 where mapPDoFC (DoExp fc t) = DoExp (f fc) (mapPTermFC f g t)

10721087 mapPDoFC (DoBind fc n nfc t) = DoBind (f fc) n (g nfc) (mapPTermFC f g t)

@@ -1074,22 +1089,22 @@ mapPTermFC f g (PDoBlock dos) = PDoBlock (map mapPDoFC dos)

10741089 DoBindP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (map (\(l,r)-> (mapPTermFC f g l, mapPTermFC f g r)) alts)

10751090 mapPDoFC (DoLet fc n nfc t1 t2) = DoLet (f fc) n (g nfc) (mapPTermFC f g t1) (mapPTermFC f g t2)

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

1092+mapPTermFC f g (PIdiom fc t) = PIdiom (f fc) (mapPTermFC f g t)

1093+mapPTermFC f g (PReturn fc) = PReturn (f fc)

1094+mapPTermFC f g (PMetavar fc n) = PMetavar (g fc) n

1095+mapPTermFC f g (PProof tacs) = PProof (map (fmap (mapPTermFC f g)) tacs)

1096+mapPTermFC f g (PTactics tacs) = PTactics (map (fmap (mapPTermFC f g)) tacs)

1097+mapPTermFC f g (PElabError err) = PElabError err

1098+mapPTermFC f g PImpossible = PImpossible

1099+mapPTermFC f g (PCoerced t) = PCoerced (mapPTermFC f g t)

1100+mapPTermFC f g (PDisamb msg t) = PDisamb msg (mapPTermFC f g t)

1101+mapPTermFC f g (PUnifyLog t) = PUnifyLog (mapPTermFC f g t)

1102+mapPTermFC f g (PNoImplicits t) = PNoImplicits (mapPTermFC f g t)

1103+mapPTermFC f g (PQuasiquote t1 t2) = PQuasiquote (mapPTermFC f g t1) (fmap (mapPTermFC f g) t2)

1104+mapPTermFC f g (PUnquote t) = PUnquote (mapPTermFC f g t)

1105+mapPTermFC f g (PRunElab fc tm ns) = PRunElab (f fc) (mapPTermFC f g tm) ns

1106+mapPTermFC f g (PConstSugar fc tm) = PConstSugar (g fc) (mapPTermFC f g tm)

1107+mapPTermFC f g (PQuoteName n x fc) = PQuoteName n x (g fc)

10931108

10941109{-!

10951110dg instance Binary PTerm

@@ -1098,28 +1113,27 @@ deriving instance NFData PTerm

10981113

10991114mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

11001115mapPT 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)

1116+ mpt (PLam fc n nfc t s) = PLam fc n nfc (mapPT f t) (mapPT f s)

1117+ mpt (PPi p n nfc t s) = PPi p n nfc (mapPT f t) (mapPT f s)

1118+ mpt (PLet fc n nfc ty v s) = PLet fc n nfc (mapPT f ty) (mapPT f v) (mapPT f s)

1119+ mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s) (fmap (mapPT f) g)

1120+ mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)

1121+ mpt (PAppBind fc t as) = PAppBind fc (mapPT f t) (map (fmap (mapPT f)) as)

1122+ mpt (PCase fc c os) = PCase fc (mapPT f c) (map (pmap (mapPT f)) os)

1123+ mpt (PIfThenElse fc c t e) = PIfThenElse fc (mapPT f c) (mapPT f t) (mapPT f e)

1124+ mpt (PTyped l r) = PTyped (mapPT f l) (mapPT f r)

1125+ mpt (PPair fc hls p l r) = PPair fc hls p (mapPT f l) (mapPT f r)

11121126 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

1127+ mpt (PAlternative ns a as) = PAlternative ns a (map (mapPT f) as)

1128+ mpt (PHidden t) = PHidden (mapPT f t)

1129+ mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds)

1130+ mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

1131+ mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

1132+ mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

1133+ mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)

1134+ mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

1135+ mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

1136+ mpt x = x

11231137

11241138

11251139data PTactic' t = Intro [Name] | Intros | Focus Name

@@ -1160,39 +1174,39 @@ deriving instance Binary PTactic'

11601174deriving instance NFData PTactic'

11611175!-}

11621176instance 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

1177+ size (Intro nms) = 1 + size nms

1178+ size Intros = 1

1179+ size (Focus nm) = 1 + size nm

1180+ size (Refine nm bs) = 1 + size nm + length bs

1181+ size (Rewrite t) = 1 + size t

1182+ size (Induction t) = 1 + size t

1183+ size (LetTac nm t) = 1 + size nm + size t

1184+ size (Exact t) = 1 + size t

1185+ size Compute = 1

1186+ size Trivial = 1

1187+ size Solve = 1

1188+ size Attack = 1

1189+ size ProofState = 1

1190+ size ProofTerm = 1

1191+ size Undo = 1

1192+ size (Try l r) = 1 + size l + size r

1193+ size (TSeq l r) = 1 + size l + size r

1194+ size (ApplyTactic t) = 1 + size t

1195+ size (Reflect t) = 1 + size t

1196+ size (Fill t) = 1 + size t

1197+ size Qed = 1

1198+ size Abandon = 1

1199+ size Skip = 1

1200+ size (TFail ts) = 1 + size ts

1201+ size SourceFC = 1

1202+ size DoUnify = 1

1203+ size (CaseTac x) = 1 + size x

1204+ size (Equiv t) = 1 + size t

1205+ size (Claim x y) = 1 + size x + size y

1206+ size Unfocus = 1

1207+ size (MatchRefine x) = 1 + size x

11941208 size (LetTacTy x y z) = 1 + size x + size y + size z

1195− size TCInstance = 1

1209+ size TCInstance = 1

11961210

11971211type PTactic = PTactic' PTerm

11981212

@@ -1208,11 +1222,11 @@ deriving instance NFData PDo'

12081222!-}

12091223

12101224instance 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

1225+ size (DoExp fc t) = 1 + size fc + size t

1226+ size (DoBind fc nm nfc t) = 1 + size fc + size nm + size nfc + size t

1227+ size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts

1228+ size (DoLet fc nm nfc l r) = 1 + size fc + size nm + size l + size r

1229+ size (DoLetP fc l r) = 1 + size fc + size l + size r

12161230

12171231type PDo = PDo' PTerm

12181232

@@ -1244,10 +1258,10 @@ data ArgOpt = AlwaysShow | HideDisplay | InaccessibleArg | UnknownImp

12441258 deriving (Show, Eq, Data, Typeable)

12451259

12461260instance 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

1261+ size (PImp p _ l nm trm) = 1 + size nm + size trm

1262+ size (PExp p l nm trm) = 1 + size nm + size trm

1263+ size (PConstraint p l nm trm) = 1 + size nm +size nm + size trm

1264+ size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

12511265

12521266{-!

12531267deriving instance Binary PArg'

@@ -1255,43 +1269,43 @@ deriving instance NFData PArg'

12551269!-}

12561270

12571271pimp 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

1272+pexp t = PExp 1 [] (sMN 0 "arg") t

1273+pconst t = PConstraint 1 [] (sMN 0 "carg") t

12601274ptacimp n s t = PTacImplicit 2 [] n s t

12611275

12621276type PArg = PArg' PTerm

12631277

12641278-- | Get the highest FC in a term, if one exists

12651279highestFC :: 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

1280+highestFC (PQuote _) = Nothing

1281+highestFC (PRef fc _ _) = Just fc

1282+highestFC (PInferRef fc _ _) = Just fc

1283+highestFC (PPatvar fc _) = Just fc

1284+highestFC (PLam fc _ _ _ _) = Just fc

1285+highestFC (PPi _ _ _ _ _) = Nothing

1286+highestFC (PLet fc _ _ _ _ _) = Just fc

1287+highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty

1288+highestFC (PApp fc _ _) = Just fc

1289+highestFC (PAppBind fc _ _) = Just fc

1290+highestFC (PMatchApp fc _) = Just fc

1291+highestFC (PCase fc _ _) = Just fc

1292+highestFC (PIfThenElse fc _ _ _) = Just fc

1293+highestFC (PTrue fc _) = Just fc

1294+highestFC (PResolveTC fc) = Just fc

1295+highestFC (PRewrite fc _ _ _) = Just fc

1296+highestFC (PPair fc _ _ _ _) = Just fc

1297+highestFC (PDPair fc _ _ _ _ _) = Just fc

1298+highestFC (PAs fc _ _) = Just fc

12851299highestFC (PAlternative _ _ args) =

12861300 case mapMaybe highestFC args of

12871301 [] -> Nothing

12881302 (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

1303+highestFC (PHidden _) = Nothing

1304+highestFC (PType fc) = Just fc

1305+highestFC (PUniverse _) = Nothing

1306+highestFC (PGoal fc _ _ _) = Just fc

1307+highestFC (PConstant fc _) = Just fc

1308+highestFC Placeholder = Nothing

12951309highestFC (PDoBlock lines) =

12961310 case map getDoFC lines of

12971311 [] -> Nothing

@@ -1303,23 +1317,23 @@ highestFC (PDoBlock lines) =

13031317 getDoFC (DoLet fc nm nfc l r) = fc

13041318 getDoFC (DoLetP fc l r) = fc

13051319

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

1320+highestFC (PIdiom fc _) = Just fc

1321+highestFC (PReturn fc) = Just fc

1322+highestFC (PMetavar fc _) = Just fc

1323+highestFC (PProof _) = Nothing

1324+highestFC (PTactics _) = Nothing

1325+highestFC (PElabError _) = Nothing

1326+highestFC PImpossible = Nothing

1327+highestFC (PCoerced tm) = highestFC tm

1328+highestFC (PDisamb _ opts) = highestFC opts

1329+highestFC (PUnifyLog tm) = highestFC tm

1330+highestFC (PNoImplicits tm) = highestFC tm

1331+highestFC (PQuasiquote _ _) = Nothing

1332+highestFC (PUnquote tm) = highestFC tm

1333+highestFC (PQuoteName _ _ fc) = Just fc

1334+highestFC (PRunElab fc _ _) = Just fc

1335+highestFC (PConstSugar fc _) = Just fc

1336+highestFC (PAppImpl t _) = highestFC t

13231337

13241338-- Type class data

13251339

@@ -1397,11 +1411,11 @@ data Syntax = Rule [SSymbol] PTerm SynContext

13971411

13981412syntaxNames :: Syntax -> [Name]

13991413syntaxNames (Rule syms _ _) = mapMaybe ename syms

1400− where ename (Keyword n) = Just n

1401− ename _ = Nothing

1414+ where ename (Keyword n) = Just n

1415+ ename _ = Nothing

14021416syntaxNames (DeclRule syms _) = mapMaybe ename syms

1403− where ename (Keyword n) = Just n

1404− ename _ = Nothing

1417+ where ename (Keyword n) = Just n

1418+ ename _ = Nothing

14051419

14061420syntaxSymbols :: Syntax -> [SSymbol]

14071421syntaxSymbols (Rule ss _ _) = ss

@@ -1434,9 +1448,9 @@ updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules

14341448 where

14351449 newRules = sortBy (ruleSort `on` syntaxSymbols) (rules ++ sr)

14361450

1437− ruleSort [] [] = EQ

1438− ruleSort [] _ = LT

1439− ruleSort _ [] = GT

1451+ ruleSort [] [] = EQ

1452+ ruleSort [] _ = LT

1453+ ruleSort _ [] = GT

14401454 ruleSort (s1:ss1) (s2:ss2) =

14411455 case symCompare s1 s2 of

14421456 EQ -> ruleSort ss1 ss2

@@ -1444,25 +1458,25 @@ updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules

14441458

14451459 -- Better than creating Ord instance for SSymbol since

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

1461+ symCompare (Keyword n1) (Keyword n2) = compare n1 n2

1462+ symCompare (Keyword _) _ = LT

1463+ symCompare (Symbol _) (Keyword _) = GT

1464+ symCompare (Symbol s1) (Symbol s2) = compare s1 s2

1465+ symCompare (Symbol _) _ = LT

1466+ symCompare (Binding _) (Keyword _) = GT

1467+ symCompare (Binding _) (Symbol _) = GT

1468+ symCompare (Binding b1) (Binding b2) = compare b1 b2

1469+ symCompare (Binding _) _ = LT

1470+ symCompare (Expr _) (Keyword _) = GT

1471+ symCompare (Expr _) (Symbol _) = GT

1472+ symCompare (Expr _) (Binding _) = GT

1473+ symCompare (Expr e1) (Expr e2) = compare e1 e2

1474+ symCompare (Expr _) _ = LT

1475+ symCompare (SimpleExpr _) (Keyword _) = GT

1476+ symCompare (SimpleExpr _) (Symbol _) = GT

1477+ symCompare (SimpleExpr _) (Binding _) = GT

1478+ symCompare (SimpleExpr _) (Expr _) = GT

1479+ symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2

14661480

14671481initDSL = DSL (PRef f [] (sUN ">>="))

14681482 (PRef f [] (sUN "return"))

@@ -1534,10 +1548,10 @@ getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc

15341548getInferTerm (App _ (App _ _ _) tm) = tm

15351549getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)

15361550

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

1551+getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

1552+ where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

1553+ toTy (PVar t) = PVTy t

1554+ toTy b = b

15411555getInferType (App _ (App _ _ ty) _) = ty

15421556

15431557

@@ -1562,9 +1576,9 @@ pairCon = sNS (sUN "MkPair") ["Builtins"]

15621576upairTy = sNS (sUN "UPair") ["Builtins"]

15631577upairCon = sNS (sUN "MkUPair") ["Builtins"]

15641578

1565−eqTy = sUN "="

1579+eqTy = sUN "="

15661580eqCon = sUN "Refl"

1567−eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

1581+eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

15681582 "The propositional equality type. A proof that `x` = `y`." ++

15691583 "\n\n" ++

15701584 "To use such a proof, pattern-match on it, and the two equal things will " ++

@@ -1607,8 +1621,8 @@ modDocName :: Name

16071621modDocName = sMN 0 "ModuleDocs"

16081622

16091623-- Defined in builtins.idr

1610−sigmaTy = sNS (sUN "Sigma") ["Builtins"]

1611−sigmaCon = sNS (sUN "MkSigma") ["Builtins"]

1624+sigmaTy = sNS (sUN "DPair") ["Builtins"]

1625+sigmaCon = sNS (sUN "MkDPair") ["Builtins"]

16121626

16131627piBind :: [(Name, PTerm)] -> PTerm -> PTerm

16141628piBind = piBindp expl

@@ -1648,11 +1662,11 @@ annotationColour ist (AnnConst c) =

16481662 in Just $ if constIsType c

16491663 then typeColour theme

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

1665+annotationColour ist (AnnData _ _) = Just $ dataColour (idris_colourTheme ist)

1666+annotationColour ist (AnnType _ _) = Just $ typeColour (idris_colourTheme ist)

1667+annotationColour ist (AnnBoundName _ True) = Just $ implicitColour (idris_colourTheme ist)

16541668annotationColour ist (AnnBoundName _ False) = Just $ boundVarColour (idris_colourTheme ist)

1655−annotationColour ist AnnKeyword = Just $ keywordColour (idris_colourTheme ist)

1669+annotationColour ist AnnKeyword = Just $ keywordColour (idris_colourTheme ist)

16561670annotationColour ist (AnnName n _ _ _) =

16571671 let ctxt = tt_ctxt ist

16581672 theme = idris_colourTheme ist

@@ -1738,7 +1752,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

17381752

17391753 st =

17401754 case s of

1741− Static -> text "[static]" <> space

1755+ Static -> text "%static" <> space

17421756 _ -> empty

17431757 prettySe d p bnd (PPi (Imp l s _ fa) n _ ty sc)

17441758 | ppopt_impl ppo =

@@ -1749,12 +1763,12 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

17491763 where

17501764 st =

17511765 case s of

1752− Static -> text "[static]" <> space

1766+ Static -> text "%static" <> space

17531767 _ -> empty

17541768 prettySe d p bnd (PPi (Constraint _ _) n _ ty sc) =

17551769 depth d . bracket p startPrec $

17561770 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) =

1771+ prettySe d p bnd (PPi (TacImp _ _ (PTactics [ProofSearch{}])) n _ ty sc) =

17581772 lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>

17591773 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc

17601774 prettySe d p bnd (PPi (TacImp _ _ s) n _ ty sc) =

@@ -1791,7 +1805,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

17911805 [x] -> group (opName True <$> group (prettySe (decD d) startPrec bnd (getTm x)))

17921806 [l,r] -> let precedence = maybe (startPrec - 1) prec f

17931807 in depth d . bracket p precedence $ inFix (getTm l) (getTm r)

1794− (l@(PExp _ _ _ _) : r@(PExp _ _ _ _) : rest) ->

1808+ (l@(PExp{}) : r@(PExp{}) : rest) ->

17951809 depth d . bracket p funcAppPrec $

17961810 enclose lparen rparen (inFix (getTm l) (getTm r)) <+>

17971811 align (group (vsep (map (prettyArgS d bnd) rest)))

@@ -1842,20 +1856,20 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

18421856 -- disambiguation on PDPair.

18431857 vars tm = filter noNS (allNamesIn tm)

18441858 noNS (NS _ _) = False

1845− noNS _ = True

1859+ noNS _ = True

18461860

18471861 prettySe d p bnd (PIfThenElse _ c t f) =

18481862 depth d . bracket p funcAppPrec . group . align . hang 2 . vsep $

1849− [ kwd "if" <+> prettySe (decD d) startPrec bnd c

1863+ [ kwd "if" <+> prettySe (decD d) startPrec bnd c

18501864 , kwd "then" <+> prettySe (decD d) startPrec bnd t

18511865 , kwd "else" <+> prettySe (decD d) startPrec bnd f

18521866 ]

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 "()"

1867+ prettySe d p bnd (PHidden tm) = text "." <> prettySe (decD d) funcAppPrec bnd tm

1868+ prettySe d p bnd (PResolveTC _) = kwd "%instance"

1869+ prettySe d p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1870+ prettySe d p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

18571871 prettySe d p bnd (PTrue _ TypeOrTerm) = text "()"

1858− prettySe d p bnd (PRewrite _ l r _) =

1872+ prettySe d p bnd (PRewrite _ l r _) =

18591873 depth d . bracket p startPrec $

18601874 text "rewrite" <+> prettySe (decD d) (startPrec + 1) bnd l <+> text "in" <+> prettySe (decD d) startPrec bnd r

18611875 prettySe d p bnd (PTyped l r) =

@@ -1865,9 +1879,9 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

18651879 align . group . vsep . punctuate (ann comma) $

18661880 map (prettySe (decD d) startPrec bnd) elts

18671881 where ann = case pun of

1868− TypeOrTerm -> id

1869− IsType -> annName pairTy

1870− IsTerm -> annName pairCon

1882+ TypeOrTerm -> id

1883+ IsType -> annName pairTy

1884+ IsTerm -> annName pairCon

18711885 prettySe d p bnd (PDPair _ _ pun l t r) =

18721886 depth d $

18731887 annotated lparen <>

@@ -1876,30 +1890,32 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

18761890 prettySe (decD d) startPrec (addBinding bnd) r <>

18771891 annotated rparen

18781892 where annotated = case pun of

1879− IsType -> annName sigmaTy

1880− IsTerm -> annName sigmaCon

1881− TypeOrTerm -> id

1893+ IsType -> annName sigmaTy

1894+ IsTerm -> annName sigmaCon

1895+ TypeOrTerm -> id

18821896 (left, addBinding) = case (l, pun) of

18831897 (PRef _ _ n, IsType) -> (bindingOf n False <+> text ":" <+> prettySe (decD d) startPrec bnd t, ((n, False) :))

1884− _ -> (prettySe (decD d) startPrec bnd l, id)

1898+ _ -> (prettySe (decD d) startPrec bnd l, id)

18851899 prettySe d p bnd (PAlternative ns a as) =

18861900 lparen <> text "|" <> prettyAs <> text "|" <> rparen

18871901 where

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

1903+ foldr ((\ l r -> l <+> text "," <+> r) .

1904+ depth d . prettySe (decD d) startPrec bnd)

1905+ empty as

1906+ prettySe d p bnd (PType _) = annotate (AnnType "Type" "The type of types") $ text "Type"

1907+ prettySe d p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u)

1908+ prettySe d p bnd (PConstant _ c) = annotate (AnnConst c) (text (show c))

18931909 -- XXX: add pretty for tactics

1894− prettySe d p bnd (PProof ts) =

1910+ prettySe d p bnd (PProof ts) =

18951911 kwd "proof" <+> lbrace <> ellipsis <> rbrace

1896− prettySe d p bnd (PTactics ts) =

1912+ prettySe d p bnd (PTactics ts) =

18971913 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) =

1914+ prettySe d p bnd (PMetavar _ n) = annotate (AnnName n (Just MetavarOutput) Nothing Nothing) $ text "?" <> pretty n

1915+ prettySe d p bnd (PReturn f) = kwd "return"

1916+ prettySe d p bnd PImpossible = kwd "impossible"

1917+ prettySe d p bnd Placeholder = text "_"

1918+ prettySe d p bnd (PDoBlock dos) =

19031919 bracket p startPrec $

19041920 kwd "do" <+> align (vsep (map (group . align . hang 2) (ppdo bnd dos)))

19051921 where ppdo bnd (DoExp _ tm:dos) = prettySe (decD d) startPrec bnd tm : ppdo bnd dos

@@ -1921,47 +1937,46 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

19211937 text "no pretty printer for pattern-matching do binding" :

19221938 ppdo bnd dos

19231939 ppdo _ [] = []

1924− prettySe d p bnd (PCoerced t) = prettySe d p bnd t

1925− prettySe d p bnd (PElabError s) = pretty s

1940+ prettySe d p bnd (PCoerced t) = prettySe d p bnd t

1941+ prettySe d p bnd (PElabError s) = pretty s

19261942 -- Quasiquote pprinting ignores bound vars

1927− prettySe d p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe (decD d) p [] t <> text ")"

1943+ prettySe d p bnd (PQuasiquote t Nothing) = text "`(" <> prettySe (decD d) p [] t <> text ")"

19281944 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

1945+ prettySe d p bnd (PUnquote t) = text "~" <> prettySe (decD d) p bnd t

1946+ prettySe d p bnd (PQuoteName n res _) = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end

19311947 where start = if res then "`{" else "`{{"

19321948 end = if res then "}" else "}}"

1933− prettySe d p bnd (PRunElab _ tm _) =

1949+ prettySe d p bnd (PRunElab _ tm _) =

19341950 bracket p funcAppPrec . group . align . hang 2 $

19351951 text "%runElab" <$>

19361952 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"

1953+ prettySe d p bnd (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless

1954+ prettySe d p bnd _ = text "missing pretty-printer for term"

19401955

19411956 prettyBindingOf :: Name -> Bool -> Doc OutputAnnotation

19421957 prettyBindingOf n imp = annotate (AnnBoundName n imp) (text (display n))

19431958 where display (UN n) = T.unpack n

19441959 display (MN _ n) = T.unpack n

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

1961+ display (NS n ns) = (intercalate "." . map T.unpack . reverse) ns ++ "." ++ display n

19471962 display n = show n

19481963

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)

1964+ prettyArgS d bnd (PImp _ _ _ n tm) = prettyArgSi d bnd (n, tm)

1965+ prettyArgS d bnd (PExp _ _ _ tm) = prettyArgSe d bnd tm

1966+ prettyArgS d bnd (PConstraint _ _ _ tm) = prettyArgSc d bnd tm

1967+ prettyArgS d bnd (PTacImplicit _ _ n _ tm) = prettyArgSti d bnd (n, tm)

19531968

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

1969+ prettyArgSe d bnd arg = prettySe d (funcAppPrec + 1) bnd arg

1970+ prettyArgSi d bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

1971+ prettyArgSc d bnd val = lbrace <> lbrace <> prettySe (decD d) startPrec bnd val <> rbrace <> rbrace

19571972 prettyArgSti d bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

19581973

19591974 annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

19601975 annName n = annotate (AnnName n Nothing Nothing Nothing)

19611976

19621977 opStr :: Name -> String

1963− opStr (NS n _) = opStr n

1964− opStr (UN n) = T.unpack n

1978+ opStr (NS n _) = opStr n

1979+ opStr (UN n) = T.unpack n

19651980

19661981 slist' :: Maybe Int -> Int -> [(Name, Bool)] -> PTerm -> Maybe [Doc OutputAnnotation]

19671982 slist' (Just d) _ _ _ | d <= 0 = Nothing

@@ -2023,7 +2038,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

20232038 ellipsis = text "..."

20242039

20252040 depth Nothing = id

2026− depth (Just d) = if d <= 0 then const (ellipsis) else id

2041+ depth (Just d) = if d <= 0 then const ellipsis else id

20272042

20282043 decD = fmap (\x -> x - 1)

20292044

@@ -2038,7 +2053,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

20382053-- | Strip away namespace information

20392054basename :: Name -> Name

20402055basename (NS n _) = basename n

2041−basename n = n

2056+basename n = n

20422057

20432058-- | Determine whether a name was the one inserted for a hole or

20442059-- guess by the delaborator

@@ -2058,15 +2073,15 @@ prettyName

20582073 -> Name -- ^^ the name to pprint

20592074 -> Doc OutputAnnotation

20602075prettyName 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

2076+ | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"

2077+ | (UN n') <- n, T.unpack n' == "_" = text "_"

2078+ | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName

2079+ | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName

20652080 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

2081+ baseName (UN n) = T.unpack n

2082+ baseName (NS n ns) = baseName n

2083+ baseName (MN i s) = T.unpack s

2084+ baseName other = show other

20702085 nameSpace = case n of

20712086 (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else ""

20722087 _ -> ""

@@ -2081,13 +2096,13 @@ showCImp ppo (PClause _ n l ws r w)

20812096 = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r

20822097 <+> text "where" <+> text (show w)

20832098 where

2084− showWs [] = empty

2099+ showWs [] = empty

20852100 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

20862101showCImp ppo (PWith _ n l ws r pn w)

20872102 = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

20882103 <+> braces (text (show w))

20892104 where

2090− showWs [] = empty

2105+ showWs [] = empty

20912106 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

20922107

20932108

@@ -2099,43 +2114,43 @@ showDImp ppo (PDatadecl n nfc ty cons)

20992114showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

21002115showDecls o ds = vsep (map (showDeclImp o) ds)

21012116

2102−showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))

2117+showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))

21032118showDeclImp 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" <+>

2119+showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>

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

2121+showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d

2122+showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)

2123+showDeclImp o (PNamespace n fc ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

21092124showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

21102125showDeclImp o (PClass _ _ _ cs n _ ps _ _ ds _ _)

21112126 = text "interface" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds

2112−showDeclImp o (PInstance _ _ _ _ cs n _ _ t _ ds)

2127+showDeclImp o (PInstance _ _ _ _ cs acc _ n _ _ t _ ds)

21132128 = text "implementation" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

21142129showDeclImp _ _ = text "..."

21152130-- showDeclImp (PImport o) = "import " ++ o

21162131

21172132getImps :: [PArg] -> [(Name, PTerm)]

21182133getImps [] = []

2119−getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

2120−getImps (_ : xs) = getImps xs

2134+getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

2135+getImps (_ : xs) = getImps xs

21212136

21222137getExps :: [PArg] -> [PTerm]

21232138getExps [] = []

2124−getExps (PExp _ _ _ tm : xs) = tm : getExps xs

2125−getExps (_ : xs) = getExps xs

2139+getExps (PExp _ _ _ tm : xs) = tm : getExps xs

2140+getExps (_ : xs) = getExps xs

21262141

21272142getShowArgs :: [PArg] -> [PArg]

21282143getShowArgs [] = []

21292144getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs

21302145getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs

21312146 | PImp _ _ _ _ tm <- e

2132− , containsHole tm = e : getShowArgs xs

2147+ , containsHole tm = e : getShowArgs xs

21332148getShowArgs (_ : xs) = getShowArgs xs

21342149

21352150getConsts :: [PArg] -> [PTerm]

2136−getConsts [] = []

2151+getConsts [] = []

21372152getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

2138−getConsts (_ : xs) = getConsts xs

2153+getConsts (_ : xs) = getConsts xs

21392154

21402155getAll :: [PArg] -> [PTerm]

21412156getAll = map getTm

@@ -2149,13 +2164,13 @@ showName :: Maybe IState -- ^^ the Idris state, for information about names an

21492164 -> Name -- ^^ the term to show

21502165 -> String

21512166showName 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

2167+ Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

2168+ Nothing -> showbasic n

21542169 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

2170+ showbasic n@(UN _) = showCG n

2171+ showbasic (MN i s) = str s

2172+ showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

2173+ showbasic (SN s) = show s

21592174 fst3 (x, _, _) = x

21602175 colourise n t = let ctxt' = fmap tt_ctxt ist in

21612176 case ctxt' of

@@ -2187,42 +2202,42 @@ showTmOpts opt = flip (displayS . renderPretty 1.0 10000000 . prettyImp opt) ""

21872202

21882203

21892204instance 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

2205+ size (PQuote rawTerm) = size rawTerm

2206+ size (PRef fc _ name) = size name

2207+ size (PLam fc name _ ty bdy) = 1 + size ty + size bdy

2208+ size (PPi plicity name fc ty bdy) = 1 + size ty + size fc + size bdy

2209+ size (PLet fc name nfc ty def bdy) = 1 + size ty + size def + size bdy

2210+ size (PTyped trm ty) = 1 + size trm + size ty

2211+ size (PApp fc name args) = 1 + size args

2212+ size (PAppBind fc name args) = 1 + size args

2213+ size (PCase fc trm bdy) = 1 + size trm + size bdy

2214+ size (PIfThenElse fc c t f) = 1 + sum (map size [c, t, f])

2215+ size (PTrue fc _) = 1

2216+ size (PResolveTC fc) = 1

2217+ size (PRewrite fc left right _) = 1 + size left + size right

2218+ size (PPair fc _ _ left right) = 1 + size left + size right

2219+ size (PDPair fs _ _ left ty right) = 1 + size left + size ty + size right

2220+ size (PAlternative _ a alts) = 1 + size alts

2221+ size (PHidden hidden) = size hidden

2222+ size (PUnifyLog tm) = size tm

2223+ size (PDisamb _ tm) = size tm

2224+ size (PNoImplicits tm) = size tm

2225+ size (PType _) = 1

2226+ size (PUniverse _) = 1

2227+ size (PConstant fc const) = 1 + size fc + size const

2228+ size Placeholder = 1

2229+ size (PDoBlock dos) = 1 + size dos

2230+ size (PIdiom fc term) = 1 + size term

2231+ size (PReturn fc) = 1

2232+ size (PMetavar _ name) = 1

2233+ size (PProof tactics) = size tactics

2234+ size (PElabError err) = size err

2235+ size PImpossible = 1

2236+ size _ = 0

22222237

22232238getPArity :: PTerm -> Int

2224−getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

2225−getPArity _ = 0

2239+getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

2240+getPArity _ = 0

22262241

22272242-- Return all names, free or globally bound, in the given term.

22282243

@@ -2230,31 +2245,30 @@ allNamesIn :: PTerm -> [Name]

22302245allNamesIn tm = nub $ ni 0 [] tm

22312246 where -- TODO THINK added niTacImp, but is it right?

22322247 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

2248+ | not (n `elem` env) = [n]

2249+ ni 0 env (PPatvar _ n) = [n]

2250+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2251+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2252+ ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env . snd) os

2253+ ni 0 env (PIfThenElse _ c t f) = ni 0 env c ++ ni 0 env t ++ ni 0 env f

2254+ ni 0 env (PLam fc n _ ty sc) = ni 0 env ty ++ ni 0 (n:env) sc

2255+ ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2256+ ni 0 env (PLet _ n _ ty val sc) = ni 0 env ty ++ ni 0 env val ++ ni 0 (n:env) sc

2257+ ni 0 env (PHidden tm) = ni 0 env tm

2258+ ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2259+ ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r

2260+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2261+ ni 0 env (PDPair _ _ _ (PRef _ _ n) Placeholder r) = n : ni 0 env r

2262+ ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2263+ ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

2264+ ni 0 env (PAlternative ns a ls) = concatMap (ni 0 env) ls

2265+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2266+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2267+ ni 0 env (PNoImplicits tm) = ni 0 env tm

22562268

2257− ni i env tm = concatMap (ni i env) (children tm)

2269+ ni i env (PQuasiquote tm ty) = ni (i+1) env tm ++ maybe [] (ni i env) ty

2270+ ni i env (PUnquote tm) = ni (i - 1) env tm

2271+ ni i env tm = concatMap (ni i env) (children tm)

22582272

22592273 niTacImp i env (TacImp _ _ scr) = ni i env scr

22602274 niTacImp _ _ _ = []

@@ -2265,32 +2279,32 @@ boundNamesIn :: PTerm -> [Name]

22652279boundNamesIn tm = S.toList (ni 0 S.empty tm)

22662280 where -- TODO THINK Added niTacImp, but is it right?

22672281 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

2282+ ni 0 set (PApp _ f as) = niTms 0 (ni 0 set f) (map getTm as)

2283+ ni 0 set (PAppBind _ f as) = niTms 0 (ni 0 set f) (map getTm as)

2284+ ni 0 set (PCase _ c os) = niTms 0 (ni 0 set c) (map snd os)

2285+ ni 0 set (PIfThenElse _ c t f) = niTms 0 set [c, t, f]

2286+ ni 0 set (PLam fc n _ ty sc) = S.insert n $ ni 0 (ni 0 set ty) sc

2287+ ni 0 set (PLet fc n nfc ty val sc) = S.insert n $ ni 0 (ni 0 (ni 0 set ty) val) sc

2288+ ni 0 set (PPi p n _ ty sc) = niTacImp 0 (S.insert n $ ni 0 (ni 0 set ty) sc) p

2289+ ni 0 set (PRewrite _ l r _) = ni 0 (ni 0 set l) r

2290+ ni 0 set (PTyped l r) = ni 0 (ni 0 set l) r

2291+ ni 0 set (PPair _ _ _ l r) = ni 0 (ni 0 set l) r

22782292 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

2293+ ni 0 set (PDPair _ _ _ l t r) = ni 0 (ni 0 (ni 0 set l) t) r

2294+ ni 0 set (PAlternative ns a as) = niTms 0 set as

2295+ ni 0 set (PHidden tm) = ni 0 set tm

2296+ ni 0 set (PUnifyLog tm) = ni 0 set tm

2297+ ni 0 set (PDisamb _ tm) = ni 0 set tm

2298+ ni 0 set (PNoImplicits tm) = ni 0 set tm

22852299

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

2300+ ni i set (PQuasiquote tm ty) = ni (i + 1) set tm `S.union` maybe S.empty (ni i set) ty

2301+ ni i set (PUnquote tm) = ni (i - 1) set tm

22882302

2289− ni i set tm = foldr S.union set (map (ni i set) (children tm))

2303+ ni i set tm = foldr (S.union . ni i set) set (children tm)

22902304

22912305 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

2306+ niTms i set [] = set

2307+ niTms i set (x : xs) = niTms i (ni i set x) xs

22942308

22952309 niTacImp i set (TacImp _ _ scr) = ni i set scr

22962310 niTacImp i set _ = set

@@ -2306,18 +2320,19 @@ implicitNamesIn uvars ist tm

23062320 addFn n = do (imps, fns) <- get

23072321 put (imps, n: fns)

23082322

2309− notCAF [] = False

2323+ notCAF [] = False

23102324 notCAF (PExp _ _ _ _ : _) = True

2311− notCAF (_ : xs) = notCAF xs

2325+ notCAF (_ : xs) = notCAF xs

23122326

23132327 notHidden (n, _) = case getAccessibility n of

2314− Hidden -> False

2315− _ -> True

2328+ Hidden -> False

2329+ Private -> False

2330+ _ -> True

23162331

23172332 getAccessibility n

23182333 = case lookupDefAccExact n False (tt_ctxt ist) of

2319− Just (n,t) -> t

2320− _ -> Public

2334+ Just (n,t) -> t

2335+ _ -> Public

23212336

23222337 ni 0 env (PRef _ _ n@(NS _ _))

23232338 | not (n `elem` env)

@@ -2327,44 +2342,44 @@ implicitNamesIn uvars ist tm

23272342 | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n

23282343 ni 0 env (PApp _ f@(PRef _ _ n) as)

23292344 | n `elem` uvars = do ni 0 env f

2330− mapM_ (ni 0 env) (map getTm as)

2345+ mapM_ (ni 0 env . getTm) as

23312346 | otherwise = do case lookupTy n (tt_ctxt ist) of

2332− [] -> return ()

2333− _ -> addFn n

2334− mapM_ (ni 0 env) (map getTm as)

2347+ [] -> return ()

2348+ _ -> addFn n

2349+ mapM_ (ni 0 env . getTm) as

23352350 ni 0 env (PApp _ f as) = do ni 0 env f

2336− mapM_ (ni 0 env) (map getTm as)

2351+ mapM_ (ni 0 env . getTm) as

23372352 ni 0 env (PAppBind _ f as) = do ni 0 env f

2338− mapM_ (ni 0 env) (map getTm as)

2353+ mapM_ (ni 0 env . getTm) as

23392354 ni 0 env (PCase _ c os) = do ni 0 env c

23402355 -- names in 'os', not counting the names bound in the cases

2341− mapM_ (ni 0 env) (map snd os)

2356+ mapM_ (ni 0 env . snd) os

23422357 (imps, fns) <- get

23432358 put ([] ,[])

2344− mapM_ (ni 0 env) (map fst os)

2359+ mapM_ (ni 0 env . fst) os

23452360 (impsfst, _) <- get

23462361 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

2362+ ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f]

2363+ ni 0 env (PLam fc n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc

2364+ ni 0 env (PPi p n _ ty sc) = do ni 0 env ty; ni 0 (n:env) sc

2365+ ni 0 env (PRewrite _ l r _) = do ni 0 env l; ni 0 env r

2366+ ni 0 env (PTyped l r) = do ni 0 env l; ni 0 env r

2367+ ni 0 env (PPair _ _ _ l r) = do ni 0 env l; ni 0 env r

2368+ ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = do ni 0 env t; ni 0 (n:env) r

2369+ ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l

2370+ ni 0 env t

2371+ ni 0 env r

2372+ ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as

2373+ ni 0 env (PHidden tm) = ni 0 env tm

2374+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2375+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2376+ ni 0 env (PNoImplicits tm) = ni 0 env tm

23622377

23632378 ni i env (PQuasiquote tm ty) = do ni (i + 1) env tm

23642379 maybe (return ()) (ni i env) ty

23652380 ni i env (PUnquote tm) = ni (i - 1) env tm

23662381

2367− ni i env tm = mapM_ (ni i env) (children tm)

2382+ ni i env tm = mapM_ (ni i env) (children tm)

23682383

23692384-- Return names which are free in the given term.

23702385namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

@@ -2373,32 +2388,32 @@ namesIn uvars ist tm = nub $ ni 0 [] tm

23732388 ni 0 env (PRef _ _ n)

23742389 | not (n `elem` env)

23752390 = 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 ++

2391+ [] -> [n]

2392+ _ -> [n | n `elem` (map fst uvars)]

2393+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2394+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2395+ ni 0 env (PCase _ c os) = ni 0 env c ++

23812396 -- 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]

2397+ (nub (concatMap (ni 0 env . snd) os)

2398+ \\ nub (concatMap (ni 0 env . fst) os))

2399+ ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

23852400 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

2401+ ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2402+ ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2403+ ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r

2404+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

23902405 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

2406+ ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

23922407 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

2408+ ni 0 env (PHidden tm) = ni 0 env tm

2409+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2410+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2411+ ni 0 env (PNoImplicits tm) = ni 0 env tm

23972412

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

2413+ ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2414+ ni i env (PUnquote tm) = ni (i - 1) env tm

24002415

2401− ni i env tm = concatMap (ni i env) (children tm)

2416+ ni i env tm = concatMap (ni i env) (children tm)

24022417

24032418 niTacImp i env (TacImp _ _ scr) = ni i env scr

24042419 niTacImp _ _ _ = []

@@ -2413,27 +2428,27 @@ usedNamesIn vars ist tm = nub $ ni 0 [] tm

24132428 = case lookupDefExact n (tt_ctxt ist) of

24142429 Nothing -> [n]

24152430 _ -> []

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

2431+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2432+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2433+ ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env . snd) os

2434+ ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2435+ ni 0 env (PLam fc n _ ty sc) = ni 0 env ty ++ ni 0 (n:env) sc

2436+ ni 0 env (PPi p n _ ty sc) = niTacImp 0 env p ++ ni 0 env ty ++ ni 0 (n:env) sc

2437+ ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2438+ ni 0 env (PTyped l r) = ni 0 env l ++ ni 0 env r

2439+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

24252440 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

2441+ ni 0 env (PDPair _ _ _ l t r) = ni 0 env l ++ ni 0 env t ++ ni 0 env r

24272442 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

2443+ ni 0 env (PHidden tm) = ni 0 env tm

2444+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2445+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2446+ ni 0 env (PNoImplicits tm) = ni 0 env tm

24322447

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

2448+ ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2449+ ni i env (PUnquote tm) = ni (i - 1) env tm

24352450

2436− ni i env tm = concatMap (ni i env) (children tm)

2451+ ni i env tm = concatMap (ni i env) (children tm)

24372452

24382453 niTacImp i env (TacImp _ _ scr) = ni i env scr

24392454 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+7−7

@@ -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,11 +48,11 @@ 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

55− return . map (show . nsroot) $ map fst (filter (\(_, (_,_,_,t)) -> not t) (idris_metavars i)) \\ primDefs

55+ return . map (show . nsroot) $ map fst (filter (\(_, (_,_,_,t,_)) -> not t) (idris_metavars i)) \\ primDefs

5656

5757

5858modules :: Idris [String]

src/Idris/Core/Binary.hs+4−3

@@ -113,8 +113,9 @@ instance Binary a => Binary (Err' a) where

113113 put x

114114 put y

115115 put z

116− put (CantResolve _ t) = do putWord8 15

117− put t

116+ put (CantResolve _ t u) = do putWord8 15

117+ put t

118+ put u

118119 put (CantResolveAlts ns) = do putWord8 16

119120 put ns

120121 put (IncompleteTerm t) = do putWord8 17

@@ -218,7 +219,7 @@ instance Binary a => Binary (Err' a) where

218219 13 -> fmap NoTypeDecl get

219220 14 -> do x <- get ; y <- get ; z <- get

220221 return $ NotInjective x y z

221− 15 -> fmap (CantResolve False) get

222+ 15 -> CantResolve False <$> get <*> get

222223 16 -> fmap CantResolveAlts get

223224 17 -> fmap IncompleteTerm get

224225 18 -> UniverseError <$> get <*> get <*> get <*> get <*> 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/DeepSeq.hs+2−1

@@ -134,7 +134,7 @@ instance NFData Err where

134134 rnf (NoTypeDecl x1) = rnf x1 `seq` ()

135135 rnf (NotInjective x1 x2 x3)

136136 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

137− rnf (CantResolve x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

137+ rnf (CantResolve x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

138138 rnf (InvalidTCArg x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

139139 rnf (CantResolveAlts x1) = rnf x1 `seq` ()

140140 rnf (NoValidAlts x1) = rnf x1 `seq` ()

@@ -239,6 +239,7 @@ instance NFData Accessibility where

239239 rnf Public = ()

240240 rnf Frozen = ()

241241 rnf Hidden = ()

242+ rnf Private = ()

242243

243244

244245instance NFData Totality where

src/Idris/Core/Elaborate.hs+19−5

@@ -139,13 +139,19 @@ runElab a e ps = runStateT e (ES (ps, a) "" Nothing)

139139execElab :: aux -> Elab' aux a -> ProofState -> TC (ElabState aux)

140140execElab a e ps = execStateT e (ES (ps, a) "" Nothing)

141141

142−initElaborator :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState

142+initElaborator :: Name -- ^ the name of what's to be elaborated

143+ -> Context -- ^ the current global context

144+ -> Ctxt TypeInfo -- ^ the value of the idris_datatypes field of IState

145+ -> Int -- ^ the value of the idris_name field of IState

146+ -> Type -- ^ the goal type

147+ -> ProofState

143148initElaborator = newProof

144149

145−elaborate :: Context -> Ctxt TypeInfo -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

146−elaborate ctxt datatypes n ty d elab = do let ps = initElaborator n ctxt datatypes ty

147− (a, ES ps' str _) <- runElab d elab ps

148− return $! (a, str)

150+elaborate :: Context -> Ctxt TypeInfo -> Int -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

151+elaborate ctxt datatypes globalNames n ty d elab =

152+ do let ps = initElaborator n ctxt datatypes globalNames ty

153+ (a, ES ps' str _) <- runElab d elab ps

154+ return $! (a, str)

149155

150156-- | Modify the auxiliary state

151157updateAux :: (aux -> aux) -> Elab' aux ()

@@ -210,6 +216,14 @@ set_datatypes :: Ctxt TypeInfo -> Elab' aux ()

210216set_datatypes ds = do ES (p, a) logs prev <- get

211217 put (ES (p { datatypes = ds }, a) logs prev)

212218

219+get_global_nextname :: Elab' aux Int

220+get_global_nextname = do ES (ps, _) _ _ <- get

221+ return (global_nextname ps)

222+

223+set_global_nextname :: Int -> Elab' aux ()

224+set_global_nextname i = do ES (ps, a) logs prev <- get

225+ put $ ES (ps { global_nextname = i}, a) logs prev

226+

213227-- | get the proof term

214228get_term :: Elab' aux Term

215229get_term = do ES p _ _ <- get

src/Idris/Core/Evaluate.hs+25−14

@@ -12,8 +12,8 @@ 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,

16− lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName,

15+ mapDefCtxt,

16+ lookupTotal, lookupTotalExact, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName,

1717 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,

1818 isUniverse) where

1919

@@ -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 || acc == Hidden || 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 || acc == Hidden || sUN "assert_total" `elem` stk ->

380378 -- unoptimised version

381379 let (ns, tree) = getCases cd in

382380 if blockSimplify ci n stk

@@ -742,15 +740,23 @@ instance Show Def where

742740

743741-------

744742

745−-- Frozen => doesn't reduce

746−-- Hidden => doesn't reduce and invisible to type checker

743+-- Hidden => Programs can't access the name at all

744+-- Public => Programs can access the name and use at will

745+-- Frozen => Programs can access the name, which doesn't reduce

746+-- Private => Programs can't access the name, doesn't reduce internally

747747

748−data Accessibility = Public | Frozen | Hidden

749− deriving (Show, Eq)

748+data Accessibility = Hidden | Public | Frozen | Private

749+ deriving (Eq, Ord)

750750{-!

751751deriving instance NFData Accessibility

752752!-}

753753

754+instance Show Accessibility where

755+ show Public = "public export"

756+ show Frozen = "export"

757+ show Private = "private"

758+ show Hidden = "hidden"

759+

754760-- | The result of totality checking

755761data Totality = Total [Int] -- ^ well-founded arguments

756762 | Productive -- ^ productive

@@ -1039,6 +1045,7 @@ lookupP_all all exact n ctxt

10391045 (Operator ty _ _, a, _, _) -> return (P Ref n' ty, a)

10401046 case snd p of

10411047 Hidden -> if all then return (fst p) else []

1048+ Private -> if all then return (fst p) else []

10421049 _ -> return (fst p)

10431050 where

10441051 names = let ns = lookupCtxtName n (definitions ctxt) in

@@ -1077,6 +1084,10 @@ lookupTotal :: Name -> Context -> [Totality]

10771084lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt)

10781085 where mkt (d, a, t, m) = t

10791086

1087+lookupTotalExact :: Name -> Context -> Maybe Totality

1088+lookupTotalExact n ctxt = fmap mkt $ lookupCtxtExact n (definitions ctxt)

1089+ where mkt (d, a, t, m) = t

1090+

10801091lookupMetaInformation :: Name -> Context -> [MetaInformation]

10811092lookupMetaInformation n ctxt = map mkm $ lookupCtxt n (definitions ctxt)

10821093 where mkm (d, a, t, m) = m

src/Idris/Core/ProofState.hs+22−5

@@ -25,7 +25,10 @@ import Util.Pretty hiding (fill)

2525data ProofState = PS { thname :: Name,

2626 holes :: [Name], -- ^ holes still to be solved

2727 usedns :: [Name], -- ^ used names, don't use again

28− nextname :: Int, -- ^ name supply

28+ nextname :: Int, -- ^ name supply, for locally unique names

29+ global_nextname :: Int, -- ^ a mirror of the global name supply,

30+ -- for generating things like type tags

31+ -- in reflection

2932 pterm :: ProofTerm, -- ^ current proof term

3033 ptype :: Type, -- ^ original goal

3134 dontunify :: [Name], -- ^ explicitly given by programmer, leave it

@@ -206,6 +209,14 @@ mergeSolutions env ns = merge [] ns

206209 merge acc ns

207210 | otherwise = merge ((n, t): acc) ns

208211

212+dropSwaps :: [(Name, TT Name)] -> [(Name, TT Name)]

213+dropSwaps [] = []

214+dropSwaps (p@(x, P _ y _) : xs) | solvedIn y x xs = dropSwaps xs

215+ where solvedIn _ _ [] = False

216+ solvedIn y x ((y', P _ x' _) : xs) | y == y' && x == x' = True

217+ solvedIn y x (_ : xs) = solvedIn y x xs

218+dropSwaps (p : xs) = p : dropSwaps xs

219+

209220unify' :: Context -> Env ->

210221 (TT Name, Maybe Provenance) ->

211222 (TT Name, Maybe Provenance) ->

@@ -242,7 +253,8 @@ unify' ctxt env (topx, xfrom) (topy, yfrom) =

242253 -- problem for each.

243254 uns <- mergeSolutions env (u' ++ ns)

244255 ps <- get

245− let (ns', probs') = updateProblems ps uns (fails ++ problems ps)

256+ let (ns_p, probs') = updateProblems ps uns (fails ++ problems ps)

257+ let ns' = dropSwaps ns_p

246258 let (notu', probs_notu) = mergeNotunified env (holes ps) (notu ++ notunified ps)

247259 traceWhen (unifylog ps)

248260 ("Now solved: " ++ show ns' ++

@@ -296,11 +308,16 @@ query q = do ps <- get

296308addLog :: Monad m => String -> StateT TState m ()

297309addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

298310

299−newProof :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState

300−newProof n ctxt datatypes ty =

311+newProof :: Name -- ^ the name of what's to be elaborated

312+ -> Context -- ^ the current global context

313+ -> Ctxt TypeInfo -- ^ the value of the idris_datatypes field of IState

314+ -> Int -- ^ the value of the idris_name field of IState

315+ -> Type -- ^ the goal type

316+ -> ProofState

317+newProof n ctxt datatypes globalNames ty =

301318 let h = holeName 0

302319 ty' = vToP ty

303− in PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')

320+ in PS n [h] [] 1 globalNames (mkProofTerm (Bind h (Hole ty')

304321 (P Bound h ty'))) ty [] (h, []) [] []

305322 Nothing [] []

306323 [] [] [] []

src/Idris/Core/TT.hs+4−4

@@ -268,7 +268,7 @@ data Err' t

268268 | NoTypeDecl Name

269269 | NotInjective t t t

270270 | CantResolve Bool -- True if postponed, False if fatal

271− t

271+ t (Err' t) -- any further information

272272 | InvalidTCArg Name t

273273 | CantResolveAlts [Name]

274274 | NoValidAlts [Name]

@@ -354,7 +354,7 @@ instance Sized Err where

354354 size (NoSuchVariable name) = size name

355355 size (NoTypeDecl name) = size name

356356 size (NotInjective l c r) = size l + size c + size r

357− size (CantResolve _ trm) = size trm

357+ size (CantResolve _ trm _) = size trm

358358 size (NoRewriting trm) = size trm

359359 size (CantResolveAlts _) = 1

360360 size (IncompleteTerm trm) = size trm

@@ -397,7 +397,7 @@ instance Show Err where

397397 show (WithFnType _) = "WithFnType"

398398 show (NoTypeDecl _) = "NoTypeDecl"

399399 show (NotInjective _ _ _) = "NotInjective"

400− show (CantResolve _ _) = "CantResolve"

400+ show (CantResolve _ _ _) = "CantResolve"

401401 show (InvalidTCArg _ _) = "InvalidTCArg"

402402 show (CantResolveAlts _) = "CantResolveAlts"

403403 show (NoValidAlts _) = "NoValidAlts"

@@ -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+52−28

@@ -59,10 +59,16 @@ genClauses fc n xs given

5959 let lhs_tms' = zipWith mergePlaceholders lhs_tms

6060 (map (stripUnmatchable i) (map flattenArgs given))

6161 let lhss = map pUnApply lhs_tms'

62+ nty <- case lookupTyExact n (tt_ctxt i) of

63+ Just t -> return (normalise (tt_ctxt i) [] t)

64+ _ -> fail "Can't happen - genClauses, lookupTyExact"

6265

6366 let argss = transpose lhss

64− let all_args = map (genAll i) argss

67+ let all_args = map (genAll i) (zip (genPH i nty) argss)

6568 logCoverage 5 $ "COVERAGE of " ++ show n

69+ logCoverage 5 $ "using type " ++ show nty

70+ logCoverage 5 $ "non-concrete args " ++ show (genPH i nty)

71+

6672 logCoverage 5 $ show (lhs_tms, lhss)

6773 logCoverage 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

6874 logCoverage 10 $ show argss ++ "\n" ++ show all_args

@@ -89,6 +95,18 @@ genClauses fc n xs given

8995 | (f, args) <- unApply term = map (\t -> delab' i t True True) args

9096 | otherwise = []

9197

98+ -- if an argument has a non-concrete type (i.e. it's a function

99+ -- that calculates something from a previous argument) we'll also

100+ -- need to generate a placeholder pattern for it since it could be

101+ -- anything based on earlier values

102+ genPH :: IState -> Type -> [Bool]

103+ genPH ist (Bind n (Pi _ ty _) sc) = notConcrete ist ty : genPH ist sc

104+ genPH ist ty = []

105+

106+ notConcrete ist t | (P _ n _, args) <- unApply t,

107+ not (isConName n (tt_ctxt ist)) = True

108+ notConcrete _ _ = False

109+

92110 pUnApply (PApp _ f args) = map getTm args

93111 pUnApply _ = []

94112

@@ -135,6 +153,7 @@ validCoverageCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)

135153 = case (unApply topx, unApply topy) of

136154 ((P _ x _, _), (P _ y _, _)) -> x == y

137155 _ -> False

156+validCoverageCase ctxt (InfiniteUnify _ _ _) = False

138157validCoverageCase ctxt (CantConvert _ _ _) = False

139158validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e

140159validCoverageCase ctxt (Elaborating _ _ _ e) = validCoverageCase ctxt e

@@ -171,16 +190,14 @@ recoverableCoverage ctxt (Elaborating _ _ _ e) = recoverableCoverage ctxt e

171190recoverableCoverage ctxt (ElaboratingArg _ _ _ e) = recoverableCoverage ctxt e

172191recoverableCoverage _ _ = False

173192

174−-- FIXME: Just look for which one is the deepest, then generate all

175−-- possibilities up to that depth.

176−-- This and below issues for this function are tracked as Issue #1741 on the issue tracker.

177−-- https://github.com/idris-lang/Idris-dev/issues/1741

178−genAll :: IState -> [PTerm] -> [PTerm]

179−genAll i args

193+genAll :: IState -> (Bool, [PTerm]) -> [PTerm]

194+genAll i (addPH, args)

180195 = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of

181196 [] -> [Placeholder]

182− xs -> inventConsts xs

197+ xs -> ph $ inventConsts xs

183198 where

199+ ph ts = if addPH then Placeholder : ts else ts

200+

184201 -- if they're constants, invent a new one to make sure that

185202 -- constants which are not explicitly handled are covered

186203 inventConsts cs@(PConstant fc c : _) = map (PConstant NoFC) (ic' (mapMaybe getConst cs))

@@ -203,7 +220,6 @@ genAll i args

203220 ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64)

204221 ic' xs@(Ch _ : _) = firstMissing xs lotsOfChars

205222 ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings

206− -- TODO: Bit vectors

207223 -- The rest are types with only one case

208224 ic' xs = xs

209225

@@ -218,19 +234,19 @@ genAll i args

218234 nubMap f acc (x : xs) = nubMap f (fnub' acc (f x)) xs

219235

220236 otherPats :: PTerm -> [PTerm]

221− otherPats o@(PRef fc hl n) = ops fc n [] o

222− otherPats o@(PApp _ (PRef fc hl n) xs) = ops fc n xs o

237+ otherPats o@(PRef fc hl n) = ph $ ops fc n [] o

238+ otherPats o@(PApp _ (PRef fc hl n) xs) = ph $ ops fc n xs o

223239 otherPats o@(PPair fc hls _ l r)

224− = ops fc pairCon

240+ = ph $ ops fc pairCon

225241 ([pimp (sUN "A") Placeholder True,

226242 pimp (sUN "B") Placeholder True] ++

227243 [pexp l, pexp r]) o

228244 otherPats o@(PDPair fc hls p t _ v)

229− = ops fc sigmaCon

245+ = ph $ ops fc sigmaCon

230246 ([pimp (sUN "a") Placeholder True,

231247 pimp (sUN "P") Placeholder True] ++

232248 [pexp t,pexp v]) o

233− otherPats o@(PConstant _ c) = inventConsts [o] -- return o

249+ otherPats o@(PConstant _ c) = ph $ inventConsts [o] -- return o

234250 otherPats arg = return Placeholder

235251

236252 ops fc n xs o

@@ -313,20 +329,21 @@ checkAllCovering fc done top n | not (n `elem` done)

313329 [Partial _] ->

314330 case lookupCtxt n (idris_callgraph i) of

315331 [cg] -> mapM_ (checkAllCovering fc (n : done) top)

316− (map fst (calls cg))

332+ (calls cg)

317333 _ -> return ()

318334 x -> return () -- stop if total

319335checkAllCovering _ _ _ _ = return ()

320336

321−-- Check if, in a given group of type declarations mut_ns,

337+-- | Check if, in a given group of type declarations mut_ns,

322338-- the constructor cn : ty is strictly positive,

323339-- and update the context accordingly

324−

325−checkPositive :: [Name] -> (Name, Type) -> Idris Totality

340+checkPositive :: [Name] -- ^ the group of type declarations

341+ -> (Name, Type) -- ^ the constructor

342+ -> Idris Totality

326343checkPositive mut_ns (cn, ty')

327− = do let ty = delazy' True ty'

344+ = do i <- getIState

345+ let ty = delazy' True (normalise (tt_ctxt i) [] ty')

328346 let p = cp ty

329− i <- getIState

330347 let tot = if p then Total (args ty) else Partial NotPositive

331348 let ctxt' = setTotal cn tot (tt_ctxt i)

332349 putIState (i { tt_ctxt = ctxt' })

@@ -365,8 +382,8 @@ calcTotality fc n pats

365382 _ -> checkSizeChange n

366383 where

367384 checkLHS i (P _ fn _)

368− = case lookupTotal fn (tt_ctxt i) of

369− [Partial _] -> return (Partial (Other [fn]))

385+ = case lookupTotalExact fn (tt_ctxt i) of

386+ Just (Partial _) -> return (Partial (Other [fn]))

370387 _ -> Nothing

371388 checkLHS i (App _ f a) = mplus (checkLHS i f) (checkLHS i a)

372389 checkLHS _ _ = Nothing

@@ -441,12 +458,18 @@ checkDeclTotality (fc, n)

441458 _ -> []

442459 when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n

443460 t <- checkTotality [] fc n

461+ let acc = case lookupDefAccExact n False (tt_ctxt i) of

462+ Just (n, a) -> a

463+ _ -> Public

444464 case t of

445465 -- if it's not total, it can't reduce, to keep

446− -- typechecking decidable

447− p@(Partial _) -> do setAccessibility n Frozen

448− addIBC (IBCAccess n Frozen)

449− logCoverage 5 $ "HIDDEN: "

466+ -- typechecking decidable.

467+ -- So if it's currently public export, set it as

468+ -- export instead.

469+ p@(Partial _) -> do let newacc = max Frozen acc

470+ setAccessibility n newacc

471+ addIBC (IBCAccess n newacc)

472+ logCoverage 5 $ "Set to " ++ show newacc ++ ":"

450473 ++ show n ++ show p

451474 _ -> return ()

452475 return t

@@ -474,6 +497,7 @@ buildSCG (_, n) = do

474497 let newscg = buildSCG' ist (rights pats) args

475498 logCoverage 5 $ "SCG is: " ++ show newscg

476499 addToCG n ( cg { scg = newscg } )

500+ _ -> return () -- CG comes from a type declaration only

477501 [] -> logCoverage 5 $ "Could not build SCG for " ++ show n ++ "\n"

478502 x -> error $ "buildSCG: " ++ show (n, x)

479503

@@ -573,8 +597,8 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

573597

574598 toJust (n, t) = Just t

575599

576− getType n = case lookupTy n (tt_ctxt ist) of

577− [ty] -> delazy ty -- must exist

600+ getType n = case lookupTyExact n (tt_ctxt ist) of

601+ Just ty -> delazy (normalise (tt_ctxt ist) [] ty) -- must exist

578602

579603 isInductive (P _ nty _) (P _ nty' _) =

580604 let co = case lookupCtxt nty (idris_datatypes ist) of

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

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` rnf x13 `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+10−4

@@ -106,7 +106,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

106106 | Just n' <- lookup n env = PRef un [] n'

107107 | otherwise

108108 = case lookup n (idris_metavars ist) of

109− Just (Just _, mi, _, _) -> mkMVApp n []

109+ Just (Just _, mi, _, _, _) -> mkMVApp n []

110110 _ -> PRef un [] n

111111 de env _ (Bind n (Lam ty) sc)

112112 = PLam un n NoFC (de env [] ty) (de ((n,n):env) [] sc)

@@ -172,7 +172,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

172172 = PApp un (de env [] f) (map pexp (map (de env []) args))

173173 deFn env (P _ n _) args

174174 | not mvs = case lookup n (idris_metavars ist) of

175− Just (Just _, mi, _, _) ->

175+ Just (Just _, mi, _, _, _) ->

176176 mkMVApp n (drop mi (map (de env []) args))

177177 _ -> mkPApp n (map (de env []) args)

178178 | otherwise = mkPApp n (map (de env []) args)

@@ -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) =

@@ -346,7 +346,13 @@ pprintErr' i (NotInjective p x y) =

346346 text "Can't verify injectivity of" <+> annTm p (pprintTerm i (delabSugared i p)) <+>

347347 text " when unifying" <+> annTm x (pprintTerm i (delabSugared i x)) <+> text "and" <+>

348348 annTm y (pprintTerm i (delabSugared i y))

349−pprintErr' i (CantResolve _ c) = text "Can't find implementation for" <+> pprintTerm i (delabSugared i c)

349+pprintErr' i (CantResolve _ c e)

350+ = text "Can't find implementation for" <+> pprintTerm i (delabSugared i c)

351+ <>

352+ case e of

353+ Msg "" -> empty

354+ _ -> line <> line <> text "Possible cause:" <>

355+ indented (pprintErr' i e)

350356pprintErr' i (InvalidTCArg n t)

351357 = annTm t (pprintTerm i (delabSugared i t)) <+> text " cannot be a parameter of "

352358 <> annName n <$>

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/AsPat.hs+8

@@ -28,6 +28,14 @@ collectAs (PApp fc t as)

2828 = do as_tm <- mapM collectAs (map getTm as)

2929 let as' = zipWith (\a tm -> a { getTm = tm }) as as_tm

3030 return (PApp fc t as') -- only valid on args

31+-- only for 'ExactlyOne' since it means the alternatives will have the

32+-- same form, so we can assume we only need to extract from the first one

33+collectAs tm@(PAlternative ns (ExactlyOne d) (a : as))

34+ = do a' <- collectAs a

35+ pats <- get

36+ as' <- mapM collectAs as -- just to drop the '@'

37+ put pats -- discard later ones, since they're repeated

38+ return (PAlternative ns (ExactlyOne d) (a' : as'))

3139collectAs x = return x

3240

3341-- | Replace _-patterns under @-patterns with fresh names that can be

src/Idris/Elab/Class.hs+16−2

@@ -78,6 +78,12 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

7878 let idecls = filter instdecl ds -- default superclass instance declarations

7979 mapM_ checkDefaultSuperclassInstance idecls

8080 let mnames = map getMName mdecls

81+ ist <- getIState

82+ let constraintNames = nub $

83+ concatMap (namesIn [] ist) (map snd constraints)

84+

85+ mapM_ (checkConstraintName (map (\(x, _, _) -> x) ps)) constraintNames

86+

8187 logElab 1 $ "Building methods " ++ show mnames

8288 ims <- mapM (tdecl mnames) mdecls

8389 defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)

@@ -138,7 +144,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

138144

139145 -- TODO: probably should normalise

140146 checkDefaultSuperclassInstance :: PDecl -> Idris ()

141− checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n _ ps _ _ _)

147+ checkDefaultSuperclassInstance (PInstance _ _ _ fc cs _ _ n _ ps _ _ _)

142148 = do when (not $ null cs) . tclift

143149 $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))

144150 i <- getIState

@@ -148,6 +154,14 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

148154 $ tfail (At fc (Msg $ "Default instances must be for a superclass constraint on the containing class."))

149155 return ()

150156

157+ checkConstraintName :: [Name] -> Name -> Idris ()

158+ checkConstraintName bound cname

159+ | cname `notElem` bound

160+ = tclift $ tfail (At fc (Msg $ "Name " ++ show cname ++

161+ " is not bound in interface " ++ show tn

162+ ++ " " ++ showSep " " (map show bound)))

163+ | otherwise = return ()

164+

151165 impbind :: [(Name, PTerm)] -> PTerm -> PTerm

152166 impbind [] x = x

153167 impbind ((n, ty): ns) x = PPi impl n NoFC ty (impbind ns x)

@@ -184,7 +198,7 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

184198

185199 tydecl (PTy _ _ _ _ _ _ _ _) = True

186200 tydecl _ = False

187− instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _) = True

201+ instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = True

188202 instdecl _ = False

189203 clause (PClauses _ _ _ _) = True

190204 clause _ = False

src/Idris/Elab/Clause.hs+91−53

@@ -80,19 +80,21 @@ 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

89− solveDeferred n

90+ solveDeferred fc n

9091

9192 -- just ensure that the structure exists

9293 fmodifyState (ist_optimisation n) id

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)

@@ -163,9 +165,12 @@ elabClauses info' fc opts n_in cs =

163165 cov <- coverage

164166 pmissing <-

165167 if cov && not (hasDefault pats_raw)

166− then do missing <- genClauses fc n (map getLHS pdef) cs_full

168+ then do -- Generate clauses from the given possible cases

169+ missing <- genClauses fc n (map getLHS pdef) cs_full

167170 -- missing <- genMissing n scargs sc

168171 missing' <- filterM (checkPossible info fc True n) missing

172+ -- Filter out the ones which match one of the

173+ -- given cases (including impossible ones)

169174 let clhs = map getLHS pdef

170175 logElab 2 $ "Must be unreachable:\n" ++

171176 showSep "\n" (map showTmImpls missing') ++

@@ -183,7 +188,8 @@ elabClauses info' fc opts n_in cs =

183188 -- pdef' is the version that gets compiled for run-time,

184189 -- so we start from the partially evaluated version

185190 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'

191+ ctxt <- getContext

192+ let pdef' = map (simple_rt ctxt) pdef_in'

187193

188194 logElab 5 $ "After data structure transformations:\n" ++ show pdef'

189195

@@ -241,24 +247,28 @@ elabClauses info' fc opts n_in cs =

241247 ctxt

242248 setContext ctxt'

243249 addIBC (IBCDef n)

250+ addDefinedName n

244251 setTotality n tot

245252 when (not reflect && PEGenerated `notElem` opts) $

246253 do totcheck (fc, n)

247254 defer_totcheck (fc, n)

248255 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

249256 i <- getIState

250− case lookupDef n (tt_ctxt i) of

257+ ctxt <- getContext

258+ case lookupDef n ctxt of

251259 (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'

260+ let (scargs, sc) = cases_compiletime cd in

261+ do let calls = map fst $ findCalls sc scargs

256262 -- let scg = buildSCG i sc scargs

257263 -- 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!

264+ logElab 2 $ "Called names: " ++ show calls

265+ -- if the definition is public, make sure

266+ -- it only uses public names

267+ nvis <- getFromHideList n

268+ case nvis of

269+ Just Public -> mapM_ (checkVisibility fc n Public Public) calls

270+ _ -> return ()

271+ addCalls n calls

262272 addIBC (IBCCG n)

263273 _ -> return ()

264274 return ()

@@ -305,7 +315,6 @@ elabClauses info' fc opts n_in cs =

305315 , (f, args) <- unApply tm = all (isPatVar pvs) args

306316 hasDefault _ = False

307317

308−

309318 getLHS (_, l, _) = l

310319

311320 simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)

@@ -353,11 +362,12 @@ elabPE info fc caller r =

353362 mkSpecialised :: (Name, [(PEArgType, Term)]) -> Idris [(Term, Term)]

354363 mkSpecialised specapp_in = do

355364 ist <- getIState

365+ ctxt <- getContext

356366 let (specTy, specapp) = getSpecTy ist specapp_in

357367 let (n, newnm, specdecl) = getSpecClause ist specapp

358368 let lhs = pe_app specdecl

359369 let rhs = pe_def specdecl

360− let undef = case lookupDefExact newnm (tt_ctxt ist) of

370+ let undef = case lookupDefExact newnm ctxt of

361371 Nothing -> True

362372 _ -> False

363373 logElab 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))

@@ -370,7 +380,7 @@ elabPE info fc caller r =

370380 let cgns' = filter (\x -> x /= n &&

371381 notStatic ist x) cgns

372382 -- set small reduction limit on partial/productive things

373− let maxred = case lookupTotal n (tt_ctxt ist) of

383+ let maxred = case lookupTotal n ctxt of

374384 [Total _] -> 65536

375385 [Productive] -> 16

376386 _ -> 1

@@ -476,16 +486,17 @@ checkPossible info fc tcgen fname lhs_in

476486 i <- getIState

477487 let lhs = addImplPat i lhs_in

478488 -- if the LHS type checks, it is possible

479− case elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

489+ case elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState

480490 (erun fc (buildTC i info ELHS [] fname

481491 (allNamesIn lhs_in)

482492 (infTerm lhs))) of

483− OK (ElabResult lhs' _ _ ctxt' newDecls highlights, _) ->

493+ OK (ElabResult lhs' _ _ ctxt' newDecls highlights newGName, _) ->

484494 do setContext ctxt'

485495 processTacticDecls info newDecls

486496 sendHighlighting highlights

497+ updateIState $ \i -> i { idris_name = newGName }

487498 let lhs_tm = orderPats (getInferTerm lhs')

488− case recheck ctxt [] (forget lhs_tm) lhs_tm of

499+ case recheck ctxt' [] (forget lhs_tm) lhs_tm of

489500 OK _ -> return True

490501 err -> return False

491502 -- if it's a recoverable error, the case may become possible

@@ -558,7 +569,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

558569 (Msg "unexpected patterns outside of \"with\" block")))

559570

560571 -- get the parameters first, to pass through to any where block

561− let fn_ty = case lookupTy fname (tt_ctxt i) of

572+ let fn_ty = case lookupTy fname ctxt of

562573 [t] -> t

563574 _ -> error "Can't happen (elabClause function type)"

564575 let fn_is = case lookupCtxt fname (idris_implicits i) of

@@ -573,12 +584,12 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

573584-- let lhs = mkLHSapp $

574585-- propagateParams i params fn_ty (addImplPat i lhs_in)

575586 logElab 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))

576− logElab 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)

577− logElab 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++

587+ logElab 5 ("LHS: " ++ show opts ++ "\n" ++ show fc ++ " " ++ showTmImpls lhs)

588+ logElab 4 ("Fixed parameters: " ++ show params ++ " from " ++ showTmImpls lhs_in ++

578589 "\n" ++ show (fn_ty, fn_is))

579590

580− ((ElabResult lhs' dlhs [] ctxt' newDecls highlights, probs, inj), _) <-

581− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

591+ ((ElabResult lhs' dlhs [] ctxt' newDecls highlights newGName, probs, inj), _) <-

592+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState

582593 (do res <- errAt "left hand side of " fname Nothing

583594 (erun fc (buildTC i info ELHS opts fname

584595 (allNamesIn lhs_in)

@@ -589,6 +600,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

589600 setContext ctxt'

590601 processTacticDecls info newDecls

591602 sendHighlighting highlights

603+ updateIState $ \i -> i { idris_name = newGName }

592604

593605 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

594606

@@ -602,6 +614,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

602614

603615 -- If we're inferring metavariables in the type, don't recheck,

604616 -- because we're only doing this to try to work out those metavariables

617+ ctxt <- getContext

605618 (clhs_c, clhsty) <- if not inf

606619 then recheckC_borrowing False (PEGenerated `notElem` opts)

607620 [] fc id [] lhs_tm

@@ -627,6 +640,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

627640 logElab 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

628641 -- Elaborate where block

629642 ist <- getIState

643+ ctxt <- getContext

644+

630645 windex <- getName

631646 let decls = nub (concatMap declared whereblock)

632647 let defs = nub (decls ++ concatMap defined whereblock)

@@ -635,7 +650,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

635650 -- Unique arguments must be passed to the where block explicitly

636651 -- (since we can't control "usage" easlily otherwise). Remove them

637652 -- from newargs here

638− let uniqargs = findUnique (tt_ctxt ist) [] lhs_tm

653+ let uniqargs = findUnique ctxt [] lhs_tm

639654 let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all

640655

641656 let winfo = (pinfo info newargs defs windex) { elabFC = Just fc }

@@ -657,14 +672,14 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

657672 logElab 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs

658673 ctxt <- getContext -- new context with where block added

659674 logElab 5 "STARTING CHECK"

660− ((rhs', defer, is, probs, ctxt', newDecls, highlights), _) <-

661− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState

675+ ((rhs', defer, holes, is, probs, ctxt', newDecls, highlights, newGName), _) <-

676+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patRHS") clhsty initEState

662677 (do pbinds ist lhs_tm

663678 -- proof search can use explicitly written names

664679 mapM_ addPSname (allNamesIn lhs_in)

665680 mapM_ setinj (nub (tcparams ++ inj))

666681 setNextName

667− (ElabResult _ _ is ctxt' newDecls highlights) <-

682+ (ElabResult _ _ is ctxt' newDecls highlights newGName) <-

668683 errAt "right hand side of " fname (Just clhsty)

669684 (erun fc (build i winfo ERHS opts fname rhs))

670685 errAt "right hand side of " fname (Just clhsty)

@@ -674,10 +689,12 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

674689 let (tm, ds) = runState (collectDeferred (Just fname)

675690 (map fst $ case_decls aux) ctxt tt) []

676691 probs <- get_probs

677− return (tm, ds, is, probs, ctxt', newDecls, highlights))

692+ hs <- get_holes

693+ return (tm, ds, hs, is, probs, ctxt', newDecls, highlights, newGName))

678694 setContext ctxt'

679695 processTacticDecls info newDecls

680696 sendHighlighting highlights

697+ updateIState $ \i -> i { idris_name = newGName }

681698

682699 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

683700

@@ -685,9 +702,12 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

685702 logElab 4 $ "---> " ++ show rhs'

686703 when (not (null defer)) $ logElab 1 $ "DEFERRED " ++

687704 show (map (\ (n, (_,_,t,_)) -> (n, t)) defer)

688− def' <- checkDef fc (\n -> Elaborating "deferred type of " n Nothing) defer

689− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

705+

706+ -- If there's holes, set the metavariables as undefinable

707+ def' <- checkDef fc (\n -> Elaborating "deferred type of " n Nothing) (null holes) defer

708+ let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, null holes))) def'

690709 addDeferred def''

710+

691711 mapM_ (\(n, _) -> addIBC (IBCDef n)) def''

692712

693713 when (not (null def')) $ do

@@ -703,11 +723,23 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

703723 logElab 5 $ "Rechecking"

704724 logElab 6 $ " ==> " ++ show (forget rhs')

705725

706− (crhs, crhsty) <- if not inf

707− then recheckC_borrowing True (PEGenerated `notElem` opts)

708− borrowed fc id [] rhs'

709− else return (rhs', clhsty)

726+ (crhs, crhsty) -- if there's holes && deferred things, it's okay

727+ -- but we'll need to freeze the definition and not

728+ -- allow the deferred things to be definable

729+ -- (this is just to allow users to inspect intermediate

730+ -- things)

731+ <- if (null holes || null def') && not inf

732+ then recheckC_borrowing True (PEGenerated `notElem` opts)

733+ borrowed fc id [] rhs'

734+ else return (rhs', clhsty)

735+

710736 logElab 6 $ " ==> " ++ showEnvDbg [] crhsty ++ " against " ++ showEnvDbg [] clhsty

737+

738+ -- If there's holes, make sure this definition is frozen

739+ when (not (null holes)) $ do

740+ logElab 5 $ "Making " ++ show fname ++ " frozen due to " ++ show holes

741+ setAccessibility fname Frozen

742+

711743 ctxt <- getContext

712744 let constv = next_tvar ctxt

713745 case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of

@@ -798,7 +830,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

798830 -- pattern bindings

799831 i <- getIState

800832 -- get the parameters first, to pass through to any where block

801− let fn_ty = case lookupTy fname (tt_ctxt i) of

833+ let fn_ty = case lookupTy fname ctxt of

802834 [t] -> t

803835 _ -> error "Can't happen (elabClause function type)"

804836 let fn_is = case lookupCtxt fname (idris_implicits i) of

@@ -809,8 +841,8 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

809841 propagateParams i params fn_ty (allNamesIn lhs_in)

810842 (addImplPat i lhs_in)

811843 logElab 2 ("LHS: " ++ show lhs)

812− (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

813− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

844+ (ElabResult lhs' dlhs [] ctxt' newDecls highlights newGName, _) <-

845+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState

814846 (errAt "left hand side of with in " fname Nothing

815847 (erun fc (buildTC i info ELHS opts fname

816848 (allNamesIn lhs_in)

@@ -818,7 +850,9 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

818850 setContext ctxt'

819851 processTacticDecls info newDecls

820852 sendHighlighting highlights

853+ updateIState $ \i -> i { idris_name = newGName }

821854

855+ ctxt <- getContext

822856 let lhs_tm = orderPats (getInferTerm lhs')

823857 let lhs_ty = getInferType lhs'

824858 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

@@ -830,28 +864,31 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

830864 let wval = addImplBound i (map fst bargs) wval_in

831865 logElab 5 ("Checking " ++ showTmImpls wval)

832866 -- Elaborate wval in this context

833− ((wval', defer, is, ctxt', newDecls, highlights), _) <-

834− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")

867+ ((wval', defer, is, ctxt', newDecls, highlights, newGName), _) <-

868+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "withRHS")

835869 (bindTyArgs PVTy bargs infP) initEState

836870 (do pbinds i lhs_tm

837871 -- proof search can use explicitly written names

838872 mapM_ addPSname (allNamesIn lhs_in)

839873 setNextName

840874 -- TODO: may want where here - see winfo abpve

841− (ElabResult _ d is ctxt' newDecls highlights) <- errAt "with value in " fname Nothing

875+ (ElabResult _ d is ctxt' newDecls highlights newGName) <- errAt "with value in " fname Nothing

842876 (erun fc (build i info ERHS opts fname (infTerm wval)))

843877 erun fc $ psolve lhs_tm

844878 tt <- get_term

845− return (tt, d, is, ctxt', newDecls, highlights))

879+ return (tt, d, is, ctxt', newDecls, highlights, newGName))

846880 setContext ctxt'

847881 processTacticDecls info newDecls

848882 sendHighlighting highlights

883+ updateIState $ \i -> i { idris_name = newGName }

849884

850− def' <- checkDef fc iderr defer

851− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

885+ def' <- checkDef fc iderr True defer

886+ let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, True))) def'

852887 addDeferred def''

853888 mapM_ (elabCaseBlock info opts) is

854889 logElab 5 ("Checked wval " ++ show wval')

890+

891+ ctxt <- getContext

855892 (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')

856893 let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)

857894 let cwvalN = explicitNames (normalise ctxt [] cwval)

@@ -910,8 +947,8 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

910947 addIBC (IBCImp wname)

911948 addIBC (IBCStatic wname)

912949

913− def' <- checkDef fc iderr [(wname, (-1, Nothing, wtype, []))]

914− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

950+ def' <- checkDef fc iderr True [(wname, (-1, Nothing, wtype, []))]

951+ let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, True))) def'

915952 addDeferred def''

916953

917954 -- in the subdecls, lhs becomes:

@@ -938,21 +975,22 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

938975 logElab 5 ("New RHS " ++ showTmImpls rhs)

939976 ctxt <- getContext -- New context with block added

940977 i <- getIState

941− ((rhs', defer, is, ctxt', newDecls, highlights), _) <-

942− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "wpatRHS") clhsty initEState

978+ ((rhs', defer, is, ctxt', newDecls, highlights, newGName), _) <-

979+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "wpatRHS") clhsty initEState

943980 (do pbinds i lhs_tm

944981 setNextName

945− (ElabResult _ d is ctxt' newDecls highlights) <-

982+ (ElabResult _ d is ctxt' newDecls highlights newGName) <-

946983 erun fc (build i info ERHS opts fname rhs)

947984 psolve lhs_tm

948985 tt <- get_term

949− return (tt, d, is, ctxt', newDecls, highlights))

986+ return (tt, d, is, ctxt', newDecls, highlights, newGName))

950987 setContext ctxt'

951988 processTacticDecls info newDecls

952989 sendHighlighting highlights

990+ updateIState $ \i -> i { idris_name = newGName }

953991

954− def' <- checkDef fc iderr defer

955− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

992+ def' <- checkDef fc iderr True defer

993+ let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, True))) def'

956994 addDeferred def''

957995 mapM_ (elabCaseBlock info opts) is

958996 logElab 5 ("Checked RHS " ++ show rhs')

src/Idris/Elab/Data.hs+14−71

@@ -60,7 +60,7 @@ elabData info syn doc argDocs fc opts (PLaterdecl n nfc t_in)

6060 = do let codata = Codata `elem` opts

6161 logElab 1 (show (fc, doc))

6262 checkUndefined fc n

63− when (implicitable n) $ warnLC fc n

63+ when (implicitable (nsroot n)) $ warnLC fc n

6464 (cty, _, t, inacc) <- buildType info syn fc [] n t_in

6565

6666 addIBC (IBCDef n)

@@ -71,7 +71,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)

7171 = do let codata = Codata `elem` opts

7272 logElab 1 (show fc)

7373 undef <- isUndefined fc n

74− when (implicitable n) $ warnLC fc n

74+ when (implicitable (nsroot n)) $ warnLC fc n

7575 (cty, ckind, t, inacc) <- buildType info syn fc [] n t_in

7676 -- if n is defined already, make sure it is just a type declaration

7777 -- with the same type we've just elaborated, and no constructors

@@ -90,7 +90,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)

9090 ttag <- getName

9191 i <- getIState

9292 let as = map (const (Left (Msg ""))) (getArgTys cty)

93− let params = findParams (map snd cons)

93+ let params = findParams n (map snd cons)

9494 logElab 2 $ "Parameters : " ++ show params

9595 -- TI contains information about mutually declared types - this will

9696 -- be updated when the mutual block is complete

@@ -132,13 +132,6 @@ elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)

132132 (nfc, AnnName n Nothing Nothing Nothing))

133133 dcons

134134 where

135− setDetaggable :: Name -> Idris ()

136− setDetaggable n = do

137− ist <- getIState

138− let opt = idris_optimisation ist

139− case lookupCtxt n opt of

140− [oi] -> putIState ist{ idris_optimisation = addDef n oi{ detaggable = True } opt }

141− _ -> putIState ist{ idris_optimisation = addDef n (Optimise [] True) opt }

142135

143136 checkDefinedAs fc n t i

144137 = let defined = tclift $ tfail (At fc (AlreadyDefined n))

@@ -152,62 +145,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)

152145 _ -> defined

153146 _ -> defined

154147 _ -> defined

155− -- parameters are names which are unchanged across the structure,

156− -- which appear exactly once in the return type of a constructor

157−

158− -- First, find all applications of the constructor, then check over

159− -- them for repeated arguments

160−

161− findParams :: [Type] -> [Int]

162− findParams ts = let allapps = map getDataApp ts

163− -- do each constructor separately, then merge the results (names

164− -- may change between constructors)

165− conParams = map paramPos allapps in

166− inAll conParams

167−

168− inAll :: [[Int]] -> [Int]

169− inAll [] = []

170− inAll (x : xs) = filter (\p -> all (\ps -> p `elem` ps) xs) x

171−

172− paramPos [] = []

173− paramPos (args : rest)

174− = dropNothing $ keepSame (zip [0..] args) rest

175−

176− dropNothing [] = []

177− dropNothing ((x, Nothing) : ts) = dropNothing ts

178− dropNothing ((x, _) : ts) = x : dropNothing ts

179−

180− keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] ->

181− [(Int, Maybe Name)]

182− keepSame as [] = as

183− keepSame as (args : rest) = keepSame (update as args) rest

184− where

185− update [] _ = []

186− update _ [] = []

187− update ((n, Just x) : as) (Just x' : args)

188− | x == x' = (n, Just x) : update as args

189− update ((n, _) : as) (_ : args) = (n, Nothing) : update as args

190−

191− getDataApp :: Type -> [[Maybe Name]]

192− getDataApp f@(App _ _ _)

193− | (P _ d _, args) <- unApply f

194− = if (d == n) then [mParam args args] else []

195− getDataApp (Bind n (Pi _ t _) sc)

196− = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc)

197− getDataApp _ = []

198−

199− -- keep the arguments which are single names, which don't appear

200− -- elsewhere

201−

202− mParam args [] = []

203− mParam args (P Bound n _ : rest)

204− | count n args == 1

205− = Just n : mParam args rest

206− where count n [] = 0

207− count n (t : ts)

208− | n `elem` freeNames t = 1 + count n ts

209− | otherwise = count n ts

210− mParam args (_ : rest) = Nothing : mParam args rest

148+

211149

212150 cname (_, _, n, _, _, _, _) = n

213151

@@ -231,7 +169,7 @@ elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

231169 Idris (Name, Type)

232170elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcenames)

233171 = do checkUndefined fc n

234− when (implicitable n) $ warnLC fc n

172+ when (implicitable (nsroot n)) $ warnLC fc n

235173 logElab 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in

236174 (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in)

237175 ctxt <- getContext

@@ -244,7 +182,7 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcen

244182

245183 logElab 5 $ show fc ++ ":Constructor " ++ show n ++ " elaborated : " ++ show t

246184 logElab 5 $ "Inaccessible args: " ++ show inacc

247− logElab 2 $ "---> " ++ show n ++ " : " ++ show cty'

185+ logElab 2 $ "---> " ++ show n ++ " : " ++ show cty

248186

249187 -- Add to the context (this is temporary, so that later constructors

250188 -- can be indexed by it)

@@ -259,9 +197,14 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcen

259197 addIBC (IBCDoc n)

260198 fputState (opt_inaccessible . ist_optimisation n) inacc

261199 addIBC (IBCOpt n)

262− return (n, cty')

200+ return (n, cty)

263201 where

264− tyIs con (Bind n b sc) = tyIs con sc

202+ tyIs con (Bind n b sc) = tyIs con (substV (P Bound n Erased) sc)

203+ tyIs con t | (P Bound n' _, _) <- unApply t

204+ = if n' /= tn then

205+ tclift $ tfail (At fc (Elaborating "constructor " con Nothing

206+ (Msg ("Type level variable " ++ show n' ++ " is not " ++ show tn))))

207+ else return ()

265208 tyIs con t | (P _ n' _, _) <- unApply t

266209 = if n' /= tn then tclift $ tfail (At fc (Elaborating "constructor " con Nothing (Msg (show n' ++ " is not " ++ show tn))))

267210 else return ()

@@ -350,7 +293,7 @@ elabCaseFun ind paramPos n ty cons info = do

350293 (ierror . Elaborating "type declaration of " elimDeclName Nothing)

351294 -- Do not elaborate clauses if there aren't any

352295 case eliminatorClauses of

353− [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type

296+ [] -> State.lift $ solveDeferred emptyFC elimDeclName -- Remove meta-variable for type

354297 _ -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef)

355298 (ierror . Elaborating "clauses of " elimDeclName Nothing)

356299 where elimLog :: String -> EliminatorState ()

src/Idris/Elab/Instance.hs+23−14

@@ -55,28 +55,35 @@ elabInstance :: ElabInfo -> SyntaxInfo ->

5555 [(Name, Docstring (Either Err PTerm))] ->

5656 ElabWhat -> -- phase

5757 FC -> [(Name, PTerm)] -> -- constraints

58+ Accessibility ->

59+ FnOpts ->

5860 Name -> -- the class

5961 FC -> -- precise location of class name

6062 [PTerm] -> -- class parameters (i.e. instance)

6163 PTerm -> -- full instance type

6264 Maybe Name -> -- explicit name

6365 [PDecl] -> Idris ()

64−elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

65− i <- getIState

66− (n, ci) <- case lookupCtxtName n (idris_classes i) of

66+elabInstance info syn doc argDocs what fc cs acc opts n nfc ps t expn ds = do

67+ ist <- getIState

68+ (n, ci) <- case lookupCtxtName n (idris_classes ist) of

6769 [c] -> return c

6870 [] -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

6971 cs -> tclift $ tfail $ At fc

7072 (CantResolveAlts (map fst cs))

7173 let constraint = PApp fc (PRef fc [] n) (map pexp ps)

7274 let iname = mkiname n (namespace info) ps expn

75+ putIState (ist { hide_list = addDef iname acc (hide_list ist) })

76+ ist <- getIState

77+

78+ let totopts = Dictionary : opts

79+

7380 let emptyclass = null (class_methods ci)

7481 when (what /= EDefns) $ do

75− nty <- elabType' True info syn doc argDocs fc [] iname NoFC t

82+ nty <- elabType' True info syn doc argDocs fc totopts iname NoFC t

7683 -- if the instance type matches any of the instances we have already,

7784 -- and it's not a named instance, then it's overlapping, so report an error

7885 case expn of

79− Nothing -> do mapM_ (maybe (return ()) overlapping . findOverlapping i (class_determiners ci) (delab i nty))

86+ Nothing -> do mapM_ (maybe (return ()) overlapping . findOverlapping ist (class_determiners ci) (delab ist nty))

8087 (map fst $ class_instances ci)

8188 addInstance intInst True n iname

8289 Just _ -> addInstance intInst False n iname

@@ -95,7 +102,7 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

95102 let pnames = nub $ map pname (concat (nub wparams)) ++

96103 concatMap (namesIn [] ist) ps

97104 let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci)

98− undefinedSuperclassInstances <- filterM (fmap not . isOverlapping i) superclassInstances

105+ undefinedSuperclassInstances <- filterM (fmap not . isOverlapping ist) superclassInstances

99106 mapM_ (rec_elabDecl info EAll info) undefinedSuperclassInstances

100107 let all_meths = map (nsroot . fst) (class_methods ci)

101108 let mtys = map (\ (n, (op, t)) ->

@@ -108,7 +115,7 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

108115 (class_methods ci)

109116 logElab 3 (show (mtys, ips))

110117 logElab 5 ("Before defaults: " ++ show ds ++ "\n" ++ show (map fst (class_methods ci)))

111− let ds_defs = insertDefaults i iname (class_defaults ci) ns ds

118+ let ds_defs = insertDefaults ist iname (class_defaults ci) ns ds

112119 logElab 3 ("After defaults: " ++ show ds_defs ++ "\n")

113120 let ds' = reorderDefs (map fst (class_methods ci)) $ ds_defs

114121 logElab 1 ("Reordered: " ++ show ds' ++ "\n")

@@ -134,10 +141,10 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

134141 let rhs = PApp fc (PRef fc [] (instanceCtorName ci))

135142 (map (pexp . mkMethApp) mtys)

136143

137− logElab 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars

144+ logElab 5 $ "Instance LHS " ++ show totopts ++ "\n" ++ show lhs ++ " " ++ show headVars

138145 logElab 5 $ "Instance RHS " ++ show rhs

139146

140− let idecls = [PClauses fc [Dictionary] iname

147+ let idecls = [PClauses fc totopts iname

141148 [PClause fc iname lhs [] rhs wb]]

142149 logElab 1 (show idecls)

143150 push_estack iname True

@@ -159,10 +166,10 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

159166 Just m -> sNS (SN (sInstanceN n' (map show ps'))) m

160167 Just nm -> nm

161168

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

169+ substInstance ips pnames (PInstance doc argDocs syn _ cs acc opts n nfc ps t expn ds)

170+ = PInstance doc argDocs syn fc cs acc opts n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds

164171

165− isOverlapping i (PInstance doc argDocs syn _ _ n nfc ps t expn _)

172+ isOverlapping i (PInstance doc argDocs syn _ _ _ _ n nfc ps t expn _)

166173 = case lookupCtxtName n (idris_classes i) of

167174 [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in

168175 case lookupTy iname (tt_ctxt i) of

@@ -179,12 +186,14 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

179186 ty' <- implicit info syn iname ty'

180187 let ty = addImpl [] i ty'

181188 ctxt <- getContext

182− (ElabResult tyT _ _ ctxt' newDecls highlights, _) <-

183− tclift $ elaborate ctxt (idris_datatypes i) iname (TType (UVal 0)) initEState

189+ (ElabResult tyT _ _ ctxt' newDecls highlights newGName, _) <-

190+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) iname (TType (UVal 0)) initEState

184191 (errAt "type of " iname Nothing (erun fc (build i info ERHS [] iname ty)))

185192 setContext ctxt'

186193 processTacticDecls info newDecls

187194 sendHighlighting highlights

195+ updateIState $ \i -> i { idris_name = newGName }

196+

188197 ctxt <- getContext

189198 (cty, _) <- recheckC fc id [] tyT

190199 let nty = normalise ctxt [] cty

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/RunElab.hs+5−3

@@ -32,18 +32,20 @@ elabRunElab info fc script' ns =

3232 mustBeElabScript scriptTy

3333 ist <- getIState

3434 ctxt <- getContext

35− (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-

36− tclift $ elaborate ctxt (idris_datatypes ist) (sMN 0 "toplLevelElab") elabScriptTy initEState

35+ (ElabResult tyT' defer is ctxt' newDecls highlights newGName, log) <-

36+ tclift $ elaborate ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "toplLevelElab") elabScriptTy initEState

3737 (transformErr RunningElabScript

3838 (erun fc (do tm <- runElabAction ist fc [] script ns

3939 EState is _ impls highlights <- getAux

4040 ctxt <- get_context

4141 let ds = [] -- todo

4242 log <- getLog

43− return (ElabResult tm ds (map snd is) ctxt impls highlights))))

43+ newGName <- get_global_nextname

44+ return (ElabResult tm ds (map snd is) ctxt impls highlights newGName))))

4445

4546

4647

4748 setContext ctxt'

4849 processTacticDecls info newDecls

4950 sendHighlighting highlights

51+ updateIState $ \i -> i { idris_name = newGName }

src/Idris/Elab/Term.hs+181−39

@@ -18,9 +18,9 @@ import Idris.Core.Unify

1818import Idris.Core.ProofTerm (getProofTerm)

1919import Idris.Core.Typecheck (check, recheck, converts, isType)

2020import Idris.Core.WHNF (whnf)

21−import Idris.Coverage (buildSCG, checkDeclTotality, genClauses, recoverableCoverage, validCoverageCase)

21+import Idris.Coverage (buildSCG, checkDeclTotality, checkPositive, 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

@@ -52,6 +52,9 @@ data ElabResult =

5252 , resultTyDecls :: [RDeclInstructions]

5353 -- ^ Meta-info about the new type declarations

5454 , resultHighlighting :: [(FC, OutputAnnotation)]

55+ -- ^ Saved highlights from elaboration

56+ , resultName :: Int

57+ -- ^ The new global name counter

5558 }

5659

5760

@@ -122,9 +125,10 @@ build ist info emode opts fn tm

122125 ctxt <- get_context

123126 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

124127 log <- getLog

128+ g_nextname <- get_global_nextname

125129 if log /= ""

126− then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights)

127− else return (ElabResult tm ds (map snd is) ctxt impls highlights)

130+ then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)

131+ else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)

128132 where pattern = emode == ELHS

129133 tydecl = emode == ETyDecl

130134

@@ -166,9 +170,10 @@ buildTC ist info emode opts fn ns tm

166170 ctxt <- get_context

167171 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

168172 log <- getLog

173+ g_nextname <- get_global_nextname

169174 if (log /= "")

170− then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights)

171− else return (ElabResult tm ds (map snd is) ctxt impls highlights)

175+ then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)

176+ else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)

172177 where pattern = emode == ELHS

173178

174179-- return whether arguments of the given constructor name can be

@@ -236,6 +241,7 @@ elab ist info emode opts fn tm

236241 pattern = emode == ELHS

237242 intransform = emode == ETransLHS

238243 bindfree = emode == ETyDecl || emode == ELHS || emode == ETransLHS

244+ autoimpls = opt_autoimpls (idris_options ist)

239245

240246 get_delayed_elab est =

241247 let ds = delayed_elab est in

@@ -614,7 +620,8 @@ elab ist info emode opts fn tm

614620 [] -> False

615621 _ -> True

616622 bindable (NS _ _) = False

617− bindable n = implicitable n

623+ bindable (MN _ _) = True

624+ bindable n = implicitable n && autoimpls

618625 elab' ina _ f@(PInferRef fc hls n) = elab' ina (Just fc) (PApp NoFC f [])

619626 elab' ina fc' tm@(PRef fc hls n)

620627 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

@@ -1156,9 +1163,10 @@ elab ist info emode opts fn tm

11561163 -- capturing lexically available variables in the quoted term.

11571164 ctxt <- get_context

11581165 datatypes <- get_datatypes

1166+ g_nextname <- get_global_nextname

11591167 saveState

11601168 updatePS (const .

1161− newProof (sMN 0 "q") ctxt datatypes $

1169+ newProof (sMN 0 "q") ctxt datatypes g_nextname $

11621170 P Ref (reflm "TT") Erased)

11631171

11641172 -- Re-add the unquotes, letting Idris infer the (fictional)

@@ -1702,8 +1710,8 @@ solveAutos ist fn ambigok

17021710-- Return true if the given error suggests a type class failure is

17031711-- recoverable

17041712tcRecoverable :: ElabMode -> Err -> Bool

1705−tcRecoverable ERHS (CantResolve f g) = f

1706−tcRecoverable ETyDecl (CantResolve f g) = f

1713+tcRecoverable ERHS (CantResolve f g _) = f

1714+tcRecoverable ETyDecl (CantResolve f g _) = f

17071715tcRecoverable e (ElaboratingArg _ _ _ err) = tcRecoverable e err

17081716tcRecoverable e (At _ err) = tcRecoverable e err

17091717tcRecoverable _ _ = True

@@ -1837,11 +1845,74 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

18371845 updateAux $ \e -> e { new_tyDecls = RClausesInstrs n clauses'' : new_tyDecls e}

18381846 return ()

18391847

1848+

18401849 checkClosed :: Raw -> Elab' aux (Term, Type)

18411850 checkClosed tm = do ctxt <- get_context

18421851 (val, ty) <- lift $ check ctxt [] tm

18431852 return $! (finalise val, finalise ty)

18441853

1854+ -- | Add another argument to a Pi

1855+ mkPi :: RFunArg -> Raw -> Raw

1856+ mkPi arg rTy = RBind (argName arg) (Pi Nothing (argTy arg) (RUType AllTypes)) rTy

1857+

1858+ mustBeType ctxt tm ty =

1859+ case normaliseAll ctxt [] (finalise ty) of

1860+ UType _ -> return ()

1861+ TType _ -> return ()

1862+ ty' -> lift . tfail . InternalMsg $

1863+ show tm ++ " is not a type: it's " ++ show ty'

1864+

1865+ mustNotBeDefined ctxt n =

1866+ case lookupDefExact n ctxt of

1867+ Just _ -> lift . tfail . InternalMsg $

1868+ show n ++ " is already defined."

1869+ Nothing -> return ()

1870+

1871+ -- | Prepare a constructor to be added to a datatype being defined here

1872+ prepareConstructor :: Name -> RConstructorDefn -> ElabD (Name, [PArg], Type)

1873+ prepareConstructor tyn (RConstructor cn args resTy) =

1874+ do ctxt <- get_context

1875+ -- ensure the constructor name is not qualified, and

1876+ -- construct a qualified one

1877+ notQualified cn

1878+ let qcn = qualify cn

1879+

1880+ -- ensure that the constructor name is not defined already

1881+ mustNotBeDefined ctxt qcn

1882+

1883+ -- construct the actual type for the constructor

1884+ let cty = foldr mkPi resTy args

1885+ (checkedTy, ctyTy) <- lift $ check ctxt [] cty

1886+ mustBeType ctxt checkedTy ctyTy

1887+

1888+ -- ensure that the constructor builds the right family

1889+ case unApply (getRetTy (normaliseAll ctxt [] (finalise checkedTy))) of

1890+ (P _ n _, _) | n == tyn -> return ()

1891+ t -> lift . tfail . Msg $ "The constructor " ++ show cn ++

1892+ " doesn't construct " ++ show tyn ++

1893+ " (return type is " ++ show t ++ ")"

1894+

1895+ -- add temporary type declaration for constructor (so it can

1896+ -- occur in later constructor types)

1897+ set_context (addTyDecl qcn (DCon 0 0 False) checkedTy ctxt)

1898+

1899+ -- Save the implicits for high-level Idris

1900+ let impls = map rFunArgToPArg args

1901+

1902+ return (qcn, impls, checkedTy)

1903+

1904+ where

1905+ notQualified (NS _ _) = lift . tfail . Msg $ "Constructor names may not be qualified"

1906+ notQualified _ = return ()

1907+

1908+ qualify n = case tyn of

1909+ (NS _ ns) -> NS n ns

1910+ _ -> n

1911+

1912+ getRetTy :: Type -> Type

1913+ getRetTy (Bind _ (Pi _ _ _) sc) = getRetTy sc

1914+ getRetTy ty = ty

1915+

18451916 -- | Do a step in the reflected elaborator monad. The input is the

18461917 -- step, the output is the (reflected) term returned.

18471918 runTacTm :: Term -> ElabD Term

@@ -2050,20 +2121,10 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

20502121 | n == tacN "Prim__DeclareType", [decl] <- args

20512122 = do (RDeclare n args res) <- reifyTyDecl decl

20522123 ctxt <- get_context

2053− let mkPi arg res = RBind (argName arg)

2054− (Pi Nothing (argTy arg) (RUType AllTypes))

2055− res

2056− rty = foldr mkPi res args

2124+ let rty = foldr mkPi res args

20572125 (checked, ty') <- lift $ check ctxt [] rty

2058− case normaliseAll ctxt [] (finalise ty') of

2059− UType _ -> return ()

2060− TType _ -> return ()

2061− ty'' -> lift . tfail . InternalMsg $

2062− show checked ++ " is not a type: it's " ++ show ty''

2063− case lookupDefExact n ctxt of

2064− Just _ -> lift . tfail . InternalMsg $

2065− show n ++ " is already defined."

2066− Nothing -> return ()

2126+ mustBeType ctxt checked ty'

2127+ mustNotBeDefined ctxt n

20672128 let decl = TyDecl Ref checked

20682129 ctxt' = addCtxtDef n decl ctxt

20692130 set_context ctxt'

@@ -2074,11 +2135,46 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

20742135 = do defn <- reifyFunDefn decl

20752136 defineFunction defn

20762137 returnUnit

2138+ | n == tacN "Prim__DeclareDatatype", [decl] <- args

2139+ = do RDeclare n args resTy <- reifyTyDecl decl

2140+ ctxt <- get_context

2141+ let tcTy = foldr mkPi resTy args

2142+ (checked, ty') <- lift $ check ctxt [] tcTy

2143+ mustBeType ctxt checked ty'

2144+ mustNotBeDefined ctxt n

2145+ let ctxt' = addTyDecl n (TCon 0 0) checked ctxt

2146+ set_context ctxt'

2147+ updateAux $ \e -> e { new_tyDecls = RDatatypeDeclInstrs n (map rFunArgToPArg args) : new_tyDecls e }

2148+ returnUnit

2149+ | n == tacN "Prim__DefineDatatype", [defn] <- args

2150+ = do RDefineDatatype n ctors <- reifyRDataDefn defn

2151+ ctxt <- get_context

2152+ tyconTy <- case lookupTyExact n ctxt of

2153+ Just t -> return t

2154+ Nothing -> lift . tfail . Msg $ "Type not previously declared"

2155+ datatypes <- get_datatypes

2156+ case lookupCtxtName n datatypes of

2157+ [] -> return ()

2158+ _ -> lift . tfail . Msg $ show n ++ " is already defined as a datatype."

2159+ -- Prepare the constructors

2160+ ctors' <- mapM (prepareConstructor n) ctors

2161+ ttag <- do ES (ps, aux) str prev <- get

2162+ let i = global_nextname ps

2163+ put $ ES (ps { global_nextname = global_nextname ps + 1 },

2164+ aux)

2165+ str

2166+ prev

2167+ return i

2168+ let ctxt' = addDatatype (Data n ttag tyconTy False (map (\(cn, _, cty) -> (cn, cty)) ctors')) ctxt

2169+ set_context ctxt'

2170+ -- the rest happens in a bit

2171+ updateAux $ \e -> e { new_tyDecls = RDatatypeDefnInstrs n tyconTy ctors' : new_tyDecls e }

2172+ returnUnit

20772173 | n == tacN "Prim__AddInstance", [cls, inst] <- args

20782174 = do className <- reifyTTName cls

20792175 instName <- reifyTTName inst

20802176 updateAux $ \e -> e { new_tyDecls = RAddInstance className instName :

2081− new_tyDecls e}

2177+ new_tyDecls e }

20822178 returnUnit

20832179 | n == tacN "Prim__IsTCName", [n] <- args

20842180 = do n' <- reifyTTName n

@@ -2113,6 +2209,7 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

21132209 aux <- getAux

21142210 datatypes <- get_datatypes

21152211 env <- get_env

2212+ g_next <- get_global_nextname

21162213

21172214 (ctxt', ES (p, aux') _ _) <-

21182215 do (ES (current_p, _) _ _) <- get

@@ -2120,13 +2217,15 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

21202217 (do runElabAction ist fc [] script ns

21212218 ctxt' <- get_context

21222219 return ctxt')

2123− ((newProof recH ctxt datatypes goalTT)

2220+ ((newProof recH ctxt datatypes g_next goalTT)

21242221 { nextname = nextname current_p })

21252222 set_context ctxt'

21262223

21272224 let tm_out = getProofTerm (pterm p)

21282225 do (ES (prf, _) s e) <- get

2129− let p' = prf { nextname = nextname p }

2226+ let p' = prf { nextname = nextname p

2227+ , global_nextname = global_nextname p

2228+ }

21302229 put (ES (p', aux') s e)

21312230 env' <- get_env

21322231 (tm, ty, _) <- lift $ recheck ctxt' env (forget tm_out) tm_out

@@ -2476,8 +2575,10 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

24762575 OK hs -> return hs

24772576

24782577 -- Normalize error handler terms to produce the new messages

2578+ -- Need to use 'normaliseAll' since we have to reduce private

2579+ -- names in error handlers too

24792580 ctxt <- getContext

2480− let results = map (normalise ctxt []) (map fst handlers)

2581+ let results = map (normaliseAll ctxt []) (map fst handlers)

24812582 logElab 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

24822583

24832584 -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

@@ -2504,7 +2605,7 @@ processTacticDecls info steps =

25042605 updateIState $ \i -> i { idris_implicits =

25052606 addDef n impls (idris_implicits i) }

25062607 addIBC (IBCImp n)

2507− ds <- checkDef fc (\_ e -> e) [(n, (-1, Nothing, ty, []))]

2608+ ds <- checkDef fc (\_ e -> e) True [(n, (-1, Nothing, ty, []))]

25082609 addIBC (IBCDef n)

25092610 ctxt <- getContext

25102611 case lookupDef n ctxt of

@@ -2513,9 +2614,53 @@ processTacticDecls info steps =

25132614 -- then it must be added as a metavariable. This needs guarding

25142615 -- to prevent overwriting case defs with a metavar, if the case

25152616 -- defs come after the type decl in the same script!

2516− let ds' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True))) ds

2617+ let ds' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True, True))) ds

25172618 in addDeferred ds'

25182619 _ -> return ()

2620+ RDatatypeDeclInstrs n impls ->

2621+ do addIBC (IBCDef n)

2622+ updateIState $ \i -> i { idris_implicits = addDef n impls (idris_implicits i) }

2623+ addIBC (IBCImp n)

2624+

2625+ RDatatypeDefnInstrs tyn tyconTy ctors ->

2626+ do let cn (n, _, _) = n

2627+ cimpls (_, impls, _) = impls

2628+ cty (_, _, t) = t

2629+ addIBC (IBCDef tyn)

2630+ mapM_ (addIBC . IBCDef . cn) ctors

2631+ let params = findParams tyn (map cty ctors)

2632+ let typeInfo = TI (map cn ctors) False [] params []

2633+ -- implicit precondition to IBCData is that idris_datatypes on the IState is populated.

2634+ -- otherwise writing the IBC just fails silently!

2635+ updateIState $ \i -> i { idris_datatypes =

2636+ addDef tyn typeInfo (idris_datatypes i) }

2637+ addIBC (IBCData tyn)

2638+

2639+

2640+ ttag <- getName -- from AbsSyntax.hs, really returns a disambiguating Int

2641+

2642+ let metainf = DataMI params

2643+ addIBC (IBCMetaInformation tyn metainf)

2644+ updateContext (setMetaInformation tyn metainf)

2645+

2646+ for_ ctors $ \(cn, impls, _) ->

2647+ do updateIState $ \i -> i { idris_implicits = addDef cn impls (idris_implicits i) }

2648+ addIBC (IBCImp cn)

2649+

2650+ for_ ctors $ \(ctorN, _, _) ->

2651+ do totcheck (NoFC, ctorN)

2652+ ctxt <- tt_ctxt <$> getIState

2653+ case lookupTyExact ctorN ctxt of

2654+ Just cty -> do checkPositive (tyn : map cn ctors) (ctorN, cty)

2655+ return ()

2656+ Nothing -> return ()

2657+

2658+ case ctors of

2659+ [ctor] -> do setDetaggable (cn ctor); setDetaggable tyn

2660+ addIBC (IBCOpt (cn ctor)); addIBC (IBCOpt tyn)

2661+ _ -> return ()

2662+ -- TODO: inaccessible

2663+

25192664 RAddInstance className instName ->

25202665 do -- The type class resolution machinery relies on a special

25212666 logElab 2 $ "Adding elab script instance " ++ show instName ++

@@ -2524,7 +2669,7 @@ processTacticDecls info steps =

25242669 addIBC (IBCInstance False True className instName)

25252670 RClausesInstrs n cs ->

25262671 do logElab 3 $ "Pattern-matching definition from tactics: " ++ show n

2527− solveDeferred n

2672+ solveDeferred emptyFC n

25282673 let lhss = map (\(_, lhs, _) -> lhs) cs

25292674 let fc = fileFC "elab_reflected"

25302675 pmissing <-

@@ -2549,13 +2694,9 @@ processTacticDecls info steps =

25492694 -- we refer to, so that if they aren't total, the whole

25502695 -- thing won't be.

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

2697+ calls = map fst $ findCalls sc scargs

2698+ in do logElab 2 $ "Called names in reflected elab: " ++ show calls

2699+ addCalls n calls

25592700 addIBC $ IBCCG n

25602701 Just _ -> return () -- TODO throw internal error

25612702 Nothing -> return ()

@@ -2581,13 +2722,14 @@ processTacticDecls info steps =

25812722 let lhs = addImplPat ist lhs_in

25822723 let fc = fileFC "elab_reflected_totality"

25832724 let tcgen = False -- TODO: later we may support dictionary generation

2584− case elaborate ctxt (idris_datatypes ist) (sMN 0 "refPatLHS") infP initEState

2725+ case elaborate ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "refPatLHS") infP initEState

25852726 (erun fc (buildTC ist info ELHS [] fname (allNamesIn lhs_in)

25862727 (infTerm lhs))) of

2587− OK (ElabResult lhs' _ _ _ _ _, _) ->

2728+ OK (ElabResult lhs' _ _ _ _ _ name', _) ->

25882729 do -- not recursively calling here, because we don't

25892730 -- want to run infinitely many times

25902731 let lhs_tm = orderPats (getInferTerm lhs')

2732+ updateIState $ \i -> i { idris_name = name' }

25912733 case recheck ctxt [] (forget lhs_tm) lhs_tm of

25922734 OK _ -> return True

25932735 err -> return False

src/Idris/Elab/Transform.hs+10−6

@@ -54,13 +54,14 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ _ tf) _) rhs_in

5454 i <- getIState

5555 let lhs = addImplPat i lhs_in

5656 logElab 5 ("Transform LHS input: " ++ showTmImpls lhs)

57− (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

58− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transLHS") infP initEState

57+ (ElabResult lhs' dlhs [] ctxt' newDecls highlights newGName, _) <-

58+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "transLHS") infP initEState

5959 (erun fc (buildTC i info ETransLHS [] (sUN "transform")

6060 (allNamesIn lhs_in) (infTerm lhs)))

6161 setContext ctxt'

6262 processTacticDecls info newDecls

6363 sendHighlighting highlights

64+ updateIState $ \i -> i { idris_name = newGName }

6465 let lhs_tm = orderPats (getInferTerm lhs')

6566 let lhs_ty = getInferType lhs'

6667 let newargs = pvars i lhs_tm

@@ -73,18 +74,21 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ _ tf) _) rhs_in

7374 let rhs = addImplBound i (map fst newargs) rhs_in

7475 logElab 5 ("Transform RHS input: " ++ showTmImpls rhs)

7576

76− ((rhs', defer, ctxt', newDecls), _) <-

77− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transRHS") clhs_ty initEState

77+ ((rhs', defer, ctxt', newDecls, newGName), _) <-

78+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "transRHS") clhs_ty initEState

7879 (do pbinds i lhs_tm

7980 setNextName

80− (ElabResult _ _ _ ctxt' newDecls highlights) <- erun fc (build i info ERHS [] (sUN "transform") rhs)

81+ (ElabResult _ _ _ ctxt' newDecls highlights newGName) <- erun fc (build i info ERHS [] (sUN "transform") rhs)

82+ set_global_nextname newGName

8183 erun fc $ psolve lhs_tm

8284 tt <- get_term

8385 let (rhs', defer) = runState (collectDeferred Nothing [] ctxt tt) []

84− return (rhs', defer, ctxt', newDecls))

86+ newGName <- get_global_nextname

87+ return (rhs', defer, ctxt', newDecls, newGName))

8588 setContext ctxt'

8689 processTacticDecls info newDecls

8790 sendHighlighting highlights

91+ updateIState $ \i -> i { idris_name = newGName }

8892

8993 (crhs_tm_in, crhs_ty) <- recheckC_borrowing False False [] fc id [] rhs'

9094 let crhs_tm = renamepats pnames crhs_tm_in

src/Idris/Elab/Type.hs+22−8

@@ -67,18 +67,19 @@ buildType info syn fc opts n ty' = do

6767 logElab 5 $ show "with methods " ++ show (imp_methods syn)

6868 logElab 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty

6969

70− (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-

71− tclift $ elaborate ctxt (idris_datatypes i) n (TType (UVal 0)) initEState

70+ (ElabResult tyT' defer is ctxt' newDecls highlights newGName, log) <-

71+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) n (TType (UVal 0)) initEState

7272 (errAt "type of " n Nothing (erun fc (build i info ETyDecl [] n ty)))

7373 setContext ctxt'

7474 processTacticDecls info newDecls

75− sendHighlighting highlights

75+ sendHighlighting highlights

76+ updateIState $ \i -> i { idris_name = newGName }

7677

7778 let tyT = patToImp tyT'

7879

7980 logElab 3 $ show ty ++ "\nElaborated: " ++ show tyT'

8081

81− ds <- checkAddDef True False fc iderr defer

82+ ds <- checkAddDef True False fc iderr True defer

8283 -- if the type is not complete, note that we'll need to infer

8384 -- things later (for solving metavariables)

8485 when (length ds > length is) -- more deferred than case blocks

@@ -102,6 +103,18 @@ buildType info syn fc opts n ty' = do

102103 logElab 3 ("Implicit " ++ show n ++ " " ++ show impls)

103104 addIBC (IBCImp n)

104105

106+ -- Add the names referenced to the call graph, and check we're not

107+ -- referring to anything less visible

108+ -- In particular, a public/export type can not refer to anything

109+ -- private, but can refer to any public/export

110+ let refs = freeNames cty

111+ nvis <- getFromHideList n

112+ case nvis of

113+ Nothing -> return ()

114+ Just acc -> mapM_ (checkVisibility fc n (max Frozen acc) acc) refs

115+ addCalls n refs

116+ addIBC (IBCCG n)

117+

105118 when (Constructor `notElem` opts) $ do

106119 let pnames = getParamsInType i [] impls cty

107120 let fninfo = FnInfo (param_pos 0 pnames cty)

@@ -161,9 +174,10 @@ elabType' norm info syn doc argDocs fc opts n nfc ty' = {- let ty' = piBind (par

161174 -- Productivity checking now via checking for guarded 'Delay'

162175 let opts' = opts -- if corec then (Coinductive : opts) else opts

163176 let usety = if norm then nty' else nty

164− ds <- checkDef fc iderr [(n, (-1, Nothing, usety, []))]

177+ ds <- checkDef fc iderr True [(n, (-1, Nothing, usety, []))]

165178 addIBC (IBCDef n)

166− let ds' = map (\(n, (i, top, fam, ns)) -> (n, (i, top, fam, ns, True))) ds

179+ addDefinedName n

180+ let ds' = map (\(n, (i, top, fam, ns)) -> (n, (i, top, fam, ns, True, True))) ds

167181 addDeferred ds'

168182 setFlags n opts'

169183 checkDocs fc argDocs ty

@@ -242,7 +256,7 @@ elabPostulate info syn doc fc nfc opts n ty = do

242256 sendHighlighting [(nfc, AnnName n (Just PostulateOutput) Nothing Nothing)]

243257

244258 -- remove it from the deferred definitions list

245− solveDeferred n

259+ solveDeferred fc n

246260

247261elabExtern :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

248262 FC -> FC -> FnOpts -> Name -> PTerm -> Idris ()

@@ -255,4 +269,4 @@ elabExtern info syn doc fc nfc opts n ty = do

255269 addIBC (IBCExtern (n, arity))

256270

257271 -- remove it from the deferred definitions list

258− solveDeferred n

272+ solveDeferred fc n

src/Idris/Elab/Utils.hs+90−9

@@ -56,21 +56,23 @@ checkDeprecated fc n

5656iderr :: Name -> Err -> Err

5757iderr _ e = e

5858

59−checkDef :: FC -> (Name -> Err -> Err) -> [(Name, (Int, Maybe Name, Type, [Name]))]

60− -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]

61−checkDef fc mkerr ns = checkAddDef False True fc mkerr ns

59+checkDef :: FC -> (Name -> Err -> Err) -> Bool ->

60+ [(Name, (Int, Maybe Name, Type, [Name]))] ->

61+ Idris [(Name, (Int, Maybe Name, Type, [Name]))]

62+checkDef fc mkerr definable ns

63+ = checkAddDef False True fc mkerr definable ns

6264

63−checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err)

65+checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err) -> Bool

6466 -> [(Name, (Int, Maybe Name, Type, [Name]))]

6567 -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]

66−checkAddDef add toplvl fc mkerr [] = return []

67−checkAddDef add toplvl fc mkerr ((n, (i, top, t, psns)) : ns)

68+checkAddDef add toplvl fc mkerr def [] = return []

69+checkAddDef add toplvl fc mkerr definable ((n, (i, top, t, psns)) : ns)

6870 = do ctxt <- getContext

69− logElab 5 $ "Rechecking deferred name " ++ show (n, t)

71+ logElab 5 $ "Rechecking deferred name " ++ show (n, t, definable)

7072 (t', _) <- recheckC fc (mkerr n) [] t

71− when add $ do addDeferred [(n, (i, top, t, psns, toplvl))]

73+ when add $ do addDeferred [(n, (i, top, t, psns, toplvl, definable))]

7274 addIBC (IBCDef n)

73− ns' <- checkAddDef add toplvl fc mkerr ns

75+ ns' <- checkAddDef add toplvl fc mkerr definable ns

7476 return ((n, (i, top, t', psns)) : ns')

7577

7678-- | Get the list of (index, name) of inaccessible arguments from an elaborated

@@ -314,3 +316,82 @@ mkStaticTy ns (PPi p n fc ty sc)

314316 | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)

315317 | otherwise = PPi p n fc ty (mkStaticTy ns sc)

316318mkStaticTy ns t = t

319+

320+-- Check that a name has the minimum required accessibility

321+checkVisibility :: FC -> Name -> Accessibility -> Accessibility -> Name -> Idris ()

322+checkVisibility fc n minAcc acc ref

323+ = do nvis <- getFromHideList ref

324+ case nvis of

325+ Nothing -> return ()

326+ Just acc' -> if acc' > minAcc

327+ then tclift $ tfail (At fc

328+ (Msg $ show acc ++ " " ++ show n ++

329+ " can't refer to " ++

330+ show acc' ++ " " ++ show ref))

331+ else return ()

332+

333+

334+-- | Find the type constructor arguments that are parameters, given a list of constructor types.

335+-- Parameters are names which are unchanged across the structure,

336+-- which appear exactly once in the return type of a constructor

337+-- First, find all applications of the constructor, then check over

338+-- them for repeated arguments

339+findParams :: Name -- ^ the name of the family that we are finding parameters for

340+ -> [Type] -- ^ the declared constructor types

341+ -> [Int]

342+findParams tyn ts =

343+ let allapps = map getDataApp ts

344+ -- do each constructor separately, then merge the results (names

345+ -- may change between constructors)

346+ conParams = map paramPos allapps

347+ in inAll conParams

348+

349+ where

350+ inAll :: [[Int]] -> [Int]

351+ inAll [] = []

352+ inAll (x : xs) = filter (\p -> all (\ps -> p `elem` ps) xs) x

353+

354+ paramPos [] = []

355+ paramPos (args : rest)

356+ = dropNothing $ keepSame (zip [0..] args) rest

357+ dropNothing [] = []

358+ dropNothing ((x, Nothing) : ts) = dropNothing ts

359+ dropNothing ((x, _) : ts) = x : dropNothing ts

360+ keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] ->

361+ [(Int, Maybe Name)]

362+ keepSame as [] = as

363+ keepSame as (args : rest) = keepSame (update as args) rest

364+ where

365+ update [] _ = []

366+ update _ [] = []

367+ update ((n, Just x) : as) (Just x' : args)

368+ | x == x' = (n, Just x) : update as args

369+ update ((n, _) : as) (_ : args) = (n, Nothing) : update as args

370+ getDataApp :: Type -> [[Maybe Name]]

371+ getDataApp f@(App _ _ _)

372+ | (P _ d _, args) <- unApply f

373+ = if (d == tyn) then [mParam args args] else []

374+ getDataApp (Bind n (Pi _ t _) sc)

375+ = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc)

376+ getDataApp _ = []

377+ -- keep the arguments which are single names, which don't appear

378+ -- elsewhere

379+ mParam args [] = []

380+ mParam args (P Bound n _ : rest)

381+ | count n args == 1

382+ = Just n : mParam args rest

383+ where count n [] = 0

384+ count n (t : ts)

385+ | n `elem` freeNames t = 1 + count n ts

386+ | otherwise = count n ts

387+ mParam args (_ : rest) = Nothing : mParam args rest

388+

389+-- | Mark a name as detaggable in the global state (should be called

390+-- for type and constructor names of single-constructor datatypes)

391+setDetaggable :: Name -> Idris ()

392+setDetaggable n = do

393+ ist <- getIState

394+ let opt = idris_optimisation ist

395+ case lookupCtxt n opt of

396+ [oi] -> putIState ist { idris_optimisation = addDef n oi { detaggable = True } opt }

397+ _ -> putIState ist { idris_optimisation = addDef n (Optimise [] True) opt }

src/Idris/Elab/Value.hs+5−4

@@ -64,19 +64,20 @@ elabValBind info aspat norm tm_in

6464 -- * elaboration as a Type

6565 -- * elaboration as a function a -> b

6666

67− (ElabResult tm' defer is ctxt' newDecls highlights, _) <-

68− tclift (elaborate ctxt (idris_datatypes i) (sMN 0 "val") infP initEState

67+ (ElabResult tm' defer is ctxt' newDecls highlights newGName, _) <-

68+ tclift (elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "val") infP initEState

6969 (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

7070

7171 -- Extend the context with new definitions created

7272 setContext ctxt'

7373 processTacticDecls info newDecls

7474 sendHighlighting highlights

75+ updateIState $ \i -> i { idris_name = newGName }

7576

7677 let vtm = orderPats (getInferTerm tm')

7778

78− def' <- checkDef (fileFC "(input)") iderr defer

79− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True))) def'

79+ def' <- checkDef (fileFC "(input)") iderr True defer

80+ let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True, True))) def'

8081 addDeferred def''

8182 mapM_ (elabCaseBlock info []) is

8283

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 fnopts 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 fnopts 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+98−67

@@ -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 = 136

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))],

@@ -79,7 +84,7 @@ data IBCFile = IBCFile { ver :: Word16,

7984 ibc_metainformation :: ![(Name, MetaInformation)],

8085 ibc_errorhandlers :: ![Name],

8186 ibc_function_errorhandlers :: ![(Name, Name, Name)], -- fn, arg, handler

82− ibc_metavars :: ![(Name, (Maybe Name, Int, [Name], Bool))],

87+ ibc_metavars :: ![(Name, (Maybe Name, Int, [Name], Bool, Bool))],

8388 ibc_patdefs :: ![(Name, ([([(Name, Term)], Term, Term)], [PTerm]))],

8489 ibc_postulates :: ![Name],

8590 ibc_externs :: ![(Name, Int)],

@@ -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 ()

@@ -429,6 +443,7 @@ pImps imps = mapM_ (\ (n, imp) ->

429443 do i <- getIState

430444 case lookupDefAccExact n False (tt_ctxt i) of

431445 Just (n, Hidden) -> return ()

446+ Just (n, Private) -> return ()

432447 _ -> putIState (i { idris_implicits

433448 = addDef n imp (idris_implicits i) }))

434449 imps

@@ -518,12 +533,9 @@ pDefs reexp ds

518533 case d' of

519534 TyDecl _ _ -> return ()

520535 _ -> do logIBC 1 $ "SOLVING " ++ show n

521− solveDeferred n

536+ solveDeferred emptyFC n

522537 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

538+ ) ds

527539 where

528540 updateDef (CaseOp c t args o s cd)

529541 = do o' <- mapM updateOrig o

@@ -537,11 +549,9 @@ pDefs reexp ds

537549 return $ Right (l', r')

538550

539551 updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

540− = do t' <- updateSC t

541− c' <- updateSC c

542− i' <- updateSC i

552+ = do c' <- updateSC c

543553 r' <- updateSC r

544− return $ CaseDefs (ts, t') (cs, c') (is, i') (rs, r')

554+ return $ CaseDefs (cs, c') (cs, c') (cs, c') (rs, r')

545555

546556 updateSC (Case t n alts) = do alts' <- mapM updateAlt alts

547557 return (Case t n alts')

@@ -562,19 +572,28 @@ pDefs reexp ds

562572 updateAlt (DefaultCase t) = do t' <- updateSC t

563573 return (DefaultCase t')

564574

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'

575+ -- We get a lot of repetition in sub terms and can save a fair chunk

576+ -- of memory if we make sure they're shared. addTT looks for a term

577+ -- and returns it if it exists already, while also keeping stats of

578+ -- how many times a subterm is repeated.

579+ update t = do tm <- addTT t

580+ case tm of

581+ Nothing -> update' t

582+ Just t' -> return t'

583+

584+ update' (P t n ty) = do n' <- getSymbol n

585+ return $ P t n' ty

586+ update' (App s f a) = liftM2 (App s) (update' f) (update' a)

587+ update' (Bind n b sc) = do b' <- updateB b

588+ sc' <- update sc

589+ return $ Bind n b' sc'

571590 where

572− updateB (Let t v) = liftM2 Let (update t) (update v)

573− updateB b = do ty' <- update (binderTy b)

591+ updateB (Let t v) = liftM2 Let (update' t) (update' v)

592+ updateB b = do ty' <- update' (binderTy b)

574593 return (b { binderTy = ty' })

575− update (Proj t i) = do t' <- update t

576− return $ Proj t' i

577− update t = return t

594+ update' (Proj t i) = do t' <- update' t

595+ return $ Proj t' i

596+ update' t = return t

578597

579598pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris ()

580599pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds

@@ -584,12 +603,22 @@ pMDocs ds = mapM_ (\ (n, d) -> updateIState (\i ->

584603 i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds

585604

586605pAccess :: Bool -- ^ Reexporting?

606+ -> IBCPhase

587607 -> [(Name, Accessibility)] -> Idris ()

588−pAccess reexp ds

608+pAccess reexp phase ds

589609 = mapM_ (\ (n, a_in) ->

590610 do let a = if reexp then a_in else Hidden

591611 logIBC 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a

592− updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })) ds

612+ updateIState (\i -> i { tt_ctxt = setAccess n a (tt_ctxt i) })

613+

614+ if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n

615+ setAccessibility n Hidden

616+ else logIBC 1 $ "Exporting " ++ show n

617+ -- Everything should be available at the REPL from

618+ -- things imported publicly

619+ when (phase == IBC_REPL True) $

620+ setAccessibility n Public

621+ ) ds

593622

594623pFlags :: [(Name, [FnOpt])] -> Idris ()

595624pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds

@@ -633,7 +662,7 @@ pFunctionErrorHandlers :: [(Name, Name, Name)] -> Idris ()

633662pFunctionErrorHandlers ns = mapM_ (\ (fn,arg,handler) ->

634663 addFunctionErrorHandlers fn arg [handler]) ns

635664

636−pMetavars :: [(Name, (Maybe Name, Int, [Name], Bool))] -> Idris ()

665+pMetavars :: [(Name, (Maybe Name, Int, [Name], Bool, Bool))] -> Idris ()

637666pMetavars ns = updateIState (\i -> i { idris_metavars = L.reverse ns ++ idris_metavars i })

638667

639668----- For Cheapskate and docstrings

@@ -753,18 +782,14 @@ instance Binary SizeChange where

753782 _ -> error "Corrupted binary data for SizeChange"

754783

755784instance Binary CGInfo where

756− put (CGInfo x1 x2 x3 x4 x5)

785+ put (CGInfo x1 x2 x3)

757786 = do put x1

758− put x2

759787-- put x3 -- Already used SCG info for totality check

760− put x4

761− put x5

788+ put x3

762789 get

763790 = do x1 <- get

764− x2 <- get

765− x4 <- get

766− x5 <- get

767− return (CGInfo x1 x2 [] x4 x5)

791+ x3 <- get

792+ return (CGInfo x1 [] x3)

768793

769794instance Binary CaseType where

770795 put x = case x of

@@ -883,13 +908,13 @@ instance Binary Def where

883908 put x2

884909 -- all primitives just get added at the start, don't write

885910 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

911+ -- no need to add/load original patterns, because they're not

912+ -- used again after totality checking

913+ CaseOp x1 x2 x3 _ _ x4 -> do putWord8 3

914+ put x1

915+ put x2

916+ put x3

917+ put x4

893918 get

894919 = do i <- getWord8

895920 case i of

@@ -903,10 +928,10 @@ instance Binary Def where

903928 3 -> do x1 <- get

904929 x2 <- get

905930 x3 <- get

906− x4 <- get

931+-- x4 <- get

907932 -- x3 <- get always []

908933 x5 <- get

909− return (CaseOp x1 x2 x3 x4 [] x5)

934+ return (CaseOp x1 x2 x3 [] [] x5)

910935 _ -> error "Corrupted binary data for Def"

911936

912937instance Binary Accessibility where

@@ -914,13 +939,15 @@ instance Binary Accessibility where

914939 = case x of

915940 Public -> putWord8 0

916941 Frozen -> putWord8 1

917− Hidden -> putWord8 2

942+ Private -> putWord8 2

943+ Hidden -> putWord8 3

918944 get

919945 = do i <- getWord8

920946 case i of

921947 0 -> return Public

922948 1 -> return Frozen

923− 2 -> return Hidden

949+ 2 -> return Private

950+ 3 -> return Hidden

924951 _ -> error "Corrupted binary data for Accessibility"

925952

926953safeToEnum :: (Enum a, Bounded a, Integral int) => String -> int -> a

@@ -1235,7 +1262,7 @@ instance (Binary t) => Binary (PDecl' t) where

12351262 put x10

12361263 put x11

12371264 put x12

1238− PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 ->

1265+ PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 ->

12391266 do putWord8 8

12401267 put x1

12411268 put x2

@@ -1248,6 +1275,8 @@ instance (Binary t) => Binary (PDecl' t) where

12481275 put x9

12491276 put x10

12501277 put x11

1278+ put x12

1279+ put x13

12511280 PDSL x1 x2 -> do putWord8 9

12521281 put x1

12531282 put x2

@@ -1362,7 +1391,9 @@ instance (Binary t) => Binary (PDecl' t) where

13621391 x9 <- get

13631392 x10 <- get

13641393 x11 <- get

1365− return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

1394+ x12 <- get

1395+ x13 <- get

1396+ return (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)

13661397 9 -> do x1 <- get

13671398 x2 <- get

13681399 return (PDSL x1 x2)

src/Idris/IdrisDoc.hs+3−3

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

@@ -182,7 +182,7 @@ filterName _ = False

182182

183183

184184-- | Whether a NsItem should be included in the documentation.

185−-- It must not be Hidden and filterName must return True for the name.

185+-- It must not be Hidden/Private and filterName must return True for the name.

186186-- Also it must have Docs -- without Docs, nothing can be done.

187187filterInclude :: NsItem -- ^ Accessibility to check

188188 -> Bool -- ^ Predicate result

@@ -254,7 +254,7 @@ getAccess ist n =

254254 let res = lookupDefAcc n False (tt_ctxt ist)

255255 in case res of

256256 [(_, acc)] -> acc

257− _ -> Hidden

257+ _ -> Private

258258

259259-- | Simple predicate for whether an NsItem has Docs

260260hasDoc :: NsItem -- ^ The NsItem to test

src/Idris/Interactive.hs+78−46

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

@@ -172,7 +172,7 @@ makeWith fn updatefile l n

172172 ++ with ++ "\n" ++

173173 unlines rest)

174174 runIO $ copyFile fb fn

175− else iPrintResult with

175+ else iPrintResult (with ++ "\n")

176176 where getIndent s = length (takeWhile isSpace s)

177177

178178-- Replace the given metavariable on the given line with a 'case'

@@ -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,15 +230,15 @@ 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

235− Just (t, e, ns, False) -> (t, e, ns, False)

236− _ -> (Nothing, 0, [], True)

235+ Just (t, e, ns, False, d) -> (t, e, ns)

236+ _ -> (Nothing, 0, [])

237237 let fc = fileFC fn

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

@@ -315,18 +332,19 @@ makeLemma fn updatefile l n

315332 ns -> ierror (CantResolveAlts (map fst ns))

316333 i <- getIState

317334 margs <- case lookup fname (idris_metavars i) of

318− Just (_, arity, _, _) -> return arity

335+ Just (_, arity, _, _, _) -> return arity

319336 _ -> return (-1)

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+76−57

@@ -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 opts cn fc' ps ity ni ds)

341+ = PInstance docs pdocs s fc cs acc opts (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,11 +906,21 @@ InstanceName ::= '[' Name ']';

903906@

904907-}

905908instance_ :: Bool -> SyntaxInfo -> IdrisParser [PDecl]

906−instance_ kwopt syn

907− = do (doc, argDocs)

908− <- try (docstring syn <* if kwopt then optional instanceKeyword

909− else do instanceKeyword

910− return (Just ()))

909+instance_ kwopt syn

910+ = do ist <- get

911+ let initOpts = if default_total ist

912+ then [TotalFn]

913+ else []

914+

915+ (doc, argDocs) <- docstring syn

916+ opts <- fnOpts initOpts

917+ acc <- accessibility

918+ opts' <- fnOpts opts

919+

920+ if kwopt then optional instanceKeyword

921+ else do instanceKeyword

922+ return (Just ())

923+

911924 fc <- getFC

912925 en <- optional instanceName

913926 cs <- constraintList syn

@@ -917,7 +930,7 @@ instance_ kwopt syn

917930 let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)

918931 let t = bindList (PPi constraint) cs sc

919932 ds <- instanceBlock syn

920− return [PInstance doc argDocs syn fc cs' cn cnfc args t en ds]

933+ return [PInstance doc argDocs syn fc cs' acc opts' cn cnfc args t en ds]

921934 <?> "implementation declaration"

922935 where instanceName :: IdrisParser Name

923936 instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'

@@ -928,11 +941,7 @@ instance_ kwopt syn

928941 instanceKeyword = reservedHL "implementation"

929942 <|> do reservedHL "instance"

930943 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−

944+ parserWarning fc Nothing (Msg "The 'instance' keyword is deprecated. Use 'implementation' (or omit it) instead.")

936945

937946-- | Parse a docstring

938947docstring :: SyntaxInfo

@@ -1321,7 +1330,10 @@ directive syn = do try (lchar '%' *> reserved "lib")

13211330 return [PDirective (DHide n)]

13221331 <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName []

13231332 return [PDirective (DFreeze n)]

1324− <|> do try (lchar '%' *> reserved "access"); acc <- accessibility

1333+ <|> do try (lchar '%' *> reserved "access")

1334+ acc <- accessibility

1335+ ist <- get

1336+ put ist { default_access = acc }

13251337 return [PDirective (DAccess acc)]

13261338 <|> do try (lchar '%' *> reserved "default"); tot <- totality

13271339 i <- get

@@ -1353,7 +1365,12 @@ directive syn = do try (lchar '%' *> reserved "lib")

13531365 fn <- fst <$> fnName

13541366 arg <- fst <$> iName []

13551367 return [PDirective (DUsed fc fn arg)]

1368+ <|> do try (lchar '%' *> reserved "auto_implicits")

1369+ b <- on_off

1370+ return [PDirective (DAutoImplicits b)]

13561371 <?> "directive"

1372+ where on_off = do reserved "on"; return True

1373+ <|> do reserved "off"; return False

13571374

13581375pLangExt :: IdrisParser LanguageExt

13591376pLangExt = (reserved "TypeProviders" >> return TypeProviders)

@@ -1491,14 +1508,23 @@ parseImports fname input

14911508 [(FC, OutputAnnotation)], IState)

14921509 imports = do whiteSpace

14931510 (mdoc, mname, annots) <- moduleHeader

1494− ps <- many import_

1511+ ps_exp <- many import_

14951512 mrk <- mark

14961513 isEof <- lookAheadMatches eof

14971514 let mrk' = if isEof

14981515 then Nothing

14991516 else Just mrk

15001517 i <- get

1518+ -- add Builtins and Prelude, unless options say

1519+ -- not to

1520+ let ps = ps_exp -- imp "Builtins" : imp "Prelude" : ps_exp

15011521 return ((mdoc, mname, ps, mrk'), annots, i)

1522+

1523+ imp m = ImportInfo False (toPath m)

1524+ Nothing [] NoFC NoFC

1525+ ns = Spl.splitOn "."

1526+ toPath = foldl1' (</>) . ns

1527+

15021528 addPath :: [(FC, OutputAnnotation)] -> FilePath -> [(FC, OutputAnnotation)]

15031529 addPath [] _ = []

15041530 addPath ((fc, AnnNamespace ns Nothing) : annots) path =

@@ -1556,17 +1582,17 @@ parseProg syn fname input mrk

15561582 return (ds, i')

15571583

15581584{- | Load idris module and show error if something wrong happens -}

1559−loadModule :: FilePath -> Idris (Maybe String)

1560−loadModule f

1561− = idrisCatch (loadModule' f)

1585+loadModule :: FilePath -> IBCPhase -> Idris (Maybe String)

1586+loadModule f phase

1587+ = idrisCatch (loadModule' f phase)

15621588 (\e -> do setErrSpan (getErrSpan e)

15631589 ist <- getIState

15641590 iWarn (getErrSpan e) $ pprintErr ist e

15651591 return Nothing)

15661592

15671593{- | Load idris module -}

1568−loadModule' :: FilePath -> Idris (Maybe String)

1569−loadModule' f

1594+loadModule' :: FilePath -> IBCPhase -> Idris (Maybe String)

1595+loadModule' f phase

15701596 = do i <- getIState

15711597 let file = takeWhile (/= ' ') f

15721598 ibcsd <- valIBCSubDir i

@@ -1580,7 +1606,7 @@ loadModule' f

15801606 IDR fn -> loadSource False fn Nothing

15811607 LIDR fn -> loadSource True fn Nothing

15821608 IBC fn src ->

1583− idrisCatch (loadIBC True fn)

1609+ idrisCatch (loadIBC True phase fn)

15841610 (\c -> do logParser 1 $ fn ++ " failed " ++ pshow i c

15851611 case src of

15861612 IDR sfn -> loadSource False sfn Nothing

@@ -1588,18 +1614,18 @@ loadModule' f

15881614 return $ Just file

15891615

15901616{- | Load idris code from file -}

1591−loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()

1592−loadFromIFile reexp i@(IBC fn src) maxline

1617+loadFromIFile :: Bool -> IBCPhase -> IFileType -> Maybe Int -> Idris ()

1618+loadFromIFile reexp phase i@(IBC fn src) maxline

15931619 = do logParser 1 $ "Skipping " ++ getSrcFile i

1594− idrisCatch (loadIBC reexp fn)

1620+ idrisCatch (loadIBC reexp phase fn)

15951621 (\err -> ierror $ LoadingFailed fn err)

15961622 where

15971623 getSrcFile (IDR fn) = fn

15981624 getSrcFile (LIDR fn) = fn

15991625 getSrcFile (IBC f src) = getSrcFile src

16001626

1601−loadFromIFile _ (IDR fn) maxline = loadSource' False fn maxline

1602−loadFromIFile _ (LIDR fn) maxline = loadSource' True fn maxline

1627+loadFromIFile _ _ (IDR fn) maxline = loadSource' False fn maxline

1628+loadFromIFile _ _ (LIDR fn) maxline = loadSource' True fn maxline

16031629

16041630{-| Load idris source code and show error if something wrong happens -}

16051631loadSource' :: Bool -> FilePath -> Maybe Int -> Idris ()

@@ -1630,7 +1656,7 @@ loadSource lidr f toline

16301656 LIDR fn -> ifail $ "No ibc for " ++ f

16311657 IDR fn -> ifail $ "No ibc for " ++ f

16321658 IBC fn src ->

1633− do loadIBC True fn

1659+ do loadIBC True IBC_Building fn

16341660 let srcFn = case src of

16351661 IDR fn -> Just fn

16361662 LIDR fn -> Just fn

@@ -1662,7 +1688,7 @@ loadSource lidr f toline

16621688 (n,fc):_ -> throwError . At fc . Msg $ "import alias not unique: " ++ show n

16631689

16641690 i <- getIState

1665− putIState (i { default_access = Hidden, module_aliases = modAliases })

1691+ putIState (i { default_access = Private, module_aliases = modAliases })

16661692 clearIBC -- start a new .ibc file

16671693 -- record package info in .ibc

16681694 imps <- allImportDirs

@@ -1760,7 +1786,7 @@ loadSource lidr f toline

17601786 clearHighlights

17611787 i <- getIState

17621788 putIState (i { default_total = def_total,

1763− hide_list = [] })

1789+ hide_list = emptyContext })

17641790 return ()

17651791 where

17661792 namespaces :: [String] -> [PDecl] -> [PDecl]

@@ -1790,16 +1816,9 @@ loadSource lidr f toline

17901816 parsedDocs ist = annotCode (tryFullExpr syn ist) docs

17911817

17921818{- | Adds names to hide list -}

1793−addHides :: [(Name, Maybe Accessibility)] -> Idris ()

1819+addHides :: Ctxt Accessibility -> Idris ()

17941820addHides xs = do i <- getIState

17951821 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

1822+ mapM_ doHide (toAlist xs)

1823+ where doHide (n, a) = do setAccessibility n a

18051824 addIBC (IBCAccess n a)

src/Idris/ParseData.hs → src/Idris/Parser/Data.hsrenamed+13−13

@@ -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,8 +71,11 @@ 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

74− toFreeze (Just Frozen) = Just Hidden

78+ toFreeze (Just Frozen) = Just Private

7579 toFreeze x = x

7680

7781 recordBody :: SyntaxInfo -> Name -> IdrisParser ([((Maybe (Name, FC)), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))], Maybe (Name, FC), Docstring (Either Err PTerm))

@@ -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+20−21

@@ -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,9 +584,9 @@ 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 ::=

593− '%' 'disamb' NameList Expr

589+ 'with' NameList Expr

594590 ;

595591-}

596592disamb :: SyntaxInfo -> IdrisParser PTerm

@@ -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+68−39

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

@@ -237,20 +245,20 @@ float = do f <- Tok.double

237245

238246-- | Idris Style for parsing identifiers/reserved keywords

239247idrisStyle :: MonadicParsing m => IdentifierStyle m

240−idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier

241− where _styleName = "Idris"

242− _styleStart = satisfy isAlpha <|> oneOf "_"

243− _styleLetter = satisfy isAlphaNum <|> oneOf "_'."

244− _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "corecord", "Type",

245− "do", "dsl", "import", "impossible",

246− "case", "of", "total", "partial", "mutual",

247− "infix", "infixl", "infixr", "rewrite",

248− "where", "with", "syntax", "proof", "postulate",

249− "using", "namespace", "class", "instance",

250− "interface", "implementation", "parameters",

251− "public", "private", "abstract", "implicit",

252− "quoteGoal", "constructor",

253− "if", "then", "else"]

248+idrisStyle = IdentifierStyle {

249+ _styleName = "Idris"

250+ , _styleStart = satisfy isAlpha <|> oneOf "_"

251+ , _styleLetter = satisfy isAlphaNum <|> oneOf "_'."

252+ , _styleReserved = HS.fromList

253+ ["let", "in", "data", "codata", "record", "corecord", "Type", "do", "dsl",

254+ "import", "impossible", "case", "of", "total", "partial", "mutual",

255+ "infix", "infixl", "infixr", "rewrite", "where", "with", "syntax",

256+ "proof", "postulate", "using", "namespace", "class", "instance",

257+ "interface", "implementation", "parameters", "public", "private",

258+ "export", "abstract", "implicit", "quoteGoal", "constructor", "if",

259+ "then", "else"]

260+ , _styleHighlight = Hi.Identifier

261+ , _styleReservedHighlight = Hi.ReservedIdentifier }

254262

255263char :: MonadicParsing m => Char -> m Char

256264char = Chr.char

@@ -285,7 +293,7 @@ reserved = Tok.reserve idrisStyle

285293-- reserved identifiers never contain line breaks.

286294reservedFC :: MonadicParsing m => String -> m FC

287295reservedFC str = do (FC file (l, c) _) <- getFC

288− Tok.reserve idrisStyle str

296+ reserved str

289297 return $ FC file (l, c) (l, c + length str)

290298

291299-- | Parse a reserved identfier, highlighting its span as a keyword

@@ -300,10 +308,9 @@ reservedOp name = token $ try $

300308 notFollowedBy (operatorLetter) <?> ("end of " ++ show name)

301309

302310reservedOpFC :: MonadicParsing m => String -> m FC

303−reservedOpFC name = token $ try $ do (FC f (l, c) _) <- getFC

304− string name

305− notFollowedBy (operatorLetter) <?> ("end of " ++ show name)

306− return (FC f (l, c) (l, c + length name))

311+reservedOpFC name = do (FC f (l, c) _) <- getFC

312+ reservedOp name

313+ return (FC f (l, c) (l, c + length name))

307314

308315-- | Parses an identifier as a token

309316identifier :: (MonadicParsing m) => m (String, FC)

@@ -385,7 +392,7 @@ commentMarkers :: [String]

385392commentMarkers = [ "--", "|||" ]

386393

387394invalidOperators :: [String]

388−invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!"]

395+invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!", "@"]

389396

390397-- | Parses an operator

391398operator :: MonadicParsing m => m String

@@ -396,12 +403,9 @@ operator = do op <- token . some $ operatorLetter

396403

397404-- | Parses an operator

398405operatorFC :: MonadicParsing m => m (String, FC)

399−operatorFC = do (op, fc) <- token $ do (FC f (l, c) _) <- getFC

400− op <- some operatorLetter

401− return (op, FC f (l, c) (l, c + length op))

402− when (op `elem` (invalidOperators ++ commentMarkers)) $

403− fail $ op ++ " is not a valid operator"

404− return (op, fc)

406+operatorFC = do (FC f (l, c) _) <- getFC

407+ op <- operator

408+ return (op, FC f (l, c) (l, c + length op))

405409

406410{- * Position helpers -}

407411{- | Get filename from position (returns "(interactive)" when no source file is given) -}

@@ -612,22 +616,47 @@ notOpenBraces = do ist <- get

612616 hasNothing = any isNothing

613617

614618{- | 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

618− <|> do reserved "private"; return Hidden

619+accessibility' :: IdrisParser Accessibility

620+accessibility'

621+ = do reserved "public";

622+ gotexp <- optional (reserved "export")

623+ case gotexp of

624+ Just _ -> return ()

625+ Nothing -> do

626+ ist <- get

627+ fc <- getFC

628+ put ist { parserWarnings =

629+ (fc, Msg "'public' is deprecated. Use 'public export' instead.")

630+ : parserWarnings ist }

631+ return Public

632+ <|> do reserved "abstract";

633+ ist <- get

634+ fc <- getFC

635+ put ist { parserWarnings =

636+ (fc, Msg "The 'abstract' keyword is deprecated. Use 'export' instead.")

637+ : parserWarnings ist }

638+ return Frozen

639+ <|> do reserved "export"; return Frozen

640+ <|> do reserved "private"; return Private

619641 <?> "accessibility modifier"

620642

643+accessibility :: IdrisParser Accessibility

644+accessibility = do acc <- optional accessibility'

645+ case acc of

646+ Just a -> return a

647+ Nothing -> do ist <- get

648+ return (default_access ist)

649+

621650-- | Adds accessibility option for function

622−addAcc :: Name -> Maybe Accessibility -> IdrisParser ()

651+addAcc :: Name -> Accessibility -> IdrisParser ()

623652addAcc n a = do i <- get

624− put (i { hide_list = (n, a) : hide_list i })

653+ put (i { hide_list = addDef n a (hide_list i) })

625654

626655{- | Add accessbility option for data declarations

627656 (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

657+accData :: Accessibility -> Name -> [Name] -> IdrisParser ()

658+accData Frozen n ns = do addAcc n Public -- so that it can be used in public definitions

659+ mapM_ (\n -> addAcc n Private) ns -- so that they are invisible

631660accData a n ns = do addAcc n a

632661 mapM_ (`addAcc` a) ns

633662

@@ -662,7 +691,7 @@ collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds

662691collect (PNamespace ns fc ps : ds) = PNamespace ns fc (collect ps) : collect ds

663692collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')

664693 = 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'

694+collect (PInstance doc argDocs f s cs acc opts n nfc ps t en ds : ds')

695+ = PInstance doc argDocs f s cs acc opts n nfc ps t en (collect ds) : collect ds'

667696collect (d : ds) = d : collect ds

668697collect [] = []

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+40−57

@@ -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,18 +269,13 @@ 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

276276 case lookupCtxtExact n (idris_datatypes ist) of

277277 Just t -> do

278278 let others = hints ++ con_names t ++ autohints

279− when (not fromProver && length (con_names t) > 1)

280− -- in interactive mode,

281− -- don't just guess (fine for 'auto',

282− -- since that's part of the point...)

283− $ checkConstructor ist others

284279 tryCons d locs tys (others ++ getFn d fn)

285280 Nothing -> typeNotSearchable t

286281 _ -> typeNotSearchable t

@@ -292,26 +287,26 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

292287 tryLocals d locs tys env

293288

294289 tryLocals d locs tys [] = fail "Locals failed"

295− tryLocals d locs tys ((x, t) : xs)

290+ tryLocals d locs tys ((x, t) : xs)

296291 | x `elem` locs || x `notElem` psnames = tryLocals d locs tys xs

297− | otherwise = try' (tryLocal d (x : locs) tys x t)

292+ | otherwise = try' (tryLocal d (x : locs) tys x t)

298293 (tryLocals d locs tys xs) True

299294

300295 tryCons d locs tys [] = fail "Constructors failed"

301− tryCons d locs tys (c : cs)

296+ tryCons d locs tys (c : cs)

302297 = try' (tryCon d locs tys c) (tryCons d locs tys cs) True

303298

304− tryLocal d locs tys n t

299+ tryLocal d locs tys n t

305300 = do let a = getPArity (delab ist (binderTy t))

306301 tryLocalArg d locs tys n a

307302

308303 tryLocalArg d locs tys n 0 = elab (PRef (fileFC "prf") [] n)

309− tryLocalArg d locs tys n i

304+ tryLocalArg d locs tys n i

310305 = simple_app False (tryLocalArg d locs tys n (i - 1))

311306 (psRec True d locs tys) "proof search local apply"

312307

313308 -- Like type class resolution, but searching with constructors

314− tryCon d locs tys n =

309+ tryCon d locs tys n =

315310 do ty <- goal

316311 let imps = case lookupCtxtExact n (idris_implicits ist) of

317312 Nothing -> []

@@ -341,23 +336,6 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

341336 (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."]

342337 _ -> []

343338

344−-- In interactive mode, only search for things if there is some

345−-- index to help pick a relevant constructor

346−checkConstructor :: IState -> [Name] -> ElabD ()

347−checkConstructor ist [] = return ()

348−checkConstructor ist (n : ns) =

349− case lookupTyExact n (tt_ctxt ist) of

350− Just t -> if not (conIndexed t)

351− then fail "Overlapping constructor types"

352− else checkConstructor ist ns

353− where

354− conIndexed t = let (_, args) = unApply (getRetTy t) in

355− any conHead args

356− conHead t | (P _ n _, _) <- unApply t = case lookupDefExact n (tt_ctxt ist) of

357− Just _ -> True

358− _ -> False

359− | otherwise = False

360−

361339-- | Resolve type classes. This will only pick up 'normal' instances, never

362340-- named instances (which is enforced by 'findInstances').

363341resolveTC :: Bool -- ^ using default Int

@@ -383,8 +361,10 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

383361 let (argsok, okholePos) = case tcArgsOK g topholes of

384362 Nothing -> (False, [])

385363 Just hs -> (True, hs)

364+ env <- get_env

365+ probs <- get_probs

386366 if not argsok -- && not mvok)

387− then lift $ tfail $ CantResolve True topg

367+ then lift $ tfail $ CantResolve True topg (probErr probs)

388368 else do

389369 ptm <- get_term

390370 ulog <- getUnifyLog

@@ -397,7 +377,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

397377 _ -> []

398378

399379 traceWhen ulog ("Resolving class " ++ show g ++ "\nin" ++ show env ++ "\n" ++ show okholes) $

400− try' (trivialTCs okholes elab ist)

380+ try' (trivialTCs okholes elab ist)

401381 (do addDefault t tc ttypes

402382 let stk = map fst (filter snd $ elab_stack ist)

403383 let insts = findInstances ist t

@@ -431,8 +411,11 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

431411 _ -> Just rs

432412 tcDetArgsOK _ _ _ [] = Just []

433413

414+ probErr [] = Msg ""

415+ probErr ((_,_,_,_,err,_,_) : _) = err

416+

434417 isMeta :: [Name] -> Term -> Bool

435− isMeta ns (P _ n _) = n `elem` ns

418+ isMeta ns (P _ n _) = n `elem` ns

436419 isMeta _ _ = False

437420

438421 notHole hs (P _ n _, c)

@@ -449,7 +432,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

449432 chaser (NS n _) = chaser n

450433 chaser _ = False

451434

452− numclass = sNS (sUN "Num") ["Classes","Prelude"]

435+ numclass = sNS (sUN "Num") ["Interfaces","Prelude"]

453436

454437 addDefault t num@(P _ nc _) [P Bound a _] | nc == numclass && defaultOn

455438 = do focus a

@@ -462,12 +445,13 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

462445 boundVar (P Bound _ _) = True

463446 boundVar _ = False

464447

465− blunderbuss t d stk [] = lift $ tfail $ CantResolve False topg

448+ blunderbuss t d stk [] = do ps <- get_probs

449+ lift $ tfail $ CantResolve False topg (probErr ps)

466450 blunderbuss t d stk (n:ns)

467451 | n /= fn -- && (n `elem` stk)

468452 = tryCatch (resolve n d)

469453 (\e -> case e of

470− CantResolve True _ -> lift $ tfail e

454+ CantResolve True _ _ -> lift $ tfail e

471455 _ -> blunderbuss t d stk ns)

472456 | otherwise = blunderbuss t d stk ns

473457

@@ -529,6 +513,5 @@ findInstances ist t

529513 | otherwise = []

530514 where accessible n = case lookupDefAccExact n False (tt_ctxt ist) of

531515 Just (_, Hidden) -> False

516+ Just (_, Private) -> False

532517 _ -> True

533−

534−

src/Idris/Prover.hs+25−8

@@ -85,7 +85,7 @@ assumptionNames e

8585

8686prove :: Bool -> Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()

8787prove mode opt ctxt lit n ty

88− = do ps <- fmap (\ist -> initElaborator n ctxt (idris_datatypes ist) ty) getIState

88+ = do ps <- fmap (\ist -> initElaborator n ctxt (idris_datatypes ist) (idris_name ist) ty) getIState

8989 idemodePutSExp "start-proof-mode" n

9090 (tm, prf) <-

9191 if mode

@@ -124,7 +124,7 @@ prove mode opt ctxt lit n ty

124124 [([], P Ref n ty, ptm')] ty

125125 ctxt

126126 setContext ctxt'

127− solveDeferred n

127+ solveDeferred emptyFC n

128128 case idris_outputmode i of

129129 IdeMode n h ->

130130 runIO . hPutStrLn h $ IdeMode.convSExp "return" (IdeMode.SymbolAtom "ok", "") n

@@ -271,6 +271,21 @@ undoElab prf env st [] = ifail "Nothing to undo"

271271undoElab prf env st (h:hs) = do (prf', env', st') <- undoStep prf env st h

272272 return (prf', env', st', hs)

273273

274+runWithInterrupt

275+ :: ElabState EState

276+ -> Idris a -- ^ run with SIGINT handler

277+ -> Idris b -- ^ run if mTry finished

278+ -> Idris b -- ^ run if mTry was interrupted

279+ -> Idris b

280+runWithInterrupt elabState mTry mSuccess mFailure = do

281+ ist <- getIState

282+ case idris_outputmode ist of

283+ RawOutput _ -> do

284+ success <- runInputT (proverSettings elabState) $

285+ handleInterrupt (return False) $

286+ withInterrupt (lift mTry >> return True)

287+ if success then mSuccess else mFailure

288+ IdeMode _ _ -> mTry >> mSuccess

274289

275290elabloop :: Name -> Bool -> String -> [String] -> ElabState EState -> [ElabShellHistory] -> Maybe History -> [(Name, Type, Term)] -> Idris (Term, [String])

276291elabloop fn d prompt prf e prev h env

@@ -283,7 +298,7 @@ elabloop fn d prompt prf e prev h env

283298 do case h of

284299 Just history -> putHistory history

285300 Nothing -> return ()

286− l <- getInputLine (prompt ++ "> ")

301+ l <- handleInterrupt (return $ Just "") $ withInterrupt $ getInputLine (prompt ++ "> ")

287302 h' <- getHistory

288303 return (l, Just h')

289304 IdeMode _ handle ->

@@ -375,8 +390,9 @@ elabloop fn d prompt prf e prev h env

375390 Right ok ->

376391 if done then do (tm, _) <- elabStep st get_term

377392 return (tm, prf')

378− else do ok

379− elabloop fn d prompt prf' st prev' h' env'

393+ else runWithInterrupt e ok

394+ (elabloop fn d prompt prf' st prev' h' env')

395+ (elabloop fn d prompt prf e prev h' env)

380396

381397 where

382398 -- A bit of a hack: wrap the value up in a let binding, which will

@@ -401,7 +417,7 @@ ploop fn d prompt prf e h

401417 do case h of

402418 Just history -> putHistory history

403419 Nothing -> return ()

404− l <- getInputLine (prompt ++ "> ")

420+ l <- handleInterrupt (return $ Just "") $ withInterrupt $ getInputLine (prompt ++ "> ")

405421 h' <- getHistory

406422 return (l, Just h')

407423 IdeMode _ handle ->

@@ -445,8 +461,9 @@ ploop fn d prompt prf e h

445461 Right ok ->

446462 if done then do (tm, _) <- elabStep st get_term

447463 return (tm, prf')

448− else do ok

449− ploop fn d prompt prf' st h'

464+ else runWithInterrupt e ok

465+ (ploop fn d prompt prf' st h')

466+ (ploop fn d prompt prf e h')

450467

451468

452469envCtxt env ctxt = foldl (\c (n, b) -> addTyDecl n Bound (binderTy b) c) ctxt env

src/Idris/REPL.hs+43−37

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

@@ -121,13 +122,13 @@ repl orig mods efile

121122 (if colour && not isWindows

122123 then colourisePrompt theme str

123124 else str) ++ " "

124− x <- H.catch (getInputLine prompt)

125− (ctrlC (return Nothing))

125+ x <- H.catch (H.withInterrupt $ getInputLine prompt)

126+ (ctrlC (return $ Just ""))

126127 case x of

127128 Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

128129 return ()

129130 Just input -> -- H.catch

130− do ms <- H.catch (lift $ processInput input orig mods efile)

131+ do ms <- H.catch (H.withInterrupt $ lift $ processInput input orig mods efile)

131132 (ctrlC (return (Just mods)))

132133 case ms of

133134 Just mods -> let efile' = fromMaybe efile (listToMaybe mods)

@@ -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 opts cls nfc parms ty instName decls) =

906+ PInstance doc argDocs syn fc constraints acc opts cls nfc parms ty instName (map fixClauses decls)

906907 fixClauses decl = decl

907908

908909process fn (Undefine names) = undefine names

@@ -958,8 +959,8 @@ process fn (Check (PRef _ _ n))

958959 case lookupNames n ctxt of

959960 ts@(t:_) ->

960961 case lookup t (idris_metavars ist) of

961− Just (_, i, _, _) -> iRenderResult . fmap (fancifyAnnots ist True) $

962− showMetavarInfo ppo ist n i

962+ Just (_, i, _, _, _) -> iRenderResult . fmap (fancifyAnnots ist True) $

963+ showMetavarInfo ppo ist n i

963964 Nothing -> iPrintFunTypes [] n (map (\n -> (n, pprintDelabTy ist n)) ts)

964965 [] -> iPrintError $ "No such variable " ++ show n

965966 where

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

@@ -1138,7 +1139,7 @@ process fn (RmProof n')

11381139 insertMetavar n =

11391140 do i <- getIState

11401141 let ms = idris_metavars i

1141− putIState $ i { idris_metavars = (n, (Nothing, 0, [], False)) : ms }

1142+ putIState $ i { idris_metavars = (n, (Nothing, 0, [], False, False)) : ms }

11421143

11431144process fn' (AddProof prf)

11441145 = do fn <- do

@@ -1191,8 +1192,9 @@ process fn (Prove mode n')

11911192 let metavars = mapMaybe (\n -> do c <- lookup n (idris_metavars ist); return (n, c)) ns

11921193 n <- case metavars of

11931194 [] -> ierror (Msg $ "Cannot find metavariable " ++ show n')

1194− [(n, (_,_,_,False))] -> return n

1195− [(_, (_,_,_,True))] -> ierror (Msg $ "Declarations not solvable using prover")

1195+ [(n, (_,_,_,False,_))] -> return n

1196+ [(_, (_,_,_,_,False))] -> ierror (Msg $ "Can't prove this hole as it depends on other holes")

1197+ [(_, (_,_,_,True,_))] -> ierror (Msg $ "Declarations not solvable using prover")

11961198 ns -> ierror (CantResolveAlts (map fst ns))

11971199 prover mode (lit fn) n

11981200 -- recheck totality

@@ -1238,12 +1240,15 @@ process fn (Compile codegen f)

12381240 iPrintError $ "Invalid filename for compiler output \"" ++ f ++"\""

12391241 | otherwise = do opts <- getCmdLine

12401242 let iface = Interface `elem` opts

1243+ let mainname = sNS (sUN "main") ["Main"]

1244+

12411245 m <- if iface then return Nothing else

12421246 do (m', _) <- elabVal recinfo ERHS

12431247 (PApp fc (PRef fc [] (sUN "run__IO"))

1244− [pexp $ PRef fc [] (sNS (sUN "main") ["Main"])])

1248+ [pexp $ PRef fc [] mainname])

12451249 return (Just m')

12461250 ir <- compile codegen f m

1251+

12471252 i <- getIState

12481253 runIO $ generate codegen (fst (head (idris_imported i))) ir

12491254 where fc = fileFC "main"

@@ -1559,7 +1564,7 @@ loadInputs inputs toline -- furthest line to read in input source files

15591564 logParser 1 ("MODULE TREE : " ++ show modTree)

15601565 logParser 1 ("RELOAD: " ++ show ifiles)

15611566 when (not (all ibc ifiles) || loadCode) $

1562− tryLoad False (filter (not . ibc) ifiles)

1567+ tryLoad False IBC_Building (filter (not . ibc) ifiles)

15631568 -- return the files that need rechecking

15641569 return (input, ifiles))

15651570 ninputs

@@ -1570,7 +1575,8 @@ loadInputs inputs toline -- furthest line to read in input source files

15701575 Nothing ->

15711576 do putIState $!! ist { idris_tyinfodata = tidata }

15721577 ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))

1573− tryLoad True (mapMaybe id ibcfiles)

1578+-- logLvl 0 $ "Loading from " ++ show ibcfiles

1579+ tryLoad True (IBC_REPL True) (mapMaybe id ibcfiles)

15741580 _ -> return ()

15751581 exports <- findExports

15761582

@@ -1590,9 +1596,9 @@ loadInputs inputs toline -- furthest line to read in input source files

15901596 iWarn emptyFC $ pprintErr i e

15911597 return [])

15921598 where -- load all files, stop if any fail

1593− tryLoad :: Bool -> [IFileType] -> Idris ()

1594− tryLoad keepstate [] = warnTotality >> return ()

1595− tryLoad keepstate (f : fs)

1599+ tryLoad :: Bool -> IBCPhase -> [IFileType] -> Idris ()

1600+ tryLoad keepstate phase [] = warnTotality >> return ()

1601+ tryLoad keepstate phase (f : fs)

15961602 = do ist <- getIState

15971603 let maxline

15981604 = case toline of

@@ -1605,7 +1611,7 @@ loadInputs inputs toline -- furthest line to read in input source files

16051611 then Just l

16061612 else Nothing

16071613 _ -> Nothing

1608− loadFromIFile True f maxline

1614+ loadFromIFile True phase f maxline

16091615 inew <- getIState

16101616 -- FIXME: Save these in IBC to avoid this hack! Need to

16111617 -- preserve it all from source inputs

@@ -1615,15 +1621,16 @@ loadInputs inputs toline -- furthest line to read in input source files

16151621 let tidata = idris_tyinfodata inew

16161622 let patdefs = idris_patdefs inew

16171623 ok <- noErrors

1618− when ok $

1619− -- The $!! here prevents a space leak on reloading.

1620− -- This isn't a solution - but it's a temporary stopgap.

1621− -- See issue #2386

1622− do when (not keepstate) $ putIState $!! ist

1623− ist <- getIState

1624− putIState $!! ist { idris_tyinfodata = tidata,

1625− idris_patdefs = patdefs }

1626− tryLoad keepstate fs

1624+ if ok then

1625+ -- The $!! here prevents a space leak on reloading.

1626+ -- This isn't a solution - but it's a temporary stopgap.

1627+ -- See issue #2386

1628+ do when (not keepstate) $ putIState $!! ist

1629+ ist <- getIState

1630+ putIState $!! ist { idris_tyinfodata = tidata,

1631+ idris_patdefs = patdefs }

1632+ tryLoad keepstate phase fs

1633+ else warnTotality

16271634

16281635 ibc (IBC _ _) = True

16291636 ibc _ = False

@@ -1727,13 +1734,12 @@ idrisMain opts =

17271734 addPkgDir "base"

17281735 mapM_ addPkgDir pkgdirs

17291736 elabPrims

1730− when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins"

1737+ when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins" (IBC_REPL True)

17311738 addAutoImport "Builtins"

17321739 return ()

1733− when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"

1740+ when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude" (IBC_REPL True)

17341741 addAutoImport "Prelude"

17351742 return ()

1736−

17371743 when (runrepl && not idesl) initScript

17381744

17391745 nobanner <- getNoBanner

@@ -1794,7 +1800,7 @@ idrisMain opts =

17941800 when (runrepl && not idesl) $ do

17951801-- clearOrigPats

17961802 startServer port orig mods

1797− runInputT (replSettings (Just historyFile)) $ repl orig mods efile

1803+ runInputT (replSettings (Just historyFile)) $ repl (force orig) mods efile

17981804 let idesock = IdemodeSocket `elem` opts

17991805 when (idesl) $ idemodeStart idesock orig inputs

18001806 ok <- noErrors

src/Idris/REPL/Browse.hs+2−1

@@ -8,7 +8,7 @@ import Data.List (isSuffixOf, nub)

88import Data.Maybe (mapMaybe)

99import qualified Data.Text as T (unpack)

1010

11−import Idris.Core.Evaluate (ctxtAlist, Accessibility(Hidden), lookupDefAccExact)

11+import Idris.Core.Evaluate (ctxtAlist, Accessibility(Private, Hidden), lookupDefAccExact)

1212import Idris.Core.TT (Name(..))

1313

1414import Idris.AbsSyntaxTree (Idris)

@@ -41,4 +41,5 @@ namesInNS ns = do let revNS = reverse ns

4141 accessible n = do ctxt <- getContext

4242 case lookupDefAccExact n False ctxt of

4343 Just (_, Hidden ) -> return False

44+ Just (_, Private ) -> return False

4445 _ -> return True

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+25−8

@@ -48,6 +48,10 @@ data RCtorArg = RCtorParameter RFunArg | RCtorField RFunArg deriving Show

4848

4949data RDatatype = RDatatype Name [RTyConArg] Raw [(Name, [RCtorArg], Raw)] deriving Show

5050

51+data RConstructorDefn = RConstructor Name [RFunArg] Raw

52+

53+data RDataDefn = RDefineDatatype Name [RConstructorDefn]

54+

5155rArgOpts :: RErasure -> [ArgOpt]

5256rArgOpts RErased = [InaccessibleArg]

5357rArgOpts _ = []

@@ -364,10 +368,10 @@ reifyArithTy (P _ n _) | n == reflm "ATDouble" = return ATFloat

364368reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)

365369

366370reifyNativeTy :: 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

371+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

372+reifyNativeTy (P _ n _) | n == reflm "IT16" = return IT16

373+reifyNativeTy (P _ n _) | n == reflm "IT32" = return IT32

374+reifyNativeTy (P _ n _) | n == reflm "IT64" = return IT64

371375reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x

372376

373377reifyIntTy :: Term -> ElabD IntTy

@@ -896,7 +900,8 @@ reflectErr (NotInjective t1 t2 t3) =

896900 , reflect t2

897901 , reflect t3

898902 ]

899−reflectErr (CantResolve _ t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

903+reflectErr (CantResolve _ t more)

904+ = raw_apply (Var $ reflErrName "CantResolve") [reflect t, reflectErr more]

900905reflectErr (InvalidTCArg n t) = raw_apply (Var $ reflErrName "InvalidTCArg") [reflectName n, reflect t]

901906reflectErr (CantResolveAlts ss) =

902907 raw_apply (Var $ reflErrName "CantResolveAlts")

@@ -962,7 +967,7 @@ reifyReportPart (App _ (P (DCon _ _ _) n _) (Constant (Str msg))) | n == reflm "

962967 Right (TextPart msg)

963968reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)

964969 | n == reflm "NamePart" =

965− case runElab initEState (reifyTTName ttn) (initElaborator (sMN 0 "hole") initContext emptyContext Erased) of

970+ case runElab initEState (reifyTTName ttn) (initElaborator (sMN 0 "hole") initContext emptyContext 0 Erased) of

966971 Error e -> Left . InternalMsg $

967972 "could not reify name term " ++

968973 show ttn ++

@@ -970,7 +975,7 @@ reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)

970975 OK (n', _)-> Right $ NamePart n'

971976reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

972977 | n == reflm "TermPart" =

973− case runElab initEState (reifyTT tm) (initElaborator (sMN 0 "hole") initContext emptyContext Erased) of

978+ case runElab initEState (reifyTT tm) (initElaborator (sMN 0 "hole") initContext emptyContext 0 Erased) of

974979 Error e -> Left . InternalMsg $

975980 "could not reify reflected term " ++

976981 show tm ++

@@ -978,7 +983,7 @@ reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

978983 OK (tm', _) -> Right $ TermPart tm'

979984reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

980985 | n == reflm "RawPart" =

981− case runElab initEState (reifyRaw tm) (initElaborator (sMN 0 "hole") initContext emptyContext Erased) of

986+ case runElab initEState (reifyRaw tm) (initElaborator (sMN 0 "hole") initContext emptyContext 0 Erased) of

982987 Error e -> Left . InternalMsg $

983988 "could not reify reflected raw term " ++

984989 show tm ++

@@ -1043,6 +1048,18 @@ reifyFunDefn (App _ (App _ (App _ (P _ n _) (P _ t _)) fnN) clauses)

10431048 reifyC tm = fail $ "Couldn't reify " ++ show tm ++ " as a clause."

10441049reifyFunDefn tm = fail $ "Couldn't reify " ++ show tm ++ " as a function declaration."

10451050

1051+reifyRConstructorDefn :: Term -> ElabD RConstructorDefn

1052+reifyRConstructorDefn (App _ (App _ (App _ (P _ n _) cn) args) retTy)

1053+ | n == tacN "Constructor", Just args' <- unList args

1054+ = RConstructor <$> reifyTTName cn <*> mapM reifyRFunArg args' <*> reifyRaw retTy

1055+reifyRConstructorDefn aTm = fail $ "Couldn't reify " ++ show aTm ++ " as an RConstructorDefn"

1056+

1057+reifyRDataDefn :: Term -> ElabD RDataDefn

1058+reifyRDataDefn (App _ (App _ (P _ n _) tyn) ctors)

1059+ | n == tacN "DefineDatatype", Just ctors' <- unList ctors

1060+ = RDefineDatatype <$> reifyTTName tyn <*> mapM reifyRConstructorDefn ctors'

1061+reifyRDataDefn aTm = fail $ "Couldn't reify " ++ show aTm ++ " as an RDataDefn"

1062+

10461063envTupleType :: Raw

10471064envTupleType

10481065 = raw_apply (Var pairTy) [ (Var $ reflm "TTName")

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/ScreenSize.hs+2−17

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

1−{-# LANGUAGE CPP #-}

21module Util.ScreenSize(getScreenWidth) where

32

4−import Debug.Trace

5−

6−#ifndef CURSES

7−

8−getScreenWidth :: IO Int

9−getScreenWidth = return 80

10−

11−#else

12−

13−import UI.HSCurses.Curses

3+import System.Console.Terminal.Size (size, width)

144

155getScreenWidth :: IO Int

16−getScreenWidth = do initScr

17− refresh

18− size <- scrSize

19− endWin

20− return (snd size)

21−#endif

6+getScreenWidth = maybe 80 width `fmap` size

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+27

@@ -0,0 +1,27 @@

1+with (import <nixpkgs> {});

2+

3+let

4+ # MUST match resolver in stack.yaml

5+ resolver = haskell.packages.lts-5_9.ghc;

6+

7+ native_libs = [

8+ libffi

9+ zlib

10+ gmp

11+ pkgconfig

12+ ] ++ lib.optionals stdenv.isDarwin (with darwin.apple_sdk.frameworks; [

13+ Cocoa

14+ CoreServices

15+ ]);

16+

17+in stdenv.mkDerivation {

18+

19+ name = "idrisBuildEnv";

20+

21+ buildInputs = [ resolver ] ++ native_libs;

22+

23+ STACK_IN_NIX_EXTRA_ARGS = builtins.foldl'

24+ (acc: lib:

25+ " --extra-lib-dirs=${lib}/lib --extra-include-dirs=${lib}/include" + acc)

26+ "" native_libs;

27+}

stack.yaml+14−11

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

1−resolver: lts-3.16

1+resolver: lts-5.9

2+

23packages:

3−- '.'

4+ - '.'

5+

46flags:

5− idris:

6− FFI: true

7− GMP: True

8− curses: True

9−extra-deps:

10−- annotated-wl-pprint-0.7.0

11−- cheapskate-0.1.0.4

12−- hscurses-1.4.2.0

13−- libffi-0.1

7+ idris:

8+ FFI: true

9+ GMP: true

10+

11+extra-deps:

12+ - libffi-0.1

13+

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 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 ffi008 primitives005 primitives006 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 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} $@ test020.idr -o test020

4+${IDRIS:-idris} $@ 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} $@ Main.idr --nocolour --check && echo MAIN-PASS

4+${IDRIS:-idris} $@ Faulty.idr --nocolour --check && echo FAULTY-PASS

5+${IDRIS:-idris} $@ 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 --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 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} --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} --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 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 --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} $@ 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} $@ 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} $@ --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} $@ --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} --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+9

@@ -0,0 +1,9 @@

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

9+7

test/ffi007/ffi007.cnew file+34

@@ -0,0 +1,34 @@

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+}

31+

32+void test_mulpar(void (*fn)(int, int)) {

33+ fn(3,4);

34+}

test/ffi007/ffi007.hnew file+13

@@ -0,0 +1,13 @@

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

12+

13+void test_mulpar(void (*fn)(int, int));

test/ffi007/ffi007.idrnew file+58

@@ -0,0 +1,58 @@

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+adder : Int -> Int -> ()

38+adder x y = unsafePerformIO $ do

39+ printLn $ x + y

40+

41+test8 : IO ()

42+test8 = foreign FFI_C "test_mulpar" (CFnPtr (Int -> Int -> ()) -> IO ())

43+ (MkCFnPtr adder)

44+

45+main : IO ()

46+main = do

47+ test

48+ test2

49+ test3

50+ ptr <- test4

51+ tv <- test5

52+ val <- prim_peek32 tv 0

53+ printLn val

54+ fptr <- test6

55+ i <- test7 fptr 3

56+ printLn i

57+ test8

58+ 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/ffi008/expectednew file+5

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

1+True

2+True

3+a: 122 b: 0

4+4

5+00000010

test/ffi008/ffi008.cnew file+14

@@ -0,0 +1,14 @@

1+#include "ffi008.h"

2+#include <stdio.h>

3+

4+int size1(void) {

5+ return sizeof(struct test1);

6+}

7+

8+int size2(void) {

9+ return sizeof(struct test2);

10+}

11+

12+void print_mystruct(void) {

13+ printf("a: %d b: %d\n", mystruct.a, mystruct.b);

14+}

test/ffi008/ffi008.hnew file+17

@@ -0,0 +1,17 @@

1+#include <stdint.h>

2+

3+struct test1 {

4+ int8_t a;

5+ int64_t b;

6+};

7+

8+struct test2 {

9+ int32_t a;

10+ int16_t b;

11+};

12+

13+struct test2 mystruct;

14+

15+int size1(void);

16+int size2(void);

17+void print_mystruct();

test/ffi008/ffi008.idrnew file+48

@@ -0,0 +1,48 @@

1+module Main

2+

3+import CFFI

4+import Data.Vect

5+

6+%include C "ffi008.h"

7+

8+size1 : IO Int

9+size1 = foreign FFI_C "size1" (IO Int)

10+

11+

12+size2 : IO Int

13+size2 = foreign FFI_C "size2" (IO Int)

14+

15+mystruct : IO Ptr

16+mystruct = foreign FFI_C "&mystruct" (IO Ptr)

17+

18+print_mystruct : IO ()

19+print_mystruct = foreign FFI_C "print_mystruct" (IO ())

20+

21+test1 : Composite

22+test1 = STRUCT [I8, I64]

23+

24+test2 : Composite

25+test2 = STRUCT [I32, I16]

26+

27+test3 : Composite

28+test3 = STRUCT [DOUBLE, DOUBLE, I8, I64]

29+

30+test4 : Composite

31+test4 = PACKEDSTRUCT [I8, I8, I8, I64]

32+

33+

34+main : IO ()

35+main = do

36+ printLn $ sizeOf test1 == !size1

37+ printLn $ sizeOf test2 == !size2

38+ fms <- return $ (test2#0) !mystruct

39+ poke I32 fms 122

40+ print_mystruct

41+ printLn $ fields test3

42+ withAlloc test2 $ \p => do

43+ f1 <- return $ (test2 # 0) p

44+ poke I32 f1 8

45+ update I32 f1 (* 2)

46+ print !(peek I32 f1)

47+ withAlloc PTR $ \p =>

48+ poke PTR p fms

test/ffi008/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ ffi008.idr -o ffi008 -p contrib --cg-opt "ffi008.c"

3+./ffi008

4+rm -f ffi008 *.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/expected+1

@@ -6,6 +6,7 @@ isElem x (y :: xs) = ?isElem_rhs_3

66f x :: map f xs

77isElem2 x (y :: ys) with (_)

88 isElem2 x (y :: ys) | with_pat = ?isElem2_rhs

9+

910 isElem3 x (x :: ys) | (Yes Refl) = ?isElem3_rhs_3

1011

1112 [] => ?bar_1

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/expected+1−1

@@ -2,4 +2,4 @@ ys

22x :: app xs ys

33[]

44f x y :: vzipWith f xs ys

5−?word_length_rhs_3 :: word_length xs

5+0 :: word_length xs

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 < 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} $@ test003a.lidr --check

3+${IDRIS:-idris} $@ 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+93−14

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

@@ -31,11 +40,39 @@ data Term

3140 | Constant Const

3241 | Ty

3342

34−unApply : Raw -> (Raw, List Raw)

35−unApply tm = unApply' tm []

36− where unApply' : Raw -> List Raw -> (Raw, List Raw)

37− unApply' (RApp f x) xs = unApply' f (x::xs)

38− unApply' notApp xs = (notApp, xs)

43+implementation Quotable Plicity Raw where

44+ quotedTy = `(Plicity)

45+ quote Explicit = `(Explicit)

46+ quote Implicit = `(Implicit)

47+ quote Constraint = `(Constraint)

48+

49+implementation (Quotable a Raw) => Quotable (Arg a) Raw where

50+ quotedTy = `(Arg ~(quotedTy {a=a}))

51+ quote (MkArg plicity argValue) =

52+ `(MkArg {a=~(quotedTy {a=a})} ~(quote plicity) ~(quote argValue))

53+

54+

55+implementation Quotable Term Raw where

56+ quotedTy = `(Term)

57+ quote (Var k xs) = `(AgdaStyleReflection.Var ~(quote k) ~(assert_total $ quote xs))

58+ quote (Ctor n xs) = `(AgdaStyleReflection.Ctor ~(quote n) ~(assert_total $ quote xs))

59+ quote (TyCtor n xs) = `(AgdaStyleReflection.TyCtor ~(quote n) ~(assert_total $ quote xs))

60+ quote (Def n xs) = `(Def ~(quote n) ~(assert_total $ quote xs))

61+ quote (Lam x) = `(AgdaStyleReflection.Lam ~(quote x))

62+ quote (Pi x y) = `(AgdaStyleReflection.Pi ~(quote x) ~(quote y))

63+ quote (Constant c) = `(Constant ~(quote c))

64+ quote Ty = `(Ty)

65+

66+

67+partial implementation Show Term where

68+ showPrec d (Var k xs) = showCon d "Var" $ showArg k ++ showArg xs

69+ showPrec d (Ctor n xs) = showCon d "Ctor" $ showArg n ++ showArg xs

70+ showPrec d (TyCtor n xs) = showCon d "TyCtor" $ showArg n ++ showArg xs

71+ showPrec d (Def n xs) = showCon d "Def" $ showArg n ++ showArg xs

72+ showPrec d (Lam x) = showCon d "Lam" $ showArg x

73+ showPrec d (Pi x y) = showCon d "Pi" $ showArg x ++ showArg y

74+ showPrec d (Constant c) = showCon d "Constant" $ showArg c

75+ showPrec d Ty = "Ty"

3976

4077||| Quote a reflected Idris term to a Term in some induced local context

4178covering

@@ -183,16 +220,39 @@ covering

183220spliceTerm : Term -> Elab ()

184221spliceTerm = spliceTerm' []

185222

186−||| Lift an Agda-style tactic into an Idris-style tactic

223+syntax "splice" [tm] = %runElab (spliceTerm tm)

224+

225+covering

226+quoteGoalImpl : TTName -> Elab ()

227+quoteGoalImpl f =

228+ do g <- goalType >>= quoteTerm

229+ fill (RApp (Var f) (quote g))

230+ solve

231+

232+syntax "quoteGoal" {g} "in" [e] =

233+ let f = \g : Term => e in %runElab (quoteGoalImpl `{f})

234+

235+

236+-- Note: this definition would seem to be the right thing, but it's not:

237+-- syntax "tactic" [tac] = quoteGoal g in splice tac g

238+-- This is because it would make

239+-- tactic foo

240+-- expand to

241+-- let f = \g : Term => %runElab (spliceTerm (tac g))

242+-- in %runElab (quoteGoalImpl `{f})

243+-- which confuses the meta-level at which the body of the lambda should be

244+-- run. It must be sequenced into the same monadic action as quoting the goal,

245+-- yielding the following implementation:

246+

187247covering

188−quoteGoalImpl : (Term -> Term) -> Elab ()

189−quoteGoalImpl f = do compute

190− g <- goalType >>= quoteTerm

191− spliceTerm (f g)

248+tacticImpl : (tac : Term -> Term) -> Elab ()

249+tacticImpl tac = do g <- goalType >>= quoteTerm

250+ AgdaStyleReflection.spliceTerm (tac g)

251+

252+syntax "tactic" [tacticCode] =

253+ %runElab (tacticImpl tacticCode)

192254

193−syntax "quoteGoal" {x} "in" [expr] = %runElab (quoteGoalImpl (\x => expr))

194255

195−syntax "tactic" [expr] = %runElab (quoteGoalImpl expr)

196256

197257

198258

@@ -231,12 +291,30 @@ covering

231291trivial : (goal : Term) -> Term

232292trivial = perhaps . trivial'

233293

234−foo : (Nat, (), Nat, Either (() -> ()) Void)

235−foo = quoteGoal x in trivial x

294+-- DOESN'T WORK because reflection operations are not pure - they have

295+-- side effects in the elaborator! Also due to metalevel confusion in

296+-- underlying syntax

297+--foo : (Nat, (), Either Void Nat, Nat -> ())

298+--foo = quoteGoal g in splice (trivial g)

299+

236300

301+-- WORKS because "tactic" takes care of the sequencing of operations

237302bar : (Nat, (), Either Void Nat, Nat -> ())

238303bar = tactic trivial

239304

305+someTerm : Term

306+someTerm = quoteGoal g in g

307+

308+ok : AgdaStyleReflection.someTerm = TyCtor (NS (UN "Term") ["AgdaStyleReflection"]) []

309+ok = Refl

310+

311+-- assert_total needed due to partial Show implementations

312+stringly : String -> String

313+stringly = quoteGoal g in \x => assert_total $ show g

314+

315+ok2 : stringly "fnord" = "Pi (Constant StrType) (Constant StrType)"

316+ok2 = Refl

317+

240318-- When checking right hand side of baz:

241319-- PROOF SEARCH FAILURE is not defined.

242320baz : (Nat, Void)

@@ -245,3 +323,4 @@ baz = tactic trivial

245323-- Local Variables:

246324-- idris-load-packages: ("pruviloj")

247325-- End:

326+

test/meta002/DataDef.idrnew file+73

@@ -0,0 +1,73 @@

1+module DataDef

2+

3+foo : Elab ()

4+foo = do declareDatatype $ Declare `{{DataDef.N}} [MkFunArg `{{n}} `(Nat) Explicit NotErased] `(Type)

5+ defineDatatype $ DefineDatatype `{{DataDef.N}} [

6+ Constructor `{{MkN}} [MkFunArg `{{x}} `(Nat) Implicit NotErased] (RApp (Var `{{DataDef.N}}) (Var `{{x}})),

7+ Constructor `{{MkN'}} [MkFunArg `{{x}} `(Nat) Explicit NotErased] (RApp (Var `{{DataDef.N}}) (RApp (Var `{S}) (Var `{{x}})))

8+ ]

9+%runElab foo

10+

11+one : N 1

12+one = MkN

13+

14+two : N 2

15+two = MkN' 1

16+

17+

18+-- mutual

19+-- data U : Type where

20+-- Base : U

21+-- Pi : (code : U) -> (el code -> U) -> U

22+-- el : U -> Type

23+-- el Base = Bool

24+-- el (Pi code body) = (x : el code) -> el (body x)

25+

26+

27+

28+mkU : Elab ()

29+mkU = do let U = `{{DataDef.U}}

30+ let el = `{{DataDef.el}}

31+ declareDatatype $ Declare U [] `(Type)

32+ declareType $ Declare el [MkFunArg `{{code}} (Var U) Explicit NotErased] `(Type)

33+ defineDatatype $ DefineDatatype U [

34+ Constructor `{{Base}} [] (Var U),

35+ Constructor `{{Pi}}

36+ [MkFunArg `{{code}} (Var U) Explicit NotErased,

37+ MkFunArg `{{body}} `(~(RApp (Var el) (Var `{{code}})) -> ~(Var U)) Explicit NotErased]

38+ (Var U)

39+ ]

40+ defineFunction $ DefineFun el [

41+ MkFunClause (RBind `{{code}} (PVar (Var U))

42+ (RBind `{{body}} (PVar `(~(RApp (Var el) (Var `{{code}})) -> ~(Var U)))

43+ (RApp (Var el)

44+ (RApp (RApp (Var `{{DataDef.Pi}})

45+ (Var `{{code}}))

46+ (Var `{{body}})))))

47+ (RBind `{{code}} (PVar (Var U))

48+ (RBind `{{body}} (PVar `(~(RApp (Var el) (Var `{{code}})) -> ~(Var U)))

49+ (RBind `{{x}} (Pi (RApp (Var el) (Var `{{code}})) `(Type))

50+ (RApp (Var el) (RApp (Var `{{body}}) (Var `{{x}})))))),

51+ MkFunClause (RApp (Var el) (Var `{{DataDef.Base}})) `(Bool)

52+

53+ ]

54+

55+%runElab mkU

56+

57+tt : el Base

58+tt = True

59+

60+fun : el (Pi Base (\x => if x then Base else Pi Base (const Base)))

61+fun = \x => (case x of

62+ False => \y => False

63+ True => False)

64+

65+

66+nope : Elab ()

67+nope = defineDatatype $ DefineDatatype `{Either} [

68+ Constructor `{{Middle}} [ MkFunArg `{{x}} `(Type) Implicit NotErased

69+ , MkFunArg `{{y}} `(Type) Implicit NotErased

70+ ] `(Either ~(Var `{{x}}) ~(Var `{{y}}))

71+ ]

72+%runElab nope

73+

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+5−2

@@ -1,9 +1,12 @@

1+DataDef.idr:72:1-9:

2+While running an elaboration script, the following error occurred:

3+Prelude.Either.Either is already defined as a datatype.

14Tacs.idr:298:15:

25When checking right hand side of testElab3 with expected type

3− Sigma Ty (Tm [])

6+ DPair Ty (Tm [])

47

58Unifying ty and ARR ty t would lead to infinite value

6−AgdaStyleReflection.idr:243:5:

9+AgdaStyleReflection.idr:321:5:

710When checking right hand side of baz with expected type

811 (Nat, Void)

912

test/meta002/run+3−2

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

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 DataDef.idr

3+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 Tacs.idr

4+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 AgdaStyleReflection.idr

45# Disabled due to excess memory consumption

56# idris $@ -p pruviloj --nocolour --check --consolewidth 70 Deriving.idr

67rm -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/primitives006/Data/ByteArray.idrnew file+100

@@ -0,0 +1,100 @@

1+module Data.ByteArray

2+

3+%include C "array.h"

4+%link C "array.o"

5+

6+%access public export

7+%default total

8+

9+namespace Byte

10+ Byte : Type

11+ Byte = Bits8

12+

13+ toInt : Byte -> Int

14+ toInt = prim__zextB8_Int

15+

16+ fromInt : Int -> Byte

17+ fromInt = prim__truncInt_B8

18+

19+export

20+record ByteArray where

21+ constructor BA

22+ ptr : CData

23+ sz : Int

24+

25+-- This needn't be precise; it just needs to be enough to be safe.

26+export

27+bytesPerInt : Int

28+bytesPerInt = 8

29+

30+export

31+allocate : Int -> IO ByteArray

32+allocate sz = do

33+ ptr <- foreign FFI_C "array_alloc" (Int -> IO CData) sz

34+ return $ BA ptr sz

35+

36+export

37+reallocate : Int -> ByteArray -> IO ()

38+reallocate newSz (BA ptr sz)

39+ = foreign FFI_C "array_realloc" (Int -> CData -> IO ()) sz ptr

40+

41+export

42+peek : Int -> ByteArray -> IO Byte

43+peek ofs (BA ptr sz)

44+ = if (ofs < 0 || ofs >= sz)

45+ then return 0

46+ else foreign FFI_C "array_peek" (Int -> CData -> IO Byte) ofs ptr

47+

48+export

49+peekInt : Int -> ByteArray -> IO Int

50+peekInt ofs (BA ptr sz)

51+ = if (ofs < 0 || ofs+bytesPerInt > sz)

52+ then return 0

53+ else foreign FFI_C "array_peek_int" (Int -> CData -> IO Int) ofs ptr

54+

55+export

56+poke : Int -> Byte -> ByteArray -> IO ()

57+poke ofs b (BA ptr sz)

58+ = if (ofs < 0 || ofs >= sz)

59+ then return ()

60+ else foreign FFI_C "array_poke" (Int -> Byte -> CData -> IO ()) ofs b ptr

61+

62+export

63+pokeInt : Int -> Int -> ByteArray -> IO ()

64+pokeInt ofs i (BA ptr sz)

65+ = if (ofs < 0 || ofs+bytesPerInt > sz)

66+ then return ()

67+ else foreign FFI_C "array_poke_int" (Int -> Int -> CData -> IO ()) ofs i ptr

68+

69+export

70+copy : (ByteArray, Int) -> (ByteArray, Int) -> Int -> IO ()

71+copy (BA srcPtr srcSz, srcIx) (BA dstPtr dstSz, dstIx) count

72+ = if (srcIx < 0 || dstIx < 0 || (srcIx+count) > srcSz || (dstIx+count) > dstSz)

73+ then return ()

74+ else foreign FFI_C "array_copy" (CData -> Int -> CData -> Int -> Int -> IO ()) srcPtr srcIx dstPtr dstIx count

75+

76+export

77+fill : Int -> Int -> Byte -> ByteArray -> IO ()

78+fill ofs count b (BA ptr sz)

79+ = if (ofs < 0 || ofs+count > sz)

80+ then return ()

81+ else foreign FFI_C "array_fill" (Int -> Int -> Byte -> CData -> IO ()) ofs count b ptr

82+

83+export

84+size : ByteArray -> Int

85+size (BA ptr sz) = sz

86+

87+export

88+compare : (ByteArray, Int) -> (ByteArray, Int) -> Int -> IO Int

89+compare (BA ptrL szL, ofsL) (BA ptrR szR, ofsR) count

90+ = if (ofsL < 0 || ofsL+count > szL || ofsR < 0 || ofsR+count > szR)

91+ then return 0

92+ else foreign FFI_C "array_compare" (CData -> Int -> CData -> Int -> Int -> IO Int) ptrL ofsL ptrR ofsR count

93+

94+export

95+find : Byte -> ByteArray -> Int -> Int -> IO (Maybe Int)

96+find b (BA ptr sz) ofs end = do

97+ ofs <- foreign FFI_C "array_find" (Byte -> CData -> Int -> Int -> IO Int) b ptr ofs end

98+ if ofs < 0

99+ then return $ Nothing

100+ else return $ Just ofs

test/primitives006/Data/Bytes.idrnew file+287

@@ -0,0 +1,287 @@

1+module Data.Bytes

2+

3+import Data.ByteArray as BA

4+

5+%access public export

6+%default total

7+

8+-- Structure of the allocated ByteArray

9+-- [used_size][.....data.....]

10+-- used_size is an int and it takes up BA.bytesPerInt bytes

11+-- at the beginning of the array

12+

13+export

14+record Bytes where

15+ constructor B

16+ arr : ByteArray

17+ ofs : Int

18+ end : Int -- first offset not included in the array

19+

20+minimalCapacity : Int

21+minimalCapacity = 16

22+

23+private

24+dataOfs : Int

25+dataOfs = 1 * BA.bytesPerInt

26+

27+private

28+allocate : Int -> IO Bytes

29+allocate capacity = do

30+ arr <- BA.allocate (BA.bytesPerInt + capacity)

31+ BA.pokeInt 0 dataOfs arr

32+ BA.fill dataOfs capacity 0 arr -- zero the array

33+ return $ B arr dataOfs dataOfs

34+

35+export

36+length : Bytes -> Int

37+length (B arr ofs end) = end - ofs

38+

39+export

40+empty : Bytes

41+empty = unsafePerformIO $ allocate minimalCapacity

42+

43+export

44+null : Bytes -> Bool

45+null (B arr ofs end) = (ofs == end)

46+

47+%freeze empty

48+

49+-- factor=1 ~ copy

50+-- factor=2 ~ grow

51+private

52+grow : Int -> Bytes -> IO Bytes

53+grow factor (B arr ofs end) = do

54+ maxUsed <- BA.peekInt 0 arr

55+ let bytesUsed = end - ofs

56+ let bytesAvailable =

57+ if maxUsed > end

58+ then bytesUsed

59+ else BA.size arr - ofs

60+ B arr' ofs' end' <- allocate $ (factor*bytesAvailable) `max` minimalCapacity

61+ BA.copy (arr, ofs) (arr', ofs') bytesUsed

62+ return $ B arr' ofs' (ofs' + bytesUsed)

63+

64+%assert_total

65+export

66+snoc : Bytes -> Byte -> Bytes

67+snoc bs@(B arr ofs end) byte

68+ = if end >= BA.size arr

69+ then unsafePerformIO $ do -- need more space

70+ grown <- grow 2 bs

71+ return $ snoc grown byte

72+ else unsafePerformIO $ do

73+ maxUsed <- BA.peekInt 0 arr

74+ if maxUsed > end

75+ then do -- someone already took the headroom, need copying

76+ copy <- grow 2 bs

77+ return $ snoc copy byte

78+ else do -- can mutate

79+ BA.pokeInt 0 (end+1) arr

80+ BA.poke end byte arr

81+ return $ B arr ofs (end+1)

82+

83+infixl 7 |>

84+export

85+(|>) : Bytes -> Byte -> Bytes

86+(|>) = snoc

87+

88+namespace SnocView

89+ data SnocView : Type where

90+ Nil : SnocView

91+ Snoc : (bs : Bytes) -> (b : Byte) -> SnocView

92+

93+ export

94+ snocView : Bytes -> SnocView

95+ snocView (B arr ofs end) =

96+ if end == ofs

97+ then SnocView.Nil

98+ else unsafePerformIO $ do

99+ last <- BA.peek (end-1) arr

100+ return $ SnocView.Snoc (B arr ofs (end-1)) last

101+

102+namespace ConsView

103+ data ConsView : Type where

104+ Nil : ConsView

105+ Cons : (b : Byte) -> (bs : Bytes) -> ConsView

106+

107+ export

108+ consView : Bytes -> ConsView

109+ consView (B arr ofs end) =

110+ if end == ofs

111+ then ConsView.Nil

112+ else unsafePerformIO $ do

113+ first <- BA.peek ofs arr

114+ return $ ConsView.Cons first (B arr (ofs+1) end)

115+

116+infixr 7 ++

117+%assert_total

118+export

119+(++) : Bytes -> Bytes -> Bytes

120+(++) bsL@(B arrL ofsL endL) bsR@(B arrR ofsR endR)

121+ = let countR = endR - ofsR in

122+ if endL + countR > BA.size arrL

123+ then unsafePerformIO $ do -- need more space

124+ grown <- grow 2 bsL

125+ return $ grown ++ bsR

126+ else unsafePerformIO $ do

127+ maxUsedL <- BA.peekInt 0 arrL

128+ if maxUsedL > endL

129+ then do -- headroom taken

130+ copyL <- grow 2 bsL

131+ return $ copyL ++ bsR

132+ else do -- can mutate

133+ BA.pokeInt 0 (endL + countR) arrL

134+ BA.copy (arrR, ofsR) (arrL, endL) countR

135+ return $ B arrL ofsL (endL + countR)

136+

137+export

138+dropPrefix : Int -> Bytes -> Bytes

139+dropPrefix n (B arr ofs end) = B arr (((ofs + n) `min` end) `max` dataOfs) end

140+

141+export

142+takePrefix : Int -> Bytes -> Bytes

143+takePrefix n (B arr ofs end) = B arr ofs (((ofs + n) `min` end) `max` dataOfs)

144+

145+export

146+pack : List Byte -> Bytes

147+pack = fromList empty

148+ where

149+ fromList : Bytes -> List Byte -> Bytes

150+ fromList bs [] = bs

151+ fromList bs (x :: xs) = fromList (bs `snoc` x) xs

152+

153+export

154+unpack : Bytes -> List Byte

155+unpack bs with (consView bs)

156+ | Nil = []

157+ | Cons x xs = x :: unpack (assert_smaller bs xs)

158+

159+export

160+slice : Int -> Int -> Bytes -> Bytes

161+slice ofs' end' (B arr ofs end)

162+ = B arr

163+ (((ofs + ofs') `min` end) `max` dataOfs)

164+ (((ofs + end') `min` end) `max` dataOfs)

165+

166+-- Folds with early exit.

167+-- If Bytes were a Functor, this would be equivalent

168+-- to a Traversable implementation interpreted in the Either monad.

169+data Result : Type -> Type where

170+ Stop : (result : a) -> Result a

171+ Cont : (acc : a) -> Result a

172+

173+export

174+iterateR : (Byte -> a -> Result a) -> a -> Bytes -> a

175+iterateR f acc bs with (snocView bs)

176+ | Nil = acc

177+ | Snoc ys y with (f y acc)

178+ | Stop result = result

179+ | Cont acc' = iterateR f acc' (assert_smaller bs ys)

180+

181+export

182+iterateL : (a -> Byte -> Result a) -> a -> Bytes -> a

183+iterateL f acc bs with (consView bs)

184+ | Nil = acc

185+ | Cons y ys with (f acc y)

186+ | Stop result = result

187+ | Cont acc' = iterateL f acc' (assert_smaller bs ys)

188+

189+infixl 3 .:

190+private

191+(.:) : (a -> b) -> (c -> d -> a) -> (c -> d -> b)

192+(.:) g f x y = g (f x y)

193+

194+export

195+foldr : (Byte -> a -> a) -> a -> Bytes -> a

196+foldr f = iterateR (Cont .: f)

197+

198+export

199+foldl : (a -> Byte -> a) -> a -> Bytes -> a

200+foldl f = iterateL (Cont .: f)

201+

202+export

203+spanLength : (Byte -> Bool) -> Bytes -> Int

204+spanLength p = iterateL step 0

205+ where

206+ step : Int -> Byte -> Result Int

207+ step n b with (p b)

208+ | True = Cont (1 + n)

209+ | False = Stop n

210+

211+find : Byte -> Bytes -> Maybe Int

212+find b (B arr ofs end) = unsafePerformIO $ BA.find b arr ofs end

213+

214+export

215+splitAt : Int -> Bytes -> (Bytes, Bytes)

216+splitAt n bs = (takePrefix n bs, dropPrefix n bs)

217+

218+export

219+splitOn : Byte -> Bytes -> (Bytes, Bytes)

220+splitOn b bs with (find b bs)

221+ | Nothing = (bs, empty)

222+ | Just ofs = (takePrefix ofs bs, dropPrefix (ofs+1) bs)

223+

224+export

225+splitsOn : Byte -> Bytes -> List Bytes

226+splitsOn b bs with (find b bs)

227+ | Nothing = [bs]

228+ | Just ofs = takePrefix ofs bs :: splitsOn b (assert_smaller bs $ dropPrefix (ofs+1) bs)

229+

230+export

231+asciiLines : Bytes -> List Bytes

232+asciiLines = splitsOn 0x0A

233+

234+export

235+span : (Byte -> Bool) -> Bytes -> (Bytes, Bytes)

236+span p bs = splitAt (spanLength p bs) bs

237+

238+export

239+break : (Byte -> Bool) -> Bytes -> (Bytes, Bytes)

240+break p bs = span (not . p) bs

241+

242+private

243+cmp : Bytes -> Bytes -> Ordering

244+cmp (B arrL ofsL endL) (B arrR ofsR endR) = unsafePerformIO $ do

245+ let countL = endL - ofsL

246+ let countR = endR - ofsR

247+ let commonCount = countL `min` countR

248+ result <- BA.compare (arrL, ofsL) (arrR, ofsR) commonCount

249+ return $

250+ if result /= 0

251+ then i2o result

252+ else compare countL countR

253+ where

254+ i2o : Int -> Ordering

255+ i2o 0 = EQ

256+ i2o i = if i < 0 then LT else GT

257+

258+implementation Eq Bytes where

259+ xs == ys = (Bytes.cmp xs ys == EQ)

260+

261+implementation Ord Bytes where

262+ compare = Bytes.cmp

263+

264+export

265+toString : Bytes -> String

266+toString = foldr (strCons . chr . toInt) ""

267+

268+export

269+fromString : String -> Bytes

270+fromString = foldl (\bs, c => bs |> fromInt (ord c)) empty . unpack

271+

272+implementation Show Bytes where

273+ show = ("b" ++) . show . toString

274+

275+implementation Semigroup Bytes where

276+ (<+>) = (++)

277+

278+implementation Monoid Bytes where

279+ neutral = empty

280+

281+-- todo:

282+--

283+-- make indices Nats

284+-- Build a ByteString on top of Bytes?

285+-- migrate to (Bits 8)?

286+--

287+-- bidirectional growth?

test/primitives006/array.cnew file+62

@@ -0,0 +1,62 @@

1+#include "array.h"

2+#include <string.h>

3+

4+int array_find(uint8_t byte, CData array, int ofs, int end)

5+{

6+ void * data = array->data + ofs;

7+ void * result = memchr(data, (int) byte, (size_t) (end - ofs));

8+ if (result == NULL)

9+ {

10+ return -1;

11+ }

12+ else

13+ {

14+ return (result - data);

15+ }

16+}

17+

18+void array_realloc(int size, CData array)

19+{

20+ array->data = realloc(array->data, (size_t) size);

21+}

22+

23+CData array_alloc(int size)

24+{

25+ return cdata_allocate((size_t) size, free);

26+}

27+

28+uint8_t array_peek(int ofs, CData array)

29+{

30+ return ((uint8_t *) array->data)[ofs];

31+}

32+

33+void array_poke(int ofs, uint8_t byte, CData array)

34+{

35+ ((uint8_t *) array->data)[ofs] = byte;

36+}

37+

38+int array_peek_int(int ofs, CData array)

39+{

40+ return *((int *) (array->data + ofs));

41+}

42+

43+void array_poke_int(int ofs, int val, CData array)

44+{

45+ *((int *) (array->data + ofs)) = val;

46+}

47+

48+void array_copy(CData src, int src_ofs, CData dst, int dst_ofs, int count)

49+{

50+ // memmove rather than memcpy in case the areas overlap

51+ memmove(dst->data + dst_ofs, src->data + src_ofs, count);

52+}

53+

54+void array_fill(int ofs, int count, uint8_t byte, CData array)

55+{

56+ memset(array->data + ofs, byte, count);

57+}

58+

59+int array_compare(CData l, int lofs, CData r, int rofs, int count)

60+{

61+ return memcmp(l->data + lofs, r->data + rofs, count);

62+}

test/primitives006/array.hnew file+18

@@ -0,0 +1,18 @@

1+#pragma once

2+

3+#include <stdint.h>

4+#include <stddef.h>

5+

6+#include "idris_rts.h"

7+

8+

9+CData array_alloc(int size);

10+void array_realloc(int size, CData array);

11+uint8_t array_peek(int ofs, CData array);

12+int array_peek_int(int ofs, CData array);

13+void array_poke(int ofs, uint8_t byte, CData array);

14+void array_poke_int(int ofs, int i, CData array);

15+void array_copy(CData src, int src_ofs, CData dst, int dst_ofs, int count);

16+void array_fill(int ofs, int count, uint8_t byte, CData array);

17+int array_compare(CData l, int lofs, CData r, int rofs, int count);

18+int array_find(uint8_t byte, CData array, int ofs, int end);

test/primitives006/expectednew file+9

@@ -0,0 +1,9 @@

1+1024

2+("01/8", (145536, 897))

3+("02/8", (145536, 897))

4+("03/8", (145536, 897))

5+("04/8", (145536, 897))

6+("05/8", (145536, 897))

7+("06/8", (145536, 897))

8+("07/8", (145536, 897))

9+("08/8", (145536, 897))

test/primitives006/load-test.idrnew file+48

@@ -0,0 +1,48 @@

1+module Main

2+

3+import Data.Bytes as B

4+import Data.ByteArray as BA

5+

6+-- %flag C "-g3 -ggdb -O0"

7+%link C "array.o"

8+

9+initialBuf : Bytes

10+initialBuf = pack . concat $ replicate 128 block

11+ where

12+ block : List Byte

13+ block = [10,32,1,10,100,32,1,10,255,32,1,10,1,10,255,32,1,10,255,32,1,10,255,32,1,10]

14+

15+unRLE : Bytes -> Bytes

16+unRLE = fst . iterateL phi (empty, Nothing)

17+ where

18+ phi : (Bytes, Maybe Byte) -> Byte -> Result (Bytes, Maybe Byte)

19+ phi (bs, Nothing) b = Cont (bs, Just b)

20+ phi (bs, Just cnt) b = Cont (bs ++ pack (replicate (cast $ prim__zextB8_Int cnt) b), Nothing)

21+

22+unit : Int -> Byte -> IO ()

23+unit n b =

24+ let expanded = unRLE initialBuf

25+ in let elines = map (flip snoc b) (asciiLines expanded)

26+ in printLn $ (show b ++ "/" ++ show n, length expanded, length elines)

27+

28+alloc : Int -> Int -> IO Int

29+alloc x 0 = return x

30+alloc x i = do

31+ -- allocate an array

32+ arr <- BA.allocate (64 * 1024 * 1024)

33+ -- write "i" at offset 63M

34+ BA.pokeInt (63*1024*1024) i arr

35+ -- read number from offset 63M

36+ j <- BA.peekInt (63*1024*1024) arr

37+ -- count matches

38+ alloc (x + if i == j then 1 else 0) (i - 1)

39+

40+main : IO ()

41+main = do

42+ -- First allocate 1024 64M arrays to break the C heap if there's a bug

43+ alloc 0 1024 >>= printLn

44+

45+ -- Then, test Bytes

46+ traverse_ (unit n . prim__truncInt_B8) [1..n]

47+ where

48+ n = 8

test/primitives006/runnew file+6

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

1+#!/usr/bin/env bash

2+${CC:-cc} -c -O2 -o array.o array.c $(${IDRIS:-idris} --include)

3+${IDRIS:-idris} $@ -o load-test load-test.idr --nocolour --warnreach

4+./load-test

5+rm -f load-test *.o *.ibc

6+find -name \*.ibc -delete

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 --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} $@ test030.idr --check --nocolour

3+${IDRIS:-idris} $@ 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 -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 --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 --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/pruviloj001.idr+4−2

@@ -12,7 +12,7 @@ partial

1212auto : Elab ()

1313auto = do compute

1414 attack

15− try $ repeatUntilFail intro'

15+ try intros

1616 hs <- map fst <$> getEnv

1717 for_ hs $

1818 \ih => try (rewriteWith (Var ih))

@@ -23,10 +23,12 @@ auto = do compute

2323partial

2424mush : Elab ()

2525mush =

26− do n <- gensym "j"

26+ do attack

27+ n <- gensym "j"

2728 intro n

2829 try intros

2930 ignore $ induction (Var n) `andThen` auto

31+ solve

3032

3133plusAssoc : (j, k, l : Nat) -> plus (plus j k) l = plus j (plus k l)

3234plusAssoc = %runElab mush

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} $@ --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} $@ --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} --check reg003.idr

3+${IDRIS:-idris} --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} $@ 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} --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} $@ 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 reg017.idr -o reg017

33./reg017

44rm -f reg017 *.ibc

test/reg018/expected+2

@@ -4,6 +4,8 @@ reg018a.idr:21:1:

44conat.loopForever is possibly not total due to: conat.minusCoNat

55reg018b.idr:8:1:

66A.showB is possibly not total due to recursive path A.showB

7+reg018b.idr:11:1:

8+A.B implementation of Prelude.Show.Show is possibly not total due to: A.showB

79reg018c.idr:21:1:

810CodataTest.inf is possibly not total due to: with block in CodataTest.inf

911reg018d.idr:8:1:

test/reg018/reg018b.idr+1−1

@@ -8,7 +8,7 @@ showB : B -> String

88showB (I x) = "I" ++ showB x

99showB (Z x) = "Z" ++ showB x

1010

11−implementation Show B where show = showB

11+Show B where show = showB

1212

1313os : B

1414os = Z os

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} $@ reg018a.idr --check

3+${IDRIS:-idris} $@ reg018b.idr --check

4+${IDRIS:-idris} $@ reg018c.idr --check

5+${IDRIS:-idris} $@ 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 $@ 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} $@ reg027.idr -o reg027

33./reg027

4−idris --consolewidth 80 $@ reg027a.idr --check

4+${IDRIS:-idris} $@ 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} $@ reg028.idr --check

3+${IDRIS:-idris} $@ 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 --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 --check reg035.idr

3+${IDRIS:-idris} --nocolour --check reg035a.lidr

4+${IDRIS:-idris} --nocolour --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 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} --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 $@ 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 $@ reg055.idr --check

3+${IDRIS:-idris} --nocolour $@ 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} $@ 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/reg068/expectednew file+7

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

1+reg068.idr:1:6:

2+Main.nat has a name which may be implicitly bound.

3+This is likely to lead to problems!

4+reg068.idr:2:6:Main.ze has a name which may be implicitly bound.

5+This is likely to lead to problems!

6+reg068.idr:2:6:When checking constructor Main.ze:

7+Type level variable nat is not Main.nat

test/reg068/reg068.idrnew file+4

@@ -0,0 +1,4 @@

1+data nat : Type where --error

2+ ze : nat --hello.idr:10:6:When checking constructor Main.ze: !!V 0!! is not Main.nat

3+ su : nat -> nat

4+

test/reg068/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ reg068.idr --check

3+rm -f *.ibc

test/reg069/Mod.idrnew file+12

@@ -0,0 +1,12 @@

1+module Mod

2+

3+-- %access public

4+

5+export

6+natfn : Nat -> Nat

7+natfn n = (S (S n))

8+

9+public export

10+natexp : (n : Nat) -> Nat

11+natexp k = S (natfn k)

12+

test/reg069/expectednew file+2

@@ -0,0 +1,2 @@

1+Mod.idr:11:1:

2+public export Mod.natexp can't refer to export Mod.natfn

test/reg069/reg069.idrnew file+5

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

1+import Mod

2+

3+foo : natexp 4 = 7

4+foo = Refl

5+

test/reg069/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ reg069.idr --check

3+rm -f *.ibc

test/reg070/expectednew file+2

@@ -0,0 +1,2 @@

1+reg070.idr:7:1:

2+Test_show.Te implementation of Prelude.Show.Show is possibly not total due to: Prelude.Show.Test_show.Te implementation of Prelude.Show.Show, method show

test/reg070/reg070.idrnew file+15

@@ -0,0 +1,15 @@

1+module Test_show

2+

3+%default total

4+

5+data Te = C1 | C2 | C3

6+

7+Show Te where

8+ show C1 = "C1"

9+

10+-- Eq Te where

11+-- (==) C1 C3 = False

12+

13+-- foo : Te -> String

14+-- foo = show

15+

test/reg070/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ reg070.idr --check

3+rm -f *.ibc

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

3+${IDRIS:-idris} $@ SyntaxTest.idr --nocolour --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} $@ --check test010.idr

3+${IDRIS:-idris} $@ --check test010a.idr

4+${IDRIS:-idris} $@ --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} $@ --check test017.idr

3+${IDRIS:-idris} $@ --check test017a.idr

4+${IDRIS:-idris} $@ --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 $@ totality003.idr --check

3+${IDRIS:-idris} --nocolour $@ 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} $@ totality004.idr -o totality004

33./totality004

4−idris --consolewidth 80 $@ --check totality004a.idr

4+${IDRIS:-idris} $@ --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} $@ totality006.idr --check

3+${IDRIS:-idris} $@ totality006a.idr --check

4+${IDRIS:-idris} $@ 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} $@ 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 --check

33rm -f *.ibc

test/totality011/expectednew file+2

@@ -0,0 +1,2 @@

1+totality011.lidr:22:1:

2+Main.weCanOnlyGetOlder is not total as there are missing cases

test/totality011/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ totality011.lidr --check

3+rm -f *.ibc

test/totality011/totality011.lidrnew file+31

@@ -0,0 +1,31 @@

1+> %default total

2+

3+> X : Nat -> Type

4+> Y : (t : Nat) -> X t -> Type

5+> step : (t : Nat) -> (x : X t) -> Y t x -> X (S t)

6+

7+> Pred : X t -> X (S t) -> Type

8+> Pred {t} x x' = Subset (Y t x) (\ y => (x' = step t x y))

9+

10+> ReachableFrom : X t'' -> X t -> Type

11+> ReachableFrom {t'' = Z } {t} x'' x =

12+> (Z = t , x'' = x)

13+> ReachableFrom {t'' = S t'} {t} x'' x =

14+> Either (S t' = t , x'' = x)

15+> (Subset (X t') (\ x' => (x' `ReachableFrom` x , x' `Pred` x'')))

16+

17+> weCanOnlyGetOlder : (x'' : X t'') ->

18+> (x : X t) ->

19+> x'' `ReachableFrom` x ->

20+> t'' `GTE` t

21+

22+> weCanOnlyGetOlder {t'' = Z} {t = Z} _ _ _ = LTEZero

23+> weCanOnlyGetOlder {t'' = Z} {t = S m} _ _ (Zeqt , _) =

24+> void (uninhabited u) where

25+> u : Z = S m

26+> u = trans Zeqt Refl

27+

28+> weCanOnlyGetOlder {t'' = S _} {t = S _} _ _ _ = ?foo

29+

30+-- > weCanOnlyGetOlder {t'' = S _} {t = S _} _ _ (_, _) = ?foo

31+

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

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/expected+1−1

@@ -18,7 +18,7 @@ When checking right hand side of with block in Main.parity with expected type

1818 Parity (S (S (j + j)))

1919

2020Type mismatch between

21− Parity (plus (S j) (S j)) (Type of Even)

21+ Parity (S j + S j) (Type of Even)

2222and

2323 Parity (S (S (plus j j))) (Expected type)

2424

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 $@ tutorial006a.idr --check

3+${IDRIS:-idris} --nocolour $@ tutorial006b.idr --check

4+${IDRIS:-idris} --nocolour $@ 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 $@ 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 $@ unique001a.idr --check

5+${IDRIS:-idris} --nocolour $@ unique001b.idr --check

6+${IDRIS:-idris} --nocolour $@ unique001c.idr --check

7+${IDRIS:-idris} --nocolour $@ unique001d.idr --check

8+${IDRIS:-idris} --nocolour $@ 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 $@ unique002.idr --check

3+${IDRIS:-idris} --nocolour $@ 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 $@ unique003.idr --check

33rm -f *.ibc