0303d07 · Idris-dev · git.iko.soy

.gitignore+2

compare with master

unifiedsplit

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

16*~

17.DS_Store

18.hpc

19+*.orig

19*.tix

20*.tix

20.projectile

21.projectile

21.dir-locals.el

22.dir-locals.el

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

27test/output

28test/output

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

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

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

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

31+test/runtest.exe

30tags

32tags

31TAGS

33TAGS

32src/Version_idris.hs

34src/Version_idris.hs

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

1New in 0.10:

90New in 0.10:

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

91============

3

92

CONTRIBUTORS+1

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

32Tom Prince

33raichoo

34Philip Rasmussen

35+Aistis Raulinaitis

35Reynir Reynisson

36Reynir Reynisson

36Adam Sandberg Eriksson

37Adam Sandberg Eriksson

37Seo Sanghyeon

38Seo 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.

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

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

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

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

66+building Idris from source with stack.

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

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

68−only.

68+NixOS unstable.

69

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

71

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

77infrastructure. For more information about Stack please visit the

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

79

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

81+the required libraries and header files are available:

82+

83+* `stack build --nix`

84+

80### System GHC

85### System GHC

81

86

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

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

Makefile+3−14

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

20test: doc test_c

21

22test_c:

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

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

24−

25−test_java:

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

27−

28−test_llvm:

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

30

24

31test_js:

25test_js:

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

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

33−

34−test_all:

35− $(MAKE) test

36− $(MAKE) test_llvm

37− $(MAKE) test_java

38

27

39test_timed:

28test_timed:

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

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

41

30

42lib_clean:

31lib_clean:

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

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

Setup.hs+19

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

10import qualified Distribution.Simple.Setup as S

11import qualified Distribution.Simple.Program as P

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

13+import Distribution.Compiler

13import Distribution.PackageDescription

14import Distribution.PackageDescription

14import Distribution.Text

15import Distribution.Text

15

16

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

45make verbosity =

46make verbosity =

46 P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake

47 P.runProgramInvocation verbosity . P.simpleProgramInvocation mymake

47

48

49+#ifdef mingw32_HOST_OS

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

51+#endif

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

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

49-- Flags

53-- Flags

50

54

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

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

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

199 return (Just buildinfo, [])

203 return (Just buildinfo, [])

200

204

205+

206+

207+idrisPreBuild args flags = do

208+#ifdef mingw32_HOST_OS

209+ createDirectoryIfMissingVerbose verbosity True dir

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

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

212+ where

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

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

215+#else

216+ return (Nothing, [])

217+#endif

218+

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

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

202 buildStdLib

220 buildStdLib

203 buildRTS

221 buildRTS

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

247main = defaultMainWithHooks $ simpleUserHooks

265main = defaultMainWithHooks $ simpleUserHooks

248 { postClean = idrisClean

266 { postClean = idrisClean

249 , postConf = idrisConfigure

267 , postConf = idrisConfigure

268+ , preBuild = idrisPreBuild

250 , postBuild = idrisBuild

269 , postBuild = idrisBuild

251 , postCopy = \_ flags pkg local ->

270 , postCopy = \_ flags pkg local ->

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

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

benchmarks/quasigroups/Parser.idr+2

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

5

6import Solver

7

8+%access public export

9+

8ParseErr : Type

10ParseErr : Type

9ParseErr = String

11ParseErr = String

10

12

benchmarks/quasigroups/Solver.idr+2−1

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

6import Data.Vect.Quantifiers

7

8%default total

9+%access public export

9

10

10Cell : Nat -> Type

11Cell : Nat -> Type

11Cell n = Maybe (Fin n)

12Cell n = Maybe (Fin n)

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

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

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

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

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

34

35

35−instance Show (Board n) where

36+Show (Board n) where

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

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

37

38

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

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

config.mk+9−2

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

1−CC ?=cc

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

2−AR ?=ar

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+

3RANLIB ?=ranlib

10RANLIB ?=ranlib

4

11

5CABAL :=cabal

12CABAL :=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'

59# built documents.

60#

61# The short X.Y version.

62−version = '0.9.19'

62+version = '0.10.3'

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

64−release = '0.9.19.1'

64+release = '0.10.3'

65

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

67# for a list of supported languages.

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

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

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

236latex_documents = [

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

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

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

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

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

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

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

241 ]

242

docs/effects/simpleeff.rst+11−10

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

578

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

580

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

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

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

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

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

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

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

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

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

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

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

586−types are first class in Idris:

587+ first class in Idris:

587

588

588−.. code-block:: idris

589+ .. code-block:: idris

589

590

590− EvalEff : Type -> Type

591+ EvalEff : Type -> Type

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

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

592

593

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

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

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

189

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

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

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

192

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

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

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

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

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

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

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

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

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

199+of any type.

197

200

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

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

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

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

docs/reference/elaborator-reflection.rst+4−4

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

37.. code-block:: idris

38

39 idNat : Nat -> Nat

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

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

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

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

42 solve)

43

44

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

57.. code-block:: idris

58

59 mkId : Elab ()

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

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

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

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

62 solve

63

64 idNat : Nat -> Nat

docs/reference/ffi.rst+94−13

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

80.. code-block:: idris

81

82 ||| Supported C integer types

83+ public export

83 data C_IntTypes : Type -> Type where

84 data C_IntTypes : Type -> Type where

84− C_IntChar : C_IntTypes Char

85+ C_IntChar : C_IntTypes Char

85− C_IntNative : C_IntTypes Int

86+ C_IntNative : C_IntTypes Int

86− ... -- more integer types

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

87

98

88 ||| Supported C foreign types

99 ||| Supported C foreign types

100+ public export

89 data C_Types : Type -> Type where

101 data C_Types : Type -> Type where

90− C_Str : C_Types String

102+ C_Str : C_Types String

91− C_Float : C_Types Float

103+ C_Float : C_Types Double

92− C_Ptr : C_Types Ptr

104+ C_Ptr : C_Types Ptr

93− C_MPtr : C_Types ManagedPtr

105+ C_MPtr : C_Types ManagedPtr

94− C_Unit : C_Types ()

106+ C_Unit : C_Types ()

95− C_Any : C_Types (Raw a)

107+ C_Any : C_Types (Raw a)

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

96− C_IntT : C_IntTypes i -> C_Types i

109+ C_IntT : C_IntTypes i -> C_Types i

97−

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

98 FFI_C : FFI

115 FFI_C : FFI

99− FFI_C = MkFFI C_Types

116+ FFI_C = MkFFI C_Types String String

100− String -- the name of the C function

101

117

102Foreign calls

118Foreign calls

103=============

119=============

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

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

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

136 jscall fname ty = foreign FFI_JS fname ty

152 jscall fname ty = foreign FFI_JS fname ty

137

153

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+

138FFI implementation

219FFI implementation

139------------------

220------------------

140

221

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

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

46 using the ``UniqueType`` universe.

47- `Partial

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

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

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

50- Error message reflection

51- Eliminators

52- Label types ``'name``

docs/reference/misc.rst+108−1

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

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

101

102

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+

103Preorder reasoning

210Preorder reasoning

104==================

211==================

105

212

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

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

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

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

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

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

227 (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) }=

122 (c * a * b) QED

229 (c * a * b) QED

123

230

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

231Note 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

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

288

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

291Arguments in anonymous functions are separated by comma.

295Arguments in anonymous functions are separated by comma.

292

296

293::

297::

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

303

307

304::

308::

305

309

306− public

310+ public export

307− abstract

311+ export

308 private

312 private

309

313

310Totality

314Totality

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

372 -- Single Line

376 -- Single Line

373 {- Multiline -}

377 {- Multiline -}

374 ||| Docstring (goes before definition)

378 ||| Docstring (goes before definition)

375−

379+

376Multi line String literals

380Multi line String literals

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

381~~~~~~~~~~~~~~~~~~~~~~~~~~

378

382

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

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

34

35.. code-block:: idris

36

37− data UList : Type -> UniqueType

37+ data UList : Type -> UniqueType where

38 Nil : UList a

39 (::) : a -> UList a -> UList a

40

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

94

95.. code-block:: idris

96

97− data BadList : UniqueType -> Type

97+ data BadList : UniqueType -> Type where

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

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

100

docs/tutorial/interp.rst+4−4

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

28.. code-block:: idris

29

30 interpTy : Ty -> Type

31− interpTy TyInt = Int

31+ interpTy TyInt = Integer

32 interpTy TyBool = Bool

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

34

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

62

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

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

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

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

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

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

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

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

115

116.. code-block:: idris

117

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

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

119

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

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

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

270 main : IO ()

271 main = do putStr "Enter a number: "

272 x <- getLine

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

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

274

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

276one 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:

39This tutorial introduces Idris, a general purpose functional

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

41project 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

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

44a lightweight foreign function interface which allows easy interaction

45with external ``C`` libraries.

docs/tutorial/modules.rst+79−31

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

75Export Modifiers

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

77

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

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

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

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

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

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

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

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

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

82−

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

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

84+

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

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

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

86+ default.

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

87+

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

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

88− names are exported.

89+

89−

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

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

91+

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

92+

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

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

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

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

94− method names.

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

95−

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

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

97+names leaking into a module's interface.

97− exported.

98+

99+Meaning for Functions

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

101+

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

103+

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

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

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

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

108+ about doing this.

98

109

99.. note::

110.. note::

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

101

111

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

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

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

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

116+ synonym for.

117+

118+

119+Meaning for Data Types

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

121+

122+For data types, the meanings are:

123+

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

125+

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

127+ exported

128+

129+

130+Meaning for Interfaces

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

132+

133+For interfaces, the meanings are:

134+

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

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

137+ definitions are exported

138+

139+

140+

141+``BTree`` Revisited

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

143+

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

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

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

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

104

146

105.. code-block:: idris

147.. code-block:: idris

106

148

107− module Btree

149+ module BTree

108

150

109− abstract data BTree a = Leaf

151+ export data BTree a = Leaf

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

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

111

153

112− abstract

154+ export

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

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

114 insert x Leaf = Node Leaf x Leaf

156 insert x Leaf = Node Leaf x Leaf

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

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

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

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

117

159

118− abstract

160+ export

119 toList : BTree a -> List a

161 toList : BTree a -> List a

120 toList Leaf = []

162 toList Leaf = []

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

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

122

164

123− abstract

165+ export

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

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

125 toTree [] = Leaf

167 toTree [] = Leaf

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

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

127

169

170+``%access`` Directive

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

172+

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

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

129directive, for example:

174directive, for example:

130

175

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

132

177

133 module Btree

178 module Btree

134

179

135− %access abstract

180+ %access export

136

181

137 data BTree a = Leaf

182 data BTree a = Leaf

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

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

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

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

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

152

197

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

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

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

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

200+

201+Propagating Inner Module API's

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

155

203

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

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

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

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

docs/tutorial/typesfuns.rst+21−4

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

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

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

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

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

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

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

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

141−Idris prompt:

142

143

143::

144::

144

145

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

494 testVec : Vect 4 Int

495 testVec : Vect 4 Int

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

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

496

497

497− inVect : IsElem 5 testVec

498+ inVect : IsElem 5 Main.testVec

498 inVect = There (There Here)

499 inVect = There (There Here)

499

500

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+

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

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

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

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

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

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

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

509 Here : IsElem x (x :: xs)

521 Here : IsElem x (x :: xs)

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

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

511

523

524+

525+

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

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

513~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

527~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

514

528

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

582

596

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

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

584 closeFile : File -> IO ()

598 closeFile : File -> IO ()

585−

599+

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

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

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

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

588 fEOF : File -> IO Bool

602 fEOF : File -> IO Bool

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

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

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

960updates the given fields in a record.

974updates the given fields in a record.

961

975

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

977+can be reused in multiple records.

978+

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

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

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

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

964well-typed.

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

1Name: idris

2−Version: 0.10

2+Version: 0.10.3

3License: BSD3

4License-file: LICENSE

5Author: Edwin Brady

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

124

125 libs/contrib/contrib.ipkg

126 libs/contrib/Makefile

127+ libs/contrib/*.idr

128+ libs/contrib/CFFI/*.idr

127 libs/contrib/Classes/*.idr

129 libs/contrib/Classes/*.idr

128 libs/contrib/Control/*.idr

130 libs/contrib/Control/*.idr

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

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

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

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

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

151

153

152 test/Makefile

154 test/Makefile

153− test/runtest.pl

155+ test/runtest.hs

154 test/reg001/run

156 test/reg001/run

155 test/reg001/*.idr

157 test/reg001/*.idr

156 test/reg001/expected

158 test/reg001/expected

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

163 test/reg004/run

165 test/reg004/run

164 test/reg004/*.idr

166 test/reg004/*.idr

165 test/reg004/expected

167 test/reg004/expected

168+ test/reg005/run

169+ test/reg005/*.idr

170+ test/reg005/expected

166 test/reg006/run

171 test/reg006/run

167 test/reg006/*.idr

172 test/reg006/*.idr

168 test/reg006/expected

173 test/reg006/expected

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

311 test/reg067/run

316 test/reg067/run

312 test/reg067/*.idr

317 test/reg067/*.idr

313 test/reg067/expected

318 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

314

328

315 test/basic001/run

329 test/basic001/run

316 test/basic001/*.idr

330 test/basic001/*.idr

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

361 test/basic016/run

375 test/basic016/run

362 test/basic016/*.idr

376 test/basic016/*.idr

363 test/basic016/expected

377 test/basic016/expected

378+ test/basic017/run

379+ test/basic017/*.idr

380+ test/basic017/expected

364

381

365 test/bignum001/run

382 test/bignum001/run

366 test/bignum001/*.idr

383 test/bignum001/*.idr

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

462 test/ffi006/*.c

479 test/ffi006/*.c

463 test/ffi006/run

480 test/ffi006/run

464 test/ffi006/expected

481 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

465

492

466 test/folding001/*.idr

493 test/folding001/*.idr

467 test/folding001/run

494 test/folding001/run

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

585 test/primitives003/run

612 test/primitives003/run

586 test/primitives003/*.idr

613 test/primitives003/*.idr

587 test/primitives003/expected

614 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

588

626

589 test/pkg001/run

627 test/pkg001/run

590 test/pkg001/test.ipkg

628 test/pkg001/test.ipkg

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

728 test/totality010/run

766 test/totality010/run

729 test/totality010/*.idr

767 test/totality010/*.idr

730 test/totality010/expected

768 test/totality010/expected

769+ test/totality011/run

770+ test/totality011/*.lidr

771+ test/totality011/expected

731

772

732 test/tutorial001/run

773 test/tutorial001/run

733 test/tutorial001/*.idr

774 test/tutorial001/*.idr

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

788 benchmarks/trivial/sortvec.idr

829 benchmarks/trivial/sortvec.idr

789 benchmarks/trivial/sortvec.ipkg

830 benchmarks/trivial/sortvec.ipkg

790

831

832+ icons/idris_icon.rc

833+ icons/idris.ico

834+

791source-repository head

835source-repository head

792 type: git

836 type: git

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

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

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

802 Default: False

846 Default: False

803 manual: True

847 manual: True

804

848

805−Flag curses

806− Description: Use Curses to get the screen width

807− Default: False

808− manual: True

809−

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

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

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

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

812Flag release

851Flag release

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

859 , Idris.Elab.Transform

898 , Idris.Elab.Transform

860 , Idris.Elab.Value

899 , Idris.Elab.Value

861 , Idris.Elab.Term

900 , Idris.Elab.Term

901+ , Idris.Elab.Quasiquote

862

902

863 , Idris.REPL.Browse

903 , Idris.REPL.Browse

864

904

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

879 , Idris.Docs

919 , Idris.Docs

880 , Idris.Docstrings

920 , Idris.Docstrings

881 , Idris.ElabDecls

921 , Idris.ElabDecls

882− , Idris.ElabQuasiquote

883 , Idris.Erasure

922 , Idris.Erasure

884 , Idris.Error

923 , Idris.Error

885 , Idris.ErrReverse

924 , Idris.ErrReverse

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

892 , Idris.Interactive

931 , Idris.Interactive

893 , Idris.Output

932 , Idris.Output

894 , Idris.Parser

933 , Idris.Parser

895− , Idris.ParseHelpers

934+ , Idris.Parser.Helpers

896− , Idris.ParseOps

935+ , Idris.Parser.Ops

897− , Idris.ParseExpr

936+ , Idris.Parser.Expr

898− , Idris.ParseData

937+ , Idris.Parser.Data

899 , Idris.PartialEval

938 , Idris.PartialEval

900 , Idris.Primitives

939 , Idris.Primitives

901 , Idris.ProofSearch

940 , Idris.ProofSearch

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

903 , Idris.Providers

942 , Idris.Providers

904 , Idris.Reflection

943 , Idris.Reflection

905 , Idris.REPL

944 , Idris.REPL

906− , Idris.REPLParser

945+ , Idris.REPL.Parser

907 , Idris.Transforms

946 , Idris.Transforms

908 , Idris.TypeSearch

947 , Idris.TypeSearch

909 , Idris.Unlit

948 , Idris.Unlit

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

965 , pretty < 1.2

1004 , pretty < 1.2

966 , process < 1.3

1005 , process < 1.3

967 , split < 0.3

1006 , split < 0.3

1007+ , terminal-size < 0.4

968 , text >=1.2.1.0 && < 1.3

1008 , text >=1.2.1.0 && < 1.3

969 , time >= 1.4 && < 1.6

1009 , time >= 1.4 && < 1.6

970 , transformers < 0.5

1010 , transformers < 0.5

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

978 , zip-archive > 0.2.3.5 && < 0.2.4

1018 , zip-archive > 0.2.3.5 && < 0.2.4

979 , safe

1019 , safe

980 , fsnotify < 2.2

1020 , fsnotify < 2.2

981− , async < 2.1

1021+ , async < 2.2

1022+

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

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

983 if impl(ghc < 7.10.3)

1024 if impl(ghc < 7.10.3)

984 build-depends: zlib < 0.6.1

1025 build-depends: zlib < 0.6.1

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

992 , TemplateHaskell

1033 , TemplateHaskell

993

1034

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

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

995− ghc-options: -threaded -rtsopts

996

1036

997 if os(linux)

1037 if os(linux)

998 cpp-options: -DLINUX

1038 cpp-options: -DLINUX

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

1016 build-depends: libffi < 0.2

1056 build-depends: libffi < 0.2

1017 extra-libraries: gmp

1057 extra-libraries: gmp

1018 cpp-options: -DIDRIS_GMP

1058 cpp-options: -DIDRIS_GMP

1019− if flag(curses)

1020− build-depends: hscurses < 1.5

1021− cpp-options: -DCURSES

1022 if flag(freestanding)

1059 if flag(freestanding)

1023 other-modules: Target_idris

1060 other-modules: Target_idris

1024 cpp-options: -DFREESTANDING

1061 cpp-options: -DFREESTANDING

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

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

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

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

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

1041

1078

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+

1042Executable idris-codegen-c

1097Executable idris-codegen-c

1043 Main-is: Main.hs

1098 Main-is: Main.hs

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

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

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

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

3import Data.Morphisms

4import Control.Category

5

6−%access public

6+%access public export

7

8infixr 5 <++>

9infixr 3 ***

libs/base/Control/Catchable.idr+2

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

2

3import Control.IOExcept

4

5+%access public export

6+

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

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

6 throw : t -> m a

8 throw : t -> m a

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

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

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

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

2

3import Data.Morphisms

4

5−%access public

5+%access public export

6

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

8 id : cat a a

libs/base/Control/IOExcept.idr+2

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

1module Control.IOExcept

2

3+%access public export

4+

3-- An IO monad with exception handling

5-- An IO monad with exception handling

4

6

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

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

libs/base/Control/Isomorphism.idr+1

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

4import Data.Fin

5

6%default total

7+%access public export

7

8

8||| An isomorphism between two types

9||| An isomorphism between two types

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

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

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

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

1module Control.Monad.Identity

2

3+%access public export

4+

3−public record Identity (a : Type) where

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

4 constructor Id

6 constructor Id

5 runIdentity : a

7 runIdentity : a

6

8

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

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

5import Control.Monad.Writer

6import Control.Monad.Reader

7

8−%access public

8+%access public export

9

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

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

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

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

4import Control.Monad.Identity

5import Control.Monad.Trans

6

7−%access public

7+%access public export

8

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

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

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

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

3import public Control.Monad.Identity

4import public Control.Monad.Trans

5

6−%access public

6+%access public export

7

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

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

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

54

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

56State : Type -> Type -> Type

57−State s a = StateT s Identity a

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

58

59||| Unwrap a State monad computation.

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

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

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

1module Control.Monad.Trans

2

3+%access public export

4+

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

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

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

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

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

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

4import Control.Monad.Identity

5import Control.Monad.Trans

6

7−%access public

7+%access public export

8

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

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

libs/base/Data/Bits.idr+49−30

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

4

5%default total

6

7−public

7+public export

8nextPow2 : Nat -> Nat

9nextPow2 Z = Z

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

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

13 where

14 l2x = log2NZ (S x) SIsNotZ

15

16−public

16+public export

17nextBytes : Nat -> Nat

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

19

20−public

20+public export

21machineTy : Nat -> Type

22machineTy Z = Bits8

23machineTy (S Z) = Bits16

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

47getPad : [static] {n : Nat} -> Nat -> machineTy n

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

49

50−public

50+public export

51data Bits : Nat -> Type where

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

53

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

92 where

93 pad = getPad {n=3} n

94

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

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

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

98+public export

95shiftLeft' : [static] {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

99shiftLeft' : [static] {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

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

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

97 | Z = pad8' n prim__shlB8 x c

101 | Z = pad8' n prim__shlB8 x c

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

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

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

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

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

101

105

102−public

106+public export

103shiftLeft : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

107shiftLeft : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

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

105

109

110+public export

106shiftRightLogical' : [static] {n : Nat} -> machineTy n -> machineTy n -> machineTy n

111shiftRightLogical' : [static] {n : Nat} -> machineTy n -> machineTy n -> machineTy n

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

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

108 | Z = prim__lshrB8 x c

113 | Z = prim__lshrB8 x c

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

110 | S (S Z) = prim__lshrB32 x c

115 | S (S Z) = prim__lshrB32 x c

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

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

112

117

113−public

118+public export

114shiftRightLogical : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

119shiftRightLogical : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

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

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

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

117

122

123+public export

118shiftRightArithmetic' : [static] {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

124shiftRightArithmetic' : [static] {n : Nat} -> machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

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

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

120 | Z = pad8' n prim__ashrB8 x c

126 | Z = pad8' n prim__ashrB8 x c

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

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

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

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

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

124

130

125−public

131+public export

126shiftRightArithmetic : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

132shiftRightArithmetic : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

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

128

134

135+public export

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

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

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

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

131 | Z = prim__andB8 x y

138 | Z = prim__andB8 x y

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

133 | S (S Z) = prim__andB32 x y

140 | S (S Z) = prim__andB32 x y

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

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

135

142

136−public

143+public export

137and : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

144and : [static] {n : Nat} -> Bits n -> Bits n -> Bits n

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

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

139

146

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

144 | S (S Z) = prim__orB32 x y

151 | S (S Z) = prim__orB32 x y

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

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

146

153

147−public

154+public export

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

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

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

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

150

157

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

155 | S (S Z) = prim__xorB32 x y

162 | S (S Z) = prim__xorB32 x y

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

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

157

164

158−public

165+public export

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

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

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

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

161

168

169+public export

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

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

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

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

164 | Z = pad8 n prim__addB8 x y

172 | Z = pad8 n prim__addB8 x y

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

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

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

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

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

168

176

169−public

177+public export

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

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

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

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

172

180

181+public export

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

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

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

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

175 | Z = pad8 n prim__subB8 x y

184 | Z = pad8 n prim__subB8 x y

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

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

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

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

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

179

188

180−public

189+public export

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

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

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

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

183

192

193+public export

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

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

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

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

186 | Z = pad8 n prim__mulB8 x y

196 | Z = pad8 n prim__mulB8 x y

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

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

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

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

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

190

200

191−public

201+public export

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

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

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

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

194

204

195partial

205partial

206+public export

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

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

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

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

198 | Z = prim__sdivB8 x y

209 | Z = prim__sdivB8 x y

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

200 | S (S Z) = prim__sdivB32 x y

211 | S (S Z) = prim__sdivB32 x y

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

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

202

213

203−public partial

214+public export partial

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

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

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

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

206

217

207partial

218partial

219+public export

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

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

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

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

210 | Z = prim__udivB8 x y

222 | Z = prim__udivB8 x y

211 | S Z = prim__udivB16 x y

223 | S Z = prim__udivB16 x y

212 | S (S Z) = prim__udivB32 x y

224 | S (S Z) = prim__udivB32 x y

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

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

214

226

215−public partial

227+public export partial

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

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

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

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

218

230

219−partial

231+public export partial

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

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

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

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

222 | Z = prim__sremB8 x y

234 | Z = prim__sremB8 x y

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

224 | S (S Z) = prim__sremB32 x y

236 | S (S Z) = prim__sremB32 x y

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

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

226

238

227−public partial

239+public export partial

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

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

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

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

230

242

231−partial

243+public export partial

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

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

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

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

234 | Z = prim__uremB8 x y

246 | Z = prim__uremB8 x y

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

236 | S (S Z) = prim__uremB32 x y

248 | S (S Z) = prim__uremB32 x y

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

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

238

250

239−public partial

251+public export partial

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

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

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

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

242

254

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

276 | S (S Z) = prim__gtB32 x y

288 | S (S Z) = prim__gtB32 x y

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

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

278

290

291+public export

279implementation Eq (Bits n) where

292implementation Eq (Bits n) where

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

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

281

294

295+public export

282implementation Ord (Bits n) where

296implementation Ord (Bits n) where

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

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

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

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

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

291 then EQ

305 then EQ

292 else GT

306 else GT

293

307

308+public export

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

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

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

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

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

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

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

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

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

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

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

304

319

305−public

320+public export

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

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

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

322complement (MkBits x) = MkBits (complement' x)

308

323

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

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

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

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

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

323

338

324−public

339+public export

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

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

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

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

327

342

343+public export

328%assert_total

344%assert_total

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

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

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

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

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

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

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

332 prim__lshrB8 (prim__shlB8 (prim__truncBigInt_B8 x) pad) pad

349 prim__lshrB8 (prim__shlB8 (prim__truncBigInt_B8 x) pad) pad

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

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

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

338 prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad

355 prim__lshrB64 (prim__shlB64 (prim__truncBigInt_B64 x) pad) pad

339

356

340−public

357+public export

341intToBits : [static] {n : Nat} -> Integer -> Bits n

358intToBits : [static] {n : Nat} -> Integer -> Bits n

342intToBits n = MkBits (intToBits' n)

359intToBits n = MkBits (intToBits' n)

343

360

344implementation Cast Integer (Bits n) where

361implementation Cast Integer (Bits n) where

345 cast = intToBits

362 cast = intToBits

346

363

364+public export

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

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

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

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

349 | Z = prim__zextB8_BigInt x

367 | Z = prim__zextB8_BigInt x

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

351 | S (S Z) = prim__zextB32_BigInt x

369 | S (S Z) = prim__zextB32_BigInt x

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

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

353

371

354−public

372+public export

355bitsToInt : [static] {n : Nat} -> Bits n -> Integer

373bitsToInt : [static] {n : Nat} -> Bits n -> Integer

356bitsToInt (MkBits x) = bitsToInt' x

374bitsToInt (MkBits x) = bitsToInt' x

357

375

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

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

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

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

412 believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad)

395

413

396−--public

414+--public export

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

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

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

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

399

417

400-- TODO: Prove

418-- TODO: Prove

419+public export

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

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

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

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

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

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

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

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

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

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

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

414

433

415−public

434+public export

416truncate : [static] {m : Nat} -> [static] {n : Nat} -> Bits (m+n) -> Bits n

435truncate : [static] {m : Nat} -> [static] {n : Nat} -> Bits (m+n) -> Bits n

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

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

418

437

419−public

438+public export

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

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

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

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

422

441

423−public

442+public export

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

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

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

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

426

445

427−public

446+public export

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

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

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

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

430

449

431−public

450+public export

432unsetBit : [static] {n : Nat} -> Fin n -> Bits n -> Bits n

451unsetBit : [static] {n : Nat} -> Fin n -> Bits n -> Bits n

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

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

434

453

libs/base/Data/Complex.idr+2

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

5

6module Data.Complex

7

8+%access public export

9+

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

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

9

11

10infix 6 :+

12infix 6 :+

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

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

1module Data.Erased

2

3−%access public

3+%access public export

4%default total

5

6||| The erasure monad.

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

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

1module Data.Fin

2

3%default total

4−%access public

4+%access public export

5

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

7|||

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

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

150 , SubReport subErr

151 ]

152−total

152+total export

153finFromIntegerErrors : Err -> Maybe (List ErrorReportPart)

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

155 = mkFinIntegerErr (TConst c) m

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

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

2

3import public Data.Vect

4

5−%access public

5+%access public export

6%default total

7

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

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

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

1module Data.List

2

3−%access public

3+%access public export

4

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

6|||

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

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

14 |||

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

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

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

17

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

19 uninhabited Here impossible

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

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

2

3import Data.List

4

5+%access public export

6+

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

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

6|||

8|||

7||| @ P the property to be satsified

9||| @ P the property to be satsified

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

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

5%default total

6

7||| Integers modulo 2^n

8−public

8+public export

9data Mod2 : Nat -> Type where

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

11

12+public export

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

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

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

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

14

15

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

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

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

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

17

18

18−public partial

19+public export partial

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

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

20div = modBin udiv

21div = modBin udiv

21

22

22−public partial

23+public export partial

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

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

24rem = modBin urem

25rem = modBin urem

25

26

26%assert_total

27%assert_total

27−public

28+public export

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

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

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

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

30

31

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

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

1module Data.Morphisms

2

3−%access public

3+%access public export

4

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

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

libs/base/Data/So.idr+1

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

1module Data.So

2

3%default total

4+%access public export

4

5

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

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

6|||

7|||

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

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

1module Data.String

2−%access public

2+%access public export

3

4private

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

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

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

3import public Data.Fin

4import Language.Reflection

5

6−%access public

6+%access public export

7%default total

8

9infixr 7 ::

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

198-- Zips and unzips

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

200

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

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

202+|||

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

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

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

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

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

203zipWith f [] [] = []

207zipWith f [] [] = []

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

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

205

209

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

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

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

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

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

575 Here : Elem x (x::xs)

579 Here : Elem x (x::xs)

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

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

577

581

578||| Nothing can be in an empty Vect

582||| Nothing can be in an empty Vect

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

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

580noEmptyElem Here impossible

584noEmptyElem Here impossible

581

585

586+Uninhabited (Elem x []) where

587+ uninhabited = noEmptyElem

588+

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

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

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

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

584neitherHereNorThere xneqy xninxs Here = xneqy Refl

591neitherHereNorThere xneqy xninxs Here = xneqy Refl

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

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

2

3import Data.Vect

4

5+%access public export

6+

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

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

6|||

8|||

7||| @ P the property to be satsified

9||| @ P the property to be satsified

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

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

7|||

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

9||| @ message The error to print

10−partial

10+partial export

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

12 (message : String) ->

13 a

libs/base/Debug/Trace.idr+1

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

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

4||| @ msg what to print

5||| @ result the final result

6+export

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

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

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

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

8

9

libs/base/Language/Reflection/Utils.idr+28−11

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

4import Language.Reflection.Elab

5import Language.Reflection.Errors

6

7+%access public export

8+

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

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

8-- Tactic construction conveniences

10-- Tactic construction conveniences

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

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

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

38getUName (NS n ns) = getUName n

40getUName (NS n ns) = getUName n

39getUName _ = Nothing

41getUName _ = Nothing

40

42

43+namespace TT

41−total

44+ total

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

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

43−unApply t = unA t []

46+ unApply t = unA t []

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

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

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

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

46− unA tm args = (tm, 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

47

66

48−total

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

50−mkApp tm [] = tm

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

52

67

53total

68total

54binderTy : Binder t -> t

69binderTy : Binder t -> t

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

145 showPrec d StrType = "StrType"

160 showPrec d StrType = "StrType"

146 showPrec d VoidType = "VoidType"

161 showPrec d VoidType = "VoidType"

147 showPrec d Forgot = "Forgot"

162 showPrec d Forgot = "Forgot"

163+ showPrec d WorldType = "WorldType"

164+ showPrec d TheWorld = "TheWorld"

148

165

149implementation Eq NativeTy where

166implementation Eq NativeTy where

150 IT8 == IT8 = True

167 IT8 == IT8 = True

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

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

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

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

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

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

318 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

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

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

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

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

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

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

libs/base/Syntax/PreorderReasoning.idr+2

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

1module Syntax.PreorderReasoning

2

3+%access public export

4+

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

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

4syntax [expr] "QED" = qed expr

6syntax [expr] "QED" = qed expr

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

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

libs/base/System.idr+1−1

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

2

3%include C "unistd.h"

4%default partial

5−%access public

5+%access public export

6

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

8||| otherwise it returns Nothing.

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

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

6

7import System

8

9+%access export

10+

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

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

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

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

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

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

libs/base/System/Info.idr+3

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

1module System.Info

2

3||| The Idris backend in use

4+export

4backend : String

5backend : String

5backend = prim__systemInfo 0

6backend = prim__systemInfo 0

6

7

7||| The operating system in use.

8||| The operating system in use.

9+export

8os : String

10os : String

9os = prim__systemInfo 1

11os = prim__systemInfo 1

10

12

11||| The triple this program was targeted for

13||| The triple this program was targeted for

14+export

12targetTriple : String

15targetTriple : String

13targetTriple = prim__systemInfo 2

16targetTriple = prim__systemInfo 2

libs/contrib/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

4import Control.Algebra.Lattice

5import Control.Algebra.VectorSpace

6

7+%access public export

8+

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

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

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

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

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

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

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

12-- and Monoid).

14-- and Monoid).

13

15

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

16interface 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

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

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

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

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

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

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

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

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

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

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

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

94

96

97+{- FIXME: Some maintenance required here.

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

99+-}

100+{-

101+

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

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

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

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

97

104

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

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

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

113

120

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

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

122+

123+-}

libs/contrib/Control/Algebra.idr+1

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

3infixl 6 <->

4infixl 7 <.>

5

6+%access public export

6

7

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

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

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

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

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

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

3import Control.Algebra

4import Data.Heap

5

6+%access public export

6

7

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

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

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

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

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

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

7import Data.Complex

8import Data.ZZ

9

10+%access public export

10

11

11Semigroup Integer where

12Semigroup Integer where

12 (<+>) = (+)

13 (<+>) = (+)

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

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

2

3import Control.Algebra

4

5+%access public export

6+

5infixl 5 <#>

7infixl 5 <#>

6infixr 2 <||>

8infixr 2 <||>

7

9

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

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

4import Data.ZZ

5

6%default total

7−%access public

7+%access public export

8

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

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

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

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

7||| @ p the predicate to wait for

8||| @ f the function to repeatedly apply

9||| @ v the starting value

10−partial

10+partial export

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

12until p f v with (p v)

13 | False = until p f (f v)

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

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

6module Control.WellFounded

7

8%default total

9−

9+%access public export

10

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

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

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

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

2

3import Data.Fin

4

5−%access public

5+%access public export

6%default total

7

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

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

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

1module Data.CoList

2

3−%access public

3+%access public export

4%default total

5

6||| Idris will know that it always can produce a new element in finite time

libs/contrib/Data/Fun.idr+1

@@ -3,6 +3,7 @@ module Data.Fun

3import public Data.Vect

4

5%default total

6+%access public export

6

7

7||| Build an n-ary function type from a Vect of Types and a result type

8||| Build an n-ary function type from a Vect of Types and a result type

8Fun : Vect n Type -> Type -> Type

9Fun : Vect n Type -> Type -> Type

libs/contrib/Data/Hash.idr+1−1

@@ -2,7 +2,7 @@ module Data.Hash

2

3import Data.Vect

4

5−%access public

5+%access public export

6%default total

7

8{- A general purpose Hashing library (not cryptographic)

libs/contrib/Data/Heap.idr+2−2

@@ -7,9 +7,9 @@ module Data.Heap

7

8

9%default total

10−%access public

10+%access export

11

12−abstract data MaxiphobicHeap : Type -> Type where

12+export data MaxiphobicHeap : Type -> Type where

13 Empty : MaxiphobicHeap a

14 Node : Nat -> MaxiphobicHeap a -> a -> MaxiphobicHeap a -> MaxiphobicHeap a

15

libs/contrib/Data/Matrix.idr+1

@@ -5,6 +5,7 @@ module Data.Matrix

5import public Data.Vect

6

7%default total

8+%access public export

8

9

9||| Matrix with n rows and m columns

10||| Matrix with n rows and m columns

10Matrix : Nat -> Nat -> Type -> Type

11Matrix : Nat -> Nat -> Type -> Type

libs/contrib/Data/Matrix/Algebraic.idr+1−1

@@ -9,7 +9,7 @@ import public Control.Algebra.NumericInstances

9

10import public Data.Matrix

11

12−

12+%access public export

13%default total

14

15infixr 2 <:> -- vector inner product

libs/contrib/Data/Matrix/Numeric.idr+1

@@ -5,6 +5,7 @@ module Data.Matrix.Numeric

5import public Data.Matrix

6

7%default total

8+%access public export

8

9

9infixr 2 <:> -- vector inner product

10infixr 2 <:> -- vector inner product

10infixr 2 >< -- vector outer product

11infixr 2 >< -- vector outer product

libs/contrib/Data/Nat/DivMod.idr+1

@@ -2,6 +2,7 @@

2module Data.Nat.DivMod

3

4%default total

5+%access public export

5

6

6||| The result of euclidean division of natural numbers

7||| The result of euclidean division of natural numbers

7|||

8|||

libs/contrib/Data/Nat/DivMod/IteratedSubtraction.idr+1−1

@@ -8,7 +8,7 @@ import Data.So

8import Control.WellFounded

9

10%default total

11−%access public

11+%access public export

12

13||| A strict less-than relation on `Nat`.

14|||

libs/contrib/Data/Rel.idr+1

@@ -2,6 +2,7 @@ module Data.Rel

2

3import Data.Fun

4

5+%access public export

5

6

6||| Build an n-ary relation type from a Vect of Types

7||| Build an n-ary relation type from a Vect of Types

7Rel : Vect n Type -> Type

8Rel : Vect n Type -> Type

libs/contrib/Data/Sign.idr+2

@@ -1,5 +1,7 @@

1module Data.Sign

2

3+%access public export

4+

3||| A representation of signs for signed datatypes such as `ZZ`

5||| A representation of signs for signed datatypes such as `ZZ`

4data Sign = Plus | Zero | Minus

6data Sign = Plus | Zero | Minus

5

7

libs/contrib/Data/SortedMap.idr+7−8

@@ -192,21 +192,21 @@ treeToList = treeToList' (:: [])

192 treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1

193 treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

194

195−abstract

195+export

196data SortedMap : Type -> Type -> Type where

197 Empty : Ord k => SortedMap k v

198 M : (o : Ord k) => (n:Nat) -> Tree n k v o -> SortedMap k v

199

200−public

200+export

201empty : Ord k => SortedMap k v

202empty = Empty

203

204−public

204+export

205lookup : k -> SortedMap k v -> Maybe v

206lookup _ Empty = Nothing

207lookup k (M _ t) = treeLookup k t

208

209−public

209+export

210insert : k -> v -> SortedMap k v -> SortedMap k v

211insert k v Empty = M Z (Leaf k v)

212insert k v (M _ t) =

@@ -214,7 +214,7 @@ insert k v (M _ t) =

214 Left t' => (M _ t')

215 Right t' => (M _ t')

216

217−public

217+export

218delete : k -> SortedMap k v -> SortedMap k v

219delete _ Empty = Empty

220delete k (M Z t) =

@@ -226,16 +226,15 @@ delete k (M (S _) t) =

226 Left t' => (M _ t')

227 Right t' => (M _ t')

228

229−public

229+export

230fromList : Ord k => List (k, v) -> SortedMap k v

231fromList l = foldl (flip (uncurry insert)) empty l

232

233−public

233+export

234toList : SortedMap k v -> List (k, v)

235toList Empty = []

236toList (M _ t) = treeToList t

237

238−public

239treeMap : (a -> b) -> Tree n k a o -> Tree n k b o

238treeMap : (a -> b) -> Tree n k a o -> Tree n k b o

240treeMap f (Leaf k v) = Leaf k (f v)

239treeMap f (Leaf k v) = Leaf k (f v)

241treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)

240treeMap f (Branch2 t1 k t2) = Branch2 (treeMap f t1) k (treeMap f t2)

libs/contrib/Data/SortedSet.idr+7−7

@@ -4,30 +4,30 @@ import Data.SortedMap

4

5-- TODO: add intersection, union, difference

6

7−abstract

7+export

8data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())

9

10−public

10+export

11empty : Ord k => SortedSet k

12empty = SetWrapper Data.SortedMap.empty

13

14−public

14+export

15insert : k -> SortedSet k -> SortedSet k

16insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)

17

18−public

18+export

19delete : k -> SortedSet k -> SortedSet k

20delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)

21

22−public

22+export

23contains : k -> SortedSet k -> Bool

24contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)

25

26−public

26+export

27fromList : Ord k => List k -> SortedSet k

28fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))

29

30−public

30+export

31toList : SortedSet k -> List k

32toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)

33

libs/contrib/Data/Storable.idrnew file+41

@@ -0,0 +1,41 @@

1+module Data.Storable

2+

3+%access public export

4+

5+interface Storable a where

6+ sizeOf : a -> Int

7+ alignOf : a -> Int

8+ peek : Ptr -> Int -> IO a

9+ poke : Ptr -> Int -> a -> IO ()

10+

11+Storable Bits8 where

12+ sizeOf _ = 1

13+ alignOf _ = 1

14+ peek p offset = prim_peek8 p offset

15+ poke p offset val = do

16+ _ <- prim_poke8 p offset val

17+ return ()

18+

19+Storable Bits16 where

20+ sizeOf _ = 2

21+ alignOf _ = 2

22+ peek p offset = prim_peek16 p offset

23+ poke p offset val = do

24+ _ <- prim_poke16 p offset val

25+ return ()

26+

27+Storable Bits32 where

28+ sizeOf _ = 4

29+ alignOf _ = 4

30+ peek p offset = prim_peek32 p offset

31+ poke p offset val = do

32+ _ <- prim_poke32 p offset val

33+ return ()

34+

35+Storable Bits64 where

36+ sizeOf _ = 8

37+ alignOf _ = 8

38+ peek p offset = prim_peek64 p offset

39+ poke p offset val = do

40+ _ <- prim_poke64 p offset val

41+ return ()

libs/contrib/Data/ZZ.idr+1−1

@@ -4,7 +4,7 @@ import Decidable.Equality

4import Data.Sign

5

6%default total

7−%access public

7+%access public export

8

9

10||| An integer is either a positive `Nat` or the negated successor of a `Nat`.

libs/contrib/Decidable/Decidable.idr+1−1

@@ -3,7 +3,7 @@ module Decidable.Decidable

3import Data.Rel

4import Data.Fun

5

6−%access public

6+%access public export

7

8--------------------------------------------------------------------------------

9-- Interface for decidable n-ary Relations

libs/contrib/Decidable/Order.idr+1−1

@@ -6,7 +6,7 @@ import Data.Fin

6import Data.Fun

7import Data.Rel

8

9−%access public

9+%access public export

10

11--------------------------------------------------------------------------------

12-- Utility Lemmas

libs/contrib/Network/Cgi.idr+11−11

@@ -4,7 +4,7 @@ import System

4

5%default total

6

7−public

7+public export

8Vars : Type

9Vars = List (String, String)

10

@@ -23,7 +23,7 @@ add_Headers str st = record { Headers = Headers st ++ str } st

23add_Output : String -> CGIInfo -> CGIInfo

24add_Output str st = record { Output = Output st ++ str } st

25

26−abstract

26+export

27data CGI : Type -> Type where

28 MkCGI : (CGIInfo -> IO (a, CGIInfo)) -> CGI a

29

@@ -51,32 +51,32 @@ setInfo i = MkCGI (\s => return ((), i))

51getInfo : CGI CGIInfo

52getInfo = MkCGI (\s => return (s, s))

53

54−abstract

54+export

55lift : IO a -> CGI a

56lift op = MkCGI (\st => do { x <- op

57 return (x, st) } )

58

59−abstract

59+export

60output : String -> CGI ()

61output s = do i <- getInfo

62 setInfo (add_Output s i)

63

64−abstract

64+export

65queryVars : CGI Vars

66queryVars = do i <- getInfo

67 return (GET i)

68

69−abstract

69+export

70postVars : CGI Vars

71postVars = do i <- getInfo

72 return (POST i)

73

74−abstract

74+export

75cookieVars : CGI Vars

76cookieVars = do i <- getInfo

77 return (Cookies i)

78

79−abstract

79+export

80queryVar : String -> CGI (Maybe String)

81queryVar x = do vs <- queryVars

82 return (lookup x vs)

@@ -89,12 +89,12 @@ getHeaders : CGI String

89getHeaders = do i <- getInfo

90 return (Headers i)

91

92−abstract

92+export

93flushHeaders : CGI ()

94flushHeaders = do o <- getHeaders

95 lift (putStrLn o)

96

97−abstract

97+export

98flush : CGI ()

99flush = do o <- getOutput

100 lift (putStr o)

@@ -119,7 +119,7 @@ getCgiEnv key = do

119 val <- getEnv key

120 return $ maybe "" id val

121

122−abstract

122+export

123runCGI : CGI a -> IO a

124runCGI prog = do

125 clen_in <- getCgiEnv "CONTENT_LENGTH"

libs/contrib/Network/Socket.idr+7−8

@@ -8,9 +8,7 @@ module IdrisNet.Socket

8%include C "sys/socket.h"

9%include C "netdb.h"

10

11−%access public

12−

13−ByteLength : Type

11+public export ByteLength : Type

14ByteLength = Int

12ByteLength = Int

15

13

16interface ToCode a where

14interface ToCode a where

@@ -67,8 +65,9 @@ implementation ToCode SocketType where

67

65

68data RecvStructPtr = RSPtr Ptr

66data RecvStructPtr = RSPtr Ptr

69data RecvfromStructPtr = RFPtr Ptr

67data RecvfromStructPtr = RFPtr Ptr

68+

70−data BufPtr = BPtr Ptr

69+export data BufPtr = BPtr Ptr

71−data SockaddrPtr = SAPtr Ptr

70+export data SockaddrPtr = SAPtr Ptr

72

71

73||| Protocol Number.

72||| Protocol Number.

74|||

73|||

@@ -120,18 +119,18 @@ record UDPAddrInfo where

120 remote_port : Port

119 remote_port : Port

121

120

122||| Frees a given pointer

121||| Frees a given pointer

123−public

122+export

124sock_free : BufPtr -> IO ()

123sock_free : BufPtr -> IO ()

125sock_free (BPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

124sock_free (BPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

126

125

127−public

126+export

128sockaddr_free : SockaddrPtr -> IO ()

127sockaddr_free : SockaddrPtr -> IO ()

129sockaddr_free (SAPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

128sockaddr_free (SAPtr ptr) = foreign FFI_C "idrnet_free" (Ptr -> IO ()) ptr

130

129

131||| Allocates an amount of memory given by the ByteLength parameter.

130||| Allocates an amount of memory given by the ByteLength parameter.

132|||

131|||

133||| Used to allocate a mutable pointer to be given to the Recv functions.

132||| Used to allocate a mutable pointer to be given to the Recv functions.

134−public

133+export

135sock_alloc : ByteLength -> IO BufPtr

134sock_alloc : ByteLength -> IO BufPtr

136sock_alloc bl = map BPtr $ foreign FFI_C "idrnet_malloc" (Int -> IO Ptr) bl

135sock_alloc bl = map BPtr $ foreign FFI_C "idrnet_malloc" (Int -> IO Ptr) bl

137

136

libs/contrib/System/Concurrency/Process.idr+10−2

@@ -4,9 +4,9 @@ module System.Concurrency.Process

4

5import System.Concurrency.Raw

6

7−%access public

7+%access public export

8

9−abstract

9+export

10data ProcID msg = MkPID Ptr

11

12||| Type safe message passing programs. Parameterised over the type of

@@ -30,24 +30,29 @@ run : Process msg x -> IO x

30run (Lift prog) = prog

31

32||| Get current process ID

33+export

33myID : Process msg (ProcID msg)

34myID : Process msg (ProcID msg)

34myID = Lift (return (MkPID prim__vm))

35myID = Lift (return (MkPID prim__vm))

35

36

36||| Send a message to another process

37||| Send a message to another process

37||| Returns whether the send was unsuccessful.

38||| Returns whether the send was unsuccessful.

39+export

38send : ProcID msg -> msg -> Process msg Bool

40send : ProcID msg -> msg -> Process msg Bool

39send (MkPID p) m = Lift (do x <- sendToThread p (prim__vm, m)

41send (MkPID p) m = Lift (do x <- sendToThread p (prim__vm, m)

40 return (x == 1))

42 return (x == 1))

41

43

42||| Return whether a message is waiting in the queue

44||| Return whether a message is waiting in the queue

45+export

43msgWaiting : Process msg Bool

46msgWaiting : Process msg Bool

44msgWaiting = Lift checkMsgs

47msgWaiting = Lift checkMsgs

45

48

46||| Return whether a message is waiting in the queue from a specific sender

49||| Return whether a message is waiting in the queue from a specific sender

50+export

47msgWaitingFrom : ProcID msg -> Process msg Bool

51msgWaitingFrom : ProcID msg -> Process msg Bool

48msgWaitingFrom (MkPID p) = Lift (checkMsgsFrom p)

52msgWaitingFrom (MkPID p) = Lift (checkMsgsFrom p)

49

53

50||| Receive a message - blocks if there is no message waiting

54||| Receive a message - blocks if there is no message waiting

55+export

51recv : Process msg msg

56recv : Process msg msg

52recv {msg} = do (senderid, m) <- Lift get

57recv {msg} = do (senderid, m) <- Lift get

53 return m

58 return m

@@ -55,6 +60,7 @@ recv {msg} = do (senderid, m) <- Lift get

55 get = getMsg

60 get = getMsg

56

61

57||| Receive a message from specific sender - blocks if there is no message waiting

62||| Receive a message from specific sender - blocks if there is no message waiting

63+export

58recvFrom : ProcID msg -> Process msg msg

64recvFrom : ProcID msg -> Process msg msg

59recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get

65recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get

60 return m

66 return m

@@ -62,6 +68,7 @@ recvFrom (MkPID p) {msg} = do (senderid, m) <- Lift get

62 get = getMsgFrom p

68 get = getMsgFrom p

63

69

64||| receive a message, and return with the sender's process ID.

70||| receive a message, and return with the sender's process ID.

71+export

65recvWithSender : Process msg (ProcID msg, msg)

72recvWithSender : Process msg (ProcID msg, msg)

66recvWithSender {msg}

73recvWithSender {msg}

67 = do (senderid, m) <- Lift get

74 = do (senderid, m) <- Lift get

@@ -69,6 +76,7 @@ recvWithSender {msg}

69 where get : IO (Ptr, msg)

76 where get : IO (Ptr, msg)

70 get = getMsg

77 get = getMsg

71

78

79+export

72create : Process msg () -> Process msg (ProcID msg)

80create : Process msg () -> Process msg (ProcID msg)

73create (Lift p) = do ptr <- Lift (fork p)

81create (Lift p) = do ptr <- Lift (fork p)

74 return (MkPID ptr)

82 return (MkPID ptr)

libs/contrib/contrib.ipkg+6−2

@@ -1,13 +1,17 @@

1package contrib

2

3opts = "--nobasepkgs --total -i ../prelude -i ../base"

4+modules = CFFI, CFFI.Types, CFFI.Memory,

5+

4−modules = Control.Algebra,

6+ Control.Algebra,

5 Control.Algebra.Lattice, Control.Algebra.VectorSpace,

7 Control.Algebra.Lattice, Control.Algebra.VectorSpace,

6 Control.Algebra.NumericInstances,

8 Control.Algebra.NumericInstances,

7 Control.Isomorphism.Primitives,

9 Control.Isomorphism.Primitives,

8 Control.Partial,

10 Control.Partial,

9 Control.WellFounded,

11 Control.WellFounded,

12+

10 Classes.Verified,

13 Classes.Verified,

14+

11 Data.Fun, Data.Rel,

15 Data.Fun, Data.Rel,

12 Data.Hash,

16 Data.Hash,

13 Data.Matrix, Data.Matrix.Algebraic, Data.Matrix.Numeric,

17 Data.Matrix, Data.Matrix.Algebraic, Data.Matrix.Numeric,

@@ -16,7 +20,7 @@ modules = Control.Algebra,

16 Data.BoundedList,

20 Data.BoundedList,

17 Data.Heap,

21 Data.Heap,

18 Data.SortedMap, Data.SortedSet,

22 Data.SortedMap, Data.SortedSet,

19− Data.CoList,

23+ Data.CoList, Data.Storable,

20

24

21 Decidable.Decidable, Decidable.Order,

25 Decidable.Decidable, Decidable.Order,

22

26

libs/effects/Effect/Default.idr+2

@@ -2,6 +2,8 @@ module Effect.Default

2

3import Data.Vect

4

5+%access public export

6+

5interface Default a where

7interface Default a where

6 default : a

8 default : a

7

9

libs/effects/Effect/Exception.idr+2

@@ -4,6 +4,8 @@ import Effects

4import System

5import Control.IOExcept

6

7+%access public export

8+

7data Exception : Type -> Effect where

9data Exception : Type -> Effect where

8 Raise : a -> sig (Exception a) b

10 Raise : a -> sig (Exception a) b

9

11

libs/effects/Effect/File.idr+5−4

@@ -4,6 +4,7 @@ module Effect.File

4import Effects

5import Control.IOExcept

6

7+%access public export

7

8

8||| A Dependent type to describe File Handles. File handles are

9||| A Dependent type to describe File Handles. File handles are

9||| parameterised with the current state of the file: Closed; Open for

10||| parameterised with the current state of the file: Closed; Open for

@@ -63,7 +64,7 @@ data FileIO : Effect where

63 ||| Write a string to a file.

64 ||| Write a string to a file.

64 |||

65 |||

65 ||| Only file that are open for writing can be written to.

66 ||| Only file that are open for writing can be written to.

66− WriteString : String -> sig FileIO () (OpenFile Write)

67+ WriteString : String -> sig FileIO () (OpenFile WriteTruncate)

67

68

68 ||| End of file?

69 ||| End of file?

69 |||

70 |||

@@ -137,11 +138,11 @@ readLine : Eff String [FILE_IO (OpenFile Read)]

137readLine = call $ ReadLine

138readLine = call $ ReadLine

138

139

139||| Write a string to a file.

140||| Write a string to a file.

140−writeString : String -> Eff () [FILE_IO (OpenFile Write)]

141+writeString : String -> Eff () [FILE_IO (OpenFile WriteTruncate)]

141writeString str = call $ WriteString str

142writeString str = call $ WriteString str

142

143

143||| Write a line to a file.

144||| Write a line to a file.

144−writeLine : String -> Eff () [FILE_IO (OpenFile Write)]

145+writeLine : String -> Eff () [FILE_IO (OpenFile WriteTruncate)]

145writeLine str = call $ WriteString (str ++ "\n")

146writeLine str = call $ WriteString (str ++ "\n")

146

147

147||| End of file?

148||| End of file?

@@ -175,7 +176,7 @@ writeFile : (errFunc : String -> e)

175 -> (content : String)

176 -> (content : String)

176 -> Eff (Either e ()) [FILE_IO ()]

177 -> Eff (Either e ()) [FILE_IO ()]

177writeFile errFunc fname content = do

178writeFile errFunc fname content = do

178− case !(open fname Write) of

179+ case !(open fname WriteTruncate) of

179 True => do

180 True => do

180 writeString content

181 writeString content

181 close

182 close

libs/effects/Effect/Logging/Category.idr+2−2

@@ -14,7 +14,7 @@ module Effect.Logging.Category

14import Effects

15import public Effect.Logging.Level

16

17−%access public

17+%access public export

18

19-- -------------------------------------------------------- [ Logging Resource ]

20

@@ -147,7 +147,7 @@ logN : (Show a, Eq a) => (l : Nat)

147 -> (cs : List a)

148 -> (m : String)

149 -> Eff () [LOG a]

150−logN l cs msg = call $ Log (getProof lvl) cs msg

150+logN l cs msg = call $ Log (snd lvl) cs msg

151 where

152 lvl : (n ** LogLevel n)

153 lvl = case cast {to=String} (cast {to=Int} l) of

libs/effects/Effect/Logging/Default.idr+2−2

@@ -15,7 +15,7 @@ module Effect.Logging.Default

15import Effects

16import public Effect.Logging.Level

17

18−%access public

18+%access public export

19

20-- ------------------------------------------------------------ [ The Resource ]

21

@@ -84,7 +84,7 @@ log l msg = call $ Log l msg

84||| @l The level to log.

85||| @m The message to log.

86logN : (l : Nat) -> {auto prf : LTE l 70} -> (m : String) -> Eff () [LOG]

87−logN l msg = call $ Log (getProof lvl) msg

87+logN l msg = call $ Log (snd lvl) msg

88 where

89 lvl : (n ** LogLevel n)

90 lvl = case cast {to=String} (cast {to=Int} l) of

libs/effects/Effect/Logging/Level.idr+1−1

@@ -14,7 +14,7 @@

14||| loggers.

15module Effect.Logging.Level

16

17−%access public

17+%access public export

18%default total

19

20-- ---------------------------------------------------- [ Log Level Definition ]

libs/effects/Effect/Memory.idr+9−3

@@ -5,13 +5,13 @@ import Control.IOExcept

5import Data.Vect

6import public Data.So

7

8−%access public

8+%access public export

9

10−abstract

10+export

11data MemoryChunk : Nat -> Nat -> Type where

12 CH : Ptr -> MemoryChunk size initialized

13

14−abstract

14+export

15data RawMemory : Effect where

16 Allocate : (n : Nat) ->

17 RawMemory () () (\v => MemoryChunk n 0)

@@ -102,10 +102,12 @@ implementation Handler RawMemory (IOExcept String) where

102RAW_MEMORY : Type -> EFFECT

103RAW_MEMORY t = MkEff t RawMemory

104

105+export

105allocate : (n : Nat) ->

106allocate : (n : Nat) ->

106 Eff () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

107 Eff () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

107allocate size = call $ Allocate size

108allocate size = call $ Allocate size

108

109

110+export

109initialize : {i : Nat} ->

111initialize : {i : Nat} ->

110 {n : Nat} ->

112 {n : Nat} ->

111 Bits8 ->

113 Bits8 ->

@@ -115,9 +117,11 @@ initialize : {i : Nat} ->

115 (\v => [RAW_MEMORY (MemoryChunk n (i + size))])

117 (\v => [RAW_MEMORY (MemoryChunk n (i + size))])

116initialize c size prf = call $ Initialize c size prf

118initialize c size prf = call $ Initialize c size prf

117

119

120+export

118free : Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

121free : Eff () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

119free = call Free

122free = call Free

120

123

124+export

121peek : {i : Nat} ->

125peek : {i : Nat} ->

122 (offset : Nat) ->

126 (offset : Nat) ->

123 (size : Nat) ->

127 (size : Nat) ->

@@ -125,6 +129,7 @@ peek : {i : Nat} ->

125 { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8)

129 { [RAW_MEMORY (MemoryChunk n i)] } Eff (Vect size Bits8)

126peek offset size prf = call $ Peek offset size prf

130peek offset size prf = call $ Peek offset size prf

127

131

132+export

128poke : {n : Nat} ->

133poke : {n : Nat} ->

129 {i : Nat} ->

134 {i : Nat} ->

130 (offset : Nat) ->

135 (offset : Nat) ->

@@ -155,6 +160,7 @@ move' src_ptr dst_offset src_offset size dst_bounds src_bounds

155

160

156data MoveDescriptor = Dst | Src

161data MoveDescriptor = Dst | Src

157

162

163+export

158move : {dst_size : Nat} ->

164move : {dst_size : Nat} ->

159 {dst_init : Nat} ->

165 {dst_init : Nat} ->

160 {src_size : Nat} ->

166 {src_size : Nat} ->

libs/effects/Effect/Monad.idr+2

@@ -2,6 +2,8 @@ module Effect.Monad

2

3import Effects

4

5+%access public export

6+

5data MonadEffT : List EFFECT -> (Type -> Type) -> Type -> Type where

7data MonadEffT : List EFFECT -> (Type -> Type) -> Type -> Type where

6 MkMonadEffT : EffM m a xs (\v => xs) -> MonadEffT xs m a

8 MkMonadEffT : EffM m a xs (\v => xs) -> MonadEffT xs m a

7

9

libs/effects/Effect/Perf.idr+1−1

@@ -12,7 +12,7 @@ import System

12import Effects

13import Effect.Default

14

15−%access public

15+%access public export

16

17-- ---------------------------------------------------- [ Timer Data Structure ]

18

libs/effects/Effect/Random.idr+2

@@ -3,6 +3,8 @@ module Effect.Random

3import Effects

4import Data.Vect

5

6+%access public export

7+

6data Random : Effect where

8data Random : Effect where

7 GetRandom : sig Random Integer Integer

9 GetRandom : sig Random Integer Integer

8 SetSeed : Integer -> sig Random () Integer

10 SetSeed : Integer -> sig Random () Integer

libs/effects/Effect/Select.idr+2

@@ -2,6 +2,8 @@ module Effect.Select

2

3import Effects

4

5+%access public export

6+

5data Selection : Effect where

7data Selection : Effect where

6 Select : List a -> sig Selection a ()

8 Select : List a -> sig Selection a ()

7

9

libs/effects/Effect/State.idr+1−1

@@ -2,7 +2,7 @@ module Effect.State

2

3import Effects

4

5−%access public

5+%access public export

6

7data State : Effect where

8 Get : sig State a a

libs/effects/Effect/StdIO.idr+2

@@ -3,6 +3,8 @@ module Effect.StdIO

3import Effects

4import Control.IOExcept

5

6+%access public export

7+

6-------------------------------------------------------------

8-------------------------------------------------------------

7-- IO effects internals

9-- IO effects internals

8-------------------------------------------------------------

10-------------------------------------------------------------

libs/effects/Effect/System.idr+2

@@ -7,6 +7,8 @@ import Effects

7import System

8import Control.IOExcept

9

10+%access public export

11+

10data System : Effect where

12data System : Effect where

11 Args : sig System (List String)

13 Args : sig System (List String)

12 Time : sig System Integer

14 Time : sig System Integer

libs/effects/Effect/Trans.idr+1−1

@@ -2,7 +2,7 @@ module Effect.Trans

2

3import Effects

4

5−%access public

5+%access public export

6

7data Trans : (Type -> Type) -> Effect where

8 Lift : m a -> sig (Trans m) a

libs/effects/Effects.idr+116−33

@@ -7,7 +7,7 @@ import Data.Vect

7--- Effectful computations are described as algebraic data types that

8--- explain how an effect is interpreted in some underlying context.

9

10−%access public

10+%access export

11-- ----------------------------------------------------------------- [ Effects ]

12||| The Effect type describes effectful computations.

13|||

@@ -15,11 +15,13 @@ import Data.Vect

15||| + The return type of the computation.

16||| + The input resource.

17||| + The computation to run on the resource given the return value.

18+public export

18Effect : Type

19Effect : Type

19Effect = (x : Type) -> Type -> (x -> Type) -> Type

20Effect = (x : Type) -> Type -> (x -> Type) -> Type

20

21

21||| The `EFFECT` Data type describes how to promote the Effect

22||| The `EFFECT` Data type describes how to promote the Effect

22||| description into a concrete effect.

23||| description into a concrete effect.

24+public export

23%error_reverse

25%error_reverse

24data EFFECT : Type where

26data EFFECT : Type where

25 MkEff : Type -> Effect -> EFFECT

27 MkEff : Type -> Effect -> EFFECT

@@ -30,24 +32,29 @@ data EFFECT : Type where

30-- or a dependent change. These are easily disambiguated by type.

32-- or a dependent change. These are easily disambiguated by type.

31

33

32namespace NoResourceEffect

34namespace NoResourceEffect

35+ public export

33 sig : Effect -> Type -> Type

36 sig : Effect -> Type -> Type

34 sig e r = e r () (\v => ())

37 sig e r = e r () (\v => ())

35

38

36namespace NoUpdateEffect

39namespace NoUpdateEffect

40+ public export

37 sig : Effect -> (ret : Type) -> (resource : Type) -> Type

41 sig : Effect -> (ret : Type) -> (resource : Type) -> Type

38 sig e r e_in = e r e_in (\v => e_in)

42 sig e r e_in = e r e_in (\v => e_in)

39

43

40namespace UpdateEffect

44namespace UpdateEffect

45+ public export

41 sig : Effect -> (ret : Type) -> (res_in : Type) -> (res_out : Type) -> Type

46 sig : Effect -> (ret : Type) -> (res_in : Type) -> (res_out : Type) -> Type

42 sig e r e_in e_out = e r e_in (\v => e_out)

47 sig e r e_in e_out = e r e_in (\v => e_out)

43

48

44namespace DepUpdateEffect

49namespace DepUpdateEffect

50+ public export

45 sig : Effect ->

51 sig : Effect ->

46 (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type

52 (ret : Type) -> (res_in : Type) -> (res_out : ret -> Type) -> Type

47 sig e r e_in e_out = e r e_in e_out

53 sig e r e_in e_out = e r e_in e_out

48

54

49||| Handler interfaces describe how an effect `e` is translated to the

55||| Handler interfaces describe how an effect `e` is translated to the

50||| underlying computation context `m` for execution.

56||| underlying computation context `m` for execution.

57+public export

51interface Handler (e : Effect) (m : Type -> Type) where

58interface Handler (e : Effect) (m : Type -> Type) where

52 ||| How to handle the effect.

59 ||| How to handle the effect.

53 |||

60 |||

@@ -77,53 +84,119 @@ syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff]

77syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)

84syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)

78

85

79-- --------------------------------------- [ Properties and Proof Construction ]

86-- --------------------------------------- [ Properties and Proof Construction ]

87+

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

80data SubList : List a -> List a -> Type where

94data SubList : List a -> List a -> Type where

81− SubNil : SubList [] []

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

82− Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

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

83− Drop : SubList xs ys -> SubList xs (x :: ys)

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)

84

132

85%hint

133%hint

86−subListId : SubList xs xs

134+public export total

87−subListId {xs = Nil} = SubNil

135+dropSuffix : SubList xs ys -> SubList xs (ys ++ zs)

88−subListId {xs = x :: xs} = Keep subListId

136+dropSuffix SubNil = SubNil

137+dropSuffix (InList el sub) = InList (inPrefix el sub) (dropSuffix sub)

89

138

90namespace Env

139namespace Env

140+ public export

91 data Env : (m : Type -> Type) -> List EFFECT -> Type where

141 data Env : (m : Type -> Type) -> List EFFECT -> Type where

92− Nil : Env m Nil

142+ Nil : Env m Nil

93− (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

143+ (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

94−

144+

145+namespace EffElem

146+ public export

95−data EffElem : Effect -> Type ->

147+ data EffElem : Effect -> Type ->

96− List EFFECT -> Type where

148+ List EFFECT -> Type where

97− Here : EffElem x a (MkEff a x :: xs)

149+ Here : EffElem x a (MkEff a x :: xs)

98− There : EffElem x a xs -> EffElem x a (y :: 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

99

155

100||| make an environment corresponding to a sub-list

156||| 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

102dropEnv [] SubNil = []

158dropEnv [] SubNil = []

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

103−dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

163+ in x :: dropEnv e rest

104−dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

164+

105−

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

106−updateWith : (ys' : List a) -> (xs : List a) ->

173+total updateWith : (ys' : List EFFECT) -> (xs : List EFFECT) ->

107− SubList ys xs -> List a

174+ SubList ys xs -> List EFFECT

175+updateWith [] xs sl = xs

176+updateWith (y :: ys) xs SubNil = xs

108−updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

177+updateWith ((MkEff a f) :: ys) xs (InList idx rest) = updateAt idx a (updateWith ys xs rest)

109−updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest

178+

110−updateWith [] [] SubNil = []

179+public export

111−updateWith (y :: ys) [] SubNil = y :: ys

180+total replaceEnvAt : (x : a) -> (idx : SubElem x' xs) -> Env m ys ->

112−updateWith [] (x :: xs) (Keep rest) = []

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

113

186

114||| Put things back, replacing old with new in the sub-environment

187||| Put things back, replacing old with new in the sub-environment

188+public export

115−rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->

189+total rebuildEnv : {ys':List EFFECT} -> Env m ys' -> (prf : SubList ys xs) ->

116 Env m xs -> Env m (updateWith ys' xs prf)

190 Env m xs -> Env m (updateWith ys' xs prf)

117−rebuildEnv [] SubNil env = env

191+rebuildEnv [] SubNil env = env

118−rebuildEnv (x :: xs) SubNil env = x :: xs

192+rebuildEnv (x :: xs) SubNil env = env

119−rebuildEnv [] (Keep rest) (y :: env) = []

193+rebuildEnv [] (InList w s) env = env

120−rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

194+rebuildEnv (x :: xs) (InList idx rest) env = replaceEnvAt x idx (rebuildEnv xs rest env)

121−rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

122−

123

195

124-- -------------------------------------------------- [ The Effect EDSL itself ]

196-- -------------------------------------------------- [ The Effect EDSL itself ]

125

197

198+public export

126−updateResTy : (val : t) ->

199+total updateResTy : (val : t) ->

127 (xs : List EFFECT) -> EffElem e a xs -> e t a b ->

200 (xs : List EFFECT) -> EffElem e a xs -> e t a b ->

128 List EFFECT

201 List EFFECT

129updateResTy {b} val (MkEff a e :: xs) Here n = (MkEff (b val) e) :: xs

202updateResTy {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

131

204

132infix 5 :::, :-, :=

205infix 5 :::, :-, :=

133

206

207+public export

134data LRes : lbl -> Type -> Type where

208data LRes : lbl -> Type -> Type where

135 (:=) : (x : lbl) -> res -> LRes x res

209 (:=) : (x : lbl) -> res -> LRes x res

136

210

211+public export

137(:::) : lbl -> EFFECT -> EFFECT

212(:::) : lbl -> EFFECT -> EFFECT

138(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e

213(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e

139

214

@@ -156,6 +231,7 @@ relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

156||| @ x The return type of the result.

231||| @ x The return type of the result.

157||| @ es The list of allowed side-effects.

232||| @ es The list of allowed side-effects.

158||| @ ce Function to compute a new list of allowed side-effects.

233||| @ ce Function to compute a new list of allowed side-effects.

234+public export

159data EffM : (m : Type -> Type) -> (x : Type)

235data EffM : (m : Type -> Type) -> (x : Type)

160 -> (es : List EFFECT)

236 -> (es : List EFFECT)

161 -> (ce : x -> List EFFECT) -> Type where

237 -> (ce : x -> List EFFECT) -> Type where

@@ -182,27 +258,33 @@ data EffM : (m : Type -> Type) -> (x : Type)

182

258

183namespace SimpleEff

259namespace SimpleEff

184 -- Simple effects, no updates

260 -- Simple effects, no updates

261+ public export

185 Eff : (x : Type) -> (es : List EFFECT) -> Type

262 Eff : (x : Type) -> (es : List EFFECT) -> Type

186 Eff x es = {m : Type -> Type} -> EffM m x es (\v => es)

263 Eff x es = {m : Type -> Type} -> EffM m x es (\v => es)

187

264

265+ public export

188 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> Type

266 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT) -> Type

189 EffT m x es = EffM m x es (\v => es)

267 EffT m x es = EffM m x es (\v => es)

190

268

191namespace TransEff

269namespace TransEff

192 -- Dependent effects, updates not dependent on result

270 -- Dependent effects, updates not dependent on result

271+ public export

193 Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

272 Eff : (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

194 Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce)

273 Eff x es ce = {m : Type -> Type} -> EffM m x es (\_ => ce)

195

274

275+ public export

196 EffT : (m : Type -> Type) ->

276 EffT : (m : Type -> Type) ->

197 (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

277 (x : Type) -> (es : List EFFECT) -> (ce : List EFFECT) -> Type

198 EffT m x es ce = EffM m x es (\_ => ce)

278 EffT m x es ce = EffM m x es (\_ => ce)

199

279

200namespace DepEff

280namespace DepEff

201 -- Dependent effects, updates dependent on result

281 -- Dependent effects, updates dependent on result

282+ public export

202 Eff : (x : Type) -> (es : List EFFECT)

283 Eff : (x : Type) -> (es : List EFFECT)

203 -> (ce : x -> List EFFECT) -> Type

284 -> (ce : x -> List EFFECT) -> Type

204 Eff x es ce = {m : Type -> Type} -> EffM m x es ce

285 Eff x es ce = {m : Type -> Type} -> EffM m x es ce

205

286

287+ public export

206 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT)

288 EffT : (m : Type -> Type) -> (x : Type) -> (es : List EFFECT)

207 -> (ce : x -> List EFFECT) -> Type

289 -> (ce : x -> List EFFECT) -> Type

208 EffT m x es ce = EffM m x es ce

290 EffT m x es ce = EffM m x es ce

@@ -271,6 +353,7 @@ execEff (val :: env) (There p) eff k

271-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

353-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

272-- updates can be propagated even through failing computations?

354-- updates can be propagated even through failing computations?

273

355

356+export

274eff : Env m xs -> EffM m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

357eff : Env m xs -> EffM m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

275eff env (Value x) k = k x env

358eff env (Value x) k = k x env

276eff env (prog `EBind` c) k

359eff env (prog `EBind` c) k

libs/prelude/Builtins.idr+48−19

@@ -1,6 +1,6 @@

1%unqualified

2

3−%access public

3+%access public export

4%default total

5

6||| The canonical single-element type, also known as the trivially

@@ -37,23 +37,31 @@ namespace Builtins

37 %used MkUPair a

38 %used MkUPair b

39

40− ||| Dependent pairs

40+ ||| Dependent pairs aid in the construction of dependent types by

41+ ||| providing evidence that some value resides in the type.

41 |||

42 |||

43+ ||| Formally, speaking, dependent pairs represent existential

42− ||| Dependent pairs represent existential quantification - they consist of a

44+ ||| quantification - they consist of a witness for the existential

43− ||| witness for the existential claim and a proof that the property holds for

45+ ||| claim and a proof that the property holds for it.

44− ||| it. Another way to see dependent pairs is as just data - for instance, the

45− ||| length of a vector paired with that vector.

46 |||

47− ||| @ a the type of the witness

47+ ||| @a the value to place in the type.

48− ||| @ P the type of the proof

48+ ||| @P the dependent type that requires the value.

49− data Sigma : (a : Type) -> (P : a -> Type) -> Type where

49+ data DPair : (a : Type) -> (P : a -> Type) -> Type where

50− MkSigma : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P

50+ MkDPair : .{P : a -> Type} -> (x : a) -> (pf : P x) -> DPair a P

51+

52+ Sigma : (a : Type) -> (P : a -> Type) -> Type

53+ Sigma wit prf = DPair wit prf

54+ %deprecate Sigma "This name is being deprecated in favour of `DPair`."

55+

56+ MkSigma : .{P : a -> Type} -> (x : a) -> (prf : P x) -> DPair a P

57+ MkSigma wit prf = MkDPair wit prf

58+ %deprecate MkSigma "This constructor is being deprecated in favour of `MkDPair`."

51

59

52||| The empty type, also known as the trivially false proposition.

60||| The empty type, also known as the trivially false proposition.

53|||

61|||

54−||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope.

62+||| Use `void` or `absurd` to prove anything if you have a variable of type `Void` in scope.

55−%elim data Void : Type where

63+%elim data Void : Type where

56−

64+

57||| The eliminator for the `Void` type.

65||| The eliminator for the `Void` type.

58void : Void -> a

66void : Void -> a

59-- We can't define void yet. We can't define a function with no clauses without

67-- We can't define void yet. We can't define a function with no clauses without

@@ -85,7 +93,7 @@ replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y

85replace Refl prf = prf

93replace Refl prf = prf

86

94

87||| Symmetry of propositional equality

95||| Symmetry of propositional equality

88−sym : {l:a} -> {r:a} -> l = r -> r = l

96+sym : {left:a} -> {right:a} -> left = right -> right = left

89sym Refl = Refl

97sym Refl = Refl

90

98

91||| Transitivity of propositional equality

99||| Transitivity of propositional equality

@@ -155,13 +163,13 @@ assert_total x = x

155

163

156||| Subvert the type checker. This function is abstract, so it will not reduce in

164||| Subvert the type checker. This function is abstract, so it will not reduce in

157||| the type checker. Use it with care - it can result in segfaults or worse!

165||| the type checker. Use it with care - it can result in segfaults or worse!

158−abstract %assert_total -- need to pretend

166+export %assert_total -- need to pretend

159believe_me : a -> b

167believe_me : a -> b

160believe_me x = prim__believe_me _ _ x

168believe_me x = prim__believe_me _ _ x

161

169

162||| Subvert the type checker. This function *will* reduce in the type checker.

170||| Subvert the type checker. This function *will* reduce in the type checker.

163||| Use it with extreme care - it can result in segfaults or worse!

171||| Use it with extreme care - it can result in segfaults or worse!

164−public %assert_total

172+public export %assert_total

165really_believe_me : a -> b

173really_believe_me : a -> b

166really_believe_me x = prim__believe_me _ _ x

174really_believe_me x = prim__believe_me _ _ x

167

175

@@ -174,8 +182,9 @@ Float = Double

174-- Pointers as external primitive; there's no literals for these, so no

182-- Pointers as external primitive; there's no literals for these, so no

175-- need for them to be part of the compiler.

183-- need for them to be part of the compiler.

176

184

177−abstract data Ptr : Type

185+export data Ptr : Type

178−abstract data ManagedPtr : Type

186+export data ManagedPtr : Type

187+export data CData : Type

179

188

180%extern prim__readFile : prim__WorldType -> Ptr -> String

189%extern prim__readFile : prim__WorldType -> Ptr -> String

181%extern prim__writeFile : prim__WorldType -> Ptr -> String -> Int

190%extern prim__writeFile : prim__WorldType -> Ptr -> String -> Int

@@ -190,4 +199,24 @@ abstract data ManagedPtr : Type

190%extern prim__eqManagedPtr : ManagedPtr -> ManagedPtr -> Int

199%extern prim__eqManagedPtr : ManagedPtr -> ManagedPtr -> Int

191%extern prim__registerPtr : Ptr -> Int -> ManagedPtr

200%extern prim__registerPtr : Ptr -> Int -> ManagedPtr

192

201

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

3import Builtins

4import Prelude.Basics

5import Prelude.Bool

6−import Prelude.Classes

6+import Prelude.Interfaces

7import Prelude.Either

8import Prelude.List

9import Prelude.Nat

10import Prelude.Maybe

11

12+%access public export

13+

12--------------------------------------------------------------------------------

14--------------------------------------------------------------------------------

13-- Utility lemmas

15-- Utility lemmas

14--------------------------------------------------------------------------------

16--------------------------------------------------------------------------------

@@ -141,7 +143,7 @@ implementation DecEq a => DecEq (List a) where

141 decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil)

143 decEq [] (x :: xs) = No (negEqSym lemma_val_not_nil)

142 decEq (x :: xs) (y :: ys) with (decEq x y)

144 decEq (x :: xs) (y :: ys) with (decEq x y)

143 decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys)

145 decEq (x :: xs) (x :: ys) | Yes Refl with (decEq xs ys)

144− decEq (x :: xs) (x :: xs) | (Yes Refl) | (Yes Refl) = Yes Refl

146+ decEq (x :: xs) (x :: xs) | (Yes Refl) | (Yes Refl) = Yes Refl

145 decEq (x :: xs) (x :: ys) | (Yes Refl) | (No p) = No (\eq => lemma_x_eq_xs_neq Refl p eq)

147 decEq (x :: xs) (x :: ys) | (Yes Refl) | (No p) = No (\eq => lemma_x_eq_xs_neq Refl p eq)

146 decEq (x :: xs) (y :: ys) | No p with (decEq xs ys)

148 decEq (x :: xs) (y :: ys) | No p with (decEq xs ys)

147 decEq (x :: xs) (y :: xs) | (No p) | (Yes Refl) = No (\eq => lemma_x_neq_xs_eq p Refl eq)

149 decEq (x :: xs) (y :: xs) | (No p) | (Yes Refl) = No (\eq => lemma_x_neq_xs_eq p Refl eq)

@@ -211,6 +213,3 @@ implementation DecEq ManagedPtr where

211 where primitiveEq : x = y

213 where primitiveEq : x = y

212 primitiveEq = believe_me (Refl {x})

214 primitiveEq = believe_me (Refl {x})

213 postulate primitiveNotEq : x = y -> Void

215 postulate primitiveNotEq : x = y -> Void

214−

215−

216−

libs/prelude/IO.idr+109−30

@@ -3,25 +3,24 @@

3import Builtins

4import Prelude.List

5

6−%access public

6+%access export

7

8||| Idris's primitive IO, for building abstractions on top of

9−abstract

10data PrimIO : Type -> Type where

9data PrimIO : Type -> Type where

11 Prim__IO : a -> PrimIO a

10 Prim__IO : a -> PrimIO a

12

11

13||| A token representing the world, for use in `IO`

12||| A token representing the world, for use in `IO`

14−abstract data World = TheWorld prim__WorldType

13+data World = TheWorld prim__WorldType

15

14

16−private

17world : World -> prim__WorldType

15world : World -> prim__WorldType

18world (TheWorld w) = w

16world (TheWorld w) = w

19

17

20−abstract WorldRes : Type -> Type

18+WorldRes : Type -> Type

21WorldRes x = x

19WorldRes x = x

22

20

23||| An FFI specifier, which describes how a particular compiler

21||| An FFI specifier, which describes how a particular compiler

24||| backend handles foreign function calls.

22||| backend handles foreign function calls.

23+public export

25record FFI where

24record FFI where

26 constructor MkFFI

25 constructor MkFFI

27 ||| A family describing which types are available in the FFI

26 ||| A family describing which types are available in the FFI

@@ -35,10 +34,10 @@ record FFI where

35

34

36||| The IO type, parameterised over the FFI that is available within

35||| The IO type, parameterised over the FFI that is available within

37||| it.

36||| it.

38−abstract

39data IO' : (lang : FFI) -> Type -> Type where

37data IO' : (lang : FFI) -> Type -> Type where

40 MkIO : (World -> PrimIO (WorldRes a)) -> IO' lang a

38 MkIO : (World -> PrimIO (WorldRes a)) -> IO' lang a

41

39

40+public export

42data FTy : FFI -> List Type -> Type -> Type where

41data FTy : FFI -> List Type -> Type -> Type where

43 FRet : ffi_types f t -> FTy f xs (IO' f t)

42 FRet : ffi_types f t -> FTy f xs (IO' f t)

44 FFun : ffi_types f s -> FTy f (s :: xs) t -> FTy f xs (s -> t)

43 FFun : ffi_types f s -> FTy f (s :: xs) t -> FTy f xs (s -> t)

@@ -47,15 +46,16 @@ namespace ForeignEnv

47 data FEnv : FFI -> List Type -> Type where

46 data FEnv : FFI -> List Type -> Type where

48 Nil : FEnv f []

47 Nil : FEnv f []

49 (::) : (ffi_types f t, t) -> FEnv f xs -> FEnv f (t :: xs)

48 (::) : (ffi_types f t, t) -> FEnv f xs -> FEnv f (t :: xs)

50−

49+

51ForeignPrimType : (xs : List Type) -> FEnv ffi xs -> Type -> Type

50ForeignPrimType : (xs : List Type) -> FEnv ffi xs -> Type -> Type

52ForeignPrimType {ffi} [] [] t = World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t

51ForeignPrimType {ffi} [] [] t = World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t

53−ForeignPrimType {ffi} (x :: xs) ((a, _) :: env) t

52+ForeignPrimType {ffi} (x :: xs) ((a, _) :: env) t

54 = (ffi_types ffi x, x) -> ForeignPrimType xs env t

53 = (ffi_types ffi x, x) -> ForeignPrimType xs env t

55

54

56%inline

55%inline

56+private

57−applyEnv : (env : FEnv ffi xs) ->

57+applyEnv : (env : FEnv ffi xs) ->

58− ForeignPrimType xs env t ->

58+ ForeignPrimType xs env t ->

59 World -> ffi_fn ffi -> ffi_types ffi t -> PrimIO t

60applyEnv [] f = f

61applyEnv (x@(_, _) :: xs) f = applyEnv xs (f x)

@@ -66,7 +66,8 @@ mkForeignPrim : {xs : _} -> {ffi : _} -> {env : FEnv ffi xs} -> {t : Type} ->

66-- explicit here.

67

68%inline

69+private

69−foreign_prim : (f : FFI) ->

70+foreign_prim : (f : FFI) ->

70 (fname : ffi_fn f) -> FTy f xs ty -> FEnv f xs -> ty

71 (fname : ffi_fn f) -> FTy f xs ty -> FEnv f xs -> ty

71foreign_prim f fname (FRet y) env

72foreign_prim f fname (FRet y) env

72 = MkIO (\w => applyEnv env mkForeignPrim w fname y)

73 = MkIO (\w => applyEnv env mkForeignPrim w fname y)

@@ -91,25 +92,21 @@ foreign : (f : FFI) -> (fname : ffi_fn f) -> (ty : Type) ->

91 {auto fty : FTy f [] ty} -> ty

92 {auto fty : FTy f [] ty} -> ty

92foreign ffi fname ty {fty} = foreign_prim ffi fname fty []

93foreign ffi fname ty {fty} = foreign_prim ffi fname fty []

93

94

94−abstract

95prim_io_bind : PrimIO a -> (a -> PrimIO b) -> PrimIO b

96prim_io_bind (Prim__IO v) k = k v

97

98unsafePerformPrimIO : PrimIO a -> a

99-- compiled as primitive

100

101−abstract

102prim_io_return : a -> PrimIO a

101prim_io_return : a -> PrimIO a

103prim_io_return x = Prim__IO x

102prim_io_return x = Prim__IO x

104

103

105−abstract

106io_bind : IO' l a -> (a -> IO' l b) -> IO' l b

104io_bind : IO' l a -> (a -> IO' l b) -> IO' l b

107io_bind (MkIO fn) k

105io_bind (MkIO fn) k

108 = MkIO (\w => prim_io_bind (fn w)

106 = MkIO (\w => prim_io_bind (fn w)

109 (\ b => case k b of

107 (\ b => case k b of

110 MkIO fkb => fkb w))

108 MkIO fkb => fkb w))

111

109

112−abstract

113io_return : a -> IO' l a

110io_return : a -> IO' l a

114io_return x = MkIO (\w => prim_io_return x)

111io_return x = MkIO (\w => prim_io_return x)

115

112

@@ -131,27 +128,32 @@ prim_read : IO' l String

131prim_read = MkIO (\w => prim_io_return (prim__readString (world w)))

128prim_read = MkIO (\w => prim_io_return (prim__readString (world w)))

132

129

133prim_write : String -> IO' l Int

130prim_write : String -> IO' l Int

134−prim_write s

131+prim_write s

135 = MkIO (\w => prim_io_return (prim__writeString (world w) s))

132 = MkIO (\w => prim_io_return (prim__writeString (world w) s))

136

133

137prim_fread : Ptr -> IO' l String

134prim_fread : Ptr -> IO' l String

138prim_fread h = MkIO (\w => prim_io_return (prim__readFile (world w) h))

135prim_fread h = MkIO (\w => prim_io_return (prim__readFile (world w) h))

139

136

140prim_fwrite : Ptr -> String -> IO' l Int

137prim_fwrite : Ptr -> String -> IO' l Int

141−prim_fwrite h s

138+prim_fwrite h s

142 = MkIO (\w => prim_io_return (prim__writeFile (world w) h s))

139 = MkIO (\w => prim_io_return (prim__writeFile (world w) h s))

143

140

144--------- The C FFI

141--------- The C FFI

145namespace FFI_C

142namespace FFI_C

143+ public export

146 data Raw : Type -> Type where

144 data Raw : Type -> Type where

147 -- code generated can assume it's compiled just as 't'

145 -- code generated can assume it's compiled just as 't'

148 MkRaw : (x : t) -> Raw t

146 MkRaw : (x : t) -> Raw t

149

147

150− -- Tell erasure analysis not to erase the argument

148+ public export

151− %used MkRaw x

149+ data CFnPtr : Type -> Type where

150+ MkCFnPtr : (x : t) -> CFnPtr t

151+

152

153+ mutual

153− ||| Supported C integer types

154+ ||| Supported C integer types

155+ public export

154− data C_IntTypes : Type -> Type where

156+ data C_IntTypes : Type -> Type where

155 C_IntChar : C_IntTypes Char

157 C_IntChar : C_IntTypes Char

156 C_IntNative : C_IntTypes Int

158 C_IntNative : C_IntTypes Int

157 C_IntBits8 : C_IntTypes Bits8

159 C_IntBits8 : C_IntTypes Bits8

@@ -159,28 +161,44 @@ namespace FFI_C

159 C_IntBits32 : C_IntTypes Bits32

161 C_IntBits32 : C_IntTypes Bits32

160 C_IntBits64 : C_IntTypes Bits64

162 C_IntBits64 : C_IntTypes Bits64

161

163

164+ public export

165+ data C_FnTypes : Type -> Type where

166+ C_Fn : C_Types s -> C_FnTypes t -> C_FnTypes (s -> t)

167+ C_FnIO : C_Types t -> C_FnTypes (IO' FFI_C t)

168+ C_FnBase : C_Types t -> C_FnTypes t

169+

162− ||| Supported C foreign types

170+ ||| Supported C foreign types

171+ public export

163− data C_Types : Type -> Type where

172+ data C_Types : Type -> Type where

164 C_Str : C_Types String

173 C_Str : C_Types String

165 C_Float : C_Types Double

174 C_Float : C_Types Double

166 C_Ptr : C_Types Ptr

175 C_Ptr : C_Types Ptr

167 C_MPtr : C_Types ManagedPtr

176 C_MPtr : C_Types ManagedPtr

168 C_Unit : C_Types ()

177 C_Unit : C_Types ()

169 C_Any : C_Types (Raw a)

178 C_Any : C_Types (Raw a)

179+ C_FnT : C_FnTypes t -> C_Types (CFnPtr t)

170 C_IntT : C_IntTypes i -> C_Types i

180 C_IntT : C_IntTypes i -> C_Types i

181+ C_CData : C_Types CData

171

182

172− ||| A descriptor for the C FFI. See the constructors of `C_Types`

183+ ||| A descriptor for the C FFI. See the constructors of `C_Types`

173− ||| and `C_IntTypes` for the concrete types that are available.

184+ ||| and `C_IntTypes` for the concrete types that are available.

174 %error_reverse

185 %error_reverse

186+ public export

175− FFI_C : FFI

187+ FFI_C : FFI

176− FFI_C = MkFFI C_Types String String

188+ FFI_C = MkFFI C_Types String String

177

189

178||| Interactive programs, describing I/O actions and returning a value.

190||| 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

180%error_reverse

192%error_reverse

193+public export

194+

181IO : (res : Type) -> Type

195IO : (res : Type) -> Type

182IO = IO' FFI_C

196IO = IO' FFI_C

183

197

198+ -- Tell erasure analysis not to erase the argument

199+%used MkRaw x

200+%used MkCFnPtr x

201+

184-- Cannot be relaxed as is used by type providers and they expect IO a

202-- Cannot be relaxed as is used by type providers and they expect IO a

185-- in the first argument.

203-- in the first argument.

186run__provider : IO a -> PrimIO a

204run__provider : IO a -> PrimIO a

@@ -207,18 +225,22 @@ namespace IO

207

225

208-- Supported JS foreign types

226-- Supported JS foreign types

209mutual

227mutual

228+ public export

210 data JsFn : Type -> Type where

229 data JsFn : Type -> Type where

211 MkJsFn : (x : t) -> JsFn t

230 MkJsFn : (x : t) -> JsFn t

212

231

232+ public export

213 data JS_IntTypes : Type -> Type where

233 data JS_IntTypes : Type -> Type where

214 JS_IntChar : JS_IntTypes Char

234 JS_IntChar : JS_IntTypes Char

215 JS_IntNative : JS_IntTypes Int

235 JS_IntNative : JS_IntTypes Int

216

236

237+ public export

217 data JS_FnTypes : Type -> Type where

238 data JS_FnTypes : Type -> Type where

218 JS_Fn : JS_Types s -> JS_FnTypes t -> JS_FnTypes (s -> t)

239 JS_Fn : JS_Types s -> JS_FnTypes t -> JS_FnTypes (s -> t)

219 JS_FnIO : JS_Types t -> JS_FnTypes (IO' l t)

240 JS_FnIO : JS_Types t -> JS_FnTypes (IO' l t)

220 JS_FnBase : JS_Types t -> JS_FnTypes t

241 JS_FnBase : JS_Types t -> JS_FnTypes t

221

242

243+ public export

222 data JS_Types : Type -> Type where

244 data JS_Types : Type -> Type where

223 JS_Str : JS_Types String

245 JS_Str : JS_Types String

224 JS_Float : JS_Types Double

246 JS_Float : JS_Types Double

@@ -236,10 +258,12 @@ mutual

236||| JavaScript code snippets, into which the arguments are substituted

258||| JavaScript code snippets, into which the arguments are substituted

237||| for the placeholders `%0`, `%1`, etc.

259||| for the placeholders `%0`, `%1`, etc.

238%error_reverse

260%error_reverse

261+public export

239FFI_JS : FFI

262FFI_JS : FFI

240FFI_JS = MkFFI JS_Types String String

263FFI_JS = MkFFI JS_Types String String

241

264

242%error_reverse

265%error_reverse

266+public export

243JS_IO : Type -> Type

267JS_IO : Type -> Type

244JS_IO = IO' FFI_JS

268JS_IO = IO' FFI_JS

245

269

@@ -249,10 +273,12 @@ JS_IO = IO' FFI_JS

249namespace FFI_Export

273namespace FFI_Export

250-- It's just like Data.List.Elem, but we don't need all the other stuff

274-- It's just like Data.List.Elem, but we don't need all the other stuff

251-- that comes with it, just a proof that a data type is defined.

275-- that comes with it, just a proof that a data type is defined.

276+ public export

252 data DataDefined : Type -> List (Type, s) -> s -> Type where

277 data DataDefined : Type -> List (Type, s) -> s -> Type where

253 DHere : DataDefined x ((x, t) :: xs) t

278 DHere : DataDefined x ((x, t) :: xs) t

254 DThere : DataDefined x xs t -> DataDefined x (y :: xs) t

279 DThere : DataDefined x xs t -> DataDefined x (y :: xs) t

255

280

281+ public export

256 data FFI_Base : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

282 data FFI_Base : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

257 FFI_ExpType : {n : ffi_data f} -> (def : DataDefined t xs n) -> FFI_Base f xs t

283 FFI_ExpType : {n : ffi_data f} -> (def : DataDefined t xs n) -> FFI_Base f xs t

258 FFI_Prim : (prim : ffi_types f t) -> FFI_Base f xs t

284 FFI_Prim : (prim : ffi_types f t) -> FFI_Base f xs t

@@ -261,6 +287,7 @@ namespace FFI_Export

261 %used FFI_ExpType def

287 %used FFI_ExpType def

262 %used FFI_Prim prim

288 %used FFI_Prim prim

263

289

290+ public export

264 data FFI_Exportable : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

291 data FFI_Exportable : (f : FFI) -> List (Type, ffi_data f) -> Type -> Type where

265 FFI_IO : (b : FFI_Base f xs t) -> FFI_Exportable f xs (IO' f t)

292 FFI_IO : (b : FFI_Base f xs t) -> FFI_Exportable f xs (IO' f t)

266 FFI_Fun : (b : FFI_Base f xs s) -> (a : FFI_Exportable f xs t) -> FFI_Exportable f xs (s -> t)

293 FFI_Fun : (b : FFI_Base f xs s) -> (a : FFI_Exportable f xs t) -> FFI_Exportable f xs (s -> t)

@@ -271,10 +298,11 @@ namespace FFI_Export

271 %used FFI_Fun a

298 %used FFI_Fun a

272 %used FFI_Ret b

299 %used FFI_Ret b

273

300

301+ public export

274 data FFI_Export : (f : FFI) -> String -> List (Type, ffi_data f) -> Type where

302 data FFI_Export : (f : FFI) -> String -> List (Type, ffi_data f) -> Type where

275− Data : (x : Type) -> (n : ffi_data f) ->

303+ Data : (x : Type) -> (n : ffi_data f) ->

276 (es : FFI_Export f h ((x, n) :: xs)) -> FFI_Export f h xs

304 (es : FFI_Export f h ((x, n) :: xs)) -> FFI_Export f h xs

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} ->

278 (es : FFI_Export f h xs) -> FFI_Export f h xs

306 (es : FFI_Export f h xs) -> FFI_Export f h xs

279 End : FFI_Export f h xs

307 End : FFI_Export f h xs

280

308

@@ -286,3 +314,54 @@ namespace FFI_Export

286%used Fun es

314%used Fun es

287%used Fun prf

315%used Fun prf

288

316

317+-- Accessing memory

318+prim_peek8 : Ptr -> Int -> IO Bits8

319+prim_peek8 ptr offset = MkIO (\w => prim_io_return (prim__peek8 (world w) ptr offset))

320+

321+prim_poke8 : Ptr -> Int -> Bits8 -> IO Int

322+prim_poke8 ptr offset val = MkIO (\w => prim_io_return (

323+ prim__poke8 (world w) ptr offset val))

324+

325+prim_peek16 : Ptr -> Int -> IO Bits16

326+prim_peek16 ptr offset = MkIO (\w => prim_io_return (prim__peek16 (world w) ptr offset))

327+

328+prim_poke16 : Ptr -> Int -> Bits16 -> IO Int

329+prim_poke16 ptr offset val = MkIO (\w => prim_io_return (

330+ prim__poke16 (world w) ptr offset val))

331+

332+prim_peek32 : Ptr -> Int -> IO Bits32

333+prim_peek32 ptr offset = MkIO (\w => prim_io_return (prim__peek32 (world w) ptr offset))

334+

335+prim_poke32 : Ptr -> Int -> Bits32 -> IO Int

336+prim_poke32 ptr offset val = MkIO (\w => prim_io_return (

337+ prim__poke32 (world w) ptr offset val))

338+

339+prim_peek64 : Ptr -> Int -> IO Bits64

340+prim_peek64 ptr offset = MkIO (\w => prim_io_return (prim__peek64 (world w) ptr offset))

341+

342+prim_poke64 : Ptr -> Int -> Bits64 -> IO Int

343+prim_poke64 ptr offset val = MkIO (\w => prim_io_return (

344+ prim__poke64 (world w) ptr offset val))

345+

346+prim_peekPtr : Ptr -> Int -> IO Ptr

347+prim_peekPtr ptr offset = MkIO (\w => prim_io_return (prim__peekPtr (world w) ptr offset))

348+

349+prim_pokePtr : Ptr -> Int -> Ptr -> IO Int

350+prim_pokePtr ptr offset val = MkIO (\w => prim_io_return (

351+ prim__pokePtr (world w) ptr offset val))

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

9import Prelude.Nat

10import Prelude.Traversable

11

12−%access public

12+%access public export

13

14||| A source location in an Idris file

15record SourceLocation where

@@ -80,7 +80,7 @@ data Const = I Int | BI Integer | Fl Double | Ch Char | Str String

80 | WorldType | TheWorld

81%name Const c, c'

82

83−abstract interface ReflConst (a : Type) where

83+export interface ReflConst (a : Type) where

84 toConst : a -> Const

85

86implementation ReflConst Int where

@@ -110,7 +110,7 @@ implementation ReflConst Bits32 where

110implementation ReflConst Bits64 where

111 toConst = B64

112

113−implicit

113+implicit export

114reflectConstant: (ReflConst a) => a -> Const

115reflectConstant = toConst

116

libs/prelude/Language/Reflection/Elab.idr+98−5

@@ -16,6 +16,8 @@ import Prelude.Monad

16import Prelude.Nat

17import Language.Reflection

18

19+%access public export

20+

19data Fixity = Infixl Nat | Infixr Nat | Infix Nat | Prefix Nat

21data Fixity = Infixl Nat | Infixr Nat | Infix Nat | Prefix Nat

20

22

21||| Erasure annotations reflect Idris's idea of what is intended to be

23||| Erasure annotations reflect Idris's idea of what is intended to be

@@ -55,11 +57,11 @@ data TyConArg =

55 ||| Indices are not uniform

57 ||| Indices are not uniform

56 TyConIndex FunArg

58 TyConIndex FunArg

57

59

58−||| A type declaration

60+||| A type declaration for a function or datatype

59record TyDecl where

61record TyDecl where

60 constructor Declare

62 constructor Declare

61

63

62− ||| The name of the function being declared.

64+ ||| The fully-qualified name of the function or datatype being declared.

63 name : TTName

65 name : TTName

64

66

65 ||| Each argument is in the scope of the names of previous arguments.

67 ||| Each argument is in the scope of the names of previous arguments.

@@ -81,6 +83,34 @@ record FunDefn a where

81 clauses : List (FunClause a)

83 clauses : List (FunClause a)

82

84

83

85

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+

84data CtorArg = CtorParameter FunArg | CtorField FunArg

114data CtorArg = CtorParameter FunArg | CtorField FunArg

85

115

86||| A reflected datatype definition

116||| A reflected datatype definition

@@ -100,7 +130,7 @@ record Datatype where

100 constructors : List (TTName, List CtorArg, Raw)

130 constructors : List (TTName, List CtorArg, Raw)

101

131

102||| A reflected elaboration script.

132||| A reflected elaboration script.

103−abstract

133+export

104data Elab : Type -> Type where

134data Elab : Type -> Type where

105 -- obligatory control stuff

135 -- obligatory control stuff

106 Prim__PureElab : a -> Elab a

136 Prim__PureElab : a -> Elab a

@@ -149,6 +179,8 @@ data Elab : Type -> Type where

149

179

150 Prim__DeclareType : TyDecl -> Elab ()

180 Prim__DeclareType : TyDecl -> Elab ()

151 Prim__DefineFunction : FunDefn Raw -> Elab ()

181 Prim__DefineFunction : FunDefn Raw -> Elab ()

182+ Prim__DeclareDatatype : TyDecl -> Elab ()

183+ Prim__DefineDatatype : DataDefn -> Elab ()

152 Prim__AddInstance : TTName -> TTName -> Elab ()

184 Prim__AddInstance : TTName -> TTName -> Elab ()

153 Prim__IsTCName : TTName -> Elab Bool

185 Prim__IsTCName : TTName -> Elab Bool

154

186

@@ -164,7 +196,7 @@ data Elab : Type -> Type where

164-------------

196-------------

165-- Public API

197-- Public API

166-------------

198-------------

167−%access public

199+%access public export

168namespace Tactics

200namespace Tactics

169 implementation Functor Elab where

201 implementation Functor Elab where

170 map f t = Prim__BindElab t (\x => Prim__PureElab (f x))

202 map f t = Prim__BindElab t (\x => Prim__PureElab (f x))

@@ -186,31 +218,38 @@ namespace Tactics

186 x >>= f = Prim__BindElab x f

218 x >>= f = Prim__BindElab x f

187

219

188 ||| Halt elaboration with an error

220 ||| Halt elaboration with an error

221+ export

189 fail : List ErrorReportPart -> Elab a

222 fail : List ErrorReportPart -> Elab a

190 fail err = Prim__Fail err

223 fail err = Prim__Fail err

191

224

192 ||| Look up the lexical binding at the focused hole. Fails if no holes are present.

225 ||| Look up the lexical binding at the focused hole. Fails if no holes are present.

226+ export

193 getEnv : Elab (List (TTName, Binder TT))

227 getEnv : Elab (List (TTName, Binder TT))

194 getEnv = Prim__Env

228 getEnv = Prim__Env

195

229

196 ||| Get the name and type of the focused hole. Fails if not holes are present.

230 ||| Get the name and type of the focused hole. Fails if not holes are present.

231+ export

197 getGoal : Elab (TTName, TT)

232 getGoal : Elab (TTName, TT)

198 getGoal = Prim__Goal

233 getGoal = Prim__Goal

199

234

200 ||| Get the hole queue, in order.

235 ||| Get the hole queue, in order.

236+ export

201 getHoles : Elab (List TTName)

237 getHoles : Elab (List TTName)

202 getHoles = Prim__Holes

238 getHoles = Prim__Holes

203

239

204 ||| If the current hole contains a guess, return it. Otherwise, fail.

240 ||| If the current hole contains a guess, return it. Otherwise, fail.

241+ export

205 getGuess : Elab TT

242 getGuess : Elab TT

206 getGuess = Prim__Guess

243 getGuess = Prim__Guess

207

244

208 ||| Look up the types of every overloading of a name.

245 ||| Look up the types of every overloading of a name.

246+ export

209 lookupTy : TTName -> Elab (List (TTName, NameType, TT))

247 lookupTy : TTName -> Elab (List (TTName, NameType, TT))

210 lookupTy n = Prim__LookupTy n

248 lookupTy n = Prim__LookupTy n

211

249

212 ||| Get the type of a fully-qualified name. Fail if it doesn not

250 ||| Get the type of a fully-qualified name. Fail if it doesn not

213 ||| resolve uniquely.

251 ||| resolve uniquely.

252+ export

214 lookupTyExact : TTName -> Elab (TTName, NameType, TT)

253 lookupTyExact : TTName -> Elab (TTName, NameType, TT)

215 lookupTyExact n = case !(lookupTy n) of

254 lookupTyExact n = case !(lookupTy n) of

216 [res] => return res

255 [res] => return res

@@ -219,12 +258,14 @@ namespace Tactics

219

258

220 ||| Find the reflected representation of all datatypes whose names

259 ||| Find the reflected representation of all datatypes whose names

221 ||| are overloadings of some name.

260 ||| are overloadings of some name.

261+ export

222 lookupDatatype : TTName -> Elab (List Datatype)

262 lookupDatatype : TTName -> Elab (List Datatype)

223 lookupDatatype n = Prim__LookupDatatype n

263 lookupDatatype n = Prim__LookupDatatype n

224

264

225 ||| Find the reflected representation of a datatype, given its

265 ||| Find the reflected representation of a datatype, given its

226 ||| fully-qualified name. Fail if the name does not uniquely resolve

266 ||| fully-qualified name. Fail if the name does not uniquely resolve

227 ||| to a datatype.

267 ||| to a datatype.

268+ export

228 lookupDatatypeExact : TTName -> Elab Datatype

269 lookupDatatypeExact : TTName -> Elab Datatype

229 lookupDatatypeExact n = case !(lookupDatatype n) of

270 lookupDatatypeExact n = case !(lookupDatatype n) of

230 [res] => return res

271 [res] => return res

@@ -233,12 +274,14 @@ namespace Tactics

233

274

234 ||| Find the reflected function definition of all functions whose names

275 ||| Find the reflected function definition of all functions whose names

235 ||| are overloadings of some name.

276 ||| are overloadings of some name.

277+ export

236 lookupFunDefn : TTName -> Elab (List (FunDefn TT))

278 lookupFunDefn : TTName -> Elab (List (FunDefn TT))

237 lookupFunDefn n = Prim__LookupFunDefn n

279 lookupFunDefn n = Prim__LookupFunDefn n

238

280

239 ||| Find the reflected function definition of a function, given its

281 ||| Find the reflected function definition of a function, given its

240 ||| fully-qualified name. Fail if the name does not uniquely resolve

282 ||| fully-qualified name. Fail if the name does not uniquely resolve

241 ||| to a function.

283 ||| to a function.

284+ export

242 lookupFunDefnExact : TTName -> Elab (FunDefn TT)

285 lookupFunDefnExact : TTName -> Elab (FunDefn TT)

243 lookupFunDefnExact n = case !(lookupFunDefn n) of

286 lookupFunDefnExact n = case !(lookupFunDefn n) of

244 [res] => return res

287 [res] => return res

@@ -246,11 +289,13 @@ namespace Tactics

246 xs => fail [TextPart "More than one function named", NamePart n]

289 xs => fail [TextPart "More than one function named", NamePart n]

247

290

248 ||| Get the argument specification for each overloading of a name.

291 ||| Get the argument specification for each overloading of a name.

292+ export

249 lookupArgs : TTName -> Elab (List (TTName, List FunArg, Raw))

293 lookupArgs : TTName -> Elab (List (TTName, List FunArg, Raw))

250 lookupArgs n = Prim__LookupArgs n

294 lookupArgs n = Prim__LookupArgs n

251

295

252 ||| Get the argument specification for a name. Fail if the name does

296 ||| Get the argument specification for a name. Fail if the name does

253 ||| not uniquely resolve.

297 ||| not uniquely resolve.

298+ export

254 lookupArgsExact : TTName -> Elab (TTName, List FunArg, Raw)

299 lookupArgsExact : TTName -> Elab (TTName, List FunArg, Raw)

255 lookupArgsExact n = case !(lookupArgs n) of

300 lookupArgsExact n = case !(lookupArgs n) of

256 [res] => return res

301 [res] => return res

@@ -261,6 +306,7 @@ namespace Tactics

261 |||

306 |||

262 ||| @ env the environment within which to check the type

307 ||| @ env the environment within which to check the type

263 ||| @ tm the term to check

308 ||| @ tm the term to check

309+ export

264 check : (env : List (TTName, Binder TT)) -> (tm : Raw) -> Elab (TT, TT)

310 check : (env : List (TTName, Binder TT)) -> (tm : Raw) -> Elab (TT, TT)

265 check env tm = Prim__Check env tm

311 check env tm = Prim__Check env tm

266

312

@@ -269,15 +315,18 @@ namespace Tactics

269 |||

315 |||

270 ||| **NB**: the generated name is unique _for this run of the

316 ||| **NB**: the generated name is unique _for this run of the

271 ||| elaborator_. Do not assume that they are globally unique.

317 ||| elaborator_. Do not assume that they are globally unique.

318+ export

272 gensym : (hint : String) -> Elab TTName

319 gensym : (hint : String) -> Elab TTName

273 gensym hint = Prim__Gensym hint

320 gensym hint = Prim__Gensym hint

274

321

275 ||| Substitute a guess into a hole.

322 ||| Substitute a guess into a hole.

323+ export

276 solve : Elab ()

324 solve : Elab ()

277 solve = Prim__Solve

325 solve = Prim__Solve

278

326

279 ||| Place a term into a hole, unifying its type. Fails if the focus

327 ||| Place a term into a hole, unifying its type. Fails if the focus

280 ||| is not a hole.

328 ||| is not a hole.

329+ export

281 fill : Raw -> Elab ()

330 fill : Raw -> Elab ()

282 fill tm = Prim__Fill tm

331 fill tm = Prim__Fill tm

283

332

@@ -295,6 +344,7 @@ namespace Tactics

295 ||| @ argSpec instructions for finding the arguments to the term,

344 ||| @ argSpec instructions for finding the arguments to the term,

296 ||| where the Boolean states whether or not to attempt to solve

345 ||| where the Boolean states whether or not to attempt to solve

297 ||| the argument by unification.

346 ||| the argument by unification.

347+ export

298 apply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

348 apply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

299 apply tm argSpec = map snd <$> Prim__Apply tm argSpec

349 apply tm argSpec = map snd <$> Prim__Apply tm argSpec

300

350

@@ -313,18 +363,21 @@ namespace Tactics

313 ||| where the Boolean states whether or not to attempt to solve

363 ||| where the Boolean states whether or not to attempt to solve

314 ||| the argument by matching.

364 ||| the argument by matching.

315

365

366+ export

316 matchApply : (op : Raw) -> (argSpec : List Bool) -> Elab (List TTName)

367 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

318

369

319 ||| Move the focus to the specified hole. Fails if the hole does not

370 ||| Move the focus to the specified hole. Fails if the hole does not

320 ||| exist.

371 ||| exist.

321 |||

372 |||

322 ||| @ hole the hole to focus on

373 ||| @ hole the hole to focus on

374+ export

323 focus : (hole : TTName) -> Elab ()

375 focus : (hole : TTName) -> Elab ()

324 focus hole = Prim__Focus hole

376 focus hole = Prim__Focus hole

325

377

326 ||| Send the currently-focused hole to the end of the hole queue and

378 ||| Send the currently-focused hole to the end of the hole queue and

327 ||| focus on the next hole.

379 ||| focus on the next hole.

380+ export

328 unfocus : TTName -> Elab ()

381 unfocus : TTName -> Elab ()

329 unfocus hole = Prim__Unfocus hole

382 unfocus hole = Prim__Unfocus hole

330

383

@@ -336,6 +389,7 @@ namespace Tactics

336 ||| binding, or else the scopes of the generated terms won't make

389 ||| binding, or else the scopes of the generated terms won't make

337 ||| sense. This tactic creates a new hole of the proper form, and

390 ||| sense. This tactic creates a new hole of the proper form, and

338 ||| points the old hole at it.

391 ||| points the old hole at it.

392+ export

339 attack : Elab ()

393 attack : Elab ()

340 attack = Prim__Attack

394 attack = Prim__Attack

341

395

@@ -344,6 +398,7 @@ namespace Tactics

344 ||| The new hole will be focused, and the previously-focused hole

398 ||| The new hole will be focused, and the previously-focused hole

345 ||| will be immediately after it in the hole queue. Because this

399 ||| will be immediately after it in the hole queue. Because this

346 ||| tactic introduces a new binding, you may need to `attack` first.

400 ||| tactic introduces a new binding, you may need to `attack` first.

401+ export

347 claim : TTName -> Raw -> Elab ()

402 claim : TTName -> Raw -> Elab ()

348 claim n ty = Prim__Claim n ty

403 claim n ty = Prim__Claim n ty

349

404

@@ -352,6 +407,7 @@ namespace Tactics

352 ||| `attack`).

407 ||| `attack`).

353 |||

408 |||

354 ||| @ n the name to use for the argument

409 ||| @ n the name to use for the argument

410+ export

355 intro : (n : TTName) -> Elab ()

411 intro : (n : TTName) -> Elab ()

356 intro n = Prim__Intro (Just n)

412 intro n = Prim__Intro (Just n)

357

413

@@ -361,6 +417,7 @@ namespace Tactics

361 |||

417 |||

362 ||| Requires that the hole be immediately under its binder (use

418 ||| Requires that the hole be immediately under its binder (use

363 ||| `attack` if it might not be).

419 ||| `attack` if it might not be).

420+ export

364 intro' : Elab ()

421 intro' : Elab ()

365 intro' = Prim__Intro Nothing

422 intro' = Prim__Intro Nothing

366

423

@@ -369,10 +426,12 @@ namespace Tactics

369 |||

426 |||

370 ||| Requires that the hole be immediately under its binder (use

427 ||| Requires that the hole be immediately under its binder (use

371 ||| `attack` if it might not be).

428 ||| `attack` if it might not be).

429+ export

372 forall : TTName -> Raw -> Elab ()

430 forall : TTName -> Raw -> Elab ()

373 forall n ty = Prim__Forall n ty

431 forall n ty = Prim__Forall n ty

374

432

375 ||| Convert a hole into a pattern variable.

433 ||| Convert a hole into a pattern variable.

434+ export

376 patvar : TTName -> Elab ()

435 patvar : TTName -> Elab ()

377 patvar n = Prim__PatVar n

436 patvar n = Prim__PatVar n

378

437

@@ -380,6 +439,7 @@ namespace Tactics

380 |||

439 |||

381 ||| Requires that the hole be immediately under its binder (use

440 ||| Requires that the hole be immediately under its binder (use

382 ||| `attack` if it might not be).

441 ||| `attack` if it might not be).

442+ export

383 patbind : TTName -> Elab ()

443 patbind : TTName -> Elab ()

384 patbind n = Prim__PatBind n

444 patbind n = Prim__PatBind n

385

445

@@ -391,10 +451,12 @@ namespace Tactics

391 ||| @ n the name to let bind

451 ||| @ n the name to let bind

392 ||| @ ty the type of the term to be let-bound

452 ||| @ ty the type of the term to be let-bound

393 ||| @ tm the term to be bound

453 ||| @ tm the term to be bound

454+ export

394 letbind : (n : TTName) -> (ty, tm : Raw) -> Elab ()

455 letbind : (n : TTName) -> (ty, tm : Raw) -> Elab ()

395 letbind n ty tm = Prim__LetBind n ty tm

456 letbind n ty tm = Prim__LetBind n ty tm

396

457

397 ||| Normalise the goal.

458 ||| Normalise the goal.

459+ export

398 compute : Elab ()

460 compute : Elab ()

399 compute = Prim__Compute

461 compute = Prim__Compute

400

462

@@ -402,12 +464,14 @@ namespace Tactics

402 |||

464 |||

403 ||| @ env the environment in which to compute (get one of these from `getEnv`)

465 ||| @ env the environment in which to compute (get one of these from `getEnv`)

404 ||| @ term the term to normalise

466 ||| @ term the term to normalise

467+ export

405 normalise : (env : List (TTName, Binder TT)) -> (term : TT) -> Elab TT

468 normalise : (env : List (TTName, Binder TT)) -> (term : TT) -> Elab TT

406 normalise env term = Prim__Normalise env term

469 normalise env term = Prim__Normalise env term

407

470

408 ||| Reduce a closed term to weak-head normal form

471 ||| Reduce a closed term to weak-head normal form

409 |||

472 |||

410 ||| @ term the term to reduce

473 ||| @ term the term to reduce

474+ export

411 whnf : (term : TT) -> Elab TT

475 whnf : (term : TT) -> Elab TT

412 whnf term = Prim__Whnf term

476 whnf term = Prim__Whnf term

413

477

@@ -417,6 +481,7 @@ namespace Tactics

417 ||| @ env a lexical environment to compare the terms in (see `getEnv`)

481 ||| @ env a lexical environment to compare the terms in (see `getEnv`)

418 ||| @ term1 the first term to convert

482 ||| @ term1 the first term to convert

419 ||| @ term2 the second term to convert

483 ||| @ term2 the second term to convert

484+ export

420 convertsInEnv : (env : List (TTName, Binder TT)) -> (term1, term2 : TT) -> Elab ()

485 convertsInEnv : (env : List (TTName, Binder TT)) -> (term1, term2 : TT) -> Elab ()

421 convertsInEnv env term1 term2 = Prim__Converts env term1 term2

486 convertsInEnv env term1 term2 = Prim__Converts env term1 term2

422

487

@@ -424,14 +489,17 @@ namespace Tactics

424 |||

489 |||

425 ||| @ term1 the first term to convert

490 ||| @ term1 the first term to convert

426 ||| @ term2 the second term to convert

491 ||| @ term2 the second term to convert

492+ export

427 converts : (term1, term2 : TT) -> Elab ()

493 converts : (term1, term2 : TT) -> Elab ()

428 converts term1 term2 = convertsInEnv !getEnv term1 term2

494 converts term1 term2 = convertsInEnv !getEnv term1 term2

429

495

430 ||| Find the source context for the elaboration script

496 ||| Find the source context for the elaboration script

497+ export

431 getSourceLocation : Elab SourceLocation

498 getSourceLocation : Elab SourceLocation

432 getSourceLocation = Prim__SourceLocation

499 getSourceLocation = Prim__SourceLocation

433

500

434 ||| Attempt to solve the current goal with the source code location

501 ||| Attempt to solve the current goal with the source code location

502+ export

435 sourceLocation : Elab ()

503 sourceLocation : Elab ()

436 sourceLocation = do loc <- getSourceLocation

504 sourceLocation = do loc <- getSourceLocation

437 fill (quote loc)

505 fill (quote loc)

@@ -442,6 +510,7 @@ namespace Tactics

442 |||

510 |||

443 ||| The namespace is represented as a reverse-order list of strings,

511 ||| The namespace is represented as a reverse-order list of strings,

444 ||| just as in the representation of names.

512 ||| just as in the representation of names.

513+ export

445 currentNamespace : Elab (List String)

514 currentNamespace : Elab (List String)

446 currentNamespace = Prim__Namespace

515 currentNamespace = Prim__Namespace

447

516

@@ -455,29 +524,45 @@ namespace Tactics

455 ||| Because this tactic internally introduces a `let` binding, it

524 ||| Because this tactic internally introduces a `let` binding, it

456 ||| requires that the hole be immediately under its binder (use

525 ||| requires that the hole be immediately under its binder (use

457 ||| `attack` if it might not be).

526 ||| `attack` if it might not be).

527+ export

458 rewriteWith : Raw -> Elab ()

528 rewriteWith : Raw -> Elab ()

459 rewriteWith rule = Prim__Rewrite rule

529 rewriteWith rule = Prim__Rewrite rule

460

530

461 ||| Add a type declaration to the global context.

531 ||| Add a type declaration to the global context.

532+ export

462 declareType : TyDecl -> Elab ()

533 declareType : TyDecl -> Elab ()

463 declareType decl = Prim__DeclareType decl

534 declareType decl = Prim__DeclareType decl

464

535

465 ||| Define a function in the global context. The function must have

536 ||| Define a function in the global context. The function must have

466 ||| already been declared, either in ordinary Idris code or using

537 ||| already been declared, either in ordinary Idris code or using

467 ||| `declareType`.

538 ||| `declareType`.

539+ export

468 defineFunction : FunDefn Raw -> Elab ()

540 defineFunction : FunDefn Raw -> Elab ()

469 defineFunction defun = Prim__DefineFunction defun

541 defineFunction defun = Prim__DefineFunction defun

470

542

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+

471 ||| Register a new implementation for interface resolution.

554 ||| Register a new implementation for interface resolution.

472 |||

555 |||

473 ||| @ ifaceName the name of the interface for which an implementation is being registered

556 ||| @ ifaceName the name of the interface for which an implementation is being registered

474 ||| @ instName the name of the definition to use in implementation search

557 ||| @ instName the name of the definition to use in implementation search

558+ export

475 addInstance : (ifaceName, instName : TTName) -> Elab ()

559 addInstance : (ifaceName, instName : TTName) -> Elab ()

476 addInstance ifaceName instName = Prim__AddInstance ifaceName instName

560 addInstance ifaceName instName = Prim__AddInstance ifaceName instName

477

561

478 ||| Determine whether a name denotes an interface.

562 ||| Determine whether a name denotes an interface.

479 |||

563 |||

480 ||| @ name a name that might denote an interface.

564 ||| @ name a name that might denote an interface.

565+ export

481 isTCName : (name : TTName) -> Elab Bool

566 isTCName : (name : TTName) -> Elab Bool

482 isTCName name = Prim__IsTCName name

567 isTCName name = Prim__IsTCName name

483

568

@@ -485,10 +570,12 @@ namespace Tactics

485 |||

570 |||

486 ||| @ fn the name of the definition being elaborated (to prevent Idris

571 ||| @ fn the name of the definition being elaborated (to prevent Idris

487 ||| from looping)

572 ||| from looping)

573+ export

488 resolveTC : (fn : TTName) -> Elab ()

574 resolveTC : (fn : TTName) -> Elab ()

489 resolveTC fn = Prim__ResolveTC fn

575 resolveTC fn = Prim__ResolveTC fn

490

576

491 ||| Use Idris's internal proof search.

577 ||| Use Idris's internal proof search.

578+ export

492 search : Elab ()

579 search : Elab ()

493 search = Prim__Search 100 []

580 search = Prim__Search 100 []

494

581

@@ -496,6 +583,7 @@ namespace Tactics

496 |||

583 |||

497 ||| @ depth the search depth

584 ||| @ depth the search depth

498 ||| @ hints additional names to try

585 ||| @ hints additional names to try

586+ export

499 search' : (depth : Int) -> (hints : List TTName) -> Elab ()

587 search' : (depth : Int) -> (hints : List TTName) -> Elab ()

500 search' depth hints = Prim__Search depth hints

588 search' depth hints = Prim__Search depth hints

501

589

@@ -505,6 +593,7 @@ namespace Tactics

505 ||| if the string is not a valid operator.

593 ||| if the string is not a valid operator.

506 |||

594 |||

507 ||| @ operator the operator string to look up

595 ||| @ operator the operator string to look up

596+ export

508 operatorFixity : (operator : String) -> Elab Fixity

597 operatorFixity : (operator : String) -> Elab Fixity

509 operatorFixity operator = Prim__Fixity operator

598 operatorFixity operator = Prim__Fixity operator

510

599

@@ -512,6 +601,7 @@ namespace Tactics

512 |||

601 |||

513 ||| This is intended for elaboration script developers, not for

602 ||| This is intended for elaboration script developers, not for

514 ||| end-users. Use `fail` for final scripts.

603 ||| end-users. Use `fail` for final scripts.

604+ export

515 debug : Elab a

605 debug : Elab a

516 debug = Prim__Debug []

606 debug = Prim__Debug []

517

607

@@ -522,18 +612,21 @@ namespace Tactics

522 ||| end-users. Use `fail` for final scripts.

612 ||| end-users. Use `fail` for final scripts.

523 |||

613 |||

524 ||| @ msg the message to display

614 ||| @ msg the message to display

615+ export

525 debugMessage : (msg : List ErrorReportPart) -> Elab a

616 debugMessage : (msg : List ErrorReportPart) -> Elab a

526 debugMessage msg = Prim__Debug msg

617 debugMessage msg = Prim__Debug msg

527

618

528 ||| Create a new top-level metavariable to solve the current hole.

619 ||| Create a new top-level metavariable to solve the current hole.

529 |||

620 |||

530 ||| @ name the name for the top-level variable

621 ||| @ name the name for the top-level variable

622+ export

531 metavar : (name : TTName) -> Elab ()

623 metavar : (name : TTName) -> Elab ()

532 metavar name = Prim__Metavar name

624 metavar name = Prim__Metavar name

533

625

534 ||| Recursively invoke the reflected elaborator with some goal.

626 ||| Recursively invoke the reflected elaborator with some goal.

535 |||

627 |||

536 ||| The result is the final term and its type.

628 ||| The result is the final term and its type.

629+ export

537 runElab : Raw -> Elab () -> Elab (TT, TT)

630 runElab : Raw -> Elab () -> Elab (TT, TT)

538 runElab goal script = Prim__RecursiveElab goal script

631 runElab goal script = Prim__RecursiveElab goal script

539

632

libs/prelude/Language/Reflection/Errors.idr+3−1

@@ -8,6 +8,8 @@ import Prelude.Bool

8import Prelude.List

9import Prelude.Maybe

10

11+%access public export

12+

11data Err = Msg String

13data Err = Msg String

12 | InternalMsg String

14 | InternalMsg String

13 | CantUnify Bool TT TT Err (List (TTName, TT)) Int

15 | CantUnify Bool TT TT Err (List (TTName, TT)) Int

@@ -28,7 +30,7 @@ data Err = Msg String

28 | CantMatch TT

30 | CantMatch TT

29 | NoTypeDecl TTName

31 | NoTypeDecl TTName

30 | NotInjective TT TT TT

32 | NotInjective TT TT TT

31− | CantResolve TT

33+ | CantResolve TT Err

32 | InvalidTCArg TTName TT

34 | InvalidTCArg TTName TT

33 | CantResolveAlts (List TTName)

35 | CantResolveAlts (List TTName)

34 | NoValidAlts (List TTName)

36 | NoValidAlts (List TTName)

libs/prelude/Prelude.idr+9−9

@@ -6,7 +6,7 @@ import public IO

6import public Prelude.Algebra

7import public Prelude.Basics

8import public Prelude.Bool

9−import public Prelude.Classes

9+import public Prelude.Interfaces

10import public Prelude.Cast

11import public Prelude.Nat

12import public Prelude.List

@@ -33,7 +33,7 @@ import public Language.Reflection

33import public Language.Reflection.Elab

34import public Language.Reflection.Errors

35

36−%access public

36+%access public export

37%default total

38

39-- Things that can't be elsewhere for import cycle reasons

@@ -210,7 +210,7 @@ Enum Int where

210Enum Char where

211 toNat c = toNat (ord c)

212 fromNat n = chr (fromNat n)

213−

213+

214 pred c = fromNat (pred (toNat c))

215

216syntax "[" [start] ".." [end] "]"

@@ -264,15 +264,15 @@ while t b = do v <- t

264------- Some error rewriting

265

266%language ErrorReflection

267−

267+

268private

269cast_part : TT -> ErrorReportPart

270cast_part (P Bound n t) = TextPart "unknown type"

271cast_part x = TermPart x

272−

272+

273−%error_handler

273+%error_handler export

274cast_error : Err -> Maybe (List ErrorReportPart)

275−cast_error (CantResolve `(Cast ~x ~y))

275+cast_error (CantResolve `(Cast ~x ~y) _)

276 = Just [TextPart "Can't cast from",

277 cast_part x,

278 TextPart "to",

@@ -280,8 +280,8 @@ cast_error (CantResolve `(Cast ~x ~y))

280cast_error _ = Nothing

281

282%error_handler

283+export

283num_error : Err -> Maybe (List ErrorReportPart)

284num_error : Err -> Maybe (List ErrorReportPart)

284−num_error (CantResolve `(Num ~x))

285+num_error (CantResolve `(Num ~x) _)

285 = Just [TermPart x, TextPart "is not a numeric type"]

286 = Just [TermPart x, TextPart "is not a numeric type"]

286num_error _ = Nothing

287num_error _ = Nothing

287−

libs/prelude/Prelude/Algebra.idr+1−1

@@ -4,7 +4,7 @@ import Builtins

4

5infixl 6 <+>

6

7−%access public

7+%access public export

8

9--------------------------------------------------------------------------------

10-- A modest interface hierarchy

libs/prelude/Prelude/Applicative.idr+3−1

@@ -4,10 +4,12 @@ import Builtins

4

5import Prelude.Basics

6import Prelude.Bool

7−import Prelude.Classes

7+import Prelude.Interfaces

8import Prelude.Foldable

9import Prelude.Functor

10

11+%access public export

12+

11---- Applicative functors/Idioms

13---- Applicative functors/Idioms

12

14

13infixl 2 <*>

15infixl 2 <*>

libs/prelude/Prelude/Basics.idr+6−4

@@ -1,7 +1,9 @@

1module Prelude.Basics

2

3import Builtins

4−

4+

5+%access public export

6+

5Not : Type -> Type

7Not : Type -> Type

6Not a = a -> Void

8Not a = a -> Void

7

9

@@ -51,9 +53,9 @@ data Dec : Type -> Type where

51

53

52 ||| The case where the property holds

54 ||| The case where the property holds

53 ||| @ prf the proof

55 ||| @ prf the proof

54− Yes : {A : Type} -> (prf : A) -> Dec A

56+ Yes : (prf : prop) -> Dec prop

55

57

56 ||| The case where the property holding would be a contradiction

58 ||| The case where the property holding would be a contradiction

57− ||| @ contra a demonstration that A would be a contradiction

59+ ||| @ contra a demonstration that prop would be a contradiction

58− No : {A : Type} -> (contra : A -> Void) -> Dec A

60+ No : (contra : prop -> Void) -> Dec prop

59

61

libs/prelude/Prelude/Bits.idr+2−2

@@ -6,13 +6,13 @@ import Prelude.Basics

6import Prelude.Bool

7import Prelude.Cast

8import Prelude.Chars

9−import Prelude.Classes

9+import Prelude.Interfaces

10import Prelude.Foldable

11import Prelude.Nat

12import Prelude.List

13import Prelude.Strings

14

15−%access public

15+%access public export

16%default total

17

18b8ToString : Bits8 -> String

libs/prelude/Prelude/Bool.idr+2

@@ -4,6 +4,8 @@ import Builtins

4

5import Prelude.Uninhabited

6

7+%access public export

8+

7||| Boolean Data Type

9||| Boolean Data Type

8%case data Bool = False | True

10%case data Bool = False | True

9

11

libs/prelude/Prelude/Cast.idr+2

@@ -3,6 +3,8 @@ module Prelude.Cast

3import Prelude.Bool

4import public Builtins

5

6+%access public export

7+

6||| Interface for transforming an instance of a data type to another type.

8||| Interface for transforming an instance of a data type to another type.

7interface Cast from to where

9interface Cast from to where

8 ||| Perform a cast operation.

10 ||| Perform a cast operation.

libs/prelude/Prelude/Chars.idr+3−3

@@ -2,11 +2,13 @@ module Prelude.Chars

2-- Functions operating over Chars

3

4import Prelude.Bool

5−import Prelude.Classes

5+import Prelude.Interfaces

6import Prelude.List

7import Prelude.Cast

8import Builtins

9

10+%access public export

11+

10||| Convert the number to its ASCII equivalent.

12||| Convert the number to its ASCII equivalent.

11chr : Int -> Char

13chr : Int -> Char

12chr x = if (x >= 0 && x < 0x110000)

14chr x = if (x >= 0 && x < 0x110000)

@@ -74,5 +76,3 @@ isHexDigit x = elem (toUpper x) hexChars where

74||| Returns true if the character is an octal digit.

76||| Returns true if the character is an octal digit.

75isOctDigit : Char -> Bool

77isOctDigit : Char -> Bool

76isOctDigit x = (x >= '0' && x <= '7')

78isOctDigit x = (x >= '0' && x <= '7')

77−

78−

libs/prelude/Prelude/Doubles.idr+4−6

@@ -1,16 +1,16 @@

1−module Prelude.Doubles

1+module Prelude.Doubles

2

3import Builtins

4−import Prelude.Classes

4+import Prelude.Interfaces

5

6−%access public

6+%access public export

7%default total

8

9%include C "math.h"

10%lib C "m"

11

12pi : Double

13−pi = 3.14159265358979323846

13+pi = 3.14159265358979323846

14

15euler : Double

16euler = 2.7182818284590452354

@@ -59,5 +59,3 @@ floor x = prim__floatFloor x

59

60ceiling : Double -> Double

61ceiling x = prim__floatCeil x

62−

63−

libs/prelude/Prelude/Either.idr+3−1

@@ -4,10 +4,12 @@ import Builtins

4

5import Prelude.Basics

6import Prelude.Bool

7−import Prelude.Classes

7+import Prelude.Interfaces

8import Prelude.Maybe

9import Prelude.List

10

11+%access public export

12+

11||| A sum type

13||| A sum type

12%elim data Either : (a, b : Type) -> Type where

14%elim data Either : (a, b : Type) -> Type where

13 ||| One possibility of the sum, conventionally used to represent errors

15 ||| One possibility of the sum, conventionally used to represent errors

libs/prelude/Prelude/File.idr+62−20

@@ -9,15 +9,15 @@ import Prelude.Strings

9import Prelude.Cast

10import Prelude.Bool

11import Prelude.Basics

12−import Prelude.Classes

12+import Prelude.Interfaces

13import Prelude.Either

14import Prelude.Show

15import IO

16

17−%access public

17+%access public export

18

19||| A file handle

20−abstract

20+export

21data File : Type where

22 FHandle : (p : Ptr) -> File

23

@@ -39,35 +39,43 @@ strError err = unsafePerformIO -- yeah, yeah...

39 (foreign FFI_C "idris_showerror" (Int -> IO String) err)

40

41getFileError : IO FileError

42−getFileError = do MkRaw err <- foreign FFI_C "idris_mkFileError"

42+getFileError = do MkRaw err <- foreign FFI_C "idris_mkFileError"

43 (Ptr -> IO (Raw FileError)) prim__vm

44 return err

45

46Show FileError where

47+ show FileReadError = "File Read Error"

48+ show FileWriteError = "File Write Error"

47 show FileNotFound = "File Not Found"

49 show FileNotFound = "File Not Found"

48 show PermissionDenied = "Permission Denied"

50 show PermissionDenied = "Permission Denied"

49 show (GenericFileError errno) = strError errno

51 show (GenericFileError errno) = strError errno

50

52

51||| Standard input

53||| Standard input

54+export

52stdin : File

55stdin : File

53stdin = FHandle prim__stdin

56stdin = FHandle prim__stdin

54

57

55||| Standard output

58||| Standard output

59+export

56stdout : File

60stdout : File

57stdout = FHandle prim__stdout

61stdout = FHandle prim__stdout

58

62

59||| Standard output

63||| Standard output

64+export

60stderr : File

65stderr : File

61stderr = FHandle prim__stderr

66stderr = FHandle prim__stderr

62

67

68+private

63do_ferror : Ptr -> IO Int

69do_ferror : Ptr -> IO Int

64do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h

70do_ferror h = foreign FFI_C "fileError" (Ptr -> IO Int) h

65

71

72+export

66ferror : File -> IO Bool

73ferror : File -> IO Bool

67ferror (FHandle h) = do err <- do_ferror h

74ferror (FHandle h) = do err <- do_ferror h

68 return (not (err == 0))

75 return (not (err == 0))

69

76

70||| Call the RTS's file opening function

77||| Call the RTS's file opening function

78+private

71do_fopen : String -> String -> IO Ptr

79do_fopen : String -> String -> IO Ptr

72do_fopen f m

80do_fopen f m

73 = foreign FFI_C "fileOpen" (String -> String -> IO Ptr) f m

81 = foreign FFI_C "fileOpen" (String -> String -> IO Ptr) f m

@@ -75,6 +83,7 @@ do_fopen f m

75||| Open a file

83||| Open a file

76||| @ f the filename

84||| @ f the filename

77||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

85||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

86+export

78fopen : (f : String) -> (m : String) -> IO (Either FileError File)

87fopen : (f : String) -> (m : String) -> IO (Either FileError File)

79fopen f m = do h <- do_fopen f m

88fopen f m = do h <- do_fopen f m

80 if !(nullPtr h)

89 if !(nullPtr h)

@@ -83,60 +92,83 @@ fopen f m = do h <- do_fopen f m

83 else return (Right (FHandle h))

92 else return (Right (FHandle h))

84

93

85||| Check whether a file handle is actually a null pointer

94||| Check whether a file handle is actually a null pointer

95+export

86validFile : File -> IO Bool

96validFile : File -> IO Bool

87validFile (FHandle h) = do x <- nullPtr h

97validFile (FHandle h) = do x <- nullPtr h

88 return (not x)

98 return (not x)

89

99

90||| Modes for opening files

100||| Modes for opening files

91−data Mode = Read | Write | ReadWrite

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+"

92

114

93||| Open a file

115||| Open a file

94||| @ f the filename

116||| @ 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

96openFile : (f : String) -> (m : Mode) -> IO (Either FileError File)

119openFile : (f : String) -> (m : Mode) -> IO (Either FileError File)

97−openFile f m = fopen f (modeStr m) where

120+openFile f m = fopen f (modeStr m)

98− modeStr Read = "r"

121+

99− modeStr Write = "w"

122+||| Open a file using C11 extended modes.

100− modeStr ReadWrite = "r+"

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"

101

128

129+private

102do_fclose : Ptr -> IO ()

130do_fclose : Ptr -> IO ()

103do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h

131do_fclose h = foreign FFI_C "fileClose" (Ptr -> IO ()) h

104

132

133+export

105closeFile : File -> IO ()

134closeFile : File -> IO ()

106closeFile (FHandle h) = do_fclose h

135closeFile (FHandle h) = do_fclose h

107

136

137+private

108do_fread : Ptr -> IO' l String

138do_fread : Ptr -> IO' l String

109do_fread h = prim_fread h

139do_fread h = prim_fread h

110

140

141+export

111fgetc : File -> IO (Either FileError Char)

142fgetc : File -> IO (Either FileError Char)

112fgetc (FHandle h) = do let c = cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h)

143fgetc (FHandle h) = do let c = cast !(foreign FFI_C "fgetc" (Ptr -> IO Int) h)

113 if !(ferror (FHandle h))

144 if !(ferror (FHandle h))

114 then return (Left FileReadError)

145 then return (Left FileReadError)

115 else return (Right c)

146 else return (Right c)

116

147

148+export

117fflush : File -> IO ()

149fflush : File -> IO ()

118fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h

150fflush (FHandle h) = foreign FFI_C "fflush" (Ptr -> IO ()) h

119

151

152+private

120do_popen : String -> String -> IO Ptr

153do_popen : String -> String -> IO Ptr

121do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m

154do_popen f m = foreign FFI_C "do_popen" (String -> String -> IO Ptr) f m

122

155

156+export

123popen : String -> Mode -> IO (Either FileError File)

157popen : String -> Mode -> IO (Either FileError File)

124popen f m = do ptr <- do_popen f (modeStr m)

158popen f m = do ptr <- do_popen f (modeStr m)

125 if !(nullPtr ptr)

159 if !(nullPtr ptr)

126 then do err <- getFileError

160 then do err <- getFileError

127 return (Left err)

161 return (Left err)

128 else return (Right (FHandle ptr))

162 else return (Right (FHandle ptr))

129− where

130− modeStr Read = "r"

131− modeStr Write = "w"

132− modeStr ReadWrite = "r+"

133

163

164+export

134pclose : File -> IO ()

165pclose : File -> IO ()

135pclose (FHandle h) = foreign FFI_C "pclose" (Ptr -> IO ()) h

166pclose (FHandle h) = foreign FFI_C "pclose" (Ptr -> IO ()) h

136

167

137-- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String))

168-- mkForeign (FFun "idris_readStr" [FPtr, FPtr] (FAny String))

138-- prim__vm h

169-- prim__vm h

139

170

171+export

140fread : File -> IO (Either FileError String)

172fread : File -> IO (Either FileError String)

141fread (FHandle h) = do str <- do_fread h

173fread (FHandle h) = do str <- do_fread h

142 if !(ferror (FHandle h))

174 if !(ferror (FHandle h))

@@ -145,56 +177,65 @@ fread (FHandle h) = do str <- do_fread h

145

177

146||| Read a line from a file

178||| Read a line from a file

147||| @h a file handle which must be open for reading

179||| @h a file handle which must be open for reading

180+export

148fGetLine : (h : File) -> IO (Either FileError String)

181fGetLine : (h : File) -> IO (Either FileError String)

149fGetLine = fread

182fGetLine = fread

150

183

151%deprecate fread "Use fGetLine instead"

184%deprecate fread "Use fGetLine instead"

152

185

186+private

153do_fwrite : Ptr -> String -> IO (Either FileError ())

187do_fwrite : Ptr -> String -> IO (Either FileError ())

154do_fwrite h s = do res <- prim_fwrite h s

188do_fwrite h s = do res <- prim_fwrite h s

155 if (res /= 0)

189 if (res /= 0)

156 then do errno <- getErrno

190 then do errno <- getErrno

157− if errno == 0

191+ if errno == 0

158 then return (Left FileWriteError)

192 then return (Left FileWriteError)

159 else do err <- getFileError

193 else do err <- getFileError

160 return (Left err)

194 return (Left err)

161 else return (Right ())

195 else return (Right ())

162

196

197+export

163fwrite : File -> String -> IO (Either FileError ())

198fwrite : File -> String -> IO (Either FileError ())

164fwrite (FHandle h) s = do_fwrite h s

199fwrite (FHandle h) s = do_fwrite h s

165

200

166||| Write a line to a file

201||| Write a line to a file

167||| @h a file handle which must be open for writing

202||| @h a file handle which must be open for writing

168||| @str the line to write to the file

203||| @str the line to write to the file

204+export

169fPutStr : (h : File) -> (str : String) -> IO (Either FileError ())

205fPutStr : (h : File) -> (str : String) -> IO (Either FileError ())

170fPutStr (FHandle h) s = do_fwrite h s

206fPutStr (FHandle h) s = do_fwrite h s

171

207

208+export

172fPutStrLn : File -> String -> IO (Either FileError ())

209fPutStrLn : File -> String -> IO (Either FileError ())

173fPutStrLn (FHandle h) s = do_fwrite h (s ++ "\n")

210fPutStrLn (FHandle h) s = do_fwrite h (s ++ "\n")

174

211

175%deprecate fwrite "Use fPutStr instead"

212%deprecate fwrite "Use fPutStr instead"

176

213

214+private

177do_feof : Ptr -> IO Int

215do_feof : Ptr -> IO Int

178do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h

216do_feof h = foreign FFI_C "fileEOF" (Ptr -> IO Int) h

179

217

180||| Check if a file handle has reached the end

218||| Check if a file handle has reached the end

219+export

181fEOF : File -> IO Bool

220fEOF : File -> IO Bool

182fEOF (FHandle h) = do eof <- do_feof h

221fEOF (FHandle h) = do eof <- do_feof h

183 return (not (eof == 0))

222 return (not (eof == 0))

184

223

185||| Check if a file handle has reached the end

224||| Check if a file handle has reached the end

225+export

186feof : File -> IO Bool

226feof : File -> IO Bool

187feof = fEOF

227feof = fEOF

188

228

189%deprecate feof "Use fEOF instead"

229%deprecate feof "Use fEOF instead"

190

230

231+export

191fpoll : File -> IO Bool

232fpoll : File -> IO Bool

192fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h

233fpoll (FHandle h) = do p <- foreign FFI_C "fpoll" (Ptr -> IO Int) h

193 return (p > 0)

234 return (p > 0)

194

235

195||| Read the contents of a file into a string

236||| Read the contents of a file into a string

196−partial -- might be reading something infinitely long like /dev/null ...

237+partial -- might be reading something infinitely long like /dev/null ...

197−covering

238+covering export

198readFile : String -> IO (Either FileError String)

239readFile : String -> IO (Either FileError String)

199readFile fn = do Right h <- openFile fn Read

240readFile fn = do Right h <- openFile fn Read

200 | Left err => return (Left err)

241 | Left err => return (Left err)

@@ -212,10 +253,11 @@ readFile fn = do Right h <- openFile fn Read

212 else return (Right contents)

253 else return (Right contents)

213

254

214||| Write a string to a file

255||| Write a string to a file

256+export

215−writeFile : (filepath : String) -> (contents : String) ->

257+writeFile : (filepath : String) -> (contents : String) ->

216 IO (Either FileError ())

258 IO (Either FileError ())

217writeFile fn contents = do

259writeFile fn contents = do

218− Right h <- openFile fn Write | Left err => return (Left err)

260+ Right h <- openFile fn WriteTruncate | Left err => return (Left err)

219− Right () <- fPutStr h contents | Left err => return (Left err)

261+ Right () <- fPutStr h contents | Left err => return (Left err)

220 closeFile h

262 closeFile h

221 return (Right ())

263 return (Right ())

libs/prelude/Prelude/Foldable.idr+4−5

@@ -3,15 +3,15 @@ module Prelude.Foldable

3import Builtins

4import Prelude.Bool

5import Prelude.Basics

6−import Prelude.Classes

6+import Prelude.Interfaces

7import Prelude.Algebra

8

9−%access public

9+%access public export

10%default total

11

12interface Foldable (t : Type -> Type) where

13− foldr : (elt -> acc -> acc) -> acc -> t elt -> acc

13+ foldr : (elem -> acc -> acc) -> acc -> t elem -> acc

14− foldl : (acc -> elt -> acc) -> acc -> t elt -> acc

14+ foldl : (acc -> elem -> acc) -> acc -> t elem -> acc

15 foldl f z t = foldr (flip (.) . flip f) id t z

16

17||| Combine each element of a structure into a monoid

@@ -54,4 +54,3 @@ sum = foldr (+) 0

54||| Multiply together all elements of a structure

55product : (Foldable t, Num a) => t a -> a

56product = foldr (*) 1

57−

libs/prelude/Prelude/Functor.idr+7−5

@@ -2,21 +2,23 @@ module Prelude.Functor

2

3import Prelude.Basics

4

5+%access public export

6+

5||| Functors allow a uniform action over a parameterised type.

7||| Functors allow a uniform action over a parameterised type.

6||| @ f a parameterised type

8||| @ f a parameterised type

7interface Functor (f : Type -> Type) where

9interface Functor (f : Type -> Type) where

8 ||| Apply a function across everything of type 'a' in a

10 ||| Apply a function across everything of type 'a' in a

9 ||| parameterised type

11 ||| parameterised type

10 ||| @ f the parameterised type

12 ||| @ f the parameterised type

11− ||| @ m the function to apply

13+ ||| @ func the function to apply

12− map : (m : a -> b) -> f a -> f b

14+ map : (func : a -> b) -> f a -> f b

13

15

14infixl 4 <$>

16infixl 4 <$>

15

17

16||| An infix alias for `map`, applying a function across everything of

18||| An infix alias for `map`, applying a function across everything of

17||| type 'a' in a parameterised type

19||| type 'a' in a parameterised type

18||| @ f the parameterised type

20||| @ f the parameterised type

19−||| @ m the function to apply

21+||| @ func the function to apply

20−(<$>) : Functor f => (m : a -> b) -> f a -> f b

22+(<$>) : Functor f => (func : a -> b) -> f a -> f b

21−m <$> x = map m x

23+func <$> x = map func x

22

24

libs/prelude/Prelude/Interactive.idr+18−19

@@ -1,5 +1,5 @@

1||| Various helper functions for creating simple interactive systems.

2−|||

2+|||

3||| These are mostly intended for helping with teaching, in that they will allow

4||| the easy creation of interactive programs without needing to teach IO

5||| or Effects first, but they also capture some common patterns of interactive

@@ -10,7 +10,7 @@ import Builtins

10import Prelude.List

11import Prelude.File

12import Prelude.Bool

13−import Prelude.Classes

13+import Prelude.Interfaces

14import Prelude.Strings

15import Prelude.Chars

16import Prelude.Show

@@ -21,7 +21,7 @@ import Prelude.Either

21import Prelude.Monad

22import IO

23

24−%access public

24+%access public export

25

26---- some basic io

27

@@ -115,19 +115,19 @@ getArgs = do n <- numArgs

115||| @ onEOF the function to run on reaching end of file, returning a String

116||| to output

117partial

118−processHandle : File ->

118+processHandle : File ->

119 (state : a) ->

120− (onRead : a -> String -> (String, a)) ->

120+ (onRead : a -> String -> (String, a)) ->

121− (onEOF : a -> String) ->

121+ (onEOF : a -> String) ->

122 IO ()

123−processHandle h acc onRead onEOF

123+processHandle h acc onRead onEOF

124 = if !(fEOF h)

125 then putStr (onEOF acc)

126 else do Right x <- fGetLine h

127 | Left err => putStr (onEOF acc)

128 let (out, acc') = onRead acc x

129 putStr out

130− processHandle h acc' onRead onEOF

130+ processHandle h acc' onRead onEOF

131

132||| Process input from the standard input stream, while maintaining a state.

133||| @ state the input state

@@ -136,34 +136,33 @@ processHandle h acc onRead onEOF

136||| @ onEOI the function to run on reaching end of input, returning a String

137||| to output

138partial

139−processStdin : (state : a) ->

139+processStdin : (state : a) ->

140− (onRead : a -> String -> (String, a)) ->

140+ (onRead : a -> String -> (String, a)) ->

141 (onEOI : a -> String) -> IO ()

142processStdin = processHandle stdin

143

144||| A basic read-eval-print loop, maintaining a state

145||| @ state the input state

146−||| @ prompt the prompt to show

146+||| @ prompt the prompt to show

147||| @ onInput the function to run on reading input, returning a String to

148||| output and a new state. Returns Nothing if the repl should exit

149partial

150−replWith : (state : a) -> (prompt : String) ->

150+replWith : (state : a) -> (prompt : String) ->

151 (onInput : a -> String -> Maybe (String, a)) -> IO ()

152−replWith acc prompt fn

152+replWith acc prompt fn

153 = do putStr prompt

154 x <- getLine

155 case fn acc x of

156− Just (out, acc') => do putStr out

156+ Just (out, acc') => do putStr out

157 replWith acc' prompt fn

158 Nothing => return ()

159

160||| A basic read-eval-print loop

161−||| @ prompt the prompt to show

161+||| @ prompt the prompt to show

162||| @ onInput the function to run on reading input, returning a String to

163−||| output

163+||| output

164partial

165−repl : (prompt : String) ->

165+repl : (prompt : String) ->

166 (onInput : String -> String) -> IO ()

167−repl prompt fn

167+repl prompt fn

168 = replWith () prompt (\x, s => Just (fn s, ()))

169−

libs/prelude/Prelude/Classes.idr → libs/prelude/Prelude/Interfaces.idrrenamed+11−11

@@ -1,9 +1,11 @@

1−module Prelude.Classes

1+module Prelude.Interfaces

2

3import Builtins

4import Prelude.Basics

5import Prelude.Bool

6

7+%access public export

8+

7-- Numerical Operator Precedence

9-- Numerical Operator Precedence

8infixl 5 ==, /=

10infixl 5 ==, /=

9infixl 6 <, <=, >, >=

11infixl 6 <, <=, >, >=

@@ -57,7 +59,7 @@ Eq Bool where

57 True == False = False

59 True == False = False

58 False == True = False

60 False == True = False

59 False == False = True

61 False == False = True

60−

62+

61(Eq a, Eq b) => Eq (a, b) where

63(Eq a, Eq b) => Eq (a, b) where

62 (==) (a, c) (b, d) = (a == b) && (c == d)

64 (==) (a, c) (b, d) = (a == b) && (c == d)

63

65

@@ -357,7 +359,7 @@ divB8 x y = case y == 0 of

357modB8 : Bits8 -> Bits8 -> Bits8

359modB8 : Bits8 -> Bits8 -> Bits8

358modB8 x y = case y == 0 of

360modB8 x y = case y == 0 of

359 False => prim__sremB8 x y

361 False => prim__sremB8 x y

360−

362+

361Integral Bits8 where

363Integral Bits8 where

362 div = divB8

364 div = divB8

363 mod = modB8

365 mod = modB8

@@ -372,8 +374,8 @@ modB16 x y = case y == 0 of

372 False => prim__sremB16 x y

374 False => prim__sremB16 x y

373

375

374Integral Bits16 where

376Integral Bits16 where

375− div = divB16

377+ div = divB16

376− mod = modB16

378+ mod = modB16

377

379

378-- ------------------------------------------------------------------ [ Bits32 ]

380-- ------------------------------------------------------------------ [ Bits32 ]

379divB32 : Bits32 -> Bits32 -> Bits32

381divB32 : Bits32 -> Bits32 -> Bits32

@@ -385,8 +387,8 @@ modB32 x y = case y == 0 of

385 False => prim__sremB32 x y

387 False => prim__sremB32 x y

386

388

387Integral Bits32 where

389Integral Bits32 where

388− div = divB32

390+ div = divB32

389− mod = modB32

391+ mod = modB32

390

392

391-- ------------------------------------------------------------------ [ Bits64 ]

393-- ------------------------------------------------------------------ [ Bits64 ]

392divB64 : Bits64 -> Bits64 -> Bits64

394divB64 : Bits64 -> Bits64 -> Bits64

@@ -398,7 +400,5 @@ modB64 x y = case y == 0 of

398 False => prim__sremB64 x y

400 False => prim__sremB64 x y

399

401

400Integral Bits64 where

402Integral Bits64 where

401− div = divB64

403+ div = divB64

402− mod = modB64

404+ mod = modB64

403−

404−

libs/prelude/Prelude/List.idr+5−6

@@ -5,14 +5,14 @@ import Builtins

5import Prelude.Algebra

6import Prelude.Basics

7import Prelude.Bool

8−import Prelude.Classes

8+import Prelude.Interfaces

9import Prelude.Foldable

10import Prelude.Functor

11import Prelude.Maybe

12import Prelude.Uninhabited

13import Prelude.Nat

14

15−%access public

15+%access public export

16%default total

17

18infix 5 \\

@@ -174,7 +174,7 @@ init' [] = Nothing

174init' (x::xs) =

175 case xs of

176 [] => Just []

177− y::ys =>

177+ y::ys =>

178 case init' $ y::ys of

179 Nothing => Nothing

180 Just j => Just $ x :: j

@@ -305,7 +305,7 @@ zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

305||| @ z the third list

306zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) ->

307 (z : List c) -> List d

308−zipWith3 f _ [] (z::zs) = []

308+zipWith3 f _ [] (z::zs) = []

309zipWith3 f _ (y::ys) [] = []

310zipWith3 f [] (y::ys) _ = []

311zipWith3 f (x::xs) [] _ = []

@@ -761,7 +761,7 @@ mergeBy : (a -> a -> Ordering) -> List a -> List a -> List a

761mergeBy order [] right = right

762mergeBy order left [] = left

763mergeBy order (x::xs) (y::ys) =

764− if order x y == LT

764+ if order x y == LT

765 then x :: mergeBy order xs (y::ys)

766 else y :: mergeBy order (x::xs) ys

767

@@ -888,4 +888,3 @@ foldlAsFoldr f z t = foldr (flip (.) . flip f) id t z

888foldlMatchesFoldr : (f : b -> a -> b) -> (q : b) -> (xs : List a) -> foldl f q xs = foldlAsFoldr f q xs

889foldlMatchesFoldr f q [] = Refl

890foldlMatchesFoldr f q (x :: xs) = foldlMatchesFoldr f (f q x) xs

891−

libs/prelude/Prelude/Maybe.idr+2−2

@@ -5,10 +5,10 @@ import Prelude.Algebra

5import Prelude.Basics

6import Prelude.Bool

7import Prelude.Cast

8−import Prelude.Classes

8+import Prelude.Interfaces

9import Prelude.Foldable

10

11−%access public

11+%access public export

12%default total

13

14||| An optional value. This can be used to represent the possibility of

libs/prelude/Prelude/Monad.idr+12−4

@@ -8,22 +8,30 @@ import Prelude.Applicative

8import Prelude.Basics

9import IO

10

11−%access public

11+%access public export

12

13infixl 5 >>=

14

15interface Applicative m => Monad (m : Type -> Type) where

16+ ||| Also called `bind`.

16 (>>=) : m a -> ((result : a) -> m b) -> m b

17 (>>=) : m a -> ((result : a) -> m b) -> m b

17

18

18−||| Also called `join` or mu

19+ ||| Also called `flatten` or mu

19−flatten : Monad m => m (m a) -> m a

20+ join : m (m a) -> m a

20−flatten a = a >>= id

21+

22+ -- default implementations

23+ (>>=) x f = join (f <$> x)

24+ join x = x >>= id

21

25

22||| For compatibility with Haskell. Note that monads are **not** free to

26||| For compatibility with Haskell. Note that monads are **not** free to

23||| define `return` and `pure` differently!

27||| define `return` and `pure` differently!

24return : Monad m => a -> m a

28return : Monad m => a -> m a

25return = pure

29return = pure

26

30

31+flatten : Monad m => m (m a) -> m a

32+flatten = join

33+%deprecate flatten "Please use `join`, which is the standard name."

34+

27-- Annoyingly, these need to be here, so that we can use them in other

35-- Annoyingly, these need to be here, so that we can use them in other

28-- Prelude modules other than the top level.

36-- Prelude modules other than the top level.

29

37

libs/prelude/Prelude/Nat.idr+19−19

@@ -6,10 +6,10 @@ import Prelude.Algebra

6import Prelude.Basics

7import Prelude.Bool

8import Prelude.Cast

9−import Prelude.Classes

9+import Prelude.Interfaces

10import Prelude.Uninhabited

11

12−%access public

12+%access public export

13%default total

14

15||| Natural numbers: unbounded, unsigned integers which can be pattern

@@ -224,9 +224,9 @@ record Multiplicative where

224

225||| A wrapper for Nat that specifies the semigroup and monad implementations that use (+)

226record Additive where

227− constructor GetAdditive

227+ constructor GetAdditive

228 _ : Nat

229−

229+

230Semigroup Multiplicative where

231 (<+>) left right = GetMultiplicative $ left' * right'

232 where

@@ -341,6 +341,7 @@ partial

341divCeil : Nat -> Nat -> Nat

342divCeil x (S y) = divCeilNZ x (S y) SIsNotZ

343

344+partial

344Integral Nat where

345Integral Nat where

345 div = divNat

346 div = divNat

346 mod = modNat

347 mod = modNat

@@ -424,7 +425,7 @@ total plusCommutative : (left : Nat) -> (right : Nat) ->

424plusCommutative Z right = rewrite plusZeroRightNeutral right in Refl

425plusCommutative Z right = rewrite plusZeroRightNeutral right in Refl

425plusCommutative (S left) right =

426plusCommutative (S left) right =

426 let inductiveHypothesis = plusCommutative left right in

427 let inductiveHypothesis = plusCommutative left right in

427− rewrite inductiveHypothesis in

428+ rewrite inductiveHypothesis in

428 rewrite plusSuccRightSucc right left in Refl

429 rewrite plusSuccRightSucc right left in Refl

429

430

430total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

431total plusAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

@@ -450,21 +451,21 @@ total plusLeftCancel : (left : Nat) -> (right : Nat) -> (right' : Nat) ->

450plusLeftCancel Z right right' p = p

451plusLeftCancel Z right right' p = p

451plusLeftCancel (S left) right right' p =

452plusLeftCancel (S left) right right' p =

452 let inductiveHypothesis = plusLeftCancel left right right' in

453 let inductiveHypothesis = plusLeftCancel left right right' in

453− inductiveHypothesis (succInjective _ _ p)

454+ inductiveHypothesis (succInjective _ _ p)

454

455

455total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) ->

456total plusRightCancel : (left : Nat) -> (left' : Nat) -> (right : Nat) ->

456 (p : left + right = left' + right) -> left = left'

457 (p : left + right = left' + right) -> left = left'

457plusRightCancel left left' Z p = rewrite sym (plusZeroRightNeutral left) in

458plusRightCancel left left' Z p = rewrite sym (plusZeroRightNeutral left) in

458 rewrite sym (plusZeroRightNeutral left') in

459 rewrite sym (plusZeroRightNeutral left') in

459− p

460+ p

460plusRightCancel left left' (S right) p =

461plusRightCancel left left' (S right) p =

461− plusRightCancel left left' right

462+ plusRightCancel left left' right

462− (succInjective _ _ (rewrite plusSuccRightSucc left right in

463+ (succInjective _ _ (rewrite plusSuccRightSucc left right in

463 rewrite plusSuccRightSucc left' right in p))

464 rewrite plusSuccRightSucc left' right in p))

464

465

465total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) ->

466total plusLeftLeftRightZero : (left : Nat) -> (right : Nat) ->

466 (p : left + right = left) -> right = Z

467 (p : left + right = left) -> right = Z

467−plusLeftLeftRightZero Z right p = p

468+plusLeftLeftRightZero Z right p = p

468plusLeftLeftRightZero (S left) right p =

469plusLeftLeftRightZero (S left) right p =

469 plusLeftLeftRightZero left right (succInjective _ _ p)

470 plusLeftLeftRightZero left right (succInjective _ _ p)

470

471

@@ -481,7 +482,7 @@ total multRightSuccPlus : (left : Nat) -> (right : Nat) ->

481multRightSuccPlus Z right = Refl

482multRightSuccPlus Z right = Refl

482multRightSuccPlus (S left) right =

483multRightSuccPlus (S left) right =

483 let inductiveHypothesis = multRightSuccPlus left right in

484 let inductiveHypothesis = multRightSuccPlus left right in

484− rewrite inductiveHypothesis in

485+ rewrite inductiveHypothesis in

485 rewrite plusAssociative left right (mult left right) in

486 rewrite plusAssociative left right (mult left right) in

486 rewrite plusAssociative right left (mult left right) in

487 rewrite plusAssociative right left (mult left right) in

487 rewrite plusCommutative right left in

488 rewrite plusCommutative right left in

@@ -493,11 +494,11 @@ multLeftSuccPlus left right = Refl

493

494

494total multCommutative : (left : Nat) -> (right : Nat) ->

495total multCommutative : (left : Nat) -> (right : Nat) ->

495 left * right = right * left

496 left * right = right * left

496−multCommutative Z right = rewrite multZeroRightZero right in Refl

497+multCommutative Z right = rewrite multZeroRightZero right in Refl

497multCommutative (S left) right =

498multCommutative (S left) right =

498 let inductiveHypothesis = multCommutative left right in

499 let inductiveHypothesis = multCommutative left right in

499 rewrite inductiveHypothesis in

500 rewrite inductiveHypothesis in

500− rewrite multRightSuccPlus right left in

501+ rewrite multRightSuccPlus right left in

501 Refl

502 Refl

502

503

503total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

504total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

@@ -505,7 +506,7 @@ total multDistributesOverPlusRight : (left : Nat) -> (centre : Nat) -> (right :

505multDistributesOverPlusRight Z centre right = Refl

506multDistributesOverPlusRight Z centre right = Refl

506multDistributesOverPlusRight (S left) centre right =

507multDistributesOverPlusRight (S left) centre right =

507 let inductiveHypothesis = multDistributesOverPlusRight left centre right in

508 let inductiveHypothesis = multDistributesOverPlusRight left centre right in

508− rewrite inductiveHypothesis in

509+ rewrite inductiveHypothesis in

509 rewrite plusAssociative (plus centre (mult left centre)) right (mult left right) in

510 rewrite plusAssociative (plus centre (mult left centre)) right (mult left right) in

510 rewrite sym (plusAssociative centre (mult left centre) right) in

511 rewrite sym (plusAssociative centre (mult left centre) right) in

511 rewrite plusCommutative (mult left centre) right in

512 rewrite plusCommutative (mult left centre) right in

@@ -527,7 +528,7 @@ total multAssociative : (left : Nat) -> (centre : Nat) -> (right : Nat) ->

527multAssociative Z centre right = Refl

528multAssociative Z centre right = Refl

528multAssociative (S left) centre right =

529multAssociative (S left) centre right =

529 let inductiveHypothesis = multAssociative left centre right in

530 let inductiveHypothesis = multAssociative left centre right in

530− rewrite inductiveHypothesis in

531+ rewrite inductiveHypothesis in

531 rewrite multDistributesOverPlusLeft centre (mult left centre) right in

532 rewrite multDistributesOverPlusLeft centre (mult left centre) right in

532 Refl

533 Refl

533

534

@@ -619,7 +620,7 @@ powerSuccPowerLeft base exp = Refl

619

620

620total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->

621total multPowerPowerPlus : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->

621 (power base exp) * (power base exp') = power base (exp + exp')

622 (power base exp) * (power base exp') = power base (exp + exp')

622−multPowerPowerPlus base Z exp' =

623+multPowerPowerPlus base Z exp' =

623 rewrite sym (plusZeroRightNeutral (power base exp')) in Refl

624 rewrite sym (plusZeroRightNeutral (power base exp')) in Refl

624multPowerPowerPlus base (S exp) exp' =

625multPowerPowerPlus base (S exp) exp' =

625 let inductiveHypothesis = multPowerPowerPlus base exp exp' in

626 let inductiveHypothesis = multPowerPowerPlus base exp exp' in

@@ -651,7 +652,7 @@ total powerPowerMultPower : (base : Nat) -> (exp : Nat) -> (exp' : Nat) ->

651powerPowerMultPower base exp Z = rewrite multZeroRightZero exp in Refl

652powerPowerMultPower base exp Z = rewrite multZeroRightZero exp in Refl

652powerPowerMultPower base exp (S exp') =

653powerPowerMultPower base exp (S exp') =

653 let inductiveHypothesis = powerPowerMultPower base exp exp' in

654 let inductiveHypothesis = powerPowerMultPower base exp exp' in

654− rewrite inductiveHypothesis in

655+ rewrite inductiveHypothesis in

655 rewrite multRightSuccPlus exp exp' in

656 rewrite multRightSuccPlus exp exp' in

656 rewrite sym (multPowerPowerPlus base exp (mult exp exp')) in

657 rewrite sym (multPowerPowerPlus base exp (mult exp exp')) in

657 Refl

658 Refl

@@ -664,7 +665,7 @@ total minusSuccPred : (left : Nat) -> (right : Nat) ->

664 minus left (S right) = pred (minus left right)

665 minus left (S right) = pred (minus left right)

665minusSuccPred Z right = Refl

666minusSuccPred Z right = Refl

666minusSuccPred (S left) Z =

667minusSuccPred (S left) Z =

667− rewrite minusZeroRight left in Refl

668+ rewrite minusZeroRight left in Refl

668minusSuccPred (S left) (S right) =

669minusSuccPred (S left) (S right) =

669 let inductiveHypothesis = minusSuccPred left right in

670 let inductiveHypothesis = minusSuccPred left right in

670 rewrite inductiveHypothesis in Refl

671 rewrite inductiveHypothesis in Refl

@@ -782,4 +783,3 @@ sucMinL (S l) = cong (sucMinL l)

782total sucMinR : (l : Nat) -> minimum l (S l) = l

783total sucMinR : (l : Nat) -> minimum l (S l) = l

783sucMinR Z = Refl

784sucMinR Z = Refl

784sucMinR (S l) = cong (sucMinR l)

785sucMinR (S l) = cong (sucMinR l)

785−

libs/prelude/Prelude/Pairs.idr+15−7

@@ -2,7 +2,7 @@ module Prelude.Pairs

2

3import Builtins

4

5−%access public

5+%access public export

6%default total

7

8swap : (a, b) -> (b, a)

@@ -14,7 +14,7 @@ using (a : Type, P : a -> Type)

14 data Exists : (P : a -> Type) -> Type where

15 Evidence : .(x : a) -> (pf : P x) -> Exists P

16

17− ||| Dependent pair where the second field is erased.

17+ ||| Dependent pair where the second field is erased.

18 data Subset : (a : Type) -> (P : a -> Type) -> Type where

19 Element : (x : a) -> .(pf : P x) -> Subset a P

20

@@ -34,12 +34,20 @@ using (a : Type, P : a -> Type)

34 getProof : (x : Subset a P) -> P (getWitness x)

35 getProof (Element x pf) = pf

36

37− namespace Sigma

37+ namespace DPair

38− getWitness : Sigma a P -> a

38+ fst : DPair a P -> a

39− getWitness (x ** pf) = x

39+ fst (x ** pf) = x

40

41− getProof : (x : Sigma a P) -> P (getWitness x)

41+ snd : (x : DPair a P) -> P (fst x)

42− getProof (x ** pf) = pf

42+ snd (x ** pf) = pf

43+

44+ getWitness : DPair a P -> a

45+ getWitness = fst

46+ %deprecate DPair.getWitness "This is being deprecated in favour of `fst`."

47+

48+ getProof : (x : DPair a P) -> P (fst x)

49+ getProof = snd

50+ %deprecate DPair.getProof "This is being deprecated in favour of `snd`."

43

51

44 -- Polymorphic (class-based) projections have been removed

52 -- Polymorphic (class-based) projections have been removed

45 -- because type-directed name disambiguation works better.

53 -- because type-directed name disambiguation works better.

libs/prelude/Prelude/Providers.idr+4−1

@@ -1,11 +1,14 @@

1module Prelude.Providers

2

3+import Prelude.Basics

3import Prelude.Functor

4import Prelude.Functor

4import Prelude.Applicative

5import Prelude.Applicative

5import Prelude.Monad

6import Prelude.Monad

6

7

8+%access public export

9+

7||| Type providers must build one of these in an IO computation.

10||| Type providers must build one of these in an IO computation.

8−public

11+public export

9data Provider : (a : Type) -> Type where

12data Provider : (a : Type) -> Type where

10 ||| Return a term to be spliced in

13 ||| Return a term to be spliced in

11 ||| @ x the term to be spliced (i.e. the proof)

14 ||| @ x the term to be spliced (i.e. the proof)

libs/prelude/Prelude/Show.idr+4−3

@@ -7,13 +7,15 @@ import Prelude.Bits

7import Prelude.Bool

8import Prelude.Cast

9import Prelude.Chars

10−import Prelude.Classes

10+import Prelude.Interfaces

11import Prelude.List

12import Prelude.Maybe

13import Prelude.Either

14import Prelude.Nat

15import Prelude.Strings

16

17+%access public export

18+

17%default total

19%default total

18

20

19||| The precedence of an Idris operator or syntactic context.

21||| The precedence of an Idris operator or syntactic context.

@@ -190,6 +192,5 @@ Show a => Show (Maybe a) where

190 showPrec d (Left x) = showCon d "Left" $ showArg x

192 showPrec d (Left x) = showCon d "Left" $ showArg x

191 showPrec d (Right x) = showCon d "Right" $ showArg x

193 showPrec d (Right x) = showCon d "Right" $ showArg x

192

194

193−(Show a, {y : a} -> Show (p y)) => Show (Sigma a p) where

195+(Show a, {y : a} -> Show (p y)) => Show (DPair a p) where

194 show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"

196 show (y ** prf) = "(" ++ show y ++ " ** " ++ show prf ++ ")"

195−

libs/prelude/Prelude/Stream.idr+7−3

@@ -9,7 +9,7 @@ import Prelude.Monad

9import Prelude.Nat

10import Prelude.List

11

12−%access public

12+%access public export

13%default total

14

15||| An infinite stream

@@ -62,8 +62,12 @@ index : Nat -> Stream a -> a

62index Z (x::xs) = x

63index (S k) (x::xs) = index k xs

64

65−||| Combine two streams element-wise using a function

65+||| Combine two streams element-wise using a function.

66+|||

67+||| @ f the function to combine elements with

68+||| @ xs the first stream of elements

69+||| @ ys the second stream of elements

66−zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c

70+zipWith : (f : a -> b -> c) -> (xs : Stream a) -> (ys : Stream b) -> Stream c

67zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

71zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

68

72

69||| Combine three streams by applying a function element-wise along them

73||| Combine three streams by applying a function element-wise along them

libs/prelude/Prelude/Strings.idr+4−3

@@ -8,7 +8,7 @@ import Prelude.Basics

8import Prelude.Bool

9import Prelude.Chars

10import Prelude.Cast

11−import Prelude.Classes

11+import Prelude.Interfaces

12import Prelude.Either

13import Prelude.Foldable

14import Prelude.Functor

@@ -17,6 +17,8 @@ import Prelude.Nat

17import Prelude.Monad

18import Decidable.Equality

19

20+%access public export

21+

20partial

22partial

21foldr1 : (a -> a -> a) -> List a -> a

23foldr1 : (a -> a -> a) -> List a -> a

22foldr1 _ [x] = x

24foldr1 _ [x] = x

@@ -112,7 +114,7 @@ strTail' x p = assert_total $ prim__strTail x

112-- we need the 'believe_me' because the operations are primitives

114-- we need the 'believe_me' because the operations are primitives

113strM : (x : String) -> StrM x

115strM : (x : String) -> StrM x

114strM x with (decEq (not (x == "")) True)

116strM x with (decEq (not (x == "")) True)

115− strM x | (Yes p) = really_believe_me $

117+ strM x | (Yes p) = really_believe_me $

116 StrCons (assert_total (strHead' x p))

118 StrCons (assert_total (strHead' x p))

117 (assert_total (strTail' x p))

119 (assert_total (strTail' x p))

118 strM x | (No p) = really_believe_me StrNil

120 strM x | (No p) = really_believe_me StrNil

@@ -364,4 +366,3 @@ partial

364nullStr : String -> IO Bool

366nullStr : String -> IO Bool

365nullStr p = do ok <- foreign FFI_C "isNull" (String -> IO Int) p

367nullStr p = do ok <- foreign FFI_C "isNull" (String -> IO Int) p

366 return (ok /= 0)

368 return (ok /= 0)

367−

libs/prelude/Prelude/Traversable.idr+2

@@ -7,6 +7,8 @@ import Prelude.Applicative

7import Prelude.Foldable

8import Prelude.Functor

9

10+%access public export

11+

10traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()

12traverse_ : (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()

11traverse_ f = foldr ((*>) . f) (pure ())

13traverse_ f = foldr ((*>) . f) (pure ())

12

14

libs/prelude/Prelude/Uninhabited.idr+2

@@ -5,6 +5,8 @@ module Prelude.Uninhabited

5

6import Builtins

7

8+%access public export

9+

8||| A canonical proof that some type is empty

10||| A canonical proof that some type is empty

9interface Uninhabited t where

11interface Uninhabited t where

10 ||| If I have a t, I've had a contradiction

12 ||| If I have a t, I've had a contradiction

libs/prelude/prelude.ipkg+1−2

@@ -4,7 +4,7 @@ opts = "--nobuiltins --total --no-elim-deprecation-warnings"

4modules = Builtins, Prelude, IO,

5

6 Prelude.Algebra, Prelude.Basics, Prelude.Bool, Prelude.Cast,

7− Prelude.Classes, Prelude.Nat, Prelude.List,

7+ Prelude.Interfaces, Prelude.Nat, Prelude.List,

8 Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either,

9 Prelude.Strings, Prelude.Chars, Prelude.Show, Prelude.Functor,

10 Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,

@@ -14,4 +14,3 @@ modules = Builtins, Prelude, IO,

14 Language.Reflection, Language.Reflection.Errors, Language.Reflection.Elab,

15

16 Decidable.Equality

17−

libs/pruviloj/Pruviloj/Core.idr+2

@@ -5,6 +5,8 @@ module Pruviloj.Core

5

6import Language.Reflection.Utils

7

8+%access public export

9+

8||| Run something for effects, throwing away the return value

10||| Run something for effects, throwing away the return value

9ignore : Functor f => f a -> f ()

11ignore : Functor f => f a -> f ()

10ignore x = map (const ()) x

12ignore x = map (const ()) x

libs/pruviloj/Pruviloj/Derive/DecEq.idr+1−1

@@ -133,7 +133,7 @@ mkRhs fn fam k =

133||| equality.

134|||

135||| @ fn the name of the function whose type has been declared

136−abstract partial -- because of mkRhs

136+export partial -- because of mkRhs

137deriveDecEq : (fn : TTName) -> Elab ()

138deriveDecEq fn =

139 do (_, Ref, sig') <- lookupTyExact fn

libs/pruviloj/Pruviloj/Derive/Eliminators.idr+1−1

@@ -248,7 +248,7 @@ getElimClauses info elimn ctors =

248 in traverse (\(i, con) => getElimClause info elimn methodCount con i)

249 (enumerate ctors)

250

251−abstract

251+export

252deriveElim : (tyn, elimn : TTName) -> Elab ()

253deriveElim tyn elimn =

254 do -- Begin with some basic sanity checking: the type name uniquely

libs/pruviloj/Pruviloj/Disjoint.idr+1−1

@@ -67,7 +67,7 @@ getDisjointness l r = exists <|> declare

67

68||| Solve a goal of the form `(C1 x1 x2 ... xn = C2 x1 x2 ... xn) ->

69||| Void` for disjoint constructors `C1` and `C2`.

70−public covering

70+public export covering

71disjoint : Elab ()

72disjoint =

73 do compute

libs/pruviloj/Pruviloj/Induction.idr+1−1

@@ -125,7 +125,7 @@ makeMotive info sub subjTy goal =

125

126||| Perform induction on some expression to solve the current

127||| goal. Return a list of new holes to be solved.

128−public

128+public export

129induction : Raw -> Elab (List TTName)

130induction subj =

131 do g <- goalType

libs/pruviloj/Pruviloj/Injective.idr+1−1

@@ -92,7 +92,7 @@ countBinders _ = Z

92|||

93||| @ tm the equality to exploit injectivity on

94||| @ n the name at which to bind the result

95−covering public

95+covering public export

96injective : (tm : Raw) -> (n : TTName) -> Elab ()

97injective tm n =

98 do (_, ty) <- check !getEnv tm

libs/pruviloj/Pruviloj/Internals.idr+2−10

@@ -7,6 +7,8 @@ import Pruviloj.Renamers

7

8import Data.Vect

9

10+%access public export

11+

10||| Get the name of a reflected type constructor argument.

12||| Get the name of a reflected type constructor argument.

11tyConArgName : TyConArg -> TTName

13tyConArgName : TyConArg -> TTName

12tyConArgName (TyConParameter a) = name a

14tyConArgName (TyConParameter a) = name a

@@ -24,16 +26,6 @@ updateTyConArgTy f (TyConParameter a) =

24updateTyConArgTy f (TyConIndex a) =

26updateTyConArgTy f (TyConIndex a) =

25 TyConIndex (record {type = f (type a) } a)

27 TyConIndex (record {type = f (type a) } a)

26

28

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−

37||| Grab the binders from around a term, alpha-converting to make

29||| Grab the binders from around a term, alpha-converting to make

38||| their names unique

30||| their names unique

39partial

31partial

libs/pruviloj/Pruviloj/Internals/TyConInfo.idr+1−1

@@ -6,7 +6,7 @@ import Pruviloj.Renamers

6

7import Language.Reflection.Utils

8

9−

9+%access public export

10

11||| A representation of a type constructor in which all argument names

12||| are made unique and they are separated into params and then

libs/pruviloj/Pruviloj/Renamers.idr+2

@@ -2,6 +2,8 @@ module Pruviloj.Renamers

2

3import Language.Reflection.Utils

4

5+%access public export

6+

5||| A renamer keeps track of names to be substituted

7||| A renamer keeps track of names to be substituted

6Renamer : Type

8Renamer : Type

7Renamer = TTName -> Maybe TTName

9Renamer = TTName -> Maybe TTName

main/Main.hs+41−44

@@ -4,12 +4,10 @@ import System.Console.Haskeline

4import System.IO

5import System.Environment

6import System.Exit

7−import System.FilePath ((</>), addTrailingPathSeparator)

8import System.Directory

7import System.Directory

9

8

10import Data.Maybe

9import Data.Maybe

11import Data.Version

10import Data.Version

12−import Control.Monad.Trans.State.Strict ( execStateT, get, put )

13import Control.Monad ( when )

11import Control.Monad ( when )

14

12

15import Idris.Core.TT

13import Idris.Core.TT

@@ -44,66 +42,65 @@ main = do opts <- runArgParser

44

42

45runIdris :: [Opt] -> Idris ()

43runIdris :: [Opt] -> Idris ()

46runIdris opts = do

44runIdris opts = do

47− runIO setupBundledCC

45+ runIO setupBundledCC

48− when (ShowLoggingCats `elem` opts) $ runIO showLoggingCats

46+ when (ShowLoggingCats `elem` opts) $ runIO showLoggingCats

49− when (ShowIncs `elem` opts) $ runIO showIncs

47+ when (ShowIncs `elem` opts) $ runIO showIncs

50− when (ShowLibs `elem` opts) $ runIO showLibs

48+ when (ShowLibs `elem` opts) $ runIO showLibs

51− when (ShowLibdir `elem` opts) $ runIO showLibdir

49+ when (ShowLibdir `elem` opts) $ runIO showLibdir

52− when (ShowPkgs `elem` opts) $ runIO showPkgs

50+ when (ShowPkgs `elem` opts) $ runIO showPkgs

53− case opt getClient opts of

51+ case opt getClient opts of

54− [] -> return ()

52+ [] -> return ()

55− (c:_) -> do setVerbose False

53+ (c:_) -> do setVerbose False

56− setQuiet True

54+ setQuiet True

57− runIO $ runClient (getPort opts) c

55+ runIO $ runClient (getPort opts) c

58− runIO $ exitWith ExitSuccess

56+ runIO exitSuccess

59− case opt getPkgCheck opts of

57+ case opt getPkgCheck opts of

60− [] -> return ()

58+ [] -> return ()

61− fs -> do runIO $ mapM_ (checkPkg (WarnOnly `elem` opts) True) fs

59+ fs -> do runIO $ mapM_ (checkPkg (WarnOnly `elem` opts) True) fs

62− runIO $ exitWith ExitSuccess

60+ runIO exitSuccess

63− case opt getPkgClean opts of

61+ case opt getPkgClean opts of

64− [] -> return ()

62+ [] -> return ()

65− fs -> do runIO $ mapM_ cleanPkg fs

63+ fs -> do runIO $ mapM_ cleanPkg fs

66− runIO $ exitWith ExitSuccess

64+ runIO exitSuccess

67− case opt getPkgMkDoc opts of -- IdrisDoc

65+ case opt getPkgMkDoc opts of -- IdrisDoc

68− [] -> return ()

66+ [] -> return ()

69− fs -> do runIO $ mapM_ documentPkg fs

67+ fs -> do runIO $ mapM_ documentPkg fs

70− runIO $ exitWith ExitSuccess

68+ runIO exitSuccess

71− case opt getPkgTest opts of

69+ case opt getPkgTest opts of

72− [] -> return ()

70+ [] -> return ()

73− fs -> do runIO $ mapM_ testPkg fs

71+ fs -> do runIO $ mapM_ testPkg fs

74− runIO $ exitWith ExitSuccess

72+ runIO exitSuccess

75− case opt getPkg opts of

73+ case opt getPkg opts of

76− [] -> case opt getPkgREPL opts of

74+ [] -> case opt getPkgREPL opts of

77− [] -> idrisMain opts

75+ [] -> idrisMain opts

78− [f] -> replPkg f

76+ [f] -> replPkg f

79− _ -> ifail "Too many packages"

77+ _ -> ifail "Too many packages"

80− fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs

78+ fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs

81

79

82showver :: IO b

80showver :: IO b

83showver = do putStrLn $ "Idris version " ++ ver

81showver = do putStrLn $ "Idris version " ++ ver

84− exitWith ExitSuccess

82+ exitSuccess

85

83

86showLibs :: IO b

84showLibs :: IO b

87showLibs = do libFlags <- getLibFlags

85showLibs = do libFlags <- getLibFlags

88 putStrLn $ unwords libFlags

86 putStrLn $ unwords libFlags

89− exitWith ExitSuccess

87+ exitSuccess

90

88

91showLibdir :: IO b

89showLibdir :: IO b

92−showLibdir = do dir <- getIdrisLibDir

90+showLibdir = do putStrLn =<< getIdrisLibDir

93− putStrLn dir

91+ exitSuccess

94− exitWith ExitSuccess

95

92

96showIncs :: IO b

93showIncs :: IO b

97showIncs = do incFlags <- getIncFlags

94showIncs = do incFlags <- getIncFlags

98 putStrLn $ unwords incFlags

95 putStrLn $ unwords incFlags

99− exitWith ExitSuccess

96+ exitSuccess

100

97

101-- | List idris packages installed

98-- | List idris packages installed

102showPkgs :: IO b

99showPkgs :: IO b

103showPkgs = do mapM putStrLn =<< installedPackages

100showPkgs = do mapM putStrLn =<< installedPackages

104− exitWith ExitSuccess

101+ exitSuccess

105

102

106showLoggingCats :: IO b

103showLoggingCats :: IO b

107showLoggingCats = do

104showLoggingCats = do

108 putStrLn loggingCatsStr

105 putStrLn loggingCatsStr

109− exitWith ExitSuccess

106+ exitSuccess

rts/getline.c+32−31

@@ -38,40 +38,41 @@

38ssize_t

39getdelim(char **buf, size_t *bufsiz, int delimiter, FILE *fp)

40{

41− char *ptr, *eptr;

41+ char *ptr, *eptr;

42

43−

44− if (*buf == NULL || *bufsiz == 0) {

43+ if (*buf == NULL || *bufsiz == 0) {

45− *bufsiz = BUFSIZ;

44+ *bufsiz = BUFSIZ;

46− if ((*buf = malloc(*bufsiz)) == NULL)

45+ 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;

46+ return -1;

57 }

47 }

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+ }

58− *ptr++ = c;

59+ *ptr++ = c;

59− if (c == delimiter) {

60+ if (c == delimiter) {

60− *ptr = '\0';

61+ *ptr = '\0';

61− return ptr - *buf;

62+ return ptr - *buf;

62− }

63+ }

63− if (ptr + 2 >= eptr) {

64+ if (ptr + 2 >= eptr) {

64− char *nbuf;

65+ char *nbuf;

65− size_t nbufsiz = *bufsiz * 2;

66+ size_t nbufsiz = *bufsiz * 2;

66− ssize_t d = ptr - *buf;

67+ ssize_t d = ptr - *buf;

67− if ((nbuf = realloc(*buf, nbufsiz)) == NULL)

68+ if ((nbuf = realloc(*buf, nbufsiz)) == NULL)

68− return -1;

69+ return -1;

69− *buf = nbuf;

70+ *buf = nbuf;

70− *bufsiz = nbufsiz;

71+ *bufsiz = nbufsiz;

71− eptr = nbuf + nbufsiz;

72+ eptr = nbuf + nbufsiz;

72− ptr = nbuf + d;

73+ ptr = nbuf + d;

74+ }

73 }

75 }

74− }

75}

76}

76

77

77ssize_t

78ssize_t

rts/idris_bitstring.c+121−86

@@ -5,7 +5,7 @@

5VAL idris_b8CopyForGC(VM *vm, VAL a) {

6 uint8_t A = a->info.bits8;

7 VAL cl = allocate(sizeof(Closure), 1);

8− SETTY(cl, BITS8);

8+ SETTY(cl, CT_BITS8);

9 cl->info.bits8 = A;

10 return cl;

11}

@@ -13,7 +13,7 @@ VAL idris_b8CopyForGC(VM *vm, VAL a) {

13VAL idris_b16CopyForGC(VM *vm, VAL a) {

14 uint16_t A = a->info.bits16;

15 VAL cl = allocate(sizeof(Closure), 1);

16− SETTY(cl, BITS16);

16+ SETTY(cl, CT_BITS16);

17 cl->info.bits16 = A;

18 return cl;

19}

@@ -21,7 +21,7 @@ VAL idris_b16CopyForGC(VM *vm, VAL a) {

21VAL idris_b32CopyForGC(VM *vm, VAL a) {

22 uint32_t A = a->info.bits32;

23 VAL cl = allocate(sizeof(Closure), 1);

24− SETTY(cl, BITS32);

24+ SETTY(cl, CT_BITS32);

25 cl->info.bits32 = A;

26 return cl;

27}

@@ -29,7 +29,7 @@ VAL idris_b32CopyForGC(VM *vm, VAL a) {

29VAL idris_b64CopyForGC(VM *vm, VAL a) {

30 uint64_t A = a->info.bits64;

31 VAL cl = allocate(sizeof(Closure), 1);

32− SETTY(cl, BITS64);

32+ SETTY(cl, CT_BITS64);

33 cl->info.bits64 = A;

34 return cl;

35}

@@ -37,7 +37,7 @@ VAL idris_b64CopyForGC(VM *vm, VAL a) {

37VAL idris_b8(VM *vm, VAL a) {

38 uint8_t A = GETINT(a);

39 VAL cl = allocate(sizeof(Closure), 0);

40− SETTY(cl, BITS8);

40+ SETTY(cl, CT_BITS8);

41 cl->info.bits8 = (uint8_t) A;

42 return cl;

43}

@@ -45,7 +45,7 @@ VAL idris_b8(VM *vm, VAL a) {

45VAL idris_b16(VM *vm, VAL a) {

46 uint16_t A = GETINT(a);

47 VAL cl = allocate(sizeof(Closure), 0);

48− SETTY(cl, BITS16);

48+ SETTY(cl, CT_BITS16);

49 cl->info.bits16 = (uint16_t) A;

50 return cl;

51}

@@ -53,7 +53,7 @@ VAL idris_b16(VM *vm, VAL a) {

53VAL idris_b32(VM *vm, VAL a) {

54 uint32_t A = GETINT(a);

55 VAL cl = allocate(sizeof(Closure), 0);

56− SETTY(cl, BITS32);

56+ SETTY(cl, CT_BITS32);

57 cl->info.bits32 = (uint32_t) A;

58 return cl;

59}

@@ -61,7 +61,7 @@ VAL idris_b32(VM *vm, VAL a) {

61VAL idris_b64(VM *vm, VAL a) {

62 uint64_t A = GETINT(a);

63 VAL cl = allocate(sizeof(Closure), 0);

64− SETTY(cl, BITS64);

64+ SETTY(cl, CT_BITS64);

65 cl->info.bits64 = (uint64_t) A;

66 return cl;

67}

@@ -72,28 +72,28 @@ VAL idris_castB32Int(VM *vm, VAL a) {

72

73VAL idris_b8const(VM *vm, uint8_t a) {

74 VAL cl = allocate(sizeof(Closure), 0);

75− SETTY(cl, BITS8);

75+ SETTY(cl, CT_BITS8);

76 cl->info.bits8 = a;

77 return cl;

78}

79

80VAL idris_b16const(VM *vm, uint16_t a) {

81 VAL cl = allocate(sizeof(Closure), 0);

82− SETTY(cl, BITS16);

82+ SETTY(cl, CT_BITS16);

83 cl->info.bits16 = a;

84 return cl;

85}

86

87VAL idris_b32const(VM *vm, uint32_t a) {

88 VAL cl = allocate(sizeof(Closure), 0);

89− SETTY(cl, BITS32);

89+ SETTY(cl, CT_BITS32);

90 cl->info.bits32 = a;

91 return cl;

92}

93

94VAL idris_b64const(VM *vm, uint64_t a) {

95 VAL cl = allocate(sizeof(Closure), 0);

96− SETTY(cl, BITS64);

96+ SETTY(cl, CT_BITS64);

97 cl->info.bits64 = a;

98 return cl;

99}

@@ -102,7 +102,7 @@ VAL idris_b8Plus(VM *vm, VAL a, VAL b) {

102 uint8_t A = a->info.bits8;

103 uint8_t B = b->info.bits8;

104 VAL cl = allocate(sizeof(Closure), 0);

105− SETTY(cl, BITS8);

105+ SETTY(cl, CT_BITS8);

106 cl->info.bits8 = A + B;

107 return cl;

108}

@@ -111,7 +111,7 @@ VAL idris_b8Minus(VM *vm, VAL a, VAL b) {

111 uint8_t A = a->info.bits8;

112 uint8_t B = b->info.bits8;

113 VAL cl = allocate(sizeof(Closure), 0);

114− SETTY(cl, BITS8);

114+ SETTY(cl, CT_BITS8);

115 cl->info.bits8 = A - B;

116 return cl;

117}

@@ -120,7 +120,7 @@ VAL idris_b8Times(VM *vm, VAL a, VAL b) {

120 uint8_t A = a->info.bits8;

121 uint8_t B = b->info.bits8;

122 VAL cl = allocate(sizeof(Closure), 0);

123− SETTY(cl, BITS8);

123+ SETTY(cl, CT_BITS8);

124 cl->info.bits8 = A * B;

125 return cl;

126}

@@ -129,7 +129,7 @@ VAL idris_b8UDiv(VM *vm, VAL a, VAL b) {

129 uint8_t A = a->info.bits8;

130 uint8_t B = b->info.bits8;

131 VAL cl = allocate(sizeof(Closure), 0);

132− SETTY(cl, BITS8);

132+ SETTY(cl, CT_BITS8);

133 cl->info.bits8 = A / B;

134 return cl;

135}

@@ -138,7 +138,7 @@ VAL idris_b8SDiv(VM *vm, VAL a, VAL b) {

138 uint8_t A = a->info.bits8;

139 uint8_t B = b->info.bits8;

140 VAL cl = allocate(sizeof(Closure), 0);

141− SETTY(cl, BITS8);

141+ SETTY(cl, CT_BITS8);

142 cl->info.bits8 = (uint8_t) (((int8_t) A) / ((int8_t) B));

143 return cl;

144}

@@ -147,7 +147,7 @@ VAL idris_b8URem(VM *vm, VAL a, VAL b) {

147 uint8_t A = a->info.bits8;

148 uint8_t B = b->info.bits8;

149 VAL cl = allocate(sizeof(Closure), 0);

150− SETTY(cl, BITS8);

150+ SETTY(cl, CT_BITS8);

151 cl->info.bits8 = A % B;

152 return cl;

153}

@@ -156,7 +156,7 @@ VAL idris_b8SRem(VM *vm, VAL a, VAL b) {

156 uint8_t A = a->info.bits8;

157 uint8_t B = b->info.bits8;

158 VAL cl = allocate(sizeof(Closure), 0);

159− SETTY(cl, BITS8);

159+ SETTY(cl, CT_BITS8);

160 cl->info.bits8 = (uint8_t) (((int8_t) A) % ((int8_t) B));

161 return cl;

162}

@@ -184,7 +184,7 @@ VAL idris_b8Gte(VM *vm, VAL a, VAL b) {

184VAL idris_b8Compl(VM *vm, VAL a) {

185 uint8_t A = a->info.bits8;

186 VAL cl = allocate(sizeof(Closure), 0);

187− SETTY(cl, BITS8);

187+ SETTY(cl, CT_BITS8);

188 cl->info.bits8 = ~ A;

189 return cl;

190}

@@ -193,7 +193,7 @@ VAL idris_b8And(VM *vm, VAL a, VAL b) {

193 uint8_t A = a->info.bits8;

194 uint8_t B = b->info.bits8;

195 VAL cl = allocate(sizeof(Closure), 0);

196− SETTY(cl, BITS8);

196+ SETTY(cl, CT_BITS8);

197 cl->info.bits8 = A & B;

198 return cl;

199}

@@ -202,7 +202,7 @@ VAL idris_b8Or(VM *vm, VAL a, VAL b) {

202 uint8_t A = a->info.bits8;

203 uint8_t B = b->info.bits8;

204 VAL cl = allocate(sizeof(Closure), 0);

205− SETTY(cl, BITS8);

205+ SETTY(cl, CT_BITS8);

206 cl->info.bits8 = A | B;

207 return cl;

208}

@@ -211,7 +211,7 @@ VAL idris_b8Xor(VM *vm, VAL a, VAL b) {

211 uint8_t A = a->info.bits8;

212 uint8_t B = b->info.bits8;

213 VAL cl = allocate(sizeof(Closure), 0);

214− SETTY(cl, BITS8);

214+ SETTY(cl, CT_BITS8);

215 cl->info.bits8 = A ^ B;

216 return cl;

217}

@@ -220,7 +220,7 @@ VAL idris_b8Shl(VM *vm, VAL a, VAL b) {

220 uint8_t A = a->info.bits8;

221 uint8_t B = b->info.bits8;

222 VAL cl = allocate(sizeof(Closure), 0);

223− SETTY(cl, BITS8);

223+ SETTY(cl, CT_BITS8);

224 cl->info.bits8 = A << B;

225 return cl;

226}

@@ -229,7 +229,7 @@ VAL idris_b8LShr(VM *vm, VAL a, VAL b) {

229 uint8_t A = a->info.bits8;

230 uint8_t B = b->info.bits8;

231 VAL cl = allocate(sizeof(Closure), 0);

232− SETTY(cl, BITS8);

232+ SETTY(cl, CT_BITS8);

233 cl->info.bits8 = A >> B;

234 return cl;

235}

@@ -238,7 +238,7 @@ VAL idris_b8AShr(VM *vm, VAL a, VAL b) {

238 uint8_t A = a->info.bits8;

239 uint8_t B = b->info.bits8;

240 VAL cl = allocate(sizeof(Closure), 0);

241− SETTY(cl, BITS8);

241+ SETTY(cl, CT_BITS8);

242 cl->info.bits8 = (uint8_t) (((int8_t) A) >> ((int8_t) B));

243 return cl;

244}

@@ -247,7 +247,7 @@ VAL idris_b16Plus(VM *vm, VAL a, VAL b) {

247 uint16_t A = a->info.bits16;

248 uint16_t B = b->info.bits16;

249 VAL cl = allocate(sizeof(Closure), 0);

250− SETTY(cl, BITS16);

250+ SETTY(cl, CT_BITS16);

251 cl->info.bits16 = A + B;

252 return cl;

253}

@@ -256,7 +256,7 @@ VAL idris_b16Minus(VM *vm, VAL a, VAL b) {

256 uint16_t A = a->info.bits16;

257 uint16_t B = b->info.bits16;

258 VAL cl = allocate(sizeof(Closure), 0);

259− SETTY(cl, BITS16);

259+ SETTY(cl, CT_BITS16);

260 cl->info.bits16 = A - B;

261 return cl;

262}

@@ -265,7 +265,7 @@ VAL idris_b16Times(VM *vm, VAL a, VAL b) {

265 uint16_t A = a->info.bits16;

266 uint16_t B = b->info.bits16;

267 VAL cl = allocate(sizeof(Closure), 0);

268− SETTY(cl, BITS16);

268+ SETTY(cl, CT_BITS16);

269 cl->info.bits16 = A * B;

270 return cl;

271}

@@ -274,7 +274,7 @@ VAL idris_b16UDiv(VM *vm, VAL a, VAL b) {

274 uint16_t A = a->info.bits16;

275 uint16_t B = b->info.bits16;

276 VAL cl = allocate(sizeof(Closure), 0);

277− SETTY(cl, BITS16);

277+ SETTY(cl, CT_BITS16);

278 cl->info.bits16 = A / B;

279 return cl;

280}

@@ -283,7 +283,7 @@ VAL idris_b16SDiv(VM *vm, VAL a, VAL b) {

283 uint16_t A = a->info.bits16;

284 uint16_t B = b->info.bits16;

285 VAL cl = allocate(sizeof(Closure), 0);

286− SETTY(cl, BITS16);

286+ SETTY(cl, CT_BITS16);

287 cl->info.bits16 = (uint16_t) (((int16_t) A) / ((int16_t) B));

288 return cl;

289}

@@ -292,7 +292,7 @@ VAL idris_b16URem(VM *vm, VAL a, VAL b) {

292 uint16_t A = a->info.bits16;

293 uint16_t B = b->info.bits16;

294 VAL cl = allocate(sizeof(Closure), 0);

295− SETTY(cl, BITS16);

295+ SETTY(cl, CT_BITS16);

296 cl->info.bits16 = A % B;

297 return cl;

298}

@@ -301,7 +301,7 @@ VAL idris_b16SRem(VM *vm, VAL a, VAL b) {

301 uint16_t A = a->info.bits16;

302 uint16_t B = b->info.bits16;

303 VAL cl = allocate(sizeof(Closure), 0);

304− SETTY(cl, BITS16);

304+ SETTY(cl, CT_BITS16);

305 cl->info.bits16 = (uint16_t) (((int16_t) A) % ((int16_t) B));

306 return cl;

307}

@@ -329,7 +329,7 @@ VAL idris_b16Gte(VM *vm, VAL a, VAL b) {

329VAL idris_b16Compl(VM *vm, VAL a) {

330 uint16_t A = a->info.bits16;

331 VAL cl = allocate(sizeof(Closure), 0);

332− SETTY(cl, BITS16);

332+ SETTY(cl, CT_BITS16);

333 cl->info.bits16 = ~ A;

334 return cl;

335}

@@ -338,7 +338,7 @@ VAL idris_b16And(VM *vm, VAL a, VAL b) {

338 uint16_t A = a->info.bits16;

339 uint16_t B = b->info.bits16;

340 VAL cl = allocate(sizeof(Closure), 0);

341− SETTY(cl, BITS16);

341+ SETTY(cl, CT_BITS16);

342 cl->info.bits16 = A & B;

343 return cl;

344}

@@ -347,7 +347,7 @@ VAL idris_b16Or(VM *vm, VAL a, VAL b) {

347 uint16_t A = a->info.bits16;

348 uint16_t B = b->info.bits16;

349 VAL cl = allocate(sizeof(Closure), 0);

350− SETTY(cl, BITS16);

350+ SETTY(cl, CT_BITS16);

351 cl->info.bits16 = A | B;

352 return cl;

353}

@@ -356,7 +356,7 @@ VAL idris_b16Xor(VM *vm, VAL a, VAL b) {

356 uint16_t A = a->info.bits16;

357 uint16_t B = b->info.bits16;

358 VAL cl = allocate(sizeof(Closure), 0);

359− SETTY(cl, BITS16);

359+ SETTY(cl, CT_BITS16);

360 cl->info.bits16 = A ^ B;

361 return cl;

362}

@@ -365,7 +365,7 @@ VAL idris_b16Shl(VM *vm, VAL a, VAL b) {

365 uint16_t A = a->info.bits16;

366 uint16_t B = b->info.bits16;

367 VAL cl = allocate(sizeof(Closure), 0);

368− SETTY(cl, BITS16);

368+ SETTY(cl, CT_BITS16);

369 cl->info.bits16 = A << B;

370 return cl;

371}

@@ -374,7 +374,7 @@ VAL idris_b16LShr(VM *vm, VAL a, VAL b) {

374 uint16_t A = a->info.bits16;

375 uint16_t B = b->info.bits16;

376 VAL cl = allocate(sizeof(Closure), 0);

377− SETTY(cl, BITS16);

377+ SETTY(cl, CT_BITS16);

378 cl->info.bits16 = A >> B;

379 return cl;

380}

@@ -383,7 +383,7 @@ VAL idris_b16AShr(VM *vm, VAL a, VAL b) {

383 uint16_t A = a->info.bits16;

384 uint16_t B = b->info.bits16;

385 VAL cl = allocate(sizeof(Closure), 0);

386− SETTY(cl, BITS16);

386+ SETTY(cl, CT_BITS16);

387 cl->info.bits16 = (uint16_t) (((int16_t) A) >> ((int16_t) B));

388 return cl;

389}

@@ -392,7 +392,7 @@ VAL idris_b32Plus(VM *vm, VAL a, VAL b) {

392 uint32_t A = a->info.bits32;

393 uint32_t B = b->info.bits32;

394 VAL cl = allocate(sizeof(Closure), 0);

395− SETTY(cl, BITS32);

395+ SETTY(cl, CT_BITS32);

396 cl->info.bits32 = A + B;

397 return cl;

398}

@@ -401,7 +401,7 @@ VAL idris_b32Minus(VM *vm, VAL a, VAL b) {

401 uint32_t A = a->info.bits32;

402 uint32_t B = b->info.bits32;

403 VAL cl = allocate(sizeof(Closure), 0);

404− SETTY(cl, BITS32);

404+ SETTY(cl, CT_BITS32);

405 cl->info.bits32 = A - B;

406 return cl;

407}

@@ -410,7 +410,7 @@ VAL idris_b32Times(VM *vm, VAL a, VAL b) {

410 uint32_t A = a->info.bits32;

411 uint32_t B = b->info.bits32;

412 VAL cl = allocate(sizeof(Closure), 0);

413− SETTY(cl, BITS32);

413+ SETTY(cl, CT_BITS32);

414 cl->info.bits32 = A * B;

415 return cl;

416}

@@ -419,7 +419,7 @@ VAL idris_b32UDiv(VM *vm, VAL a, VAL b) {

419 uint32_t A = a->info.bits32;

420 uint32_t B = b->info.bits32;

421 VAL cl = allocate(sizeof(Closure), 0);

422− SETTY(cl, BITS32);

422+ SETTY(cl, CT_BITS32);

423 cl->info.bits32 = A / B;

424 return cl;

425}

@@ -428,7 +428,7 @@ VAL idris_b32SDiv(VM *vm, VAL a, VAL b) {

428 uint32_t A = a->info.bits32;

429 uint32_t B = b->info.bits32;

430 VAL cl = allocate(sizeof(Closure), 0);

431− SETTY(cl, BITS32);

431+ SETTY(cl, CT_BITS32);

432 cl->info.bits32 = (uint32_t) (((int32_t) A) / ((int32_t) B));

433 return cl;

434}

@@ -437,7 +437,7 @@ VAL idris_b32URem(VM *vm, VAL a, VAL b) {

437 uint32_t A = a->info.bits32;

438 uint32_t B = b->info.bits32;

439 VAL cl = allocate(sizeof(Closure), 0);

440− SETTY(cl, BITS32);

440+ SETTY(cl, CT_BITS32);

441 cl->info.bits32 = A % B;

442 return cl;

443}

@@ -446,7 +446,7 @@ VAL idris_b32SRem(VM *vm, VAL a, VAL b) {

446 uint32_t A = a->info.bits32;

447 uint32_t B = b->info.bits32;

448 VAL cl = allocate(sizeof(Closure), 0);

449− SETTY(cl, BITS32);

449+ SETTY(cl, CT_BITS32);

450 cl->info.bits32 = (uint32_t) (((int32_t) A) % ((int32_t) B));

451 return cl;

452}

@@ -474,7 +474,7 @@ VAL idris_b32Gte(VM *vm, VAL a, VAL b) {

474VAL idris_b32Compl(VM *vm, VAL a) {

475 uint32_t A = a->info.bits32;

476 VAL cl = allocate(sizeof(Closure), 0);

477− SETTY(cl, BITS32);

477+ SETTY(cl, CT_BITS32);

478 cl->info.bits32 = ~ A;

479 return cl;

480}

@@ -483,7 +483,7 @@ VAL idris_b32And(VM *vm, VAL a, VAL b) {

483 uint32_t A = a->info.bits32;

484 uint32_t B = b->info.bits32;

485 VAL cl = allocate(sizeof(Closure), 0);

486− SETTY(cl, BITS32);

486+ SETTY(cl, CT_BITS32);

487 cl->info.bits32 = A & B;

488 return cl;

489}

@@ -492,7 +492,7 @@ VAL idris_b32Or(VM *vm, VAL a, VAL b) {

492 uint32_t A = a->info.bits32;

493 uint32_t B = b->info.bits32;

494 VAL cl = allocate(sizeof(Closure), 0);

495− SETTY(cl, BITS32);

495+ SETTY(cl, CT_BITS32);

496 cl->info.bits32 = A | B;

497 return cl;

498}

@@ -501,7 +501,7 @@ VAL idris_b32Xor(VM *vm, VAL a, VAL b) {

501 uint32_t A = a->info.bits32;

502 uint32_t B = b->info.bits32;

503 VAL cl = allocate(sizeof(Closure), 0);

504− SETTY(cl, BITS32);

504+ SETTY(cl, CT_BITS32);

505 cl->info.bits32 = A ^ B;

506 return cl;

507}

@@ -510,7 +510,7 @@ VAL idris_b32Shl(VM *vm, VAL a, VAL b) {

510 uint32_t A = a->info.bits32;

511 uint32_t B = b->info.bits32;

512 VAL cl = allocate(sizeof(Closure), 0);

513− SETTY(cl, BITS32);

513+ SETTY(cl, CT_BITS32);

514 cl->info.bits32 = A << B;

515 return cl;

516}

@@ -519,7 +519,7 @@ VAL idris_b32LShr(VM *vm, VAL a, VAL b) {

519 uint32_t A = a->info.bits32;

520 uint32_t B = b->info.bits32;

521 VAL cl = allocate(sizeof(Closure), 0);

522− SETTY(cl, BITS32);

522+ SETTY(cl, CT_BITS32);

523 cl->info.bits32 = A >> B;

524 return cl;

525}

@@ -528,7 +528,7 @@ VAL idris_b32AShr(VM *vm, VAL a, VAL b) {

528 uint32_t A = a->info.bits32;

529 uint32_t B = b->info.bits32;

530 VAL cl = allocate(sizeof(Closure), 0);

531− SETTY(cl, BITS32);

531+ SETTY(cl, CT_BITS32);

532 cl->info.bits32 = (uint32_t) (((int32_t)A) >> ((int32_t)B));

533 return cl;

534}

@@ -537,7 +537,7 @@ VAL idris_b64Plus(VM *vm, VAL a, VAL b) {

537 uint64_t A = a->info.bits64;

538 uint64_t B = b->info.bits64;

539 VAL cl = allocate(sizeof(Closure), 0);

540− SETTY(cl, BITS64);

540+ SETTY(cl, CT_BITS64);

541 cl->info.bits64 = A + B;

542 return cl;

543}

@@ -546,7 +546,7 @@ VAL idris_b64Minus(VM *vm, VAL a, VAL b) {

546 uint64_t A = a->info.bits64;

547 uint64_t B = b->info.bits64;

548 VAL cl = allocate(sizeof(Closure), 0);

549− SETTY(cl, BITS64);

549+ SETTY(cl, CT_BITS64);

550 cl->info.bits64 = A - B;

551 return cl;

552}

@@ -555,7 +555,7 @@ VAL idris_b64Times(VM *vm, VAL a, VAL b) {

555 uint64_t A = a->info.bits64;

556 uint64_t B = b->info.bits64;

557 VAL cl = allocate(sizeof(Closure), 0);

558− SETTY(cl, BITS64);

558+ SETTY(cl, CT_BITS64);

559 cl->info.bits64 = A * B;

560 return cl;

561}

@@ -564,7 +564,7 @@ VAL idris_b64UDiv(VM *vm, VAL a, VAL b) {

564 uint64_t A = a->info.bits64;

565 uint64_t B = b->info.bits64;

566 VAL cl = allocate(sizeof(Closure), 0);

567− SETTY(cl, BITS64);

567+ SETTY(cl, CT_BITS64);

568 cl->info.bits64 = A / B;

569 return cl;

570}

@@ -573,7 +573,7 @@ VAL idris_b64SDiv(VM *vm, VAL a, VAL b) {

573 uint64_t A = a->info.bits64;

574 uint64_t B = b->info.bits64;

575 VAL cl = allocate(sizeof(Closure), 0);

576− SETTY(cl, BITS64);

576+ SETTY(cl, CT_BITS64);

577 cl->info.bits64 = (uint64_t) (((int64_t) A) / ((int64_t) B));

578 return cl;

579}

@@ -582,7 +582,7 @@ VAL idris_b64URem(VM *vm, VAL a, VAL b) {

582 uint64_t A = a->info.bits64;

583 uint64_t B = b->info.bits64;

584 VAL cl = allocate(sizeof(Closure), 0);

585− SETTY(cl, BITS64);

585+ SETTY(cl, CT_BITS64);

586 cl->info.bits64 = A % B;

587 return cl;

588}

@@ -591,7 +591,7 @@ VAL idris_b64SRem(VM *vm, VAL a, VAL b) {

591 uint64_t A = a->info.bits64;

592 uint64_t B = b->info.bits64;

593 VAL cl = allocate(sizeof(Closure), 0);

594− SETTY(cl, BITS64);

594+ SETTY(cl, CT_BITS64);

595 cl->info.bits64 = (uint64_t) (((int64_t) A) % ((int64_t) B));

596 return cl;

597}

@@ -619,7 +619,7 @@ VAL idris_b64Gte(VM *vm, VAL a, VAL b) {

619VAL idris_b64Compl(VM *vm, VAL a) {

620 uint64_t A = a->info.bits64;

621 VAL cl = allocate(sizeof(Closure), 0);

622− SETTY(cl, BITS64);

622+ SETTY(cl, CT_BITS64);

623 cl->info.bits64 = ~ A;

624 return cl;

625}

@@ -628,7 +628,7 @@ VAL idris_b64And(VM *vm, VAL a, VAL b) {

628 uint64_t A = a->info.bits64;

629 uint64_t B = b->info.bits64;

630 VAL cl = allocate(sizeof(Closure), 0);

631− SETTY(cl, BITS64);

631+ SETTY(cl, CT_BITS64);

632 cl->info.bits64 = A & B;

633 return cl;

634}

@@ -637,7 +637,7 @@ VAL idris_b64Or(VM *vm, VAL a, VAL b) {

637 uint64_t A = a->info.bits64;

638 uint64_t B = b->info.bits64;

639 VAL cl = allocate(sizeof(Closure), 0);

640− SETTY(cl, BITS64);

640+ SETTY(cl, CT_BITS64);

641 cl->info.bits64 = A | B;

642 return cl;

643}

@@ -646,7 +646,7 @@ VAL idris_b64Xor(VM *vm, VAL a, VAL b) {

646 uint64_t A = a->info.bits64;

647 uint64_t B = b->info.bits64;

648 VAL cl = allocate(sizeof(Closure), 0);

649− SETTY(cl, BITS64);

649+ SETTY(cl, CT_BITS64);

650 cl->info.bits64 = A ^ B;

651 return cl;

652}

@@ -655,7 +655,7 @@ VAL idris_b64Shl(VM *vm, VAL a, VAL b) {

655 uint64_t A = a->info.bits64;

656 uint64_t B = b->info.bits64;

657 VAL cl = allocate(sizeof(Closure), 0);

658− SETTY(cl, BITS64);

658+ SETTY(cl, CT_BITS64);

659 cl->info.bits64 = A << B;

660 return cl;

661}

@@ -664,7 +664,7 @@ VAL idris_b64LShr(VM *vm, VAL a, VAL b) {

664 uint64_t A = a->info.bits64;

665 uint64_t B = b->info.bits64;

666 VAL cl = allocate(sizeof(Closure), 0);

667− SETTY(cl, BITS64);

667+ SETTY(cl, CT_BITS64);

668 cl->info.bits64 = A >> B;

669 return cl;

670}

@@ -673,7 +673,7 @@ VAL idris_b64AShr(VM *vm, VAL a, VAL b) {

673 uint64_t A = a->info.bits64;

674 uint64_t B = b->info.bits64;

675 VAL cl = allocate(sizeof(Closure), 0);

676− SETTY(cl, BITS64);

676+ SETTY(cl, CT_BITS64);

677 cl->info.bits64 = (uint64_t) (((int64_t) A) >> ((int64_t) B));

678 return cl;

679}

@@ -681,7 +681,7 @@ VAL idris_b64AShr(VM *vm, VAL a, VAL b) {

681VAL idris_b8Z16(VM *vm, VAL a) {

682 uint8_t A = a->info.bits8;

683 VAL cl = allocate(sizeof(Closure), 0);

684− SETTY(cl, BITS16);

684+ SETTY(cl, CT_BITS16);

685 cl->info.bits16 = (uint16_t) A;

686 return cl;

687}

@@ -689,7 +689,7 @@ VAL idris_b8Z16(VM *vm, VAL a) {

689VAL idris_b8Z32(VM *vm, VAL a) {

690 uint8_t A = a->info.bits8;

691 VAL cl = allocate(sizeof(Closure), 0);

692− SETTY(cl, BITS32);

692+ SETTY(cl, CT_BITS32);

693 cl->info.bits32 = (uint32_t) A;

694 return cl;

695}

@@ -697,7 +697,7 @@ VAL idris_b8Z32(VM *vm, VAL a) {

697VAL idris_b8Z64(VM *vm, VAL a) {

698 uint8_t A = a->info.bits8;

699 VAL cl = allocate(sizeof(Closure), 0);

700− SETTY(cl, BITS64);

700+ SETTY(cl, CT_BITS64);

701 cl->info.bits64 = (uint64_t) A;

702 return cl;

703}

@@ -705,7 +705,7 @@ VAL idris_b8Z64(VM *vm, VAL a) {

705VAL idris_b8S16(VM *vm, VAL a) {

706 uint8_t A = a->info.bits8;

707 VAL cl = allocate(sizeof(Closure), 0);

708− SETTY(cl, BITS16);

708+ SETTY(cl, CT_BITS16);

709 cl->info.bits16 = (uint16_t) (int16_t) (int8_t) A;

710 return cl;

711}

@@ -713,7 +713,7 @@ VAL idris_b8S16(VM *vm, VAL a) {

713VAL idris_b8S32(VM *vm, VAL a) {

714 uint8_t A = a->info.bits8;

715 VAL cl = allocate(sizeof(Closure), 0);

716− SETTY(cl, BITS32);

716+ SETTY(cl, CT_BITS32);

717 cl->info.bits32 = (uint32_t) (int32_t) (int8_t) A;

718 return cl;

719}

@@ -721,7 +721,7 @@ VAL idris_b8S32(VM *vm, VAL a) {

721VAL idris_b8S64(VM *vm, VAL a) {

722 uint8_t A = a->info.bits8;

723 VAL cl = allocate(sizeof(Closure), 0);

724− SETTY(cl, BITS64);

724+ SETTY(cl, CT_BITS64);

725 cl->info.bits64 = (uint64_t) (int64_t) (int8_t) A;

726 return cl;

727}

@@ -729,7 +729,7 @@ VAL idris_b8S64(VM *vm, VAL a) {

729VAL idris_b16Z32(VM *vm, VAL a) {

730 uint16_t A = a->info.bits16;

731 VAL cl = allocate(sizeof(Closure), 0);

732− SETTY(cl, BITS32);

732+ SETTY(cl, CT_BITS32);

733 cl->info.bits32 = (uint32_t) A;

734 return cl;

735}

@@ -737,7 +737,7 @@ VAL idris_b16Z32(VM *vm, VAL a) {

737VAL idris_b16Z64(VM *vm, VAL a) {

738 uint16_t A = a->info.bits16;

739 VAL cl = allocate(sizeof(Closure), 0);

740− SETTY(cl, BITS64);

740+ SETTY(cl, CT_BITS64);

741 cl->info.bits64 = (uint64_t) A;

742 return cl;

743}

@@ -745,7 +745,7 @@ VAL idris_b16Z64(VM *vm, VAL a) {

745VAL idris_b16S32(VM *vm, VAL a) {

746 uint16_t A = a->info.bits16;

747 VAL cl = allocate(sizeof(Closure), 0);

748− SETTY(cl, BITS32);

748+ SETTY(cl, CT_BITS32);

749 cl->info.bits32 = (uint32_t) (int32_t) (int16_t) A;

750 return cl;

751}

@@ -753,7 +753,7 @@ VAL idris_b16S32(VM *vm, VAL a) {

753VAL idris_b16S64(VM *vm, VAL a) {

754 uint16_t A = a->info.bits16;

755 VAL cl = allocate(sizeof(Closure), 0);

756− SETTY(cl, BITS64);

756+ SETTY(cl, CT_BITS64);

757 cl->info.bits64 = (uint64_t) (int64_t) (int16_t) A;

758 return cl;

759}

@@ -761,7 +761,7 @@ VAL idris_b16S64(VM *vm, VAL a) {

761VAL idris_b16T8(VM *vm, VAL a) {

762 uint16_t A = a->info.bits16;

763 VAL cl = allocate(sizeof(Closure), 0);

764− SETTY(cl, BITS8);

764+ SETTY(cl, CT_BITS8);

765 cl->info.bits8 = (uint8_t) A;

766 return cl;

767}

@@ -769,7 +769,7 @@ VAL idris_b16T8(VM *vm, VAL a) {

769VAL idris_b32Z64(VM *vm, VAL a) {

770 uint32_t A = a->info.bits32;

771 VAL cl = allocate(sizeof(Closure), 0);

772− SETTY(cl, BITS64);

772+ SETTY(cl, CT_BITS64);

773 cl->info.bits64 = (uint64_t) A;

774 return cl;

775}

@@ -777,7 +777,7 @@ VAL idris_b32Z64(VM *vm, VAL a) {

777VAL idris_b32S64(VM *vm, VAL a) {

778 uint32_t A = a->info.bits32;

779 VAL cl = allocate(sizeof(Closure), 0);

780− SETTY(cl, BITS64);

780+ SETTY(cl, CT_BITS64);

781 cl->info.bits64 = (uint64_t) (int64_t) (int32_t) A;

782 return cl;

783}

@@ -785,7 +785,7 @@ VAL idris_b32S64(VM *vm, VAL a) {

785VAL idris_b32T8(VM *vm, VAL a) {

786 uint32_t A = a->info.bits32;

787 VAL cl = allocate(sizeof(Closure), 0);

788− SETTY(cl, BITS8);

788+ SETTY(cl, CT_BITS8);

789 cl->info.bits8 = (uint8_t) A;

790 return cl;

791}

@@ -793,7 +793,7 @@ VAL idris_b32T8(VM *vm, VAL a) {

793VAL idris_b32T16(VM *vm, VAL a) {

794 uint32_t A = a->info.bits32;

795 VAL cl = allocate(sizeof(Closure), 0);

796− SETTY(cl, BITS16);

796+ SETTY(cl, CT_BITS16);

797 cl->info.bits16 = (uint16_t) A;

798 return cl;

799}

@@ -801,7 +801,7 @@ VAL idris_b32T16(VM *vm, VAL a) {

801VAL idris_b64T8(VM *vm, VAL a) {

802 uint64_t A = a->info.bits64;

803 VAL cl = allocate(sizeof(Closure), 0);

804− SETTY(cl, BITS8);

804+ SETTY(cl, CT_BITS8);

805 cl->info.bits8 = (uint8_t) A;

806 return cl;

807}

@@ -809,7 +809,7 @@ VAL idris_b64T8(VM *vm, VAL a) {

809VAL idris_b64T16(VM *vm, VAL a) {

810 uint64_t A = a->info.bits64;

811 VAL cl = allocate(sizeof(Closure), 0);

812− SETTY(cl, BITS16);

812+ SETTY(cl, CT_BITS16);

813 cl->info.bits16 = (uint16_t) A;

814 return cl;

815}

@@ -817,8 +817,43 @@ VAL idris_b64T16(VM *vm, VAL a) {

817VAL idris_b64T32(VM *vm, VAL a) {

818 uint64_t A = a->info.bits64;

819 VAL cl = allocate(sizeof(Closure), 0);

820− SETTY(cl, BITS32);

820+ SETTY(cl, CT_BITS32);

821 cl->info.bits32 = (uint32_t) A;

822 return cl;

823}

824

825+VAL idris_peekB8(VM* vm, VAL ptr, VAL offset) {

826+ return MKB8(vm, *(uint8_t*)(GETPTR(ptr) + GETINT(offset)));

827+}

828+

829+VAL idris_pokeB8(VAL ptr, VAL offset, VAL data) {

830+ *(uint8_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS8(data);

831+ return MKINT(0);

832+}

833+

834+VAL idris_peekB16(VM* vm, VAL ptr, VAL offset) {

835+ return MKB16(vm, *(uint16_t*)(GETPTR(ptr) + GETINT(offset)));

836+}

837+

838+VAL idris_pokeB16(VAL ptr, VAL offset, VAL data) {

839+ *(uint16_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS16(data);

840+ return MKINT(0);

841+}

842+

843+VAL idris_peekB32(VM* vm, VAL ptr, VAL offset) {

844+ return MKB32(vm, *(uint32_t*)(GETPTR(ptr) + GETINT(offset)));

845+}

846+

847+VAL idris_pokeB32(VAL ptr, VAL offset, VAL data) {

848+ *(uint32_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS32(data);

849+ return MKINT(0);

850+}

851+

852+VAL idris_peekB64(VM* vm, VAL ptr, VAL offset) {

853+ return MKB64(vm, *(uint64_t*)(GETPTR(ptr) + GETINT(offset)));

854+}

855+

856+VAL idris_pokeB64(VAL ptr, VAL offset, VAL data) {

857+ *(uint64_t*)(GETPTR(ptr) + GETINT(offset)) = GETBITS64(data);

858+ return MKINT(0);

859+}

rts/idris_bitstring.h+10

@@ -126,4 +126,14 @@ VAL idris_b64T8(VM *vm, VAL a);

126VAL idris_b64T16(VM *vm, VAL a);

127VAL idris_b64T32(VM *vm, VAL a);

128

129+// memory access

130+VAL idris_peekB8(VM* vm, VAL ptr, VAL offset);

131+VAL idris_pokeB8(VAL ptr, VAL offset, VAL data);

132+VAL idris_peekB16(VM* vm, VAL ptr, VAL offset);

133+VAL idris_pokeB16(VAL ptr, VAL offset, VAL data);

134+VAL idris_peekB32(VM* vm, VAL ptr, VAL offset);

135+VAL idris_pokeB32(VAL ptr, VAL offset, VAL data);

136+VAL idris_peekB64(VM* vm, VAL ptr, VAL offset);

137+VAL idris_pokeB64(VAL ptr, VAL offset, VAL data);

138+

129#endif

139#endif

rts/idris_gc.c+24−17

@@ -10,7 +10,7 @@ VAL copy(VM* vm, VAL x) {

10 return x;

11 }

12 switch(GETTY(x)) {

13− case CON:

13+ case CT_CON:

14 ar = CARITY(x);

15 if (ar == 0 && CTAG(x) < 256) {

16 return x;

@@ -21,49 +21,53 @@ VAL copy(VM* vm, VAL x) {

21 }

22 }

23 break;

24− case FLOAT:

24+ case CT_FLOAT:

25 cl = MKFLOATc(vm, x->info.f);

26 break;

27− case STRING:

27+ case CT_STRING:

28 cl = MKSTRc(vm, x->info.str);

29 break;

30− case STROFFSET:

30+ case CT_STROFFSET:

31 cl = MKSTROFFc(vm, x->info.str_offset);

32 break;

33− case BIGINT:

33+ case CT_BIGINT:

34 cl = MKBIGMc(vm, x->info.ptr);

35 break;

36− case PTR:

36+ case CT_PTR:

37 cl = MKPTRc(vm, x->info.ptr);

38 break;

39− case MANAGEDPTR:

39+ case CT_MANAGEDPTR:

40 cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);

41 break;

42− case BITS8:

42+ case CT_BITS8:

43 cl = idris_b8CopyForGC(vm, x);

44 break;

45− case BITS16:

45+ case CT_BITS16:

46 cl = idris_b16CopyForGC(vm, x);

47 break;

48− case BITS32:

48+ case CT_BITS32:

49 cl = idris_b32CopyForGC(vm, x);

50 break;

51− case BITS64:

51+ case CT_BITS64:

52 cl = idris_b64CopyForGC(vm, x);

53 break;

54− case FWD:

54+ case CT_FWD:

55 return x->info.ptr;

56− case RAWDATA:

56+ case CT_RAWDATA:

57 {

58 size_t size = x->info.size + sizeof(Closure);

59 cl = allocate(size, 0);

60 memcpy(cl, x, size);

61 }

62 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;

63 default:

67 default:

64 break;

68 break;

65 }

69 }

66− SETTY(x, FWD);

70+ SETTY(x, CT_FWD);

67 x->info.ptr = cl;

71 x->info.ptr = cl;

68 return cl;

72 return cl;

69}

73}

@@ -76,16 +80,16 @@ void cheney(VM *vm) {

76 while(scan < vm->heap.next) {

80 while(scan < vm->heap.next) {

77 size_t inc = *((size_t*)scan);

81 size_t inc = *((size_t*)scan);

78 VAL heap_item = (VAL)(scan+sizeof(size_t));

82 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

80 switch(GETTY(heap_item)) {

84 switch(GETTY(heap_item)) {

81− case CON:

85+ case CT_CON:

82 ar = ARITY(heap_item);

86 ar = ARITY(heap_item);

83 for(i = 0; i < ar; ++i) {

87 for(i = 0; i < ar; ++i) {

84 VAL newptr = copy(vm, heap_item->info.c.args[i]);

88 VAL newptr = copy(vm, heap_item->info.c.args[i]);

85 heap_item->info.c.args[i] = newptr;

89 heap_item->info.c.args[i] = newptr;

86 }

90 }

87 break;

91 break;

88− case STROFFSET:

92+ case CT_STROFFSET:

89 heap_item->info.str_offset->str

93 heap_item->info.str_offset->str

90 = copy(vm, heap_item->info.str_offset->str);

94 = copy(vm, heap_item->info.str_offset->str);

91 break;

95 break;

@@ -133,6 +137,9 @@ void idris_gc(VM* vm) {

133 vm->heap.size += vm->heap.growth;

137 vm->heap.size += vm->heap.growth;

134 }

138 }

135

139

140+ // finally, sweep the C heap

141+ c_heap_sweep(&vm->c_heap);

142+

136 STATS_LEAVE_GC(vm->stats, vm->heap.size, vm->heap.next - vm->heap.heap)

143 STATS_LEAVE_GC(vm->stats, vm->heap.size, vm->heap.next - vm->heap.heap)

137 HEAP_CHECK(vm)

144 HEAP_CHECK(vm)

138}

145}

rts/idris_gmp.c+31−18

@@ -33,7 +33,7 @@ VAL MKBIGC(VM* vm, char* val) {

33 mpz_init(*bigint);

34 mpz_set_str(*bigint, val, 10);

35

36− SETTY(cl, BIGINT);

36+ SETTY(cl, CT_BIGINT);

37 cl -> info.ptr = (void*)bigint;

38

39 return cl;

@@ -50,7 +50,7 @@ VAL MKBIGM(VM* vm, void* big) {

50 mpz_init(*bigint);

51 mpz_set(*bigint, *((mpz_t*)big));

52

53− SETTY(cl, BIGINT);

53+ SETTY(cl, CT_BIGINT);

54 cl -> info.ptr = (void*)bigint;

55

56 return cl;

@@ -66,7 +66,7 @@ VAL MKBIGMc(VM* vm, void* big) {

66

67 mpz_init_set(*bigint, *((mpz_t*)big));

68

69− SETTY(cl, BIGINT);

69+ SETTY(cl, CT_BIGINT);

70 cl -> info.ptr = (void*)bigint;

71

72 return cl;

@@ -82,7 +82,7 @@ VAL MKBIGUI(VM* vm, unsigned long val) {

82

83 mpz_init_set_ui(*bigint, val);

84

85− SETTY(cl, BIGINT);

85+ SETTY(cl, CT_BIGINT);

86 cl -> info.ptr = (void*)bigint;

87

88 return cl;

@@ -98,7 +98,7 @@ VAL MKBIGSI(VM* vm, signed long val) {

98

99 mpz_init_set_si(*bigint, val);

100

101− SETTY(cl, BIGINT);

101+ SETTY(cl, CT_BIGINT);

102 cl -> info.ptr = (void*)bigint;

103

104 return cl;

@@ -116,14 +116,14 @@ VAL GETBIG(VM * vm, VAL x) {

116 mpz_init(*bigint);

117 mpz_set_si(*bigint, GETINT(x));

118

119− SETTY(cl, BIGINT);

119+ SETTY(cl, CT_BIGINT);

120 cl -> info.ptr = (void*)bigint;

121

122 return cl;

123 } else {

124 idris_doneAlloc();

125 switch(GETTY(x)) {

126− case FWD:

126+ case CT_FWD:

127 return GETBIG(vm, x->info.ptr);

128 default:

129 return x;

@@ -139,7 +139,7 @@ VAL bigAdd(VM* vm, VAL x, VAL y) {

139 idris_doneAlloc();

140 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

141 mpz_add(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

142− SETTY(cl, BIGINT);

142+ SETTY(cl, CT_BIGINT);

143 cl -> info.ptr = (void*)bigint;

144 return cl;

145}

@@ -152,7 +152,7 @@ VAL bigSub(VM* vm, VAL x, VAL y) {

152 idris_doneAlloc();

153 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

154 mpz_sub(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

155− SETTY(cl, BIGINT);

155+ SETTY(cl, CT_BIGINT);

156 cl -> info.ptr = (void*)bigint;

157 return cl;

158}

@@ -165,7 +165,7 @@ VAL bigMul(VM* vm, VAL x, VAL y) {

165 idris_doneAlloc();

166 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

167 mpz_mul(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

168− SETTY(cl, BIGINT);

168+ SETTY(cl, CT_BIGINT);

169 cl -> info.ptr = (void*)bigint;

170 return cl;

171}

@@ -178,7 +178,7 @@ VAL bigDiv(VM* vm, VAL x, VAL y) {

178 idris_doneAlloc();

179 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

180 mpz_tdiv_q(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

181− SETTY(cl, BIGINT);

181+ SETTY(cl, CT_BIGINT);

182 cl -> info.ptr = (void*)bigint;

183 return cl;

184}

@@ -191,7 +191,7 @@ VAL bigMod(VM* vm, VAL x, VAL y) {

191 idris_doneAlloc();

192 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

193 mpz_mod(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

194− SETTY(cl, BIGINT);

194+ SETTY(cl, CT_BIGINT);

195 cl -> info.ptr = (void*)bigint;

196 return cl;

197}

@@ -204,7 +204,7 @@ VAL bigAnd(VM* vm, VAL x, VAL y) {

204 idris_doneAlloc();

205 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

206 mpz_and(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

207− SETTY(cl, BIGINT);

207+ SETTY(cl, CT_BIGINT);

208 cl -> info.ptr = (void*)bigint;

209 return cl;

210}

@@ -217,7 +217,7 @@ VAL bigOr(VM* vm, VAL x, VAL y) {

217 idris_doneAlloc();

218 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

219 mpz_ior(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

220− SETTY(cl, BIGINT);

220+ SETTY(cl, CT_BIGINT);

221 cl -> info.ptr = (void*)bigint;

222 return cl;

223}

@@ -230,7 +230,7 @@ VAL bigShiftLeft(VM* vm, VAL x, VAL y) {

230 idris_doneAlloc();

231 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

232 mpz_mul_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));

233− SETTY(cl, BIGINT);

233+ SETTY(cl, CT_BIGINT);

234 cl -> info.ptr = (void*)bigint;

235 return cl;

236}

@@ -244,7 +244,7 @@ VAL bigLShiftRight(VM* vm, VAL x, VAL y) {

244 idris_doneAlloc();

245 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

246 mpz_fdiv_q_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));

247− SETTY(cl, BIGINT);

247+ SETTY(cl, CT_BIGINT);

248 cl -> info.ptr = (void*)bigint;

249 return cl;

250}

@@ -257,7 +257,7 @@ VAL bigAShiftRight(VM* vm, VAL x, VAL y) {

257 idris_doneAlloc();

258 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

259 mpz_fdiv_q_2exp(*bigint, GETMPZ(GETBIG(vm,x)), GETINT(y));

260− SETTY(cl, BIGINT);

260+ SETTY(cl, CT_BIGINT);

261 cl -> info.ptr = (void*)bigint;

262 return cl;

263}

@@ -473,7 +473,7 @@ VAL idris_castFloatBig(VM* vm, VAL f) {

473

474 mpz_init_set_d(*bigint, val);

475

476− SETTY(cl, BIGINT);

476+ SETTY(cl, CT_BIGINT);

477 cl -> info.ptr = (void*)bigint;

478

479 return cl;

@@ -488,3 +488,16 @@ VAL idris_castBigStr(VM* vm, VAL i) {

488 return MKSTR(vm, str);

489}

490

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);

43VAL idris_bigShiftLeft(VM* vm, VAL x, VAL y);

44VAL idris_bigShiftRight(VM* vm, VAL x, VAL y);

45

46+uint64_t idris_truncBigB64(const mpz_t bi);

47+

46#define GETMPZ(x) *((mpz_t*)((x)->info.ptr))

48#define GETMPZ(x) *((mpz_t*)((x)->info.ptr))

47

49

48#endif

50#endif

rts/idris_heap.c+105−5

@@ -1,12 +1,112 @@

1#include "idris_heap.h"

2#include "idris_rts.h"

3+#include "idris_gc.h"

3

4

4#include <stdlib.h>

5#include <stdlib.h>

5#include <stddef.h>

6#include <stddef.h>

6#include <stdio.h>

7#include <stdio.h>

8+#include <assert.h>

7

9

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+}

8

108

9−/* Used for initializing the heap. */

109+/* Used for initializing the FP heap. */

10void alloc_heap(Heap * h, size_t heap_size, size_t growth, char * old)

110void alloc_heap(Heap * h, size_t heap_size, size_t growth, char * old)

11{

111{

12 char * mem = malloc(heap_size);

112 char * mem = malloc(heap_size);

@@ -86,7 +186,7 @@ void heap_check_pointers(Heap * heap) {

86 VAL heap_item = (VAL)(scan + sizeof(size_t));

186 VAL heap_item = (VAL)(scan + sizeof(size_t));

87

187

88 switch(GETTY(heap_item)) {

188 switch(GETTY(heap_item)) {

89− case CON:

189+ case CT_CON:

90 {

190 {

91 int ar = ARITY(heap_item);

191 int ar = ARITY(heap_item);

92 int i = 0;

192 int i = 0;

@@ -107,7 +207,7 @@ void heap_check_pointers(Heap * heap) {

107 if (!(ptr < heap_item)) {

207 if (!(ptr < heap_item)) {

108 fprintf(stderr,

208 fprintf(stderr,

109 "RTS ERROR: heap unidirectionality broken:" \

209 "RTS ERROR: heap unidirectionality broken:" \

110− "<CON %p> <FIELD %p>\n",

210+ "<CT_CON %p> <FIELD %p>\n",

111 heap_item, ptr);

211 heap_item, ptr);

112 exit(EXIT_FAILURE);

212 exit(EXIT_FAILURE);

113 }

213 }

@@ -116,9 +216,9 @@ void heap_check_pointers(Heap * heap) {

116 }

216 }

117 break;

217 break;

118 }

218 }

119− case FWD:

219+ case CT_FWD:

120 // Check for artifacts after cheney gc.

220 // 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");

122 exit(EXIT_FAILURE);

222 exit(EXIT_FAILURE);

123 break;

223 break;

124 default:

224 default:

rts/idris_heap.h+82

@@ -1,8 +1,90 @@

1#ifndef _IDRIS_HEAP_H

2#define _IDRIS_HEAP_H

3

4+#include <stdbool.h>

4#include <stddef.h>

5#include <stddef.h>

5

6

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+

6typedef struct {

88typedef struct {

7 char* next; // Next allocated chunk. Should always (heap <= next < end).

89 char* next; // Next allocated chunk. Should always (heap <= next < end).

8 char* heap; // Point to bottom of heap

90 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,

35

36 alloc_heap(&(vm->heap), heap_size, heap_size, NULL);

37

38+ c_heap_init(&vm->c_heap);

39+

38 vm->ret = NULL;

40 vm->ret = NULL;

39 vm->reg1 = NULL;

41 vm->reg1 = NULL;

40#ifdef HAS_PTHREAD

42#ifdef HAS_PTHREAD

@@ -78,13 +80,29 @@ VM* idris_vm() {

78 return vm;

80 return vm;

79}

81}

80

82

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+

81void close_vm(VM* vm) {

92void close_vm(VM* vm) {

82 terminate(vm);

93 terminate(vm);

83}

94}

84

95

85−void init_threadkeys() {

86#ifdef HAS_PTHREAD

96#ifdef HAS_PTHREAD

97+void create_key() {

87 pthread_key_create(&vm_key, (void*)free_key);

98 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);

88#endif

106#endif

89}

107}

90

108

@@ -108,12 +126,13 @@ Stats terminate(VM* vm) {

108#endif

126#endif

109 free(vm->valstack);

127 free(vm->valstack);

110 free_heap(&(vm->heap));

128 free_heap(&(vm->heap));

129+ c_heap_destroy(&(vm->c_heap));

111#ifdef HAS_PTHREAD

130#ifdef HAS_PTHREAD

112 pthread_mutex_destroy(&(vm -> inbox_lock));

131 pthread_mutex_destroy(&(vm -> inbox_lock));

113 pthread_mutex_destroy(&(vm -> inbox_block));

132 pthread_mutex_destroy(&(vm -> inbox_block));

114 pthread_cond_destroy(&(vm -> inbox_waiting));

133 pthread_cond_destroy(&(vm -> inbox_waiting));

115#endif

134#endif

116− // free(vm);

135+ // free(vm);

117 // Set the VM as inactive, so that if any message gets sent to it

136 // Set the VM as inactive, so that if any message gets sent to it

118 // it will not get there, rather than crash the entire system.

137 // it will not get there, rather than crash the entire system.

119 // (TODO: We really need to be cleverer than this if we're going to

138 // (TODO: We really need to be cleverer than this if we're going to

@@ -124,6 +143,17 @@ Stats terminate(VM* vm) {

124 return stats;

143 return stats;

125}

144}

126

145

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+

127void idris_requireAlloc(size_t size) {

157void idris_requireAlloc(size_t size) {

128#ifdef HAS_PTHREAD

158#ifdef HAS_PTHREAD

129 VM* vm = pthread_getspecific(vm_key);

159 VM* vm = pthread_getspecific(vm_key);

@@ -158,7 +188,7 @@ int space(VM* vm, size_t size) {

158

188

159void* idris_alloc(size_t size) {

189void* idris_alloc(size_t size) {

160 Closure* cl = (Closure*) allocate(sizeof(Closure)+size, 0);

190 Closure* cl = (Closure*) allocate(sizeof(Closure)+size, 0);

161− SETTY(cl, RAWDATA);

191+ SETTY(cl, CT_RAWDATA);

162 cl->info.size = size;

192 cl->info.size = size;

163 return (void*)cl+sizeof(Closure);

193 return (void*)cl+sizeof(Closure);

164}

194}

@@ -223,7 +253,7 @@ void* allocate(size_t size, int outerlock) {

223void* allocCon(VM* vm, int arity, int outer) {

253void* allocCon(VM* vm, int arity, int outer) {

224 Closure* cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*arity,

254 Closure* cl = allocate(vm, sizeof(Closure) + sizeof(VAL)*arity,

225 outer);

255 outer);

226− SETTY(cl, CON);

256+ SETTY(cl, CT_CON);

227

257

228 cl -> info.c.arity = arity;

258 cl -> info.c.arity = arity;

229// cl -> info.c.tag = 42424242;

259// cl -> info.c.tag = 42424242;

@@ -234,7 +264,7 @@ void* allocCon(VM* vm, int arity, int outer) {

234

264

235VAL MKFLOAT(VM* vm, double val) {

265VAL MKFLOAT(VM* vm, double val) {

236 Closure* cl = allocate(sizeof(Closure), 0);

266 Closure* cl = allocate(sizeof(Closure), 0);

237− SETTY(cl, FLOAT);

267+ SETTY(cl, CT_FLOAT);

238 cl -> info.f = val;

268 cl -> info.f = val;

239 return cl;

269 return cl;

240}

270}

@@ -248,7 +278,7 @@ VAL MKSTR(VM* vm, const char* str) {

248 }

278 }

249 Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +

279 Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +

250 sizeof(char)*len, 0);

280 sizeof(char)*len, 0);

251− SETTY(cl, STRING);

281+ SETTY(cl, CT_STRING);

252 cl -> info.str = (char*)cl + sizeof(Closure);

282 cl -> info.str = (char*)cl + sizeof(Closure);

253 if (str == NULL) {

283 if (str == NULL) {

254 cl->info.str = NULL;

284 cl->info.str = NULL;

@@ -264,9 +294,25 @@ char* GETSTROFF(VAL stroff) {

264 return (root->str->info.str + root->offset);

294 return (root->str->info.str + root->offset);

265}

295}

266

296

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+

267VAL MKPTR(VM* vm, void* ptr) {

313VAL MKPTR(VM* vm, void* ptr) {

268 Closure* cl = allocate(sizeof(Closure), 0);

314 Closure* cl = allocate(sizeof(Closure), 0);

269− SETTY(cl, PTR);

315+ SETTY(cl, CT_PTR);

270 cl -> info.ptr = ptr;

316 cl -> info.ptr = ptr;

271 return cl;

317 return cl;

272}

318}

@@ -274,7 +320,7 @@ VAL MKPTR(VM* vm, void* ptr) {

274VAL MKMPTR(VM* vm, void* ptr, size_t size) {

320VAL MKMPTR(VM* vm, void* ptr, size_t size) {

275 Closure* cl = allocate(sizeof(Closure) +

321 Closure* cl = allocate(sizeof(Closure) +

276 sizeof(ManagedPtr) + size, 0);

322 sizeof(ManagedPtr) + size, 0);

277− SETTY(cl, MANAGEDPTR);

323+ SETTY(cl, CT_MANAGEDPTR);

278 cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

324 cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

279 cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

325 cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

280 memcpy(cl->info.mptr->data, ptr, size);

326 memcpy(cl->info.mptr->data, ptr, size);

@@ -284,7 +330,7 @@ VAL MKMPTR(VM* vm, void* ptr, size_t size) {

284

330

285VAL MKFLOATc(VM* vm, double val) {

331VAL MKFLOATc(VM* vm, double val) {

286 Closure* cl = allocate(sizeof(Closure), 1);

332 Closure* cl = allocate(sizeof(Closure), 1);

287− SETTY(cl, FLOAT);

333+ SETTY(cl, CT_FLOAT);

288 cl -> info.f = val;

334 cl -> info.f = val;

289 return cl;

335 return cl;

290}

336}

@@ -292,7 +338,7 @@ VAL MKFLOATc(VM* vm, double val) {

292VAL MKSTRc(VM* vm, char* str) {

338VAL MKSTRc(VM* vm, char* str) {

293 Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +

339 Closure* cl = allocate(sizeof(Closure) + // Type) + sizeof(char*) +

294 sizeof(char)*strlen(str)+1, 1);

340 sizeof(char)*strlen(str)+1, 1);

295− SETTY(cl, STRING);

341+ SETTY(cl, CT_STRING);

296 cl -> info.str = (char*)cl + sizeof(Closure);

342 cl -> info.str = (char*)cl + sizeof(Closure);

297

343

298 strcpy(cl -> info.str, str);

344 strcpy(cl -> info.str, str);

@@ -301,7 +347,7 @@ VAL MKSTRc(VM* vm, char* str) {

301

347

302VAL MKPTRc(VM* vm, void* ptr) {

348VAL MKPTRc(VM* vm, void* ptr) {

303 Closure* cl = allocate(sizeof(Closure), 1);

349 Closure* cl = allocate(sizeof(Closure), 1);

304− SETTY(cl, PTR);

350+ SETTY(cl, CT_PTR);

305 cl -> info.ptr = ptr;

351 cl -> info.ptr = ptr;

306 return cl;

352 return cl;

307}

353}

@@ -309,7 +355,7 @@ VAL MKPTRc(VM* vm, void* ptr) {

309VAL MKMPTRc(VM* vm, void* ptr, size_t size) {

355VAL MKMPTRc(VM* vm, void* ptr, size_t size) {

310 Closure* cl = allocate(sizeof(Closure) +

356 Closure* cl = allocate(sizeof(Closure) +

311 sizeof(ManagedPtr) + size, 1);

357 sizeof(ManagedPtr) + size, 1);

312− SETTY(cl, MANAGEDPTR);

358+ SETTY(cl, CT_MANAGEDPTR);

313 cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

359 cl->info.mptr = (ManagedPtr*)((char*)cl + sizeof(Closure));

314 cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

360 cl->info.mptr->data = (char*)cl + sizeof(Closure) + sizeof(ManagedPtr);

315 memcpy(cl->info.mptr->data, ptr, size);

361 memcpy(cl->info.mptr->data, ptr, size);

@@ -319,28 +365,28 @@ VAL MKMPTRc(VM* vm, void* ptr, size_t size) {

319

365

320VAL MKB8(VM* vm, uint8_t bits8) {

366VAL MKB8(VM* vm, uint8_t bits8) {

321 Closure* cl = allocate(sizeof(Closure), 1);

367 Closure* cl = allocate(sizeof(Closure), 1);

322− SETTY(cl, BITS8);

368+ SETTY(cl, CT_BITS8);

323 cl -> info.bits8 = bits8;

369 cl -> info.bits8 = bits8;

324 return cl;

370 return cl;

325}

371}

326

372

327VAL MKB16(VM* vm, uint16_t bits16) {

373VAL MKB16(VM* vm, uint16_t bits16) {

328 Closure* cl = allocate(sizeof(Closure), 1);

374 Closure* cl = allocate(sizeof(Closure), 1);

329− SETTY(cl, BITS16);

375+ SETTY(cl, CT_BITS16);

330 cl -> info.bits16 = bits16;

376 cl -> info.bits16 = bits16;

331 return cl;

377 return cl;

332}

378}

333

379

334VAL MKB32(VM* vm, uint32_t bits32) {

380VAL MKB32(VM* vm, uint32_t bits32) {

335 Closure* cl = allocate(sizeof(Closure), 1);

381 Closure* cl = allocate(sizeof(Closure), 1);

336− SETTY(cl, BITS32);

382+ SETTY(cl, CT_BITS32);

337 cl -> info.bits32 = bits32;

383 cl -> info.bits32 = bits32;

338 return cl;

384 return cl;

339}

385}

340

386

341VAL MKB64(VM* vm, uint64_t bits64) {

387VAL MKB64(VM* vm, uint64_t bits64) {

342 Closure* cl = allocate(sizeof(Closure), 1);

388 Closure* cl = allocate(sizeof(Closure), 1);

343− SETTY(cl, BITS64);

389+ SETTY(cl, CT_BITS64);

344 cl -> info.bits64 = bits64;

390 cl -> info.bits64 = bits64;

345 return cl;

391 return cl;

346}

392}

@@ -382,18 +428,18 @@ void dumpVal(VAL v) {

382 return;

428 return;

383 }

429 }

384 switch(GETTY(v)) {

430 switch(GETTY(v)) {

385− case CON:

431+ case CT_CON:

386 printf("%d[", TAG(v));

432 printf("%d[", TAG(v));

387 for(i = 0; i < ARITY(v); ++i) {

433 for(i = 0; i < ARITY(v); ++i) {

388 dumpVal(v->info.c.args[i]);

434 dumpVal(v->info.c.args[i]);

389 }

435 }

390 printf("] ");

436 printf("] ");

391 break;

437 break;

392− case STRING:

438+ case CT_STRING:

393 printf("STR[%s]", v->info.str);

439 printf("STR[%s]", v->info.str);

394 break;

440 break;

395− case FWD:

441+ case CT_FWD:

396− printf("FWD ");

442+ printf("CT_FWD ");

397 dumpVal((VAL)(v->info.ptr));

443 dumpVal((VAL)(v->info.ptr));

398 break;

444 break;

399 default:

445 default:

@@ -414,6 +460,36 @@ void idris_poke(void* ptr, i_int offset, uint8_t data) {

414 *(((uint8_t*)ptr) + offset) = data;

460 *(((uint8_t*)ptr) + offset) = data;

415}

461}

416

462

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+

417void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {

493void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {

418 memmove(dest + dest_offset, src + src_offset, size);

494 memmove(dest + dest_offset, src + src_offset, size);

419}

495}

@@ -421,7 +497,7 @@ void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i

421VAL idris_castIntStr(VM* vm, VAL i) {

497VAL idris_castIntStr(VM* vm, VAL i) {

422 int x = (int) GETINT(i);

498 int x = (int) GETINT(i);

423 Closure* cl = allocate(sizeof(Closure) + sizeof(char)*16, 0);

499 Closure* cl = allocate(sizeof(Closure) + sizeof(char)*16, 0);

424− SETTY(cl, STRING);

500+ SETTY(cl, CT_STRING);

425 cl -> info.str = (char*)cl + sizeof(Closure);

501 cl -> info.str = (char*)cl + sizeof(Closure);

426 sprintf(cl -> info.str, "%d", x);

502 sprintf(cl -> info.str, "%d", x);

427 return cl;

503 return cl;

@@ -432,25 +508,25 @@ VAL idris_castBitsStr(VM* vm, VAL i) {

432 ClosureType ty = i->ty;

508 ClosureType ty = i->ty;

433

509

434 switch (ty) {

510 switch (ty) {

435− case BITS8:

511+ case CT_BITS8:

436 // max length 8 bit unsigned int str 3 chars (256)

512 // max length 8 bit unsigned int str 3 chars (256)

437 cl = allocate(sizeof(Closure) + sizeof(char)*4, 0);

513 cl = allocate(sizeof(Closure) + sizeof(char)*4, 0);

438 cl->info.str = (char*)cl + sizeof(Closure);

514 cl->info.str = (char*)cl + sizeof(Closure);

439 sprintf(cl->info.str, "%" PRIu8, (uint8_t)i->info.bits8);

515 sprintf(cl->info.str, "%" PRIu8, (uint8_t)i->info.bits8);

440 break;

516 break;

441− case BITS16:

517+ case CT_BITS16:

442 // max length 16 bit unsigned int str 5 chars (65,535)

518 // max length 16 bit unsigned int str 5 chars (65,535)

443 cl = allocate(sizeof(Closure) + sizeof(char)*6, 0);

519 cl = allocate(sizeof(Closure) + sizeof(char)*6, 0);

444 cl->info.str = (char*)cl + sizeof(Closure);

520 cl->info.str = (char*)cl + sizeof(Closure);

445 sprintf(cl->info.str, "%" PRIu16, (uint16_t)i->info.bits16);

521 sprintf(cl->info.str, "%" PRIu16, (uint16_t)i->info.bits16);

446 break;

522 break;

447− case BITS32:

523+ case CT_BITS32:

448 // max length 32 bit unsigned int str 10 chars (4,294,967,295)

524 // max length 32 bit unsigned int str 10 chars (4,294,967,295)

449 cl = allocate(sizeof(Closure) + sizeof(char)*11, 0);

525 cl = allocate(sizeof(Closure) + sizeof(char)*11, 0);

450 cl->info.str = (char*)cl + sizeof(Closure);

526 cl->info.str = (char*)cl + sizeof(Closure);

451 sprintf(cl->info.str, "%" PRIu32, (uint32_t)i->info.bits32);

527 sprintf(cl->info.str, "%" PRIu32, (uint32_t)i->info.bits32);

452 break;

528 break;

453− case BITS64:

529+ case CT_BITS64:

454 // max length 64 bit unsigned int str 20 chars (18,446,744,073,709,551,615)

530 // max length 64 bit unsigned int str 20 chars (18,446,744,073,709,551,615)

455 cl = allocate(sizeof(Closure) + sizeof(char)*21, 0);

531 cl = allocate(sizeof(Closure) + sizeof(char)*21, 0);

456 cl->info.str = (char*)cl + sizeof(Closure);

532 cl->info.str = (char*)cl + sizeof(Closure);

@@ -461,7 +537,7 @@ VAL idris_castBitsStr(VM* vm, VAL i) {

461 exit(EXIT_FAILURE);

537 exit(EXIT_FAILURE);

462 }

538 }

463

539

464− SETTY(cl, STRING);

540+ SETTY(cl, CT_STRING);

465 return cl;

541 return cl;

466}

542}

467

543

@@ -476,7 +552,7 @@ VAL idris_castStrInt(VM* vm, VAL i) {

476

552

477VAL idris_castFloatStr(VM* vm, VAL i) {

553VAL idris_castFloatStr(VM* vm, VAL i) {

478 Closure* cl = allocate(sizeof(Closure) + sizeof(char)*32, 0);

554 Closure* cl = allocate(sizeof(Closure) + sizeof(char)*32, 0);

479− SETTY(cl, STRING);

555+ SETTY(cl, CT_STRING);

480 cl -> info.str = (char*)cl + sizeof(Closure);

556 cl -> info.str = (char*)cl + sizeof(Closure);

481 snprintf(cl -> info.str, 32, "%.16g", GETFLOAT(i));

557 snprintf(cl -> info.str, 32, "%.16g", GETFLOAT(i));

482 return cl;

558 return cl;

@@ -492,7 +568,7 @@ VAL idris_concat(VM* vm, VAL l, VAL r) {

492 // dumpVal(l);

568 // dumpVal(l);

493 // printf("\n");

569 // printf("\n");

494 Closure* cl = allocate(sizeof(Closure) + strlen(ls) + strlen(rs) + 1, 0);

570 Closure* cl = allocate(sizeof(Closure) + strlen(ls) + strlen(rs) + 1, 0);

495− SETTY(cl, STRING);

571+ SETTY(cl, CT_STRING);

496 cl -> info.str = (char*)cl + sizeof(Closure);

572 cl -> info.str = (char*)cl + sizeof(Closure);

497 strcpy(cl -> info.str, ls);

573 strcpy(cl -> info.str, ls);

498 strcat(cl -> info.str, rs);

574 strcat(cl -> info.str, rs);

@@ -538,7 +614,7 @@ VAL idris_strHead(VM* vm, VAL str) {

538

614

539VAL MKSTROFFc(VM* vm, StrOffset* off) {

615VAL MKSTROFFc(VM* vm, StrOffset* off) {

540 Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 1);

616 Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 1);

541− SETTY(cl, STROFFSET);

617+ SETTY(cl, CT_STROFFSET);

542 cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure));

618 cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure));

543

619

544 cl->info.str_offset->str = off->str;

620 cl->info.str_offset->str = off->str;

@@ -552,7 +628,7 @@ VAL idris_strTail(VM* vm, VAL str) {

552 // gc moves str

628 // gc moves str

553 if (space(vm, sizeof(Closure) + sizeof(StrOffset))) {

629 if (space(vm, sizeof(Closure) + sizeof(StrOffset))) {

554 Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 0);

630 Closure* cl = allocate(sizeof(Closure) + sizeof(StrOffset), 0);

555− SETTY(cl, STROFFSET);

631+ SETTY(cl, CT_STROFFSET);

556 cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure));

632 cl->info.str_offset = (StrOffset*)((char*)cl + sizeof(Closure));

557

633

558 int offset = 0;

634 int offset = 0;

@@ -580,7 +656,7 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) {

580 if ((xval & 0x80) == 0) { // ASCII char

656 if ((xval & 0x80) == 0) { // ASCII char

581 Closure* cl = allocate(sizeof(Closure) +

657 Closure* cl = allocate(sizeof(Closure) +

582 strlen(xstr) + 2, 0);

658 strlen(xstr) + 2, 0);

583− SETTY(cl, STRING);

659+ SETTY(cl, CT_STRING);

584 cl -> info.str = (char*)cl + sizeof(Closure);

660 cl -> info.str = (char*)cl + sizeof(Closure);

585 cl -> info.str[0] = (char)(GETINT(x));

661 cl -> info.str[0] = (char)(GETINT(x));

586 strcpy(cl -> info.str+1, xstr);

662 strcpy(cl -> info.str+1, xstr);

@@ -588,7 +664,7 @@ VAL idris_strCons(VM* vm, VAL x, VAL xs) {

588 } else {

664 } else {

589 char *init = idris_utf8_fromChar(xval);

665 char *init = idris_utf8_fromChar(xval);

590 Closure* cl = allocate(sizeof(Closure) + strlen(init) + strlen(xstr) + 1, 0);

666 Closure* cl = allocate(sizeof(Closure) + strlen(init) + strlen(xstr) + 1, 0);

591− SETTY(cl, STRING);

667+ SETTY(cl, CT_STRING);

592 cl -> info.str = (char*)cl + sizeof(Closure);

668 cl -> info.str = (char*)cl + sizeof(Closure);

593 strcpy(cl -> info.str, init);

669 strcpy(cl -> info.str, init);

594 strcat(cl -> info.str, xstr);

670 strcat(cl -> info.str, xstr);

@@ -606,7 +682,7 @@ VAL idris_substr(VM* vm, VAL offset, VAL length, VAL str) {

606 char *start = idris_utf8_advance(GETSTR(str), GETINT(offset));

682 char *start = idris_utf8_advance(GETSTR(str), GETINT(offset));

607 char *end = idris_utf8_advance(start, GETINT(length));

683 char *end = idris_utf8_advance(start, GETINT(length));

608 Closure* newstr = allocate(sizeof(Closure) + (end - start) +1, 0);

684 Closure* newstr = allocate(sizeof(Closure) + (end - start) +1, 0);

609− SETTY(newstr, STRING);

685+ SETTY(newstr, CT_STRING);

610 newstr -> info.str = (char*)newstr + sizeof(Closure);

686 newstr -> info.str = (char*)newstr + sizeof(Closure);

611 memcpy(newstr -> info.str, start, end - start);

687 memcpy(newstr -> info.str, start, end - start);

612 *(newstr -> info.str + (end - start) + 1) = '\0';

688 *(newstr -> info.str + (end - start) + 1) = '\0';

@@ -617,7 +693,7 @@ VAL idris_strRev(VM* vm, VAL str) {

617 char *xstr = GETSTR(str);

693 char *xstr = GETSTR(str);

618 Closure* cl = allocate(sizeof(Closure) +

694 Closure* cl = allocate(sizeof(Closure) +

619 strlen(xstr) + 1, 0);

695 strlen(xstr) + 1, 0);

620− SETTY(cl, STRING);

696+ SETTY(cl, CT_STRING);

621 cl->info.str = (char*)cl + sizeof(Closure);

697 cl->info.str = (char*)cl + sizeof(Closure);

622 idris_utf8_rev(xstr, cl->info.str);

698 idris_utf8_rev(xstr, cl->info.str);

623 return cl;

699 return cl;

@@ -700,7 +776,7 @@ VAL doCopyTo(VM* vm, VAL x) {

700 return x;

776 return x;

701 }

777 }

702 switch(GETTY(x)) {

778 switch(GETTY(x)) {

703− case CON:

779+ case CT_CON:

704 ar = CARITY(x);

780 ar = CARITY(x);

705 if (ar == 0 && CTAG(x) < 256) { // globally allocated

781 if (ar == 0 && CTAG(x) < 256) { // globally allocated

706 cl = x;

782 cl = x;

@@ -714,34 +790,34 @@ VAL doCopyTo(VM* vm, VAL x) {

714 }

790 }

715 }

791 }

716 break;

792 break;

717− case FLOAT:

793+ case CT_FLOAT:

718 cl = MKFLOATc(vm, x->info.f);

794 cl = MKFLOATc(vm, x->info.f);

719 break;

795 break;

720− case STRING:

796+ case CT_STRING:

721 cl = MKSTRc(vm, x->info.str);

797 cl = MKSTRc(vm, x->info.str);

722 break;

798 break;

723− case BIGINT:

799+ case CT_BIGINT:

724 cl = MKBIGMc(vm, x->info.ptr);

800 cl = MKBIGMc(vm, x->info.ptr);

725 break;

801 break;

726− case PTR:

802+ case CT_PTR:

727 cl = MKPTRc(vm, x->info.ptr);

803 cl = MKPTRc(vm, x->info.ptr);

728 break;

804 break;

729− case MANAGEDPTR:

805+ case CT_MANAGEDPTR:

730 cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);

806 cl = MKMPTRc(vm, x->info.mptr->data, x->info.mptr->size);

731 break;

807 break;

732− case BITS8:

808+ case CT_BITS8:

733 cl = idris_b8CopyForGC(vm, x);

809 cl = idris_b8CopyForGC(vm, x);

734 break;

810 break;

735− case BITS16:

811+ case CT_BITS16:

736 cl = idris_b16CopyForGC(vm, x);

812 cl = idris_b16CopyForGC(vm, x);

737 break;

813 break;

738− case BITS32:

814+ case CT_BITS32:

739 cl = idris_b32CopyForGC(vm, x);

815 cl = idris_b32CopyForGC(vm, x);

740 break;

816 break;

741− case BITS64:

817+ case CT_BITS64:

742 cl = idris_b64CopyForGC(vm, x);

818 cl = idris_b64CopyForGC(vm, x);

743 break;

819 break;

744− case RAWDATA:

820+ case CT_RAWDATA:

745 {

821 {

746 size_t size = x->info.size + sizeof(Closure);

822 size_t size = x->info.size + sizeof(Closure);

747 cl = allocate(size, 0);

823 cl = allocate(size, 0);

@@ -789,12 +865,12 @@ int idris_sendMessage(VM* sender, VM* dest, VAL msg) {

789 }

865 }

790

866

791 pthread_mutex_lock(&(dest->inbox_lock));

867 pthread_mutex_lock(&(dest->inbox_lock));

792−

868+

793 if (dest->inbox_write >= dest->inbox_end) {

869 if (dest->inbox_write >= dest->inbox_end) {

794 // FIXME: This is obviously bad in the long run. This should

870 // FIXME: This is obviously bad in the long run. This should

795 // either block, make the inbox bigger, or return an error code,

871 // either block, make the inbox bigger, or return an error code,

796 // or possibly make it user configurable

872 // or possibly make it user configurable

797− fprintf(stderr, "Inbox full");

873+ fprintf(stderr, "Inbox full");

798 exit(-1);

874 exit(-1);

799 }

875 }

800

876

@@ -820,7 +896,7 @@ VM* idris_checkMessages(VM* vm) {

820

896

821VM* idris_checkMessagesFrom(VM* vm, VM* sender) {

897VM* idris_checkMessagesFrom(VM* vm, VM* sender) {

822 Msg* msg;

898 Msg* msg;

823−

899+

824 for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {

900 for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {

825 if (sender == NULL || msg->sender == sender) {

901 if (sender == NULL || msg->sender == sender) {

826 return msg->sender;

902 return msg->sender;

@@ -854,7 +930,7 @@ VM* idris_checkMessagesTimeout(VM* vm, int delay) {

854

930

855Msg* idris_getMessageFrom(VM* vm, VM* sender) {

931Msg* idris_getMessageFrom(VM* vm, VM* sender) {

856 Msg* msg;

932 Msg* msg;

857−

933+

858 for (msg = vm->inbox; msg < vm->inbox_write; ++msg) {

934 for (msg = vm->inbox; msg < vm->inbox_write; ++msg) {

859 if (sender == NULL || msg->sender == sender) {

935 if (sender == NULL || msg->sender == sender) {

860 return msg;

936 return msg;

@@ -951,7 +1027,7 @@ void init_nullaries() {

951 nullary_cons = malloc(256 * sizeof(VAL));

1027 nullary_cons = malloc(256 * sizeof(VAL));

952 for(i = 0; i < 256; ++i) {

1028 for(i = 0; i < 256; ++i) {

953 cl = malloc(sizeof(Closure));

1029 cl = malloc(sizeof(Closure));

954− SETTY(cl, CON);

1030+ SETTY(cl, CT_CON);

955 cl->info.c.tag_arity = i << 8;

1031 cl->info.c.tag_arity = i << 8;

956 nullary_cons[i] = cl;

1032 nullary_cons[i] = cl;

957 }

1033 }

rts/idris_rts.h+59−14

@@ -25,9 +25,9 @@

25

26// Closures

27typedef enum {

28− CON, INT, BIGINT, FLOAT, STRING, STROFFSET,

28+ CT_CON, CT_INT, CT_BIGINT, CT_FLOAT, CT_STRING, CT_STROFFSET,

29− BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD,

29+ CT_BITS8, CT_BITS16, CT_BITS32, CT_BITS64, CT_UNIT, CT_PTR, CT_FWD,

30− MANAGEDPTR, RAWDATA

30+ CT_MANAGEDPTR, CT_RAWDATA, CT_CDATA

31} ClosureType;

32

33typedef struct Closure *VAL;

@@ -67,20 +67,21 @@ typedef struct Closure {

67 uint32_t bits32;

68 uint64_t bits64;

69 ManagedPtr* mptr;

70+ CHeapItem* c_heap_item;

70 size_t size;

71 size_t size;

71 } info;

72 } info;

72} Closure;

73} Closure;

73

74

74−struct VM_t;

75+struct VM;

75

76

76struct Msg_t {

77struct Msg_t {

77− struct VM_t* sender;

78+ struct VM* sender;

78 VAL msg;

79 VAL msg;

79};

80};

80

81

81typedef struct Msg_t Msg;

82typedef struct Msg_t Msg;

82

83

83−struct VM_t {

84+struct VM {

84 int active; // 0 if no longer running; keep for message passing

85 int active; // 0 if no longer running; keep for message passing

85 // TODO: If we're going to have lots of concurrent threads,

86 // TODO: If we're going to have lots of concurrent threads,

86 // we really need to be cleverer than this!

87 // we really need to be cleverer than this!

@@ -90,6 +91,7 @@ struct VM_t {

90 VAL* valstack_base;

91 VAL* valstack_base;

91 VAL* stack_max;

92 VAL* stack_max;

92

93

94+ CHeap c_heap;

93 Heap heap;

95 Heap heap;

94#ifdef HAS_PTHREAD

96#ifdef HAS_PTHREAD

95 pthread_mutex_t inbox_lock;

97 pthread_mutex_t inbox_lock;

@@ -110,11 +112,44 @@ struct VM_t {

110 VAL reg1;

112 VAL reg1;

111};

113};

112

114

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+

114

146

115// Create a new VM

147// Create a new VM

116VM* init_vm(int stack_size, size_t heap_size,

148VM* init_vm(int stack_size, size_t heap_size,

117 int max_threads);

149 int max_threads);

150+

151+// Get the VM for the current thread

152+VM* get_vm(void);

118// Initialise thread-local data for this VM

153// Initialise thread-local data for this VM

119void init_threaddata(VM *vm);

154void init_threaddata(VM *vm);

120// Clean up a VM once it's no longer needed

155// Clean up a VM once it's no longer needed

@@ -147,16 +182,17 @@ typedef void(*func)(VM*, VAL*);

147#define GETPTR(x) (((VAL)(x))->info.ptr)

182#define GETPTR(x) (((VAL)(x))->info.ptr)

148#define GETMPTR(x) (((VAL)(x))->info.mptr->data)

183#define GETMPTR(x) (((VAL)(x))->info.mptr->data)

149#define GETFLOAT(x) (((VAL)(x))->info.f)

184#define GETFLOAT(x) (((VAL)(x))->info.f)

185+#define GETCDATA(x) (((VAL)(x))->info.c_heap_item)

150

186

151#define GETBITS8(x) (((VAL)(x))->info.bits8)

187#define GETBITS8(x) (((VAL)(x))->info.bits8)

152#define GETBITS16(x) (((VAL)(x))->info.bits16)

188#define GETBITS16(x) (((VAL)(x))->info.bits16)

153#define GETBITS32(x) (((VAL)(x))->info.bits32)

189#define GETBITS32(x) (((VAL)(x))->info.bits32)

154#define GETBITS64(x) (((VAL)(x))->info.bits64)

190#define GETBITS64(x) (((VAL)(x))->info.bits64)

155

191

156−#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity >> 8 : (-1)) )

192+#define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_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)) )

193+#define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CT_CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) )

158

194

159−// Already checked it's a CON

195+// Already checked it's a CT_CON

160#define CTAG(x) (((x)->info.c.tag_arity) >> 8)

196#define CTAG(x) (((x)->info.c.tag_arity) >> 8)

161#define CARITY(x) ((x)->info.c.tag_arity & 0x000000ff)

197#define CARITY(x) ((x)->info.c.tag_arity & 0x000000ff)

162

198

@@ -176,7 +212,7 @@ typedef intptr_t i_int;

176#define MKINT(x) ((void*)((x)<<1)+1)

212#define MKINT(x) ((void*)((x)<<1)+1)

177#define GETINT(x) ((i_int)(x)>>1)

213#define GETINT(x) ((i_int)(x)>>1)

178#define ISINT(x) ((((i_int)x)&1) == 1)

214#define ISINT(x) ((((i_int)x)&1) == 1)

179−#define ISSTR(x) (GETTY(x) == STRING)

215+#define ISSTR(x) (GETTY(x) == CT_STRING)

180

216

181#define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1)))

217#define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1)))

182#define UINTOP(op,x,y) MKINT((i_int)((((uintptr_t)x)>>1) op (((uintptr_t)y)>>1)))

218#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);

207VAL MKB16(VM* vm, uint16_t b);

243VAL MKB16(VM* vm, uint16_t b);

208VAL MKB32(VM* vm, uint32_t b);

244VAL MKB32(VM* vm, uint32_t b);

209VAL MKB64(VM* vm, uint64_t b);

245VAL MKB64(VM* vm, uint64_t b);

246+VAL MKCDATA(VM* vm, CHeapItem * item);

210

247

211// following versions don't take a lock when allocating

248// following versions don't take a lock when allocating

212VAL MKFLOATc(VM* vm, double val);

249VAL MKFLOATc(VM* vm, double val);

@@ -214,6 +251,7 @@ VAL MKSTROFFc(VM* vm, StrOffset* off);

214VAL MKSTRc(VM* vm, char* str);

251VAL MKSTRc(VM* vm, char* str);

215VAL MKPTRc(VM* vm, void* ptr);

252VAL MKPTRc(VM* vm, void* ptr);

216VAL MKMPTRc(VM* vm, void* ptr, size_t size);

253VAL MKMPTRc(VM* vm, void* ptr, size_t size);

254+VAL MKCDATAc(VM* vm, CHeapItem * item);

217

255

218char* GETSTROFF(VAL stroff);

256char* GETSTROFF(VAL stroff);

219

257

@@ -245,12 +283,12 @@ void idris_free(void* ptr, size_t size);

245

283

246#define allocCon(cl, vm, t, a, o) \

284#define allocCon(cl, vm, t, a, o) \

247 cl = allocate(sizeof(Closure) + sizeof(VAL)*a, o); \

285 cl = allocate(sizeof(Closure) + sizeof(VAL)*a, o); \

248− SETTY(cl, CON); \

286+ SETTY(cl, CT_CON); \

249 cl->info.c.tag_arity = ((t) << 8) | (a);

287 cl->info.c.tag_arity = ((t) << 8) | (a);

250

288

251#define updateCon(cl, old, t, a) \

289#define updateCon(cl, old, t, a) \

252 cl = old; \

290 cl = old; \

253− SETTY(cl, CON); \

291+ SETTY(cl, CT_CON); \

254 cl->info.c.tag_arity = ((t) << 8) | (a);

292 cl->info.c.tag_arity = ((t) << 8) | (a);

255

293

256#define NULL_CON(x) nullary_cons[x]

294#define NULL_CON(x) nullary_cons[x]

@@ -304,9 +342,16 @@ VAL idris_castStrFloat(VM* vm, VAL i);

304

342

305// Raw memory manipulation

343// Raw memory manipulation

306void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size);

344void 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);

307uint8_t idris_peek(void* ptr, i_int offset);

346uint8_t idris_peek(void* ptr, i_int offset);

308void idris_poke(void* ptr, i_int offset, uint8_t data);

347void 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);

310

355

311// String primitives

356// String primitives

312VAL idris_concat(VM* vm, VAL l, VAL r);

357VAL idris_concat(VM* vm, VAL l, VAL r);

samples/tutorial/interp.idr+1−1

@@ -33,7 +33,7 @@ using (G : Vect n Ty)

33 Expr G c

34 If : Expr G TyBool -> Lazy (Expr G a) -> Lazy (Expr G a) -> Expr G a

35

36− interp : Env G -> [static] (e : Expr G t) -> interpTy t

36+ interp : Env G -> %static (e : Expr G t) -> interpTy t

37 interp env (Var i) = lookup i env

38 interp env (Val x) = x

39 interp env (Lam sc) = \x => interp (x :: env) sc

src/IRTS/CodegenC.hs+208−24

@@ -13,7 +13,7 @@ import Util.System

13import Numeric

14import Data.Char

15import Data.Bits

16−import Data.List (intercalate)

16+import Data.List (intercalate, nubBy)

17import System.Process

18import System.Exit

19import System.IO

@@ -48,19 +48,20 @@ codegenC' :: [(Name, SDecl)] ->

48 [String] -> -- extra object files

49 [String] -> -- extra compiler flags (libraries)

50 [String] -> -- extra compiler flags (anything)

51− [ExportIFace] ->

51+ [ExportIFace] ->

52 Bool -> -- interfaces too (so make a .o instead)

53 DbgLevel ->

54 IO ()

55codegenC' defs out exec incs objs libs flags exports iface dbg

56 = do -- print defs

57 let bc = map toBC defs

58+ let wrappers = genWrappers bc

58 let h = concatMap toDecl (map fst bc)

59 let h = concatMap toDecl (map fst bc)

59 let cc = concatMap (uncurry toC) bc

60 let cc = concatMap (uncurry toC) bc

60 let hi = concatMap ifaceC (concatMap getExp exports)

61 let hi = concatMap ifaceC (concatMap getExp exports)

61 d <- getDataDir

62 d <- getDataDir

62 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")

63 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")

63− let cout = headers incs ++ debug dbg ++ h ++ cc ++

64+ let cout = headers incs ++ debug dbg ++ h ++ wrappers ++ cc ++

64 (if (exec == Executable) then mprog else hi)

65 (if (exec == Executable) then mprog else hi)

65 case exec of

66 case exec of

66 MavenProject -> putStrLn ("FAILURE: output type not supported")

67 MavenProject -> putStrLn ("FAILURE: output type not supported")

@@ -74,6 +75,7 @@ codegenC' defs out exec incs objs libs flags exports iface dbg

74 libFlags <- getLibFlags

75 libFlags <- getLibFlags

75 incFlags <- getIncFlags

76 incFlags <- getIncFlags

76 envFlags <- getEnvFlags

77 envFlags <- getEnvFlags

78+ let stackFlag = if isWindows then ["-Wl,--stack,16777216"] else []

77 let args = [gccDbg dbg] ++

79 let args = [gccDbg dbg] ++

78 gccFlags iface ++

80 gccFlags iface ++

79 -- # Any flags defined here which alter the RTS API must also be added to config.mk

81 -- # 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

81 "-I."] ++ objs ++ envFlags ++

83 "-I."] ++ objs ++ envFlags ++

82 (if (exec == Executable) then [] else ["-c"]) ++

84 (if (exec == Executable) then [] else ["-c"]) ++

83 [tmpn] ++

85 [tmpn] ++

84− (if not iface then concatMap words libFlags else []) ++

86+ (if not iface then libFlags else []) ++

85− concatMap words incFlags ++

87+ incFlags ++

86− (if not iface then concatMap words libs else []) ++

88+ (if not iface then libs else []) ++

87− concatMap words flags ++

89+ flags ++ stackFlag ++

88 ["-o", out]

90 ["-o", out]

89-- putStrLn (show args)

91-- putStrLn (show args)

90 exit <- rawSystem comp args

92 exit <- rawSystem comp args

@@ -153,7 +155,7 @@ showCStr s = '"' : foldr ((++) . showChar) "\"" s

153 headHex h (length bytes) : map toHex bytes

155 headHex h (length bytes) : map toHex bytes

154 where

156 where

155 split acc 0 = acc

157 split acc 0 = acc

156− split acc x = let xbits = x .&. 0x3f

158+ split acc x = let xbits = x .&. 0x3f

157 xrest = shiftR x 6 in

159 xrest = shiftR x 6 in

158 split (xbits : acc) xrest

160 split (xbits : acc) xrest

159

161

@@ -185,7 +187,7 @@ bcc i (ASSIGNCONST l c)

185 -- if it's a type constant, we won't use it, but equally it shouldn't

187 -- if it's a type constant, we won't use it, but equally it shouldn't

186 -- report an error. These might creep into generated for various reasons

188 -- report an error. These might creep into generated for various reasons

187 -- (especially if erasure is disabled).

189 -- (especially if erasure is disabled).

188− mkConst c | isTypeConst c = "MKINT(42424242)"

190+ mkConst c | isTypeConst c = "MKINT(42424242)"

189 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"

191 mkConst c = error $ "mkConst of (" ++ show c ++ ") not implemented"

190

192

191bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

193bcc 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"

317bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

319bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

318bcc i STOREOLD = indent i ++ "STOREOLD;\n"

320bcc i STOREOLD = indent i ++ "STOREOLD;\n"

319bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

321bcc 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"

320bcc i (FOREIGNCALL l rty (FStr fn) args)

333bcc i (FOREIGNCALL l rty (FStr fn) args)

321 = indent i ++

334 = indent i ++

322 c_irts (toFType rty) (creg l ++ " = ")

335 c_irts (toFType rty) (creg l ++ " = ")

323 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

336 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

324− where fcall (t, arg) = irts_c (toFType t) (creg arg)

325bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

337bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

326bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

338bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); fprintf(stderr, \"\\n\"); exit(-1);\n"

327-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"

339-- bcc i c = error (show c) -- indent i ++ "// not done yet\n"

328

340

341+fcall (t, arg) = irts_c (toFType t) (creg arg)

329-- Deconstruct the Foreign type in the defunctionalised expression and build

342-- Deconstruct the Foreign type in the defunctionalised expression and build

330-- a foreign type description for c_irts and irts_c

343-- a foreign type description for c_irts and irts_c

331−toAType (FCon i)

344+toAType (FCon i)

332 | i == sUN "C_IntChar" = ATInt ITChar

345 | i == sUN "C_IntChar" = ATInt ITChar

333 | i == sUN "C_IntNative" = ATInt ITNative

346 | i == sUN "C_IntNative" = ATInt ITNative

334 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)

347 | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)

@@ -337,18 +350,27 @@ toAType (FCon i)

337 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)

350 | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)

338toAType t = error (show t ++ " not defined in toAType")

351toAType t = error (show t ++ " not defined in toAType")

339

352

340−toFType (FCon c)

353+toFType (FCon c)

341 | c == sUN "C_Str" = FString

354 | c == sUN "C_Str" = FString

342 | c == sUN "C_Float" = FArith ATFloat

355 | c == sUN "C_Float" = FArith ATFloat

343 | c == sUN "C_Ptr" = FPtr

356 | c == sUN "C_Ptr" = FPtr

344 | c == sUN "C_MPtr" = FManagedPtr

357 | c == sUN "C_MPtr" = FManagedPtr

358+ | c == sUN "C_CData" = FCData

345 | c == sUN "C_Unit" = FUnit

359 | c == sUN "C_Unit" = FUnit

346−toFType (FApp c [_,ity])

360+toFType (FApp c [_,ity])

347 | c == sUN "C_IntT" = FArith (toAType ity)

361 | c == sUN "C_IntT" = FArith (toAType ity)

348−toFType (FApp c [_])

362+ | c == sUN "C_FnT" = toFunType ity

363+toFType (FApp c [_])

349 | c == sUN "C_Any" = FAny

364 | c == sUN "C_Any" = FAny

350toFType t = FAny

365toFType t = FAny

351

366

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+

352c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

374c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

353c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x

375c_irts (FArith (ATInt ITChar)) l x = c_irts (FArith (ATInt ITNative)) l x

354c_irts (FArith (ATInt (ITFixed ity))) l x

376c_irts (FArith (ATInt (ITFixed ity))) l x

@@ -358,7 +380,10 @@ c_irts FUnit l x = x

358c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

380c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

359c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"

381c_irts FManagedPtr l x = l ++ "MKMPTR(vm, " ++ x ++ ")"

360c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

382c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

383+c_irts FCData l x = l ++ "MKCDATA(vm, " ++ x ++ ")"

361c_irts FAny l x = l ++ x

384c_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"

362

387

363irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"

388irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"

364irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x

389irts_c (FArith (ATInt ITChar)) x = irts_c (FArith (ATInt ITNative)) x

@@ -369,7 +394,16 @@ irts_c FUnit x = x

369irts_c FPtr x = "GETPTR(" ++ x ++ ")"

394irts_c FPtr x = "GETPTR(" ++ x ++ ")"

370irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"

395irts_c FManagedPtr x = "GETMPTR(" ++ x ++ ")"

371irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

396irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"

397+irts_c FCData x = "GETCDATA(" ++ x ++ ")"

372irts_c FAny x = x

398irts_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 ++ ")"

373

407

374bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

408bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

375

409

@@ -527,6 +561,8 @@ doOp v (LTrunc (ITFixed from) ITNative) [x]

527 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"

561 = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"

528doOp v (LTrunc (ITFixed from) ITChar) [x]

562doOp v (LTrunc (ITFixed from) ITChar) [x]

529 = doOp v (LTrunc (ITFixed from) ITNative) [x]

563 = 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 ++ ")))"

530doOp v (LTrunc ITBig (ITFixed to)) [x]

566doOp v (LTrunc ITBig (ITFixed to)) [x]

531 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"

567 = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"

532doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]

568doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]

@@ -551,7 +587,7 @@ doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

551doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

587doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

552

588

553doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"

589doOp v LReadStr [_] = v ++ "idris_readStr(vm, stdin)"

554−doOp v LWriteStr [_,s]

590+doOp v LWriteStr [_,s]

555 = v ++ "MKINT((i_int)(idris_writeStr(stdout"

591 = v ++ "MKINT((i_int)(idris_writeStr(stdout"

556 ++ ",GETSTR("

592 ++ ",GETSTR("

557 ++ creg s ++ "))))"

593 ++ creg s ++ "))))"

@@ -577,10 +613,10 @@ doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"

577doOp v LNoOp args = v ++ creg (last args)

613doOp v LNoOp args = v ++ creg (last args)

578

614

579-- Pointer primitives (declared as %extern in Builtins.idr)

615-- Pointer primitives (declared as %extern in Builtins.idr)

580−doOp v (LExternal rf) [_,x]

616+doOp v (LExternal rf) [_,x]

581 | rf == sUN "prim__readFile"

617 | rf == sUN "prim__readFile"

582 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

618 = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

583−doOp v (LExternal wf) [_,x,s]

619+doOp v (LExternal wf) [_,x,s]

584 | wf == sUN "prim__writeFile"

620 | wf == sUN "prim__writeFile"

585 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x

621 = v ++ "MKINT((i_int)(idris_writeStr(GETPTR(" ++ creg x

586 ++ "),GETSTR("

622 ++ "),GETSTR("

@@ -591,15 +627,49 @@ doOp v (LExternal so) [] | so == sUN "prim__stdout" = v ++ "MKPTR(vm, stdout)"

591doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"

627doOp v (LExternal se) [] | se == sUN "prim__stderr" = v ++ "MKPTR(vm, stderr)"

592

628

593doOp v (LExternal nul) [] | nul == sUN "prim__null" = v ++ "MKPTR(vm, NULL)"

629doOp 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"

595 = v ++ "MKINT((i_int)(GETPTR(" ++ creg x ++ ") == GETPTR(" ++ creg y ++ ")))"

631 = 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"

597 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"

633 = v ++ "MKINT((i_int)(GETMPTR(" ++ creg x ++ ") == GETMPTR(" ++ creg y ++ ")))"

598doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"

634doOp v (LExternal rp) [p, i] | rp == sUN "prim__registerPtr"

599 = v ++ "MKMPTR(vm, GETPTR(" ++ creg p ++ "), GETINT(" ++ creg i ++ "))"

635 = 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 ++ "))"

601doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"

670doOp _ op args = error $ "doOp not implemented (" ++ show (op, args) ++ ")"

602

671

672+

603flUnOp :: String -> String -> String

673flUnOp :: String -> String -> String

604flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

674flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

605

675

@@ -610,7 +680,7 @@ flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

610ifaceC :: Export -> String

680ifaceC :: Export -> String

611ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

681ifaceC (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

612ifaceC (ExportFun n cn ret args)

682ifaceC (ExportFun n cn ret args)

613− = ctype ret ++ " " ++ cdesc cn ++

683+ = ctype ret ++ " " ++ cdesc cn ++

614 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"

684 "(VM* vm" ++ showArgs (zip argNames args) ++ ") {\n"

615 ++ mkBody n (zip argNames args) ret ++ "}\n\n"

685 ++ mkBody n (zip argNames args) ret ++ "}\n\n"

616 where showArgs [] = ""

686 where showArgs [] = ""

@@ -623,7 +693,7 @@ mkBody n as t = indent 1 ++ "INITFRAME;\n" ++

623 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++

693 indent 1 ++ "RESERVE(" ++ show (max (length as) 3) ++ ");\n" ++

624 push 0 as ++ call n ++ retval t

694 push 0 as ++ call n ++ retval t

625 where push i [] = ""

695 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)

627 ("TOP(" ++ show i ++ ") = ") n

697 ("TOP(" ++ show i ++ ") = ") n

628 ++ ";\n" ++ push (i + 1) ts

698 ++ ";\n" ++ push (i + 1) ts

629

699

@@ -689,7 +759,7 @@ hdr_guard x = "__" ++ map hchar x

689hdr_export :: Export -> String

759hdr_export :: Export -> String

690hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

760hdr_export (ExportData n) = "typedef VAL " ++ cdesc n ++ ";\n"

691hdr_export (ExportFun n cn ret args)

761hdr_export (ExportFun n cn ret args)

692− = ctype ret ++ " " ++ cdesc cn ++

762+ = ctype ret ++ " " ++ cdesc cn ++

693 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"

763 "(VM* vm" ++ showArgs (zip argNames args) ++ ");\n"

694 where showArgs [] = ""

764 where showArgs [] = ""

695 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++

765 showArgs ((n, t) : ts) = ", " ++ ctype t ++ " " ++ n ++

@@ -697,5 +767,119 @@ hdr_export (ExportFun n cn ret args)

697

767

698 argNames = zipWith (++) (repeat "arg") (map show [0..])

768 argNames = zipWith (++) (repeat "arg") (map show [0..])

699

769

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

700

859

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

3import Idris.Core.TT

4import IRTS.Simplified

5import IRTS.Defunctionalise

6−import IRTS.Lang

7−

8−import Control.Exception

9−import Data.Word

10−import System.Environment

11

6

12data DbgLevel = NONE | DEBUG | TRACE deriving Eq

7data DbgLevel = NONE | DEBUG | TRACE deriving Eq

13data OutputType = Raw | Object | Executable | MavenProject deriving (Eq, Show)

8data OutputType = Raw | Object | Executable | MavenProject deriving (Eq, Show)

14

9

15−environment :: String -> IO (Maybe String)

16−environment x = Control.Exception.catch (do e <- getEnv x

17− return (Just e))

18− (\y-> do return (y::SomeException); return Nothing)

19−

20-- Everything which might be needed in a code generator - a CG can choose which

10-- Everything which might be needed in a code generator - a CG can choose which

21-- level of Decls to generate code from (simplified, defunctionalised or merely

11-- level of Decls to generate code from (simplified, defunctionalised or merely

22-- lambda lifted) and has access to the list of object files, libraries, etc.

12-- lambda lifted) and has access to the list of object files, libraries, etc.

src/IRTS/Compiler.hs+8−2

@@ -18,6 +18,7 @@ import Idris.AbsSyntaxTree

18import Idris.ASTUtils

19import Idris.Erasure

20import Idris.Error

21+import Idris.Output

21

22

22import Debug.Trace

23import Debug.Trace

23

24

@@ -112,7 +113,9 @@ compile codegen f mtm

112 where checkMVs = do i <- getIState

113 where checkMVs = do i <- getIState

113 case map fst (idris_metavars i) \\ primDefs of

114 case map fst (idris_metavars i) \\ primDefs of

114 [] -> return ()

115 [] -> 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 ()

116 checkTotality = do i <- getIState

119 checkTotality = do i <- getIState

117 case idris_totcheckfail i of

120 case idris_totcheckfail i of

118 [] -> return ()

121 [] -> return ()

@@ -227,6 +230,9 @@ irTerm :: Vars -> [Name] -> Term -> Idris LExp

227irTerm vs env tm@(App _ f a) = do

230irTerm vs env tm@(App _ f a) = do

228 ist <- getIState

231 ist <- getIState

229 case unApply tm of

232 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

230 (P _ (UN m) _, args)

236 (P _ (UN m) _, args)

231 | m == txt "mkForeignPrim"

237 | m == txt "mkForeignPrim"

232 -> doForeign vs env (reverse (drop 4 args)) -- drop implicits

238 -> doForeign vs env (reverse (drop 4 args)) -- drop implicits

@@ -462,7 +468,7 @@ doForeign vs env (ret : fname : world : args)

462 = do let l' = toFDesc l

468 = do let l' = toFDesc l

463 r' <- irTerm vs env r

469 r' <- irTerm vs env r

464 return (l', r')

470 return (l', r')

465− splitArg _ = ifail "Badly formed foreign function call"

471+ splitArg _ = ifail $ "Badly formed foreign function call"

466

472

467 toFDesc (Constant (Str str)) = FStr str

473 toFDesc (Constant (Str str)) = FStr str

468 toFDesc tm

474 toFDesc tm

src/IRTS/Lang.hs+9−7

@@ -17,10 +17,11 @@ data LVar = Loc Int | Glob Name

17 deriving (Show, Eq)

18

19-- ASSUMPTION: All variable bindings have unique names here

20+-- Constructors commented as lifted are not present in the LIR provided to the different backends.

20data LExp = LV LVar

21data LExp = LV LVar

21 | LApp Bool LExp [LExp] -- True = tail call

22 | LApp Bool LExp [LExp] -- True = tail call

22 | LLazyApp Name [LExp] -- True = tail call

23 | LLazyApp Name [LExp] -- True = tail call

23− | LLazyExp LExp

24+ | LLazyExp LExp -- lifted out before compiling

24 | LForce LExp -- make sure Exp is evaluted

25 | LForce LExp -- make sure Exp is evaluted

25 | LLet Name LExp LExp -- name just for pretty printing

26 | LLet Name LExp LExp -- name just for pretty printing

26 | LLam [Name] LExp -- lambda, lifted out before compiling

27 | LLam [Name] LExp -- lambda, lifted out before compiling

@@ -99,6 +100,7 @@ data FType = FArith ArithTy

99 | FUnit

100 | FUnit

100 | FPtr

101 | FPtr

101 | FManagedPtr

102 | FManagedPtr

103+ | FCData

102 | FAny

104 | FAny

103 deriving (Show, Eq)

105 deriving (Show, Eq)

104

106

@@ -132,7 +134,7 @@ data LiftState = LS Name Int [(Name, LDecl)]

132

134

133lname (NS n x) i = NS (lname n i) x

135lname (NS n x) i = NS (lname n i) x

134lname (UN n) i = MN i n

136lname (UN n) i = MN i n

135−lname x i = sMN i (show x ++ "_lam")

137+lname x i = sMN i (showCG x ++ "_lam")

136

138

137liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

139liftAll :: [(Name, LDecl)] -> [(Name, LDecl)]

138liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs

140liftAll xs = concatMap (\ (x, d) -> lambdaLift x d) xs

@@ -215,7 +217,7 @@ allocUnique defs (n, LFun opts fn args e)

215 -- Keep track of 'updatable' names in the state, i.e. names whose heap

217 -- Keep track of 'updatable' names in the state, i.e. names whose heap

216 -- entry may be reused, along with the arity which was there

218 -- entry may be reused, along with the arity which was there

217 findUp :: LExp -> State [(Name, Int)] LExp

219 findUp :: LExp -> State [(Name, Int)] LExp

218− findUp (LApp t (LV (Glob n)) as)

220+ findUp (LApp t (LV (Glob n)) as)

219 | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,

221 | Just (LConstructor _ i ar) <- lookupCtxtExact n defs,

220 ar == length as

222 ar == length as

221 = findUp (LCon Nothing i n as)

223 = findUp (LCon Nothing i n as)

@@ -241,7 +243,7 @@ allocUnique defs (n, LFun opts fn args e)

241 findUp (LOp o es) = LOp o <$> mapM findUp es

243 findUp (LOp o es) = LOp o <$> mapM findUp es

242 findUp (LCase Updatable e@(LV (Glob n)) as)

244 findUp (LCase Updatable e@(LV (Glob n)) as)

243 = LCase Updatable e <$> mapM (doUpAlt n) as

245 = LCase Updatable e <$> mapM (doUpAlt n) as

244− findUp (LCase t e as)

246+ findUp (LCase t e as)

245 = LCase t <$> findUp e <*> mapM findUpAlt as

247 = LCase t <$> findUp e <*> mapM findUpAlt as

246 findUp t = return t

248 findUp t = return t

247

249

@@ -252,7 +254,7 @@ allocUnique defs (n, LFun opts fn args e)

252 findUpAlt (LConstCase i rhs) = LConstCase i <$> findUp rhs

254 findUpAlt (LConstCase i rhs) = LConstCase i <$> findUp rhs

253 findUpAlt (LDefaultCase rhs) = LDefaultCase <$> findUp rhs

255 findUpAlt (LDefaultCase rhs) = LDefaultCase <$> findUp rhs

254

256

255− doUpAlt n (LConCase i t args rhs)

257+ doUpAlt n (LConCase i t args rhs)

256 = do avail <- get

258 = do avail <- get

257 put ((n, length args) : avail)

259 put ((n, length args) : avail)

258 rhs' <- findUp rhs

260 rhs' <- findUp rhs

@@ -282,7 +284,7 @@ usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e

282usedIn env (LLam ns e) = usedIn (env \\ ns) e

284usedIn env (LLam ns e) = usedIn (env \\ ns) e

283usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in

285usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in

284 case v of

286 case v of

285− Nothing -> rest

287+ Nothing -> rest

286 Just (Glob n) -> usedArg env n ++ rest

288 Just (Glob n) -> usedArg env n ++ rest

287usedIn env (LProj t i) = usedIn env t

289usedIn env (LProj t i) = usedIn env t

288usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts

290usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts

@@ -329,7 +331,7 @@ instance Show LExp where

329 Updatable -> "! "

331 Updatable -> "! "

330 fmt [] = ""

332 fmt [] = ""

331 fmt [alt]

333 fmt [alt]

332− = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt

334+ = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt

333 fmt (alt:as)

335 fmt (alt:as)

334 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ". ") alt

336 = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ". ") alt

335 ++ "\n" ++ fmt as

337 ++ "\n" ++ fmt as

src/IRTS/System.hs+9−25

@@ -1,8 +1,7 @@

1{-# LANGUAGE CPP #-}

2module IRTS.System(getDataFileName, getDataDir, getTargetDir,getCC,getLibFlags,getIdrisLibDir,

3− getIncFlags, getEnvFlags, getMvn,getExecutablePom, version) where

3+ getIncFlags, getEnvFlags, version) where

4

5−import Util.System

6import Data.List.Split

5import Data.List.Split

7

6

8import Control.Applicative ((<$>))

7import Control.Applicative ((<$>))

@@ -17,28 +16,18 @@ import Paths_idris (version)

17import Paths_idris

16import Paths_idris

18#endif

17#endif

19

18

19+overrideDataDirWith :: String -> IO FilePath

20+overrideDataDirWith envVar = do envValue <- lookupEnv envVar

21+ maybe getDataDir return envValue

22+

20getCC :: IO String

23getCC :: IO String

21−getCC = fromMaybe "gcc" <$> environment "IDRIS_CC"

24+getCC = fromMaybe "gcc" <$> lookupEnv "IDRIS_CC"

22

25

23getEnvFlags :: IO [String]

26getEnvFlags :: IO [String]

24−getEnvFlags = maybe [] (splitOn " ") <$> environment "IDRIS_CFLAGS"

27+getEnvFlags = maybe [] (splitOn " ") <$> lookupEnv "IDRIS_CFLAGS"

25−

26−mvnCommand :: String

27−#ifdef mingw32_HOST_OS

28−mvnCommand = "mvn.bat"

29−#else

30−mvnCommand = "mvn"

31−#endif

32−

33−getMvn :: IO String

34−getMvn = fromMaybe mvnCommand <$> environment "IDRIS_MVN"

35−

36−environment :: String -> IO (Maybe String)

37−environment x = catchIO (Just <$> getEnv x)

38− (\_ -> return Nothing)

39

28

40getTargetDir :: IO String

29getTargetDir :: IO String

41−getTargetDir = environment "TARGET" >>= maybe getDataDir return

30+getTargetDir = overrideDataDirWith "TARGET"

42

31

43#if defined(FREEBSD) || defined(DRAGONFLY)

32#if defined(FREEBSD) || defined(DRAGONFLY)

44extraLib = ["-L/usr/local/lib"]

33extraLib = ["-L/usr/local/lib"]

@@ -56,9 +45,7 @@ getLibFlags = do dir <- getDataDir

56 return $ ["-L" ++ (dir </> "rts"),

45 return $ ["-L" ++ (dir </> "rts"),

57 "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"]

46 "-lidris_rts"] ++ extraLib ++ gmpLib ++ ["-lpthread"]

58

47

59−getIdrisLibDir = do libPath <- environment "IDRIS_LIBRARY_PATH"

48+getIdrisLibDir = addTrailingPathSeparator <$> overrideDataDirWith "IDRIS_LIBRARY_PATH"

60− dir <- maybe getDataDir return libPath

61− return $ addTrailingPathSeparator dir

62

49

63#if defined(FREEBSD) || defined(DRAGONFLY)

50#if defined(FREEBSD) || defined(DRAGONFLY)

64extraInclude = ["-I/usr/local/include"]

51extraInclude = ["-I/usr/local/include"]

@@ -67,6 +54,3 @@ extraInclude = []

67#endif

54#endif

68getIncFlags = do dir <- getDataDir

55getIncFlags = do dir <- getDataDir

69 return $ ("-I" ++ dir </> "rts") : extraInclude

56 return $ ("-I" ++ dir </> "rts") : extraInclude

70−

71−getExecutablePom = do dir <- getDataDir

72− return $ dir </> "java" </> "executable_pom.xml"

src/Idris/ASTUtils.hs+1−4

@@ -118,17 +118,14 @@ opt_detaggable = Field detaggable (\v opt -> opt{ detaggable = v })

118ist_callgraph :: Name -> Field IState CGInfo

119ist_callgraph n =

120 maybe_default CGInfo

121− { argsdef = [], calls = [], scg = []

121+ { calls = [], scg = [], usedpos = []

122− , argsused = [], usedpos = []

123 }

122 }

124 . ctxt_lookup n

123 . ctxt_lookup n

125 . Field idris_callgraph (\v ist -> ist{ idris_callgraph = v })

124 . Field idris_callgraph (\v ist -> ist{ idris_callgraph = v })

126

125

127−-- some fields of the CGInfo record

128cg_usedpos :: Field CGInfo [(Int, [UsageReason])]

126cg_usedpos :: Field CGInfo [(Int, [UsageReason])]

129cg_usedpos = Field usedpos (\v cg -> cg{ usedpos = v })

127cg_usedpos = Field usedpos (\v cg -> cg{ usedpos = v })

130

128

131−

132-- Commandline flags

129-- Commandline flags

133--------------------

130--------------------

134

131

src/Idris/AbsSyntax.hs+125−77

@@ -77,7 +77,7 @@ addDyLib libs = do i <- getIState

77 (\_ -> return Nothing)) $ libs

78 case msum handle of

79 Nothing -> return (Right $ "Could not load dynamic alternatives \"" ++

80− concat (intersperse "," libs) ++ "\"")

80+ intercalate "," libs ++ "\"")

81 Just x -> do putIState $ i { idris_dynamic_libs = x:ls }

82 return (Left x)

83 where findDyLib :: [DynamicLib] -> String -> Maybe DynamicLib

@@ -96,6 +96,33 @@ addAutoImport fp = do i <- getIState

96 put (i { idris_options = opts { opt_autoImport =

97 fp : opt_autoImport opts } } )

98

99+addDefinedName :: Name -> Idris ()

100+addDefinedName n = do ist <- getIState

101+ putIState $ ist { idris_inmodule = S.insert n (idris_inmodule ist) }

102+

103+getDefinedNames :: Idris [Name]

104+getDefinedNames = do ist <- getIState

105+ return (S.toList (idris_inmodule ist))

106+

107+addTT :: Term -> Idris (Maybe Term)

108+addTT t = do ist <- getIState

109+ case M.lookup t (idris_ttstats ist) of

110+ Nothing -> do let tt' = M.insert t (1, t) (idris_ttstats ist)

111+ putIState $ ist { idris_ttstats = tt' }

112+ return Nothing

113+ Just (i, t') -> do let tt' = M.insert t' (i + 1, t') (idris_ttstats ist)

114+ putIState $ ist { idris_ttstats = tt' }

115+ return (Just t')

116+

117+dumpTT :: Idris ()

118+dumpTT = do ist <- get

119+ let sts = sortBy count (M.toList (idris_ttstats ist))

120+ mapM_ dump sts

121+ return ()

122+ where

123+ count (_,x) (_,y) = compare y x

124+ dump (tm, val) = runIO $ putStrLn (show val ++ ": " ++ show tm)

125+

99addHdr :: Codegen -> String -> Idris ()

126addHdr :: Codegen -> String -> Idris ()

100addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i }

127addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i }

101

128

@@ -180,6 +207,11 @@ setAccessibility n a

180 let ctxt = setAccess n a (tt_ctxt i)

207 let ctxt = setAccess n a (tt_ctxt i)

181 putIState $ i { tt_ctxt = ctxt }

208 putIState $ i { tt_ctxt = ctxt }

182

209

210+-- | get the accessibility of a name outside this module

211+getFromHideList :: Name -> Idris (Maybe Accessibility)

212+getFromHideList n = do i <- getIState

213+ return $ lookupCtxtExact n (hide_list i)

214+

183setTotality :: Name -> Totality -> Idris ()

215setTotality :: Name -> Totality -> Idris ()

184setTotality n a

216setTotality n a

185 = do i <- getIState

217 = do i <- getIState

@@ -203,8 +235,7 @@ getCoercionsTo i ty =

203 findCoercions t (n : ns) =

235 findCoercions t (n : ns) =

204 let ps = case lookupTy n (tt_ctxt i) of

236 let ps = case lookupTy n (tt_ctxt i) of

205 [ty'] -> case unApply (getRetTy (normalise (tt_ctxt i) [] ty')) of

237 [ty'] -> case unApply (getRetTy (normalise (tt_ctxt i) [] ty')) of

206− (t', _) ->

238+ (t', _) -> [n | t == t']

207− if t == t' then [n] else []

208 _ -> [] in

239 _ -> [] in

209 ps ++ findCoercions t ns

240 ps ++ findCoercions t ns

210

241

@@ -213,6 +244,14 @@ addToCG n cg

213 = do i <- getIState

244 = do i <- getIState

214 putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) }

245 putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) }

215

246

247+addCalls :: Name -> [Name] -> Idris ()

248+addCalls n calls

249+ = do i <- getIState

250+ case lookupCtxtExact n (idris_callgraph i) of

251+ Nothing -> addToCG n (CGInfo calls [] [])

252+ Just (CGInfo cs scg used) ->

253+ addToCG n (CGInfo (nub (calls ++ cs)) scg used)

254+

216addTyInferred :: Name -> Idris ()

255addTyInferred :: Name -> Idris ()

217addTyInferred n

256addTyInferred n

218 = do i <- getIState

257 = do i <- getIState

@@ -228,7 +267,7 @@ addTyInfConstraints fc ts = do logLvl 2 $ "TI missing: " ++ show ts

228 findMVApps x y

267 findMVApps x y

229 = do let (fx, argsx) = unApply x

268 = do let (fx, argsx) = unApply x

230 let (fy, argsy) = unApply y

269 let (fy, argsy) = unApply y

231− if (not (fx == fy))

270+ if (fx /= fy)

232 then do

271 then do

233 tryAddMV fx y

272 tryAddMV fx y

234 tryAddMV fy x

273 tryAddMV fy x

@@ -309,7 +348,7 @@ allNames :: [Name] -> Name -> Idris [Name]

309allNames ns n | n `elem` ns = return []

348allNames ns n | n `elem` ns = return []

310allNames ns n = do i <- getIState

349allNames ns n = do i <- getIState

311 case lookupCtxtExact n (idris_callgraph i) of

350 case lookupCtxtExact n (idris_callgraph i) of

312− Just ns' -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))

351+ Just ns' -> do more <- mapM (allNames (n:ns)) (calls ns')

313 return (nub (n : concat more))

352 return (nub (n : concat more))

314 _ -> return [n]

353 _ -> return [n]

315

354

@@ -341,11 +380,6 @@ getNameHints i n =

341 [ns] -> ns

380 [ns] -> ns

342 _ -> []

381 _ -> []

343

382

344−-- Issue #1737 in the Issue Tracker.

345−-- https://github.com/idris-lang/Idris-dev/issues/1737

346−addToCalledG :: Name -> [Name] -> Idris ()

347−addToCalledG n ns = return () -- TODO

348−

349addDeprecated :: Name -> String -> Idris ()

383addDeprecated :: Name -> String -> Idris ()

350addDeprecated n reason = do i <- getIState

384addDeprecated n reason = do i <- getIState

351 putIState $ i { idris_deprecated = addDef n reason (idris_deprecated i) }

385 putIState $ i { idris_deprecated = addDef n reason (idris_deprecated i) }

@@ -439,7 +473,8 @@ addIBC ibc@(IBCDef n)

439addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }

473addIBC ibc = do i <- getIState; putIState $ i { ibc_write = ibc : ibc_write i }

440

474

441clearIBC :: Idris ()

475clearIBC :: Idris ()

442−clearIBC = do i <- getIState; putIState $ i { ibc_write = [] }

476+clearIBC = do i <- getIState; putIState $ i { ibc_write = [],

477+ idris_inmodule = S.empty }

443

478

444resetNameIdx :: Idris ()

479resetNameIdx :: Idris ()

445resetNameIdx = do i <- getIState

480resetNameIdx = do i <- getIState

@@ -611,7 +646,7 @@ addDeferredTyCon = addDeferred' (TCon 0 0)

611

646

612-- | Save information about a name that is not yet defined

647-- | Save information about a name that is not yet defined

613addDeferred' :: NameType

648addDeferred' :: NameType

614− -> [(Name, (Int, Maybe Name, Type, [Name], Bool))]

649+ -> [(Name, (Int, Maybe Name, Type, [Name], Bool, Bool))]

615 -- ^ The Name is the name being made into a metavar,

650 -- ^ The Name is the name being made into a metavar,

616 -- the Int is the number of vars that are part of a

651 -- the Int is the number of vars that are part of a

617 -- putative proof context, the Maybe Name is the

652 -- putative proof context, the Maybe Name is the

@@ -620,10 +655,11 @@ addDeferred' :: NameType

620 -- allowed

655 -- allowed

621 -> Idris ()

656 -> Idris ()

622addDeferred' nt ns

657addDeferred' 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

624 mapM_ (\(n, _) -> when (not (n `elem` primDefs)) $ addIBC (IBCMetavar n)) ns

659 mapM_ (\(n, _) -> when (not (n `elem` primDefs)) $ addIBC (IBCMetavar n)) ns

625 i <- getIState

660 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 ++

627 idris_metavars i }

663 idris_metavars i }

628 where

664 where

629 -- 'tidyNames' is to generate user accessible names in case they are

665 -- 'tidyNames' is to generate user accessible names in case they are

@@ -636,9 +672,13 @@ addDeferred' nt ns

636 Bind n' b $ tidyNames (S.insert n' used) sc

672 Bind n' b $ tidyNames (S.insert n' used) sc

637 tidyNames used b = b

673 tidyNames used b = b

638

674

639−solveDeferred :: Name -> Idris ()

675+solveDeferred :: FC -> Name -> Idris ()

640−solveDeferred n = do i <- getIState

676+solveDeferred fc n

641− putIState $ i { idris_metavars =

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 =

642 filter (\(n', _) -> n/=n')

682 filter (\(n', _) -> n/=n')

643 (idris_metavars i),

683 (idris_metavars i),

644 ibc_write =

684 ibc_write =

@@ -738,6 +778,16 @@ logLevel :: Idris Int

738logLevel = do i <- getIState

778logLevel = do i <- getIState

739 return (opt_logLevel (idris_options i))

779 return (opt_logLevel (idris_options i))

740

780

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+

741setErrContext :: Bool -> Idris ()

791setErrContext :: Bool -> Idris ()

742setErrContext t = do i <- getIState

792setErrContext t = do i <- getIState

743 let opts = idris_options i

793 let opts = idris_options i

@@ -1024,7 +1074,7 @@ logLvlCats cs l str = do

1024 runIO . hPutStrLn h $ convSExp "log" good n

1074 runIO . hPutStrLn h $ convSExp "log" good n

1025 where

1075 where

1026 inCat :: [LogCat] -> [LogCat] -> Bool

1076 inCat :: [LogCat] -> [LogCat] -> Bool

1027− inCat cs cats = or $ map (\x -> elem x cats) cs

1077+ inCat cs cats = any (`elem` cats) cs

1028

1078

1029cmdOptType :: Opt -> Idris Bool

1079cmdOptType :: Opt -> Idris Bool

1030cmdOptType x = do i <- getIState

1080cmdOptType x = do i <- getIState

@@ -1101,25 +1151,25 @@ expandParams dec ps ns infs tm = en 0 tm

1101 | n `nselem` ns = PQuote (Var (dec n))

1151 | n `nselem` ns = PQuote (Var (dec n))

1102 en 0 (PApp fc (PInferRef fc' hl n) as)

1152 en 0 (PApp fc (PInferRef fc' hl n) as)

1103 | n `nselem` ns = PApp fc (PInferRef fc' hl (dec n))

1153 | 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))

1105 en 0 (PApp fc (PRef fc' hl n) as)

1155 en 0 (PApp fc (PRef fc' hl n) as)

1106 | n `elem` infs = PApp fc (PInferRef fc' hl (dec n))

1156 | 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))

1108 | n `nselem` ns = PApp fc (PRef fc' hl (dec n))

1158 | 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))

1110 en 0 (PAppBind fc (PRef fc' hl n) as)

1160 en 0 (PAppBind fc (PRef fc' hl n) as)

1111 | n `elem` infs = PAppBind fc (PInferRef fc' hl (dec n))

1161 | 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))

1113 | n `nselem` ns = PAppBind fc (PRef fc' hl (dec n))

1163 | 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))

1115 en 0 (PRef fc hl n)

1165 en 0 (PRef fc hl n)

1116 | n `elem` infs = PApp fc (PInferRef fc hl (dec n))

1166 | 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)

1118 | n `nselem` ns = PApp fc (PRef fc hl (dec n))

1168 | 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)

1120 en 0 (PInferRef fc hl n)

1170 en 0 (PInferRef fc hl n)

1121 | n `nselem` ns = PApp fc (PInferRef fc hl (dec n))

1171 | 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)

1123 en 0 (PApp fc f as) = PApp fc (en 0 f) (map (fmap (en 0)) as)

1173 en 0 (PApp fc f as) = PApp fc (en 0 f) (map (fmap (en 0)) as)

1124 en 0 (PAppBind fc f as) = PAppBind fc (en 0 f) (map (fmap (en 0)) as)

1174 en 0 (PAppBind fc f as) = PAppBind fc (en 0 f) (map (fmap (en 0)) as)

1125 en 0 (PCase fc c os) = PCase fc (en 0 c) (map (pmap (en 0)) os)

1175 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)

1191 removeBound lhs ns = ns \\ nub (bnames lhs)

1241 removeBound lhs ns = ns \\ nub (bnames lhs)

1192

1242

1193 bnames (PRef _ _ n) = [n]

1243 bnames (PRef _ _ n) = [n]

1194− bnames (PApp _ _ args) = concatMap bnames (map getTm args)

1244+ bnames (PApp _ _ args) = concatMap (bnames . getTm) args

1195 bnames (PPair _ _ _ l r) = bnames l ++ bnames r

1245 bnames (PPair _ _ _ l r) = bnames l ++ bnames r

1196 bnames (PDPair _ _ _ l Placeholder r) = bnames l ++ bnames r

1246 bnames (PDPair _ _ _ l Placeholder r) = bnames l ++ bnames r

1197 bnames _ = []

1247 bnames _ = []

@@ -1227,10 +1277,10 @@ expandParamsD rhs ist dec ps ns (PClass doc info f cs n nfc params pDocs fds dec

1227 (map (expandParamsD rhs ist dec ps ns) decls)

1277 (map (expandParamsD rhs ist dec ps ns) decls)

1228 cn

1278 cn

1229 cd

1279 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)

1231 = PInstance doc argDocs info f

1281 = PInstance doc argDocs info f

1232 (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)

1282 (map (\ (n, t) -> (n, expandParams dec ps ns [] t)) cs)

1233− n

1283+ acc opts n

1234 nfc

1284 nfc

1235 (map (expandParams dec ps ns []) params)

1285 (map (expandParams dec ps ns []) params)

1236 (expandParams dec ps ns [] ty)

1286 (expandParams dec ps ns [] ty)

@@ -1258,9 +1308,9 @@ getPriority i tm = 1 -- pri tm

1258 pri (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))

1308 pri (PPi _ _ _ x y) = max 5 (max (pri x) (pri y))

1259 pri (PTrue _ _) = 0

1309 pri (PTrue _ _) = 0

1260 pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r))

1310 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)))

1311+ pri (PApp _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))

1262− pri (PAppBind _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

1312+ pri (PAppBind _ f as) = max 1 (max (pri f) (foldr (max . pri . getTm) 0 as))

1263− pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as)))

1313+ pri (PCase _ f as) = max 1 (max (pri f) (foldr (max . pri . snd) 0 as))

1264 pri (PTyped l r) = pri l

1314 pri (PTyped l r) = pri l

1265 pri (PPair _ _ _ l r) = max 1 (max (pri l) (pri r))

1315 pri (PPair _ _ _ l r) = max 1 (max (pri l) (pri r))

1266 pri (PDPair _ _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

1316 pri (PDPair _ _ _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

@@ -1277,11 +1327,11 @@ addStatics n tm ptm =

1277 let paramnames

1327 let paramnames

1278 = nub $ case lookupCtxtExact n (idris_fninfo ist) of

1328 = nub $ case lookupCtxtExact n (idris_fninfo ist) of

1279 Just p -> getNamesFrom 0 (fn_params p) tm ++

1329 Just p -> getNamesFrom 0 (fn_params p) tm ++

1280− concatMap (getParamNames ist) (map snd statics)

1330+ concatMap (getParamNames ist . snd) statics

1281− _ -> concatMap (getParamNames ist) (map snd statics)

1331+ _ -> concatMap (getParamNames ist . snd) statics

1282

1332

1283− let stnames = nub $ concatMap freeArgNames (map snd statics)

1333+ let stnames = nub $ concatMap (freeArgNames . snd) statics

1284− let dnames = (nub $ concatMap freeArgNames (map snd dynamics))

1334+ let dnames = (nub $ concatMap (freeArgNames . snd) dynamics)

1285 \\ paramnames

1335 \\ paramnames

1286 -- also get the arguments which are 'uniquely inferrable' from

1336 -- also get the arguments which are 'uniquely inferrable' from

1287 -- statics (see sec 4.2 of "Scrapping Your Inefficient Engine")

1337 -- statics (see sec 4.2 of "Scrapping Your Inefficient Engine")

@@ -1290,7 +1340,7 @@ addStatics n tm ptm =

1290 filter (\x -> not (elem x dnames)) stnames

1340 filter (\x -> not (elem x dnames)) stnames

1291 let stpos = staticList statics' tm

1341 let stpos = staticList statics' tm

1292 i <- getIState

1342 i <- getIState

1293− when (not (null statics)) $

1343+ unless (null statics) $

1294 logLvl 3 $ "Statics for " ++ show n ++ " " ++ show tm ++ "\n"

1344 logLvl 3 $ "Statics for " ++ show n ++ " " ++ show tm ++ "\n"

1295 ++ showTmImpls ptm ++ "\n"

1345 ++ showTmImpls ptm ++ "\n"

1296 ++ show statics ++ "\n" ++ show dynamics

1346 ++ show statics ++ "\n" ++ show dynamics

@@ -1376,7 +1426,7 @@ addUsingConstraints syn fc t

1376 | otherwise = doAdd cs ns t

1426 | otherwise = doAdd cs ns t

1377

1427

1378 mkConst c args = PApp fc (PRef fc [] c)

1428 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)

1380

1430

1381 getConstraints (PPi (Constraint _ _) _ _ c sc)

1431 getConstraints (PPi (Constraint _ _) _ _ c sc)

1382 = getcapp c ++ getConstraints sc

1432 = getcapp c ++ getConstraints sc

@@ -1395,10 +1445,14 @@ addUsingConstraints syn fc t

1395addUsingImpls :: SyntaxInfo -> Name -> FC -> PTerm -> Idris PTerm

1445addUsingImpls :: SyntaxInfo -> Name -> FC -> PTerm -> Idris PTerm

1396addUsingImpls syn n fc t

1446addUsingImpls syn n fc t

1397 = do ist <- getIState

1447 = 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+

1399 let badnames = filter (\n -> not (implicitable n) &&

1453 let badnames = filter (\n -> not (implicitable n) &&

1400 n `notElem` (map iname uimpls)) ns

1454 n `notElem` (map iname uimpls)) ns

1401− when (not (null badnames)) $

1455+ unless (null badnames) $

1402 throwError (At fc (Elaborating "type of " n Nothing

1456 throwError (At fc (Elaborating "type of " n Nothing

1403 (NoSuchVariable (head badnames))))

1457 (NoSuchVariable (head badnames))))

1404 let cs = getArgnames t -- get already bound names

1458 let cs = getArgnames t -- get already bound names

@@ -1481,15 +1535,19 @@ implicit info syn n ptm = implicit' info syn [] n ptm

1481implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1535implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1482implicit' info syn ignore n ptm

1536implicit' info syn ignore n ptm

1483 = do i <- getIState

1537 = do i <- getIState

1484− let (tm', impdata) = implicitise syn ignore i ptm

1538+ auto <- getAutoImpls

1485− defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

1539+ if not auto

1486−-- let (tm'', spos) = findStatics i tm'

1540+ then return ptm

1487− putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1541+ else do

1488− addIBC (IBCImp n)

1542+ let (tm', impdata) = implicitise syn ignore i ptm

1489− logLvl 5 ("Implicit " ++ show n ++ " " ++ show impdata)

1543+ defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

1490−-- i <- get

1544+ -- let (tm'', spos) = findStatics i tm'

1491−-- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1545+ putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1492− return tm'

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'

1493 where

1551 where

1494 -- Detect unknown names in default arguments and throw error if found.

1552 -- Detect unknown names in default arguments and throw error if found.

1495 defaultArgCheck :: [Name] -> [PArg] -> Idris ()

1553 defaultArgCheck :: [Name] -> [PArg] -> Idris ()

@@ -1534,12 +1592,12 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1534 -- Find names in argument position in a type, suitable for implicit

1592 -- Find names in argument position in a type, suitable for implicit

1535 -- binding

1593 -- binding

1536 -- Not the function position, but do everything else...

1594 -- Not the function position, but do everything else...

1537− implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv) (map getTm args)

1595+ implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv . getTm) args

1538− implNamesIn uv t = namesIn uv ist t

1596+ implNamesIn uv t = implicitNamesIn (map fst uv) ist t

1539

1597

1540− imps top env (PApp _ f as)

1598+ imps top env ty@(PApp _ f as)

1541 = do (decls, ns) <- get

1599 = do (decls, ns) <- get

1542− let isn = concatMap (namesIn uvars ist) (map getTm as)

1600+ let isn = nub (implNamesIn uvars ty)

1543 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1601 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1544 imps top env (PPi (Imp l _ _ _) n _ ty sc)

1602 imps top env (PPi (Imp l _ _ _) n _ ty sc)

1545 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

1603 = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

@@ -1644,9 +1702,9 @@ addImpl' inpat env infns imp_meths ist ptm

1644 ai :: Bool -> Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm

1702 ai :: Bool -> Bool -> [(Name, Maybe PTerm)] -> [[T.Text]] -> PTerm -> PTerm

1645 ai inpat qq env ds (PRef fc fcs f)

1703 ai inpat qq env ds (PRef fc fcs f)

1646 | f `elem` infns = PInferRef fc fcs f

1704 | 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 []

1648 ai inpat qq env ds (PHidden (PRef fc hl f))

1706 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 [])

1650 ai inpat qq env ds (PRewrite fc l r g)

1708 ai inpat qq env ds (PRewrite fc l r g)

1651 = let l' = ai inpat qq env ds l

1709 = let l' = ai inpat qq env ds l

1652 r' = ai inpat qq env ds r

1710 r' = ai inpat qq env ds r

@@ -1675,9 +1733,8 @@ addImpl' inpat env infns imp_meths ist ptm

1675 ai inpat qq env ds (PApp fc ftm@(PRef ffc hl f) as)

1733 ai inpat qq env ds (PApp fc ftm@(PRef ffc hl f) as)

1676 | f `elem` infns = ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as)

1734 | f `elem` infns = ai inpat qq env ds (PApp fc (PInferRef ffc hl f) as)

1677 | not (f `elem` map fst env)

1735 | not (f `elem` map fst env)

1678− = let as' = map (fmap (ai inpat qq env ds)) as

1736+ = let as' = map (fmap (ai inpat qq env ds)) as in

1679− asdotted' = map (fmap (ai False qq env ds)) as in

1737+ handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as'

1680− handleErr $ aiFn topname inpat False qq imp_meths ist fc f ffc ds as' asdotted'

1681 | Just (Just ty) <- lookup f env =

1738 | Just (Just ty) <- lookup f env =

1682 let as' = map (fmap (ai inpat qq env ds)) as

1739 let as' = map (fmap (ai inpat qq env ds)) as

1683 arity = getPArity ty in

1740 arity = getPArity ty in

@@ -1750,9 +1807,8 @@ aiFn :: Name -> Bool -> Bool -> Bool

1750 -> Name -- ^ function being applied

1807 -> Name -- ^ function being applied

1751 -> FC -> [[T.Text]]

1808 -> FC -> [[T.Text]]

1752 -> [PArg] -- ^ initial arguments (if in a pattern)

1809 -> [PArg] -- ^ initial arguments (if in a pattern)

1753− -> [PArg] -- ^ initial arguments (if in an expression)

1754 -> Either Err PTerm

1810 -> 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 []

1756 | inpat && implicitable f && unqualified f = Right $ PPatvar ffc f

1812 | inpat && implicitable f && unqualified f = Right $ PPatvar ffc f

1757 | otherwise

1813 | otherwise

1758 = case lookupDef f (tt_ctxt ist) of

1814 = case lookupDef f (tt_ctxt ist) of

@@ -1762,7 +1818,7 @@ aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _

1762 if (not (vname f) || tcname f

1818 if (not (vname f) || tcname f

1763 || any (conCaf (tt_ctxt ist)) ialts)

1819 || any (conCaf (tt_ctxt ist)) ialts)

1764-- any constructor alts || any allImp ialts))

1820-- 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

1766 else Right $ PPatvar ffc f

1822 else Right $ PPatvar ffc f

1767 where imp (PExp _ _ _ _) = False

1823 where imp (PExp _ _ _ _) = False

1768 imp _ = True

1824 imp _ = True

@@ -1780,9 +1836,9 @@ aiFn topname inpat True qq imp_meths ist fc f ffc ds [] _

1780 vname (UN n) = True -- non qualified

1836 vname (UN n) = True -- non qualified

1781 vname _ = False

1837 vname _ = False

1782

1838

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

1784 | f `elem` primNames = Right $ PApp fc (PRef ffc [ffc] f) as

1840 | 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

1786 -- This is where namespaces get resolved by adding PAlternative

1842 -- This is where namespaces get resolved by adding PAlternative

1787 = do let ns = lookupCtxtName f (idris_implicits ist)

1843 = do let ns = lookupCtxtName f (idris_implicits ist)

1788 let nh = filter (\(n, _) -> notHidden n) ns

1844 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

1791 x -> x

1847 x -> x

1792 case ns' of

1848 case ns' of

1793 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))

1849 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))

1794− (insertImpl ns (chooseArgs f' as asexp))

1850+ (insertImpl ns as)

1795 [] -> if f `elem` (map fst (idris_metavars ist))

1851 [] -> if f `elem` (map fst (idris_metavars ist))

1796 then Right $ PApp fc (PRef ffc [ffc] f) as

1852 then Right $ PApp fc (PRef ffc [ffc] f) as

1797 else Right $ mkPApp fc (length as) (PRef ffc [ffc] f) as

1853 else Right $ mkPApp fc (length as) (PRef ffc [ffc] f) as

1798 alts -> Right $

1854 alts -> Right $

1799 PAlternative [] (ExactlyOne True) $

1855 PAlternative [] (ExactlyOne True) $

1800 map (\(f', ns) -> mkPApp fc (length ns) (PRef ffc [ffc] (isImpName f f'))

1856 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

1802 where

1858 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−

1812 -- if the name is in imp_meths, we should actually refer to the bound

1859 -- if the name is in imp_meths, we should actually refer to the bound

1813 -- name rather than the global one after expanding implicits

1860 -- name rather than the global one after expanding implicits

1814 isImpName f f' | f `elem` imp_meths = f

1861 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

1823

1870

1824 notHidden n = case getAccessibility n of

1871 notHidden n = case getAccessibility n of

1825 Hidden -> False

1872 Hidden -> False

1873+ Private -> False

1826 _ -> True

1874 _ -> True

1827

1875

1828 getAccessibility n

1876 getAccessibility n

@@ -1854,9 +1902,9 @@ aiFn topname inpat expat qq imp_meths ist fc f ffc ds as asexp

1854 case find n imps [] of

1902 case find n imps [] of

1855 Just (tm, imps') ->

1903 Just (tm, imps') ->

1856 PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given imps'

1904 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

1905+ Nothing ->

1858− PImp p True l n ph :

1906+ PImp p True l n Placeholder :

1859− insImpAcc (M.insert n ph pnas) ps given imps

1907+ insImpAcc (M.insert n Placeholder pnas) ps given imps

1860 insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given imps =

1908 insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given imps =

1861 let sc = addImpl imp_meths ist (substMatches (M.toList pnas) sc') in

1909 let sc = addImpl imp_meths ist (substMatches (M.toList pnas) sc') in

1862 case find n imps [] of

1910 case find n imps [] of

src/Idris/AbsSyntaxTree.hs+478−463

@@ -94,6 +94,7 @@ data IOption = IOption {

94 , opt_printdepth :: Maybe Int

95 , opt_evaltypes :: Bool -- ^ normalise types in :t

96 , opt_desugarnats :: Bool

97+ , opt_autoimpls :: Bool

97 } deriving (Show, Eq)

98 } deriving (Show, Eq)

98

99

99defaultOpts = IOption { opt_logLevel = 0

100defaultOpts = IOption { opt_logLevel = 0

@@ -121,6 +122,7 @@ defaultOpts = IOption { opt_logLevel = 0

121 , opt_printdepth = Just 5000

122 , opt_printdepth = Just 5000

122 , opt_evaltypes = True

123 , opt_evaltypes = True

123 , opt_desugarnats = False

124 , opt_desugarnats = False

125+ , opt_autoimpls = True

124 }

126 }

125

127

126data PPOption = PPOption {

128data PPOption = PPOption {

@@ -194,7 +196,6 @@ data IState = IState {

194 -- ^ list of lhs/rhs, and a list of missing clauses

196 -- ^ list of lhs/rhs, and a list of missing clauses

195 idris_flags :: Ctxt [FnOpt],

197 idris_flags :: Ctxt [FnOpt],

196 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

198 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

197− idris_calledgraph :: Ctxt [Name],

198 idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]),

199 idris_docstrings :: Ctxt (Docstring DocTerm, [(Name, Docstring DocTerm)]),

199 idris_moduledocs :: Ctxt (Docstring DocTerm),

200 idris_moduledocs :: Ctxt (Docstring DocTerm),

200 -- ^ module documentation is saved in a special MN so the context

201 -- ^ module documentation is saved in a special MN so the context

@@ -210,12 +211,14 @@ data IState = IState {

210 idris_name :: Int,

211 idris_name :: Int,

211 idris_lineapps :: [((FilePath, Int), PTerm)],

212 idris_lineapps :: [((FilePath, Int), PTerm)],

212 -- ^ Full application LHS on source line

213 -- ^ 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))],

214 -- ^ The currently defined but not proven metavariables. The Int

215 -- ^ The currently defined but not proven metavariables. The Int

215 -- is the number of vars to display as a context, the Maybe Name

216 -- is the number of vars to display as a context, the Maybe Name

216 -- is its top-level function, the [Name] is the list of local variables

217 -- 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+ -- available for proof search and the Bools are whether :p is

218− -- allowed

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)

219 idris_coercions :: [Name],

222 idris_coercions :: [Name],

220 idris_errRev :: [(Term, Term)],

223 idris_errRev :: [(Term, Term)],

221 syntax_rules :: SyntaxRules,

224 syntax_rules :: SyntaxRules,

@@ -235,7 +238,7 @@ data IState = IState {

235 brace_stack :: [Maybe Int],

238 brace_stack :: [Maybe Int],

236 lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

239 lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

237 idris_parsedSpan :: Maybe FC,

240 idris_parsedSpan :: Maybe FC,

238− hide_list :: [(Name, Maybe Accessibility)],

241+ hide_list :: Ctxt Accessibility,

239 default_access :: Accessibility,

242 default_access :: Accessibility,

240 default_total :: Bool,

243 default_total :: Bool,

241 ibc_write :: [IBCWrite],

244 ibc_write :: [IBCWrite],

@@ -262,7 +265,9 @@ data IState = IState {

262 idris_exports :: [Name], -- ^ Functions with ExportList

265 idris_exports :: [Name], -- ^ Functions with ExportList

263 idris_highlightedRegions :: [(FC, OutputAnnotation)], -- ^ Highlighting information to output

266 idris_highlightedRegions :: [(FC, OutputAnnotation)], -- ^ Highlighting information to output

264 idris_parserHighlights :: [(FC, OutputAnnotation)], -- ^ Highlighting information from the parser

267 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)

266 }

271 }

267

272

268-- Required for parsers library, and therefore trifecta

273-- Required for parsers library, and therefore trifecta

@@ -279,11 +284,10 @@ deriving instance NFData SizeChange

279type SCGEntry = (Name, [Maybe (Int, SizeChange)])

284type SCGEntry = (Name, [Maybe (Int, SizeChange)])

280type UsageReason = (Name, Int) -- fn_name, its_arg_number

285type UsageReason = (Name, Int) -- fn_name, its_arg_number

281

286

282−data CGInfo = CGInfo { argsdef :: [Name],

287+data CGInfo = CGInfo { calls :: [Name],

283− calls :: [(Name, [[Name]])],

284 scg :: [SCGEntry],

288 scg :: [SCGEntry],

285− argsused :: [Name],

289+ usedpos :: [(Int, [UsageReason])]

286− usedpos :: [(Int, [UsageReason])] }

290+ }

287 deriving Show

291 deriving Show

288{-!

292{-!

289deriving instance Binary CGInfo

293deriving instance Binary CGInfo

@@ -348,12 +352,13 @@ idrisInit = IState initContext S.empty []

348 emptyContext emptyContext emptyContext emptyContext

352 emptyContext emptyContext emptyContext emptyContext

349 emptyContext emptyContext emptyContext emptyContext

353 emptyContext emptyContext emptyContext emptyContext

350 emptyContext emptyContext emptyContext emptyContext

354 emptyContext emptyContext emptyContext emptyContext

351− emptyContext emptyContext

355+ emptyContext

352 [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] []

356 [] [] [] defaultOpts 6 [] [] [] [] emptySyntaxRules [] [] [] [] [] [] []

353− [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] []

357+ [] [] Nothing [] Nothing [] [] Nothing Nothing emptyContext Private False [] Nothing [] []

354 (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty

358 (RawOutput stdout) True defaultTheme [] (0, emptyContext) emptyContext M.empty

355 AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []

359 AutomaticWidth S.empty S.empty [] Nothing Nothing [] [] M.empty [] [] []

356− emptyContext

360+ emptyContext S.empty M.empty

361+

357

362

358-- | The monad for the main REPL - reading and processing files and updating

363-- | The monad for the main REPL - reading and processing files and updating

359-- global state (hence the IO inner monad).

364-- global state (hence the IO inner monad).

@@ -631,13 +636,17 @@ is_scoped :: Plicity -> Maybe ImplicitInfo

631is_scoped (Imp _ _ _ s) = s

636is_scoped (Imp _ _ _ s) = s

632is_scoped _ = Nothing

637is_scoped _ = Nothing

633

638

634−impl = Imp [] Dynamic False (Just (Impl False True))

639+impl = Imp [] Dynamic False (Just (Impl False True))

635−forall_imp = Imp [] Dynamic False (Just (Impl False False))

640+

641+forall_imp = Imp [] Dynamic False (Just (Impl False False))

636forall_constraint = Imp [] Dynamic False (Just (Impl True False))

642forall_constraint = Imp [] Dynamic False (Just (Impl True False))

637−expl = Exp [] Dynamic False

643+

638−expl_param = Exp [] Dynamic True

644+expl = Exp [] Dynamic False

639−constraint = Constraint [] Static

645+expl_param = Exp [] Dynamic True

640−tacimpl t = TacImp [] Dynamic t

646+

647+constraint = Constraint [] Static

648+

649+tacimpl t = TacImp [] Dynamic t

641

650

642data FnOpt = Inlinable -- always evaluate when simplifying

651data FnOpt = Inlinable -- always evaluate when simplifying

643 | TotalFn | PartialFn | CoveringFn

652 | TotalFn | PartialFn | CoveringFn

@@ -695,7 +704,7 @@ data PDecl' t

695 FC -- Record name precise location

704 FC -- Record name precise location

696 [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span

705 [(Name, FC, Plicity, t)] -- Parameters, where FC is precise name span

697 [(Name, Docstring (Either Err t))] -- Param Docs

706 [(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

699 (Maybe (Name, FC)) -- Optional constructor name and location

708 (Maybe (Name, FC)) -- Optional constructor name and location

700 (Docstring (Either Err t)) -- Constructor doc

709 (Docstring (Either Err t)) -- Constructor doc

701 SyntaxInfo -- Constructor SyntaxInfo

710 SyntaxInfo -- Constructor SyntaxInfo

@@ -717,6 +726,8 @@ data PDecl' t

717 [(Name, Docstring (Either Err t))] -- Parameter docs

726 [(Name, Docstring (Either Err t))] -- Parameter docs

718 SyntaxInfo

727 SyntaxInfo

719 FC [(Name, t)] -- constraints

728 FC [(Name, t)] -- constraints

729+ Accessibility

730+ FnOpts

720 Name -- class

731 Name -- class

721 FC -- precise location of class

732 FC -- precise location of class

722 [t] -- parameters

733 [t] -- parameters

@@ -756,6 +767,7 @@ data Directive = DLib Codegen String |

756 DErrorHandlers Name FC Name FC [(Name, FC)] |

767 DErrorHandlers Name FC Name FC [(Name, FC)] |

757 DLanguage LanguageExt |

768 DLanguage LanguageExt |

758 DDeprecate Name String |

769 DDeprecate Name String |

770+ DAutoImplicits Bool |

759 DUsed FC Name Name

771 DUsed FC Name Name

760

772

761-- | A set of instructions for things that need to happen in IState

773-- | A set of instructions for things that need to happen in IState

@@ -763,6 +775,9 @@ data Directive = DLib Codegen String |

763data RDeclInstructions = RTyDeclInstrs Name FC [PArg] Type

775data RDeclInstructions = RTyDeclInstrs Name FC [PArg] Type

764 | RClausesInstrs Name [([(Name, Term)], Term, Term)]

776 | RClausesInstrs Name [([(Name, Term)], Term, Term)]

765 | RAddInstance Name Name

777 | RAddInstance Name Name

778+ | RDatatypeDeclInstrs Name [PArg]

779+ | RDatatypeDefnInstrs Name Type [(Name, [PArg], Type)]

780+ -- ^ Datatype, constructors

766

781

767-- | For elaborator state

782-- | For elaborator state

768data EState = EState {

783data EState = EState {

@@ -875,10 +890,10 @@ mapPDeclFC f g (PClass doc syn fc constrs n nfc params paramDocs det body ctor c

875 (map (mapPDeclFC f g) body)

890 (map (mapPDeclFC f g) body)

876 (fmap (\(n, nfc) -> (n, g nfc)) ctor)

891 (fmap (\(n, nfc) -> (n, g nfc)) ctor)

877 ctorDoc

892 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) =

879 PInstance doc paramDocs syn (f fc)

894 PInstance doc paramDocs syn (f fc)

880 (map (\(constrN, constrT) -> (constrN, mapPTermFC f g constrT)) constrs)

895 (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)

882 (mapPTermFC f g instTy)

897 (mapPTermFC f g instTy)

883 instN

898 instN

884 (map (mapPDeclFC f g) body)

899 (map (mapPDeclFC f g) body)

@@ -918,7 +933,7 @@ declared (PParams _ _ ds) = concatMap declared ds

918declared (PNamespace _ _ ds) = concatMap declared ds

933declared (PNamespace _ _ ds) = concatMap declared ds

919declared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

934declared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

920declared (PClass _ _ _ _ n _ _ _ _ ms cn cd) = n : (map fst (maybeToList cn) ++ concatMap declared ms)

935declared (PClass _ _ _ _ n _ _ _ _ ms cn cd) = n : (map fst (maybeToList cn) ++ concatMap declared ms)

921−declared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

936+declared (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = []

922declared (PDSL n _) = [n]

937declared (PDSL n _) = [n]

923declared (PSyntax _ _) = []

938declared (PSyntax _ _) = []

924declared (PMutual _ ds) = concatMap declared ds

939declared (PMutual _ ds) = concatMap declared ds

@@ -927,39 +942,39 @@ declared _ = []

927

942

928-- get the names declared, not counting nested parameter blocks

943-- get the names declared, not counting nested parameter blocks

929tldeclared :: PDecl -> [Name]

944tldeclared :: PDecl -> [Name]

930−tldeclared (PFix _ _ _) = []

945+tldeclared (PFix _ _ _) = []

931−tldeclared (PTy _ _ _ _ _ n _ t) = [n]

946+tldeclared (PTy _ _ _ _ _ n _ t) = [n]

932−tldeclared (PPostulate _ _ _ _ _ _ n t) = [n]

947+tldeclared (PPostulate _ _ _ _ _ _ n t) = [n]

933−tldeclared (PClauses _ _ n _) = [] -- not a declaration

948+tldeclared (PClauses _ _ n _) = [] -- not a declaration

934−tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

949+tldeclared (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

935tldeclared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

950tldeclared (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

936 where fstt (_, _, a, _, _, _, _) = a

951 where fstt (_, _, a, _, _, _, _) = a

937−tldeclared (PParams _ _ ds) = []

952+tldeclared (PParams _ _ ds) = []

938−tldeclared (PMutual _ ds) = concatMap tldeclared ds

953+tldeclared (PMutual _ ds) = concatMap tldeclared ds

939−tldeclared (PNamespace _ _ ds) = concatMap tldeclared ds

954+tldeclared (PNamespace _ _ ds) = concatMap tldeclared ds

940−tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)

955+tldeclared (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap tldeclared ms)

941−tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

956+tldeclared (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = []

942−tldeclared _ = []

957+tldeclared _ = []

943

958

944defined :: PDecl -> [Name]

959defined :: PDecl -> [Name]

945−defined (PFix _ _ _) = []

960+defined (PFix _ _ _) = []

946−defined (PTy _ _ _ _ _ n _ t) = []

961+defined (PTy _ _ _ _ _ n _ t) = []

947−defined (PPostulate _ _ _ _ _ _ n t) = []

962+defined (PPostulate _ _ _ _ _ _ n t) = []

948−defined (PClauses _ _ n _) = [n] -- not a declaration

963+defined (PClauses _ _ n _) = [n] -- not a declaration

949−defined (PCAF _ n _) = [n]

964+defined (PCAF _ n _) = [n]

950−defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

965+defined (PData _ _ _ _ _ (PDatadecl n _ _ ts)) = n : map fstt ts

951 where fstt (_, _, a, _, _, _, _) = a

966 where fstt (_, _, a, _, _, _, _) = a

952−defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = []

967+defined (PData _ _ _ _ _ (PLaterdecl n _ _)) = []

953−defined (PParams _ _ ds) = concatMap defined ds

968+defined (PParams _ _ ds) = concatMap defined ds

954−defined (PNamespace _ _ ds) = concatMap defined ds

969+defined (PNamespace _ _ ds) = concatMap defined ds

955−defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

970+defined (PRecord _ _ _ _ n _ _ _ _ cn _ _) = n : map fst (maybeToList cn)

956−defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)

971+defined (PClass _ _ _ _ n _ _ _ _ ms cn _) = n : (map fst (maybeToList cn) ++ concatMap defined ms)

957−defined (PInstance _ _ _ _ _ _ _ _ _ _ _) = []

972+defined (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = []

958−defined (PDSL n _) = [n]

973+defined (PDSL n _) = [n]

959−defined (PSyntax _ _) = []

974+defined (PSyntax _ _) = []

960−defined (PMutual _ ds) = concatMap defined ds

975+defined (PMutual _ ds) = concatMap defined ds

961−defined (PDirective _) = []

976+defined (PDirective _) = []

962−defined _ = []

977+defined _ = []

963

978

964updateN :: [(Name, Name)] -> Name -> Name

979updateN :: [(Name, Name)] -> Name -> Name

965updateN ns n | Just n' <- lookup n ns = n'

980updateN ns n | Just n' <- lookup n ns = n'

@@ -1040,33 +1055,33 @@ data PAltType = ExactlyOne Bool -- ^ flag sets whether delay is allowed

1040-- general-purpose FCs, and the second transforms those that are used

1055-- general-purpose FCs, and the second transforms those that are used

1041-- for semantic source highlighting, so they can be treated specially.

1056-- for semantic source highlighting, so they can be treated specially.

1042mapPTermFC :: (FC -> FC) -> (FC -> FC) -> PTerm -> PTerm

1057mapPTermFC :: (FC -> FC) -> (FC -> FC) -> PTerm -> PTerm

1043−mapPTermFC f g (PQuote q) = PQuote q

1058+mapPTermFC f g (PQuote q) = PQuote q

1044−mapPTermFC f g (PRef fc fcs n) = PRef (g fc) (map g fcs) n

1059+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

1060+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

1061+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)

1062+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)

1063+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)

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)

1050−mapPTermFC f g (PTyped t1 t2) = PTyped (mapPTermFC f g t1) (mapPTermFC f g t2)

1065+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)

1066+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

1067+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)

1068+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

1069+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)

1070+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)

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)

1057−mapPTermFC f g (PTrue fc info) = PTrue (f fc) info

1072+mapPTermFC f g (PTrue fc info) = PTrue (f fc) info

1058−mapPTermFC f g (PResolveTC fc) = PResolveTC (f fc)

1073+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)

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)

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)

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)

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)

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)

1062−mapPTermFC f g (PAs fc n t) = PAs (f fc) n (mapPTermFC f g t)

1077+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)

1078+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)

1079+mapPTermFC f g (PHidden t) = PHidden (mapPTermFC f g t)

1065−mapPTermFC f g (PType fc) = PType (f fc)

1080+mapPTermFC f g (PType fc) = PType (f fc)

1066−mapPTermFC f g (PUniverse u) = PUniverse u

1081+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)

1082+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

1083+mapPTermFC f g (PConstant fc c) = PConstant (f fc) c

1069−mapPTermFC f g Placeholder = Placeholder

1084+mapPTermFC f g Placeholder = Placeholder

1070mapPTermFC f g (PDoBlock dos) = PDoBlock (map mapPDoFC dos)

1085mapPTermFC f g (PDoBlock dos) = PDoBlock (map mapPDoFC dos)

1071 where mapPDoFC (DoExp fc t) = DoExp (f fc) (mapPTermFC f g t)

1086 where mapPDoFC (DoExp fc t) = DoExp (f fc) (mapPTermFC f g t)

1072 mapPDoFC (DoBind fc n nfc t) = DoBind (f fc) n (g nfc) (mapPTermFC f g t)

1087 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)

1074 DoBindP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (map (\(l,r)-> (mapPTermFC f g l, mapPTermFC f g r)) alts)

1089 DoBindP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2) (map (\(l,r)-> (mapPTermFC f g l, mapPTermFC f g r)) alts)

1075 mapPDoFC (DoLet fc n nfc t1 t2) = DoLet (f fc) n (g nfc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1090 mapPDoFC (DoLet fc n nfc t1 t2) = DoLet (f fc) n (g nfc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1076 mapPDoFC (DoLetP fc t1 t2) = DoLetP (f fc) (mapPTermFC f g t1) (mapPTermFC f g t2)

1091 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)

1092+mapPTermFC f g (PIdiom fc t) = PIdiom (f fc) (mapPTermFC f g t)

1078−mapPTermFC f g (PReturn fc) = PReturn (f fc)

1093+mapPTermFC f g (PReturn fc) = PReturn (f fc)

1079−mapPTermFC f g (PMetavar fc n) = PMetavar (g fc) n

1094+mapPTermFC f g (PMetavar fc n) = PMetavar (g fc) n

1080−mapPTermFC f g (PProof tacs) = PProof (map (fmap (mapPTermFC f g)) tacs)

1095+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)

1096+mapPTermFC f g (PTactics tacs) = PTactics (map (fmap (mapPTermFC f g)) tacs)

1082−mapPTermFC f g (PElabError err) = PElabError err

1097+mapPTermFC f g (PElabError err) = PElabError err

1083−mapPTermFC f g PImpossible = PImpossible

1098+mapPTermFC f g PImpossible = PImpossible

1084−mapPTermFC f g (PCoerced t) = PCoerced (mapPTermFC f g t)

1099+mapPTermFC f g (PCoerced t) = PCoerced (mapPTermFC f g t)

1085−mapPTermFC f g (PDisamb msg t) = PDisamb msg (mapPTermFC f g t)

1100+mapPTermFC f g (PDisamb msg t) = PDisamb msg (mapPTermFC f g t)

1086−mapPTermFC f g (PUnifyLog t) = PUnifyLog (mapPTermFC f g t)

1101+mapPTermFC f g (PUnifyLog t) = PUnifyLog (mapPTermFC f g t)

1087−mapPTermFC f g (PNoImplicits t) = PNoImplicits (mapPTermFC f g t)

1102+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)

1103+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)

1104+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

1105+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)

1106+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)

1107+mapPTermFC f g (PQuoteName n x fc) = PQuoteName n x (g fc)

1093

1108

1094{-!

1109{-!

1095dg instance Binary PTerm

1110dg instance Binary PTerm

@@ -1098,28 +1113,27 @@ deriving instance NFData PTerm

1098

1113

1099mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

1114mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

1100mapPT f t = f (mpt t) where

1115mapPT f t = f (mpt t) where

1101− mpt (PLam fc n nfc t s) = PLam fc n nfc (mapPT f t) (mapPT f s)

1116+ 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)

1117+ 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)

1118+ 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)

1119+ mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s) (fmap (mapPT f) g)

1105− (fmap (mapPT f) g)

1120+ mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)

1106− 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)

1107− 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)

1108− 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)

1109− 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)

1110− 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)

1111− mpt (PPair fc hls p l r) = PPair fc hls p (mapPT f l) (mapPT f r)

1112 mpt (PDPair fc hls p l t r) = PDPair fc hls p (mapPT f l) (mapPT f t) (mapPT f r)

1126 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)

1127+ mpt (PAlternative ns a as) = PAlternative ns a (map (mapPT f) as)

1114− mpt (PHidden t) = PHidden (mapPT f t)

1128+ mpt (PHidden t) = PHidden (mapPT f t)

1115− mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds)

1129+ mpt (PDoBlock ds) = PDoBlock (map (fmap (mapPT f)) ds)

1116− mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

1130+ mpt (PProof ts) = PProof (map (fmap (mapPT f)) ts)

1117− mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

1131+ mpt (PTactics ts) = PTactics (map (fmap (mapPT f)) ts)

1118− mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

1132+ mpt (PUnifyLog tm) = PUnifyLog (mapPT f tm)

1119− mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)

1133+ mpt (PDisamb ns tm) = PDisamb ns (mapPT f tm)

1120− mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

1134+ mpt (PNoImplicits tm) = PNoImplicits (mapPT f tm)

1121− mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

1135+ mpt (PGoal fc r n sc) = PGoal fc (mapPT f r) n (mapPT f sc)

1122− mpt x = x

1136+ mpt x = x

1123

1137

1124

1138

1125data PTactic' t = Intro [Name] | Intros | Focus Name

1139data PTactic' t = Intro [Name] | Intros | Focus Name

@@ -1160,39 +1174,39 @@ deriving instance Binary PTactic'

1160deriving instance NFData PTactic'

1174deriving instance NFData PTactic'

1161!-}

1175!-}

1162instance Sized a => Sized (PTactic' a) where

1176instance Sized a => Sized (PTactic' a) where

1163− size (Intro nms) = 1 + size nms

1177+ size (Intro nms) = 1 + size nms

1164− size Intros = 1

1178+ size Intros = 1

1165− size (Focus nm) = 1 + size nm

1179+ size (Focus nm) = 1 + size nm

1166− size (Refine nm bs) = 1 + size nm + length bs

1180+ size (Refine nm bs) = 1 + size nm + length bs

1167− size (Rewrite t) = 1 + size t

1181+ size (Rewrite t) = 1 + size t

1168− size (Induction t) = 1 + size t

1182+ size (Induction t) = 1 + size t

1169− size (LetTac nm t) = 1 + size nm + size t

1183+ size (LetTac nm t) = 1 + size nm + size t

1170− size (Exact t) = 1 + size t

1184+ size (Exact t) = 1 + size t

1171− size Compute = 1

1185+ size Compute = 1

1172− size Trivial = 1

1186+ size Trivial = 1

1173− size Solve = 1

1187+ size Solve = 1

1174− size Attack = 1

1188+ size Attack = 1

1175− size ProofState = 1

1189+ size ProofState = 1

1176− size ProofTerm = 1

1190+ size ProofTerm = 1

1177− size Undo = 1

1191+ size Undo = 1

1178− size (Try l r) = 1 + size l + size r

1192+ size (Try l r) = 1 + size l + size r

1179− size (TSeq l r) = 1 + size l + size r

1193+ size (TSeq l r) = 1 + size l + size r

1180− size (ApplyTactic t) = 1 + size t

1194+ size (ApplyTactic t) = 1 + size t

1181− size (Reflect t) = 1 + size t

1195+ size (Reflect t) = 1 + size t

1182− size (Fill t) = 1 + size t

1196+ size (Fill t) = 1 + size t

1183− size Qed = 1

1197+ size Qed = 1

1184− size Abandon = 1

1198+ size Abandon = 1

1185− size Skip = 1

1199+ size Skip = 1

1186− size (TFail ts) = 1 + size ts

1200+ size (TFail ts) = 1 + size ts

1187− size SourceFC = 1

1201+ size SourceFC = 1

1188− size DoUnify = 1

1202+ size DoUnify = 1

1189− size (CaseTac x) = 1 + size x

1203+ size (CaseTac x) = 1 + size x

1190− size (Equiv t) = 1 + size t

1204+ size (Equiv t) = 1 + size t

1191− size (Claim x y) = 1 + size x + size y

1205+ size (Claim x y) = 1 + size x + size y

1192− size Unfocus = 1

1206+ size Unfocus = 1

1193− size (MatchRefine x) = 1 + size x

1207+ size (MatchRefine x) = 1 + size x

1194 size (LetTacTy x y z) = 1 + size x + size y + size z

1208 size (LetTacTy x y z) = 1 + size x + size y + size z

1195− size TCInstance = 1

1209+ size TCInstance = 1

1196

1210

1197type PTactic = PTactic' PTerm

1211type PTactic = PTactic' PTerm

1198

1212

@@ -1208,11 +1222,11 @@ deriving instance NFData PDo'

1208!-}

1222!-}

1209

1223

1210instance Sized a => Sized (PDo' a) where

1224instance Sized a => Sized (PDo' a) where

1211− size (DoExp fc t) = 1 + size fc + size t

1225+ 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

1226+ 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

1227+ 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

1228+ 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

1229+ size (DoLetP fc l r) = 1 + size fc + size l + size r

1216

1230

1217type PDo = PDo' PTerm

1231type PDo = PDo' PTerm

1218

1232

@@ -1244,10 +1258,10 @@ data ArgOpt = AlwaysShow | HideDisplay | InaccessibleArg | UnknownImp

1244 deriving (Show, Eq, Data, Typeable)

1258 deriving (Show, Eq, Data, Typeable)

1245

1259

1246instance Sized a => Sized (PArg' a) where

1260instance Sized a => Sized (PArg' a) where

1247− size (PImp p _ l nm trm) = 1 + size nm + size trm

1261+ size (PImp p _ l nm trm) = 1 + size nm + size trm

1248− size (PExp p l nm trm) = 1 + size nm + size trm

1262+ 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

1263+ 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

1264+ size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

1251

1265

1252{-!

1266{-!

1253deriving instance Binary PArg'

1267deriving instance Binary PArg'

@@ -1255,43 +1269,43 @@ deriving instance NFData PArg'

1255!-}

1269!-}

1256

1270

1257pimp n t mach = PImp 1 mach [] n t

1271pimp n t mach = PImp 1 mach [] n t

1258−pexp t = PExp 1 [] (sMN 0 "arg") t

1272+pexp t = PExp 1 [] (sMN 0 "arg") t

1259−pconst t = PConstraint 1 [] (sMN 0 "carg") t

1273+pconst t = PConstraint 1 [] (sMN 0 "carg") t

1260ptacimp n s t = PTacImplicit 2 [] n s t

1274ptacimp n s t = PTacImplicit 2 [] n s t

1261

1275

1262type PArg = PArg' PTerm

1276type PArg = PArg' PTerm

1263

1277

1264-- | Get the highest FC in a term, if one exists

1278-- | Get the highest FC in a term, if one exists

1265highestFC :: PTerm -> Maybe FC

1279highestFC :: PTerm -> Maybe FC

1266−highestFC (PQuote _) = Nothing

1280+highestFC (PQuote _) = Nothing

1267−highestFC (PRef fc _ _) = Just fc

1281+highestFC (PRef fc _ _) = Just fc

1268−highestFC (PInferRef fc _ _) = Just fc

1282+highestFC (PInferRef fc _ _) = Just fc

1269−highestFC (PPatvar fc _) = Just fc

1283+highestFC (PPatvar fc _) = Just fc

1270−highestFC (PLam fc _ _ _ _) = Just fc

1284+highestFC (PLam fc _ _ _ _) = Just fc

1271−highestFC (PPi _ _ _ _ _) = Nothing

1285+highestFC (PPi _ _ _ _ _) = Nothing

1272−highestFC (PLet fc _ _ _ _ _) = Just fc

1286+highestFC (PLet fc _ _ _ _ _) = Just fc

1273−highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty

1287+highestFC (PTyped tm ty) = highestFC tm <|> highestFC ty

1274−highestFC (PApp fc _ _) = Just fc

1288+highestFC (PApp fc _ _) = Just fc

1275−highestFC (PAppBind fc _ _) = Just fc

1289+highestFC (PAppBind fc _ _) = Just fc

1276−highestFC (PMatchApp fc _) = Just fc

1290+highestFC (PMatchApp fc _) = Just fc

1277−highestFC (PCase fc _ _) = Just fc

1291+highestFC (PCase fc _ _) = Just fc

1278−highestFC (PIfThenElse fc _ _ _) = Just fc

1292+highestFC (PIfThenElse fc _ _ _) = Just fc

1279−highestFC (PTrue fc _) = Just fc

1293+highestFC (PTrue fc _) = Just fc

1280−highestFC (PResolveTC fc) = Just fc

1294+highestFC (PResolveTC fc) = Just fc

1281−highestFC (PRewrite fc _ _ _) = Just fc

1295+highestFC (PRewrite fc _ _ _) = Just fc

1282−highestFC (PPair fc _ _ _ _) = Just fc

1296+highestFC (PPair fc _ _ _ _) = Just fc

1283−highestFC (PDPair fc _ _ _ _ _) = Just fc

1297+highestFC (PDPair fc _ _ _ _ _) = Just fc

1284−highestFC (PAs fc _ _) = Just fc

1298+highestFC (PAs fc _ _) = Just fc

1285highestFC (PAlternative _ _ args) =

1299highestFC (PAlternative _ _ args) =

1286 case mapMaybe highestFC args of

1300 case mapMaybe highestFC args of

1287 [] -> Nothing

1301 [] -> Nothing

1288 (fc:_) -> Just fc

1302 (fc:_) -> Just fc

1289−highestFC (PHidden _) = Nothing

1303+highestFC (PHidden _) = Nothing

1290−highestFC (PType fc) = Just fc

1304+highestFC (PType fc) = Just fc

1291−highestFC (PUniverse _) = Nothing

1305+highestFC (PUniverse _) = Nothing

1292−highestFC (PGoal fc _ _ _) = Just fc

1306+highestFC (PGoal fc _ _ _) = Just fc

1293−highestFC (PConstant fc _) = Just fc

1307+highestFC (PConstant fc _) = Just fc

1294−highestFC Placeholder = Nothing

1308+highestFC Placeholder = Nothing

1295highestFC (PDoBlock lines) =

1309highestFC (PDoBlock lines) =

1296 case map getDoFC lines of

1310 case map getDoFC lines of

1297 [] -> Nothing

1311 [] -> Nothing

@@ -1303,23 +1317,23 @@ highestFC (PDoBlock lines) =

1303 getDoFC (DoLet fc nm nfc l r) = fc

1317 getDoFC (DoLet fc nm nfc l r) = fc

1304 getDoFC (DoLetP fc l r) = fc

1318 getDoFC (DoLetP fc l r) = fc

1305

1319

1306−highestFC (PIdiom fc _) = Just fc

1320+highestFC (PIdiom fc _) = Just fc

1307−highestFC (PReturn fc) = Just fc

1321+highestFC (PReturn fc) = Just fc

1308−highestFC (PMetavar fc _) = Just fc

1322+highestFC (PMetavar fc _) = Just fc

1309−highestFC (PProof _) = Nothing

1323+highestFC (PProof _) = Nothing

1310−highestFC (PTactics _) = Nothing

1324+highestFC (PTactics _) = Nothing

1311−highestFC (PElabError _) = Nothing

1325+highestFC (PElabError _) = Nothing

1312−highestFC PImpossible = Nothing

1326+highestFC PImpossible = Nothing

1313−highestFC (PCoerced tm) = highestFC tm

1327+highestFC (PCoerced tm) = highestFC tm

1314−highestFC (PDisamb _ opts) = highestFC opts

1328+highestFC (PDisamb _ opts) = highestFC opts

1315−highestFC (PUnifyLog tm) = highestFC tm

1329+highestFC (PUnifyLog tm) = highestFC tm

1316−highestFC (PNoImplicits tm) = highestFC tm

1330+highestFC (PNoImplicits tm) = highestFC tm

1317−highestFC (PQuasiquote _ _) = Nothing

1331+highestFC (PQuasiquote _ _) = Nothing

1318−highestFC (PUnquote tm) = highestFC tm

1332+highestFC (PUnquote tm) = highestFC tm

1319−highestFC (PQuoteName _ _ fc) = Just fc

1333+highestFC (PQuoteName _ _ fc) = Just fc

1320−highestFC (PRunElab fc _ _) = Just fc

1334+highestFC (PRunElab fc _ _) = Just fc

1321−highestFC (PConstSugar fc _) = Just fc

1335+highestFC (PConstSugar fc _) = Just fc

1322−highestFC (PAppImpl t _) = highestFC t

1336+highestFC (PAppImpl t _) = highestFC t

1323

1337

1324-- Type class data

1338-- Type class data

1325

1339

@@ -1397,11 +1411,11 @@ data Syntax = Rule [SSymbol] PTerm SynContext

1397

1411

1398syntaxNames :: Syntax -> [Name]

1412syntaxNames :: Syntax -> [Name]

1399syntaxNames (Rule syms _ _) = mapMaybe ename syms

1413syntaxNames (Rule syms _ _) = mapMaybe ename syms

1400− where ename (Keyword n) = Just n

1414+ where ename (Keyword n) = Just n

1401− ename _ = Nothing

1415+ ename _ = Nothing

1402syntaxNames (DeclRule syms _) = mapMaybe ename syms

1416syntaxNames (DeclRule syms _) = mapMaybe ename syms

1403− where ename (Keyword n) = Just n

1417+ where ename (Keyword n) = Just n

1404− ename _ = Nothing

1418+ ename _ = Nothing

1405

1419

1406syntaxSymbols :: Syntax -> [SSymbol]

1420syntaxSymbols :: Syntax -> [SSymbol]

1407syntaxSymbols (Rule ss _ _) = ss

1421syntaxSymbols (Rule ss _ _) = ss

@@ -1434,9 +1448,9 @@ updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules

1434 where

1448 where

1435 newRules = sortBy (ruleSort `on` syntaxSymbols) (rules ++ sr)

1449 newRules = sortBy (ruleSort `on` syntaxSymbols) (rules ++ sr)

1436

1450

1437− ruleSort [] [] = EQ

1451+ ruleSort [] [] = EQ

1438− ruleSort [] _ = LT

1452+ ruleSort [] _ = LT

1439− ruleSort _ [] = GT

1453+ ruleSort _ [] = GT

1440 ruleSort (s1:ss1) (s2:ss2) =

1454 ruleSort (s1:ss1) (s2:ss2) =

1441 case symCompare s1 s2 of

1455 case symCompare s1 s2 of

1442 EQ -> ruleSort ss1 ss2

1456 EQ -> ruleSort ss1 ss2

@@ -1444,25 +1458,25 @@ updateSyntaxRules rules (SyntaxRules sr) = SyntaxRules newRules

1444

1458

1445 -- Better than creating Ord instance for SSymbol since

1459 -- Better than creating Ord instance for SSymbol since

1446 -- in general this ordering does not really make sense.

1460 -- in general this ordering does not really make sense.

1447− symCompare (Keyword n1) (Keyword n2) = compare n1 n2

1461+ symCompare (Keyword n1) (Keyword n2) = compare n1 n2

1448− symCompare (Keyword _) _ = LT

1462+ symCompare (Keyword _) _ = LT

1449− symCompare (Symbol _) (Keyword _) = GT

1463+ symCompare (Symbol _) (Keyword _) = GT

1450− symCompare (Symbol s1) (Symbol s2) = compare s1 s2

1464+ symCompare (Symbol s1) (Symbol s2) = compare s1 s2

1451− symCompare (Symbol _) _ = LT

1465+ symCompare (Symbol _) _ = LT

1452− symCompare (Binding _) (Keyword _) = GT

1466+ symCompare (Binding _) (Keyword _) = GT

1453− symCompare (Binding _) (Symbol _) = GT

1467+ symCompare (Binding _) (Symbol _) = GT

1454− symCompare (Binding b1) (Binding b2) = compare b1 b2

1468+ symCompare (Binding b1) (Binding b2) = compare b1 b2

1455− symCompare (Binding _) _ = LT

1469+ symCompare (Binding _) _ = LT

1456− symCompare (Expr _) (Keyword _) = GT

1470+ symCompare (Expr _) (Keyword _) = GT

1457− symCompare (Expr _) (Symbol _) = GT

1471+ symCompare (Expr _) (Symbol _) = GT

1458− symCompare (Expr _) (Binding _) = GT

1472+ symCompare (Expr _) (Binding _) = GT

1459− symCompare (Expr e1) (Expr e2) = compare e1 e2

1473+ symCompare (Expr e1) (Expr e2) = compare e1 e2

1460− symCompare (Expr _) _ = LT

1474+ symCompare (Expr _) _ = LT

1461− symCompare (SimpleExpr _) (Keyword _) = GT

1475+ symCompare (SimpleExpr _) (Keyword _) = GT

1462− symCompare (SimpleExpr _) (Symbol _) = GT

1476+ symCompare (SimpleExpr _) (Symbol _) = GT

1463− symCompare (SimpleExpr _) (Binding _) = GT

1477+ symCompare (SimpleExpr _) (Binding _) = GT

1464− symCompare (SimpleExpr _) (Expr _) = GT

1478+ symCompare (SimpleExpr _) (Expr _) = GT

1465− symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2

1479+ symCompare (SimpleExpr e1) (SimpleExpr e2) = compare e1 e2

1466

1480

1467initDSL = DSL (PRef f [] (sUN ">>="))

1481initDSL = DSL (PRef f [] (sUN ">>="))

1468 (PRef f [] (sUN "return"))

1482 (PRef f [] (sUN "return"))

@@ -1534,10 +1548,10 @@ getInferTerm (Bind n b sc) = Bind n b $ getInferTerm sc

1534getInferTerm (App _ (App _ _ _) tm) = tm

1548getInferTerm (App _ (App _ _ _) tm) = tm

1535getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)

1549getInferTerm tm = tm -- error ("getInferTerm " ++ show tm)

1536

1550

1537−getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

1551+getInferType (Bind n b sc) = Bind n (toTy b) $ getInferType sc

1538− where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

1552+ where toTy (Lam t) = Pi Nothing t (TType (UVar 0))

1539− toTy (PVar t) = PVTy t

1553+ toTy (PVar t) = PVTy t

1540− toTy b = b

1554+ toTy b = b

1541getInferType (App _ (App _ _ ty) _) = ty

1555getInferType (App _ (App _ _ ty) _) = ty

1542

1556

1543

1557

@@ -1562,9 +1576,9 @@ pairCon = sNS (sUN "MkPair") ["Builtins"]

1562upairTy = sNS (sUN "UPair") ["Builtins"]

1576upairTy = sNS (sUN "UPair") ["Builtins"]

1563upairCon = sNS (sUN "MkUPair") ["Builtins"]

1577upairCon = sNS (sUN "MkUPair") ["Builtins"]

1564

1578

1565−eqTy = sUN "="

1579+eqTy = sUN "="

1566eqCon = sUN "Refl"

1580eqCon = sUN "Refl"

1567−eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

1581+eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

1568 "The propositional equality type. A proof that `x` = `y`." ++

1582 "The propositional equality type. A proof that `x` = `y`." ++

1569 "\n\n" ++

1583 "\n\n" ++

1570 "To use such a proof, pattern-match on it, and the two equal things will " ++

1584 "To use such a proof, pattern-match on it, and the two equal things will " ++

@@ -1607,8 +1621,8 @@ modDocName :: Name

1607modDocName = sMN 0 "ModuleDocs"

1621modDocName = sMN 0 "ModuleDocs"

1608

1622

1609-- Defined in builtins.idr

1623-- Defined in builtins.idr

1610−sigmaTy = sNS (sUN "Sigma") ["Builtins"]

1624+sigmaTy = sNS (sUN "DPair") ["Builtins"]

1611−sigmaCon = sNS (sUN "MkSigma") ["Builtins"]

1625+sigmaCon = sNS (sUN "MkDPair") ["Builtins"]

1612

1626

1613piBind :: [(Name, PTerm)] -> PTerm -> PTerm

1627piBind :: [(Name, PTerm)] -> PTerm -> PTerm

1614piBind = piBindp expl

1628piBind = piBindp expl

@@ -1648,11 +1662,11 @@ annotationColour ist (AnnConst c) =

1648 in Just $ if constIsType c

1662 in Just $ if constIsType c

1649 then typeColour theme

1663 then typeColour theme

1650 else dataColour theme

1664 else dataColour theme

1651−annotationColour ist (AnnData _ _) = Just $ dataColour (idris_colourTheme ist)

1665+annotationColour ist (AnnData _ _) = Just $ dataColour (idris_colourTheme ist)

1652−annotationColour ist (AnnType _ _) = Just $ typeColour (idris_colourTheme ist)

1666+annotationColour ist (AnnType _ _) = Just $ typeColour (idris_colourTheme ist)

1653−annotationColour ist (AnnBoundName _ True) = Just $ implicitColour (idris_colourTheme ist)

1667+annotationColour ist (AnnBoundName _ True) = Just $ implicitColour (idris_colourTheme ist)

1654annotationColour ist (AnnBoundName _ False) = Just $ boundVarColour (idris_colourTheme ist)

1668annotationColour 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)

1656annotationColour ist (AnnName n _ _ _) =

1670annotationColour ist (AnnName n _ _ _) =

1657 let ctxt = tt_ctxt ist

1671 let ctxt = tt_ctxt ist

1658 theme = idris_colourTheme ist

1672 theme = idris_colourTheme ist

@@ -1738,7 +1752,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1738

1752

1739 st =

1753 st =

1740 case s of

1754 case s of

1741− Static -> text "[static]" <> space

1755+ Static -> text "%static" <> space

1742 _ -> empty

1756 _ -> empty

1743 prettySe d p bnd (PPi (Imp l s _ fa) n _ ty sc)

1757 prettySe d p bnd (PPi (Imp l s _ fa) n _ ty sc)

1744 | ppopt_impl ppo =

1758 | ppopt_impl ppo =

@@ -1749,12 +1763,12 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1749 where

1763 where

1750 st =

1764 st =

1751 case s of

1765 case s of

1752− Static -> text "[static]" <> space

1766+ Static -> text "%static" <> space

1753 _ -> empty

1767 _ -> empty

1754 prettySe d p bnd (PPi (Constraint _ _) n _ ty sc) =

1768 prettySe d p bnd (PPi (Constraint _ _) n _ ty sc) =

1755 depth d . bracket p startPrec $

1769 depth d . bracket p startPrec $

1756 prettySe (decD d) (startPrec + 1) bnd ty <+> text "=>" </> prettySe (decD d) startPrec ((n, True):bnd) sc

1770 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) =

1758 lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>

1772 lbrace <> kwd "auto" <+> pretty n <+> colon <+> prettySe (decD d) startPrec bnd ty <>

1759 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc

1773 rbrace <+> text "->" </> prettySe (decD d) startPrec ((n, True):bnd) sc

1760 prettySe d p bnd (PPi (TacImp _ _ s) n _ ty sc) =

1774 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

1791 [x] -> group (opName True <$> group (prettySe (decD d) startPrec bnd (getTm x)))

1805 [x] -> group (opName True <$> group (prettySe (decD d) startPrec bnd (getTm x)))

1792 [l,r] -> let precedence = maybe (startPrec - 1) prec f

1806 [l,r] -> let precedence = maybe (startPrec - 1) prec f

1793 in depth d . bracket p precedence $ inFix (getTm l) (getTm r)

1807 in depth d . bracket p precedence $ inFix (getTm l) (getTm r)

1794− (l@(PExp _ _ _ _) : r@(PExp _ _ _ _) : rest) ->

1808+ (l@(PExp{}) : r@(PExp{}) : rest) ->

1795 depth d . bracket p funcAppPrec $

1809 depth d . bracket p funcAppPrec $

1796 enclose lparen rparen (inFix (getTm l) (getTm r)) <+>

1810 enclose lparen rparen (inFix (getTm l) (getTm r)) <+>

1797 align (group (vsep (map (prettyArgS d bnd) rest)))

1811 align (group (vsep (map (prettyArgS d bnd) rest)))

@@ -1842,20 +1856,20 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1842 -- disambiguation on PDPair.

1856 -- disambiguation on PDPair.

1843 vars tm = filter noNS (allNamesIn tm)

1857 vars tm = filter noNS (allNamesIn tm)

1844 noNS (NS _ _) = False

1858 noNS (NS _ _) = False

1845− noNS _ = True

1859+ noNS _ = True

1846

1860

1847 prettySe d p bnd (PIfThenElse _ c t f) =

1861 prettySe d p bnd (PIfThenElse _ c t f) =

1848 depth d . bracket p funcAppPrec . group . align . hang 2 . vsep $

1862 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

1850 , kwd "then" <+> prettySe (decD d) startPrec bnd t

1864 , kwd "then" <+> prettySe (decD d) startPrec bnd t

1851 , kwd "else" <+> prettySe (decD d) startPrec bnd f

1865 , kwd "else" <+> prettySe (decD d) startPrec bnd f

1852 ]

1866 ]

1853− prettySe d p bnd (PHidden tm) = text "." <> prettySe (decD d) funcAppPrec bnd tm

1867+ prettySe d p bnd (PHidden tm) = text "." <> prettySe (decD d) funcAppPrec bnd tm

1854− prettySe d p bnd (PResolveTC _) = kwd "%instance"

1868+ prettySe d p bnd (PResolveTC _) = kwd "%instance"

1855− prettySe d p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1869+ prettySe d p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1856− prettySe d p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

1870+ prettySe d p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

1857 prettySe d p bnd (PTrue _ TypeOrTerm) = text "()"

1871 prettySe d p bnd (PTrue _ TypeOrTerm) = text "()"

1858− prettySe d p bnd (PRewrite _ l r _) =

1872+ prettySe d p bnd (PRewrite _ l r _) =

1859 depth d . bracket p startPrec $

1873 depth d . bracket p startPrec $

1860 text "rewrite" <+> prettySe (decD d) (startPrec + 1) bnd l <+> text "in" <+> prettySe (decD d) startPrec bnd r

1874 text "rewrite" <+> prettySe (decD d) (startPrec + 1) bnd l <+> text "in" <+> prettySe (decD d) startPrec bnd r

1861 prettySe d p bnd (PTyped l r) =

1875 prettySe d p bnd (PTyped l r) =

@@ -1865,9 +1879,9 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1865 align . group . vsep . punctuate (ann comma) $

1879 align . group . vsep . punctuate (ann comma) $

1866 map (prettySe (decD d) startPrec bnd) elts

1880 map (prettySe (decD d) startPrec bnd) elts

1867 where ann = case pun of

1881 where ann = case pun of

1868− TypeOrTerm -> id

1882+ TypeOrTerm -> id

1869− IsType -> annName pairTy

1883+ IsType -> annName pairTy

1870− IsTerm -> annName pairCon

1884+ IsTerm -> annName pairCon

1871 prettySe d p bnd (PDPair _ _ pun l t r) =

1885 prettySe d p bnd (PDPair _ _ pun l t r) =

1872 depth d $

1886 depth d $

1873 annotated lparen <>

1887 annotated lparen <>

@@ -1876,30 +1890,32 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

1876 prettySe (decD d) startPrec (addBinding bnd) r <>

1890 prettySe (decD d) startPrec (addBinding bnd) r <>

1877 annotated rparen

1891 annotated rparen

1878 where annotated = case pun of

1892 where annotated = case pun of

1879− IsType -> annName sigmaTy

1893+ IsType -> annName sigmaTy

1880− IsTerm -> annName sigmaCon

1894+ IsTerm -> annName sigmaCon

1881− TypeOrTerm -> id

1895+ TypeOrTerm -> id

1882 (left, addBinding) = case (l, pun) of

1896 (left, addBinding) = case (l, pun) of

1883 (PRef _ _ n, IsType) -> (bindingOf n False <+> text ":" <+> prettySe (decD d) startPrec bnd t, ((n, False) :))

1897 (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)

1885 prettySe d p bnd (PAlternative ns a as) =

1899 prettySe d p bnd (PAlternative ns a as) =

1886 lparen <> text "|" <> prettyAs <> text "|" <> rparen

1900 lparen <> text "|" <> prettyAs <> text "|" <> rparen

1887 where

1901 where

1888 prettyAs =

1902 prettyAs =

1889− foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (depth d . prettySe (decD d) startPrec bnd) as

1903+ foldr ((\ l r -> l <+> text "," <+> r) .

1890− prettySe d p bnd (PType _) = annotate (AnnType "Type" "The type of types") $ text "Type"

1904+ depth d . prettySe (decD d) startPrec bnd)

1891− prettySe d p bnd (PUniverse u) = annotate (AnnType (show u) "The type of unique types") $ text (show u)

1905+ empty as

1892− prettySe d p bnd (PConstant _ c) = annotate (AnnConst c) (text (show c))

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))

1893 -- XXX: add pretty for tactics

1909 -- XXX: add pretty for tactics

1894− prettySe d p bnd (PProof ts) =

1910+ prettySe d p bnd (PProof ts) =

1895 kwd "proof" <+> lbrace <> ellipsis <> rbrace

1911 kwd "proof" <+> lbrace <> ellipsis <> rbrace

1896− prettySe d p bnd (PTactics ts) =

1912+ prettySe d p bnd (PTactics ts) =

1897 kwd "tactics" <+> lbrace <> ellipsis <> rbrace

1913 kwd "tactics" <+> lbrace <> ellipsis <> rbrace

1898− prettySe d p bnd (PMetavar _ n) = annotate (AnnName n (Just MetavarOutput) Nothing Nothing) $ text "?" <> pretty n

1914+ 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"

1915+ prettySe d p bnd (PReturn f) = kwd "return"

1900− prettySe d p bnd PImpossible = kwd "impossible"

1916+ prettySe d p bnd PImpossible = kwd "impossible"

1901− prettySe d p bnd Placeholder = text "_"

1917+ prettySe d p bnd Placeholder = text "_"

1902− prettySe d p bnd (PDoBlock dos) =

1918+ prettySe d p bnd (PDoBlock dos) =

1903 bracket p startPrec $

1919 bracket p startPrec $

1904 kwd "do" <+> align (vsep (map (group . align . hang 2) (ppdo bnd dos)))

1920 kwd "do" <+> align (vsep (map (group . align . hang 2) (ppdo bnd dos)))

1905 where ppdo bnd (DoExp _ tm:dos) = prettySe (decD d) startPrec bnd tm : ppdo bnd dos

1921 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

1921 text "no pretty printer for pattern-matching do binding" :

1937 text "no pretty printer for pattern-matching do binding" :

1922 ppdo bnd dos

1938 ppdo bnd dos

1923 ppdo _ [] = []

1939 ppdo _ [] = []

1924− prettySe d p bnd (PCoerced t) = prettySe d p bnd t

1940+ prettySe d p bnd (PCoerced t) = prettySe d p bnd t

1925− prettySe d p bnd (PElabError s) = pretty s

1941+ prettySe d p bnd (PElabError s) = pretty s

1926 -- Quasiquote pprinting ignores bound vars

1942 -- 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 ")"

1928 prettySe d p bnd (PQuasiquote t (Just g)) = text "`(" <> prettySe (decD d) p [] t <+> colon <+> prettySe (decD d) p [] g <> text ")"

1944 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

1945+ 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

1946+ prettySe d p bnd (PQuoteName n res _) = text start <> prettyName True (ppopt_impl ppo) bnd n <> text end

1931 where start = if res then "`{" else "`{{"

1947 where start = if res then "`{" else "`{{"

1932 end = if res then "}" else "}}"

1948 end = if res then "}" else "}}"

1933− prettySe d p bnd (PRunElab _ tm _) =

1949+ prettySe d p bnd (PRunElab _ tm _) =

1934 bracket p funcAppPrec . group . align . hang 2 $

1950 bracket p funcAppPrec . group . align . hang 2 $

1935 text "%runElab" <$>

1951 text "%runElab" <$>

1936 prettySe (decD d) funcAppPrec bnd tm

1952 prettySe (decD d) funcAppPrec bnd tm

1937− prettySe d p bnd (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless

1953+ prettySe d p bnd (PConstSugar fc tm) = prettySe d p bnd tm -- should never occur, but harmless

1938−

1954+ prettySe d p bnd _ = text "missing pretty-printer for term"

1939− prettySe d p bnd _ = text "missing pretty-printer for term"

1940

1955

1941 prettyBindingOf :: Name -> Bool -> Doc OutputAnnotation

1956 prettyBindingOf :: Name -> Bool -> Doc OutputAnnotation

1942 prettyBindingOf n imp = annotate (AnnBoundName n imp) (text (display n))

1957 prettyBindingOf n imp = annotate (AnnBoundName n imp) (text (display n))

1943 where display (UN n) = T.unpack n

1958 where display (UN n) = T.unpack n

1944 display (MN _ n) = T.unpack n

1959 display (MN _ n) = T.unpack n

1945 -- If a namespace is specified on a binding form, we'd better show it regardless of the implicits settings

1960 -- 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

1947 display n = show n

1962 display n = show n

1948

1963

1949− prettyArgS d bnd (PImp _ _ _ n tm) = prettyArgSi d bnd (n, tm)

1964+ prettyArgS d bnd (PImp _ _ _ n tm) = prettyArgSi d bnd (n, tm)

1950− prettyArgS d bnd (PExp _ _ _ tm) = prettyArgSe d bnd tm

1965+ prettyArgS d bnd (PExp _ _ _ tm) = prettyArgSe d bnd tm

1951− prettyArgS d bnd (PConstraint _ _ _ tm) = prettyArgSc d bnd tm

1966+ prettyArgS d bnd (PConstraint _ _ _ tm) = prettyArgSc d bnd tm

1952− prettyArgS d bnd (PTacImplicit _ _ n _ tm) = prettyArgSti d bnd (n, tm)

1967+ prettyArgS d bnd (PTacImplicit _ _ n _ tm) = prettyArgSti d bnd (n, tm)

1953

1968

1954− prettyArgSe d bnd arg = prettySe d (funcAppPrec + 1) bnd arg

1969+ 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

1970+ 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

1971+ prettyArgSc d bnd val = lbrace <> lbrace <> prettySe (decD d) startPrec bnd val <> rbrace <> rbrace

1957 prettyArgSti d bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

1972 prettyArgSti d bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe (decD d) startPrec bnd val <> rbrace

1958

1973

1959 annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

1974 annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

1960 annName n = annotate (AnnName n Nothing Nothing Nothing)

1975 annName n = annotate (AnnName n Nothing Nothing Nothing)

1961

1976

1962 opStr :: Name -> String

1977 opStr :: Name -> String

1963− opStr (NS n _) = opStr n

1978+ opStr (NS n _) = opStr n

1964− opStr (UN n) = T.unpack n

1979+ opStr (UN n) = T.unpack n

1965

1980

1966 slist' :: Maybe Int -> Int -> [(Name, Bool)] -> PTerm -> Maybe [Doc OutputAnnotation]

1981 slist' :: Maybe Int -> Int -> [(Name, Bool)] -> PTerm -> Maybe [Doc OutputAnnotation]

1967 slist' (Just d) _ _ _ | d <= 0 = Nothing

1982 slist' (Just d) _ _ _ | d <= 0 = Nothing

@@ -2023,7 +2038,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

2023 ellipsis = text "..."

2038 ellipsis = text "..."

2024

2039

2025 depth Nothing = id

2040 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

2027

2042

2028 decD = fmap (\x -> x - 1)

2043 decD = fmap (\x -> x - 1)

2029

2044

@@ -2038,7 +2053,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe (ppopt_depth ppo) startPrec bnd

2038-- | Strip away namespace information

2053-- | Strip away namespace information

2039basename :: Name -> Name

2054basename :: Name -> Name

2040basename (NS n _) = basename n

2055basename (NS n _) = basename n

2041−basename n = n

2056+basename n = n

2042

2057

2043-- | Determine whether a name was the one inserted for a hole or

2058-- | Determine whether a name was the one inserted for a hole or

2044-- guess by the delaborator

2059-- guess by the delaborator

@@ -2058,15 +2073,15 @@ prettyName

2058 -> Name -- ^^ the name to pprint

2073 -> Name -- ^^ the name to pprint

2059 -> Doc OutputAnnotation

2074 -> Doc OutputAnnotation

2060prettyName infixParen showNS bnd n

2075prettyName infixParen showNS bnd n

2061− | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"

2076+ | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"

2062− | (UN n') <- n, T.unpack n' == "_" = text "_"

2077+ | (UN n') <- n, T.unpack n' == "_" = text "_"

2063− | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName

2078+ | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName

2064− | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName

2079+ | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName

2065 where fullName = text nameSpace <> parenthesise (text (baseName n))

2080 where fullName = text nameSpace <> parenthesise (text (baseName n))

2066− baseName (UN n) = T.unpack n

2081+ baseName (UN n) = T.unpack n

2067− baseName (NS n ns) = baseName n

2082+ baseName (NS n ns) = baseName n

2068− baseName (MN i s) = T.unpack s

2083+ baseName (MN i s) = T.unpack s

2069− baseName other = show other

2084+ baseName other = show other

2070 nameSpace = case n of

2085 nameSpace = case n of

2071 (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else ""

2086 (NS n' ns) -> if showNS then (concatMap (++ ".") . map T.unpack . reverse) ns else ""

2072 _ -> ""

2087 _ -> ""

@@ -2081,13 +2096,13 @@ showCImp ppo (PClause _ n l ws r w)

2081 = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r

2096 = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r

2082 <+> text "where" <+> text (show w)

2097 <+> text "where" <+> text (show w)

2083 where

2098 where

2084− showWs [] = empty

2099+ showWs [] = empty

2085 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

2100 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

2086showCImp ppo (PWith _ n l ws r pn w)

2101showCImp ppo (PWith _ n l ws r pn w)

2087 = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

2102 = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

2088 <+> braces (text (show w))

2103 <+> braces (text (show w))

2089 where

2104 where

2090− showWs [] = empty

2105+ showWs [] = empty

2091 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

2106 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

2092

2107

2093

2108

@@ -2099,43 +2114,43 @@ showDImp ppo (PDatadecl n nfc ty cons)

2099showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

2114showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

2100showDecls o ds = vsep (map (showDeclImp o) ds)

2115showDecls o ds = vsep (map (showDeclImp o) ds)

2101

2116

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))

2103showDeclImp o (PTy _ _ _ _ _ n _ t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t

2118showDeclImp 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" <+>

2105 indent 2 (vsep (map (showCImp o) cs))

2120 indent 2 (vsep (map (showCImp o) cs))

2106−showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d

2121+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)

2122+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)

2123+showDeclImp o (PNamespace n fc ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

2109showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

2124showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

2110showDeclImp o (PClass _ _ _ cs n _ ps _ _ ds _ _)

2125showDeclImp o (PClass _ _ _ cs n _ ps _ _ ds _ _)

2111 = text "interface" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds

2126 = 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)

2113 = text "implementation" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

2128 = text "implementation" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

2114showDeclImp _ _ = text "..."

2129showDeclImp _ _ = text "..."

2115-- showDeclImp (PImport o) = "import " ++ o

2130-- showDeclImp (PImport o) = "import " ++ o

2116

2131

2117getImps :: [PArg] -> [(Name, PTerm)]

2132getImps :: [PArg] -> [(Name, PTerm)]

2118getImps [] = []

2133getImps [] = []

2119−getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

2134+getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

2120−getImps (_ : xs) = getImps xs

2135+getImps (_ : xs) = getImps xs

2121

2136

2122getExps :: [PArg] -> [PTerm]

2137getExps :: [PArg] -> [PTerm]

2123getExps [] = []

2138getExps [] = []

2124−getExps (PExp _ _ _ tm : xs) = tm : getExps xs

2139+getExps (PExp _ _ _ tm : xs) = tm : getExps xs

2125−getExps (_ : xs) = getExps xs

2140+getExps (_ : xs) = getExps xs

2126

2141

2127getShowArgs :: [PArg] -> [PArg]

2142getShowArgs :: [PArg] -> [PArg]

2128getShowArgs [] = []

2143getShowArgs [] = []

2129getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs

2144getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs

2130getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs

2145getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs

2131 | PImp _ _ _ _ tm <- e

2146 | PImp _ _ _ _ tm <- e

2132− , containsHole tm = e : getShowArgs xs

2147+ , containsHole tm = e : getShowArgs xs

2133getShowArgs (_ : xs) = getShowArgs xs

2148getShowArgs (_ : xs) = getShowArgs xs

2134

2149

2135getConsts :: [PArg] -> [PTerm]

2150getConsts :: [PArg] -> [PTerm]

2136−getConsts [] = []

2151+getConsts [] = []

2137getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

2152getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

2138−getConsts (_ : xs) = getConsts xs

2153+getConsts (_ : xs) = getConsts xs

2139

2154

2140getAll :: [PArg] -> [PTerm]

2155getAll :: [PArg] -> [PTerm]

2141getAll = map getTm

2156getAll = map getTm

@@ -2149,13 +2164,13 @@ showName :: Maybe IState -- ^^ the Idris state, for information about names an

2149 -> Name -- ^^ the term to show

2164 -> Name -- ^^ the term to show

2150 -> String

2165 -> String

2151showName ist bnd ppo colour n = case ist of

2166showName ist bnd ppo colour n = case ist of

2152− Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

2167+ Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

2153− Nothing -> showbasic n

2168+ Nothing -> showbasic n

2154 where name = if ppopt_impl ppo then show n else showbasic n

2169 where name = if ppopt_impl ppo then show n else showbasic n

2155− showbasic n@(UN _) = showCG n

2170+ showbasic n@(UN _) = showCG n

2156− showbasic (MN i s) = str s

2171+ showbasic (MN i s) = str s

2157− showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

2172+ showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

2158− showbasic (SN s) = show s

2173+ showbasic (SN s) = show s

2159 fst3 (x, _, _) = x

2174 fst3 (x, _, _) = x

2160 colourise n t = let ctxt' = fmap tt_ctxt ist in

2175 colourise n t = let ctxt' = fmap tt_ctxt ist in

2161 case ctxt' of

2176 case ctxt' of

@@ -2187,42 +2202,42 @@ showTmOpts opt = flip (displayS . renderPretty 1.0 10000000 . prettyImp opt) ""

2187

2202

2188

2203

2189instance Sized PTerm where

2204instance Sized PTerm where

2190− size (PQuote rawTerm) = size rawTerm

2205+ size (PQuote rawTerm) = size rawTerm

2191− size (PRef fc _ name) = size name

2206+ size (PRef fc _ name) = size name

2192− size (PLam fc name _ ty bdy) = 1 + size ty + size bdy

2207+ 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

2208+ 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

2209+ 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

2210+ size (PTyped trm ty) = 1 + size trm + size ty

2196− size (PApp fc name args) = 1 + size args

2211+ size (PApp fc name args) = 1 + size args

2197− size (PAppBind fc name args) = 1 + size args

2212+ size (PAppBind fc name args) = 1 + size args

2198− size (PCase fc trm bdy) = 1 + size trm + size bdy

2213+ size (PCase fc trm bdy) = 1 + size trm + size bdy

2199− size (PIfThenElse fc c t f) = 1 + sum (map size [c, t, f])

2214+ size (PIfThenElse fc c t f) = 1 + sum (map size [c, t, f])

2200− size (PTrue fc _) = 1

2215+ size (PTrue fc _) = 1

2201− size (PResolveTC fc) = 1

2216+ size (PResolveTC fc) = 1

2202− size (PRewrite fc left right _) = 1 + size left + size right

2217+ size (PRewrite fc left right _) = 1 + size left + size right

2203− size (PPair fc _ _ left right) = 1 + size left + size right

2218+ size (PPair fc _ _ left right) = 1 + size left + size right

2204− size (PDPair fs _ _ left ty right) = 1 + size left + size ty + size right

2219+ size (PDPair fs _ _ left ty right) = 1 + size left + size ty + size right

2205− size (PAlternative _ a alts) = 1 + size alts

2220+ size (PAlternative _ a alts) = 1 + size alts

2206− size (PHidden hidden) = size hidden

2221+ size (PHidden hidden) = size hidden

2207− size (PUnifyLog tm) = size tm

2222+ size (PUnifyLog tm) = size tm

2208− size (PDisamb _ tm) = size tm

2223+ size (PDisamb _ tm) = size tm

2209− size (PNoImplicits tm) = size tm

2224+ size (PNoImplicits tm) = size tm

2210− size (PType _) = 1

2225+ size (PType _) = 1

2211− size (PUniverse _) = 1

2226+ size (PUniverse _) = 1

2212− size (PConstant fc const) = 1 + size fc + size const

2227+ size (PConstant fc const) = 1 + size fc + size const

2213− size Placeholder = 1

2228+ size Placeholder = 1

2214− size (PDoBlock dos) = 1 + size dos

2229+ size (PDoBlock dos) = 1 + size dos

2215− size (PIdiom fc term) = 1 + size term

2230+ size (PIdiom fc term) = 1 + size term

2216− size (PReturn fc) = 1

2231+ size (PReturn fc) = 1

2217− size (PMetavar _ name) = 1

2232+ size (PMetavar _ name) = 1

2218− size (PProof tactics) = size tactics

2233+ size (PProof tactics) = size tactics

2219− size (PElabError err) = size err

2234+ size (PElabError err) = size err

2220− size PImpossible = 1

2235+ size PImpossible = 1

2221− size _ = 0

2236+ size _ = 0

2222

2237

2223getPArity :: PTerm -> Int

2238getPArity :: PTerm -> Int

2224−getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

2239+getPArity (PPi _ _ _ _ sc) = 1 + getPArity sc

2225−getPArity _ = 0

2240+getPArity _ = 0

2226

2241

2227-- Return all names, free or globally bound, in the given term.

2242-- Return all names, free or globally bound, in the given term.

2228

2243

@@ -2230,31 +2245,30 @@ allNamesIn :: PTerm -> [Name]

2230allNamesIn tm = nub $ ni 0 [] tm

2245allNamesIn tm = nub $ ni 0 [] tm

2231 where -- TODO THINK added niTacImp, but is it right?

2246 where -- TODO THINK added niTacImp, but is it right?

2232 ni 0 env (PRef _ _ n)

2247 ni 0 env (PRef _ _ n)

2233− | not (n `elem` env) = [n]

2248+ | not (n `elem` env) = [n]

2234− ni 0 env (PPatvar _ n) = [n]

2249+ ni 0 env (PPatvar _ n) = [n]

2235− ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2250+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2236− ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2251+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2237− ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env) (map snd os)

2252+ ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env . snd) os

2238− ni 0 env (PIfThenElse _ c t f) = ni 0 env c ++ ni 0 env t ++ ni 0 env f

2253+ 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

2254+ 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

2255+ 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

2256+ 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

2257+ ni 0 env (PHidden tm) = ni 0 env tm

2243− ni 0 env (PRewrite _ l r _) = ni 0 env l ++ ni 0 env r

2258+ 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

2259+ 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

2260+ 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

2261+ 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

2262+ 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

2263+ 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

2264+ ni 0 env (PAlternative ns a ls) = concatMap (ni 0 env) ls

2250− ni 0 env (PUnifyLog tm) = ni 0 env tm

2265+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2251− ni 0 env (PDisamb _ tm) = ni 0 env tm

2266+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2252− ni 0 env (PNoImplicits tm) = ni 0 env tm

2267+ ni 0 env (PNoImplicits tm) = ni 0 env tm

2253−

2254− ni i env (PQuasiquote tm ty) = ni (i+1) env tm ++ maybe [] (ni i env) ty

2255− ni i env (PUnquote tm) = ni (i - 1) env tm

2256

2268

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)

2258

2272

2259 niTacImp i env (TacImp _ _ scr) = ni i env scr

2273 niTacImp i env (TacImp _ _ scr) = ni i env scr

2260 niTacImp _ _ _ = []

2274 niTacImp _ _ _ = []

@@ -2265,32 +2279,32 @@ boundNamesIn :: PTerm -> [Name]

2265boundNamesIn tm = S.toList (ni 0 S.empty tm)

2279boundNamesIn tm = S.toList (ni 0 S.empty tm)

2266 where -- TODO THINK Added niTacImp, but is it right?

2280 where -- TODO THINK Added niTacImp, but is it right?

2267 ni :: Int -> S.Set Name -> PTerm -> S.Set Name

2281 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)

2282+ 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)

2283+ 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)

2284+ 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]

2285+ 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

2286+ 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

2287+ 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

2288+ 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

2289+ 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

2290+ 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

2291+ ni 0 set (PPair _ _ _ l r) = ni 0 (ni 0 set l) r

2278 ni 0 set (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 (ni 0 set t) r

2292 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

2293+ 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

2294+ ni 0 set (PAlternative ns a as) = niTms 0 set as

2281− ni 0 set (PHidden tm) = ni 0 set tm

2295+ ni 0 set (PHidden tm) = ni 0 set tm

2282− ni 0 set (PUnifyLog tm) = ni 0 set tm

2296+ ni 0 set (PUnifyLog tm) = ni 0 set tm

2283− ni 0 set (PDisamb _ tm) = ni 0 set tm

2297+ ni 0 set (PDisamb _ tm) = ni 0 set tm

2284− ni 0 set (PNoImplicits tm) = ni 0 set tm

2298+ ni 0 set (PNoImplicits tm) = ni 0 set tm

2285

2299

2286− ni i set (PQuasiquote tm ty) = ni (i + 1) set tm `S.union` maybe S.empty (ni i set) ty

2300+ 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

2301+ ni i set (PUnquote tm) = ni (i - 1) set tm

2288

2302

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)

2290

2304

2291 niTms :: Int -> S.Set Name -> [PTerm] -> S.Set Name

2305 niTms :: Int -> S.Set Name -> [PTerm] -> S.Set Name

2292− niTms i set [] = set

2306+ niTms i set [] = set

2293− niTms i set (x : xs) = niTms i (ni i set x) xs

2307+ niTms i set (x : xs) = niTms i (ni i set x) xs

2294

2308

2295 niTacImp i set (TacImp _ _ scr) = ni i set scr

2309 niTacImp i set (TacImp _ _ scr) = ni i set scr

2296 niTacImp i set _ = set

2310 niTacImp i set _ = set

@@ -2306,18 +2320,19 @@ implicitNamesIn uvars ist tm

2306 addFn n = do (imps, fns) <- get

2320 addFn n = do (imps, fns) <- get

2307 put (imps, n: fns)

2321 put (imps, n: fns)

2308

2322

2309− notCAF [] = False

2323+ notCAF [] = False

2310 notCAF (PExp _ _ _ _ : _) = True

2324 notCAF (PExp _ _ _ _ : _) = True

2311− notCAF (_ : xs) = notCAF xs

2325+ notCAF (_ : xs) = notCAF xs

2312

2326

2313 notHidden (n, _) = case getAccessibility n of

2327 notHidden (n, _) = case getAccessibility n of

2314− Hidden -> False

2328+ Hidden -> False

2315− _ -> True

2329+ Private -> False

2330+ _ -> True

2316

2331

2317 getAccessibility n

2332 getAccessibility n

2318 = case lookupDefAccExact n False (tt_ctxt ist) of

2333 = case lookupDefAccExact n False (tt_ctxt ist) of

2319− Just (n,t) -> t

2334+ Just (n,t) -> t

2320− _ -> Public

2335+ _ -> Public

2321

2336

2322 ni 0 env (PRef _ _ n@(NS _ _))

2337 ni 0 env (PRef _ _ n@(NS _ _))

2323 | not (n `elem` env)

2338 | not (n `elem` env)

@@ -2327,44 +2342,44 @@ implicitNamesIn uvars ist tm

2327 | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n

2342 | not (n `elem` env) && implicitable n || n `elem` uvars = addImp n

2328 ni 0 env (PApp _ f@(PRef _ _ n) as)

2343 ni 0 env (PApp _ f@(PRef _ _ n) as)

2329 | n `elem` uvars = do ni 0 env f

2344 | n `elem` uvars = do ni 0 env f

2330− mapM_ (ni 0 env) (map getTm as)

2345+ mapM_ (ni 0 env . getTm) as

2331 | otherwise = do case lookupTy n (tt_ctxt ist) of

2346 | otherwise = do case lookupTy n (tt_ctxt ist) of

2332− [] -> return ()

2347+ [] -> return ()

2333− _ -> addFn n

2348+ _ -> addFn n

2334− mapM_ (ni 0 env) (map getTm as)

2349+ mapM_ (ni 0 env . getTm) as

2335 ni 0 env (PApp _ f as) = do ni 0 env f

2350 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

2337 ni 0 env (PAppBind _ f as) = do ni 0 env f

2352 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

2339 ni 0 env (PCase _ c os) = do ni 0 env c

2354 ni 0 env (PCase _ c os) = do ni 0 env c

2340 -- names in 'os', not counting the names bound in the cases

2355 -- 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

2342 (imps, fns) <- get

2357 (imps, fns) <- get

2343 put ([] ,[])

2358 put ([] ,[])

2344− mapM_ (ni 0 env) (map fst os)

2359+ mapM_ (ni 0 env . fst) os

2345 (impsfst, _) <- get

2360 (impsfst, _) <- get

2346 put (nub imps \\ nub impsfst, fns)

2361 put (nub imps \\ nub impsfst, fns)

2347− ni 0 env (PIfThenElse _ c t f) = mapM_ (ni 0 env) [c, t, f]

2362+ 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

2363+ 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

2364+ 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

2365+ 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

2366+ 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

2367+ 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

2368+ 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

2369+ ni 0 env (PDPair _ _ _ l t r) = do ni 0 env l

2355− ni 0 env t

2370+ ni 0 env t

2356− ni 0 env r

2371+ ni 0 env r

2357− ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as

2372+ ni 0 env (PAlternative ns a as) = mapM_ (ni 0 env) as

2358− ni 0 env (PHidden tm) = ni 0 env tm

2373+ ni 0 env (PHidden tm) = ni 0 env tm

2359− ni 0 env (PUnifyLog tm) = ni 0 env tm

2374+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2360− ni 0 env (PDisamb _ tm) = ni 0 env tm

2375+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2361− ni 0 env (PNoImplicits tm) = ni 0 env tm

2376+ ni 0 env (PNoImplicits tm) = ni 0 env tm

2362

2377

2363 ni i env (PQuasiquote tm ty) = do ni (i + 1) env tm

2378 ni i env (PQuasiquote tm ty) = do ni (i + 1) env tm

2364 maybe (return ()) (ni i env) ty

2379 maybe (return ()) (ni i env) ty

2365 ni i env (PUnquote tm) = ni (i - 1) env tm

2380 ni i env (PUnquote tm) = ni (i - 1) env tm

2366

2381

2367− ni i env tm = mapM_ (ni i env) (children tm)

2382+ ni i env tm = mapM_ (ni i env) (children tm)

2368

2383

2369-- Return names which are free in the given term.

2384-- Return names which are free in the given term.

2370namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

2385namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

@@ -2373,32 +2388,32 @@ namesIn uvars ist tm = nub $ ni 0 [] tm

2373 ni 0 env (PRef _ _ n)

2388 ni 0 env (PRef _ _ n)

2374 | not (n `elem` env)

2389 | not (n `elem` env)

2375 = case lookupTy n (tt_ctxt ist) of

2390 = case lookupTy n (tt_ctxt ist) of

2376− [] -> [n]

2391+ [] -> [n]

2377− _ -> if n `elem` (map fst uvars) then [n] else []

2392+ _ -> [n | n `elem` (map fst uvars)]

2378− ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2393+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2379− ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2394+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2380− ni 0 env (PCase _ c os) = ni 0 env c ++

2395+ ni 0 env (PCase _ c os) = ni 0 env c ++

2381 -- names in 'os', not counting the names bound in the cases

2396 -- names in 'os', not counting the names bound in the cases

2382− (nub (concatMap (ni 0 env) (map snd os))

2397+ (nub (concatMap (ni 0 env . snd) os)

2383− \\ nub (concatMap (ni 0 env) (map fst os)))

2398+ \\ nub (concatMap (ni 0 env . fst) os))

2384− ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2399+ ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2385 ni 0 env (PLam fc n nfc ty sc) = ni 0 env ty ++ ni 0 (n:env) sc

2400 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

2401+ 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

2402+ 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

2403+ 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

2404+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2390 ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2405 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

2392 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2407 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2393− ni 0 env (PHidden tm) = ni 0 env tm

2408+ ni 0 env (PHidden tm) = ni 0 env tm

2394− ni 0 env (PUnifyLog tm) = ni 0 env tm

2409+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2395− ni 0 env (PDisamb _ tm) = ni 0 env tm

2410+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2396− ni 0 env (PNoImplicits tm) = ni 0 env tm

2411+ ni 0 env (PNoImplicits tm) = ni 0 env tm

2397

2412

2398− ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2413+ 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

2414+ ni i env (PUnquote tm) = ni (i - 1) env tm

2400

2415

2401− ni i env tm = concatMap (ni i env) (children tm)

2416+ ni i env tm = concatMap (ni i env) (children tm)

2402

2417

2403 niTacImp i env (TacImp _ _ scr) = ni i env scr

2418 niTacImp i env (TacImp _ _ scr) = ni i env scr

2404 niTacImp _ _ _ = []

2419 niTacImp _ _ _ = []

@@ -2413,27 +2428,27 @@ usedNamesIn vars ist tm = nub $ ni 0 [] tm

2413 = case lookupDefExact n (tt_ctxt ist) of

2428 = case lookupDefExact n (tt_ctxt ist) of

2414 Nothing -> [n]

2429 Nothing -> [n]

2415 _ -> []

2430 _ -> []

2416− ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2431+ ni 0 env (PApp _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2417− ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env) (map getTm as)

2432+ ni 0 env (PAppBind _ f as) = ni 0 env f ++ concatMap (ni 0 env . getTm) as

2418− ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env) (map snd os)

2433+ ni 0 env (PCase _ c os) = ni 0 env c ++ concatMap (ni 0 env . snd) os

2419− ni 0 env (PIfThenElse _ c t f) = concatMap (ni 0 env) [c, t, f]

2434+ 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

2435+ 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

2436+ 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

2437+ 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

2438+ 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

2439+ ni 0 env (PPair _ _ _ l r) = ni 0 env l ++ ni 0 env r

2425 ni 0 env (PDPair _ _ _ (PRef _ _ n) t r) = ni 0 env t ++ ni 0 (n:env) r

2440 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

2427 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2442 ni 0 env (PAlternative ns a as) = concatMap (ni 0 env) as

2428− ni 0 env (PHidden tm) = ni 0 env tm

2443+ ni 0 env (PHidden tm) = ni 0 env tm

2429− ni 0 env (PUnifyLog tm) = ni 0 env tm

2444+ ni 0 env (PUnifyLog tm) = ni 0 env tm

2430− ni 0 env (PDisamb _ tm) = ni 0 env tm

2445+ ni 0 env (PDisamb _ tm) = ni 0 env tm

2431− ni 0 env (PNoImplicits tm) = ni 0 env tm

2446+ ni 0 env (PNoImplicits tm) = ni 0 env tm

2432

2447

2433− ni i env (PQuasiquote tm ty) = ni (i + 1) env tm ++ maybe [] (ni i env) ty

2448+ 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

2449+ ni i env (PUnquote tm) = ni (i - 1) env tm

2435

2450

2436− ni i env tm = concatMap (ni i env) (children tm)

2451+ ni i env tm = concatMap (ni i env) (children tm)

2437

2452

2438 niTacImp i env (TacImp _ _ scr) = ni i env scr

2453 niTacImp i env (TacImp _ _ scr) = ni i env scr

2439 niTacImp _ _ _ = []

2454 niTacImp _ _ _ = []

src/Idris/CaseSplit.hs+3−2

@@ -77,7 +77,7 @@ split n t'

77 logElab 1 ("New patterns " ++ showSep ", "

78 (map showTmImpls splits))

79 let newPats_in = zipWith (replaceVar ctxt n) splits (repeat t)

80− logElab 4 ("Working from " ++ show t)

80+ logElab 4 ("Working from " ++ showTmImpls t)

81 logElab 4 ("Trying " ++ showSep "\n"

82 (map (showTmImpls) newPats_in))

83 newPats_in <- mapM elabNewPat newPats_in

@@ -227,7 +227,8 @@ elabNewPat t = idrisCatch (do (tm, ty) <- elabVal recinfo ELHS t

227 i <- getIState

228 return (True, delab i tm))

229 (\e -> do i <- getIState

230− logElab 5 $ "Not a valid split:\n" ++ pshow i e

230+ logElab 5 $ "Not a valid split:\n" ++ showTmImpls t ++ "\n"

231+ ++ pshow i e

231 return (False, t))

232 return (False, t))

232

233

233findPats :: IState -> Type -> [PTerm]

234findPats :: IState -> Type -> [PTerm]

src/Idris/Colours.hs+6−6

@@ -47,9 +47,9 @@ defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True False True

47mkSGR :: IdrisColour -> [SGR]

48mkSGR (IdrisColour c v u b i) =

49 fg c ++

50− (if u then [SetUnderlining SingleUnderline] else []) ++

50+ [SetUnderlining SingleUnderline | u] ++

51− (if b then [SetConsoleIntensity BoldIntensity] else []) ++

51+ [SetConsoleIntensity BoldIntensity | b] ++

52− (if i then [SetItalicized True] else [])

52+ [SetItalicized True | i]

53 where

54 fg Nothing = []

55 fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]

@@ -71,9 +71,9 @@ hEndColourise h _ = hSetSGR h [Reset]

71colouriseWithSTX :: IdrisColour -> String -> String

72colouriseWithSTX (IdrisColour c v u b i) str = setSGRCode sgr ++ "\STX" ++ str ++ setSGRCode [Reset] ++ "\STX"

73 where sgr = fg c ++

74− (if u then [SetUnderlining SingleUnderline] else []) ++

74+ [SetUnderlining SingleUnderline | u] ++

75− (if b then [SetConsoleIntensity BoldIntensity] else []) ++

75+ [SetConsoleIntensity BoldIntensity | b] ++

76− (if i then [SetItalicized True] else [])

76+ [SetItalicized True | i]

77 fg Nothing = []

78 fg (Just c) = [SetColor Foreground (if v then Vivid else Dull) c]

79

src/Idris/Completion.hs+7−7

@@ -9,10 +9,10 @@ import Idris.AbsSyntaxTree

9import Idris.Help

10import Idris.Imports (installedPackages)

11import Idris.Colours

12−import Idris.ParseHelpers(opChars)

12+import Idris.Parser.Helpers(opChars)

13−import qualified Idris.ParseExpr (constants, tactics)

13+import qualified Idris.Parser.Expr (constants, tactics)

14−import Idris.ParseExpr (TacticArg (..))

14+import Idris.Parser.Expr (TacticArg (..))

15−import Idris.REPLParser (allHelp, setOptions)

15+import Idris.REPL.Parser (allHelp, setOptions)

16import Control.Monad.State.Strict

17

18import Data.List

@@ -26,7 +26,7 @@ import System.Console.ANSI (Color)

26commands = [ n | (names, _, _) <- allHelp ++ extraHelp, n <- names ]

27

28tacticArgs :: [(String, Maybe TacticArg)]

29−tacticArgs = [ (name, args) | (names, args, _) <- Idris.ParseExpr.tactics

29+tacticArgs = [ (name, args) | (names, args, _) <- Idris.Parser.Expr.tactics

30 , name <- names ]

31tactics = map fst tacticArgs

32

@@ -48,11 +48,11 @@ names = do i <- get

48 let ctxt = tt_ctxt i

49 return . nub $

50 mapMaybe (nameString . fst) (ctxtAlist ctxt) ++

51− "Type" : map fst Idris.ParseExpr.constants

51+ "Type" : map fst Idris.Parser.Expr.constants

52

53metavars :: Idris [String]

54metavars = do i <- get

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

56

57

58modules :: Idris [String]

src/Idris/Core/Binary.hs+4−3

@@ -113,8 +113,9 @@ instance Binary a => Binary (Err' a) where

113 put x

114 put y

115 put z

116− put (CantResolve _ t) = do putWord8 15

116+ put (CantResolve _ t u) = do putWord8 15

117− put t

117+ put t

118+ put u

118 put (CantResolveAlts ns) = do putWord8 16

119 put (CantResolveAlts ns) = do putWord8 16

119 put ns

120 put ns

120 put (IncompleteTerm t) = do putWord8 17

121 put (IncompleteTerm t) = do putWord8 17

@@ -218,7 +219,7 @@ instance Binary a => Binary (Err' a) where

218 13 -> fmap NoTypeDecl get

219 13 -> fmap NoTypeDecl get

219 14 -> do x <- get ; y <- get ; z <- get

220 14 -> do x <- get ; y <- get ; z <- get

220 return $ NotInjective x y z

221 return $ NotInjective x y z

221− 15 -> fmap (CantResolve False) get

222+ 15 -> CantResolve False <$> get <*> get

222 16 -> fmap CantResolveAlts get

223 16 -> fmap CantResolveAlts get

223 17 -> fmap IncompleteTerm get

224 17 -> fmap IncompleteTerm get

224 18 -> UniverseError <$> get <*> get <*> get <*> get <*> get

225 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

152 nua ps (SucCase _ sc) = nu' ps sc

153 nua ps (DefaultCase sc) = nu' ps sc

154

155− nut ps (P Ref n _) | n `elem` ps = []

155+ nut ps (P _ n _) | n `elem` ps = []

156 | otherwise = [(n, [])] -- tmp

157 nut ps fn@(App _ f a)

158− | (P Ref n _, args) <- unApply fn

158+ | (P _ n _, args) <- unApply fn

159 = if n `elem` ps then nut ps f ++ nut ps a

160 else [(n, map argNames args)] ++ concatMap (nut ps) args

161 | (P (TCon _ _) n _, _) <- unApply fn = []

src/Idris/Core/DeepSeq.hs+2−1

@@ -134,7 +134,7 @@ instance NFData Err where

134 rnf (NoTypeDecl x1) = rnf x1 `seq` ()

135 rnf (NotInjective x1 x2 x3)

136 = 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` ()

138 rnf (InvalidTCArg x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

139 rnf (CantResolveAlts x1) = rnf x1 `seq` ()

140 rnf (NoValidAlts x1) = rnf x1 `seq` ()

@@ -239,6 +239,7 @@ instance NFData Accessibility where

239 rnf Public = ()

240 rnf Frozen = ()

241 rnf Hidden = ()

242+ rnf Private = ()

242

243

244

244instance NFData Totality where

245instance NFData Totality where

src/Idris/Core/Elaborate.hs+19−5

@@ -139,13 +139,19 @@ runElab a e ps = runStateT e (ES (ps, a) "" Nothing)

139execElab :: aux -> Elab' aux a -> ProofState -> TC (ElabState aux)

140execElab a e ps = execStateT e (ES (ps, a) "" Nothing)

141

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

143initElaborator = newProof

148initElaborator = newProof

144

149

145−elaborate :: Context -> Ctxt TypeInfo -> Name -> Type -> aux -> Elab' aux a -> TC (a, String)

150+elaborate :: Context -> Ctxt TypeInfo -> Int -> 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

151+elaborate ctxt datatypes globalNames n ty d elab =

147− (a, ES ps' str _) <- runElab d elab ps

152+ do let ps = initElaborator n ctxt datatypes globalNames ty

148− return $! (a, str)

153+ (a, ES ps' str _) <- runElab d elab ps

154+ return $! (a, str)

149

155

150-- | Modify the auxiliary state

156-- | Modify the auxiliary state

151updateAux :: (aux -> aux) -> Elab' aux ()

157updateAux :: (aux -> aux) -> Elab' aux ()

@@ -210,6 +216,14 @@ set_datatypes :: Ctxt TypeInfo -> Elab' aux ()

210set_datatypes ds = do ES (p, a) logs prev <- get

216set_datatypes ds = do ES (p, a) logs prev <- get

211 put (ES (p { datatypes = ds }, a) logs prev)

217 put (ES (p { datatypes = ds }, a) logs prev)

212

218

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+

213-- | get the proof term

227-- | get the proof term

214get_term :: Elab' aux Term

228get_term :: Elab' aux Term

215get_term = do ES p _ _ <- get

229get_term = do ES p _ _ <- get

src/Idris/Core/Evaluate.hs+25−14

@@ -12,8 +12,8 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC,

12 addDatatype, addCasedef, simplifyCasedef, addOperator,

13 lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact,

14 lookupP, lookupP_all, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,

15− mapDefCtxt,

15+ mapDefCtxt,

16− lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName,

16+ lookupTotal, lookupTotalExact, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName,

17 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,

18 isUniverse) where

19

@@ -247,18 +247,16 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

247 | otherwise

248 = do (u, ntimes) <- usable spec n ntimes_in

249 if u then

250− do let val = lookupDefAcc n (spec || atRepl) ctxt

250+ do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt

251 case val of

252 [(Function _ tm, _)] | sUN "assert_total" `elem` stk ->

253 ev ntimes (n:stk) True env tm

254 [(Function _ tm, Public)] ->

255 ev ntimes (n:stk) True env tm

256− [(Function _ tm, Hidden)] ->

257− ev ntimes (n:stk) True env tm

258 [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty

256 [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty

259 return $ VP nt n vty

257 return $ VP nt n vty

260 [(CaseOp ci _ _ _ _ cd, acc)]

258 [(CaseOp ci _ _ _ _ cd, acc)]

261− | (acc /= Frozen || sUN "assert_total" `elem` stk) &&

259+ | (acc == Public || acc == Hidden || sUN "assert_total" `elem` stk) &&

262 null (fst (cases_totcheck cd)) -> -- unoptimised version

260 null (fst (cases_totcheck cd)) -> -- unoptimised version

263 let (ns, tree) = getCases cd in

261 let (ns, tree) = getCases cd in

264 if blockSimplify ci n stk

262 if blockSimplify ci n stk

@@ -319,7 +317,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

319 evApply ntimes' stk top env [l',t',arg'] d'

317 evApply ntimes' stk top env [l',t',arg'] d'

320 -- Treat "assert_total" specially, as long as it's defined!

318 -- Treat "assert_total" specially, as long as it's defined!

321 ev ntimes stk top env (App _ (App _ (P _ n@(UN at) _) _) arg)

319 ev ntimes stk top env (App _ (App _ (P _ n@(UN at) _) _) arg)

322− | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

320+ | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl || runtime) ctxt,

323 at == txt "assert_total" && not simpl

321 at == txt "assert_total" && not simpl

324 = ev ntimes (n : stk) top env arg

322 = ev ntimes (n : stk) top env arg

325 ev ntimes stk top env (App _ f a)

323 ev ntimes stk top env (App _ f a)

@@ -347,7 +345,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

347 = apply ntimes stk top env f args

345 = apply ntimes stk top env f args

348

346

349 reapply ntimes stk top env f@(VP Ref n ty) args

347 reapply ntimes stk top env f@(VP Ref n ty) args

350− = let val = lookupDefAcc n (spec || atRepl) ctxt in

348+ = let val = lookupDefAcc n (spec || atRepl || runtime) ctxt in

351 case val of

349 case val of

352 [(CaseOp ci _ _ _ _ cd, acc)] ->

350 [(CaseOp ci _ _ _ _ cd, acc)] ->

353 let (ns, tree) = getCases cd in

351 let (ns, tree) = getCases cd in

@@ -373,10 +371,10 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

373 | otherwise

371 | otherwise

374 = do (u, ntimes) <- usable spec n ntimes_in

372 = do (u, ntimes) <- usable spec n ntimes_in

375 if u then

373 if u then

376− do let val = lookupDefAcc n (spec || atRepl) ctxt

374+ do let val = lookupDefAcc n (spec || atRepl || runtime) ctxt

377 case val of

375 case val of

378 [(CaseOp ci _ _ _ _ cd, acc)]

376 [(CaseOp ci _ _ _ _ cd, acc)]

379− | acc /= Frozen || sUN "assert_total" `elem` stk ->

377+ | acc == Public || acc == Hidden || sUN "assert_total" `elem` stk ->

380 -- unoptimised version

378 -- unoptimised version

381 let (ns, tree) = getCases cd in

379 let (ns, tree) = getCases cd in

382 if blockSimplify ci n stk

380 if blockSimplify ci n stk

@@ -742,15 +740,23 @@ instance Show Def where

742

740

743-------

741-------

744

742

745−-- Frozen => doesn't reduce

743+-- Hidden => Programs can't access the name at all

746−-- Hidden => doesn't reduce and invisible to type checker

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

747

748−data Accessibility = Public | Frozen | Hidden

748+data Accessibility = Hidden | Public | Frozen | Private

749− deriving (Show, Eq)

749+ deriving (Eq, Ord)

750{-!

751deriving instance NFData Accessibility

752!-}

753

754+instance Show Accessibility where

755+ show Public = "public export"

756+ show Frozen = "export"

757+ show Private = "private"

758+ show Hidden = "hidden"

759+

754-- | The result of totality checking

760-- | The result of totality checking

755data Totality = Total [Int] -- ^ well-founded arguments

761data Totality = Total [Int] -- ^ well-founded arguments

756 | Productive -- ^ productive

762 | Productive -- ^ productive

@@ -1039,6 +1045,7 @@ lookupP_all all exact n ctxt

1039 (Operator ty _ _, a, _, _) -> return (P Ref n' ty, a)

1045 (Operator ty _ _, a, _, _) -> return (P Ref n' ty, a)

1040 case snd p of

1046 case snd p of

1041 Hidden -> if all then return (fst p) else []

1047 Hidden -> if all then return (fst p) else []

1048+ Private -> if all then return (fst p) else []

1042 _ -> return (fst p)

1049 _ -> return (fst p)

1043 where

1050 where

1044 names = let ns = lookupCtxtName n (definitions ctxt) in

1051 names = let ns = lookupCtxtName n (definitions ctxt) in

@@ -1077,6 +1084,10 @@ lookupTotal :: Name -> Context -> [Totality]

1077lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt)

1084lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt)

1078 where mkt (d, a, t, m) = t

1085 where mkt (d, a, t, m) = t

1079

1086

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+

1080lookupMetaInformation :: Name -> Context -> [MetaInformation]

1091lookupMetaInformation :: Name -> Context -> [MetaInformation]

1081lookupMetaInformation n ctxt = map mkm $ lookupCtxt n (definitions ctxt)

1092lookupMetaInformation n ctxt = map mkm $ lookupCtxt n (definitions ctxt)

1082 where mkm (d, a, t, m) = m

1093 where mkm (d, a, t, m) = m

src/Idris/Core/ProofState.hs+22−5

@@ -25,7 +25,10 @@ import Util.Pretty hiding (fill)

25data ProofState = PS { thname :: Name,

26 holes :: [Name], -- ^ holes still to be solved

27 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

29 pterm :: ProofTerm, -- ^ current proof term

32 pterm :: ProofTerm, -- ^ current proof term

30 ptype :: Type, -- ^ original goal

33 ptype :: Type, -- ^ original goal

31 dontunify :: [Name], -- ^ explicitly given by programmer, leave it

34 dontunify :: [Name], -- ^ explicitly given by programmer, leave it

@@ -206,6 +209,14 @@ mergeSolutions env ns = merge [] ns

206 merge acc ns

209 merge acc ns

207 | otherwise = merge ((n, t): acc) ns

210 | otherwise = merge ((n, t): acc) ns

208

211

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+

209unify' :: Context -> Env ->

220unify' :: Context -> Env ->

210 (TT Name, Maybe Provenance) ->

221 (TT Name, Maybe Provenance) ->

211 (TT Name, Maybe Provenance) ->

222 (TT Name, Maybe Provenance) ->

@@ -242,7 +253,8 @@ unify' ctxt env (topx, xfrom) (topy, yfrom) =

242 -- problem for each.

253 -- problem for each.

243 uns <- mergeSolutions env (u' ++ ns)

254 uns <- mergeSolutions env (u' ++ ns)

244 ps <- get

255 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

246 let (notu', probs_notu) = mergeNotunified env (holes ps) (notu ++ notunified ps)

258 let (notu', probs_notu) = mergeNotunified env (holes ps) (notu ++ notunified ps)

247 traceWhen (unifylog ps)

259 traceWhen (unifylog ps)

248 ("Now solved: " ++ show ns' ++

260 ("Now solved: " ++ show ns' ++

@@ -296,11 +308,16 @@ query q = do ps <- get

296addLog :: Monad m => String -> StateT TState m ()

308addLog :: Monad m => String -> StateT TState m ()

297addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

309addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

298

310

299−newProof :: Name -> Context -> Ctxt TypeInfo -> Type -> ProofState

311+newProof :: Name -- ^ the name of what's to be elaborated

300−newProof n ctxt datatypes ty =

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 =

301 let h = holeName 0

318 let h = holeName 0

302 ty' = vToP ty

319 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')

304 (P Bound h ty'))) ty [] (h, []) [] []

321 (P Bound h ty'))) ty [] (h, []) [] []

305 Nothing [] []

322 Nothing [] []

306 [] [] [] []

323 [] [] [] []

src/Idris/Core/TT.hs+4−4

@@ -268,7 +268,7 @@ data Err' t

268 | NoTypeDecl Name

269 | NotInjective t t t

270 | CantResolve Bool -- True if postponed, False if fatal

271− t

271+ t (Err' t) -- any further information

272 | InvalidTCArg Name t

273 | CantResolveAlts [Name]

274 | NoValidAlts [Name]

@@ -354,7 +354,7 @@ instance Sized Err where

354 size (NoSuchVariable name) = size name

355 size (NoTypeDecl name) = size name

356 size (NotInjective l c r) = size l + size c + size r

357− size (CantResolve _ trm) = size trm

357+ size (CantResolve _ trm _) = size trm

358 size (NoRewriting trm) = size trm

359 size (CantResolveAlts _) = 1

360 size (IncompleteTerm trm) = size trm

@@ -397,7 +397,7 @@ instance Show Err where

397 show (WithFnType _) = "WithFnType"

398 show (NoTypeDecl _) = "NoTypeDecl"

399 show (NotInjective _ _ _) = "NotInjective"

400− show (CantResolve _ _) = "CantResolve"

400+ show (CantResolve _ _ _) = "CantResolve"

401 show (InvalidTCArg _ _) = "InvalidTCArg"

402 show (CantResolveAlts _) = "CantResolveAlts"

403 show (NoValidAlts _) = "NoValidAlts"

@@ -588,7 +588,7 @@ tcname (SN (MethodN _)) = True

588tcname (SN (ParentN _ _)) = True

589tcname _ = False

590

591−implicitable (NS n _) = implicitable n

591+implicitable (NS n _) = False

592implicitable (UN xs) | T.null xs = False

593 | otherwise = isLower (T.head xs) || T.head xs == '_'

594implicitable (MN _ x) = not (tnull x) && thead x /= '_'

src/Idris/Coverage.hs+52−28

@@ -59,10 +59,16 @@ genClauses fc n xs given

59 let lhs_tms' = zipWith mergePlaceholders lhs_tms

60 (map (stripUnmatchable i) (map flattenArgs given))

61 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"

62

65

63 let argss = transpose lhss

66 let argss = transpose lhss

64− let all_args = map (genAll i) argss

67+ let all_args = map (genAll i) (zip (genPH i nty) argss)

65 logCoverage 5 $ "COVERAGE of " ++ show n

68 logCoverage 5 $ "COVERAGE of " ++ show n

69+ logCoverage 5 $ "using type " ++ show nty

70+ logCoverage 5 $ "non-concrete args " ++ show (genPH i nty)

71+

66 logCoverage 5 $ show (lhs_tms, lhss)

72 logCoverage 5 $ show (lhs_tms, lhss)

67 logCoverage 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

73 logCoverage 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

68 logCoverage 10 $ show argss ++ "\n" ++ show all_args

74 logCoverage 10 $ show argss ++ "\n" ++ show all_args

@@ -89,6 +95,18 @@ genClauses fc n xs given

89 | (f, args) <- unApply term = map (\t -> delab' i t True True) args

95 | (f, args) <- unApply term = map (\t -> delab' i t True True) args

90 | otherwise = []

96 | otherwise = []

91

97

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+

92 pUnApply (PApp _ f args) = map getTm args

110 pUnApply (PApp _ f args) = map getTm args

93 pUnApply _ = []

111 pUnApply _ = []

94

112

@@ -135,6 +153,7 @@ validCoverageCase ctxt (CantUnify _ (topx, _) (topy, _) e _ _)

135 = case (unApply topx, unApply topy) of

153 = case (unApply topx, unApply topy) of

136 ((P _ x _, _), (P _ y _, _)) -> x == y

154 ((P _ x _, _), (P _ y _, _)) -> x == y

137 _ -> False

155 _ -> False

156+validCoverageCase ctxt (InfiniteUnify _ _ _) = False

138validCoverageCase ctxt (CantConvert _ _ _) = False

157validCoverageCase ctxt (CantConvert _ _ _) = False

139validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e

158validCoverageCase ctxt (At _ e) = validCoverageCase ctxt e

140validCoverageCase ctxt (Elaborating _ _ _ e) = validCoverageCase ctxt e

159validCoverageCase ctxt (Elaborating _ _ _ e) = validCoverageCase ctxt e

@@ -171,16 +190,14 @@ recoverableCoverage ctxt (Elaborating _ _ _ e) = recoverableCoverage ctxt e

171recoverableCoverage ctxt (ElaboratingArg _ _ _ e) = recoverableCoverage ctxt e

190recoverableCoverage ctxt (ElaboratingArg _ _ _ e) = recoverableCoverage ctxt e

172recoverableCoverage _ _ = False

191recoverableCoverage _ _ = False

173

192

174−-- FIXME: Just look for which one is the deepest, then generate all

193+genAll :: IState -> (Bool, [PTerm]) -> [PTerm]

175−-- possibilities up to that depth.

194+genAll i (addPH, args)

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

180 = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of

195 = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of

181 [] -> [Placeholder]

196 [] -> [Placeholder]

182− xs -> inventConsts xs

197+ xs -> ph $ inventConsts xs

183 where

198 where

199+ ph ts = if addPH then Placeholder : ts else ts

200+

184 -- if they're constants, invent a new one to make sure that

201 -- if they're constants, invent a new one to make sure that

185 -- constants which are not explicitly handled are covered

202 -- constants which are not explicitly handled are covered

186 inventConsts cs@(PConstant fc c : _) = map (PConstant NoFC) (ic' (mapMaybe getConst cs))

203 inventConsts cs@(PConstant fc c : _) = map (PConstant NoFC) (ic' (mapMaybe getConst cs))

@@ -203,7 +220,6 @@ genAll i args

203 ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64)

220 ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64)

204 ic' xs@(Ch _ : _) = firstMissing xs lotsOfChars

221 ic' xs@(Ch _ : _) = firstMissing xs lotsOfChars

205 ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings

222 ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings

206− -- TODO: Bit vectors

207 -- The rest are types with only one case

223 -- The rest are types with only one case

208 ic' xs = xs

224 ic' xs = xs

209

225

@@ -218,19 +234,19 @@ genAll i args

218 nubMap f acc (x : xs) = nubMap f (fnub' acc (f x)) xs

234 nubMap f acc (x : xs) = nubMap f (fnub' acc (f x)) xs

219

235

220 otherPats :: PTerm -> [PTerm]

236 otherPats :: PTerm -> [PTerm]

221− otherPats o@(PRef fc hl n) = ops fc n [] o

237+ otherPats o@(PRef fc hl n) = ph $ ops fc n [] o

222− otherPats o@(PApp _ (PRef fc hl n) xs) = ops fc n xs o

238+ otherPats o@(PApp _ (PRef fc hl n) xs) = ph $ ops fc n xs o

223 otherPats o@(PPair fc hls _ l r)

239 otherPats o@(PPair fc hls _ l r)

224− = ops fc pairCon

240+ = ph $ ops fc pairCon

225 ([pimp (sUN "A") Placeholder True,

241 ([pimp (sUN "A") Placeholder True,

226 pimp (sUN "B") Placeholder True] ++

242 pimp (sUN "B") Placeholder True] ++

227 [pexp l, pexp r]) o

243 [pexp l, pexp r]) o

228 otherPats o@(PDPair fc hls p t _ v)

244 otherPats o@(PDPair fc hls p t _ v)

229− = ops fc sigmaCon

245+ = ph $ ops fc sigmaCon

230 ([pimp (sUN "a") Placeholder True,

246 ([pimp (sUN "a") Placeholder True,

231 pimp (sUN "P") Placeholder True] ++

247 pimp (sUN "P") Placeholder True] ++

232 [pexp t,pexp v]) o

248 [pexp t,pexp v]) o

233− otherPats o@(PConstant _ c) = inventConsts [o] -- return o

249+ otherPats o@(PConstant _ c) = ph $ inventConsts [o] -- return o

234 otherPats arg = return Placeholder

250 otherPats arg = return Placeholder

235

251

236 ops fc n xs o

252 ops fc n xs o

@@ -313,20 +329,21 @@ checkAllCovering fc done top n | not (n `elem` done)

313 [Partial _] ->

329 [Partial _] ->

314 case lookupCtxt n (idris_callgraph i) of

330 case lookupCtxt n (idris_callgraph i) of

315 [cg] -> mapM_ (checkAllCovering fc (n : done) top)

331 [cg] -> mapM_ (checkAllCovering fc (n : done) top)

316− (map fst (calls cg))

332+ (calls cg)

317 _ -> return ()

333 _ -> return ()

318 x -> return () -- stop if total

334 x -> return () -- stop if total

319checkAllCovering _ _ _ _ = return ()

335checkAllCovering _ _ _ _ = return ()

320

336

321−-- Check if, in a given group of type declarations mut_ns,

337+-- | Check if, in a given group of type declarations mut_ns,

322-- the constructor cn : ty is strictly positive,

338-- the constructor cn : ty is strictly positive,

323-- and update the context accordingly

339-- and update the context accordingly

324−

340+checkPositive :: [Name] -- ^ the group of type declarations

325−checkPositive :: [Name] -> (Name, Type) -> Idris Totality

341+ -> (Name, Type) -- ^ the constructor

342+ -> Idris Totality

326checkPositive mut_ns (cn, ty')

343checkPositive 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')

328 let p = cp ty

346 let p = cp ty

329− i <- getIState

330 let tot = if p then Total (args ty) else Partial NotPositive

347 let tot = if p then Total (args ty) else Partial NotPositive

331 let ctxt' = setTotal cn tot (tt_ctxt i)

348 let ctxt' = setTotal cn tot (tt_ctxt i)

332 putIState (i { tt_ctxt = ctxt' })

349 putIState (i { tt_ctxt = ctxt' })

@@ -365,8 +382,8 @@ calcTotality fc n pats

365 _ -> checkSizeChange n

382 _ -> checkSizeChange n

366 where

383 where

367 checkLHS i (P _ fn _)

384 checkLHS i (P _ fn _)

368− = case lookupTotal fn (tt_ctxt i) of

385+ = case lookupTotalExact fn (tt_ctxt i) of

369− [Partial _] -> return (Partial (Other [fn]))

386+ Just (Partial _) -> return (Partial (Other [fn]))

370 _ -> Nothing

387 _ -> Nothing

371 checkLHS i (App _ f a) = mplus (checkLHS i f) (checkLHS i a)

388 checkLHS i (App _ f a) = mplus (checkLHS i f) (checkLHS i a)

372 checkLHS _ _ = Nothing

389 checkLHS _ _ = Nothing

@@ -441,12 +458,18 @@ checkDeclTotality (fc, n)

441 _ -> []

458 _ -> []

442 when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n

459 when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n

443 t <- checkTotality [] fc n

460 t <- checkTotality [] fc n

461+ let acc = case lookupDefAccExact n False (tt_ctxt i) of

462+ Just (n, a) -> a

463+ _ -> Public

444 case t of

464 case t of

445 -- if it's not total, it can't reduce, to keep

465 -- if it's not total, it can't reduce, to keep

446− -- typechecking decidable

466+ -- typechecking decidable.

447− p@(Partial _) -> do setAccessibility n Frozen

467+ -- So if it's currently public export, set it as

448− addIBC (IBCAccess n Frozen)

468+ -- export instead.

449− logCoverage 5 $ "HIDDEN: "

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 ++ ":"

450 ++ show n ++ show p

473 ++ show n ++ show p

451 _ -> return ()

474 _ -> return ()

452 return t

475 return t

@@ -474,6 +497,7 @@ buildSCG (_, n) = do

474 let newscg = buildSCG' ist (rights pats) args

497 let newscg = buildSCG' ist (rights pats) args

475 logCoverage 5 $ "SCG is: " ++ show newscg

498 logCoverage 5 $ "SCG is: " ++ show newscg

476 addToCG n ( cg { scg = newscg } )

499 addToCG n ( cg { scg = newscg } )

500+ _ -> return () -- CG comes from a type declaration only

477 [] -> logCoverage 5 $ "Could not build SCG for " ++ show n ++ "\n"

501 [] -> logCoverage 5 $ "Could not build SCG for " ++ show n ++ "\n"

478 x -> error $ "buildSCG: " ++ show (n, x)

502 x -> error $ "buildSCG: " ++ show (n, x)

479

503

@@ -573,8 +597,8 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

573

597

574 toJust (n, t) = Just t

598 toJust (n, t) = Just t

575

599

576− getType n = case lookupTy n (tt_ctxt ist) of

600+ getType n = case lookupTyExact n (tt_ctxt ist) of

577− [ty] -> delazy ty -- must exist

601+ Just ty -> delazy (normalise (tt_ctxt ist) [] ty) -- must exist

578

602

579 isInductive (P _ nty _) (P _ nty' _) =

603 isInductive (P _ nty _) (P _ nty' _) =

580 let co = case lookupCtxt nty (idris_datatypes ist) of

604 let co = case lookupCtxt nty (idris_datatypes ist) of

src/Idris/DeepSeq.hs+9−7

@@ -199,7 +199,8 @@ instance NFData IOption where

199 opt_optimise

200 opt_printdepth

201 opt_evaltypes

202− opt_desugarnats) =

202+ opt_desugarnats

203+ opt_autoimpls) =

203 rnf opt_logLevel

204 rnf opt_logLevel

204 `seq` rnf opt_typecase

205 `seq` rnf opt_typecase

205 `seq` rnf opt_typeintype

206 `seq` rnf opt_typeintype

@@ -224,6 +225,7 @@ instance NFData IOption where

224 `seq` rnf opt_printdepth

225 `seq` rnf opt_printdepth

225 `seq` rnf opt_evaltypes

226 `seq` rnf opt_evaltypes

226 `seq` rnf opt_desugarnats

227 `seq` rnf opt_desugarnats

228+ `seq` rnf opt_autoimpls

227 `seq` ()

229 `seq` ()

228

230

229instance NFData LanguageExt where

231instance NFData LanguageExt where

@@ -365,9 +367,9 @@ instance NFData LogCat where

365 rnf _ = ()

367 rnf _ = ()

366

368

367instance NFData CGInfo where

369instance NFData CGInfo where

368− rnf (CGInfo x1 x2 x3 x4 x5)

370+ rnf (CGInfo x1 x2 x3)

369 = rnf x1 `seq`

371 = rnf x1 `seq`

370− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

372+ rnf x2 `seq` rnf x3 `seq` ()

371

373

372instance NFData Fixity where

374instance NFData Fixity where

373 rnf (Infixl x1) = rnf x1 `seq` ()

375 rnf (Infixl x1) = rnf x1 `seq` ()

@@ -466,7 +468,7 @@ instance (NFData t) => NFData (PDecl' t) where

466 rnf x9 `seq`

468 rnf x9 `seq`

467 rnf x10 `seq`

469 rnf x10 `seq`

468 rnf x11 `seq` rnf x12 `seq` ()

470 rnf x11 `seq` rnf x12 `seq` ()

469− rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)

471+ rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)

470 = rnf x1 `seq`

472 = rnf x1 `seq`

471 rnf x2 `seq`

473 rnf x2 `seq`

472 rnf x3 `seq`

474 rnf x3 `seq`

@@ -475,7 +477,7 @@ instance (NFData t) => NFData (PDecl' t) where

475 rnf x6 `seq`

477 rnf x6 `seq`

476 rnf x7 `seq`

478 rnf x7 `seq`

477 rnf x8 `seq`

479 rnf x8 `seq`

478− rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` ()

480+ rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` ()

479 rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

481 rnf (PDSL x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

480 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

482 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

481 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

483 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -696,8 +698,8 @@ instance NFData IState where

696 rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20

698 rnf (IState x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20

697 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40

699 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40

698 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60

700 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60

699− x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74)

701+ x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75)

700 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` () `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` rnf x15 `seq` rnf x16 `seq` rnf x17 `seq` rnf x18 `seq` rnf x19 `seq` rnf x20 `seq`

702 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` () `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` rnf x15 `seq` rnf x16 `seq` rnf x17 `seq` rnf x18 `seq` rnf x19 `seq` rnf x20 `seq`

701 rnf x21 `seq` rnf x22 `seq` rnf x23 `seq` rnf x24 `seq` rnf x25 `seq` rnf x26 `seq` rnf x27 `seq` rnf x28 `seq` rnf x29 `seq` rnf x30 `seq` rnf x31 `seq` rnf x32 `seq` rnf x33 `seq` rnf x34 `seq` rnf x35 `seq` rnf x36 `seq` rnf x37 `seq` rnf x38 `seq` rnf x39 `seq` rnf x40 `seq`

703 rnf x21 `seq` rnf x22 `seq` rnf x23 `seq` rnf x24 `seq` rnf x25 `seq` rnf x26 `seq` rnf x27 `seq` rnf x28 `seq` rnf x29 `seq` rnf x30 `seq` rnf x31 `seq` rnf x32 `seq` rnf x33 `seq` rnf x34 `seq` rnf x35 `seq` rnf x36 `seq` rnf x37 `seq` rnf x38 `seq` rnf x39 `seq` rnf x40 `seq`

702 rnf x41 `seq` rnf x42 `seq` rnf x43 `seq` rnf x44 `seq` rnf x45 `seq` rnf x46 `seq` rnf x47 `seq` rnf x48 `seq` rnf x49 `seq` rnf x50 `seq` rnf x51 `seq` rnf x52 `seq` rnf x53 `seq` rnf x54 `seq` rnf x55 `seq` rnf x56 `seq` rnf x57 `seq` rnf x58 `seq` rnf x59 `seq` rnf x60 `seq`

704 rnf x41 `seq` rnf x42 `seq` rnf x43 `seq` rnf x44 `seq` rnf x45 `seq` rnf x46 `seq` rnf x47 `seq` rnf x48 `seq` rnf x49 `seq` rnf x50 `seq` rnf x51 `seq` rnf x52 `seq` rnf x53 `seq` rnf x54 `seq` rnf x55 `seq` rnf x56 `seq` rnf x57 `seq` rnf x58 `seq` rnf x59 `seq` rnf x60 `seq`

703− rnf x61 `seq` rnf x62 `seq` rnf x63 `seq` rnf x64 `seq` rnf x65 `seq` rnf x66 `seq` rnf x67 `seq` rnf x68 `seq` rnf x69 `seq` rnf x70 `seq` rnf x71 `seq` rnf x72 `seq` rnf x73 `seq` rnf x74 `seq` ()

705+ rnf x61 `seq` rnf x62 `seq` rnf x63 `seq` rnf x64 `seq` rnf x65 `seq` rnf x66 `seq` rnf x67 `seq` rnf x68 `seq` rnf x69 `seq` rnf x70 `seq` rnf x71 `seq` rnf x72 `seq` rnf x73 `seq` rnf x74 `seq` rnf x75 `seq` ()

src/Idris/Delaborate.hs+10−4

@@ -106,7 +106,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

106 | Just n' <- lookup n env = PRef un [] n'

107 | otherwise

108 = case lookup n (idris_metavars ist) of

109− Just (Just _, mi, _, _) -> mkMVApp n []

109+ Just (Just _, mi, _, _, _) -> mkMVApp n []

110 _ -> PRef un [] n

111 de env _ (Bind n (Lam ty) sc)

112 = PLam un n NoFC (de env [] ty) (de ((n,n):env) [] sc)

@@ -172,7 +172,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

172 = PApp un (de env [] f) (map pexp (map (de env []) args))

173 deFn env (P _ n _) args

174 | not mvs = case lookup n (idris_metavars ist) of

175− Just (Just _, mi, _, _) ->

175+ Just (Just _, mi, _, _, _) ->

176 mkMVApp n (drop mi (map (de env []) args))

177 _ -> mkPApp n (map (de env []) args)

178 | otherwise = mkPApp n (map (de env []) args)

@@ -317,7 +317,7 @@ pprintErr' i (CantConvert x_in y_in env) =

317 flagUnique (Bind n b sc) = Bind n (fmap flagUnique b) (flagUnique sc)

318 flagUnique t = t

319pprintErr' i (CantSolveGoal x env) =

320− text "Can't solve goal " <>

320+ text "Can't find a value of type " <>

321 indented (annTm x (pprintTerm' i (map (\ (n, b) -> (n, False)) env) (delabSugared i x))) <>

322 if (opt_errContext (idris_options i)) then line <> showSc i env else empty

323pprintErr' i (UnifyScope n out tm env) =

@@ -346,7 +346,13 @@ pprintErr' i (NotInjective p x y) =

346 text "Can't verify injectivity of" <+> annTm p (pprintTerm i (delabSugared i p)) <+>

347 text " when unifying" <+> annTm x (pprintTerm i (delabSugared i x)) <+> text "and" <+>

348 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)

350pprintErr' i (InvalidTCArg n t)

356pprintErr' i (InvalidTCArg n t)

351 = annTm t (pprintTerm i (delabSugared i t)) <+> text " cannot be a parameter of "

357 = annTm t (pprintTerm i (delabSugared i t)) <+> text " cannot be a parameter of "

352 <> annName n <$>

358 <> annName n <$>

src/Idris/Directives.hs+6−2

@@ -21,8 +21,10 @@ directiveAction (DLink cgn obj) = do dirs <- allImportDirs

21 addIBC (IBCObj cgn obj) -- just name, search on loading ibc

22 addObjectFile cgn o

23

24−directiveAction (DFlag cgn flag) = do addIBC (IBCCGFlag cgn flag)

24+directiveAction (DFlag cgn flag) = do

25− addFlag cgn flag

25+ let flags = words flag

26+ mapM_ (\f -> addIBC (IBCCGFlag cgn f)) flags

27+ mapM_ (addFlag cgn) flags

26

28

27directiveAction (DInclude cgn hdr) = do addHdr cgn hdr

29directiveAction (DInclude cgn hdr) = do addHdr cgn hdr

28 addIBC (IBCHeader cgn hdr)

30 addIBC (IBCHeader cgn hdr)

@@ -68,6 +70,8 @@ directiveAction (DDeprecate n reason)

68 = do n' <- disambiguate n

70 = do n' <- disambiguate n

69 addDeprecated n' reason

71 addDeprecated n' reason

70 addIBC (IBCDeprecate n' reason)

72 addIBC (IBCDeprecate n' reason)

73+directiveAction (DAutoImplicits b)

74+ = setAutoImpls b

71directiveAction (DUsed fc fn arg) = addUsedName fc fn arg

75directiveAction (DUsed fc fn arg) = addUsedName fc fn arg

72

76

73disambiguate :: Name -> Idris Name

77disambiguate :: Name -> Idris Name

src/Idris/Docs.hs+3−3

@@ -19,7 +19,7 @@ import Data.Maybe

19import Data.List

20import qualified Data.Text as T

21

22−-- TODO: Only include names with public/abstract accessibility

22+-- TODO: Only include names with public/export accessibility

23--

24-- Issue #1573 on the Issue tracker.

25-- https://github.com/idris-lang/Idris-dev/issues/1573

@@ -319,8 +319,8 @@ docClass n ci

319 namedInst n@(UN _) = Just n

320 namedInst _ = Nothing

321

322− getDInst (PInstance _ _ _ _ _ _ _ _ t _ _) = Just t

322+ getDInst (PInstance _ _ _ _ _ _ _ _ _ _ t _ _) = Just t

323− getDInst _ = Nothing

323+ getDInst _ = Nothing

324

325 isSubclass (PPi (Constraint _ _) _ _ (PApp _ _ args) (PApp _ (PRef _ _ nm) args'))

326 = nm == n && map getTm args == map getTm args'

src/Idris/Elab/AsPat.hs+8

@@ -28,6 +28,14 @@ collectAs (PApp fc t as)

28 = do as_tm <- mapM collectAs (map getTm as)

29 let as' = zipWith (\a tm -> a { getTm = tm }) as as_tm

30 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'))

31collectAs x = return x

39collectAs x = return x

32

40

33-- | Replace _-patterns under @-patterns with fresh names that can be

41-- | 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

78 let idecls = filter instdecl ds -- default superclass instance declarations

79 mapM_ checkDefaultSuperclassInstance idecls

80 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+

81 logElab 1 $ "Building methods " ++ show mnames

87 logElab 1 $ "Building methods " ++ show mnames

82 ims <- mapM (tdecl mnames) mdecls

88 ims <- mapM (tdecl mnames) mdecls

83 defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)

89 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

138

144

139 -- TODO: probably should normalise

145 -- TODO: probably should normalise

140 checkDefaultSuperclassInstance :: PDecl -> Idris ()

146 checkDefaultSuperclassInstance :: PDecl -> Idris ()

141− checkDefaultSuperclassInstance (PInstance _ _ _ fc cs n _ ps _ _ _)

147+ checkDefaultSuperclassInstance (PInstance _ _ _ fc cs _ _ n _ ps _ _ _)

142 = do when (not $ null cs) . tclift

148 = do when (not $ null cs) . tclift

143 $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))

149 $ tfail (At fc (Msg $ "Default superclass instances can't have constraints."))

144 i <- getIState

150 i <- getIState

@@ -148,6 +154,14 @@ elabClass info syn_in doc fc constraints tn tnfc ps pDocs fds ds mcn cd

148 $ tfail (At fc (Msg $ "Default instances must be for a superclass constraint on the containing class."))

154 $ tfail (At fc (Msg $ "Default instances must be for a superclass constraint on the containing class."))

149 return ()

155 return ()

150

156

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+

151 impbind :: [(Name, PTerm)] -> PTerm -> PTerm

165 impbind :: [(Name, PTerm)] -> PTerm -> PTerm

152 impbind [] x = x

166 impbind [] x = x

153 impbind ((n, ty): ns) x = PPi impl n NoFC ty (impbind ns x)

167 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

184

198

185 tydecl (PTy _ _ _ _ _ _ _ _) = True

199 tydecl (PTy _ _ _ _ _ _ _ _) = True

186 tydecl _ = False

200 tydecl _ = False

187− instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _) = True

201+ instdecl (PInstance _ _ _ _ _ _ _ _ _ _ _ _ _) = True

188 instdecl _ = False

202 instdecl _ = False

189 clause (PClauses _ _ _ _) = True

203 clause (PClauses _ _ _ _) = True

190 clause _ = False

204 clause _ = False

src/Idris/Elab/Clause.hs+91−53

@@ -80,19 +80,21 @@ elabClauses info' fc opts n_in cs =

80 let atys = map snd (getArgTys fty)

81 cs_elab <- mapM (elabClause info opts)

82 (zip [0..] cs)

83+ ctxt <- getContext

83 -- pats_raw is the version we'll work with at compile time:

84 -- pats_raw is the version we'll work with at compile time:

84 -- no simplification or PE

85 -- no simplification or PE

85 let (pats_in, cs_full) = unzip cs_elab

86 let (pats_in, cs_full) = unzip cs_elab

86− let pats_raw = map (simple_lhs (tt_ctxt ist)) pats_in

87+ let pats_raw = map (simple_lhs ctxt) pats_in

87 logElab 3 $ "Elaborated patterns:\n" ++ show pats_raw

88 logElab 3 $ "Elaborated patterns:\n" ++ show pats_raw

88

89

89− solveDeferred n

90+ solveDeferred fc n

90

91

91 -- just ensure that the structure exists

92 -- just ensure that the structure exists

92 fmodifyState (ist_optimisation n) id

93 fmodifyState (ist_optimisation n) id

93 addIBC (IBCOpt n)

94 addIBC (IBCOpt n)

94

95

95 ist <- getIState

96 ist <- getIState

97+ ctxt <- getContext

96 -- Don't apply rules if this is a partial evaluation definition,

98 -- Don't apply rules if this is a partial evaluation definition,

97 -- or we'll make something that just runs itself!

99 -- or we'll make something that just runs itself!

98 let tpats = case specNames opts of

100 let tpats = case specNames opts of

@@ -103,7 +105,7 @@ elabClauses info' fc opts n_in cs =

103 -- RHS

105 -- RHS

104 pe_tm <- doPartialEval ist tpats

106 pe_tm <- doPartialEval ist tpats

105 let pats_pe = if petrans

107 let pats_pe = if petrans

106− then map (simple_lhs (tt_ctxt ist)) pe_tm

108+ then map (simple_lhs ctxt) pe_tm

107 else pats_raw

109 else pats_raw

108

110

109 let tcase = opt_typecase (idris_options ist)

111 let tcase = opt_typecase (idris_options ist)

@@ -163,9 +165,12 @@ elabClauses info' fc opts n_in cs =

163 cov <- coverage

165 cov <- coverage

164 pmissing <-

166 pmissing <-

165 if cov && not (hasDefault pats_raw)

167 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

167 -- missing <- genMissing n scargs sc

170 -- missing <- genMissing n scargs sc

168 missing' <- filterM (checkPossible info fc True n) missing

171 missing' <- filterM (checkPossible info fc True n) missing

172+ -- Filter out the ones which match one of the

173+ -- given cases (including impossible ones)

169 let clhs = map getLHS pdef

174 let clhs = map getLHS pdef

170 logElab 2 $ "Must be unreachable:\n" ++

175 logElab 2 $ "Must be unreachable:\n" ++

171 showSep "\n" (map showTmImpls missing') ++

176 showSep "\n" (map showTmImpls missing') ++

@@ -183,7 +188,8 @@ elabClauses info' fc opts n_in cs =

183 -- pdef' is the version that gets compiled for run-time,

188 -- pdef' is the version that gets compiled for run-time,

184 -- so we start from the partially evaluated version

189 -- so we start from the partially evaluated version

185 pdef_in' <- applyOpts $ map (\(ns, lhs, rhs) -> (map fst ns, lhs, rhs)) pdef_pe

190 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'

187

193

188 logElab 5 $ "After data structure transformations:\n" ++ show pdef'

194 logElab 5 $ "After data structure transformations:\n" ++ show pdef'

189

195

@@ -241,24 +247,28 @@ elabClauses info' fc opts n_in cs =

241 ctxt

247 ctxt

242 setContext ctxt'

248 setContext ctxt'

243 addIBC (IBCDef n)

249 addIBC (IBCDef n)

250+ addDefinedName n

244 setTotality n tot

251 setTotality n tot

245 when (not reflect && PEGenerated `notElem` opts) $

252 when (not reflect && PEGenerated `notElem` opts) $

246 do totcheck (fc, n)

253 do totcheck (fc, n)

247 defer_totcheck (fc, n)

254 defer_totcheck (fc, n)

248 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

255 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

249 i <- getIState

256 i <- getIState

250− case lookupDef n (tt_ctxt i) of

257+ ctxt <- getContext

258+ case lookupDef n ctxt of

251 (CaseOp _ _ _ _ _ cd : _) ->

259 (CaseOp _ _ _ _ _ cd : _) ->

252− let (scargs, sc) = cases_compiletime cd

260+ let (scargs, sc) = cases_compiletime cd in

253− (scargs', sc') = cases_runtime cd in

261+ do let calls = map fst $ findCalls sc scargs

254− do let calls = findCalls sc' scargs'

255− let used = findUsedArgs sc' scargs'

256 -- let scg = buildSCG i sc scargs

262 -- let scg = buildSCG i sc scargs

257 -- add SCG later, when checking totality

263 -- add SCG later, when checking totality

258− let cg = CGInfo scargs' calls [] used [] -- TODO: remove this, not needed anymore

264+ logElab 2 $ "Called names: " ++ show calls

259− logElab 2 $ "Called names: " ++ show cg

265+ -- if the definition is public, make sure

260− addToCG n cg

266+ -- it only uses public names

261− addToCalledG n (nub (map fst calls)) -- plus names in type!

267+ nvis <- getFromHideList n

268+ case nvis of

269+ Just Public -> mapM_ (checkVisibility fc n Public Public) calls

270+ _ -> return ()

271+ addCalls n calls

262 addIBC (IBCCG n)

272 addIBC (IBCCG n)

263 _ -> return ()

273 _ -> return ()

264 return ()

274 return ()

@@ -305,7 +315,6 @@ elabClauses info' fc opts n_in cs =

305 , (f, args) <- unApply tm = all (isPatVar pvs) args

315 , (f, args) <- unApply tm = all (isPatVar pvs) args

306 hasDefault _ = False

316 hasDefault _ = False

307

317

308−

309 getLHS (_, l, _) = l

318 getLHS (_, l, _) = l

310

319

311 simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)

320 simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)

@@ -353,11 +362,12 @@ elabPE info fc caller r =

353 mkSpecialised :: (Name, [(PEArgType, Term)]) -> Idris [(Term, Term)]

362 mkSpecialised :: (Name, [(PEArgType, Term)]) -> Idris [(Term, Term)]

354 mkSpecialised specapp_in = do

363 mkSpecialised specapp_in = do

355 ist <- getIState

364 ist <- getIState

365+ ctxt <- getContext

356 let (specTy, specapp) = getSpecTy ist specapp_in

366 let (specTy, specapp) = getSpecTy ist specapp_in

357 let (n, newnm, specdecl) = getSpecClause ist specapp

367 let (n, newnm, specdecl) = getSpecClause ist specapp

358 let lhs = pe_app specdecl

368 let lhs = pe_app specdecl

359 let rhs = pe_def specdecl

369 let rhs = pe_def specdecl

360− let undef = case lookupDefExact newnm (tt_ctxt ist) of

370+ let undef = case lookupDefExact newnm ctxt of

361 Nothing -> True

371 Nothing -> True

362 _ -> False

372 _ -> False

363 logElab 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))

373 logElab 5 $ show (newnm, undef, map (concreteArg ist) (snd specapp))

@@ -370,7 +380,7 @@ elabPE info fc caller r =

370 let cgns' = filter (\x -> x /= n &&

380 let cgns' = filter (\x -> x /= n &&

371 notStatic ist x) cgns

381 notStatic ist x) cgns

372 -- set small reduction limit on partial/productive things

382 -- 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

374 [Total _] -> 65536

384 [Total _] -> 65536

375 [Productive] -> 16

385 [Productive] -> 16

376 _ -> 1

386 _ -> 1

@@ -476,16 +486,17 @@ checkPossible info fc tcgen fname lhs_in

476 i <- getIState

486 i <- getIState

477 let lhs = addImplPat i lhs_in

487 let lhs = addImplPat i lhs_in

478 -- if the LHS type checks, it is possible

488 -- 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

480 (erun fc (buildTC i info ELHS [] fname

490 (erun fc (buildTC i info ELHS [] fname

481 (allNamesIn lhs_in)

491 (allNamesIn lhs_in)

482 (infTerm lhs))) of

492 (infTerm lhs))) of

483− OK (ElabResult lhs' _ _ ctxt' newDecls highlights, _) ->

493+ OK (ElabResult lhs' _ _ ctxt' newDecls highlights newGName, _) ->

484 do setContext ctxt'

494 do setContext ctxt'

485 processTacticDecls info newDecls

495 processTacticDecls info newDecls

486 sendHighlighting highlights

496 sendHighlighting highlights

497+ updateIState $ \i -> i { idris_name = newGName }

487 let lhs_tm = orderPats (getInferTerm lhs')

498 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

489 OK _ -> return True

500 OK _ -> return True

490 err -> return False

501 err -> return False

491 -- if it's a recoverable error, the case may become possible

502 -- 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

558 (Msg "unexpected patterns outside of \"with\" block")))

569 (Msg "unexpected patterns outside of \"with\" block")))

559

570

560 -- get the parameters first, to pass through to any where block

571 -- 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

562 [t] -> t

573 [t] -> t

563 _ -> error "Can't happen (elabClause function type)"

574 _ -> error "Can't happen (elabClause function type)"

564 let fn_is = case lookupCtxt fname (idris_implicits i) of

575 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

573-- let lhs = mkLHSapp $

584-- let lhs = mkLHSapp $

574-- propagateParams i params fn_ty (addImplPat i lhs_in)

585-- propagateParams i params fn_ty (addImplPat i lhs_in)

575 logElab 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))

586 logElab 10 (show (params, fn_ty) ++ " " ++ showTmImpls (addImplPat i lhs_in))

576− logElab 5 ("LHS: " ++ show fc ++ " " ++ showTmImpls lhs)

587+ logElab 5 ("LHS: " ++ show opts ++ "\n" ++ show fc ++ " " ++ showTmImpls lhs)

577− logElab 4 ("Fixed parameters: " ++ show params ++ " from " ++ show lhs_in ++

588+ logElab 4 ("Fixed parameters: " ++ show params ++ " from " ++ showTmImpls lhs_in ++

578 "\n" ++ show (fn_ty, fn_is))

589 "\n" ++ show (fn_ty, fn_is))

579

590

580− ((ElabResult lhs' dlhs [] ctxt' newDecls highlights, probs, inj), _) <-

591+ ((ElabResult lhs' dlhs [] ctxt' newDecls highlights newGName, probs, inj), _) <-

581− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

592+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState

582 (do res <- errAt "left hand side of " fname Nothing

593 (do res <- errAt "left hand side of " fname Nothing

583 (erun fc (buildTC i info ELHS opts fname

594 (erun fc (buildTC i info ELHS opts fname

584 (allNamesIn lhs_in)

595 (allNamesIn lhs_in)

@@ -589,6 +600,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

589 setContext ctxt'

600 setContext ctxt'

590 processTacticDecls info newDecls

601 processTacticDecls info newDecls

591 sendHighlighting highlights

602 sendHighlighting highlights

603+ updateIState $ \i -> i { idris_name = newGName }

592

604

593 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

605 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

594

606

@@ -602,6 +614,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

602

614

603 -- If we're inferring metavariables in the type, don't recheck,

615 -- If we're inferring metavariables in the type, don't recheck,

604 -- because we're only doing this to try to work out those metavariables

616 -- because we're only doing this to try to work out those metavariables

617+ ctxt <- getContext

605 (clhs_c, clhsty) <- if not inf

618 (clhs_c, clhsty) <- if not inf

606 then recheckC_borrowing False (PEGenerated `notElem` opts)

619 then recheckC_borrowing False (PEGenerated `notElem` opts)

607 [] fc id [] lhs_tm

620 [] fc id [] lhs_tm

@@ -627,6 +640,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

627 logElab 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

640 logElab 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

628 -- Elaborate where block

641 -- Elaborate where block

629 ist <- getIState

642 ist <- getIState

643+ ctxt <- getContext

644+

630 windex <- getName

645 windex <- getName

631 let decls = nub (concatMap declared whereblock)

646 let decls = nub (concatMap declared whereblock)

632 let defs = nub (decls ++ concatMap defined whereblock)

647 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

635 -- Unique arguments must be passed to the where block explicitly

650 -- Unique arguments must be passed to the where block explicitly

636 -- (since we can't control "usage" easlily otherwise). Remove them

651 -- (since we can't control "usage" easlily otherwise). Remove them

637 -- from newargs here

652 -- from newargs here

638− let uniqargs = findUnique (tt_ctxt ist) [] lhs_tm

653+ let uniqargs = findUnique ctxt [] lhs_tm

639 let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all

654 let newargs = filter (\(n,_) -> n `notElem` uniqargs) newargs_all

640

655

641 let winfo = (pinfo info newargs defs windex) { elabFC = Just fc }

656 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

657 logElab 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs

672 logElab 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs

658 ctxt <- getContext -- new context with where block added

673 ctxt <- getContext -- new context with where block added

659 logElab 5 "STARTING CHECK"

674 logElab 5 "STARTING CHECK"

660− ((rhs', defer, is, probs, ctxt', newDecls, highlights), _) <-

675+ ((rhs', defer, holes, is, probs, ctxt', newDecls, highlights, newGName), _) <-

661− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patRHS") clhsty initEState

676+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patRHS") clhsty initEState

662 (do pbinds ist lhs_tm

677 (do pbinds ist lhs_tm

663 -- proof search can use explicitly written names

678 -- proof search can use explicitly written names

664 mapM_ addPSname (allNamesIn lhs_in)

679 mapM_ addPSname (allNamesIn lhs_in)

665 mapM_ setinj (nub (tcparams ++ inj))

680 mapM_ setinj (nub (tcparams ++ inj))

666 setNextName

681 setNextName

667− (ElabResult _ _ is ctxt' newDecls highlights) <-

682+ (ElabResult _ _ is ctxt' newDecls highlights newGName) <-

668 errAt "right hand side of " fname (Just clhsty)

683 errAt "right hand side of " fname (Just clhsty)

669 (erun fc (build i winfo ERHS opts fname rhs))

684 (erun fc (build i winfo ERHS opts fname rhs))

670 errAt "right hand side of " fname (Just clhsty)

685 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

674 let (tm, ds) = runState (collectDeferred (Just fname)

689 let (tm, ds) = runState (collectDeferred (Just fname)

675 (map fst $ case_decls aux) ctxt tt) []

690 (map fst $ case_decls aux) ctxt tt) []

676 probs <- get_probs

691 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))

678 setContext ctxt'

694 setContext ctxt'

679 processTacticDecls info newDecls

695 processTacticDecls info newDecls

680 sendHighlighting highlights

696 sendHighlighting highlights

697+ updateIState $ \i -> i { idris_name = newGName }

681

698

682 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

699 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

683

700

@@ -685,9 +702,12 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

685 logElab 4 $ "---> " ++ show rhs'

702 logElab 4 $ "---> " ++ show rhs'

686 when (not (null defer)) $ logElab 1 $ "DEFERRED " ++

703 when (not (null defer)) $ logElab 1 $ "DEFERRED " ++

687 show (map (\ (n, (_,_,t,_)) -> (n, t)) defer)

704 show (map (\ (n, (_,_,t,_)) -> (n, t)) defer)

688− def' <- checkDef fc (\n -> Elaborating "deferred type of " n Nothing) defer

705+

689− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

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'

690 addDeferred def''

709 addDeferred def''

710+

691 mapM_ (\(n, _) -> addIBC (IBCDef n)) def''

711 mapM_ (\(n, _) -> addIBC (IBCDef n)) def''

692

712

693 when (not (null def')) $ do

713 when (not (null def')) $ do

@@ -703,11 +723,23 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

703 logElab 5 $ "Rechecking"

723 logElab 5 $ "Rechecking"

704 logElab 6 $ " ==> " ++ show (forget rhs')

724 logElab 6 $ " ==> " ++ show (forget rhs')

705

725

706− (crhs, crhsty) <- if not inf

726+ (crhs, crhsty) -- if there's holes && deferred things, it's okay

707− then recheckC_borrowing True (PEGenerated `notElem` opts)

727+ -- but we'll need to freeze the definition and not

708− borrowed fc id [] rhs'

728+ -- allow the deferred things to be definable

709− else return (rhs', clhsty)

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+

710 logElab 6 $ " ==> " ++ showEnvDbg [] crhsty ++ " against " ++ showEnvDbg [] clhsty

736 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+

711 ctxt <- getContext

743 ctxt <- getContext

712 let constv = next_tvar ctxt

744 let constv = next_tvar ctxt

713 case LState.runStateT (convertsC ctxt [] crhsty clhsty) (constv, []) of

745 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)

798 -- pattern bindings

830 -- pattern bindings

799 i <- getIState

831 i <- getIState

800 -- get the parameters first, to pass through to any where block

832 -- 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

802 [t] -> t

834 [t] -> t

803 _ -> error "Can't happen (elabClause function type)"

835 _ -> error "Can't happen (elabClause function type)"

804 let fn_is = case lookupCtxt fname (idris_implicits i) of

836 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)

809 propagateParams i params fn_ty (allNamesIn lhs_in)

841 propagateParams i params fn_ty (allNamesIn lhs_in)

810 (addImplPat i lhs_in)

842 (addImplPat i lhs_in)

811 logElab 2 ("LHS: " ++ show lhs)

843 logElab 2 ("LHS: " ++ show lhs)

812− (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

844+ (ElabResult lhs' dlhs [] ctxt' newDecls highlights newGName, _) <-

813− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "patLHS") infP initEState

845+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "patLHS") infP initEState

814 (errAt "left hand side of with in " fname Nothing

846 (errAt "left hand side of with in " fname Nothing

815 (erun fc (buildTC i info ELHS opts fname

847 (erun fc (buildTC i info ELHS opts fname

816 (allNamesIn lhs_in)

848 (allNamesIn lhs_in)

@@ -818,7 +850,9 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

818 setContext ctxt'

850 setContext ctxt'

819 processTacticDecls info newDecls

851 processTacticDecls info newDecls

820 sendHighlighting highlights

852 sendHighlighting highlights

853+ updateIState $ \i -> i { idris_name = newGName }

821

854

855+ ctxt <- getContext

822 let lhs_tm = orderPats (getInferTerm lhs')

856 let lhs_tm = orderPats (getInferTerm lhs')

823 let lhs_ty = getInferType lhs'

857 let lhs_ty = getInferType lhs'

824 let ret_ty = getRetTy (explicitNames (normalise ctxt [] lhs_ty))

858 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)

830 let wval = addImplBound i (map fst bargs) wval_in

864 let wval = addImplBound i (map fst bargs) wval_in

831 logElab 5 ("Checking " ++ showTmImpls wval)

865 logElab 5 ("Checking " ++ showTmImpls wval)

832 -- Elaborate wval in this context

866 -- Elaborate wval in this context

833− ((wval', defer, is, ctxt', newDecls, highlights), _) <-

867+ ((wval', defer, is, ctxt', newDecls, highlights, newGName), _) <-

834− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "withRHS")

868+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "withRHS")

835 (bindTyArgs PVTy bargs infP) initEState

869 (bindTyArgs PVTy bargs infP) initEState

836 (do pbinds i lhs_tm

870 (do pbinds i lhs_tm

837 -- proof search can use explicitly written names

871 -- proof search can use explicitly written names

838 mapM_ addPSname (allNamesIn lhs_in)

872 mapM_ addPSname (allNamesIn lhs_in)

839 setNextName

873 setNextName

840 -- TODO: may want where here - see winfo abpve

874 -- 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

842 (erun fc (build i info ERHS opts fname (infTerm wval)))

876 (erun fc (build i info ERHS opts fname (infTerm wval)))

843 erun fc $ psolve lhs_tm

877 erun fc $ psolve lhs_tm

844 tt <- get_term

878 tt <- get_term

845− return (tt, d, is, ctxt', newDecls, highlights))

879+ return (tt, d, is, ctxt', newDecls, highlights, newGName))

846 setContext ctxt'

880 setContext ctxt'

847 processTacticDecls info newDecls

881 processTacticDecls info newDecls

848 sendHighlighting highlights

882 sendHighlighting highlights

883+ updateIState $ \i -> i { idris_name = newGName }

849

884

850− def' <- checkDef fc iderr defer

885+ def' <- checkDef fc iderr True defer

851− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

886+ let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, True))) def'

852 addDeferred def''

887 addDeferred def''

853 mapM_ (elabCaseBlock info opts) is

888 mapM_ (elabCaseBlock info opts) is

854 logElab 5 ("Checked wval " ++ show wval')

889 logElab 5 ("Checked wval " ++ show wval')

890+

891+ ctxt <- getContext

855 (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')

892 (cwval, cwvalty) <- recheckC fc id [] (getInferTerm wval')

856 let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)

893 let cwvaltyN = explicitNames (normalise ctxt [] cwvalty)

857 let cwvalN = explicitNames (normalise ctxt [] cwval)

894 let cwvalN = explicitNames (normalise ctxt [] cwval)

@@ -910,8 +947,8 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

910 addIBC (IBCImp wname)

947 addIBC (IBCImp wname)

911 addIBC (IBCStatic wname)

948 addIBC (IBCStatic wname)

912

949

913− def' <- checkDef fc iderr [(wname, (-1, Nothing, wtype, []))]

950+ def' <- checkDef fc iderr True [(wname, (-1, Nothing, wtype, []))]

914− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

951+ let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, True))) def'

915 addDeferred def''

952 addDeferred def''

916

953

917 -- in the subdecls, lhs becomes:

954 -- in the subdecls, lhs becomes:

@@ -938,21 +975,22 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

938 logElab 5 ("New RHS " ++ showTmImpls rhs)

975 logElab 5 ("New RHS " ++ showTmImpls rhs)

939 ctxt <- getContext -- New context with block added

976 ctxt <- getContext -- New context with block added

940 i <- getIState

977 i <- getIState

941− ((rhs', defer, is, ctxt', newDecls, highlights), _) <-

978+ ((rhs', defer, is, ctxt', newDecls, highlights, newGName), _) <-

942− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "wpatRHS") clhsty initEState

979+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "wpatRHS") clhsty initEState

943 (do pbinds i lhs_tm

980 (do pbinds i lhs_tm

944 setNextName

981 setNextName

945− (ElabResult _ d is ctxt' newDecls highlights) <-

982+ (ElabResult _ d is ctxt' newDecls highlights newGName) <-

946 erun fc (build i info ERHS opts fname rhs)

983 erun fc (build i info ERHS opts fname rhs)

947 psolve lhs_tm

984 psolve lhs_tm

948 tt <- get_term

985 tt <- get_term

949− return (tt, d, is, ctxt', newDecls, highlights))

986+ return (tt, d, is, ctxt', newDecls, highlights, newGName))

950 setContext ctxt'

987 setContext ctxt'

951 processTacticDecls info newDecls

988 processTacticDecls info newDecls

952 sendHighlighting highlights

989 sendHighlighting highlights

990+ updateIState $ \i -> i { idris_name = newGName }

953

991

954− def' <- checkDef fc iderr defer

992+ def' <- checkDef fc iderr True defer

955− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False))) def'

993+ let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, False, True))) def'

956 addDeferred def''

994 addDeferred def''

957 mapM_ (elabCaseBlock info opts) is

995 mapM_ (elabCaseBlock info opts) is

958 logElab 5 ("Checked RHS " ++ show rhs')

996 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)

60 = do let codata = Codata `elem` opts

61 logElab 1 (show (fc, doc))

62 checkUndefined fc n

63− when (implicitable n) $ warnLC fc n

63+ when (implicitable (nsroot n)) $ warnLC fc n

64 (cty, _, t, inacc) <- buildType info syn fc [] n t_in

65

66 addIBC (IBCDef n)

@@ -71,7 +71,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n nfc t_in dcons)

71 = do let codata = Codata `elem` opts

72 logElab 1 (show fc)

73 undef <- isUndefined fc n

74− when (implicitable n) $ warnLC fc n

74+ when (implicitable (nsroot n)) $ warnLC fc n

75 (cty, ckind, t, inacc) <- buildType info syn fc [] n t_in

76 -- if n is defined already, make sure it is just a type declaration

77 -- 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)

90 ttag <- getName

91 i <- getIState

92 let as = map (const (Left (Msg ""))) (getArgTys cty)

93− let params = findParams (map snd cons)

93+ let params = findParams n (map snd cons)

94 logElab 2 $ "Parameters : " ++ show params

95 -- TI contains information about mutually declared types - this will

96 -- 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)

132 (nfc, AnnName n Nothing Nothing Nothing))

133 dcons

134 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 }

142

135

143 checkDefinedAs fc n t i

136 checkDefinedAs fc n t i

144 = let defined = tclift $ tfail (At fc (AlreadyDefined n))

137 = 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)

152 _ -> defined

145 _ -> defined

153 _ -> defined

146 _ -> defined

154 _ -> defined

147 _ -> defined

155− -- parameters are names which are unchanged across the structure,

148+

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

211

149

212 cname (_, _, n, _, _, _, _) = n

150 cname (_, _, n, _, _, _, _) = n

213

151

@@ -231,7 +169,7 @@ elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

231 Idris (Name, Type)

169 Idris (Name, Type)

232elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcenames)

170elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcenames)

233 = do checkUndefined fc n

171 = do checkUndefined fc n

234− when (implicitable n) $ warnLC fc n

172+ when (implicitable (nsroot n)) $ warnLC fc n

235 logElab 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in

173 logElab 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t_in

236 (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in)

174 (cty, ckind, t, inacc) <- buildType info syn fc [Constructor] n (if codata then mkLazy t_in else t_in)

237 ctxt <- getContext

175 ctxt <- getContext

@@ -244,7 +182,7 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcen

244

182

245 logElab 5 $ show fc ++ ":Constructor " ++ show n ++ " elaborated : " ++ show t

183 logElab 5 $ show fc ++ ":Constructor " ++ show n ++ " elaborated : " ++ show t

246 logElab 5 $ "Inaccessible args: " ++ show inacc

184 logElab 5 $ "Inaccessible args: " ++ show inacc

247− logElab 2 $ "---> " ++ show n ++ " : " ++ show cty'

185+ logElab 2 $ "---> " ++ show n ++ " : " ++ show cty

248

186

249 -- Add to the context (this is temporary, so that later constructors

187 -- Add to the context (this is temporary, so that later constructors

250 -- can be indexed by it)

188 -- can be indexed by it)

@@ -259,9 +197,14 @@ elabCon info syn tn codata expkind dkind (doc, argDocs, n, nfc, t_in, fc, forcen

259 addIBC (IBCDoc n)

197 addIBC (IBCDoc n)

260 fputState (opt_inaccessible . ist_optimisation n) inacc

198 fputState (opt_inaccessible . ist_optimisation n) inacc

261 addIBC (IBCOpt n)

199 addIBC (IBCOpt n)

262− return (n, cty')

200+ return (n, cty)

263 where

201 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 ()

265 tyIs con t | (P _ n' _, _) <- unApply t

208 tyIs con t | (P _ n' _, _) <- unApply t

266 = if n' /= tn then tclift $ tfail (At fc (Elaborating "constructor " con Nothing (Msg (show n' ++ " is not " ++ show tn))))

209 = if n' /= tn then tclift $ tfail (At fc (Elaborating "constructor " con Nothing (Msg (show n' ++ " is not " ++ show tn))))

267 else return ()

210 else return ()

@@ -350,7 +293,7 @@ elabCaseFun ind paramPos n ty cons info = do

350 (ierror . Elaborating "type declaration of " elimDeclName Nothing)

293 (ierror . Elaborating "type declaration of " elimDeclName Nothing)

351 -- Do not elaborate clauses if there aren't any

294 -- Do not elaborate clauses if there aren't any

352 case eliminatorClauses of

295 case eliminatorClauses of

353− [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type

296+ [] -> State.lift $ solveDeferred emptyFC elimDeclName -- Remove meta-variable for type

354 _ -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef)

297 _ -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef)

355 (ierror . Elaborating "clauses of " elimDeclName Nothing)

298 (ierror . Elaborating "clauses of " elimDeclName Nothing)

356 where elimLog :: String -> EliminatorState ()

299 where elimLog :: String -> EliminatorState ()

src/Idris/Elab/Instance.hs+23−14

@@ -55,28 +55,35 @@ elabInstance :: ElabInfo -> SyntaxInfo ->

55 [(Name, Docstring (Either Err PTerm))] ->

56 ElabWhat -> -- phase

57 FC -> [(Name, PTerm)] -> -- constraints

58+ Accessibility ->

59+ FnOpts ->

58 Name -> -- the class

60 Name -> -- the class

59 FC -> -- precise location of class name

61 FC -> -- precise location of class name

60 [PTerm] -> -- class parameters (i.e. instance)

62 [PTerm] -> -- class parameters (i.e. instance)

61 PTerm -> -- full instance type

63 PTerm -> -- full instance type

62 Maybe Name -> -- explicit name

64 Maybe Name -> -- explicit name

63 [PDecl] -> Idris ()

65 [PDecl] -> Idris ()

64−elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

66+elabInstance info syn doc argDocs what fc cs acc opts n nfc ps t expn ds = do

65− i <- getIState

67+ ist <- getIState

66− (n, ci) <- case lookupCtxtName n (idris_classes i) of

68+ (n, ci) <- case lookupCtxtName n (idris_classes ist) of

67 [c] -> return c

69 [c] -> return c

68 [] -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

70 [] -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

69 cs -> tclift $ tfail $ At fc

71 cs -> tclift $ tfail $ At fc

70 (CantResolveAlts (map fst cs))

72 (CantResolveAlts (map fst cs))

71 let constraint = PApp fc (PRef fc [] n) (map pexp ps)

73 let constraint = PApp fc (PRef fc [] n) (map pexp ps)

72 let iname = mkiname n (namespace info) ps expn

74 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+

73 let emptyclass = null (class_methods ci)

80 let emptyclass = null (class_methods ci)

74 when (what /= EDefns) $ do

81 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

76 -- if the instance type matches any of the instances we have already,

83 -- if the instance type matches any of the instances we have already,

77 -- and it's not a named instance, then it's overlapping, so report an error

84 -- and it's not a named instance, then it's overlapping, so report an error

78 case expn of

85 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))

80 (map fst $ class_instances ci)

87 (map fst $ class_instances ci)

81 addInstance intInst True n iname

88 addInstance intInst True n iname

82 Just _ -> addInstance intInst False n iname

89 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

95 let pnames = nub $ map pname (concat (nub wparams)) ++

102 let pnames = nub $ map pname (concat (nub wparams)) ++

96 concatMap (namesIn [] ist) ps

103 concatMap (namesIn [] ist) ps

97 let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci)

104 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

99 mapM_ (rec_elabDecl info EAll info) undefinedSuperclassInstances

106 mapM_ (rec_elabDecl info EAll info) undefinedSuperclassInstances

100 let all_meths = map (nsroot . fst) (class_methods ci)

107 let all_meths = map (nsroot . fst) (class_methods ci)

101 let mtys = map (\ (n, (op, t)) ->

108 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

108 (class_methods ci)

115 (class_methods ci)

109 logElab 3 (show (mtys, ips))

116 logElab 3 (show (mtys, ips))

110 logElab 5 ("Before defaults: " ++ show ds ++ "\n" ++ show (map fst (class_methods ci)))

117 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

112 logElab 3 ("After defaults: " ++ show ds_defs ++ "\n")

119 logElab 3 ("After defaults: " ++ show ds_defs ++ "\n")

113 let ds' = reorderDefs (map fst (class_methods ci)) $ ds_defs

120 let ds' = reorderDefs (map fst (class_methods ci)) $ ds_defs

114 logElab 1 ("Reordered: " ++ show ds' ++ "\n")

121 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

134 let rhs = PApp fc (PRef fc [] (instanceCtorName ci))

141 let rhs = PApp fc (PRef fc [] (instanceCtorName ci))

135 (map (pexp . mkMethApp) mtys)

142 (map (pexp . mkMethApp) mtys)

136

143

137− logElab 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars

144+ logElab 5 $ "Instance LHS " ++ show totopts ++ "\n" ++ show lhs ++ " " ++ show headVars

138 logElab 5 $ "Instance RHS " ++ show rhs

145 logElab 5 $ "Instance RHS " ++ show rhs

139

146

140− let idecls = [PClauses fc [Dictionary] iname

147+ let idecls = [PClauses fc totopts iname

141 [PClause fc iname lhs [] rhs wb]]

148 [PClause fc iname lhs [] rhs wb]]

142 logElab 1 (show idecls)

149 logElab 1 (show idecls)

143 push_estack iname True

150 push_estack iname True

@@ -159,10 +166,10 @@ elabInstance info syn doc argDocs what fc cs n nfc ps t expn ds = do

159 Just m -> sNS (SN (sInstanceN n' (map show ps'))) m

166 Just m -> sNS (SN (sInstanceN n' (map show ps'))) m

160 Just nm -> nm

167 Just nm -> nm

161

168

162− substInstance ips pnames (PInstance doc argDocs syn _ cs n nfc ps t expn ds)

169+ substInstance ips pnames (PInstance doc argDocs syn _ cs acc opts 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

170+ = PInstance doc argDocs syn fc cs acc opts n nfc (map (substMatchesShadow ips pnames) ps) (substMatchesShadow ips pnames t) expn ds

164

171

165− isOverlapping i (PInstance doc argDocs syn _ _ n nfc ps t expn _)

172+ isOverlapping i (PInstance doc argDocs syn _ _ _ _ n nfc ps t expn _)

166 = case lookupCtxtName n (idris_classes i) of

173 = case lookupCtxtName n (idris_classes i) of

167 [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in

174 [(n, ci)] -> let iname = (mkiname n (namespace info) ps expn) in

168 case lookupTy iname (tt_ctxt i) of

175 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

179 ty' <- implicit info syn iname ty'

186 ty' <- implicit info syn iname ty'

180 let ty = addImpl [] i ty'

187 let ty = addImpl [] i ty'

181 ctxt <- getContext

188 ctxt <- getContext

182− (ElabResult tyT _ _ ctxt' newDecls highlights, _) <-

189+ (ElabResult tyT _ _ ctxt' newDecls highlights newGName, _) <-

183− tclift $ elaborate ctxt (idris_datatypes i) iname (TType (UVal 0)) initEState

190+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) iname (TType (UVal 0)) initEState

184 (errAt "type of " iname Nothing (erun fc (build i info ERHS [] iname ty)))

191 (errAt "type of " iname Nothing (erun fc (build i info ERHS [] iname ty)))

185 setContext ctxt'

192 setContext ctxt'

186 processTacticDecls info newDecls

193 processTacticDecls info newDecls

187 sendHighlighting highlights

194 sendHighlighting highlights

195+ updateIState $ \i -> i { idris_name = newGName }

196+

188 ctxt <- getContext

197 ctxt <- getContext

189 (cty, _) <- recheckC fc id [] tyT

198 (cty, _) <- recheckC fc id [] tyT

190 let nty = normalise ctxt [] cty

199 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

2

3import Idris.Core.Elaborate hiding (Tactic(..))

4import Idris.Core.TT

@@ -171,5 +171,3 @@ extractUnquotes n (PRunElab fc tm ns)

171extractUnquotes n (PConstSugar fc tm)

172 = extractUnquotes n tm

173extractUnquotes n x = return (x, []) -- no subterms!

174−

175−

src/Idris/Elab/Record.hs+1−1

@@ -17,7 +17,7 @@ import Idris.DeepSeq

17import Idris.Output (iputStrLn, pshow, iWarn, sendHighlighting)

18import IRTS.Lang

19

20−import Idris.ParseExpr (tryFullExpr)

20+import Idris.Parser.Expr (tryFullExpr)

21

22import Idris.Elab.Type

23import Idris.Elab.Data

src/Idris/Elab/RunElab.hs+5−3

@@ -32,18 +32,20 @@ elabRunElab info fc script' ns =

32 mustBeElabScript scriptTy

33 ist <- getIState

34 ctxt <- getContext

35− (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-

35+ (ElabResult tyT' defer is ctxt' newDecls highlights newGName, log) <-

36− tclift $ elaborate ctxt (idris_datatypes ist) (sMN 0 "toplLevelElab") elabScriptTy initEState

36+ tclift $ elaborate ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "toplLevelElab") elabScriptTy initEState

37 (transformErr RunningElabScript

38 (erun fc (do tm <- runElabAction ist fc [] script ns

39 EState is _ impls highlights <- getAux

40 ctxt <- get_context

41 let ds = [] -- todo

42 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))))

44

45

46

47

47 setContext ctxt'

48 setContext ctxt'

48 processTacticDecls info newDecls

49 processTacticDecls info newDecls

49 sendHighlighting highlights

50 sendHighlighting highlights

51+ updateIState $ \i -> i { idris_name = newGName }

src/Idris/Elab/Term.hs+181−39

@@ -18,9 +18,9 @@ import Idris.Core.Unify

18import Idris.Core.ProofTerm (getProofTerm)

19import Idris.Core.Typecheck (check, recheck, converts, isType)

20import Idris.Core.WHNF (whnf)

21−import Idris.Coverage (buildSCG, checkDeclTotality, genClauses, recoverableCoverage, validCoverageCase)

21+import Idris.Coverage (buildSCG, checkDeclTotality, checkPositive, genClauses, recoverableCoverage, validCoverageCase)

22import Idris.ErrReverse (errReverse)

23−import Idris.ElabQuasiquote (extractUnquotes)

23+import Idris.Elab.Quasiquote (extractUnquotes)

24import Idris.Elab.Utils

25import Idris.Reflection

26import qualified Util.Pretty as U

@@ -52,6 +52,9 @@ data ElabResult =

52 , resultTyDecls :: [RDeclInstructions]

53 -- ^ Meta-info about the new type declarations

54 , resultHighlighting :: [(FC, OutputAnnotation)]

55+ -- ^ Saved highlights from elaboration

56+ , resultName :: Int

57+ -- ^ The new global name counter

55 }

58 }

56

59

57

60

@@ -122,9 +125,10 @@ build ist info emode opts fn tm

122 ctxt <- get_context

125 ctxt <- get_context

123 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

126 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

124 log <- getLog

127 log <- getLog

128+ g_nextname <- get_global_nextname

125 if log /= ""

129 if log /= ""

126− then trace log $ 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)

127− else return (ElabResult tm ds (map snd is) ctxt impls highlights)

131+ else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)

128 where pattern = emode == ELHS

132 where pattern = emode == ELHS

129 tydecl = emode == ETyDecl

133 tydecl = emode == ETyDecl

130

134

@@ -166,9 +170,10 @@ buildTC ist info emode opts fn ns tm

166 ctxt <- get_context

170 ctxt <- get_context

167 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

171 let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []

168 log <- getLog

172 log <- getLog

173+ g_nextname <- get_global_nextname

169 if (log /= "")

174 if (log /= "")

170− then trace log $ 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)

171− else return (ElabResult tm ds (map snd is) ctxt impls highlights)

176+ else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)

172 where pattern = emode == ELHS

177 where pattern = emode == ELHS

173

178

174-- return whether arguments of the given constructor name can be

179-- return whether arguments of the given constructor name can be

@@ -236,6 +241,7 @@ elab ist info emode opts fn tm

236 pattern = emode == ELHS

241 pattern = emode == ELHS

237 intransform = emode == ETransLHS

242 intransform = emode == ETransLHS

238 bindfree = emode == ETyDecl || emode == ELHS || emode == ETransLHS

243 bindfree = emode == ETyDecl || emode == ELHS || emode == ETransLHS

244+ autoimpls = opt_autoimpls (idris_options ist)

239

245

240 get_delayed_elab est =

246 get_delayed_elab est =

241 let ds = delayed_elab est in

247 let ds = delayed_elab est in

@@ -614,7 +620,8 @@ elab ist info emode opts fn tm

614 [] -> False

620 [] -> False

615 _ -> True

621 _ -> True

616 bindable (NS _ _) = False

622 bindable (NS _ _) = False

617− bindable n = implicitable n

623+ bindable (MN _ _) = True

624+ bindable n = implicitable n && autoimpls

618 elab' ina _ f@(PInferRef fc hls n) = elab' ina (Just fc) (PApp NoFC f [])

625 elab' ina _ f@(PInferRef fc hls n) = elab' ina (Just fc) (PApp NoFC f [])

619 elab' ina fc' tm@(PRef fc hls n)

626 elab' ina fc' tm@(PRef fc hls n)

620 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

627 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

@@ -1156,9 +1163,10 @@ elab ist info emode opts fn tm

1156 -- capturing lexically available variables in the quoted term.

1163 -- capturing lexically available variables in the quoted term.

1157 ctxt <- get_context

1164 ctxt <- get_context

1158 datatypes <- get_datatypes

1165 datatypes <- get_datatypes

1166+ g_nextname <- get_global_nextname

1159 saveState

1167 saveState

1160 updatePS (const .

1168 updatePS (const .

1161− newProof (sMN 0 "q") ctxt datatypes $

1169+ newProof (sMN 0 "q") ctxt datatypes g_nextname $

1162 P Ref (reflm "TT") Erased)

1170 P Ref (reflm "TT") Erased)

1163

1171

1164 -- Re-add the unquotes, letting Idris infer the (fictional)

1172 -- Re-add the unquotes, letting Idris infer the (fictional)

@@ -1702,8 +1710,8 @@ solveAutos ist fn ambigok

1702-- Return true if the given error suggests a type class failure is

1710-- Return true if the given error suggests a type class failure is

1703-- recoverable

1711-- recoverable

1704tcRecoverable :: ElabMode -> Err -> Bool

1712tcRecoverable :: ElabMode -> Err -> Bool

1705−tcRecoverable ERHS (CantResolve f g) = f

1713+tcRecoverable ERHS (CantResolve f g _) = f

1706−tcRecoverable ETyDecl (CantResolve f g) = f

1714+tcRecoverable ETyDecl (CantResolve f g _) = f

1707tcRecoverable e (ElaboratingArg _ _ _ err) = tcRecoverable e err

1715tcRecoverable e (ElaboratingArg _ _ _ err) = tcRecoverable e err

1708tcRecoverable e (At _ err) = tcRecoverable e err

1716tcRecoverable e (At _ err) = tcRecoverable e err

1709tcRecoverable _ _ = True

1717tcRecoverable _ _ = True

@@ -1837,11 +1845,74 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

1837 updateAux $ \e -> e { new_tyDecls = RClausesInstrs n clauses'' : new_tyDecls e}

1845 updateAux $ \e -> e { new_tyDecls = RClausesInstrs n clauses'' : new_tyDecls e}

1838 return ()

1846 return ()

1839

1847

1848+

1840 checkClosed :: Raw -> Elab' aux (Term, Type)

1849 checkClosed :: Raw -> Elab' aux (Term, Type)

1841 checkClosed tm = do ctxt <- get_context

1850 checkClosed tm = do ctxt <- get_context

1842 (val, ty) <- lift $ check ctxt [] tm

1851 (val, ty) <- lift $ check ctxt [] tm

1843 return $! (finalise val, finalise ty)

1852 return $! (finalise val, finalise ty)

1844

1853

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+

1845 -- | Do a step in the reflected elaborator monad. The input is the

1916 -- | Do a step in the reflected elaborator monad. The input is the

1846 -- step, the output is the (reflected) term returned.

1917 -- step, the output is the (reflected) term returned.

1847 runTacTm :: Term -> ElabD Term

1918 runTacTm :: Term -> ElabD Term

@@ -2050,20 +2121,10 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

2050 | n == tacN "Prim__DeclareType", [decl] <- args

2121 | n == tacN "Prim__DeclareType", [decl] <- args

2051 = do (RDeclare n args res) <- reifyTyDecl decl

2122 = do (RDeclare n args res) <- reifyTyDecl decl

2052 ctxt <- get_context

2123 ctxt <- get_context

2053− let mkPi arg res = RBind (argName arg)

2124+ let rty = foldr mkPi res args

2054− (Pi Nothing (argTy arg) (RUType AllTypes))

2055− res

2056− rty = foldr mkPi res args

2057 (checked, ty') <- lift $ check ctxt [] rty

2125 (checked, ty') <- lift $ check ctxt [] rty

2058− case normaliseAll ctxt [] (finalise ty') of

2126+ mustBeType ctxt checked ty'

2059− UType _ -> return ()

2127+ mustNotBeDefined ctxt n

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 ()

2067 let decl = TyDecl Ref checked

2128 let decl = TyDecl Ref checked

2068 ctxt' = addCtxtDef n decl ctxt

2129 ctxt' = addCtxtDef n decl ctxt

2069 set_context ctxt'

2130 set_context ctxt'

@@ -2074,11 +2135,46 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

2074 = do defn <- reifyFunDefn decl

2135 = do defn <- reifyFunDefn decl

2075 defineFunction defn

2136 defineFunction defn

2076 returnUnit

2137 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

2077 | n == tacN "Prim__AddInstance", [cls, inst] <- args

2173 | n == tacN "Prim__AddInstance", [cls, inst] <- args

2078 = do className <- reifyTTName cls

2174 = do className <- reifyTTName cls

2079 instName <- reifyTTName inst

2175 instName <- reifyTTName inst

2080 updateAux $ \e -> e { new_tyDecls = RAddInstance className instName :

2176 updateAux $ \e -> e { new_tyDecls = RAddInstance className instName :

2081− new_tyDecls e}

2177+ new_tyDecls e }

2082 returnUnit

2178 returnUnit

2083 | n == tacN "Prim__IsTCName", [n] <- args

2179 | n == tacN "Prim__IsTCName", [n] <- args

2084 = do n' <- reifyTTName n

2180 = do n' <- reifyTTName n

@@ -2113,6 +2209,7 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

2113 aux <- getAux

2209 aux <- getAux

2114 datatypes <- get_datatypes

2210 datatypes <- get_datatypes

2115 env <- get_env

2211 env <- get_env

2212+ g_next <- get_global_nextname

2116

2213

2117 (ctxt', ES (p, aux') _ _) <-

2214 (ctxt', ES (p, aux') _ _) <-

2118 do (ES (current_p, _) _ _) <- get

2215 do (ES (current_p, _) _ _) <- get

@@ -2120,13 +2217,15 @@ runElabAction ist fc env tm ns = do tm' <- eval tm

2120 (do runElabAction ist fc [] script ns

2217 (do runElabAction ist fc [] script ns

2121 ctxt' <- get_context

2218 ctxt' <- get_context

2122 return ctxt')

2219 return ctxt')

2123− ((newProof recH ctxt datatypes goalTT)

2220+ ((newProof recH ctxt datatypes g_next goalTT)

2124 { nextname = nextname current_p })

2221 { nextname = nextname current_p })

2125 set_context ctxt'

2222 set_context ctxt'

2126

2223

2127 let tm_out = getProofTerm (pterm p)

2224 let tm_out = getProofTerm (pterm p)

2128 do (ES (prf, _) s e) <- get

2225 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+ }

2130 put (ES (p', aux') s e)

2229 put (ES (p', aux') s e)

2131 env' <- get_env

2230 env' <- get_env

2132 (tm, ty, _) <- lift $ recheck ctxt' env (forget tm_out) tm_out

2231 (tm, ty, _) <- lift $ recheck ctxt' env (forget tm_out) tm_out

@@ -2476,8 +2575,10 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

2476 OK hs -> return hs

2575 OK hs -> return hs

2477

2576

2478 -- Normalize error handler terms to produce the new messages

2577 -- 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

2479 ctxt <- getContext

2580 ctxt <- getContext

2480− let results = map (normalise ctxt []) (map fst handlers)

2581+ let results = map (normaliseAll ctxt []) (map fst handlers)

2481 logElab 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

2582 logElab 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

2482

2583

2483 -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

2584 -- 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 =

2504 updateIState $ \i -> i { idris_implicits =

2605 updateIState $ \i -> i { idris_implicits =

2505 addDef n impls (idris_implicits i) }

2606 addDef n impls (idris_implicits i) }

2506 addIBC (IBCImp n)

2607 addIBC (IBCImp n)

2507− ds <- checkDef fc (\_ e -> e) [(n, (-1, Nothing, ty, []))]

2608+ ds <- checkDef fc (\_ e -> e) True [(n, (-1, Nothing, ty, []))]

2508 addIBC (IBCDef n)

2609 addIBC (IBCDef n)

2509 ctxt <- getContext

2610 ctxt <- getContext

2510 case lookupDef n ctxt of

2611 case lookupDef n ctxt of

@@ -2513,9 +2614,53 @@ processTacticDecls info steps =

2513 -- then it must be added as a metavariable. This needs guarding

2614 -- then it must be added as a metavariable. This needs guarding

2514 -- to prevent overwriting case defs with a metavar, if the case

2615 -- to prevent overwriting case defs with a metavar, if the case

2515 -- defs come after the type decl in the same script!

2616 -- 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

2517 in addDeferred ds'

2618 in addDeferred ds'

2518 _ -> return ()

2619 _ -> 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+

2519 RAddInstance className instName ->

2664 RAddInstance className instName ->

2520 do -- The type class resolution machinery relies on a special

2665 do -- The type class resolution machinery relies on a special

2521 logElab 2 $ "Adding elab script instance " ++ show instName ++

2666 logElab 2 $ "Adding elab script instance " ++ show instName ++

@@ -2524,7 +2669,7 @@ processTacticDecls info steps =

2524 addIBC (IBCInstance False True className instName)

2669 addIBC (IBCInstance False True className instName)

2525 RClausesInstrs n cs ->

2670 RClausesInstrs n cs ->

2526 do logElab 3 $ "Pattern-matching definition from tactics: " ++ show n

2671 do logElab 3 $ "Pattern-matching definition from tactics: " ++ show n

2527− solveDeferred n

2672+ solveDeferred emptyFC n

2528 let lhss = map (\(_, lhs, _) -> lhs) cs

2673 let lhss = map (\(_, lhs, _) -> lhs) cs

2529 let fc = fileFC "elab_reflected"

2674 let fc = fileFC "elab_reflected"

2530 pmissing <-

2675 pmissing <-

@@ -2549,13 +2694,9 @@ processTacticDecls info steps =

2549 -- we refer to, so that if they aren't total, the whole

2694 -- we refer to, so that if they aren't total, the whole

2550 -- thing won't be.

2695 -- thing won't be.

2551 let (scargs, sc) = cases_compiletime cd

2696 let (scargs, sc) = cases_compiletime cd

2552− (scargs', sc') = cases_runtime cd

2697+ calls = map fst $ findCalls sc scargs

2553− calls = findCalls sc' scargs

2698+ in do logElab 2 $ "Called names in reflected elab: " ++ show calls

2554− used = findUsedArgs sc' scargs'

2699+ addCalls n calls

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))

2559 addIBC $ IBCCG n

2700 addIBC $ IBCCG n

2560 Just _ -> return () -- TODO throw internal error

2701 Just _ -> return () -- TODO throw internal error

2561 Nothing -> return ()

2702 Nothing -> return ()

@@ -2581,13 +2722,14 @@ processTacticDecls info steps =

2581 let lhs = addImplPat ist lhs_in

2722 let lhs = addImplPat ist lhs_in

2582 let fc = fileFC "elab_reflected_totality"

2723 let fc = fileFC "elab_reflected_totality"

2583 let tcgen = False -- TODO: later we may support dictionary generation

2724 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

2585 (erun fc (buildTC ist info ELHS [] fname (allNamesIn lhs_in)

2726 (erun fc (buildTC ist info ELHS [] fname (allNamesIn lhs_in)

2586 (infTerm lhs))) of

2727 (infTerm lhs))) of

2587− OK (ElabResult lhs' _ _ _ _ _, _) ->

2728+ OK (ElabResult lhs' _ _ _ _ _ name', _) ->

2588 do -- not recursively calling here, because we don't

2729 do -- not recursively calling here, because we don't

2589 -- want to run infinitely many times

2730 -- want to run infinitely many times

2590 let lhs_tm = orderPats (getInferTerm lhs')

2731 let lhs_tm = orderPats (getInferTerm lhs')

2732+ updateIState $ \i -> i { idris_name = name' }

2591 case recheck ctxt [] (forget lhs_tm) lhs_tm of

2733 case recheck ctxt [] (forget lhs_tm) lhs_tm of

2592 OK _ -> return True

2734 OK _ -> return True

2593 err -> return False

2735 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

54 i <- getIState

55 let lhs = addImplPat i lhs_in

56 logElab 5 ("Transform LHS input: " ++ showTmImpls lhs)

57− (ElabResult lhs' dlhs [] ctxt' newDecls highlights, _) <-

57+ (ElabResult lhs' dlhs [] ctxt' newDecls highlights newGName, _) <-

58− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transLHS") infP initEState

58+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "transLHS") infP initEState

59 (erun fc (buildTC i info ETransLHS [] (sUN "transform")

60 (allNamesIn lhs_in) (infTerm lhs)))

61 setContext ctxt'

62 processTacticDecls info newDecls

63 sendHighlighting highlights

64+ updateIState $ \i -> i { idris_name = newGName }

64 let lhs_tm = orderPats (getInferTerm lhs')

65 let lhs_tm = orderPats (getInferTerm lhs')

65 let lhs_ty = getInferType lhs'

66 let lhs_ty = getInferType lhs'

66 let newargs = pvars i lhs_tm

67 let newargs = pvars i lhs_tm

@@ -73,18 +74,21 @@ elabTransform info fc safe lhs_in@(PApp _ (PRef _ _ tf) _) rhs_in

73 let rhs = addImplBound i (map fst newargs) rhs_in

74 let rhs = addImplBound i (map fst newargs) rhs_in

74 logElab 5 ("Transform RHS input: " ++ showTmImpls rhs)

75 logElab 5 ("Transform RHS input: " ++ showTmImpls rhs)

75

76

76− ((rhs', defer, ctxt', newDecls), _) <-

77+ ((rhs', defer, ctxt', newDecls, newGName), _) <-

77− tclift $ elaborate ctxt (idris_datatypes i) (sMN 0 "transRHS") clhs_ty initEState

78+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "transRHS") clhs_ty initEState

78 (do pbinds i lhs_tm

79 (do pbinds i lhs_tm

79 setNextName

80 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

81 erun fc $ psolve lhs_tm

83 erun fc $ psolve lhs_tm

82 tt <- get_term

84 tt <- get_term

83 let (rhs', defer) = runState (collectDeferred Nothing [] ctxt tt) []

85 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))

85 setContext ctxt'

88 setContext ctxt'

86 processTacticDecls info newDecls

89 processTacticDecls info newDecls

87 sendHighlighting highlights

90 sendHighlighting highlights

91+ updateIState $ \i -> i { idris_name = newGName }

88

92

89 (crhs_tm_in, crhs_ty) <- recheckC_borrowing False False [] fc id [] rhs'

93 (crhs_tm_in, crhs_ty) <- recheckC_borrowing False False [] fc id [] rhs'

90 let crhs_tm = renamepats pnames crhs_tm_in

94 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

67 logElab 5 $ show "with methods " ++ show (imp_methods syn)

68 logElab 2 $ show n ++ " type " ++ show (using syn) ++ "\n" ++ showTmImpls ty

69

70− (ElabResult tyT' defer is ctxt' newDecls highlights, log) <-

70+ (ElabResult tyT' defer is ctxt' newDecls highlights newGName, log) <-

71− tclift $ elaborate ctxt (idris_datatypes i) n (TType (UVal 0)) initEState

71+ tclift $ elaborate ctxt (idris_datatypes i) (idris_name i) n (TType (UVal 0)) initEState

72 (errAt "type of " n Nothing (erun fc (build i info ETyDecl [] n ty)))

73 setContext ctxt'

74 processTacticDecls info newDecls

75− sendHighlighting highlights

75+ sendHighlighting highlights

76+ updateIState $ \i -> i { idris_name = newGName }

76

77

77 let tyT = patToImp tyT'

78 let tyT = patToImp tyT'

78

79

79 logElab 3 $ show ty ++ "\nElaborated: " ++ show tyT'

80 logElab 3 $ show ty ++ "\nElaborated: " ++ show tyT'

80

81

81− ds <- checkAddDef True False fc iderr defer

82+ ds <- checkAddDef True False fc iderr True defer

82 -- if the type is not complete, note that we'll need to infer

83 -- if the type is not complete, note that we'll need to infer

83 -- things later (for solving metavariables)

84 -- things later (for solving metavariables)

84 when (length ds > length is) -- more deferred than case blocks

85 when (length ds > length is) -- more deferred than case blocks

@@ -102,6 +103,18 @@ buildType info syn fc opts n ty' = do

102 logElab 3 ("Implicit " ++ show n ++ " " ++ show impls)

103 logElab 3 ("Implicit " ++ show n ++ " " ++ show impls)

103 addIBC (IBCImp n)

104 addIBC (IBCImp n)

104

105

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+

105 when (Constructor `notElem` opts) $ do

118 when (Constructor `notElem` opts) $ do

106 let pnames = getParamsInType i [] impls cty

119 let pnames = getParamsInType i [] impls cty

107 let fninfo = FnInfo (param_pos 0 pnames cty)

120 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

161 -- Productivity checking now via checking for guarded 'Delay'

174 -- Productivity checking now via checking for guarded 'Delay'

162 let opts' = opts -- if corec then (Coinductive : opts) else opts

175 let opts' = opts -- if corec then (Coinductive : opts) else opts

163 let usety = if norm then nty' else nty

176 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, []))]

165 addIBC (IBCDef n)

178 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

167 addDeferred ds'

181 addDeferred ds'

168 setFlags n opts'

182 setFlags n opts'

169 checkDocs fc argDocs ty

183 checkDocs fc argDocs ty

@@ -242,7 +256,7 @@ elabPostulate info syn doc fc nfc opts n ty = do

242 sendHighlighting [(nfc, AnnName n (Just PostulateOutput) Nothing Nothing)]

256 sendHighlighting [(nfc, AnnName n (Just PostulateOutput) Nothing Nothing)]

243

257

244 -- remove it from the deferred definitions list

258 -- remove it from the deferred definitions list

245− solveDeferred n

259+ solveDeferred fc n

246

260

247elabExtern :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

261elabExtern :: ElabInfo -> SyntaxInfo -> Docstring (Either Err PTerm) ->

248 FC -> FC -> FnOpts -> Name -> PTerm -> Idris ()

262 FC -> FC -> FnOpts -> Name -> PTerm -> Idris ()

@@ -255,4 +269,4 @@ elabExtern info syn doc fc nfc opts n ty = do

255 addIBC (IBCExtern (n, arity))

269 addIBC (IBCExtern (n, arity))

256

270

257 -- remove it from the deferred definitions list

271 -- 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

56iderr :: Name -> Err -> Err

57iderr _ e = e

58

59−checkDef :: FC -> (Name -> Err -> Err) -> [(Name, (Int, Maybe Name, Type, [Name]))]

59+checkDef :: FC -> (Name -> Err -> Err) -> Bool ->

60− -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]

60+ [(Name, (Int, Maybe Name, Type, [Name]))] ->

61−checkDef fc mkerr ns = checkAddDef False True fc mkerr ns

61+ Idris [(Name, (Int, Maybe Name, Type, [Name]))]

62+checkDef fc mkerr definable ns

63+ = checkAddDef False True fc mkerr definable ns

62

64

63−checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err)

65+checkAddDef :: Bool -> Bool -> FC -> (Name -> Err -> Err) -> Bool

64 -> [(Name, (Int, Maybe Name, Type, [Name]))]

66 -> [(Name, (Int, Maybe Name, Type, [Name]))]

65 -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]

67 -> Idris [(Name, (Int, Maybe Name, Type, [Name]))]

66−checkAddDef add toplvl fc mkerr [] = return []

68+checkAddDef add toplvl fc mkerr def [] = return []

67−checkAddDef add toplvl fc mkerr ((n, (i, top, t, psns)) : ns)

69+checkAddDef add toplvl fc mkerr definable ((n, (i, top, t, psns)) : ns)

68 = do ctxt <- getContext

70 = do ctxt <- getContext

69− logElab 5 $ "Rechecking deferred name " ++ show (n, t)

71+ logElab 5 $ "Rechecking deferred name " ++ show (n, t, definable)

70 (t', _) <- recheckC fc (mkerr n) [] t

72 (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))]

72 addIBC (IBCDef n)

74 addIBC (IBCDef n)

73− ns' <- checkAddDef add toplvl fc mkerr ns

75+ ns' <- checkAddDef add toplvl fc mkerr definable ns

74 return ((n, (i, top, t', psns)) : ns')

76 return ((n, (i, top, t', psns)) : ns')

75

77

76-- | Get the list of (index, name) of inaccessible arguments from an elaborated

78-- | Get the list of (index, name) of inaccessible arguments from an elaborated

@@ -314,3 +316,82 @@ mkStaticTy ns (PPi p n fc ty sc)

314 | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)

316 | n `elem` ns = PPi (p { pstatic = Static }) n fc ty (mkStaticTy ns sc)

315 | otherwise = PPi p n fc ty (mkStaticTy ns sc)

317 | otherwise = PPi p n fc ty (mkStaticTy ns sc)

316mkStaticTy ns t = t

318mkStaticTy 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

64 -- * elaboration as a Type

65 -- * elaboration as a function a -> b

66

67− (ElabResult tm' defer is ctxt' newDecls highlights, _) <-

67+ (ElabResult tm' defer is ctxt' newDecls highlights newGName, _) <-

68− tclift (elaborate ctxt (idris_datatypes i) (sMN 0 "val") infP initEState

68+ tclift (elaborate ctxt (idris_datatypes i) (idris_name i) (sMN 0 "val") infP initEState

69 (build i info aspat [Reflection] (sMN 0 "val") (infTerm tm)))

70

71 -- Extend the context with new definitions created

72 setContext ctxt'

73 processTacticDecls info newDecls

74 sendHighlighting highlights

75+ updateIState $ \i -> i { idris_name = newGName }

75

76

76 let vtm = orderPats (getInferTerm tm')

77 let vtm = orderPats (getInferTerm tm')

77

78

78− def' <- checkDef (fileFC "(input)") iderr defer

79+ def' <- checkDef (fileFC "(input)") iderr True defer

79− let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True))) def'

80+ let def'' = map (\(n, (i, top, t, ns)) -> (n, (i, top, t, ns, True, True))) def'

80 addDeferred def''

81 addDeferred def''

81 mapM_ (elabCaseBlock info []) is

82 mapM_ (elabCaseBlock info []) is

82

83

src/Idris/ElabDecls.hs+2−2

@@ -242,9 +242,9 @@ elabDecl' what info (PClass doc s f cs n nfc ps pdocs fds ds cn cd)

242 | what /= EDefns

243 = do logElab 1 $ "Elaborating class " ++ show n

244 elabClass info (s { syn_params = [] }) doc f cs n nfc ps pdocs fds ds cn cd

245−elabDecl' what info (PInstance doc argDocs s f cs n nfc ps t expn ds)

245+elabDecl' what info (PInstance doc argDocs s f cs acc fnopts n nfc ps t expn ds)

246 = do logElab 1 $ "Elaborating instance " ++ show n

247− elabInstance info s doc argDocs what f cs n nfc ps t expn ds

247+ elabInstance info s doc argDocs what f cs acc fnopts n nfc ps t expn ds

248elabDecl' what info (PRecord doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn)

249 = do logElab 1 $ "Elaborating record " ++ show name

250 elabRecord info what doc rsyn fc opts name nfc ps pdocs fs cname cdoc csyn

src/Idris/IBC.hs+98−67

@@ -3,7 +3,7 @@

3

4module Idris.IBC (loadIBC, loadPkgIndex,

5 writeIBC, writePkgIndex,

6− hasValidIBCVersion) where

6+ hasValidIBCVersion, IBCPhase(..)) where

7

8import Idris.Core.Evaluate

9import Idris.Core.TT

@@ -40,10 +40,18 @@ import System.Directory

40import Codec.Archive.Zip

41

42ibcVersion :: Word16

43−ibcVersion = 128

43+ibcVersion = 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)

44

51

45data IBCFile = IBCFile { ver :: Word16,

52data IBCFile = IBCFile { ver :: Word16,

46 sourcefile :: FilePath,

53 sourcefile :: FilePath,

54+ ibc_reachablenames :: ![Name],

47 ibc_imports :: ![(Bool, FilePath)],

55 ibc_imports :: ![(Bool, FilePath)],

48 ibc_importdirs :: ![FilePath],

56 ibc_importdirs :: ![FilePath],

49 ibc_implicits :: ![(Name, [PArg])],

57 ibc_implicits :: ![(Name, [PArg])],

@@ -62,13 +70,10 @@ data IBCFile = IBCFile { ver :: Word16,

62 ibc_cgflags :: ![(Codegen, String)],

70 ibc_cgflags :: ![(Codegen, String)],

63 ibc_dynamic_libs :: ![String],

71 ibc_dynamic_libs :: ![String],

64 ibc_hdrs :: ![(Codegen, String)],

72 ibc_hdrs :: ![(Codegen, String)],

65− ibc_access :: ![(Name, Accessibility)],

66− ibc_total :: ![(Name, Totality)],

67 ibc_totcheckfail :: ![(FC, String)],

73 ibc_totcheckfail :: ![(FC, String)],

68 ibc_flags :: ![(Name, [FnOpt])],

74 ibc_flags :: ![(Name, [FnOpt])],

69 ibc_fninfo :: ![(Name, FnInfo)],

75 ibc_fninfo :: ![(Name, FnInfo)],

70 ibc_cg :: ![(Name, CGInfo)],

76 ibc_cg :: ![(Name, CGInfo)],

71− ibc_defs :: ![(Name, Def)],

72 ibc_docstrings :: ![(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))],

77 ibc_docstrings :: ![(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))],

73 ibc_moduledocs :: ![(Name, Docstring D.DocTerm)],

78 ibc_moduledocs :: ![(Name, Docstring D.DocTerm)],

74 ibc_transforms :: ![(Name, (Term, Term))],

79 ibc_transforms :: ![(Name, (Term, Term))],

@@ -79,7 +84,7 @@ data IBCFile = IBCFile { ver :: Word16,

79 ibc_metainformation :: ![(Name, MetaInformation)],

84 ibc_metainformation :: ![(Name, MetaInformation)],

80 ibc_errorhandlers :: ![Name],

85 ibc_errorhandlers :: ![Name],

81 ibc_function_errorhandlers :: ![(Name, Name, Name)], -- fn, arg, handler

86 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))],

83 ibc_patdefs :: ![(Name, ([([(Name, Term)], Term, Term)], [PTerm]))],

88 ibc_patdefs :: ![(Name, ([([(Name, Term)], Term, Term)], [PTerm]))],

84 ibc_postulates :: ![Name],

89 ibc_postulates :: ![Name],

85 ibc_externs :: ![(Name, Int)],

90 ibc_externs :: ![(Name, Int)],

@@ -87,7 +92,10 @@ data IBCFile = IBCFile { ver :: Word16,

87 ibc_usage :: ![(Name, Int)],

92 ibc_usage :: ![(Name, Int)],

88 ibc_exports :: ![Name],

93 ibc_exports :: ![Name],

89 ibc_autohints :: ![(Name, Name)],

94 ibc_autohints :: ![(Name, Name)],

90− ibc_deprecated :: ![(Name, String)]

95+ ibc_deprecated :: ![(Name, String)],

96+ ibc_defs :: ![(Name, Def)],

97+ ibc_total :: ![(Name, Totality)],

98+ ibc_access :: ![(Name, Accessibility)]

91 }

99 }

92 deriving Show

100 deriving Show

93{-!

101{-!

@@ -95,7 +103,7 @@ deriving instance Binary IBCFile

95!-}

103!-}

96

104

97initIBC :: IBCFile

105initIBC :: IBCFile

98−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] []

106+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] Nothing [] [] [] [] [] [] []

99

107

100hasValidIBCVersion :: FilePath -> Idris Bool

108hasValidIBCVersion :: FilePath -> Idris Bool

101hasValidIBCVersion fp = do

109hasValidIBCVersion fp = do

@@ -106,8 +114,9 @@ hasValidIBCVersion fp = do

106 return (ver == ibcVersion)

114 return (ver == ibcVersion)

107

115

108loadIBC :: Bool -- ^ True = reexport, False = make everything private

116loadIBC :: Bool -- ^ True = reexport, False = make everything private

117+ -> IBCPhase

109 -> FilePath -> Idris ()

118 -> FilePath -> Idris ()

110−loadIBC reexport fp

119+loadIBC reexport phase fp

111 = do imps <- getImported

120 = do imps <- getImported

112 let redo = case lookup fp imps of

121 let redo = case lookup fp imps of

113 Nothing -> True

122 Nothing -> True

@@ -118,15 +127,16 @@ loadIBC reexport fp

118 case toArchiveOrFail archiveFile of

127 case toArchiveOrFail archiveFile of

119 Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"

128 Left _ -> ifail $ fp ++ " isn't loadable, it may have an old ibc format.\n"

120 ++ "Please clean and rebuild it."

129 ++ "Please clean and rebuild it."

121− Right archive -> do process reexport archive fp

130+ Right archive -> do process reexport phase archive fp

122 addImported reexport fp

131 addImported reexport fp

132+-- dumpTT

123

133

124-- | Load an entire package from its index file

134-- | Load an entire package from its index file

125loadPkgIndex :: String -> Idris ()

135loadPkgIndex :: String -> Idris ()

126loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir

136loadPkgIndex pkg = do ddir <- runIO $ getIdrisLibDir

127 addImportDir (ddir </> pkg)

137 addImportDir (ddir </> pkg)

128 fp <- findPkgIndex pkg

138 fp <- findPkgIndex pkg

129− loadIBC True fp

139+ loadIBC True IBC_Building fp

130

140

131

141

132makeEntry :: (Binary b) => String -> [b] -> Maybe Entry

142makeEntry :: (Binary b) => String -> [b] -> Maybe Entry

@@ -156,13 +166,10 @@ entries i = catMaybes [Just $ toEntry "ver" 0 (encode $ ver i),

156 makeEntry "ibc_cgflags" (ibc_cgflags i),

166 makeEntry "ibc_cgflags" (ibc_cgflags i),

157 makeEntry "ibc_dynamic_libs" (ibc_dynamic_libs i),

167 makeEntry "ibc_dynamic_libs" (ibc_dynamic_libs i),

158 makeEntry "ibc_hdrs" (ibc_hdrs i),

168 makeEntry "ibc_hdrs" (ibc_hdrs i),

159− makeEntry "ibc_access" (ibc_access i),

160− makeEntry "ibc_total" (ibc_total i),

161 makeEntry "ibc_totcheckfail" (ibc_totcheckfail i),

169 makeEntry "ibc_totcheckfail" (ibc_totcheckfail i),

162 makeEntry "ibc_flags" (ibc_flags i),

170 makeEntry "ibc_flags" (ibc_flags i),

163 makeEntry "ibc_fninfo" (ibc_fninfo i),

171 makeEntry "ibc_fninfo" (ibc_fninfo i),

164 makeEntry "ibc_cg" (ibc_cg i),

172 makeEntry "ibc_cg" (ibc_cg i),

165− makeEntry "ibc_defs" (ibc_defs i),

166 makeEntry "ibc_docstrings" (ibc_docstrings i),

173 makeEntry "ibc_docstrings" (ibc_docstrings i),

167 makeEntry "ibc_moduledocs" (ibc_moduledocs i),

174 makeEntry "ibc_moduledocs" (ibc_moduledocs i),

168 makeEntry "ibc_transforms" (ibc_transforms i),

175 makeEntry "ibc_transforms" (ibc_transforms i),

@@ -181,7 +188,10 @@ entries i = catMaybes [Just $ toEntry "ver" 0 (encode $ ver i),

181 makeEntry "ibc_usage" (ibc_usage i),

188 makeEntry "ibc_usage" (ibc_usage i),

182 makeEntry "ibc_exports" (ibc_exports i),

189 makeEntry "ibc_exports" (ibc_exports i),

183 makeEntry "ibc_autohints" (ibc_autohints i),

190 makeEntry "ibc_autohints" (ibc_autohints i),

184− makeEntry "ibc_deprecated" (ibc_deprecated i)]

191+ makeEntry "ibc_deprecated" (ibc_deprecated i),

192+ makeEntry "ibc_defs" (ibc_defs i),

193+ makeEntry "ibc_total" (ibc_total i),

194+ makeEntry "ibc_access" (ibc_access i)]

185

195

186writeArchive :: FilePath -> IBCFile -> Idris ()

196writeArchive :: FilePath -> IBCFile -> Idris ()

187writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)

197writeArchive fp i = do let a = L.foldl (\x y -> addEntryToArchive y x) emptyArchive (entries i)

@@ -315,8 +325,9 @@ getEntry alt f a = case findEntryByPath f a of

315 Just e -> return $! (force . decode . fromEntry) e

325 Just e -> return $! (force . decode . fromEntry) e

316

326

317process :: Bool -- ^ Reexporting

327process :: Bool -- ^ Reexporting

328+ -> IBCPhase

318 -> Archive -> FilePath -> Idris ()

329 -> Archive -> FilePath -> Idris ()

319−process reexp i fn = do

330+process reexp phase i fn = do

320 ver <- getEntry 0 "ver" i

331 ver <- getEntry 0 "ver" i

321 when (ver /= ibcVersion) $ do

332 when (ver /= ibcVersion) $ do

322 logIBC 1 "ibc out of date"

333 logIBC 1 "ibc out of date"

@@ -328,7 +339,7 @@ process reexp i fn = do

328 srcok <- runIO $ doesFileExist source

339 srcok <- runIO $ doesFileExist source

329 when srcok $ timestampOlder source fn

340 when srcok $ timestampOlder source fn

330 pImportDirs =<< getEntry [] "ibc_importdirs" i

341 pImportDirs =<< getEntry [] "ibc_importdirs" i

331− pImports reexp =<< getEntry [] "ibc_imports" i

342+ pImports reexp phase =<< getEntry [] "ibc_imports" i

332 pImps =<< getEntry [] "ibc_implicits" i

343 pImps =<< getEntry [] "ibc_implicits" i

333 pFixes =<< getEntry [] "ibc_fixes" i

344 pFixes =<< getEntry [] "ibc_fixes" i

334 pStatics =<< getEntry [] "ibc_statics" i

345 pStatics =<< getEntry [] "ibc_statics" i

@@ -345,12 +356,9 @@ process reexp i fn = do

345 pCGFlags =<< getEntry [] "ibc_cgflags" i

356 pCGFlags =<< getEntry [] "ibc_cgflags" i

346 pDyLibs =<< getEntry [] "ibc_dynamic_libs" i

357 pDyLibs =<< getEntry [] "ibc_dynamic_libs" i

347 pHdrs =<< getEntry [] "ibc_hdrs" i

358 pHdrs =<< getEntry [] "ibc_hdrs" i

348− pDefs reexp =<< getEntry [] "ibc_defs" i

349 pPatdefs =<< getEntry [] "ibc_patdefs" i

359 pPatdefs =<< getEntry [] "ibc_patdefs" i

350− pAccess reexp =<< getEntry [] "ibc_access" i

351 pFlags =<< getEntry [] "ibc_flags" i

360 pFlags =<< getEntry [] "ibc_flags" i

352 pFnInfo =<< getEntry [] "ibc_fninfo" i

361 pFnInfo =<< getEntry [] "ibc_fninfo" i

353− pTotal =<< getEntry [] "ibc_total" i

354 pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i

362 pTotCheckErr =<< getEntry [] "ibc_totcheckfail" i

355 pCG =<< getEntry [] "ibc_cg" i

363 pCG =<< getEntry [] "ibc_cg" i

356 pDocs =<< getEntry [] "ibc_docstrings" i

364 pDocs =<< getEntry [] "ibc_docstrings" i

@@ -371,6 +379,9 @@ process reexp i fn = do

371 pExports =<< getEntry [] "ibc_exports" i

379 pExports =<< getEntry [] "ibc_exports" i

372 pAutoHints =<< getEntry [] "ibc_autohints" i

380 pAutoHints =<< getEntry [] "ibc_autohints" i

373 pDeprecate =<< getEntry [] "ibc_deprecated" i

381 pDeprecate =<< getEntry [] "ibc_deprecated" i

382+ pDefs reexp =<< getEntry [] "ibc_defs" i

383+ pTotal =<< getEntry [] "ibc_total" i

384+ pAccess reexp phase =<< getEntry [] "ibc_access" i

374

385

375timestampOlder :: FilePath -> FilePath -> Idris ()

386timestampOlder :: FilePath -> FilePath -> Idris ()

376timestampOlder src ibc = do srct <- runIO $ getModificationTime src

387timestampOlder src ibc = do srct <- runIO $ getModificationTime src

@@ -404,8 +415,8 @@ pDeprecate ns = mapM_ (\(n,reason) -> addDeprecated n reason) ns

404pImportDirs :: [FilePath] -> Idris ()

415pImportDirs :: [FilePath] -> Idris ()

405pImportDirs fs = mapM_ addImportDir fs

416pImportDirs fs = mapM_ addImportDir fs

406

417

407−pImports :: Bool -> [(Bool, FilePath)] -> Idris ()

418+pImports :: Bool -> IBCPhase -> [(Bool, FilePath)] -> Idris ()

408−pImports reexp fs

419+pImports reexp phase fs

409 = do mapM_ (\(re, f) ->

420 = do mapM_ (\(re, f) ->

410 do i <- getIState

421 do i <- getIState

411 ibcsd <- valIBCSubDir i

422 ibcsd <- valIBCSubDir i

@@ -414,6 +425,9 @@ pImports reexp fs

414-- if (f `elem` imported i)

425-- if (f `elem` imported i)

415-- then logLvl 1 $ "Already read " ++ f

426-- then logLvl 1 $ "Already read " ++ f

416 putIState (i { imported = f : imported i })

427 putIState (i { imported = f : imported i })

428+ let phase' = case phase of

429+ IBC_REPL _ -> IBC_REPL False

430+ p -> p

417 case fp of

431 case fp of

418 LIDR fn -> do

432 LIDR fn -> do

419 logIBC 1 $ "Failed at " ++ fn

433 logIBC 1 $ "Failed at " ++ fn

@@ -421,7 +435,7 @@ pImports reexp fs

421 IDR fn -> do

435 IDR fn -> do

422 logIBC 1 $ "Failed at " ++ fn

436 logIBC 1 $ "Failed at " ++ fn

423 ifail "Must be an ibc"

437 ifail "Must be an ibc"

424− IBC fn src -> loadIBC (reexp && re) fn)

438+ IBC fn src -> loadIBC (reexp && re) phase' fn)

425 fs

439 fs

426

440

427pImps :: [(Name, [PArg])] -> Idris ()

441pImps :: [(Name, [PArg])] -> Idris ()

@@ -429,6 +443,7 @@ pImps imps = mapM_ (\ (n, imp) ->

429 do i <- getIState

443 do i <- getIState

430 case lookupDefAccExact n False (tt_ctxt i) of

444 case lookupDefAccExact n False (tt_ctxt i) of

431 Just (n, Hidden) -> return ()

445 Just (n, Hidden) -> return ()

446+ Just (n, Private) -> return ()

432 _ -> putIState (i { idris_implicits

447 _ -> putIState (i { idris_implicits

433 = addDef n imp (idris_implicits i) }))

448 = addDef n imp (idris_implicits i) }))

434 imps

449 imps

@@ -518,12 +533,9 @@ pDefs reexp ds

518 case d' of

533 case d' of

519 TyDecl _ _ -> return ()

534 TyDecl _ _ -> return ()

520 _ -> do logIBC 1 $ "SOLVING " ++ show n

535 _ -> do logIBC 1 $ "SOLVING " ++ show n

521− solveDeferred n

536+ solveDeferred emptyFC n

522 updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

537 updateIState (\i -> i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })

523−-- logLvl 1 $ "Added " ++ show (n, d')

538+ ) ds

524− if (not reexp) then do logIBC 1 $ "Not exporting " ++ show n

525− setAccessibility n Hidden

526− else logIBC 1 $ "Exporting " ++ show n) ds

527 where

539 where

528 updateDef (CaseOp c t args o s cd)

540 updateDef (CaseOp c t args o s cd)

529 = do o' <- mapM updateOrig o

541 = do o' <- mapM updateOrig o

@@ -537,11 +549,9 @@ pDefs reexp ds

537 return $ Right (l', r')

549 return $ Right (l', r')

538

550

539 updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

551 updateCD (CaseDefs (ts, t) (cs, c) (is, i) (rs, r))

540− = do t' <- updateSC t

552+ = do c' <- updateSC c

541− c' <- updateSC c

542− i' <- updateSC i

543 r' <- updateSC r

553 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')

545

555

546 updateSC (Case t n alts) = do alts' <- mapM updateAlt alts

556 updateSC (Case t n alts) = do alts' <- mapM updateAlt alts

547 return (Case t n alts')

557 return (Case t n alts')

@@ -562,19 +572,28 @@ pDefs reexp ds

562 updateAlt (DefaultCase t) = do t' <- updateSC t

572 updateAlt (DefaultCase t) = do t' <- updateSC t

563 return (DefaultCase t')

573 return (DefaultCase t')

564

574

565− update (P t n ty) = do n' <- getSymbol n

575+ -- We get a lot of repetition in sub terms and can save a fair chunk

566− return $ P t n' ty

576+ -- of memory if we make sure they're shared. addTT looks for a term

567− update (App s f a) = liftM2 (App s) (update f) (update a)

577+ -- and returns it if it exists already, while also keeping stats of

568− update (Bind n b sc) = do b' <- updateB b

578+ -- how many times a subterm is repeated.

569− sc' <- update sc

579+ update t = do tm <- addTT t

570− return $ Bind n b' sc'

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'

571 where

590 where

572− updateB (Let t v) = liftM2 Let (update t) (update v)

591+ updateB (Let t v) = liftM2 Let (update' t) (update' v)

573− updateB b = do ty' <- update (binderTy b)

592+ updateB b = do ty' <- update' (binderTy b)

574 return (b { binderTy = ty' })

593 return (b { binderTy = ty' })

575− update (Proj t i) = do t' <- update t

594+ update' (Proj t i) = do t' <- update' t

576− return $ Proj t' i

595+ return $ Proj t' i

577− update t = return t

596+ update' t = return t

578

597

579pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris ()

598pDocs :: [(Name, (Docstring D.DocTerm, [(Name, Docstring D.DocTerm)]))] -> Idris ()

580pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds

599pDocs ds = mapM_ (\(n, a) -> addDocStr n (fst a) (snd a)) ds

@@ -584,12 +603,22 @@ pMDocs ds = mapM_ (\ (n, d) -> updateIState (\i ->

584 i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds

603 i { idris_moduledocs = addDef n d (idris_moduledocs i) })) ds

585

604

586pAccess :: Bool -- ^ Reexporting?

605pAccess :: Bool -- ^ Reexporting?

606+ -> IBCPhase

587 -> [(Name, Accessibility)] -> Idris ()

607 -> [(Name, Accessibility)] -> Idris ()

588−pAccess reexp ds

608+pAccess reexp phase ds

589 = mapM_ (\ (n, a_in) ->

609 = mapM_ (\ (n, a_in) ->

590 do let a = if reexp then a_in else Hidden

610 do let a = if reexp then a_in else Hidden

591 logIBC 3 $ "Setting " ++ show (a, n) ++ " to " ++ show a

611 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

593

622

594pFlags :: [(Name, [FnOpt])] -> Idris ()

623pFlags :: [(Name, [FnOpt])] -> Idris ()

595pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds

624pFlags ds = mapM_ (\ (n, a) -> setFlags n a) ds

@@ -633,7 +662,7 @@ pFunctionErrorHandlers :: [(Name, Name, Name)] -> Idris ()

633pFunctionErrorHandlers ns = mapM_ (\ (fn,arg,handler) ->

662pFunctionErrorHandlers ns = mapM_ (\ (fn,arg,handler) ->

634 addFunctionErrorHandlers fn arg [handler]) ns

663 addFunctionErrorHandlers fn arg [handler]) ns

635

664

636−pMetavars :: [(Name, (Maybe Name, Int, [Name], Bool))] -> Idris ()

665+pMetavars :: [(Name, (Maybe Name, Int, [Name], Bool, Bool))] -> Idris ()

637pMetavars ns = updateIState (\i -> i { idris_metavars = L.reverse ns ++ idris_metavars i })

666pMetavars ns = updateIState (\i -> i { idris_metavars = L.reverse ns ++ idris_metavars i })

638

667

639----- For Cheapskate and docstrings

668----- For Cheapskate and docstrings

@@ -753,18 +782,14 @@ instance Binary SizeChange where

753 _ -> error "Corrupted binary data for SizeChange"

782 _ -> error "Corrupted binary data for SizeChange"

754

783

755instance Binary CGInfo where

784instance Binary CGInfo where

756− put (CGInfo x1 x2 x3 x4 x5)

785+ put (CGInfo x1 x2 x3)

757 = do put x1

786 = do put x1

758− put x2

759-- put x3 -- Already used SCG info for totality check

787-- put x3 -- Already used SCG info for totality check

760− put x4

788+ put x3

761− put x5

762 get

789 get

763 = do x1 <- get

790 = do x1 <- get

764− x2 <- get

791+ x3 <- get

765− x4 <- get

792+ return (CGInfo x1 [] x3)

766− x5 <- get

767− return (CGInfo x1 x2 [] x4 x5)

768

793

769instance Binary CaseType where

794instance Binary CaseType where

770 put x = case x of

795 put x = case x of

@@ -883,13 +908,13 @@ instance Binary Def where

883 put x2

908 put x2

884 -- all primitives just get added at the start, don't write

909 -- all primitives just get added at the start, don't write

885 Operator x1 x2 x3 -> do return ()

910 Operator x1 x2 x3 -> do return ()

886− CaseOp x1 x2 x2a x3 x3a x4 -> do putWord8 3

911+ -- no need to add/load original patterns, because they're not

887− put x1

912+ -- used again after totality checking

888− put x2

913+ CaseOp x1 x2 x3 _ _ x4 -> do putWord8 3

889− put x2a

914+ put x1

890− put x3

915+ put x2

891− -- no x3a

916+ put x3

892− put x4

917+ put x4

893 get

918 get

894 = do i <- getWord8

919 = do i <- getWord8

895 case i of

920 case i of

@@ -903,10 +928,10 @@ instance Binary Def where

903 3 -> do x1 <- get

928 3 -> do x1 <- get

904 x2 <- get

929 x2 <- get

905 x3 <- get

930 x3 <- get

906− x4 <- get

931+-- x4 <- get

907 -- x3 <- get always []

932 -- x3 <- get always []

908 x5 <- get

933 x5 <- get

909− return (CaseOp x1 x2 x3 x4 [] x5)

934+ return (CaseOp x1 x2 x3 [] [] x5)

910 _ -> error "Corrupted binary data for Def"

935 _ -> error "Corrupted binary data for Def"

911

936

912instance Binary Accessibility where

937instance Binary Accessibility where

@@ -914,13 +939,15 @@ instance Binary Accessibility where

914 = case x of

939 = case x of

915 Public -> putWord8 0

940 Public -> putWord8 0

916 Frozen -> putWord8 1

941 Frozen -> putWord8 1

917− Hidden -> putWord8 2

942+ Private -> putWord8 2

943+ Hidden -> putWord8 3

918 get

944 get

919 = do i <- getWord8

945 = do i <- getWord8

920 case i of

946 case i of

921 0 -> return Public

947 0 -> return Public

922 1 -> return Frozen

948 1 -> return Frozen

923− 2 -> return Hidden

949+ 2 -> return Private

950+ 3 -> return Hidden

924 _ -> error "Corrupted binary data for Accessibility"

951 _ -> error "Corrupted binary data for Accessibility"

925

952

926safeToEnum :: (Enum a, Bounded a, Integral int) => String -> int -> a

953safeToEnum :: (Enum a, Bounded a, Integral int) => String -> int -> a

@@ -1235,7 +1262,7 @@ instance (Binary t) => Binary (PDecl' t) where

1235 put x10

1262 put x10

1236 put x11

1263 put x11

1237 put x12

1264 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 ->

1239 do putWord8 8

1266 do putWord8 8

1240 put x1

1267 put x1

1241 put x2

1268 put x2

@@ -1248,6 +1275,8 @@ instance (Binary t) => Binary (PDecl' t) where

1248 put x9

1275 put x9

1249 put x10

1276 put x10

1250 put x11

1277 put x11

1278+ put x12

1279+ put x13

1251 PDSL x1 x2 -> do putWord8 9

1280 PDSL x1 x2 -> do putWord8 9

1252 put x1

1281 put x1

1253 put x2

1282 put x2

@@ -1362,7 +1391,9 @@ instance (Binary t) => Binary (PDecl' t) where

1362 x9 <- get

1391 x9 <- get

1363 x10 <- get

1392 x10 <- get

1364 x11 <- get

1393 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)

1366 9 -> do x1 <- get

1397 9 -> do x1 <- get

1367 x2 <- get

1398 x2 <- get

1368 return (PDSL x1 x2)

1399 return (PDSL x1 x2)

src/Idris/IdrisDoc.hs+3−3

@@ -10,7 +10,7 @@ import Idris.Core.TT (Name (..), sUN, SpecialName (..), OutputAnnotation (..),

10import Idris.Core.Evaluate (ctxtAlist, Def (..), lookupDefAcc,

11 Accessibility (..), isDConName, isFnName,

12 isTConName)

13−import Idris.ParseHelpers (opChars)

13+import Idris.Parser.Helpers (opChars)

14import Idris.AbsSyntax

15import Idris.Docs

16import Idris.Docstrings (nullDocstring)

@@ -182,7 +182,7 @@ filterName _ = False

182

183

184-- | 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.

186-- Also it must have Docs -- without Docs, nothing can be done.

187filterInclude :: NsItem -- ^ Accessibility to check

188 -> Bool -- ^ Predicate result

@@ -254,7 +254,7 @@ getAccess ist n =

254 let res = lookupDefAcc n False (tt_ctxt ist)

255 in case res of

256 [(_, acc)] -> acc

257− _ -> Hidden

257+ _ -> Private

258

259-- | Simple predicate for whether an NsItem has Docs

260hasDoc :: NsItem -- ^ The NsItem to test

src/Idris/Interactive.hs+78−46

@@ -76,7 +76,7 @@ addClauseFrom fn updatefile l n = do

76 getIndent i n xs | take 9 xs == "instance " = i

77 getIndent i n xs | take (length n) xs == n = i

78 getIndent i n (x : xs) = getIndent (i + 1) n xs

79−

79+

80 getAppName (PApp _ r _) = getAppName r

81 getAppName (PRef _ _ r) = r

82 getAppName (PTyped n _) = getAppName n

@@ -120,7 +120,7 @@ addMissing fn updatefile l n

120 if updatefile

121 then do let fb = fn ++ "~"

122 runIO $ writeSource fb (unlines (before ++ nonblank)

123− ++ extras ++

123+ ++ extras ++

124 (if null extras then ""

125 else "\n" ++ unlines rest))

126 runIO $ copyFile fb fn

@@ -172,7 +172,7 @@ makeWith fn updatefile l n

172 ++ with ++ "\n" ++

173 unlines rest)

174 runIO $ copyFile fb fn

175− else iPrintResult with

175+ else iPrintResult (with ++ "\n")

176 where getIndent s = length (takeWhile isSpace s)

177

178-- Replace the given metavariable on the given line with a 'case'

@@ -193,7 +193,7 @@ makeCase fn updatefile l n

193 case findSubstr ('?':n) line of

194 Just (before, pos, after) ->

195 [before ++ (if b then "(" else "") ++ "case _ of",

196− take (pos + (if b then 6 else 5)) (repeat ' ') ++

196+ take (pos + (if b then 6 else 5)) (repeat ' ') ++

197 "case_val => ?" ++ n ++ (if b then ")" else "")

198 ++ after]

199 Nothing -> fail "No such metavariable"

@@ -208,7 +208,7 @@ makeCase fn updatefile l n

208

209 findSubstr n xs = findSubstr' [] 0 n xs

210

211− findSubstr' acc i n xs | take (length n) xs == n

211+ findSubstr' acc i n xs | take (length n) xs == n

212 = Just (reverse acc, i, drop (length n) xs)

213 findSubstr' acc i n [] = Nothing

214 findSubstr' acc i n (x : xs) = findSubstr' (x : acc) (i + 1) n xs

@@ -217,7 +217,7 @@ makeCase fn updatefile l n

217

218

219

220−doProofSearch :: FilePath -> Bool -> Bool ->

220+doProofSearch :: FilePath -> Bool -> Bool ->

221 Int -> Name -> [Name] -> Maybe Int -> Idris ()

222doProofSearch fn updatefile rec l n hints Nothing

223 = doProofSearch fn updatefile rec l n hints (Just 20)

@@ -230,15 +230,15 @@ doProofSearch fn updatefile rec l n hints (Just depth)

230 [] -> return n

231 ns -> ierror (CantResolveAlts ns)

232 i <- getIState

233− let (top, envlen, psnames, _)

233+ let (top, envlen, psnames)

234 = case lookup mn (idris_metavars i) of

235− Just (t, e, ns, False) -> (t, e, ns, False)

235+ Just (t, e, ns, False, d) -> (t, e, ns)

236− _ -> (Nothing, 0, [], True)

236+ _ -> (Nothing, 0, [])

237 let fc = fileFC fn

238 let body t = PProof [Try (TSeq Intros (ProofSearch rec False depth t psnames hints))

239 (ProofSearch rec False depth t psnames hints)]

240 let def = PClause fc mn (PRef fc [] mn) [] (body top) []

241− newmv <- idrisCatch

241+ newmv_pre <- idrisCatch

242 (do elabDecl' EAll recinfo (PClauses fc [] mn [def])

243 (tm, ty) <- elabVal recinfo ERHS (PRef fc [] mn)

244 ctxt <- getContext

@@ -249,10 +249,11 @@ doProofSearch fn updatefile rec l n hints (Just depth)

249 (dropCtxt envlen

250 (delab i (fst (specialise ctxt [] [(mn, 1)] tm))))))

251 (\e -> return ("?" ++ show n))

252+ let newmv = guessBrackets False tyline (show n) newmv_pre

252 if updatefile then

253 if updatefile then

253 do let fb = fn ++ "~"

254 do let fb = fn ++ "~"

254 runIO $ writeSource fb (unlines before ++

255 runIO $ writeSource fb (unlines before ++

255− updateMeta False tyline (show n) newmv ++ "\n"

256+ updateMeta tyline (show n) newmv ++ "\n"

256 ++ unlines later)

257 ++ unlines later)

257 runIO $ copyFile fb fn

258 runIO $ copyFile fb fn

258 else iPrintResult newmv

259 else iPrintResult newmv

@@ -270,18 +271,34 @@ doProofSearch fn updatefile rec l n hints (Just depth)

270 nsroot (SN (WhereN _ _ n)) = nsroot n

271 nsroot (SN (WhereN _ _ n)) = nsroot n

271 nsroot n = n

272 nsroot n = n

272

273

273−updateMeta brack ('?':cs) n new

274+updateMeta ('?':cs) n new

275+ | length cs >= length n

276+ = case splitAt (length n) cs of

277+ (mv, c:cs) ->

278+ if ((isSpace c || c == ')' || c == '}') && mv == n)

279+ then new ++ (c : cs)

280+ else '?' : mv ++ c : updateMeta cs n new

281+ (mv, []) -> if (mv == n) then new else '?' : mv

282+updateMeta ('=':'>':cs) n new = '=':'>':updateMeta cs n new

283+updateMeta ('=':cs) n new = '=':updateMeta cs n new

284+updateMeta (c:cs) n new

285+ = c : updateMeta cs n new

286+updateMeta [] n new = ""

287+

288+guessBrackets brack ('?':cs) n new

274 | length cs >= length n

289 | length cs >= length n

275 = case splitAt (length n) cs of

290 = case splitAt (length n) cs of

276 (mv, c:cs) ->

291 (mv, c:cs) ->

277 if ((isSpace c || c == ')' || c == '}') && mv == n)

292 if ((isSpace c || c == ')' || c == '}') && mv == n)

278− then addBracket brack new ++ (c : cs)

293+ then addBracket brack new

279− else '?' : mv ++ c : updateMeta True cs n new

294+ else guessBrackets True cs n new

280 (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv

295 (mv, []) -> if (mv == n) then addBracket brack new else '?' : mv

281−updateMeta brack ('=':cs) n new = '=':updateMeta False cs n new

296+guessBrackets brack ('=':'>':cs) n new = guessBrackets False cs n new

282−updateMeta brack (c:cs) n new

297+guessBrackets brack ('-':'>':cs) n new = guessBrackets False cs n new

283− = c : updateMeta (brack || not (isSpace c)) cs n new

298+guessBrackets brack ('=':cs) n new = guessBrackets False cs n new

284−updateMeta brack [] n new = ""

299+guessBrackets brack (c:cs) n new

300+ = guessBrackets (brack || not (isSpace c)) cs n new

301+guessBrackets brack [] n new = ""

285

302

286checkProv line n = isProv' False line n

303checkProv line n = isProv' False line n

287 where

304 where

@@ -291,7 +308,7 @@ checkProv line n = isProv' False line n

291 isProv' _ ('}':cs) n = isProv' True cs n

308 isProv' _ ('}':cs) n = isProv' True cs n

292 isProv' p (_:cs) n = isProv' p cs n

309 isProv' p (_:cs) n = isProv' p cs n

293 isProv' _ [] n = False

310 isProv' _ [] n = False

294−

311+

295addBracket False new = new

312addBracket False new = new

296addBracket True new@('(':xs) | last xs == ')' = new

313addBracket True new@('(':xs) | last xs == ')' = new

297addBracket True new | any isSpace new = '(' : new ++ ")"

314addBracket True new | any isSpace new = '(' : new ++ ")"

@@ -305,7 +322,7 @@ makeLemma fn updatefile l n

305

322

306 -- if the name is in braces, rather than preceded by a ?, treat it

323 -- if the name is in braces, rather than preceded by a ?, treat it

307 -- as a lemma in a provisional definition

324 -- as a lemma in a provisional definition

308−

325+

309 let isProv = checkProv tyline (show n)

326 let isProv = checkProv tyline (show n)

310

327

311 ctxt <- getContext

328 ctxt <- getContext

@@ -315,18 +332,19 @@ makeLemma fn updatefile l n

315 ns -> ierror (CantResolveAlts (map fst ns))

332 ns -> ierror (CantResolveAlts (map fst ns))

316 i <- getIState

333 i <- getIState

317 margs <- case lookup fname (idris_metavars i) of

334 margs <- case lookup fname (idris_metavars i) of

318− Just (_, arity, _, _) -> return arity

335+ Just (_, arity, _, _, _) -> return arity

319 _ -> return (-1)

336 _ -> return (-1)

320

337

321 if (not isProv) then do

338 if (not isProv) then do

322 let skip = guessImps i (tt_ctxt i) mty

339 let skip = guessImps i (tt_ctxt i) mty

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

324

342

325− let lem = show n ++ " : " ++

343+ let lem = show n ++ " : " ++

326 constraints i classes mty ++

344 constraints i classes mty ++

327 showTmOpts (defaultPPOption { ppopt_pinames = True })

345 showTmOpts (defaultPPOption { ppopt_pinames = True })

328− (stripMNBind skip margs (delab i mty))

346+ impty

329− let lem_app = show n ++ appArgs skip margs mty

347+ let lem_app = guessBrackets False tyline (show n) (show n ++ appArgs skip margs mty)

330

348

331 if updatefile then

349 if updatefile then

332 do let fb = fn ++ "~"

350 do let fb = fn ++ "~"

@@ -362,19 +380,26 @@ makeLemma fn updatefile l n

362 where getIndent s = length (takeWhile isSpace s)

380 where getIndent s = length (takeWhile isSpace s)

363

381

364 appArgs skip 0 _ = ""

382 appArgs skip 0 _ = ""

365− appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc)

383+ appArgs skip i (Bind n@(UN c) (Pi _ _ _) sc)

366 | (thead c /= '_' && n `notElem` skip)

384 | (thead c /= '_' && n `notElem` skip)

367 = " " ++ show n ++ appArgs skip (i - 1) sc

385 = " " ++ show n ++ appArgs skip (i - 1) sc

368 appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc

386 appArgs skip i (Bind _ (Pi _ _ _) sc) = appArgs skip (i - 1) sc

369 appArgs skip i _ = ""

387 appArgs skip i _ = ""

370

388

371− stripMNBind _ args t | args <= 0 = t

389+ stripMNBind _ args t | args <= 0 = stripImp t

372− stripMNBind skip args (PPi b n@(UN c) _ ty sc)

390+ stripMNBind skip args (PPi b n@(UN c) _ ty sc)

373 | n `notElem` skip ||

391 | n `notElem` skip ||

374 take 4 (str c) == "__pi" -- keep in type, but not in app

392 take 4 (str c) == "__pi" -- keep in type, but not in app

375− = PPi b n NoFC ty (stripMNBind skip (args - 1) sc)

393+ = PPi b n NoFC (stripImp ty) (stripMNBind skip (args - 1) sc)

376 stripMNBind skip args (PPi b _ _ ty sc) = stripMNBind skip (args - 1) sc

394 stripMNBind skip args (PPi b _ _ ty sc) = stripMNBind skip (args - 1) sc

377− stripMNBind skip args t = t

395+ stripMNBind skip args t = stripImp t

396+

397+ stripImp (PApp fc f as) = PApp fc (stripImp f) (map placeholderImp as)

398+ where

399+ placeholderImp tm@(PImp _ _ _ _ _) = tm { getTm = Placeholder }

400+ placeholderImp tm = tm { getTm = stripImp (getTm tm) }

401+ stripImp (PPi b n f ty sc) = PPi b n f (stripImp ty) (stripImp sc)

402+ stripImp t = t

378

403

379 constraints :: IState -> [Name] -> Type -> String

404 constraints :: IState -> [Name] -> Type -> String

380 constraints i [] ty = ""

405 constraints i [] ty = ""

@@ -382,7 +407,7 @@ makeLemma fn updatefile l n

382 constraints i ns ty = "(" ++ showSep ", " (showConstraints i ns ty) ++ ") => "

407 constraints i ns ty = "(" ++ showSep ", " (showConstraints i ns ty) ++ ") => "

383

408

384 showConstraints i ns (Bind n (Pi _ ty _) sc)

409 showConstraints i ns (Bind n (Pi _ ty _) sc)

385− | n `elem` ns = show (delab i ty) :

410+ | n `elem` ns = show (delab i ty) :

386 showConstraints i ns (substV (P Bound n Erased) sc)

411 showConstraints i ns (substV (P Bound n Erased) sc)

387 | otherwise = showConstraints i ns (substV (P Bound n Erased) sc)

412 | otherwise = showConstraints i ns (substV (P Bound n Erased) sc)

388 showConstraints _ _ _ = []

413 showConstraints _ _ _ = []

@@ -393,10 +418,10 @@ makeLemma fn updatefile l n

393 -- Also, make type class instances implicit

418 -- Also, make type class instances implicit

394 guessImps :: IState -> Context -> Term -> [Name]

419 guessImps :: IState -> Context -> Term -> [Name]

395 -- machine names aren't lifted

420 -- machine names aren't lifted

396− guessImps ist ctxt (Bind n@(MN _ _) (Pi _ ty _) sc)

421+ guessImps ist ctxt (Bind n@(MN _ _) (Pi _ ty _) sc)

397 = n : guessImps ist ctxt sc

422 = n : guessImps ist ctxt sc

398 guessImps ist ctxt (Bind n (Pi _ ty _) sc)

423 guessImps ist ctxt (Bind n (Pi _ ty _) sc)

399− | guarded ctxt n (substV (P Bound n Erased) sc)

424+ | guarded ctxt n (substV (P Bound n Erased) sc)

400 = n : guessImps ist ctxt sc

425 = n : guessImps ist ctxt sc

401 | isClass ist ty

426 | isClass ist ty

402 = n : guessImps ist ctxt sc

427 = n : guessImps ist ctxt sc

@@ -404,22 +429,29 @@ makeLemma fn updatefile l n

404 | ignoreName n = n : guessImps ist ctxt sc

429 | ignoreName n = n : guessImps ist ctxt sc

405 | otherwise = guessImps ist ctxt sc

430 | otherwise = guessImps ist ctxt sc

406 guessImps ist ctxt _ = []

431 guessImps ist ctxt _ = []

407−

432+

408 paramty (TType _) = True

433 paramty (TType _) = True

409 paramty (Bind _ (Pi _ (TType _) _) sc) = paramty sc

434 paramty (Bind _ (Pi _ (TType _) _) sc) = paramty sc

410 paramty _ = False

435 paramty _ = False

411−

436+

412 -- TMP HACK unusable name so don't lift

437 -- TMP HACK unusable name so don't lift

413 ignoreName n = case show n of

438 ignoreName n = case show n of

414 "_aX" -> True

439 "_aX" -> True

415 _ -> False

440 _ -> False

416

441

417− guessClasses :: IState -> Context -> Term -> [Name]

442+ guessClasses :: IState -> Context -> [Name] -> [Name] -> Term -> [Name]

418− guessClasses ist ctxt (Bind n (Pi _ ty _) sc)

443+ guessClasses ist ctxt binders usednames (Bind n (Pi _ ty _) sc)

419− | isParamClass ist ty

444+ | isParamClass ist ty && any (\x -> elem x usednames)

420− = n : guessClasses ist ctxt sc

445+ (paramNames binders ty)

421− | otherwise = guessClasses ist ctxt sc

446+ = n : guessClasses ist ctxt (n : binders) usednames sc

422− guessClasses ist ctxt _ = []

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

423

455

424 isClass ist t

456 isClass ist t

425 | (P _ n _, args) <- unApply t

457 | (P _ n _, args) <- unApply t

@@ -427,7 +459,7 @@ makeLemma fn updatefile l n

427 Just _ -> True

459 Just _ -> True

428 _ -> False

460 _ -> False

429 | otherwise = False

461 | otherwise = False

430−

462+

431 isParamClass ist t

463 isParamClass ist t

432 | (P _ n _, args) <- unApply t

464 | (P _ n _, args) <- unApply t

433 = case lookupCtxtExact n (idris_classes ist) of

465 = case lookupCtxtExact n (idris_classes ist) of

@@ -443,18 +475,18 @@ makeLemma fn updatefile l n

443 isConName f ctxt = any (guarded ctxt n) args

475 isConName f ctxt = any (guarded ctxt n) args

444-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows

476-- guarded ctxt n (Bind (UN cn) (Pi t) sc) -- ignore shadows

445-- | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc

477-- | thead cn /= '_' = guarded ctxt n t || guarded ctxt n sc

446− guarded ctxt n (Bind _ (Pi _ t _) sc)

478+ guarded ctxt n (Bind _ (Pi _ t _) sc)

447 = guarded ctxt n t || guarded ctxt n sc

479 = guarded ctxt n t || guarded ctxt n sc

448 guarded ctxt n _ = False

480 guarded ctxt n _ = False

449

481

450 blank = all isSpace

482 blank = all isSpace

451

483

452 addLem before tyline lem lem_app later

484 addLem before tyline lem lem_app later

453− = let (bef_end, blankline : bef_start)

485+ = let (bef_end, blankline : bef_start)

454 = case span (not . blank) (reverse before) of

486 = case span (not . blank) (reverse before) of

455 (bef, []) -> (bef, "" : [])

487 (bef, []) -> (bef, "" : [])

456 x -> x

488 x -> x

457− mvline = updateMeta False tyline (show n) lem_app in

489+ mvline = updateMeta tyline (show n) lem_app in

458 unlines $ reverse bef_start ++

490 unlines $ reverse bef_start ++

459 [blankline, lem, blankline] ++

491 [blankline, lem, blankline] ++

460 reverse bef_end ++ mvline : later

492 reverse bef_end ++ mvline : later

@@ -464,6 +496,6 @@ makeLemma fn updatefile l n

464 = case span (not . blank) later of

496 = case span (not . blank) later of

465 (bef, []) -> (bef, "" : [])

497 (bef, []) -> (bef, "" : [])

466 x -> x in

498 x -> x in

467− unlines $ before ++ tyline :

499+ unlines $ before ++ tyline :

468 (later_bef ++ [blankline, lem_app, blankline] ++

500 (later_bef ++ [blankline, lem_app, blankline] ++

469 later_end)

501 later_end)

src/Idris/Parser.hs+76−57

@@ -1,10 +1,10 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2{-# OPTIONS_GHC -O0 #-}

3module Idris.Parser(module Idris.Parser,

4− module Idris.ParseExpr,

4+ module Idris.Parser.Expr,

5− module Idris.ParseData,

5+ module Idris.Parser.Data,

6− module Idris.ParseHelpers,

6+ module Idris.Parser.Helpers,

7− module Idris.ParseOps) where

7+ module Idris.Parser.Ops) where

8

9import Prelude hiding (pi)

10

@@ -35,10 +35,10 @@ import Idris.Unlit

35import Idris.Providers

36import Idris.Output

37

38−import Idris.ParseHelpers

38+import Idris.Parser.Helpers

39−import Idris.ParseOps

39+import Idris.Parser.Ops

40−import Idris.ParseExpr

40+import Idris.Parser.Expr

41−import Idris.ParseData

41+import Idris.Parser.Data

42

43import Idris.Docstrings hiding (Unchecked)

44

@@ -211,7 +211,7 @@ internalDecl syn

211 declBody continue)

212 <|> fail "End of readable input"

213 where declBody :: Bool -> IdrisParser [PDecl]

214− declBody b =

214+ declBody b =

215 try (instance_ True syn)

216 <|> declBody' b

217 <|> using_ syn

@@ -337,8 +337,8 @@ declExtension syn ns rules =

337 (map (updateNs ns) ds)

338 (updateRecCon ns cname)

339 cdocs

340− updateNs ns (PInstance docs pdocs s fc cs cn fc' ps ity ni ds)

340+ updateNs ns (PInstance docs pdocs s fc cs acc opts cn fc' ps ity ni ds)

341− = PInstance docs pdocs s fc cs (updateB ns cn) fc'

341+ = PInstance docs pdocs s fc cs acc opts (updateB ns cn) fc'

342 ps ity (fmap (updateB ns) ni)

343 (map (updateNs ns) ds)

344 updateNs ns (PMutual fc ds) = PMutual fc (map (updateNs ns) ds)

@@ -502,7 +502,9 @@ syntaxRule syn

502 body' <- fixBind ((n,n'):rens) body

503 return $ PLam fc n' nfc ty' body'

504 fixBind rens (PPi plic n nfc argTy body)

505− | n `elem` userNames = liftM2 (PPi plic n nfc) (fixBind rens argTy) (fixBind rens body)

505+ | n `elem` userNames = liftM2 (PPi plic n nfc)

506+ (fixBind rens argTy)

507+ (fixBind rens body)

506 | otherwise =

508 | otherwise =

507 do ty' <- fixBind rens argTy

509 do ty' <- fixBind rens argTy

508 n' <- gensym n

510 n' <- gensym n

@@ -521,6 +523,10 @@ syntaxRule syn

521 return $ PLet fc n' nfc ty' val' body'

523 return $ PLet fc n' nfc ty' val' body'

522 fixBind rens (PMatchApp fc n) | Just n' <- lookup n rens =

524 fixBind rens (PMatchApp fc n) | Just n' <- lookup n rens =

523 return $ PMatchApp fc n'

525 return $ PMatchApp fc n'

526+ -- Also rename resolved quotations, to allow syntax rules to

527+ -- have quoted references to their own bindings.

528+ fixBind rens (PQuoteName n True fc) | Just n' <- lookup n rens =

529+ return $ PQuoteName n' True fc

524 fixBind rens x = descendM (fixBind rens) x

530 fixBind rens x = descendM (fixBind rens) x

525

531

526 gensym :: Name -> IdrisParser Name

532 gensym :: Name -> IdrisParser Name

@@ -584,7 +590,7 @@ fnDecl' syn = checkFixity $

584 then [TotalFn]

590 then [TotalFn]

585 else []

591 else []

586 opts <- fnOpts initOpts

592 opts <- fnOpts initOpts

587− acc <- optional accessibility

593+ acc <- accessibility

588 opts' <- fnOpts opts

594 opts' <- fnOpts opts

589 (n_in, nfc) <- fnName

595 (n_in, nfc) <- fnName

590 let n = expandNS syn n_in

596 let n = expandNS syn n_in

@@ -698,7 +704,7 @@ postulate syn = do (doc, ext)

698 then [TotalFn]

704 then [TotalFn]

699 else []

705 else []

700 opts <- fnOpts initOpts

706 opts <- fnOpts initOpts

701− acc <- optional accessibility

707+ acc <- accessibility

702 opts' <- fnOpts opts

708 opts' <- fnOpts opts

703 (n_in, nfc) <- fnName

709 (n_in, nfc) <- fnName

704 let n = expandNS syn n_in

710 let n = expandNS syn n_in

@@ -856,7 +862,7 @@ Class ::=

856class_ :: SyntaxInfo -> IdrisParser [PDecl]

862class_ :: SyntaxInfo -> IdrisParser [PDecl]

857class_ syn = do (doc, argDocs, acc)

863class_ syn = do (doc, argDocs, acc)

858 <- try (do (doc, argDocs) <- docstring syn

864 <- try (do (doc, argDocs) <- docstring syn

859− acc <- optional accessibility

865+ acc <- accessibility

860 classKeyword

866 classKeyword

861 return (doc, argDocs, acc))

867 return (doc, argDocs, acc))

862 fc <- getFC

868 fc <- getFC

@@ -873,15 +879,12 @@ class_ syn = do (doc, argDocs, acc)

873 where

879 where

874 fundeps :: IdrisParser [(Name, FC)]

880 fundeps :: IdrisParser [(Name, FC)]

875 fundeps = do lchar '|'; sepBy name (lchar ',')

881 fundeps = do lchar '|'; sepBy name (lchar ',')

876−

882+

877 classKeyword :: IdrisParser ()

883 classKeyword :: IdrisParser ()

878 classKeyword = reservedHL "interface"

884 classKeyword = reservedHL "interface"

879 <|> do reservedHL "class"

885 <|> do reservedHL "class"

880 fc <- getFC

886 fc <- getFC

881− ist <- get

887+ parserWarning fc Nothing (Msg "The 'class' keyword is deprecated. Use 'interface' instead.")

882− put ist { parserWarnings =

883− (fc, Msg "The 'class' keyword is deprecated. Use 'interface' instead.")

884− : parserWarnings ist }

885

888

886 carg :: IdrisParser (Name, FC, PTerm)

889 carg :: IdrisParser (Name, FC, PTerm)

887 carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'

890 carg = do lchar '('; (i, ifc) <- name; lchar ':'; ty <- expr syn; lchar ')'

@@ -903,11 +906,21 @@ InstanceName ::= '[' Name ']';

903@

906@

904-}

907-}

905instance_ :: Bool -> SyntaxInfo -> IdrisParser [PDecl]

908instance_ :: Bool -> SyntaxInfo -> IdrisParser [PDecl]

906−instance_ kwopt syn

909+instance_ kwopt syn

907− = do (doc, argDocs)

910+ = do ist <- get

908− <- try (docstring syn <* if kwopt then optional instanceKeyword

911+ let initOpts = if default_total ist

909− else do instanceKeyword

912+ then [TotalFn]

910− return (Just ()))

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+

911 fc <- getFC

924 fc <- getFC

912 en <- optional instanceName

925 en <- optional instanceName

913 cs <- constraintList syn

926 cs <- constraintList syn

@@ -917,7 +930,7 @@ instance_ kwopt syn

917 let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)

930 let sc = PApp fc (PRef cnfc [cnfc] cn) (map pexp args)

918 let t = bindList (PPi constraint) cs sc

931 let t = bindList (PPi constraint) cs sc

919 ds <- instanceBlock syn

932 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]

921 <?> "implementation declaration"

934 <?> "implementation declaration"

922 where instanceName :: IdrisParser Name

935 where instanceName :: IdrisParser Name

923 instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'

936 instanceName = do lchar '['; n_in <- fst <$> fnName; lchar ']'

@@ -928,11 +941,7 @@ instance_ kwopt syn

928 instanceKeyword = reservedHL "implementation"

941 instanceKeyword = reservedHL "implementation"

929 <|> do reservedHL "instance"

942 <|> do reservedHL "instance"

930 fc <- getFC

943 fc <- getFC

931− ist <- get

944+ parserWarning fc Nothing (Msg "The 'instance' keyword is deprecated. Use 'implementation' (or omit it) instead.")

932− put ist { parserWarnings =

933− (fc, Msg "The 'instance' keyword is deprecated. Use 'implementation' (or omit it) instead.")

934− : parserWarnings ist }

935−

936

945

937-- | Parse a docstring

946-- | Parse a docstring

938docstring :: SyntaxInfo

947docstring :: SyntaxInfo

@@ -1321,7 +1330,10 @@ directive syn = do try (lchar '%' *> reserved "lib")

1321 return [PDirective (DHide n)]

1330 return [PDirective (DHide n)]

1322 <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName []

1331 <|> do try (lchar '%' *> reserved "freeze"); n <- fst <$> iName []

1323 return [PDirective (DFreeze n)]

1332 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 }

1325 return [PDirective (DAccess acc)]

1337 return [PDirective (DAccess acc)]

1326 <|> do try (lchar '%' *> reserved "default"); tot <- totality

1338 <|> do try (lchar '%' *> reserved "default"); tot <- totality

1327 i <- get

1339 i <- get

@@ -1353,7 +1365,12 @@ directive syn = do try (lchar '%' *> reserved "lib")

1353 fn <- fst <$> fnName

1365 fn <- fst <$> fnName

1354 arg <- fst <$> iName []

1366 arg <- fst <$> iName []

1355 return [PDirective (DUsed fc fn arg)]

1367 return [PDirective (DUsed fc fn arg)]

1368+ <|> do try (lchar '%' *> reserved "auto_implicits")

1369+ b <- on_off

1370+ return [PDirective (DAutoImplicits b)]

1356 <?> "directive"

1371 <?> "directive"

1372+ where on_off = do reserved "on"; return True

1373+ <|> do reserved "off"; return False

1357

1374

1358pLangExt :: IdrisParser LanguageExt

1375pLangExt :: IdrisParser LanguageExt

1359pLangExt = (reserved "TypeProviders" >> return TypeProviders)

1376pLangExt = (reserved "TypeProviders" >> return TypeProviders)

@@ -1491,14 +1508,23 @@ parseImports fname input

1491 [(FC, OutputAnnotation)], IState)

1508 [(FC, OutputAnnotation)], IState)

1492 imports = do whiteSpace

1509 imports = do whiteSpace

1493 (mdoc, mname, annots) <- moduleHeader

1510 (mdoc, mname, annots) <- moduleHeader

1494− ps <- many import_

1511+ ps_exp <- many import_

1495 mrk <- mark

1512 mrk <- mark

1496 isEof <- lookAheadMatches eof

1513 isEof <- lookAheadMatches eof

1497 let mrk' = if isEof

1514 let mrk' = if isEof

1498 then Nothing

1515 then Nothing

1499 else Just mrk

1516 else Just mrk

1500 i <- get

1517 i <- get

1518+ -- add Builtins and Prelude, unless options say

1519+ -- not to

1520+ let ps = ps_exp -- imp "Builtins" : imp "Prelude" : ps_exp

1501 return ((mdoc, mname, ps, mrk'), annots, i)

1521 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+

1502 addPath :: [(FC, OutputAnnotation)] -> FilePath -> [(FC, OutputAnnotation)]

1528 addPath :: [(FC, OutputAnnotation)] -> FilePath -> [(FC, OutputAnnotation)]

1503 addPath [] _ = []

1529 addPath [] _ = []

1504 addPath ((fc, AnnNamespace ns Nothing) : annots) path =

1530 addPath ((fc, AnnNamespace ns Nothing) : annots) path =

@@ -1556,17 +1582,17 @@ parseProg syn fname input mrk

1556 return (ds, i')

1582 return (ds, i')

1557

1583

1558{- | Load idris module and show error if something wrong happens -}

1584{- | Load idris module and show error if something wrong happens -}

1559−loadModule :: FilePath -> Idris (Maybe String)

1585+loadModule :: FilePath -> IBCPhase -> Idris (Maybe String)

1560−loadModule f

1586+loadModule f phase

1561− = idrisCatch (loadModule' f)

1587+ = idrisCatch (loadModule' f phase)

1562 (\e -> do setErrSpan (getErrSpan e)

1588 (\e -> do setErrSpan (getErrSpan e)

1563 ist <- getIState

1589 ist <- getIState

1564 iWarn (getErrSpan e) $ pprintErr ist e

1590 iWarn (getErrSpan e) $ pprintErr ist e

1565 return Nothing)

1591 return Nothing)

1566

1592

1567{- | Load idris module -}

1593{- | Load idris module -}

1568−loadModule' :: FilePath -> Idris (Maybe String)

1594+loadModule' :: FilePath -> IBCPhase -> Idris (Maybe String)

1569−loadModule' f

1595+loadModule' f phase

1570 = do i <- getIState

1596 = do i <- getIState

1571 let file = takeWhile (/= ' ') f

1597 let file = takeWhile (/= ' ') f

1572 ibcsd <- valIBCSubDir i

1598 ibcsd <- valIBCSubDir i

@@ -1580,7 +1606,7 @@ loadModule' f

1580 IDR fn -> loadSource False fn Nothing

1606 IDR fn -> loadSource False fn Nothing

1581 LIDR fn -> loadSource True fn Nothing

1607 LIDR fn -> loadSource True fn Nothing

1582 IBC fn src ->

1608 IBC fn src ->

1583− idrisCatch (loadIBC True fn)

1609+ idrisCatch (loadIBC True phase fn)

1584 (\c -> do logParser 1 $ fn ++ " failed " ++ pshow i c

1610 (\c -> do logParser 1 $ fn ++ " failed " ++ pshow i c

1585 case src of

1611 case src of

1586 IDR sfn -> loadSource False sfn Nothing

1612 IDR sfn -> loadSource False sfn Nothing

@@ -1588,18 +1614,18 @@ loadModule' f

1588 return $ Just file

1614 return $ Just file

1589

1615

1590{- | Load idris code from file -}

1616{- | Load idris code from file -}

1591−loadFromIFile :: Bool -> IFileType -> Maybe Int -> Idris ()

1617+loadFromIFile :: Bool -> IBCPhase -> IFileType -> Maybe Int -> Idris ()

1592−loadFromIFile reexp i@(IBC fn src) maxline

1618+loadFromIFile reexp phase i@(IBC fn src) maxline

1593 = do logParser 1 $ "Skipping " ++ getSrcFile i

1619 = do logParser 1 $ "Skipping " ++ getSrcFile i

1594− idrisCatch (loadIBC reexp fn)

1620+ idrisCatch (loadIBC reexp phase fn)

1595 (\err -> ierror $ LoadingFailed fn err)

1621 (\err -> ierror $ LoadingFailed fn err)

1596 where

1622 where

1597 getSrcFile (IDR fn) = fn

1623 getSrcFile (IDR fn) = fn

1598 getSrcFile (LIDR fn) = fn

1624 getSrcFile (LIDR fn) = fn

1599 getSrcFile (IBC f src) = getSrcFile src

1625 getSrcFile (IBC f src) = getSrcFile src

1600

1626

1601−loadFromIFile _ (IDR fn) maxline = loadSource' False fn maxline

1627+loadFromIFile _ _ (IDR fn) maxline = loadSource' False fn maxline

1602−loadFromIFile _ (LIDR fn) maxline = loadSource' True fn maxline

1628+loadFromIFile _ _ (LIDR fn) maxline = loadSource' True fn maxline

1603

1629

1604{-| Load idris source code and show error if something wrong happens -}

1630{-| Load idris source code and show error if something wrong happens -}

1605loadSource' :: Bool -> FilePath -> Maybe Int -> Idris ()

1631loadSource' :: Bool -> FilePath -> Maybe Int -> Idris ()

@@ -1630,7 +1656,7 @@ loadSource lidr f toline

1630 LIDR fn -> ifail $ "No ibc for " ++ f

1656 LIDR fn -> ifail $ "No ibc for " ++ f

1631 IDR fn -> ifail $ "No ibc for " ++ f

1657 IDR fn -> ifail $ "No ibc for " ++ f

1632 IBC fn src ->

1658 IBC fn src ->

1633− do loadIBC True fn

1659+ do loadIBC True IBC_Building fn

1634 let srcFn = case src of

1660 let srcFn = case src of

1635 IDR fn -> Just fn

1661 IDR fn -> Just fn

1636 LIDR fn -> Just fn

1662 LIDR fn -> Just fn

@@ -1662,7 +1688,7 @@ loadSource lidr f toline

1662 (n,fc):_ -> throwError . At fc . Msg $ "import alias not unique: " ++ show n

1688 (n,fc):_ -> throwError . At fc . Msg $ "import alias not unique: " ++ show n

1663

1689

1664 i <- getIState

1690 i <- getIState

1665− putIState (i { default_access = Hidden, module_aliases = modAliases })

1691+ putIState (i { default_access = Private, module_aliases = modAliases })

1666 clearIBC -- start a new .ibc file

1692 clearIBC -- start a new .ibc file

1667 -- record package info in .ibc

1693 -- record package info in .ibc

1668 imps <- allImportDirs

1694 imps <- allImportDirs

@@ -1760,7 +1786,7 @@ loadSource lidr f toline

1760 clearHighlights

1786 clearHighlights

1761 i <- getIState

1787 i <- getIState

1762 putIState (i { default_total = def_total,

1788 putIState (i { default_total = def_total,

1763− hide_list = [] })

1789+ hide_list = emptyContext })

1764 return ()

1790 return ()

1765 where

1791 where

1766 namespaces :: [String] -> [PDecl] -> [PDecl]

1792 namespaces :: [String] -> [PDecl] -> [PDecl]

@@ -1790,16 +1816,9 @@ loadSource lidr f toline

1790 parsedDocs ist = annotCode (tryFullExpr syn ist) docs

1816 parsedDocs ist = annotCode (tryFullExpr syn ist) docs

1791

1817

1792{- | Adds names to hide list -}

1818{- | Adds names to hide list -}

1793−addHides :: [(Name, Maybe Accessibility)] -> Idris ()

1819+addHides :: Ctxt Accessibility -> Idris ()

1794addHides xs = do i <- getIState

1820addHides xs = do i <- getIState

1795 let defh = default_access i

1821 let defh = default_access i

1796− let (hs, as) = partition isNothing xs

1822+ mapM_ doHide (toAlist xs)

1797− unless (null as) $

1823+ where doHide (n, a) = do setAccessibility n a

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

1805 addIBC (IBCAccess n a)

1824 addIBC (IBCAccess n a)

src/Idris/ParseData.hs → src/Idris/Parser/Data.hsrenamed+13−13

@@ -1,5 +1,5 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−module Idris.ParseData where

2+module Idris.Parser.Data where

3

4import Prelude hiding (pi)

5

@@ -12,9 +12,9 @@ import qualified Text.Parser.Char as Chr

12import qualified Text.Parser.Token.Highlight as Hi

13

14import Idris.AbsSyntax

15−import Idris.ParseHelpers

15+import Idris.Parser.Helpers

16−import Idris.ParseOps

16+import Idris.Parser.Ops

17−import Idris.ParseExpr

17+import Idris.Parser.Expr

18import Idris.DSL

19

20import Idris.Core.TT

@@ -48,7 +48,7 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

48 let doc' = annotCode (tryFullExpr syn ist) doc

49 paramDocs' = [ (n, annotCode (tryFullExpr syn ist) d)

50 | (n, d) <- paramDocs ]

51− acc <- optional accessibility

51+ acc <- accessibility

52 opts <- dataOpts []

53 co <- recordI

54 return (doc', paramDocs', acc, opts ++ co))

@@ -59,8 +59,9 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

59 syn_namespace syn }

60 params <- manyTill (recordParameter rsyn) (reservedHL "where")

61 (fields, cname, cdoc) <- indentedBlockS $ recordBody rsyn tyn

62+ let fnames = map (expandNS rsyn) (mapMaybe getName fields)

62 case cname of

63 case cname of

63− Just cn' -> accData acc tyn [fst cn']

64+ Just cn' -> accData acc tyn (fst cn' : fnames)

64 Nothing -> return ()

65 Nothing -> return ()

65 return $ PRecord doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc syn

66 return $ PRecord doc rsyn fc opts tyn nfc params paramDocs fields cname cdoc syn

66 <?> "record type declaration"

67 <?> "record type declaration"

@@ -70,8 +71,11 @@ record syn = do (doc, paramDocs, acc, opts) <- try (do

70 ++ getRecNames syn sc

71 ++ getRecNames syn sc

71 getRecNames _ _ = []

72 getRecNames _ _ = []

72

73

74+ getName (Just (n, _), _, _, _) = Just n

75+ getName _ = Nothing

76+

73 toFreeze :: Maybe Accessibility -> Maybe Accessibility

77 toFreeze :: Maybe Accessibility -> Maybe Accessibility

74− toFreeze (Just Frozen) = Just Hidden

78+ toFreeze (Just Frozen) = Just Private

75 toFreeze x = x

79 toFreeze x = x

76

80

77 recordBody :: SyntaxInfo -> Name -> IdrisParser ([((Maybe (Name, FC)), Plicity, PTerm, Maybe (Docstring (Either Err PTerm)))], Maybe (Name, FC), Docstring (Either Err PTerm))

81 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

167 <|> return opts

171 <|> return opts

168 <?> "data options"

172 <?> "data options"

169 where warnElim fc =

173 where warnElim fc =

170− do ist <- get

174+ parserWarning fc (Just NoElimDeprecationWarnings) (Msg "The 'class' keyword is deprecated. Use 'interface' instead.")

171− let cmdline = opt_cmdline (idris_options ist)

172− unless (NoElimDeprecationWarnings `elem` cmdline) $

173− put ist { parserWarnings =

174− (fc, Msg "Eliminator generation is deprecated. Use an eliminator generator in a library instead.") : parserWarnings ist }

175

176{- | Parses a data type declaration

177Data ::= DocComment? Accessibility? DataI DefaultEliminator FnName TypeSig ExplicitTypeDataRest?

@@ -192,7 +192,7 @@ data_ :: SyntaxInfo -> IdrisParser PDecl

192data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

193 (doc, argDocs) <- option noDocs docComment

194 pushIndent

195− acc <- optional accessibility

195+ acc <- accessibility

196 elim <- dataOpts []

197 co <- dataI

198 ist <- get

src/Idris/ParseExpr.hs → src/Idris/Parser/Expr.hsrenamed+20−21

@@ -1,5 +1,5 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, TupleSections #-}

2−module Idris.ParseExpr where

2+module Idris.Parser.Expr where

3

4import Prelude hiding (pi)

5

@@ -12,8 +12,8 @@ import qualified Text.Parser.Char as Chr

12import qualified Text.Parser.Token.Highlight as Hi

13

14import Idris.AbsSyntax

15−import Idris.ParseHelpers

15+import Idris.Parser.Helpers

16−import Idris.ParseOps

16+import Idris.Parser.Ops

17import Idris.DSL

18

19import Idris.Core.TT

@@ -161,7 +161,7 @@ extension syn ns rules =

161 extensionSymbol (Symbol s) = do fc <- symbolFC s

162 highlightP fc AnnKeyword

163 return Nothing

164−

164+

165 flatten :: PTerm -> PTerm -- flatten application

166 flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))

167 flatten t = t

@@ -252,7 +252,7 @@ updateSynMatch = update

252

253 updTacImp ns (TacImp o st scr) = TacImp o st (update ns scr)

254 updTacImp _ x = x

255−

255+

256 dropn :: Name -> [(Name, a)] -> [(Name, a)]

257 dropn n [] = []

258 dropn n ((x,t) : xs) | n == x = xs

@@ -333,11 +333,7 @@ caseOption syn = do lhs <- expr (syn { inPattern = True })

333

334warnTacticDeprecation :: FC -> IdrisParser ()

335warnTacticDeprecation fc =

336− do ist <- get

336+ parserWarning fc (Just NoOldTacticDeprecationWarnings) (Msg "This style of tactic proof is deprecated. See %runElab for the replacement.")

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 }

341

337

342{- | Parses a proof block

338{- | Parses a proof block

343@

339@

@@ -480,7 +476,7 @@ bracketed' open syn =

480 <|> try (do l <- simpleExpr syn

476 <|> try (do l <- simpleExpr syn

481 op <- option Nothing (do o <- operator

477 op <- option Nothing (do o <- operator

482 lchar ')'

478 lchar ')'

483− return (Just o))

479+ return (Just o))

484 fc0 <- getFC

480 fc0 <- getFC

485 case op of

481 case op of

486 Nothing -> bracketedExpr syn open l

482 Nothing -> bracketedExpr syn open l

@@ -588,9 +584,9 @@ runElab syn = do (FC fn (sl, sc) kwEnd) <- try (lchar '%' *> reservedFC "runElab

588 return $ PRunElab fc tm (syn_namespace syn)

584 return $ PRunElab fc tm (syn_namespace syn)

589 <?> "new-style tactics expression"

585 <?> "new-style tactics expression"

590

586

591−{- | Parses a disambiguation expression

587+{- | Parses a disambiguation expression

592Disamb ::=

588Disamb ::=

593− '%' 'disamb' NameList Expr

589+ 'with' NameList Expr

594 ;

590 ;

595-}

591-}

596disamb :: SyntaxInfo -> IdrisParser PTerm

592disamb :: SyntaxInfo -> IdrisParser PTerm

@@ -1010,7 +1006,7 @@ Pi' ::=

1010@

1006@

1011 -}

1007 -}

1012

1008

1013−bindsymbol opts st syn

1009+bindsymbol opts st syn

1014 = do symbol "->"

1010 = do symbol "->"

1015 return (Exp opts st False)

1011 return (Exp opts st False)

1016

1012

@@ -1019,7 +1015,7 @@ explicitPi opts st syn

1019 binder <- bindsymbol opts st syn

1015 binder <- bindsymbol opts st syn

1020 sc <- expr syn

1016 sc <- expr syn

1021 return (bindList (PPi binder) xt sc)

1017 return (bindList (PPi binder) xt sc)

1022−

1018+

1023autoImplicit opts st syn

1019autoImplicit opts st syn

1024 = do kw <- reservedFC "auto"

1020 = do kw <- reservedFC "auto"

1025 when (st == Static) $ fail "auto implicits can not be static"

1021 when (st == Static) $ fail "auto implicits can not be static"

@@ -1029,7 +1025,7 @@ autoImplicit opts st syn

1029 sc <- expr syn

1025 sc <- expr syn

1030 highlightP kw AnnKeyword

1026 highlightP kw AnnKeyword

1031 return (bindList (PPi

1027 return (bindList (PPi

1032− (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing [] []]))) xt sc)

1028+ (TacImp [] Dynamic (PTactics [ProofSearch True True 100 Nothing [] []]))) xt sc)

1033

1029

1034defaultImplicit opts st syn = do

1030defaultImplicit opts st syn = do

1035 kw <- reservedFC "default"

1031 kw <- reservedFC "default"

@@ -1055,7 +1051,7 @@ normalImplicit opts st syn = do

1055 constraint)

1051 constraint)

1056 else (Imp opts st False (Just (Impl False False)),

1052 else (Imp opts st False (Just (Impl False False)),

1057 Imp opts st False (Just (Impl True False)))

1053 Imp opts st False (Just (Impl True False)))

1058− return (bindList (PPi im) xt

1054+ return (bindList (PPi im) xt

1059 (bindList (PPi cl) cs sc))

1055 (bindList (PPi cl) cs sc))

1060

1056

1061implicitPi opts st syn =

1057implicitPi opts st syn =

@@ -1389,7 +1385,11 @@ Static ::=

1389@

1385@

1390-}

1386-}

1391static :: IdrisParser Static

1387static :: IdrisParser Static

1392−static = do reserved "[static]"; return Static

1388+static = do reserved "%static"; return Static

1389+ <|> do reserved "[static]"

1390+ fc <- getFC

1391+ parserWarning fc Nothing (Msg "The use of [static] is deprecated, use %static instead.")

1392+ return Static

1393 <|> return Dynamic

1394 <?> "static modifier"

1395

@@ -1443,7 +1443,7 @@ data TacticArg = NameTArg -- ^ Names: n1, n2, n3, ... n

1443-- https://github.com/idris-lang/Idris-dev/issues/1766

1444-- | A list of available tactics and their argument requirements

1445tactics :: [([String], Maybe TacticArg, SyntaxInfo -> IdrisParser PTactic)]

1446−tactics =

1446+tactics =

1447 [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)

1448 do ns <- sepBy (spaced (fst <$> name)) (lchar ','); return $ Intro ns)

1449 , noArgs ["intros"] Intros

@@ -1527,7 +1527,7 @@ tactics =

1527 imp :: IdrisParser Bool

1528 imp = do lchar '?'; return False

1529 <|> do lchar '_'; return True

1530−

1530+

1531

1532tactic :: SyntaxInfo -> IdrisParser PTactic

1533tactic syn = choice [ do choice (map reserved names); parser syn

@@ -1550,4 +1550,3 @@ fullTactic :: SyntaxInfo -> IdrisParser PTactic

1550fullTactic syn = do t <- tactic syn

1551 eof

1552 return t

1553−

src/Idris/ParseHelpers.hs → src/Idris/Parser/Helpers.hsrenamed+68−39

@@ -2,12 +2,12 @@

2#if !(MIN_VERSION_base(4,8,0))

3{-# LANGUAGE OverlappingInstances #-}

4#endif

5−module Idris.ParseHelpers where

5+module Idris.Parser.Helpers where

6

7import Prelude hiding (pi)

8

9import Text.Trifecta.Delta

10−import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace)

10+import Text.Trifecta hiding (span, stringLiteral, charLiteral, natural, symbol, char, string, whiteSpace, Err)

11import Text.Parser.LookAhead

12import Text.Parser.Expression

13import qualified Text.Parser.Token as Tok

@@ -105,6 +105,14 @@ reportParserWarnings = do ist <- getIState

105 parserWarnings ist)

106 clearParserWarnings

107

108+

109+parserWarning :: FC -> Maybe Opt -> Err -> IdrisParser ()

110+parserWarning fc warnOpt warnErr = do

111+ ist <- get

112+ let cmdline = opt_cmdline (idris_options ist)

113+ unless (maybe False (`elem` cmdline) warnOpt) $

114+ put ist { parserWarnings = (fc, warnErr) : parserWarnings ist }

115+

108{- * Space, comments and literals (token/lexing like parsers) -}

116{- * Space, comments and literals (token/lexing like parsers) -}

109

117

110-- | Consumes any simple whitespace (any character which satisfies Char.isSpace)

118-- | Consumes any simple whitespace (any character which satisfies Char.isSpace)

@@ -237,20 +245,20 @@ float = do f <- Tok.double

237

245

238-- | Idris Style for parsing identifiers/reserved keywords

246-- | Idris Style for parsing identifiers/reserved keywords

239idrisStyle :: MonadicParsing m => IdentifierStyle m

247idrisStyle :: MonadicParsing m => IdentifierStyle m

240−idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier

248+idrisStyle = IdentifierStyle {

241− where _styleName = "Idris"

249+ _styleName = "Idris"

242− _styleStart = satisfy isAlpha <|> oneOf "_"

250+ , _styleStart = satisfy isAlpha <|> oneOf "_"

243− _styleLetter = satisfy isAlphaNum <|> oneOf "_'."

251+ , _styleLetter = satisfy isAlphaNum <|> oneOf "_'."

244− _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "corecord", "Type",

252+ , _styleReserved = HS.fromList

245− "do", "dsl", "import", "impossible",

253+ ["let", "in", "data", "codata", "record", "corecord", "Type", "do", "dsl",

246− "case", "of", "total", "partial", "mutual",

254+ "import", "impossible", "case", "of", "total", "partial", "mutual",

247− "infix", "infixl", "infixr", "rewrite",

255+ "infix", "infixl", "infixr", "rewrite", "where", "with", "syntax",

248− "where", "with", "syntax", "proof", "postulate",

256+ "proof", "postulate", "using", "namespace", "class", "instance",

249− "using", "namespace", "class", "instance",

257+ "interface", "implementation", "parameters", "public", "private",

250− "interface", "implementation", "parameters",

258+ "export", "abstract", "implicit", "quoteGoal", "constructor", "if",

251− "public", "private", "abstract", "implicit",

259+ "then", "else"]

252− "quoteGoal", "constructor",

260+ , _styleHighlight = Hi.Identifier

253− "if", "then", "else"]

261+ , _styleReservedHighlight = Hi.ReservedIdentifier }

254

262

255char :: MonadicParsing m => Char -> m Char

263char :: MonadicParsing m => Char -> m Char

256char = Chr.char

264char = Chr.char

@@ -285,7 +293,7 @@ reserved = Tok.reserve idrisStyle

285-- reserved identifiers never contain line breaks.

293-- reserved identifiers never contain line breaks.

286reservedFC :: MonadicParsing m => String -> m FC

294reservedFC :: MonadicParsing m => String -> m FC

287reservedFC str = do (FC file (l, c) _) <- getFC

295reservedFC str = do (FC file (l, c) _) <- getFC

288− Tok.reserve idrisStyle str

296+ reserved str

289 return $ FC file (l, c) (l, c + length str)

297 return $ FC file (l, c) (l, c + length str)

290

298

291-- | Parse a reserved identfier, highlighting its span as a keyword

299-- | Parse a reserved identfier, highlighting its span as a keyword

@@ -300,10 +308,9 @@ reservedOp name = token $ try $

300 notFollowedBy (operatorLetter) <?> ("end of " ++ show name)

308 notFollowedBy (operatorLetter) <?> ("end of " ++ show name)

301

309

302reservedOpFC :: MonadicParsing m => String -> m FC

310reservedOpFC :: MonadicParsing m => String -> m FC

303−reservedOpFC name = token $ try $ do (FC f (l, c) _) <- getFC

311+reservedOpFC name = do (FC f (l, c) _) <- getFC

304− string name

312+ reservedOp name

305− notFollowedBy (operatorLetter) <?> ("end of " ++ show name)

313+ return (FC f (l, c) (l, c + length name))

306− return (FC f (l, c) (l, c + length name))

307

314

308-- | Parses an identifier as a token

315-- | Parses an identifier as a token

309identifier :: (MonadicParsing m) => m (String, FC)

316identifier :: (MonadicParsing m) => m (String, FC)

@@ -385,7 +392,7 @@ commentMarkers :: [String]

385commentMarkers = [ "--", "|||" ]

392commentMarkers = [ "--", "|||" ]

386

393

387invalidOperators :: [String]

394invalidOperators :: [String]

388−invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!"]

395+invalidOperators = [":", "=>", "->", "<-", "=", "?=", "|", "**", "==>", "\\", "%", "~", "?", "!", "@"]

389

396

390-- | Parses an operator

397-- | Parses an operator

391operator :: MonadicParsing m => m String

398operator :: MonadicParsing m => m String

@@ -396,12 +403,9 @@ operator = do op <- token . some $ operatorLetter

396

403

397-- | Parses an operator

404-- | Parses an operator

398operatorFC :: MonadicParsing m => m (String, FC)

405operatorFC :: MonadicParsing m => m (String, FC)

399−operatorFC = do (op, fc) <- token $ do (FC f (l, c) _) <- getFC

406+operatorFC = do (FC f (l, c) _) <- getFC

400− op <- some operatorLetter

407+ op <- operator

401− return (op, FC f (l, c) (l, c + length op))

408+ 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)

405

409

406{- * Position helpers -}

410{- * Position helpers -}

407{- | Get filename from position (returns "(interactive)" when no source file is given) -}

411{- | Get filename from position (returns "(interactive)" when no source file is given) -}

@@ -612,22 +616,47 @@ notOpenBraces = do ist <- get

612 hasNothing = any isNothing

616 hasNothing = any isNothing

613

617

614{- | Parses an accessibilty modifier (e.g. public, private) -}

618{- | Parses an accessibilty modifier (e.g. public, private) -}

615−accessibility :: IdrisParser Accessibility

619+accessibility' :: IdrisParser Accessibility

616−accessibility = do reserved "public"; return Public

620+accessibility'

617− <|> do reserved "abstract"; return Frozen

621+ = do reserved "public";

618− <|> do reserved "private"; return Hidden

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

619 <?> "accessibility modifier"

641 <?> "accessibility modifier"

620

642

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+

621-- | Adds accessibility option for function

650-- | Adds accessibility option for function

622−addAcc :: Name -> Maybe Accessibility -> IdrisParser ()

651+addAcc :: Name -> Accessibility -> IdrisParser ()

623addAcc n a = do i <- get

652addAcc 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) })

625

654

626{- | Add accessbility option for data declarations

655{- | Add accessbility option for data declarations

627 (works for classes too - 'abstract' means the data/class is visible but members not) -}

656 (works for classes too - 'abstract' means the data/class is visible but members not) -}

628−accData :: Maybe Accessibility -> Name -> [Name] -> IdrisParser ()

657+accData :: Accessibility -> Name -> [Name] -> IdrisParser ()

629−accData (Just Frozen) n ns = do addAcc n (Just Frozen)

658+accData Frozen n ns = do addAcc n Public -- so that it can be used in public definitions

630− mapM_ (\n -> addAcc n (Just Hidden)) ns

659+ mapM_ (\n -> addAcc n Private) ns -- so that they are invisible

631accData a n ns = do addAcc n a

660accData a n ns = do addAcc n a

632 mapM_ (`addAcc` a) ns

661 mapM_ (`addAcc` a) ns

633

662

@@ -662,7 +691,7 @@ collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds

662collect (PNamespace ns fc ps : ds) = PNamespace ns fc (collect ps) : collect ds

691collect (PNamespace ns fc ps : ds) = PNamespace ns fc (collect ps) : collect ds

663collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')

692collect (PClass doc f s cs n nfc ps pdocs fds ds cn cd : ds')

664 = PClass doc f s cs n nfc ps pdocs fds (collect ds) cn cd : collect ds'

693 = 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')

694+collect (PInstance doc argDocs f s cs acc opts n nfc ps t en ds : ds')

666− = PInstance doc argDocs f s cs n nfc ps t en (collect ds) : collect ds'

695+ = PInstance doc argDocs f s cs acc opts n nfc ps t en (collect ds) : collect ds'

667collect (d : ds) = d : collect ds

696collect (d : ds) = d : collect ds

668collect [] = []

697collect [] = []

src/Idris/ParseOps.hs → src/Idris/Parser/Ops.hsrenamed+2−3

@@ -1,5 +1,5 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−module Idris.ParseOps where

2+module Idris.Parser.Ops where

3

4import Prelude hiding (pi)

5

@@ -12,7 +12,7 @@ import qualified Text.Parser.Char as Chr

12import qualified Text.Parser.Token.Highlight as Hi

13

14import Idris.AbsSyntax

15−import Idris.ParseHelpers

15+import Idris.Parser.Helpers

16

17import Idris.Core.TT

18

@@ -170,4 +170,3 @@ fixityType = do reserved "infixl"; return Infixl

170 <|> do reserved "infix"; return InfixN

171 <|> do reserved "prefix"; return PrefixN

172 <?> "fixity type"

173−

src/Idris/ProofSearch.hs+40−57

@@ -48,13 +48,13 @@ trivialHoles psnames ok elab ist

48 then try' (elab (PRef (fileFC "prf") [] x))

49 (tryAll xs) True

50 else tryAll xs

51−

51+

52 holesOK hs ap@(App _ _ _)

53 | (P _ n _, args) <- unApply ap

54 = holeArgsOK hs n 0 args

55 holesOK hs (App _ f a) = holesOK hs f && holesOK hs a

56 holesOK hs (P _ n _) = not (n `elem` hs)

57− holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&

57+ holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&

58 holesOK hs sc

59 holesOK hs _ = True

60

@@ -85,8 +85,8 @@ trivialTCs ok elab ist

85 then try' (elab (PRef (fileFC "prf") [] x))

86 (tryAll xs) True

87 else tryAll xs

88−

88+

89− tcArg env ty

89+ tcArg env ty

90 | (P _ n _, args) <- unApply (getRetTy (normalise (tt_ctxt ist) env ty))

91 = case lookupCtxtExact n (idris_classes ist) of

92 Just _ -> True

@@ -98,7 +98,7 @@ trivialTCs ok elab ist

98 = holeArgsOK hs n 0 args

99 holesOK hs (App _ f a) = holesOK hs f && holesOK hs a

100 holesOK hs (P _ n _) = not (n `elem` hs)

101− holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&

101+ holesOK hs (Bind n b sc) = holesOK hs (binderTy b) &&

102 holesOK hs sc

103 holesOK hs _ = True

104

@@ -111,16 +111,16 @@ cantSolveGoal :: ElabD a

111cantSolveGoal = do g <- goal

112 env <- get_env

113 lift $ tfail $

114− CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env)

114+ CantSolveGoal g (map (\(n,b) -> (n, binderTy b)) env)

115

116−proofSearch :: Bool -> -- recursive search (False for 'refine')

116+proofSearch :: Bool -> -- recursive search (False for 'refine')

117 Bool -> -- invoked from a tactic proof. If so, making

118 -- new metavariables is meaningless, and there shoudl

119 -- be an error reported instead.

120 Bool -> -- ambiguity ok

121 Bool -> -- defer on failure

122 Int -> -- maximum depth

123− (PTerm -> ElabD ()) -> Maybe Name -> Name ->

123+ (PTerm -> ElabD ()) -> Maybe Name -> Name ->

124 [Name] ->

125 [Name] ->

126 IState -> ElabD ()

@@ -131,7 +131,7 @@ proofSearch False fromProver ambigok deferonfail depth elab _ nroot psnames [fn]

131 tryAllFns all_imps

132 where

133 -- if nothing worked, make a new metavariable

134− tryAllFns [] | fromProver = cantSolveGoal

134+ tryAllFns [] | fromProver = cantSolveGoal

135 tryAllFns [] = do attack; defer [] nroot; solve

136 tryAllFns (f : fs) = try' (tryFn f) (tryAllFns fs) True

137

@@ -142,20 +142,20 @@ proofSearch False fromProver ambigok deferonfail depth elab _ nroot psnames [fn]

142 (match_apply (Var f) imps) True

143 ps' <- get_probs

144-- when (length ps < length ps') $ fail "Can't apply constructor"

145− -- Make metavariables for new holes

145+ -- Make metavariables for new holes

146 hs' <- get_holes

147 ptm <- get_term

148 if fromProver then cantSolveGoal

149 else do

150 mapM_ (\ h -> do focus h

151− attack; defer [] nroot; solve)

151+ attack; defer [] nroot; solve)

152 (hs' \\ hs)

153-- (filter (\ (x, y) -> not x) (zip (map fst imps) args))

154 solve

155

156 isImp (PImp p _ _ _ _) = (True, p)

157 isImp arg = (True, priority arg) -- try to get all of them by unification

158−proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hints ist

158+proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hints ist

159 = do compute

160 ty <- goal

161 hs <- get_holes

@@ -172,7 +172,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

172 (autoArg (sUN "auto"))

173 else autoArg (sUN "auto") -- not enough info in the type yet

174 where

175− findInferredTy (t : _) = elab (delab ist (toUN t))

175+ findInferredTy (t : _) = elab (delab ist (toUN t))

176

177 cantsolve (InternalMsg _) = True

178 cantsolve (CantSolveGoal _ _) = True

@@ -185,12 +185,12 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

185 conArgsOK ty

186 = let (f, as) = unApply ty in

187 case f of

188− P _ n _ ->

188+ P _ n _ ->

189 let autohints = case lookupCtxtExact n (idris_autohints ist) of

190 Nothing -> []

191 Just hs -> hs in

192 case lookupCtxtExact n (idris_datatypes ist) of

193− Just t -> do rs <- mapM (conReady as)

193+ Just t -> do rs <- mapM (conReady as)

194 (autohints ++ con_names t)

195 return (and rs)

196 Nothing -> -- local variable, go for it

@@ -199,7 +199,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

199 _ -> typeNotSearchable ty

200

201 conReady :: [Term] -> Name -> ElabD Bool

202− conReady as n

202+ conReady as n

203 = case lookupTyExact n (tt_ctxt ist) of

204 Just ty -> do let (_, cs) = unApply (getRetTy ty)

205 -- if any metavariables in 'as' correspond to

@@ -223,7 +223,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

223 inHS hs (P _ n _) = n `elem` hs

224 isHS _ _ = False

225

226− toUN t@(P nt (MN i n) ty)

226+ toUN t@(P nt (MN i n) ty)

227 | ('_':xs) <- str n = t

228 | otherwise = P nt (UN n) ty

229 toUN (App s f a) = App s (toUN f) (toUN a)

@@ -239,7 +239,7 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

239 psRec :: Bool -> Int -> [Name] -> S.Set Type -> ElabD ()

240 psRec _ 0 locs tys | fromProver = cantSolveGoal

241 psRec rec 0 locs tys = do attack; defer [] nroot; solve --fail "Maximum depth reached"

242− psRec False d locs tys = tryCons d locs tys hints

242+ psRec False d locs tys = tryCons d locs tys hints

243 psRec True d locs tys

244 = do compute

245 ty <- goal

@@ -248,11 +248,11 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

248 try' (try' (trivialHoles psnames [] elab ist)

249 (resolveTC False False 20 ty nroot elab ist)

250 True)

251− (try' (try' (resolveByCon (d - 1) locs tys')

251+ (try' (try' (resolveByCon (d - 1) locs tys')

252 (resolveByLocals (d - 1) locs tys')

253 True)

254 -- if all else fails, make a new metavariable

255− (if fromProver

255+ (if fromProver

256 then fail "cantSolveGoal"

257 else do attack; defer [] nroot; solve) True) True

258

@@ -269,18 +269,13 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

269 = do t <- goal

270 let (f, _) = unApply t

271 case f of

272− P _ n _ ->

272+ P _ n _ ->

273 do let autohints = case lookupCtxtExact n (idris_autohints ist) of

274 Nothing -> []

275 Just hs -> hs

276 case lookupCtxtExact n (idris_datatypes ist) of

277 Just t -> do

278 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

284 tryCons d locs tys (others ++ getFn d fn)

279 tryCons d locs tys (others ++ getFn d fn)

285 Nothing -> typeNotSearchable t

280 Nothing -> typeNotSearchable t

286 _ -> typeNotSearchable t

281 _ -> typeNotSearchable t

@@ -292,26 +287,26 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

292 tryLocals d locs tys env

287 tryLocals d locs tys env

293

288

294 tryLocals d locs tys [] = fail "Locals failed"

289 tryLocals d locs tys [] = fail "Locals failed"

295− tryLocals d locs tys ((x, t) : xs)

290+ tryLocals d locs tys ((x, t) : xs)

296 | x `elem` locs || x `notElem` psnames = tryLocals d locs tys xs

291 | 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)

298 (tryLocals d locs tys xs) True

293 (tryLocals d locs tys xs) True

299

294

300 tryCons d locs tys [] = fail "Constructors failed"

295 tryCons d locs tys [] = fail "Constructors failed"

301− tryCons d locs tys (c : cs)

296+ tryCons d locs tys (c : cs)

302 = try' (tryCon d locs tys c) (tryCons d locs tys cs) True

297 = try' (tryCon d locs tys c) (tryCons d locs tys cs) True

303

298

304− tryLocal d locs tys n t

299+ tryLocal d locs tys n t

305 = do let a = getPArity (delab ist (binderTy t))

300 = do let a = getPArity (delab ist (binderTy t))

306 tryLocalArg d locs tys n a

301 tryLocalArg d locs tys n a

307

302

308 tryLocalArg d locs tys n 0 = elab (PRef (fileFC "prf") [] n)

303 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

310 = simple_app False (tryLocalArg d locs tys n (i - 1))

305 = simple_app False (tryLocalArg d locs tys n (i - 1))

311 (psRec True d locs tys) "proof search local apply"

306 (psRec True d locs tys) "proof search local apply"

312

307

313 -- Like type class resolution, but searching with constructors

308 -- Like type class resolution, but searching with constructors

314− tryCon d locs tys n =

309+ tryCon d locs tys n =

315 do ty <- goal

310 do ty <- goal

316 let imps = case lookupCtxtExact n (idris_implicits ist) of

311 let imps = case lookupCtxtExact n (idris_implicits ist) of

317 Nothing -> []

312 Nothing -> []

@@ -341,23 +336,6 @@ proofSearch rec fromProver ambigok deferonfail maxDepth elab fn nroot psnames hi

341 (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."]

336 (Bind _ (Pi _ _ _) _) -> [TextPart "In particular, function types are not supported."]

342 _ -> []

337 _ -> []

343

338

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−

361-- | Resolve type classes. This will only pick up 'normal' instances, never

339-- | Resolve type classes. This will only pick up 'normal' instances, never

362-- named instances (which is enforced by 'findInstances').

340-- named instances (which is enforced by 'findInstances').

363resolveTC :: Bool -- ^ using default Int

341resolveTC :: Bool -- ^ using default Int

@@ -383,8 +361,10 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

383 let (argsok, okholePos) = case tcArgsOK g topholes of

361 let (argsok, okholePos) = case tcArgsOK g topholes of

384 Nothing -> (False, [])

362 Nothing -> (False, [])

385 Just hs -> (True, hs)

363 Just hs -> (True, hs)

364+ env <- get_env

365+ probs <- get_probs

386 if not argsok -- && not mvok)

366 if not argsok -- && not mvok)

387− then lift $ tfail $ CantResolve True topg

367+ then lift $ tfail $ CantResolve True topg (probErr probs)

388 else do

368 else do

389 ptm <- get_term

369 ptm <- get_term

390 ulog <- getUnifyLog

370 ulog <- getUnifyLog

@@ -397,7 +377,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

397 _ -> []

377 _ -> []

398

378

399 traceWhen ulog ("Resolving class " ++ show g ++ "\nin" ++ show env ++ "\n" ++ show okholes) $

379 traceWhen ulog ("Resolving class " ++ show g ++ "\nin" ++ show env ++ "\n" ++ show okholes) $

400− try' (trivialTCs okholes elab ist)

380+ try' (trivialTCs okholes elab ist)

401 (do addDefault t tc ttypes

381 (do addDefault t tc ttypes

402 let stk = map fst (filter snd $ elab_stack ist)

382 let stk = map fst (filter snd $ elab_stack ist)

403 let insts = findInstances ist t

383 let insts = findInstances ist t

@@ -431,8 +411,11 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

431 _ -> Just rs

411 _ -> Just rs

432 tcDetArgsOK _ _ _ [] = Just []

412 tcDetArgsOK _ _ _ [] = Just []

433

413

414+ probErr [] = Msg ""

415+ probErr ((_,_,_,_,err,_,_) : _) = err

416+

434 isMeta :: [Name] -> Term -> Bool

417 isMeta :: [Name] -> Term -> Bool

435− isMeta ns (P _ n _) = n `elem` ns

418+ isMeta ns (P _ n _) = n `elem` ns

436 isMeta _ _ = False

419 isMeta _ _ = False

437

420

438 notHole hs (P _ n _, c)

421 notHole hs (P _ n _, c)

@@ -449,7 +432,7 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

449 chaser (NS n _) = chaser n

432 chaser (NS n _) = chaser n

450 chaser _ = False

433 chaser _ = False

451

434

452− numclass = sNS (sUN "Num") ["Classes","Prelude"]

435+ numclass = sNS (sUN "Num") ["Interfaces","Prelude"]

453

436

454 addDefault t num@(P _ nc _) [P Bound a _] | nc == numclass && defaultOn

437 addDefault t num@(P _ nc _) [P Bound a _] | nc == numclass && defaultOn

455 = do focus a

438 = do focus a

@@ -462,12 +445,13 @@ resTC' tcs defaultOn topholes depth topg fn elab ist

462 boundVar (P Bound _ _) = True

445 boundVar (P Bound _ _) = True

463 boundVar _ = False

446 boundVar _ = False

464

447

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)

466 blunderbuss t d stk (n:ns)

450 blunderbuss t d stk (n:ns)

467 | n /= fn -- && (n `elem` stk)

451 | n /= fn -- && (n `elem` stk)

468 = tryCatch (resolve n d)

452 = tryCatch (resolve n d)

469 (\e -> case e of

453 (\e -> case e of

470− CantResolve True _ -> lift $ tfail e

454+ CantResolve True _ _ -> lift $ tfail e

471 _ -> blunderbuss t d stk ns)

455 _ -> blunderbuss t d stk ns)

472 | otherwise = blunderbuss t d stk ns

456 | otherwise = blunderbuss t d stk ns

473

457

@@ -529,6 +513,5 @@ findInstances ist t

529 | otherwise = []

513 | otherwise = []

530 where accessible n = case lookupDefAccExact n False (tt_ctxt ist) of

514 where accessible n = case lookupDefAccExact n False (tt_ctxt ist) of

531 Just (_, Hidden) -> False

515 Just (_, Hidden) -> False

516+ Just (_, Private) -> False

532 _ -> True

517 _ -> True

533−

534−

src/Idris/Prover.hs+25−8

@@ -85,7 +85,7 @@ assumptionNames e

85

86prove :: Bool -> Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()

87prove 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

89 idemodePutSExp "start-proof-mode" n

90 (tm, prf) <-

91 if mode

@@ -124,7 +124,7 @@ prove mode opt ctxt lit n ty

124 [([], P Ref n ty, ptm')] ty

125 ctxt

126 setContext ctxt'

127− solveDeferred n

127+ solveDeferred emptyFC n

128 case idris_outputmode i of

129 IdeMode n h ->

130 runIO . hPutStrLn h $ IdeMode.convSExp "return" (IdeMode.SymbolAtom "ok", "") n

@@ -271,6 +271,21 @@ undoElab prf env st [] = ifail "Nothing to undo"

271undoElab prf env st (h:hs) = do (prf', env', st') <- undoStep prf env st h

272 return (prf', env', st', hs)

273

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

274

289

275elabloop :: Name -> Bool -> String -> [String] -> ElabState EState -> [ElabShellHistory] -> Maybe History -> [(Name, Type, Term)] -> Idris (Term, [String])

290elabloop :: Name -> Bool -> String -> [String] -> ElabState EState -> [ElabShellHistory] -> Maybe History -> [(Name, Type, Term)] -> Idris (Term, [String])

276elabloop fn d prompt prf e prev h env

291elabloop fn d prompt prf e prev h env

@@ -283,7 +298,7 @@ elabloop fn d prompt prf e prev h env

283 do case h of

298 do case h of

284 Just history -> putHistory history

299 Just history -> putHistory history

285 Nothing -> return ()

300 Nothing -> return ()

286− l <- getInputLine (prompt ++ "> ")

301+ l <- handleInterrupt (return $ Just "") $ withInterrupt $ getInputLine (prompt ++ "> ")

287 h' <- getHistory

302 h' <- getHistory

288 return (l, Just h')

303 return (l, Just h')

289 IdeMode _ handle ->

304 IdeMode _ handle ->

@@ -375,8 +390,9 @@ elabloop fn d prompt prf e prev h env

375 Right ok ->

390 Right ok ->

376 if done then do (tm, _) <- elabStep st get_term

391 if done then do (tm, _) <- elabStep st get_term

377 return (tm, prf')

392 return (tm, prf')

378− else do ok

393+ else runWithInterrupt e ok

379− elabloop fn d prompt prf' st prev' h' env'

394+ (elabloop fn d prompt prf' st prev' h' env')

395+ (elabloop fn d prompt prf e prev h' env)

380

396

381 where

397 where

382 -- A bit of a hack: wrap the value up in a let binding, which will

398 -- 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

401 do case h of

417 do case h of

402 Just history -> putHistory history

418 Just history -> putHistory history

403 Nothing -> return ()

419 Nothing -> return ()

404− l <- getInputLine (prompt ++ "> ")

420+ l <- handleInterrupt (return $ Just "") $ withInterrupt $ getInputLine (prompt ++ "> ")

405 h' <- getHistory

421 h' <- getHistory

406 return (l, Just h')

422 return (l, Just h')

407 IdeMode _ handle ->

423 IdeMode _ handle ->

@@ -445,8 +461,9 @@ ploop fn d prompt prf e h

445 Right ok ->

461 Right ok ->

446 if done then do (tm, _) <- elabStep st get_term

462 if done then do (tm, _) <- elabStep st get_term

447 return (tm, prf')

463 return (tm, prf')

448− else do ok

464+ else runWithInterrupt e ok

449− ploop fn d prompt prf' st h'

465+ (ploop fn d prompt prf' st h')

466+ (ploop fn d prompt prf e h')

450

467

451

468

452envCtxt env ctxt = foldl (\c (n, b) -> addTyDecl n Bound (binderTy b) c) ctxt env

469envCtxt 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,

8import Idris.AbsSyntax

9import Idris.ASTUtils

10import Idris.Apropos (apropos, aproposModules)

11−import Idris.REPLParser

11+import Idris.REPL.Parser

12−import Idris.ElabDecls

13import Idris.Erasure

12import Idris.Erasure

14import Idris.Error

13import Idris.Error

14+import Idris.IBC

15import Idris.ErrReverse

16import Idris.Delaborate

17import Idris.Docstrings (Docstring, overview, renderDocstring, renderDocTerm)

@@ -38,6 +38,7 @@ import Idris.IBC (loadPkgIndex, writePkgIndex)

38

39import Idris.REPL.Browse (namesInNS, namespacesInNS)

40

41+import Idris.ElabDecls

41import Idris.Elab.Type

42import Idris.Elab.Type

42import Idris.Elab.Clause

43import Idris.Elab.Clause

43import Idris.Elab.Data

44import Idris.Elab.Data

@@ -121,13 +122,13 @@ repl orig mods efile

121 (if colour && not isWindows

122 (if colour && not isWindows

122 then colourisePrompt theme str

123 then colourisePrompt theme str

123 else str) ++ " "

124 else str) ++ " "

124− x <- H.catch (getInputLine prompt)

125+ x <- H.catch (H.withInterrupt $ getInputLine prompt)

125− (ctrlC (return Nothing))

126+ (ctrlC (return $ Just ""))

126 case x of

127 case x of

127 Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

128 Nothing -> do lift $ when (not quiet) (iputStrLn "Bye bye")

128 return ()

129 return ()

129 Just input -> -- H.catch

130 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)

131 (ctrlC (return (Just mods)))

132 (ctrlC (return (Just mods)))

132 case ms of

133 case ms of

133 Just mods -> let efile' = fromMaybe efile (listToMaybe mods)

134 Just mods -> let efile' = fromMaybe efile (listToMaybe mods)

@@ -690,9 +691,9 @@ reload orig inputs = do

690

691

691watch :: IState -> [FilePath] -> Idris (Maybe [FilePath])

692watch :: IState -> [FilePath] -> Idris (Maybe [FilePath])

692watch orig inputs = do

693watch orig inputs = do

693− let inputSet = S.fromList inputs

694− let dirs = nub $ map takeDirectory inputs

695 resp <- runIO $ do

694 resp <- runIO $ do

695+ let dirs = nub $ map takeDirectory inputs

696+ inputSet <- fmap S.fromList $ mapM canonicalizePath inputs

696 signal <- newEmptyMVar

697 signal <- newEmptyMVar

697 withManager $ \mgr -> do

698 withManager $ \mgr -> do

698 forM_ dirs $ \dir ->

699 forM_ dirs $ \dir ->

@@ -735,7 +736,7 @@ processInput cmd orig inputs efile

735 return (Just mod)

736 return (Just mod)

736 Success (Right (ModImport f)) ->

737 Success (Right (ModImport f)) ->

737 do clearErr

738 do clearErr

738− fmod <- loadModule f

739+ fmod <- loadModule f (IBC_REPL True)

739 return (Just (inputs ++ maybe [] (:[]) fmod))

740 return (Just (inputs ++ maybe [] (:[]) fmod))

740 Success (Right Edit) -> do -- takeMVar stvar

741 Success (Right Edit) -> do -- takeMVar stvar

741 edit efile orig

742 edit efile orig

@@ -817,7 +818,7 @@ process fn Warranty = iPrintResult warranty

817process fn (ChangeDirectory f)

818process fn (ChangeDirectory f)

818 = do runIO $ setCurrentDirectory f

819 = do runIO $ setCurrentDirectory f

819 return ()

820 return ()

820−process fn (ModImport f) = do fmod <- loadModule f

821+process fn (ModImport f) = do fmod <- loadModule f (IBC_REPL True)

821 case fmod of

822 case fmod of

822 Just pr -> isetPrompt pr

823 Just pr -> isetPrompt pr

823 Nothing -> iPrintError $ "Can't find import " ++ f

824 Nothing -> iPrintError $ "Can't find import " ++ f

@@ -901,8 +902,8 @@ process fn (NewDefn decls) = do

901 fixClauses :: PDecl' t -> PDecl' t

902 fixClauses :: PDecl' t -> PDecl' t

902 fixClauses (PClauses fc opts _ css@(clause:cs)) =

903 fixClauses (PClauses fc opts _ css@(clause:cs)) =

903 PClauses fc opts (getClauseName clause) css

904 PClauses fc opts (getClauseName clause) css

904− fixClauses (PInstance doc argDocs syn fc constraints cls nfc parms ty instName decls) =

905+ fixClauses (PInstance doc argDocs syn fc constraints acc opts cls nfc parms ty instName decls) =

905− PInstance doc argDocs syn fc constraints cls nfc parms ty instName (map fixClauses decls)

906+ PInstance doc argDocs syn fc constraints acc opts cls nfc parms ty instName (map fixClauses decls)

906 fixClauses decl = decl

907 fixClauses decl = decl

907

908

908process fn (Undefine names) = undefine names

909process fn (Undefine names) = undefine names

@@ -958,8 +959,8 @@ process fn (Check (PRef _ _ n))

958 case lookupNames n ctxt of

959 case lookupNames n ctxt of

959 ts@(t:_) ->

960 ts@(t:_) ->

960 case lookup t (idris_metavars ist) of

961 case lookup t (idris_metavars ist) of

961− Just (_, i, _, _) -> iRenderResult . fmap (fancifyAnnots ist True) $

962+ Just (_, i, _, _, _) -> iRenderResult . fmap (fancifyAnnots ist True) $

962− showMetavarInfo ppo ist n i

963+ showMetavarInfo ppo ist n i

963 Nothing -> iPrintFunTypes [] n (map (\n -> (n, pprintDelabTy ist n)) ts)

964 Nothing -> iPrintFunTypes [] n (map (\n -> (n, pprintDelabTy ist n)) ts)

964 [] -> iPrintError $ "No such variable " ++ show n

965 [] -> iPrintError $ "No such variable " ++ show n

965 where

966 where

@@ -1089,7 +1090,7 @@ process fn (DebugInfo n)

1089 when (not (null di)) $ iputStrLn (show di)

1090 when (not (null di)) $ iputStrLn (show di)

1090 let imps = lookupCtxt n (idris_implicits i)

1091 let imps = lookupCtxt n (idris_implicits i)

1091 when (not (null imps)) $ iputStrLn (show imps)

1092 when (not (null imps)) $ iputStrLn (show imps)

1092− let d = lookupDef n (tt_ctxt i)

1093+ let d = lookupDefAcc n False (tt_ctxt i)

1093 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

1094 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

1094 let cg = lookupCtxtName n (idris_callgraph i)

1095 let cg = lookupCtxtName n (idris_callgraph i)

1095 i <- getIState

1096 i <- getIState

@@ -1138,7 +1139,7 @@ process fn (RmProof n')

1138 insertMetavar n =

1139 insertMetavar n =

1139 do i <- getIState

1140 do i <- getIState

1140 let ms = idris_metavars i

1141 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 }

1142

1143

1143process fn' (AddProof prf)

1144process fn' (AddProof prf)

1144 = do fn <- do

1145 = do fn <- do

@@ -1191,8 +1192,9 @@ process fn (Prove mode n')

1191 let metavars = mapMaybe (\n -> do c <- lookup n (idris_metavars ist); return (n, c)) ns

1192 let metavars = mapMaybe (\n -> do c <- lookup n (idris_metavars ist); return (n, c)) ns

1192 n <- case metavars of

1193 n <- case metavars of

1193 [] -> ierror (Msg $ "Cannot find metavariable " ++ show n')

1194 [] -> ierror (Msg $ "Cannot find metavariable " ++ show n')

1194− [(n, (_,_,_,False))] -> return n

1195+ [(n, (_,_,_,False,_))] -> return n

1195− [(_, (_,_,_,True))] -> ierror (Msg $ "Declarations not solvable using prover")

1196+ [(_, (_,_,_,_,False))] -> ierror (Msg $ "Can't prove this hole as it depends on other holes")

1197+ [(_, (_,_,_,True,_))] -> ierror (Msg $ "Declarations not solvable using prover")

1196 ns -> ierror (CantResolveAlts (map fst ns))

1198 ns -> ierror (CantResolveAlts (map fst ns))

1197 prover mode (lit fn) n

1199 prover mode (lit fn) n

1198 -- recheck totality

1200 -- recheck totality

@@ -1238,12 +1240,15 @@ process fn (Compile codegen f)

1238 iPrintError $ "Invalid filename for compiler output \"" ++ f ++"\""

1240 iPrintError $ "Invalid filename for compiler output \"" ++ f ++"\""

1239 | otherwise = do opts <- getCmdLine

1241 | otherwise = do opts <- getCmdLine

1240 let iface = Interface `elem` opts

1242 let iface = Interface `elem` opts

1243+ let mainname = sNS (sUN "main") ["Main"]

1244+

1241 m <- if iface then return Nothing else

1245 m <- if iface then return Nothing else

1242 do (m', _) <- elabVal recinfo ERHS

1246 do (m', _) <- elabVal recinfo ERHS

1243 (PApp fc (PRef fc [] (sUN "run__IO"))

1247 (PApp fc (PRef fc [] (sUN "run__IO"))

1244− [pexp $ PRef fc [] (sNS (sUN "main") ["Main"])])

1248+ [pexp $ PRef fc [] mainname])

1245 return (Just m')

1249 return (Just m')

1246 ir <- compile codegen f m

1250 ir <- compile codegen f m

1251+

1247 i <- getIState

1252 i <- getIState

1248 runIO $ generate codegen (fst (head (idris_imported i))) ir

1253 runIO $ generate codegen (fst (head (idris_imported i))) ir

1249 where fc = fileFC "main"

1254 where fc = fileFC "main"

@@ -1559,7 +1564,7 @@ loadInputs inputs toline -- furthest line to read in input source files

1559 logParser 1 ("MODULE TREE : " ++ show modTree)

1564 logParser 1 ("MODULE TREE : " ++ show modTree)

1560 logParser 1 ("RELOAD: " ++ show ifiles)

1565 logParser 1 ("RELOAD: " ++ show ifiles)

1561 when (not (all ibc ifiles) || loadCode) $

1566 when (not (all ibc ifiles) || loadCode) $

1562− tryLoad False (filter (not . ibc) ifiles)

1567+ tryLoad False IBC_Building (filter (not . ibc) ifiles)

1563 -- return the files that need rechecking

1568 -- return the files that need rechecking

1564 return (input, ifiles))

1569 return (input, ifiles))

1565 ninputs

1570 ninputs

@@ -1570,7 +1575,8 @@ loadInputs inputs toline -- furthest line to read in input source files

1570 Nothing ->

1575 Nothing ->

1571 do putIState $!! ist { idris_tyinfodata = tidata }

1576 do putIState $!! ist { idris_tyinfodata = tidata }

1572 ibcfiles <- mapM findNewIBC (nub (concat (map snd ifiles)))

1577 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)

1574 _ -> return ()

1580 _ -> return ()

1575 exports <- findExports

1581 exports <- findExports

1576

1582

@@ -1590,9 +1596,9 @@ loadInputs inputs toline -- furthest line to read in input source files

1590 iWarn emptyFC $ pprintErr i e

1596 iWarn emptyFC $ pprintErr i e

1591 return [])

1597 return [])

1592 where -- load all files, stop if any fail

1598 where -- load all files, stop if any fail

1593− tryLoad :: Bool -> [IFileType] -> Idris ()

1599+ tryLoad :: Bool -> IBCPhase -> [IFileType] -> Idris ()

1594− tryLoad keepstate [] = warnTotality >> return ()

1600+ tryLoad keepstate phase [] = warnTotality >> return ()

1595− tryLoad keepstate (f : fs)

1601+ tryLoad keepstate phase (f : fs)

1596 = do ist <- getIState

1602 = do ist <- getIState

1597 let maxline

1603 let maxline

1598 = case toline of

1604 = case toline of

@@ -1605,7 +1611,7 @@ loadInputs inputs toline -- furthest line to read in input source files

1605 then Just l

1611 then Just l

1606 else Nothing

1612 else Nothing

1607 _ -> Nothing

1613 _ -> Nothing

1608− loadFromIFile True f maxline

1614+ loadFromIFile True phase f maxline

1609 inew <- getIState

1615 inew <- getIState

1610 -- FIXME: Save these in IBC to avoid this hack! Need to

1616 -- FIXME: Save these in IBC to avoid this hack! Need to

1611 -- preserve it all from source inputs

1617 -- preserve it all from source inputs

@@ -1615,15 +1621,16 @@ loadInputs inputs toline -- furthest line to read in input source files

1615 let tidata = idris_tyinfodata inew

1621 let tidata = idris_tyinfodata inew

1616 let patdefs = idris_patdefs inew

1622 let patdefs = idris_patdefs inew

1617 ok <- noErrors

1623 ok <- noErrors

1618− when ok $

1624+ if ok then

1619− -- The $!! here prevents a space leak on reloading.

1625+ -- The $!! here prevents a space leak on reloading.

1620− -- This isn't a solution - but it's a temporary stopgap.

1626+ -- This isn't a solution - but it's a temporary stopgap.

1621− -- See issue #2386

1627+ -- See issue #2386

1622− do when (not keepstate) $ putIState $!! ist

1628+ do when (not keepstate) $ putIState $!! ist

1623− ist <- getIState

1629+ ist <- getIState

1624− putIState $!! ist { idris_tyinfodata = tidata,

1630+ putIState $!! ist { idris_tyinfodata = tidata,

1625− idris_patdefs = patdefs }

1631+ idris_patdefs = patdefs }

1626− tryLoad keepstate fs

1632+ tryLoad keepstate phase fs

1633+ else warnTotality

1627

1634

1628 ibc (IBC _ _) = True

1635 ibc (IBC _ _) = True

1629 ibc _ = False

1636 ibc _ = False

@@ -1727,13 +1734,12 @@ idrisMain opts =

1727 addPkgDir "base"

1734 addPkgDir "base"

1728 mapM_ addPkgDir pkgdirs

1735 mapM_ addPkgDir pkgdirs

1729 elabPrims

1736 elabPrims

1730− when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins"

1737+ when (not (NoBuiltins `elem` opts)) $ do x <- loadModule "Builtins" (IBC_REPL True)

1731 addAutoImport "Builtins"

1738 addAutoImport "Builtins"

1732 return ()

1739 return ()

1733− when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"

1740+ when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude" (IBC_REPL True)

1734 addAutoImport "Prelude"

1741 addAutoImport "Prelude"

1735 return ()

1742 return ()

1736−

1737 when (runrepl && not idesl) initScript

1743 when (runrepl && not idesl) initScript

1738

1744

1739 nobanner <- getNoBanner

1745 nobanner <- getNoBanner

@@ -1794,7 +1800,7 @@ idrisMain opts =

1794 when (runrepl && not idesl) $ do

1800 when (runrepl && not idesl) $ do

1795-- clearOrigPats

1801-- clearOrigPats

1796 startServer port orig mods

1802 startServer port orig mods

1797− runInputT (replSettings (Just historyFile)) $ repl orig mods efile

1803+ runInputT (replSettings (Just historyFile)) $ repl (force orig) mods efile

1798 let idesock = IdemodeSocket `elem` opts

1804 let idesock = IdemodeSocket `elem` opts

1799 when (idesl) $ idemodeStart idesock orig inputs

1805 when (idesl) $ idemodeStart idesock orig inputs

1800 ok <- noErrors

1806 ok <- noErrors

src/Idris/REPL/Browse.hs+2−1

@@ -8,7 +8,7 @@ import Data.List (isSuffixOf, nub)

8import Data.Maybe (mapMaybe)

9import qualified Data.Text as T (unpack)

10

11−import Idris.Core.Evaluate (ctxtAlist, Accessibility(Hidden), lookupDefAccExact)

11+import Idris.Core.Evaluate (ctxtAlist, Accessibility(Private, Hidden), lookupDefAccExact)

12import Idris.Core.TT (Name(..))

13

14import Idris.AbsSyntaxTree (Idris)

@@ -41,4 +41,5 @@ namesInNS ns = do let revNS = reverse ns

41 accessible n = do ctxt <- getContext

42 case lookupDefAccExact n False ctxt of

43 Just (_, Hidden ) -> return False

44+ Just (_, Private ) -> return False

44 _ -> return True

45 _ -> return True

src/Idris/REPLParser.hs → src/Idris/REPL/Parser.hsrenamed+1−1

@@ -1,5 +1,5 @@

1

2−module Idris.REPLParser (parseCmd, help, allHelp, setOptions) where

2+module Idris.REPL.Parser (parseCmd, help, allHelp, setOptions) where

3

4import System.FilePath ((</>))

5import System.Console.ANSI (Color(..))

src/Idris/Reflection.hs+25−8

@@ -48,6 +48,10 @@ data RCtorArg = RCtorParameter RFunArg | RCtorField RFunArg deriving Show

48

49data RDatatype = RDatatype Name [RTyConArg] Raw [(Name, [RCtorArg], Raw)] deriving Show

50

51+data RConstructorDefn = RConstructor Name [RFunArg] Raw

52+

53+data RDataDefn = RDefineDatatype Name [RConstructorDefn]

54+

51rArgOpts :: RErasure -> [ArgOpt]

55rArgOpts :: RErasure -> [ArgOpt]

52rArgOpts RErased = [InaccessibleArg]

56rArgOpts RErased = [InaccessibleArg]

53rArgOpts _ = []

57rArgOpts _ = []

@@ -364,10 +368,10 @@ reifyArithTy (P _ n _) | n == reflm "ATDouble" = return ATFloat

364reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)

368reifyArithTy x = fail ("Couldn't reify reflected ArithTy: " ++ show x)

365

369

366reifyNativeTy :: Term -> ElabD NativeTy

370reifyNativeTy :: Term -> ElabD NativeTy

367−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

371+reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

368−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

372+reifyNativeTy (P _ n _) | n == reflm "IT16" = return IT16

369−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

373+reifyNativeTy (P _ n _) | n == reflm "IT32" = return IT32

370−reifyNativeTy (P _ n _) | n == reflm "IT8" = return IT8

374+reifyNativeTy (P _ n _) | n == reflm "IT64" = return IT64

371reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x

375reifyNativeTy x = fail $ "Couldn't reify reflected NativeTy " ++ show x

372

376

373reifyIntTy :: Term -> ElabD IntTy

377reifyIntTy :: Term -> ElabD IntTy

@@ -896,7 +900,8 @@ reflectErr (NotInjective t1 t2 t3) =

896 , reflect t2

900 , reflect t2

897 , reflect t3

901 , reflect t3

898 ]

902 ]

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]

900reflectErr (InvalidTCArg n t) = raw_apply (Var $ reflErrName "InvalidTCArg") [reflectName n, reflect t]

905reflectErr (InvalidTCArg n t) = raw_apply (Var $ reflErrName "InvalidTCArg") [reflectName n, reflect t]

901reflectErr (CantResolveAlts ss) =

906reflectErr (CantResolveAlts ss) =

902 raw_apply (Var $ reflErrName "CantResolveAlts")

907 raw_apply (Var $ reflErrName "CantResolveAlts")

@@ -962,7 +967,7 @@ reifyReportPart (App _ (P (DCon _ _ _) n _) (Constant (Str msg))) | n == reflm "

962 Right (TextPart msg)

967 Right (TextPart msg)

963reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)

968reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)

964 | n == reflm "NamePart" =

969 | 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

966 Error e -> Left . InternalMsg $

971 Error e -> Left . InternalMsg $

967 "could not reify name term " ++

972 "could not reify name term " ++

968 show ttn ++

973 show ttn ++

@@ -970,7 +975,7 @@ reifyReportPart (App _ (P (DCon _ _ _) n _) ttn)

970 OK (n', _)-> Right $ NamePart n'

975 OK (n', _)-> Right $ NamePart n'

971reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

976reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

972 | n == reflm "TermPart" =

977 | 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

974 Error e -> Left . InternalMsg $

979 Error e -> Left . InternalMsg $

975 "could not reify reflected term " ++

980 "could not reify reflected term " ++

976 show tm ++

981 show tm ++

@@ -978,7 +983,7 @@ reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

978 OK (tm', _) -> Right $ TermPart tm'

983 OK (tm', _) -> Right $ TermPart tm'

979reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

984reifyReportPart (App _ (P (DCon _ _ _) n _) tm)

980 | n == reflm "RawPart" =

985 | 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

982 Error e -> Left . InternalMsg $

987 Error e -> Left . InternalMsg $

983 "could not reify reflected raw term " ++

988 "could not reify reflected raw term " ++

984 show tm ++

989 show tm ++

@@ -1043,6 +1048,18 @@ reifyFunDefn (App _ (App _ (App _ (P _ n _) (P _ t _)) fnN) clauses)

1043 reifyC tm = fail $ "Couldn't reify " ++ show tm ++ " as a clause."

1048 reifyC tm = fail $ "Couldn't reify " ++ show tm ++ " as a clause."

1044reifyFunDefn tm = fail $ "Couldn't reify " ++ show tm ++ " as a function declaration."

1049reifyFunDefn tm = fail $ "Couldn't reify " ++ show tm ++ " as a function declaration."

1045

1050

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+

1046envTupleType :: Raw

1063envTupleType :: Raw

1047envTupleType

1064envTupleType

1048 = raw_apply (Var pairTy) [ (Var $ reflm "TTName")

1065 = raw_apply (Var pairTy) [ (Var $ reflm "TTName")

src/Pkg/PParser.hs+3−3

@@ -5,11 +5,11 @@

5module Pkg.PParser where

6

7import Text.Trifecta hiding (span, charLiteral, natural, symbol, char, string, whiteSpace)

8−

8+import qualified Text.PrettyPrint.ANSI.Leijen as PP

9import Idris.Core.TT

10import Idris.REPL

11import Idris.AbsSyntaxTree

12−import Idris.ParseHelpers hiding (stringLiteral)

12+import Idris.Parser.Helpers hiding (stringLiteral)

13import Idris.CmdOptions

14

15import Control.Monad.State.Strict

@@ -51,7 +51,7 @@ parseDesc :: FilePath -> IO PkgDesc

51parseDesc fp = do

52 p <- readFile fp

53 case runparser pPkg defaultPkg fp p of

54− Failure err -> fail (show err)

54+ Failure err -> fail (show $ PP.plain err)

55 Success x -> return x

56

57pPkg :: PParser PkgDesc

src/Pkg/Package.hs+1−1

@@ -142,7 +142,7 @@ documentPkg fp =

142 setCurrentDirectory pkgDir

143 let run l = runExceptT . execStateT l

144 load [] = return ()

145− load (f:fs) = do loadModule f; load fs

145+ load (f:fs) = do loadModule f IBC_Building; load fs

146 loader = do idrisMain opts; addImportDir (sourcedir pkgdesc); load fs

147 idrisInstance <- run loader idrisInit

148 setCurrentDirectory cd

src/Util/ScreenSize.hs+2−17

@@ -1,21 +1,6 @@

1−{-# LANGUAGE CPP #-}

2module Util.ScreenSize(getScreenWidth) where

1module Util.ScreenSize(getScreenWidth) where

3

2

4−import Debug.Trace

3+import System.Console.Terminal.Size (size, width)

5−

6−#ifndef CURSES

7−

8−getScreenWidth :: IO Int

9−getScreenWidth = return 80

10−

11−#else

12−

13−import UI.HSCurses.Curses

14

4

15getScreenWidth :: IO Int

5getScreenWidth :: IO Int

16−getScreenWidth = do initScr

6+getScreenWidth = maybe 80 width `fmap` size

17− refresh

18− size <- scrSize

19− endWin

20− return (snd size)

21−#endif

src/Util/System.hs−4

@@ -2,7 +2,6 @@

2module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows,

3 writeSource, writeSourceText, readSource,

4 setupBundledCC, isATTY) where

5−

6-- System helper functions.

5-- System helper functions.

7

6

8import Control.Exception as CE

7import Control.Exception as CE

@@ -32,9 +31,6 @@ import System.Environment (getEnv, setEnv, getExecutablePath)

32catchIO :: IO a -> (IOError -> IO a) -> IO a

31catchIO :: IO a -> (IOError -> IO a) -> IO a

33catchIO = CE.catch

32catchIO = CE.catch

34

33

35−throwIO :: IOError -> IO a

36−throwIO = CE.throw

37−

38isWindows :: Bool

34isWindows :: Bool

39isWindows = os `elem` ["win32", "mingw32", "cygwin32"]

35isWindows = os `elem` ["win32", "mingw32", "cygwin32"]

40

36

stack-shell.nixnew file+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+

2packages:

3packages:

3−- '.'

4+ - '.'

5+

4flags:

6flags:

5− idris:

7+ idris:

6− FFI: true

8+ FFI: true

7− GMP: True

9+ GMP: true

8− curses: True

10+

9−extra-deps:

11+extra-deps:

10−- annotated-wl-pprint-0.7.0

12+ - libffi-0.1

11−- cheapskate-0.1.0.4

13+

12−- hscurses-1.4.2.0

14+nix:

13−- libffi-0.1

15+ enable: false

16+ shell-file: stack-shell.nix

test/Makefile+23−13

@@ -1,24 +1,34 @@

1−.PHONY: test test_java test_js time update diff distclean $(TESTS)

1+.PHONY: test test_js time update diff distclean $(TESTS)

2

3TESTS = $(sort $(patsubst %/,%.test,$(wildcard */)))

4

5test: $(TESTS)

6

7−%.test:

8− @perl ./runtest.pl $(patsubst %.test,%,$@)

9

7

10−test_js:

8+info: runtest

11− @perl ./runtest.pl without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 --codegen node

9+ @./runtest all

12

10

13−update:

11+%.test: runtest

14− /usr/bin/env perl ./runtest.pl all -u

12+ @./runtest $(patsubst %.test,%,$@) -q

15

13

16−diff:

14+test_js: runtest

17− /usr/bin/env perl ./runtest.pl all -d

15+ @./runtest without sugar004 reg029 reg052 io001 dsl002 io003 effects001 effects002 basic007 basic011 ffi006 ffi007 ffi008 primitives005 primitives006 opts --codegen node

18

16

19−time:

17+update: runtest

20− /usr/bin/env perl ./runtest.pl all -t

18+ @./runtest all -u

19+

20+diff: runtest

21+ @./runtest all -d

22+

23+time: runtest

24+ @./runtest all -t

21

25

22distclean:

26distclean:

23− rm -f *~

27+ @rm runtest

24− rm -f */output

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 @@

1#!/usr/bin/env bash

2−idris $@ reg005.idr -o reg005

2+${IDRIS:-idris} $@ reg005.idr -o reg005

3−idris $@ basic001a.idr -o basic001a

3+${IDRIS:-idris} $@ basic001a.idr -o basic001a

4./reg005

5./basic001a

6rm -f reg005 basic001a *.ibc

test/basic002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 test006.idr -o test006

2+${IDRIS:-idris} $@ --nocolour test006.idr -o test006

3./test006

4rm -f test006 test006.ibc

test/basic003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test027.idr -o test027

2+${IDRIS:-idris} $@ test027.idr -o test027

3./test027

4rm -f test027 *.ibc

test/basic004/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test016.idr -o test016

2+${IDRIS:-idris} $@ test016.idr -o test016

3./test016

4rm -f test016 *.ibc

test/basic005/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test019.lidr -o test019

2+${IDRIS:-idris} $@ test019.lidr -o test019

3./test019

4rm -f test019 *.ibc

test/basic006/run+2−2

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2

3−idris --consolewidth 80 $@ test020.idr -o test020

3+${IDRIS:-idris} $@ test020.idr -o test020

4−idris --consolewidth 80 $@ test020a.idr --check --nocolor

4+${IDRIS:-idris} $@ test020a.idr --check --nocolor

5./test020

6rm -f test020 *.ibc

test/basic007/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ -o test033 test033.idr

2+${IDRIS:-idris} $@ -o test033 test033.idr

3./test033

4rm -f *.ibc test033

test/basic008/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test036.idr -o test036

2+${IDRIS:-idris} $@ test036.idr -o test036

3./test036

4rm -f test036 *.ibc

test/basic009/A.idr+1

@@ -1,4 +1,5 @@

1module A

2

3+public export

3num : Nat

4num : Nat

4num = 0

5num = 0

test/basic009/B/C.idr+1

@@ -1,4 +1,5 @@

1module B.C

2

3+public export

3num : Nat

4num : Nat

4num = 1

5num = 1

test/basic009/run+3−3

@@ -1,8 +1,8 @@

1#!/usr/bin/env bash

2

3−idris --consolewidth 80 $@ Main.idr --nocolour --check && echo MAIN-PASS

3+${IDRIS:-idris} $@ Main.idr --nocolour --check && echo MAIN-PASS

4−idris --consolewidth 80 $@ Faulty.idr --nocolour --check && echo FAULTY-PASS

4+${IDRIS:-idris} $@ Faulty.idr --nocolour --check && echo FAULTY-PASS

5−idris --consolewidth 80 $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS

5+${IDRIS:-idris} $@ Multiple.idr --nocolour --check && echo MULTIPLE-PASS

6

7

8rm -f *.ibc B/*.ibc

test/basic011/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ basic011.idr -p contrib -o basic011

2+${IDRIS:-idris} $@ basic011.idr -p contrib -o basic011

3./basic011

4rm -f basic011 *.ibc

test/basic012/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ basic012.idr -o basic012

2+${IDRIS:-idris} $@ basic012.idr -o basic012

3./basic012

4rm -f basic012 *.ibc

test/basic013/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ basic013.idr -o basic013

2+${IDRIS:-idris} $@ basic013.idr -o basic013

3./basic013

4rm -f basic013 *.ibc

test/basic014/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ basic014.idr --check

2+${IDRIS:-idris} $@ basic014.idr --check

3rm -f *.ibc

test/basic015/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ basic015.idr -o basic015

2+${IDRIS:-idris} $@ basic015.idr -o basic015

3./basic015

4rm -f basic015 *.ibc

test/basic016/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ CycleA.idr --consolewidth 80 --nocolour --check

2+${IDRIS:-idris} $@ CycleA.idr --nocolour --check

3rm -f *.ibc

test/basic017/basic017.idrnew file+25

@@ -0,0 +1,25 @@

1+%auto_implicits off

2+

3+data Vect : Nat -> Type -> Type where

4+ Nil : {a : _} -> Vect Z a

5+ (::) : {a, k : _} -> a -> Vect k a -> Vect (S k) a

6+

7+data Elem : {a, n : _} -> a -> Vect n a -> Type where

8+ Here : {x, xs : _} -> Elem x (x :: xs)

9+ There : {x, y, xs : _} -> Elem x xs -> Elem x (y :: xs)

10+

11+using (xs : Vect _ _)

12+ data Elem2 : {a, n : _} -> a -> Vect n a -> Type where

13+ Here2 : {x : _} -> Elem2 x (x :: xs)

14+ There2 : {x, y : _} -> Elem2 x xs -> Elem2 x (y :: xs)

15+

16+append : {n, m, a : _} -> Vect n a -> Vect m a -> Vect (n + m) a

17+append [] ys = ys

18+append (x :: xs) ys = x :: append xs ys

19+

20+%auto_implicits on

21+

22+append2 : Vect n a -> Vect m a -> Vect (n + m) a

23+append2 [] ys = ys

24+append2 (x :: xs) ys = x :: append2 xs ys

25+

test/basic017/basic017a.idrnew file+15

@@ -0,0 +1,15 @@

1+%auto_implicits off

2+

3+data Vect : Nat -> Type -> Type where

4+ Nil : {a : _} -> Vect Z a

5+ (::) : {a, k : _} -> a -> Vect k a -> Vect (S k) a

6+

7+data Elem : {a, n : _} -> a -> Vect n a -> Type where

8+ Here : {x, xs : _} -> Elem x (x :: xs)

9+ There : {x, y, xs : _} -> Elem x xs -> Elem x (y :: xs)

10+

11+append : Vect n a -> Vect m a -> Vect (n + m) a

12+append [] ys = ys

13+append (x :: xs) ys = x :: append xs ys

14+

15+

test/basic017/expectednew file+3

@@ -0,0 +1,3 @@

1+basic017a.idr:11:8:When checking type of Main.append:

2+When checking an application of Main.Vect:

3+ No such variable n

test/basic017/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ basic017.idr --check --nocolor

3+${IDRIS:-idris} $@ basic017a.idr --check --nocolor

4+rm -f *.ibc

test/bignum001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ bignum001.idr -o bignum001

2+${IDRIS:-idris} $@ bignum001.idr -o bignum001

3./bignum001

4rm -f bignum001 *.ibc

test/bignum002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ bignum002.idr -o bignum002

2+${IDRIS:-idris} $@ bignum002.idr -o bignum002

3./bignum002

4rm -f bignum002 *.ibc

test/bounded001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ bounded001.idr -o bounded001

2+${IDRIS:-idris} $@ bounded001.idr -o bounded001

3./bounded001

4rm -f bounded001 *.ibc

test/classes001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --quiet --nocolour --consolewidth 70 ClassName.idr < input

2+${IDRIS:-idris} $@ --quiet --nocolour --consolewidth 70 ClassName.idr < input

3rm -f bounded001 *.ibc

test/corecords001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ corecords001.idr -o corecords001

2+${IDRIS:-idris} $@ corecords001.idr -o corecords001

3./corecords001

4rm -f corecords001 corecords001.ibc

test/corecords002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ corecords002.idr -o corecords002

2+${IDRIS:-idris} $@ corecords002.idr -o corecords002

3./corecords002

4rm -f corecords002 corecords002.ibc

test/delab001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --quiet --nocolor delab001.idr < input

2+${IDRIS:-idris} $@ --quiet --nocolor delab001.idr < input

3rm -f *.ibc

test/disambig002/disambig002.idr+10−12

@@ -6,7 +6,7 @@ Dec0 : Type -> Type

6Dec0 = Dec

7

8Dec1 : {A : Type} -> (P : A -> Type) -> Type

9−Dec1 {A} P = (a : A) -> Dec0 (P a)

9+Dec1 {A} P = (a : A) -> Dec0 (P a)

10

11Unique : Type -> Type

12Unique t = (p : t) -> (q : t) -> p = q

@@ -53,8 +53,8 @@ namespace Finite

53filterTag : {A : Type} ->

54 {P : A -> Type} ->

55 Dec1 P ->

56− Vect n A ->

56+ Vect n A ->

57− Sigma Nat (\ m => Vect m (Sigma A P))

57+ DPair Nat (\ m => Vect m (DPair A P))

58filterTag d1P Nil = (_ ** Nil)

59filterTag d1P (a :: as) with (filterTag d1P as)

60 | (_ ** tail) with (d1P a)

@@ -66,7 +66,7 @@ toVect : {A : Type} ->

66 {P : A -> Type} ->

67 Finite A ->

68 Dec1 P ->

69− (n : Nat ** Vect n (Sigma A P))

69+ (n : Nat ** Vect n (DPair A P))

70toVect fA d1P = filterTag d1P (toVect fA)

71

72sigmaUniqueLemma1 : {A : Type} ->

@@ -74,16 +74,14 @@ sigmaUniqueLemma1 : {A : Type} ->

74 Unique1 {t0 = A} P ->

75 (a : A) ->

76 (p : P a) ->

77− (ss : Vect n (Sigma A P)) ->

77+ (ss : Vect n (DPair A P)) ->

78− Elem a (map getWitness ss) ->

78+ Elem a (map fst ss) ->

79 Elem (a ** p) ss

80

81toVectComplete : {A : Type} ->

82 {P : A -> Type} ->

83− (fA : Finite A) ->

83+ (fA : Finite A) ->

84− (d1P : Dec1 P) ->

84+ (d1P : Dec1 P) ->

85 Unique1 {t0 = A} P ->

86− (s : Sigma A P) ->

86+ (s : DPair A P) ->

87− Elem s (getProof (toVect fA d1P))

87+ Elem s (snd (toVect fA d1P))

88−

89−

test/disambig002/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ disambig002.idr --check

2+${IDRIS:-idris} $@ disambig002.idr --check

3rm -f *.ibc

test/docs001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet --nocolor --consolewidth 80 docs001.idr < input

2+${IDRIS:-idris} --quiet --nocolor docs001.idr < input

3rm *.ibc

test/docs002/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --nobanner --nocolor --quiet docs002.idr < input

2+${IDRIS:-idris} --nobanner --nocolor --quiet docs002.idr < input

3rm *.ibc

test/docs003/expected+1−1

@@ -5,7 +5,7 @@ Parameters:

5 f -- a parameterised type

6

7Methods:

8− map : Functor f => (m : a -> b) -> f a -> f b

8+ map : Functor f => (func : a -> b) -> f a -> f b

9 Apply a function across everything of type 'a' in a

10 parameterised type

11

test/docs003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --quiet --nocolor docs003.idr < input

2+${IDRIS:-idris} --quiet --nocolor docs003.idr < input

3rm *.ibc

test/docs004/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet --nocolor --consolewidth 80 docs004.idr < input

2+${IDRIS:-idris} --quiet --nocolor docs004.idr < input

3rm *.ibc

test/dsl001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test001.idr -o test001

2+${IDRIS:-idris} $@ test001.idr -o test001

3./test001

4rm -f test001 test001.ibc

test/dsl001/test001.idr+1−1

@@ -45,7 +45,7 @@ using (G : Vect n Ty)

45 index_next = Pop

46

47 total

48− interp : Env G -> [static] (e : Expr G t) -> interpTy t

48+ interp : Env G -> %static (e : Expr G t) -> interpTy t

49 interp env (Var i) = lookup i env

50 interp env (Val x) = x

51 interp env (Lam sc) = \x => interp (x :: env) sc

test/dsl002/Resimp.idr+3−1

@@ -3,6 +3,8 @@ module Resimp

3import public Data.Vect

4import public Data.Fin

5

6+%access public export

7+

6-- IO operations which read a resource

8-- IO operations which read a resource

7data Reader : Type -> Type where

9data Reader : Type -> Type where

8 MkReader : IO a -> Reader a

10 MkReader : IO a -> Reader a

@@ -122,7 +124,7 @@ using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty)

122 ioret : a -> IO a

124 ioret : a -> IO a

123 ioret = return

125 ioret = return

124

126

125− interp : Env gam -> [static] (e : Res gam gam' t) ->

127+ interp : Env gam -> %static (e : Res gam gam' t) ->

126 (Env gam' -> interpTy t -> IO u) -> IO u

128 (Env gam' -> interpTy t -> IO u) -> IO u

127

129

128 interp env (Let val scope) k

130 interp env (Let val scope) k

test/dsl002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test014.idr -o test014

2+${IDRIS:-idris} $@ test014.idr -o test014

3./test014

4rm -f test014 Resimp.ibc test014.ibc

test/dsl003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --check DSLPi.idr -e test1 -e test2

2+${IDRIS:-idris} $@ --nocolour --check DSLPi.idr -e test1 -e test2

3rm -f *.ibc

test/dsl004/run+3−3

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris $@ Door0.idr --check

2+${IDRIS:-idris} $@ Door0.idr --check

3−idris $@ Door1.idr --check

3+${IDRIS:-idris} $@ Door1.idr --check

4−idris $@ Door2.idr --check

4+${IDRIS:-idris} $@ Door2.idr --check

5rm -f *.ibc

test/effects001/run+2−2

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2−idris -p effects $@ test021.idr -o test021

2+${IDRIS:-idris} -p effects $@ test021.idr -o test021

3−idris -p effects $@ test021a.idr -o test021a

3+${IDRIS:-idris} -p effects $@ test021a.idr -o test021a

4./test021

5./test021a

6rm -f test021 test021a *.ibc

test/effects002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris -p effects $@ test025.idr -o test025

2+${IDRIS:-idris} -p effects $@ test025.idr -o test025

3./test025

4rm -f test025 *.ibc

test/effects003/VectMissing.idr+1−3

@@ -3,9 +3,7 @@ module VectMissing

3import Data.Fin

4import Data.Vect

5

6−implementation Uninhabited (Elem x []) where

6+export

7− uninhabited Here impossible

8−

9shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a

7shrink : (xs : Vect (S n) a) -> Elem x xs -> Vect n a

10shrink (x :: ys) Here = ys

8shrink (x :: ys) Here = ys

11shrink (y :: []) (There p) = absurd p

9shrink (y :: []) (There p) = absurd p

test/effects003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ hangman.idr --consolewidth 80 --nocolour -p effects -o hangman

2+${IDRIS:-idris} $@ hangman.idr --nocolour -p effects -o hangman

3./hangman < input

4rm -f hangman *.ibc

test/effects004/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ effects004.idr -o effects004 -p effects

2+${IDRIS:-idris} $@ effects004.idr -o effects004 -p effects

3./effects004 < input

4rm -f effects004 *.ibc

test/effects005/run+2−2

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2−idris $@ defaultLogger.idr -o default -p effects

2+${IDRIS:-idris} $@ defaultLogger.idr -o default -p effects

3./default

4−idris $@ categoryLogger.idr -o category -p effects

4+${IDRIS:-idris} $@ categoryLogger.idr -o category -p effects

5./category

6rm -f default category *.ibc

test/error001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ test002.idr --check --noprelude --consolewidth 70

2+${IDRIS:-idris} $@ test002.idr --check --noprelude --consolewidth 70

3rm -f *.ibc

test/error002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test031.idr -o test031

2+${IDRIS:-idris} $@ test031.idr -o test031

3./test031

4rm -f test031 *.ibc

test/error003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ ErrorReflection.idr --nocolour --check

2+${IDRIS:-idris} $@ ErrorReflection.idr --nocolour --check

3rm -f *.ibc

test/error004/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ FunErrTest.idr --nocolour --check

2+${IDRIS:-idris} $@ FunErrTest.idr --nocolour --check

3rm -f *.ibc

test/error005/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check --nocolour error005.idr

2+${IDRIS:-idris} $@ --check --nocolour error005.idr

3rm -f *.ibc

test/error006/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check --nocolour WithPatsNoWith.idr

2+${IDRIS:-idris} $@ --check --nocolour WithPatsNoWith.idr

3rm -f *.ibc

test/ffi001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet --nocolour test022.idr --exec main

2+${IDRIS:-idris} --quiet --nocolour test022.idr --exec main

3rm -f *.ibc

test/ffi002/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --quiet test023.idr -o test023

2+${IDRIS:-idris} --quiet test023.idr -o test023

3rm -f test023 *.ibc

test/ffi003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet --nocolour test024.idr --exec main < input

2+${IDRIS:-idris} --quiet --nocolour test024.idr --exec main < input

3rm -f *.ibc

test/ffi004/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet --nocolour --check test026.idr

2+${IDRIS:-idris} --quiet --nocolour --check test026.idr

3rm -f *.ibc

test/ffi005/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2

3−idris $@ Postulate.idr -o postulate

3+${IDRIS:-idris} $@ Postulate.idr -o postulate

4./postulate

5rm -f postulate *.ibc

test/ffi006/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris $@ ffi006.idr --interface -o ffi006.o

2+${IDRIS:-idris} $@ ffi006.idr --interface -o ffi006.o

3${CC:=cc} ffi006.c ffi006.o `idris --include` `idris --link` -o ffi006

4./ffi006

5rm -f ffi006 *.ibc *.o *.h

test/ffi007/expectednew file+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 @@

1#!/usr/bin/env bash

2−idris $@ folding001.idr -o folding001

2+${IDRIS:-idris} $@ folding001.idr -o folding001

3./folding001

4rm -f folding001 *.ibc

test/idrisdoc001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2# Tests that no documentation is built for empty and/or private-only namespaces

3−idris --mkdoc test_empty.ipkg

3+${IDRIS:-idris} --mkdoc test_empty.ipkg

4rm -rf *.ibc *_doc

test/idrisdoc002/TestFunctions.idr+2−1

@@ -1,5 +1,6 @@

1module TestFunctions

2

3||| Test function

4+public export

4test : ()

5test : ()

5−test = ()

6+test = ()

test/idrisdoc002/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2# Tests that documentation is generated for functions

3−idris --mkdoc test_functions.ipkg

3+${IDRIS:-idris} --mkdoc test_functions.ipkg

4[ -d test_functions_doc ] && echo "Functions are documented"

5rm -rf *.ibc *_doc

test/idrisdoc003/TestDatatypes.idr+2−1

@@ -1,6 +1,7 @@

1module TestDatatypes

2

3||| This is another test

4+public export

4data Test : Type where

5data Test : Type where

5 ||| Test constructor

6 ||| Test constructor

6− ATest : Test

7+ ATest : Test

test/idrisdoc003/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2# Tests that documentation is generated for data types

3−idris --mkdoc test_datatypes.ipkg

3+${IDRIS:-idris} --mkdoc test_datatypes.ipkg

4[ -d test_datatypes_doc ] && echo "Data types are documented"

5rm -rf *.ibc *_doc

test/idrisdoc004/TestTypeclasses.idr+1

@@ -3,6 +3,7 @@ module TestTypeclasses

3||| This is a test

4|||

5||| @ a Test arg

6+public export

6interface Test a where

7interface Test a where

7 ||| Test function

8 ||| Test function

8 test : a -> Int

9 test : a -> Int

test/idrisdoc004/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2# Tests that documentation is generated for typeclasses

3−idris --mkdoc test_typeclasses.ipkg

3+${IDRIS:-idris} --mkdoc test_typeclasses.ipkg

4[ -d test_typeclasses_doc ] && echo "Typeclasses are documented"

5rm -rf *.ibc *_doc

test/idrisdoc005/TestTracing.idr+2−1

@@ -1,4 +1,5 @@

1module TestTracing

2

3+public export

3test : Bool

4test : Bool

4−test = True

5+test = True

test/idrisdoc005/run+1−1

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2# Tests that references to other namespaces are traced

3−idris --mkdoc test_tracing.ipkg

3+${IDRIS:-idris} --mkdoc test_tracing.ipkg

4[ -f test_tracing_doc/docs/TestTracing.html ] && echo "TestTracing: Check"

5[ -f test_tracing_doc/docs/Prelude.Bool.html ] && echo "Prelude.Bool: Check"

6rm -rf *.ibc *_doc

test/idrisdoc006/A/fully/Qualified/NAME.idr+2−2

@@ -1,6 +1,6 @@

1module A.fully.Qualified.NAME

2

3||| This is another test

4−data Test : Type where

4+public export data Test : Type where

5 ||| Test constructor

6− ATest : Test

6+ ATest : Test

test/idrisdoc006/B.idr+2−1

@@ -1,5 +1,6 @@

1module B

2

3||| Test function

4+public export

4test : ()

5test : ()

5−test = ()

6+test = ()

test/idrisdoc006/run+2−2

@@ -1,8 +1,8 @@

1#!/usr/bin/env bash

2# Tests that documentation properly is merged with existent.

3−idris --mkdoc package_a.ipkg

3+${IDRIS:-idris} --mkdoc package_a.ipkg

4[ -f test_merge_doc/IdrisDoc ] && echo "IdrisDoc file written"

5−idris --mkdoc package_b.ipkg

5+${IDRIS:-idris} --mkdoc package_b.ipkg

6ls -1p test_merge_doc/docs

7if grep -q "href\\=\"docs/A.fully.Qualified.NAME\\.html\"" test_merge_doc/index.html; then

8 echo A.fully.Qualified.NAME is in the index

test/idrisdoc007/run+1−1

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2# Tests that documentation only is written when safe

3mkdir do_not_delete_doc

4−idris --mkdoc package.ipkg > nowhere

4+${IDRIS:-idris} --mkdoc package.ipkg > nowhere

5echo Exit status $expects 1$: $?

6rm -rf do_not_delete_doc *.ibc nowhere

test/idrisdoc008/Abstract.idr+2−2

@@ -1,5 +1,5 @@

1module Abstract

2

3−abstract

3+export

4frozen : ()

5−frozen = ()

5+frozen = ()

test/idrisdoc008/Visible.idr+2−2

@@ -1,5 +1,5 @@

1module Visible

2

3−public

3+public export

4visible : ()

5−visible = ()

5+visible = ()

test/idrisdoc008/run+1−1

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2# Tests that documentation is generated for both public and abstract members.

3−idris --mkdoc visibility.ipkg

3+${IDRIS:-idris} --mkdoc visibility.ipkg

4[ -f visibility_doc/docs/Abstract.html ] && echo "Abstract members are documented"

5[ -f visibility_doc/docs/Visible.html ] && echo "Public members are documented"

6rm -rf *.ibc *_doc

test/idrisdoc009/Test.idr+2

@@ -23,6 +23,8 @@

23module Test

24import Data.Complex

25

26+%access public export

27+

26myplus : Nat -> Nat -> Nat

28myplus : Nat -> Nat -> Nat

27myplus Z j = j

29myplus Z j = j

28myplus (S k) j = S (myplus k j)

30myplus (S k) j = S (myplus k j)

test/idrisdoc009/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --quiet Test.idr < input

2+${IDRIS:-idris} $@ --nocolour --quiet Test.idr < input

3rm -f *.ibc

test/interactive001/expected+1

@@ -6,6 +6,7 @@ isElem x (y :: xs) = ?isElem_rhs_3

6f x :: map f xs

7isElem2 x (y :: ys) with (_)

8 isElem2 x (y :: ys) | with_pat = ?isElem2_rhs

9+

9 isElem3 x (x :: ys) | (Yes Refl) = ?isElem3_rhs_3

10 isElem3 x (x :: ys) | (Yes Refl) = ?isElem3_rhs_3

10

11

11 [] => ?bar_1

12 [] => ?bar_1

test/interactive001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet test032.idr < input

2+${IDRIS:-idris} --quiet test032.idr < input

3rm -f *.ibc

test/interactive002/expected+1−1

@@ -5,6 +5,6 @@ Nat

5Vect (n + m) a

6Nat

7Nat

8−S n

8+(S n)

9String

10()

test/interactive002/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet interactive002.idr < input

2+${IDRIS:-idris} --quiet interactive002.idr < input

3rm -f *.ibc

test/interactive003/expected+1−1

@@ -2,4 +2,4 @@ ys

2x :: app xs ys

3[]

4f 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 @@

1#!/usr/bin/env bash

2−idris --quiet interactive003.idr < input

2+${IDRIS:-idris} --quiet interactive003.idr < input

3rm -f *.ibc

test/interactive004/expected+1−1

@@ -1,2 +1,2 @@

1plus ?foo_rhs2 ?foo_rhs3

2−append k m ?append_rhs2 ?append_rhs3

2+(append k m ?append_rhs2 ?append_rhs3)

test/interactive004/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet interactive004.idr < input

2+${IDRIS:-idris} --quiet interactive004.idr < input

3rm -f *.ibc

test/interactive005/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --nocolour --quiet interactive005.idr --consolewidth 70 < input

2+${IDRIS:-idris} --nocolour --quiet interactive005.idr --consolewidth 70 < input

3rm -f *.ibc

4rm -f hello.bytecode

5rm -f hello

test/interactive006/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet --port 5000 interactive006.idr < input

2+${IDRIS:-idris} --quiet --port 5000 interactive006.idr < input

3rm -f *.ibc

test/interactive007/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris -p contrib --nobanner --nocolor < input

2+${IDRIS:-idris} -p contrib --nobanner --nocolor < input

test/interactive008/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris --nobanner --nocolor < input

2+${IDRIS:-idris} --nobanner --nocolor < input

test/interactive009/expected+1−1

@@ -1 +1 @@

1−IsSetCons pf prfRec

1+(IsSetCons pf prfRec)

test/interactive009/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet interactive009.idr < input

2+${IDRIS:-idris} --quiet interactive009.idr < input

3rm -f *.ibc

test/interactive010/expected+3−3

@@ -1,12 +1,12 @@

1Prelude.List.(++) : List a -> List a -> List a

2Prelude.Strings.(++) : String -> String -> String

3−a is not an implicit argument of Prelude.Classes./

3+a is not an implicit argument of Prelude.Interfaces./

4Usage is :doc <functionname>

5Usage is :wc <functionname>

6Usage is :printdef <functionname>

7−pat {ty504} : Type u. pat {__class505} : Prelude.Classes.Fractional {ty504}. Prelude.Classes./ {ty504} {__class505}

7+pat {ty504} : Type u. pat {__class505} : Prelude.Interfaces.Fractional {ty504}. Prelude.Interfaces./ {ty504} {__class505}

8

9− : pty {ty504} : Type u. pty {__class505} : Prelude.Classes.Fractional {ty504}. {ty504} -> {ty504} -> {ty504}

9+ : pty {ty504} : Type u. pty {__class505} : Prelude.Interfaces.Fractional {ty504}. {ty504} -> {ty504} -> {ty504}

10(input):1:1: error: expected: ":",

11 dependent type signature,

12 end of input

test/interactive010/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris --quiet --nobanner --nocolor --consolewidth 80 < input

2+${IDRIS:-idris} --quiet --nobanner --nocolor < input

test/interactive011/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --quiet interactive011.idr < input

2+${IDRIS:-idris} --quiet interactive011.idr < input

3rm -f *.ibc

test/interactive012/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 70 --quiet interactive012.idr < input

2+${IDRIS:-idris} --nocolour --consolewidth 70 --quiet interactive012.idr < input

3rm -f *.ibc

test/io001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test004.idr -o test004

2+${IDRIS:-idris} $@ test004.idr -o test004

3./test004

4rm -f test004 test004.ibc testfile

test/io001/test004.idr+1−1

@@ -17,7 +17,7 @@ dumpFile fn = do { Right h <- openFile fn Read

17 closeFile h }

18

19main : IO ()

20−main = do { Right h <- openFile "testfile" Write

20+main = do { Right h <- openFile "testfile" WriteTruncate

21 fPutStr h "Hello!\nWorld!\n...\n3\n4\nLast line\n"

22 closeFile h

23 putStrLn "Reading testfile"

test/io002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test008.idr -o test008

2+${IDRIS:-idris} $@ test008.idr -o test008

3./test008

4rm -f test008 test008.ibc

test/io003/run+2−2

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2−idris $@ test018.idr -p contrib -o test018

2+${IDRIS:-idris} $@ test018.idr -p contrib -o test018

3−idris $@ test018a.idr -p contrib -o test018a

3+${IDRIS:-idris} $@ test018a.idr -p contrib -o test018a

4./test018

5#./test018a

6rm -f test018 test018a *.ibc

test/literate001/Lit.lidr+2−2

@@ -2,12 +2,12 @@

2

3Test some string primitives while we're at it

4

5−> st : String

5+> export st : String

6> st = "abcdefg"

7

8Literate main program

9

10−> main : IO ()

10+> export main : IO ()

11> main = do { putStrLn (show (strHead st))

12> putStrLn (show (strIndex st 3))

13> putStrLn (strCons 'z' st)

test/literate001/run+2−2

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ test003a.lidr --check

2+${IDRIS:-idris} $@ test003a.lidr --check

3−idris --consolewidth 80 $@ test003.lidr -o test003

3+${IDRIS:-idris} $@ test003.lidr -o test003

4./test003

5rm -f test003 test003.ibc Lit.ibc

test/meta001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --check --nocolour --consolewidth 70 Finite.idr

2+${IDRIS:-idris} $@ --check --nocolour --consolewidth 70 Finite.idr

3rm -f *.ibc

test/meta002/AgdaStyleReflection.idr+93−14

@@ -2,6 +2,10 @@

2||| Idris's reflected elaboration. Requires handling type class

3||| resolution and implicit arguments - some of the same features as

4||| the Idris elaborator itself.

5+|||

6+||| Since this test was put together, Agda has adopted an Idris-style

7+||| elaborator reflection mechanism. The module name is preserved for

8+||| historical interest.

5module AgdaStyleReflection

9module AgdaStyleReflection

6

10

7

11

@@ -11,6 +15,7 @@ import Pruviloj

11%default total

15%default total

12

16

13

17

18+

14||| Function arguments as provided at the application site

19||| Function arguments as provided at the application site

15record Arg a where

20record Arg a where

16 constructor MkArg

21 constructor MkArg

@@ -20,6 +25,10 @@ record Arg a where

20implementation Functor Arg where

25implementation Functor Arg where

21 map f (MkArg plic x) = MkArg plic (f x)

26 map f (MkArg plic x) = MkArg plic (f x)

22

27

28+implementation Show a => Show (Arg a) where

29+ showPrec d (MkArg plic x) = showCon d "MkArg" $ showArg plic ++ showArg x

30+

31+

23||| Reflected terms, in the tradition of Agda's reflection library

32||| Reflected terms, in the tradition of Agda's reflection library

24data Term

33data Term

25 = Var Nat (List (Arg Term))

34 = Var Nat (List (Arg Term))

@@ -31,11 +40,39 @@ data Term

31 | Constant Const

40 | Constant Const

32 | Ty

41 | Ty

33

42

34−unApply : Raw -> (Raw, List Raw)

43+implementation Quotable Plicity Raw where

35−unApply tm = unApply' tm []

44+ quotedTy = `(Plicity)

36− where unApply' : Raw -> List Raw -> (Raw, List Raw)

45+ quote Explicit = `(Explicit)

37− unApply' (RApp f x) xs = unApply' f (x::xs)

46+ quote Implicit = `(Implicit)

38− unApply' notApp xs = (notApp, xs)

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"

39

76

40||| Quote a reflected Idris term to a Term in some induced local context

77||| Quote a reflected Idris term to a Term in some induced local context

41covering

78covering

@@ -183,16 +220,39 @@ covering

183spliceTerm : Term -> Elab ()

220spliceTerm : Term -> Elab ()

184spliceTerm = spliceTerm' []

221spliceTerm = spliceTerm' []

185

222

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+

187covering

247covering

188−quoteGoalImpl : (Term -> Term) -> Elab ()

248+tacticImpl : (tac : Term -> Term) -> Elab ()

189−quoteGoalImpl f = do compute

249+tacticImpl tac = do g <- goalType >>= quoteTerm

190− g <- goalType >>= quoteTerm

250+ AgdaStyleReflection.spliceTerm (tac g)

191− spliceTerm (f g)

251+

252+syntax "tactic" [tacticCode] =

253+ %runElab (tacticImpl tacticCode)

192

254

193−syntax "quoteGoal" {x} "in" [expr] = %runElab (quoteGoalImpl (\x => expr))

194

255

195−syntax "tactic" [expr] = %runElab (quoteGoalImpl expr)

196

256

197

257

198

258

@@ -231,12 +291,30 @@ covering

231trivial : (goal : Term) -> Term

291trivial : (goal : Term) -> Term

232trivial = perhaps . trivial'

292trivial = perhaps . trivial'

233

293

234−foo : (Nat, (), Nat, Either (() -> ()) Void)

294+-- DOESN'T WORK because reflection operations are not pure - they have

235−foo = quoteGoal x in trivial x

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+

236

300

301+-- WORKS because "tactic" takes care of the sequencing of operations

237bar : (Nat, (), Either Void Nat, Nat -> ())

302bar : (Nat, (), Either Void Nat, Nat -> ())

238bar = tactic trivial

303bar = tactic trivial

239

304

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+

240-- When checking right hand side of baz:

318-- When checking right hand side of baz:

241-- PROOF SEARCH FAILURE is not defined.

319-- PROOF SEARCH FAILURE is not defined.

242baz : (Nat, Void)

320baz : (Nat, Void)

@@ -245,3 +323,4 @@ baz = tactic trivial

245-- Local Variables:

323-- Local Variables:

246-- idris-load-packages: ("pruviloj")

324-- idris-load-packages: ("pruviloj")

247-- End:

325-- 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

208

209 -- Now we put this hole variable into our sigma constructor

210 -- prior to elaboration, so it doesn't disappear too soon

211− fill `(MkSigma ~(Var tH) ~(Var tmH) : Sigma Ty (Tm []))

211+ fill `(MkDPair ~(Var tH) ~(Var tmH) : DPair Ty (Tm []))

212 solve

213 focus tmH

214 mkTerm [] tm

@@ -287,18 +287,17 @@ namespace STLC

287 apply `(UnitCon {env=~(Var envH)})

288 []

289 solve

290− testElab : Sigma Ty (Tm [])

290+ testElab : DPair Ty (Tm [])

291 testElab = %runElab (elaborateSTLC (App (Lam "x" UnitCon) UnitCon))

292

293− testElab2 : Sigma Ty (Tm [])

293+ testElab2 : DPair Ty (Tm [])

294 testElab2 = %runElab (elaborateSTLC (App (Lam "x" (Var 0)) UnitCon))

295

296 -- Doesn't work! :-)

297− testElab3 : Sigma Ty (Tm [])

297+ testElab3 : DPair Ty (Tm [])

298 testElab3 = %runElab (elaborateSTLC (App (Lam "x" (App (Var 0) (Var 0)))

299 (Lam "x" (App (Var 0) (Var 0)))))

300 -- Error is:

301 -- Tacs.idr line 247 col 14:

302 -- When elaborating right hand side of testElab3:

303 -- Unifying ty and Tacs.STLC.ARR ty t would lead to infinite value

304−

test/meta002/expected+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.

1Tacs.idr:298:15:

4Tacs.idr:298:15:

2When checking right hand side of testElab3 with expected type

5When checking right hand side of testElab3 with expected type

3− Sigma Ty (Tm [])

6+ DPair Ty (Tm [])

4

7

5Unifying ty and ARR ty t would lead to infinite value

8Unifying ty and ARR ty t would lead to infinite value

6−AgdaStyleReflection.idr:243:5:

9+AgdaStyleReflection.idr:321:5:

7When checking right hand side of baz with expected type

10When checking right hand side of baz with expected type

8 (Nat, Void)

11 (Nat, Void)

9

12

test/meta002/run+3−2

@@ -1,6 +1,7 @@

1#!/usr/bin/env bash

2−idris $@ -p pruviloj --nocolour --check --consolewidth 70 Tacs.idr

2+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 DataDef.idr

3−idris $@ -p pruviloj --nocolour --check --consolewidth 70 AgdaStyleReflection.idr

3+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 Tacs.idr

4+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 AgdaStyleReflection.idr

4# Disabled due to excess memory consumption

5# Disabled due to excess memory consumption

5# idris $@ -p pruviloj --nocolour --check --consolewidth 70 Deriving.idr

6# idris $@ -p pruviloj --nocolour --check --consolewidth 70 Deriving.idr

6rm -f *.ibc

7rm -f *.ibc

test/meta003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --check --consolewidth 70 BadDef.idr

2+${IDRIS:-idris} $@ --nocolour --check --consolewidth 70 BadDef.idr

3rm -f *.ibc

test/meta004/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ -p pruviloj --nocolour --check --consolewidth 70 meta004.idr

2+${IDRIS:-idris} $@ -p pruviloj --nocolour --check --consolewidth 70 meta004.idr

3rm -f *.ibc

test/mktest.pl+1−1

@@ -13,7 +13,7 @@ chdir($test);

13open(FOO,">run");

14

15print FOO "#!/usr/bin/env bash\n";

16−print FOO "idris \$@ $test.idr -o $test\n";

16+print FOO "\${IDRIS:-idris} \$@ $test.idr -o $test\n";

17print FOO "./$test\n";print FOO "rm -f $test *.ibc\n";

18

19close(FOO);

test/pkg001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --build test.ipkg

2+${IDRIS:-idris} $@ --build test.ipkg

3rm -f *.ibc

test/pkg002/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2### Test: IPKG executable names can be any namespaced identifier.

3−idris $@ --build test.ipkg

3+${IDRIS:-idris} $@ --build test.ipkg

4rm -f *.ibc

5rm -f some.namespaced.identifier

test/pkg003/run+1−1

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2### Test: IPKG executable names can be a quoted string

3### containing a valid filename.

4−idris $@ --build test.ipkg

4+${IDRIS:-idris} $@ --build test.ipkg

5rm -f *.ibc

6rm -f 'quoting-allows-hyphens and spaces and fun stuff!'

test/pkg004/expected+3−3

@@ -1,5 +1,5 @@

1−Uncaught error: user error ([1mtest.ipkg[0m:[1m10[0m:[1m1[0m: [91merror[0m: filename

1+Uncaught error: user error (test.ipkg:9:1: error: filename

2 must contain no directory

3 component, expected: space

4−[1m[94m<EOF>[0;1m[0m

4+<EOF>

5−[92m^[0m )

5+^ )

test/pkg004/run+1−1

@@ -2,5 +2,5 @@

2### Test: IPKG executable names CANNOT include a directory separator.

3# TODO: Verify that a name like "a/b\c" is rejected by both *NIX and Windows

4# (assuming these tests get run on Windows).

5−idris $@ --consolewidth 80 --nobanner --nocolor --build test.ipkg

5+${IDRIS:-idris} $@ --build test.ipkg

6rm -f *.ibc

test/pkg004/test.ipkg−1

@@ -2,7 +2,6 @@ package test

2

3modules = Main

4

5−

6opts = "--warnpartial --warnreach --nocolour --quiet --consolewidth 80"

5opts = "--warnpartial --warnreach --nocolour --quiet --consolewidth 80"

7

6

8main = Main

7main = Main

test/primitives001/run+2−2

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2−idris $@ test005.idr -o test005

2+${IDRIS:-idris} $@ test005.idr -o test005

3./test005

4−idris $@ substring.idr -o substring

4+${IDRIS:-idris} $@ substring.idr -o substring

5./substring < input

6rm -f test005 substring *.ibc

test/primitives003/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris $@ -o test038 test038.idr --nocolour

2+${IDRIS:-idris} $@ -o test038 test038.idr --nocolour

3./test038

4rm -f test038 *.ibc

5

test/primitives004-disabled/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ -o primitives004 primitives004.idr --nocolour

2+${IDRIS:-idris} $@ -o primitives004 primitives004.idr --nocolour

3./primitives004

4rm -f primitives004 *.ibc

test/primitives005/expectednew file+2

@@ -0,0 +1,2 @@

1+04030201

2+000000000000FFFF

test/primitives005/primitives005.idrnew file+24

@@ -0,0 +1,24 @@

1+module Main

2+

3+%include C "memory.h"

4+

5+-- use calloc to ensure zeroed out memory

6+malloc : Int -> IO Ptr

7+malloc size = foreign FFI_C "calloc" (Int -> Int -> IO Ptr) size 1

8+

9+free : Ptr -> IO ()

10+free ptr = foreign FFI_C "free" (Ptr -> IO ()) ptr

11+

12+main : IO ()

13+main = do

14+ p <- malloc 1000

15+ prim_poke16 p 0 0xffff

16+ prim_poke8 p 8 1

17+ prim_poke8 p 9 2

18+ prim_poke8 p 10 3

19+ prim_poke8 p 11 4

20+ a <- prim_peek32 p 8

21+ b <- prim_peek64 p 0

22+ printLn a

23+ printLn b

24+ free p

test/primitives005/runnew file+5

@@ -0,0 +1,5 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ -o p005 primitives005.idr --nocolour

3+./p005

4+rm -f p005 *.ibc

5+

test/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 @@

1#!/usr/bin/env bash

2−idris $@ test029.idr --consolewidth 80 --nocolour --check test029

2+${IDRIS:-idris} $@ test029.idr --nocolour --check test029

3rm -f *.ibc

test/proof002/Reflect.idr+3−4

@@ -2,6 +2,7 @@ module Reflect

2

3import Decidable.Equality

4

5+%access public export

5%default total

6%default total

6

7

7using (xs : List a, ys : List a, G : List (List a))

8using (xs : List a, ys : List a, G : List (List a))

@@ -43,7 +44,7 @@ using (xs : List a, ys : List a, G : List (List a))

43 let (yl ** (yr, yprf)) = expr_r ey in

44 let (yl ** (yr, yprf)) = expr_r ey in

44 appRExpr _ _ xr yr xprf yprf

45 appRExpr _ _ xr yr xprf yprf

45 where

46 where

46− appRExpr : (xs', ys' : List a) ->

47+ appRExpr : (xs', ys' : List a) ->

47 {G : List (List a)} -> {xs, ys : List a} ->

48 {G : List (List a)} -> {xs, ys : List a} ->

48 RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->

49 RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->

49 (ws' ** (RExpr G ws', xs' ++ ys' = ws'))

50 (ws' ** (RExpr G ws', xs' ++ ys' = ws'))

@@ -205,6 +206,4 @@ Reflect.bp1 = proof {

205-- prover.

206-- prover.

206

207

207syntax AssocProof [ty] = quoteGoal x by reflectEq ty [] in

208syntax AssocProof [ty] = quoteGoal x by reflectEq ty [] in

208− getJust (prove (getProof x)) ItIsJust

209+ getJust (prove (snd x)) ItIsJust

209−

210−

test/proof002/expected+4−4

@@ -1,8 +1,8 @@

1−Reflect.idr:173:21-26:

1+Reflect.idr:174:21-26:

2This style of tactic proof is deprecated. See %runElab for the replacement.

3−Reflect.idr:182:21-26:

3+Reflect.idr:183:21-26:

4This style of tactic proof is deprecated. See %runElab for the replacement.

5−Reflect.idr:190:15-20:

5+Reflect.idr:191:15-20:

6This style of tactic proof is deprecated. See %runElab for the replacement.

7test030a.idr:12:26-14:1:

8When checking right hand side of testReflect1 with expected type

@@ -12,7 +12,7 @@ When checking an application of function Reflect.getJust:

12 Type mismatch between

13 IsJust (Just x1) (Type of ItIsJust)

14 and

15− IsJust (prove (getProof x)) (Expected type)

15+ IsJust (prove (snd x)) (Expected type)

16

17 Specifically:

18 Type mismatch between

test/proof002/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ test030.idr --check --nocolour

2+${IDRIS:-idris} $@ test030.idr --check --nocolour

3−idris --consolewidth 80 $@ test030a.idr --check --nocolour

3+${IDRIS:-idris} $@ test030a.idr --check --nocolour

4rm -f *.ibc

test/proof002/test030.idr−1

@@ -10,4 +10,3 @@ total

10testReflect1 : (xs, ys : List a) ->

11 ((xs ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs)))

12testReflect1 {a} xs ys = AssocProof a

13−

test/proof003/Parity.idr+2

@@ -1,5 +1,7 @@

1module Parity

2

3+%access public export

4+

3data Parity : Nat -> Type where

5data Parity : Nat -> Type where

4 Even : {n : Nat} -> Parity (n + n)

6 Even : {n : Nat} -> Parity (n + n)

5 Odd : {n : Nat} -> Parity (S (n + n))

7 Odd : {n : Nat} -> Parity (S (n + n))

test/proof003/expected+2−2

@@ -1,6 +1,6 @@

1−Parity.idr:15:18-23:

1+Parity.idr:17:18-23:

2This style of tactic proof is deprecated. See %runElab for the replacement.

3−Parity.idr:22:18-23:

3+Parity.idr:24:18-23:

4This style of tactic proof is deprecated. See %runElab for the replacement.

5test015.idr:88:15-20:

6This style of tactic proof is deprecated. See %runElab for the replacement.

test/proof003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test015.idr --nocolour --consolewidth 80 -o test015

2+${IDRIS:-idris} $@ test015.idr --nocolour -o test015

3./test015

4rm -f test015 Parity.ibc test015.ibc

test/proof004/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --check $@ test035.idr

2+${IDRIS:-idris} --check $@ test035.idr

3rm -f *.ibc

test/proof005/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --check $@ DefaultArgSubstitutionSuccess.idr

2+${IDRIS:-idris} --check $@ DefaultArgSubstitutionSuccess.idr

3rm -f *.ibc

test/proof006/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --check $@ DefaultArgSubstitutionSyntax.idr

2+${IDRIS:-idris} --check $@ DefaultArgSubstitutionSyntax.idr

3rm -f *.ibc

test/proof007/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check $@ DefaultArgUnknownName.idr

2+${IDRIS:-idris} --nocolour --check $@ DefaultArgUnknownName.idr

3rm -f *.ibc

test/proof008/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check $@ ClaimAndUnfocus.idr

2+${IDRIS:-idris} --nocolour --check $@ ClaimAndUnfocus.idr

3rm -f *.ibc

test/proof009/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --consolewidth 70 --quiet proof009.idr < input

2+${IDRIS:-idris} $@ --consolewidth 70 --quiet proof009.idr < input

3rm -f *.ibc

test/proof010/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ proof010.idr -o proof010

2+${IDRIS:-idris} $@ proof010.idr -o proof010

3./proof010

4rm -f proof010 *.ibc

test/proofsearch001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --check proofsearch001.idr

2+${IDRIS:-idris} $@ --check proofsearch001.idr

3rm -f *.ibc

test/proofsearch002/Process.idr+1−1

@@ -3,7 +3,7 @@ module Process

3import System.Concurrency.Raw

4import public Data.List -- public, to get proof search machinery

5

6−%access public

6+%access public export

7

8-- Process IDs are parameterised by their interface. A request of type

9-- 'iface t' will get a response of type 't'

test/proofsearch002/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --check proofsearch002.idr

2+${IDRIS:-idris} $@ --check proofsearch002.idr

3rm -f *.ibc

test/proofsearch003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --check proofsearch003.idr

2+${IDRIS:-idris} --check proofsearch003.idr

3rm -f *.ibc

test/pruviloj001/pruviloj001.idr+4−2

@@ -12,7 +12,7 @@ partial

12auto : Elab ()

13auto = do compute

14 attack

15− try $ repeatUntilFail intro'

15+ try intros

16 hs <- map fst <$> getEnv

17 for_ hs $

18 \ih => try (rewriteWith (Var ih))

@@ -23,10 +23,12 @@ auto = do compute

23partial

24mush : Elab ()

25mush =

26− do n <- gensym "j"

26+ do attack

27+ n <- gensym "j"

27 intro n

28 intro n

28 try intros

29 try intros

29 ignore $ induction (Var n) `andThen` auto

30 ignore $ induction (Var n) `andThen` auto

31+ solve

30

32

31plusAssoc : (j, k, l : Nat) -> plus (plus j k) l = plus j (plus k l)

33plusAssoc : (j, k, l : Nat) -> plus (plus j k) l = plus j (plus k l)

32plusAssoc = %runElab mush

34plusAssoc = %runElab mush

test/pruviloj001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ -p pruviloj --check --nocolour --consolewidth 70 pruviloj001.idr

2+${IDRIS:-idris} $@ -p pruviloj --check --nocolour --consolewidth 70 pruviloj001.idr

3rm -f *.ibc

test/quasiquote001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ QuasiquoteBasics.idr -o quasiquote001

2+${IDRIS:-idris} $@ QuasiquoteBasics.idr -o quasiquote001

3./quasiquote001

4rm -f quasiquote001 *.ibc

test/quasiquote002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ GoalQQuote.idr -o quasiquote002

2+${IDRIS:-idris} $@ GoalQQuote.idr -o quasiquote002

3./quasiquote002

4rm -f quasiquote002 *.ibc

test/quasiquote003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check NoInfer.idr

2+${IDRIS:-idris} $@ --check NoInfer.idr

3rm -f *.ibc

test/quasiquote004/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check --nocolour Quasiquote004.idr

2+${IDRIS:-idris} $@ --check --nocolour Quasiquote004.idr

3rm -f *.ibc

test/quasiquote005/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --check --nocolour Quasiquote005.idr

2+${IDRIS:-idris} $@ --check --nocolour Quasiquote005.idr

3rm -f *.ibc

test/quasiquote006/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr

2+${IDRIS:-idris} $@ --check --nocolour --quiet --consolewidth 70 quasiquote006.idr

3rm -f *.ibc

test/records001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test011.idr -o test011

2+${IDRIS:-idris} $@ test011.idr -o test011

3./test011

4rm -f test011 test011.ibc

test/records002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ record002.idr -o record002

2+${IDRIS:-idris} $@ record002.idr -o record002

3./record002

4rm -f record002 *.ibc

test/records003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ records003.idr -o records003

2+${IDRIS:-idris} $@ records003.idr -o records003

3./records003

4rm -f records003 *.ibc

test/records004/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ records004.idr -o records004

2+${IDRIS:-idris} $@ records004.idr -o records004

3./records004

4rm -f records004 *.ibc

test/reg001/reg001.idr+13−14

@@ -37,7 +37,7 @@ filterTagP {n = S m} p (a :: as) q with (p a)

37 **

38 ((a ** believe_me Oh)

39 ::

40− (fst (getProof (filterTagP p as (believe_me Oh)))),

40+ (fst (snd (filterTagP p as (believe_me Oh)))),

41 Oh

42 )

43 )

@@ -95,7 +95,7 @@ mytranspose (x :: y :: xs)

95

96using (A : Type, B : A->Type, C : Type)

97 foo2 : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C)

98− foo2 f p = f (getWitness p) (getProof p)

98+ foo2 f p = f (fst p) (snd p)

99

100

101m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->

@@ -144,7 +144,7 @@ X : Nat -> Type

144X t = (c : Nat ** So (c < 5))

145

146column : X t -> Nat

147−column = getWitness

147+column = fst

148

149data Action = Left | Ahead | Right

150

@@ -161,31 +161,31 @@ isSubsetOf : Set univ => univ -> univ -> Type

161isSubsetOf {univ} a b = (c : univ) -> (member c a) -> (member c b)

162

163interface Set univ => HasPower univ where

164− Powerset : (a : univ) ->

164+ Powerset : (a : univ) ->

165− Sigma univ (\Pa => (c : univ) ->

165+ DPair univ (\Pa => (c : univ) ->

166 (isSubsetOf c a) -> member c Pa)

167

168powerset : HasPower univ => univ -> univ

169−powerset {univ} a = getWitness (Powerset a)

169+powerset {univ} a = fst (Powerset a)

170

171mapFilter : (alpha -> beta) ->

172− (alpha -> Bool) ->

172+ (alpha -> Bool) ->

173− Vect n alpha ->

173+ Vect n alpha ->

174 (n : Nat ** Vect n beta)

175mapFilter f p Nil = (_ ** Nil)

176mapFilter f p (a :: as) with (p a)

177− | True = (_ ** (f a) :: (getProof (mapFilter f p as)))

177+ | True = (_ ** (f a) :: (snd (mapFilter f p as)))

178 | False = mapFilter f p as

179

180hVectEx1 : HVect [String, List Nat, Nat, (Nat, Nat)]

181hVectEx1 = ["Hello",[1,2,3],42,(0,10)]

182−

182+

183vecfoo : HVect [String, List Nat, Nat, (Nat, Nat)]

184vecfoo = put (S (S Z)) hVectEx1

185

186foom : Monad m => Int -> m Int

187−foom = pure

187+foom = pure

188−

188+

189bar : IO ()

190bar = case foom 5 of

191 Nothing => print 42

@@ -193,7 +193,7 @@ bar = case foom 5 of

193

194Max : (Nat -> Type) -> Type

195Max p = (Nat , (k : Nat) -> p k -> Nat)

196−

196+

197maxEquiv : Max p -> (n1 : Nat) -> p n1 -> Nat

198maxEquiv a n1 pr1 = snd a n1 pr1

199

@@ -207,4 +207,3 @@ data Kappa : (r : Rho) -> Type where K : Kappa r

207kappa : Kappa (rho r) -> Kappa (rho r)

208kappa {r} k = k' where -- k' : Kappa (rho r)

209 k' = k

210−

test/reg001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris reg001.idr --check

2+${IDRIS:-idris} reg001.idr --check

3rm -rf reg001.ibc

4

test/reg002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris reg012.idr -o reg012

2+${IDRIS:-idris} reg012.idr -o reg012

3./reg012

4rm -f reg012 *.ibc

test/reg003/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --check reg003.idr

2+${IDRIS:-idris} --check reg003.idr

3−idris --consolewidth 80 --check reg003a.idr

3+${IDRIS:-idris} --check reg003a.idr

4rm -f *.ibc

test/reg004/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg004.idr -o reg004

2+${IDRIS:-idris} $@ reg004.idr -o reg004

3./reg004

4rm -f reg004 *.ibc

test/reg005/expectednew file+3

@@ -0,0 +1,3 @@

1+hey

2+you

3+[(), ()]

test/reg005/reg005.idrnew file+9

@@ -0,0 +1,9 @@

1+module UPIO

2+

3+foo : List (IO ())

4+foo = [putStrLn "hey", putStrLn "you"]

5+

6+namespace Main

7+ main : IO ()

8+ main = let stuff = map unsafePerformIO foo in putStrLn (show stuff)

9+

test/reg005/runnew file+4

@@ -0,0 +1,4 @@

1+#!/usr/bin/env bash

2+${IDRIS:-idris} $@ reg005.idr -o reg005

3+./reg005

4+rm -f reg005 *.ibc

test/reg006/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg006.idr --check

2+${IDRIS:-idris} $@ reg006.idr --check

3rm -f *.ibc

test/reg007/A.lidr+1−1

@@ -1,5 +1,5 @@

1> module A

2

3−> n : Nat

3+> public export n : Nat

4> n = ?lala

5

test/reg007/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --nocolour --check $@ reg007.lidr

2+${IDRIS:-idris} --nocolour --check $@ reg007.lidr

3rm -f *.ibc

test/reg010/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg010.idr --check --nocolour

2+${IDRIS:-idris} $@ reg010.idr --check --nocolour

test/reg013/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg013.idr -o reg013

2+${IDRIS:-idris} $@ reg013.idr -o reg013

3./reg013

4rm -f reg013 *.ibc

test/reg016/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg016.idr -o reg016

2+${IDRIS:-idris} $@ reg016.idr -o reg016

3./reg016

4rm -f reg016 *.ibc

test/reg017/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 reg017.idr -o reg017

2+${IDRIS:-idris} $@ --nocolour reg017.idr -o reg017

3./reg017

4rm -f reg017 *.ibc

test/reg018/expected+2

@@ -4,6 +4,8 @@ reg018a.idr:21:1:

4conat.loopForever is possibly not total due to: conat.minusCoNat

5reg018b.idr:8:1:

6A.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

7reg018c.idr:21:1:

9reg018c.idr:21:1:

8CodataTest.inf is possibly not total due to: with block in CodataTest.inf

10CodataTest.inf is possibly not total due to: with block in CodataTest.inf

9reg018d.idr:8:1:

11reg018d.idr:8:1:

test/reg018/reg018b.idr+1−1

@@ -8,7 +8,7 @@ showB : B -> String

8showB (I x) = "I" ++ showB x

9showB (Z x) = "Z" ++ showB x

10

11−implementation Show B where show = showB

11+Show B where show = showB

12

13os : B

14os = Z os

test/reg018/run+4−4

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg018a.idr --check

2+${IDRIS:-idris} $@ reg018a.idr --check

3−idris --consolewidth 80 $@ reg018b.idr --check

3+${IDRIS:-idris} $@ reg018b.idr --check

4−idris --consolewidth 80 $@ reg018c.idr --check

4+${IDRIS:-idris} $@ reg018c.idr --check

5−idris --consolewidth 80 $@ reg018d.idr --check

5+${IDRIS:-idris} $@ reg018d.idr --check

6rm *.ibc

test/reg020/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg020.idr -o reg020

2+${IDRIS:-idris} $@ reg020.idr -o reg020

3./reg020

4rm -f reg020 *.ibc

test/reg023/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ reg023.idr --check

2+${IDRIS:-idris} --nocolour $@ reg023.idr --check

3rm -f *.ibc

test/reg024/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg024.idr -o reg024

2+${IDRIS:-idris} $@ reg024.idr -o reg024

3./reg024

4rm -f reg024 *.ibc

test/reg025/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg025.idr -o reg025

2+${IDRIS:-idris} $@ reg025.idr -o reg025

3./reg025

4rm -f reg025 *.ibc

test/reg027/run+2−2

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg027.idr -o reg027

2+${IDRIS:-idris} $@ reg027.idr -o reg027

3./reg027

4−idris --consolewidth 80 $@ reg027a.idr --check

4+${IDRIS:-idris} $@ reg027a.idr --check

5rm -f reg027 *.ibc

test/reg028/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg028.idr --check

2+${IDRIS:-idris} $@ reg028.idr --check

3−idris --consolewidth 80 $@ reg028a.idr --check

3+${IDRIS:-idris} $@ reg028a.idr --check

4rm -f *.ibc

test/reg029/run+2−2

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2

3−idris $@ reg029.idr -o reg029

3+${IDRIS:-idris} $@ reg029.idr -o reg029

4unset IDRIS_REG029_NONEXISTENT_VAR

5export IDRIS_REG029_EXISTENT_VAR='exists!'

6

@@ -12,6 +12,6 @@ else

12 javac -cp reg029:. Reg029Wrapper.java

13 java -cp reg029:. Reg029Wrapper

14fi

15−idris $@ reg029.idr --execute

15+${IDRIS:-idris} $@ reg029.idr --execute

16rm -f reg029 *.ibc *.class

17

test/reg031/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg031.idr -o reg031

2+${IDRIS:-idris} $@ reg031.idr -o reg031

3./reg031

4rm -f *.ibc reg031

test/reg032/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test028.idr -o test028

2+${IDRIS:-idris} $@ test028.idr -o test028

3./test028

4rm -f test028 test028.ibc

test/reg034/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check reg034.idr

2+${IDRIS:-idris} --nocolour --check reg034.idr

3rm -f reg034 *.ibc

test/reg035/run+3−3

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 --check reg035.idr

2+${IDRIS:-idris} --nocolour --check reg035.idr

3−idris --nocolour --consolewidth 80 --check reg035a.lidr

3+${IDRIS:-idris} --nocolour --check reg035a.lidr

4−idris --nocolour --consolewidth 80 --check reg035b.idr

4+${IDRIS:-idris} --nocolour --check reg035b.idr

5rm -f *.ibc

test/reg036/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --check reg036.idr

2+${IDRIS:-idris} --check reg036.idr

3rm -f reg036 *.ibc

test/reg037/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --check reg037.idr

2+${IDRIS:-idris} --check reg037.idr

3rm -f reg037 *.ibc

test/reg038/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --check reg038.idr

2+${IDRIS:-idris} --check reg038.idr

3rm -f *.ibc

test/reg040/run+1−1

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2

3−idris --warnreach reg040.idr -o reg040

3+${IDRIS:-idris} --warnreach reg040.idr -o reg040

4./reg040

5

6rm -f reg040 *.ibc

test/reg041/run+2−2

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris $@ --quiet ott.idr -e example

2+${IDRIS:-idris} $@ --quiet ott.idr -e example

3−idris $@ showu.idr -o reg040

3+${IDRIS:-idris} $@ showu.idr -o reg040

4./reg040

5rm -f reg040 *.ibc

test/reg042/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg042 -o reg042 --warnreach

2+${IDRIS:-idris} $@ reg042 -o reg042 --warnreach

3./reg042

4rm -f reg042 *.ibc

test/reg044/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 reg044.idr --check

2+${IDRIS:-idris} --nocolour reg044.idr --check

3rm -f *.ibc

test/reg045/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg045.idr -o reg045

2+${IDRIS:-idris} $@ reg045.idr -o reg045

3./reg045

4rm -f reg045 *.ibc

test/reg046/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ reg046.idr --check

2+${IDRIS:-idris} $@ reg046.idr --check

3rm -f reg046 *.ibc

test/reg047/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg047.idr --check --nobuiltins

2+${IDRIS:-idris} $@ reg047.idr --check --nobuiltins

3−idris $@ reg047a.idr --check

3+${IDRIS:-idris} $@ reg047a.idr --check

4rm -f *.ibc

test/reg048/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg048.idr -p contrib -o reg048

2+${IDRIS:-idris} $@ reg048.idr -p contrib -o reg048

3./reg048

4rm -f reg048 *.ibc

test/reg049/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 --nocolour --check $@ reg049.idr

2+${IDRIS:-idris} --nocolour --check $@ reg049.idr

3rm -f *.ibc

test/reg050/run+3−3

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --nocolour --check $@ working.idr

2+${IDRIS:-idris} --nocolour --check $@ working.idr

3−idris --nocolour --check $@ badbangop.idr

3+${IDRIS:-idris} --nocolour --check $@ badbangop.idr

4−idris --nocolour --check $@ baddoublebang.idr

4+${IDRIS:-idris} --nocolour --check $@ baddoublebang.idr

5rm -f *.ibc

test/reg051-disabled/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ reg051.idr --check

2+${IDRIS:-idris} $@ reg051.idr --check

3rm -f *.ibc

test/reg052/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ -o reg052 reg052.idr

2+${IDRIS:-idris} $@ -o reg052 reg052.idr

3./reg052

4rm -f reg052 *.ibc

test/reg053/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --check four.idr

2+${IDRIS:-idris} $@ --check four.idr

3rm -f *.ibc

test/reg054/run+1−1

@@ -1,2 +1,2 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ reg054.idr --check

2+${IDRIS:-idris} --nocolour $@ reg054.idr --check

test/reg055/run+2−2

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ reg055.idr --check

2+${IDRIS:-idris} --nocolour $@ reg055.idr --check

3−idris --nocolour --consolewidth 80 $@ reg055a.idr --check

3+${IDRIS:-idris} --nocolour $@ reg055a.idr --check

4rm -f *.ibc

5

test/reg056/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ reg056.idr -o reg056

2+${IDRIS:-idris} $@ reg056.idr -o reg056

3rm -f *.ibc

test/reg057/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ reg057.idr --check

2+${IDRIS:-idris} $@ reg057.idr --check

3rm -f *.ibc

test/reg058/run+2−2

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris $@ implicits.idr --check

2+${IDRIS:-idris} $@ implicits.idr --check

3−idris $@ implicits2.idr --check

3+${IDRIS:-idris} $@ implicits2.idr --check

4

5rm -f *.ibc

test/reg059/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ reg059.idr --check

2+${IDRIS:-idris} $@ reg059.idr --check

3rm -f *.ibc

test/reg060/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ reg060.idr --check

2+${IDRIS:-idris} $@ reg060.idr --check

3rm -f *.ibc

test/reg061/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ Capture.idr --check

2+${IDRIS:-idris} $@ Capture.idr --check

3rm -f *.ibc

test/reg062/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ reg062.idr --check --nocolour

2+${IDRIS:-idris} $@ reg062.idr --check --nocolour

3−idris $@ reg062.lidr --check --nocolour

3+${IDRIS:-idris} $@ reg062.lidr --check --nocolour

4rm -f *.ibc

test/reg063/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ Cmp.idr --check --nocolour --quiet

2+${IDRIS:-idris} $@ Cmp.idr --check --nocolour --quiet

3rm *.ibc

test/reg064/reg064.idr+6−7

@@ -1,9 +1,8 @@

1−sigmaEq2 : {A : Type} ->

1+sigmaEq2 : {A : Type} ->

2− {P : A -> Type} ->

2+ {P : A -> Type} ->

3− {s1: Sigma A P} ->

3+ {s1: DPair A P} ->

4− {s2: Sigma A P} ->

4+ {s2: DPair A P} ->

5− getWitness s1 = getWitness s2 ->

5+ fst s1 = fst s2 ->

6− getProof s1 = getProof s2 ->

6+ snd s1 = snd s2 ->

7 s1 = s2

8sigmaEq2 {A} {P} {s1 = (x ** prf)} {s2 = (x ** prf)} Refl Refl = Refl

9−

test/reg064/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ reg064.idr --check

2+${IDRIS:-idris} $@ reg064.idr --check

3rm -f *.ibc

test/reg065/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ reg065.idr --check

2+${IDRIS:-idris} $@ reg065.idr --check

3rm -f *.ibc

test/reg066/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ reg066.idr --check --nocolor

2+${IDRIS:-idris} $@ reg066.idr --check --nocolor

3rm -f *.ibc

test/reg067/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2rm -f *.ibc reg067

3−idris $@ reg067.idr -o reg067 --warnreach

3+${IDRIS:-idris} $@ reg067.idr -o reg067 --warnreach

4./reg067

5rm -f *.ibc reg067

test/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 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 SourceLoc.idr -o sourceLocation001

2+${IDRIS:-idris} $@ --nocolour SourceLoc.idr -o sourceLocation001

3./sourceLocation001

4rm -f sourceLocation001 *.ibc

test/sugar001/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test007.idr -o test007

2+${IDRIS:-idris} $@ test007.idr -o test007

3./test007

4rm -f test007 test007.ibc

test/sugar002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test009.idr -o test009

2+${IDRIS:-idris} $@ test009.idr -o test009

3./test009

4rm -f test009 test009.ibc

test/sugar003/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ test013.idr -o test013

2+${IDRIS:-idris} $@ test013.idr -o test013

3./test013

4rm -f test013 test013.ibc

test/sugar004/run+1−1

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris $@ sugar004.idr -o sugar004

2+${IDRIS:-idris} $@ sugar004.idr -o sugar004

3./sugar004

4./sugar004 42

5./sugar004 42 100

test/sugar005/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ As.idr -o sugar005

2+${IDRIS:-idris} $@ As.idr -o sugar005

3./sugar005

4rm -f sugar005 *.ibc

test/syntax001/expected+2−2

@@ -2,7 +2,7 @@ Syntax.idr:6:7-9:1:

2When checking right hand side of foo with expected type

3 Nat

4

5−When checking an application of function Prelude.Classes.+:

5+When checking an application of function Prelude.Interfaces.+:

6 Type mismatch between

7 String (Type of "argh")

8 and

@@ -11,7 +11,7 @@ SyntaxTest.idr:5:7-6:1:

11When checking right hand side of foo with expected type

12 Nat

13

14−When checking an application of function Prelude.Classes.+:

14+When checking an application of function Prelude.Interfaces.+:

15 Type mismatch between

16 String (Type of "argh")

17 and

test/syntax001/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ Syntax.idr --nocolour --consolewidth 80 --check

2+${IDRIS:-idris} $@ Syntax.idr --nocolour --check

3−idris $@ SyntaxTest.idr --nocolour --consolewidth 80 --check

3+${IDRIS:-idris} $@ SyntaxTest.idr --nocolour --check

4rm -f *.ibc

test/syntax002/run+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris $@ syntax002.idr -o syntax002

2+${IDRIS:-idris} $@ syntax002.idr -o syntax002

3./syntax002

4rm -f syntax002 *.ibc

test/tactics001/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --check Tactics.idr

2+${IDRIS:-idris} $@ --check Tactics.idr

3rm -f *.ibc

test/totality001/run+3−3

@@ -1,6 +1,6 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check test010.idr

2+${IDRIS:-idris} $@ --check test010.idr

3−idris --consolewidth 80 $@ --check test010a.idr

3+${IDRIS:-idris} $@ --check test010a.idr

4−idris --consolewidth 80 $@ --check test010b.idr

4+${IDRIS:-idris} $@ --check test010b.idr

5

6rm -f *.ibc

test/totality002/run+3−3

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ --check test017.idr

2+${IDRIS:-idris} $@ --check test017.idr

3−idris --consolewidth 80 $@ --check test017a.idr

3+${IDRIS:-idris} $@ --check test017a.idr

4−idris --consolewidth 80 $@ --check test017b.idr

4+${IDRIS:-idris} $@ --check test017b.idr

5rm -f *.ibc

test/totality003/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ totality003.idr --check

2+${IDRIS:-idris} --nocolour $@ totality003.idr --check

3−idris --nocolour --consolewidth 80 $@ totality003a.idr --check

3+${IDRIS:-idris} --nocolour $@ totality003a.idr --check

4rm -f *.ibc

test/totality004/run+2−2

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ totality004.idr -o totality004

2+${IDRIS:-idris} $@ totality004.idr -o totality004

3./totality004

4−idris --consolewidth 80 $@ --check totality004a.idr

4+${IDRIS:-idris} $@ --check totality004a.idr

5rm -f totality004 *.ibc

test/totality005/run+2−2

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris $@ totality005.idr --total --check

2+${IDRIS:-idris} $@ totality005.idr --total --check

3−idris $@ totality005.idr -o totality005

3+${IDRIS:-idris} $@ totality005.idr -o totality005

4./totality005

5rm -f totality005 *.ibc

test/totality006/run+3−3

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ totality006.idr --check

2+${IDRIS:-idris} $@ totality006.idr --check

3−idris --consolewidth 80 $@ totality006a.idr --check

3+${IDRIS:-idris} $@ totality006a.idr --check

4−idris --consolewidth 80 $@ totality006b.idr --check

4+${IDRIS:-idris} $@ totality006b.idr --check

5rm -f *.ibc

test/totality007/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --build totality.ipkg

2+${IDRIS:-idris} $@ --build totality.ipkg

3rm -f src/*.ibc

test/totality008/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --consolewidth 80 $@ totality008.idr --check

2+${IDRIS:-idris} $@ totality008.idr --check

3rm -f *.ibc

test/totality009/run+2−2

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2OPTS="--consolewidth infinite --nocolour"

3−idris "$@" $OPTS --check TestLambdaImpossible

3+${IDRIS:-idris} "$@" $OPTS --check TestLambdaImpossible

4−idris "$@" $OPTS --check --warnpartial TestLambdaPossible

4+${IDRIS:-idris} "$@" $OPTS --check --warnpartial TestLambdaPossible

5rm -f *.ibc

test/totality010/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ totality010.idr --nocolour --consolewidth 80 --check

2+${IDRIS:-idris} $@ totality010.idr --nocolour --check

3rm -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 @@

1#!/usr/bin/env bash

2−idris --check tutorial001.idr

2+${IDRIS:-idris} --check tutorial001.idr

3rm -f *.ibc

test/tutorial002/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ --nocolour --consolewidth 80 tutorial002.idr --check

2+${IDRIS:-idris} $@ --nocolour tutorial002.idr --check

3rm -f *.ibc

test/tutorial003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ tutorial003.idr --check

2+${IDRIS:-idris} $@ tutorial003.idr --check

3rm -f *.ibc

test/tutorial004/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ tutorial004.idr --check --nocolour --consolewidth 80

2+${IDRIS:-idris} $@ tutorial004.idr --check --nocolour

3rm -f *.ibc

test/tutorial005/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris $@ tutorial005.idr --check

2+${IDRIS:-idris} $@ tutorial005.idr --check

3rm -f *.ibc

test/tutorial006/expected+1−1

@@ -18,7 +18,7 @@ When checking right hand side of with block in Main.parity with expected type

18 Parity (S (S (j + j)))

19

20Type mismatch between

21− Parity (plus (S j) (S j)) (Type of Even)

21+ Parity (S j + S j) (Type of Even)

22and

23 Parity (S (S (plus j j))) (Expected type)

24

test/tutorial006/run+3−3

@@ -1,5 +1,5 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ tutorial006a.idr --check

2+${IDRIS:-idris} --nocolour $@ tutorial006a.idr --check

3−idris --nocolour --consolewidth 80 $@ tutorial006b.idr --check

3+${IDRIS:-idris} --nocolour $@ tutorial006b.idr --check

4−idris --nocolour --consolewidth 80 $@ tutorial006c.idr -p effects --check

4+${IDRIS:-idris} --nocolour $@ tutorial006c.idr -p effects --check

5rm -f *.ibc

test/unique001/run+6−6

@@ -1,9 +1,9 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ unique001.idr -o unique001

2+${IDRIS:-idris} --nocolour $@ unique001.idr -o unique001

3./unique001

4−idris --nocolour --consolewidth 80 $@ unique001a.idr --check

4+${IDRIS:-idris} --nocolour $@ unique001a.idr --check

5−idris --nocolour --consolewidth 80 $@ unique001b.idr --check

5+${IDRIS:-idris} --nocolour $@ unique001b.idr --check

6−idris --nocolour --consolewidth 80 $@ unique001c.idr --check

6+${IDRIS:-idris} --nocolour $@ unique001c.idr --check

7−idris --nocolour --consolewidth 80 $@ unique001d.idr --check

7+${IDRIS:-idris} --nocolour $@ unique001d.idr --check

8−idris --nocolour --consolewidth 80 $@ unique001e.idr --check

8+${IDRIS:-idris} --nocolour $@ unique001e.idr --check

9rm -f unique001 *.ibc

test/unique001/unique001c.idr−4

@@ -44,7 +44,3 @@ data MPair : AnyType -> AnyType -> AnyType where

44

45ndup : {a : UniqueType} -> a -> UPair a a

46ndup {a} x = (\f : Int -> a => MkUPair (f 0) (f 1)) (uconst x)

47−

48−

49−

50−

test/unique002/run+2−2

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ unique002.idr --check

2+${IDRIS:-idris} --nocolour $@ unique002.idr --check

3−idris --nocolour --consolewidth 80 $@ unique002a.idr --check

3+${IDRIS:-idris} --nocolour $@ unique002a.idr --check

4rm -f *.ibc

test/unique003/run+1−1

@@ -1,3 +1,3 @@

1#!/usr/bin/env bash

2−idris --nocolour --consolewidth 80 $@ unique003.idr --check

2+${IDRIS:-idris} --nocolour $@ unique003.idr --check

3rm -f *.ibc