681d876 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

on master help sign in

Merge branch 'master' into agda-style-records

681d876Sune Alkærsig12 years ago

.gitignore+2

compare with master

unifiedsplit

@@ -14,6 +14,8 @@ cabal.sandbox.config

14.DS_Store

15.hpc

16*.tix

17+.projectile

18+.dir-locals.el

17custom.mk

19custom.mk

18libs/base/base_doc/

20libs/base/base_doc/

19libs/effects/effects_doc/

21libs/effects/effects_doc/

.travis.yml+6

@@ -1,4 +1,10 @@

1language: haskell

2+ghc:

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

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

5+ - 7.6

6+ - 7.8

2before_install:

8before_install:

3 - sudo add-apt-repository --yes ppa:h-rayflood/llvm

9 - sudo add-apt-repository --yes ppa:h-rayflood/llvm

4 - sudo apt-get update -qq

10 - sudo apt-get update -qq

CHANGELOG+11

@@ -1,3 +1,14 @@

1+New in 0.9.17:

2+--------------

3+* The --ideslave command line option has been replaced with a --ide-mode

4+ command line option with the same semantics.

5+* A new tactic "claim N TY" that introduces a new hole named N with type TY

6+* A new tactic "unfocus" that moves the current hole to the bottom of the

7+ hole stack

8+* Quasiquotation supports the generation of Language.Reflection.Raw terms

9+ in addition to Language.Reflection.TT. Types are used for disambiguation,

10+ defaulting to TT at the REPL.

11+

1New in 0.9.16:

12New in 0.9.16:

2--------------

13--------------

3* Inductive-inductive definitions are now supported (i.e. simultaneously

14* Inductive-inductive definitions are now supported (i.e. simultaneously

CITATION.mdnew file+29

@@ -0,0 +1,29 @@

1+# Citing `Idris`

3+If you use `Idris` in your work we would prefer it if you would use the following reference in your work.

5+## BibTeX

7+```bibtex

8+@article{JFP:9060502,

9+ author = {BRADY,EDWIN},

10+ title = {Idris, a general-purpose dependently typed programming language: Design and implementation},

11+ journal = {Journal of Functional Programming},

12+ volume = {23},

13+ issue = {05},

14+ month = {9},

15+ year = {2013},

16+ issn = {1469-7653},

17+ pages = {552--593},

18+ numpages = {42},

19+ doi = {10.1017/S095679681300018X},

20+ URL = {http://journals.cambridge.org/article_S095679681300018X},

21+}

22+```

23+

24+## Textual

25+

26+ EDWIN BRADY (2013). Idris, a general-purpose dependently typed

27+ programming language: Design and implementation. Journal of

28+ Functional Programming, 23, pp

29+ 552-593. doi:10.1017/S095679681300018X.

CONTRIBUTORS+3−2

@@ -7,6 +7,8 @@ Jan Bessai

7Michael R. Bernstein

8Nicola Botta

9Edwin Brady

10+Jakob Brünker

11+Alyssa Carter

10David Raymond Christiansen

12David Raymond Christiansen

11Carter Charbonneau

13Carter Charbonneau

12Jason Dagit

14Jason Dagit

@@ -28,6 +30,7 @@ Philip Rasmussen

28Reynir Reynisson

30Reynir Reynisson

29Seo Sanghyeon

31Seo Sanghyeon

30Benjamin Saunders

32Benjamin Saunders

33+Alexander Shabalin

31startling

34startling

32Chetan T

35Chetan T

33Matúš Tejiščák

36Matúš Tejiščák

@@ -35,5 +38,3 @@ Dirk Ullrich

35Leif Warner

38Leif Warner

36Daniel Waterworth

39Daniel Waterworth

37Jonas Westerlund

40Jonas Westerlund

38−Alyssa Carter

39−Alexander Shabalin

Setup.hs+1−1

@@ -106,7 +106,7 @@ generateVersionModule verbosity dir release = do

106 "gitHash :: String\n" ++

107 if release

108 then "gitHash = \"\"\n"

109− else "gitHash = \"-git:" ++ h ++ "\"\n"

109+ else "gitHash = \"git:" ++ h ++ "\"\n"

110

111-- Generate a module that contains the lib path for a freestanding Idris

112generateTargetModule verbosity dir targetDir = do

contribs/lib/SQLite3/Makefile+2−3

@@ -7,10 +7,9 @@ sqltest : testunit.idr Sqlite3.idr sqlite3api.o

7 idris testunit.idr -o sqltest

9sqlite3api.o : sqlite3api.c

10− gcc -c sqlite3api.c

10+ gcc -I . -c sqlite3api.c

12sqlite3api.so: sqlite3api.c

13− gcc -fPIC -o sqlite3api.so -shared sqlite3api.c

13+ gcc -I . -fPIC -o sqlite3api.so -shared sqlite3api.c

15all : sqltest sqlite3api.o

16−

contribs/lib/SQLite3/Sqlite3.idr+42−48

@@ -1,8 +1,9 @@

1module Sqlite3

2−import Sqlexpr

2+import public Sqlexpr

3−

5%lib C "sqlite3"

4%lib C "sqlite3"

5+-- %link C "sqlite3.o"

6+-- %include C "sqlite3.h"

6%link C "sqlite3api.o"

7%link C "sqlite3api.o"

7%include C "sqlite3api.h"

8%include C "sqlite3api.h"

@@ -59,7 +60,7 @@ instance Monad DB where

59 Left err => return (Left err)

60 Left err => return (Left err)

60 Right v => case k v of

61 Right v => case k v of

61 MkDB k' => k')

62 MkDB k' => k')

62− return x = MkDB (return (Right x))

63+ --return x = MkDB (return (Right x))

64fail : String -> DB a

65fail : String -> DB a

65fail err = MkDB (return (Left err))

66fail err = MkDB (return (Left err))

@@ -83,7 +84,7 @@ runDB (MkDB f) = do f' <- f

83-----------------------------------------------------------------------------

84-----------------------------------------------------------------------------

85open_db : String -> DB DBPointer

86open_db : String -> DB DBPointer

86−open_db name = do x <- liftIO (mkForeign (FFun "sqlite3_open_idr" [FString] FPtr) name)

87+open_db name = do x <- liftIO (foreign FFI_C "sqlite3_open_idr" (String -> IO Ptr) name)

87 return (MkDBPointer x)

88 return (MkDBPointer x)

89-----------------------------------------------------------------------------

90-----------------------------------------------------------------------------

@@ -91,7 +92,7 @@ open_db name = do x <- liftIO (mkForeign (FFun "sqlite3_open_idr" [FString] FPtr

91-----------------------------------------------------------------------------

92-----------------------------------------------------------------------------

93close_db : DBPointer -> DB Int

94close_db : DBPointer -> DB Int

94−close_db (MkDBPointer pointer) = liftIO (mkForeign (FFun "sqlite3_close_idr" [FPtr] FInt) pointer)

95+close_db (MkDBPointer pointer) = liftIO (foreign FFI_C "sqlite3_close_idr" (Ptr -> IO Int) pointer)

96-----------------------------------------------------------------------------

97-----------------------------------------------------------------------------

97-- | Wrapper around prepare, step and finalize.

98-- | Wrapper around prepare, step and finalize.

@@ -99,7 +100,7 @@ close_db (MkDBPointer pointer) = liftIO (mkForeign (FFun "sqlite3_close_idr" [FP

100

100exec_db : DBPointer -> String -> DB Int

101exec_db : DBPointer -> String -> DB Int

101exec_db (MkDBPointer pointer) stmt = do

102exec_db (MkDBPointer pointer) stmt = do

102− x <- liftIO (mkForeign (FFun "sqlite3_exec_idr" [FPtr, FString] FInt) pointer stmt)

103+ x <- liftIO (foreign FFI_C "sqlite3_exec_idr" (Ptr -> String -> IO Int) pointer stmt)

103 if (x == 1)

104 if (x == 1)

104 then fail "Could not execute."

105 then fail "Could not execute."

105 else return x

106 else return x

@@ -110,7 +111,7 @@ exec_db (MkDBPointer pointer) stmt = do

110

111

111exec_db_v2 : StmtPtr -> DB Int

112exec_db_v2 : StmtPtr -> DB Int

112exec_db_v2 (MkStmtPtr pointer) = do

113exec_db_v2 (MkStmtPtr pointer) = do

113− x <- liftIO (mkForeign (FFun "exec_db" [FPtr] FInt) pointer)

114+ x <- liftIO (foreign FFI_C "exec_db" (Ptr -> IO Int) pointer)

114 if (x == 21)

115 if (x == 21)

115 then fail "No data returned."

116 then fail "No data returned."

116 else return x

117 else return x

@@ -122,8 +123,7 @@ exec_db_v2 (MkStmtPtr pointer) = do

122-----------------------------------------------------------------------------

123-----------------------------------------------------------------------------

123

124

124get_error : DBPointer -> IO String

125get_error : DBPointer -> IO String

125−get_error (MkDBPointer pointer) = mkForeign (FFun "sqlite3_get_error" [FPtr] FString) pointer

126+get_error (MkDBPointer pointer) = foreign FFI_C "sqlite3_get_error" (Ptr -> IO String) pointer

126−

127

128-----------------------------------------------------------------------------

129-- | Compiles the query inot a byte-code program in order to execute it.

@@ -133,7 +133,7 @@ get_error (MkDBPointer pointer) = mkForeign (FFun "sqlite3_get_error" [FPtr] FSt

133

134prepare_db : DBPointer -> String -> DB StmtPtr

135prepare_db (MkDBPointer pointer) cmd = do

136− result <- liftIO (mkForeign (FFun "sqlite3_prepare_idr" [FPtr, FString] FPtr) pointer cmd)

136+ result <- liftIO (foreign FFI_C "sqlite3_prepare_idr" (Ptr -> String -> IO Ptr) pointer cmd)

137 flag <- liftIO (nullPtr result)

138 if flag

139 then fail "Error occured while preparing"

@@ -147,8 +147,8 @@ prepare_db (MkDBPointer pointer) cmd = do

147

148step_db : StmtPtr -> DB Int

149step_db (MkStmtPtr pointer)= do

150− x <- liftIO (mkForeign (FFun "sqlite3_step_idr" [FPtr] FInt)pointer)

150+ x <- liftIO (foreign FFI_C "sqlite3_step_idr" (Ptr -> IO Int) pointer)

151− if ( x == 101)

151+ if (x == 101)

152 then fail "SQLITE_DONE"

153 else return x

154

@@ -159,7 +159,7 @@ step_db (MkStmtPtr pointer)= do

159

160finalize_db : StmtPtr -> DB Int

161finalize_db (MkStmtPtr pointer) = do

162− x <- liftIO (mkForeign (FFun "sqlite3_finalize_idr" [FPtr] FInt) pointer)

162+ x <- liftIO (foreign FFI_C "sqlite3_finalize_idr" (Ptr -> IO Int) pointer)

163 if (x /= 0)

164 then fail "Could not finalize"

165 else return x

@@ -170,7 +170,7 @@ finalize_db (MkStmtPtr pointer) = do

170

171reset_db : StmtPtr -> DB Int

172reset_db (MkStmtPtr pointer) = do

173− x <- liftIO (mkForeign (FFun "sqlite3_reset_idr" [FPtr] FInt) pointer)

173+ x <- liftIO (foreign FFI_C "sqlite3_reset_idr" (Ptr -> IO Int) pointer)

174 if (x /= 0)

175 then fail "Could not reset"

176 else return x

@@ -181,38 +181,34 @@ reset_db (MkStmtPtr pointer) = do

181

182column_count : DBPointer -> IO (Either String Int)

183column_count (MkDBPointer pointer) = do

184− x <- mkForeign (FFun "sqlite3_column_count_idr" [FPtr] FInt) pointer

184+ x <- foreign FFI_C "sqlite3_column_count_idr" (Ptr -> IO Int) pointer

185− return $ if (x == 0 )

185+ return $ if (x == 0)

186 then Left "No Data"

187 else (Right x)

188

189column_name : DBPointer -> Int -> IO String

190column_name (MkDBPointer pointer) iCol =

191− mkForeign (FFun "sqlite3_column_name_idr" [FPtr, FInt] FString) pointer iCol

191+ foreign FFI_C "sqlite3_column_name_idr" (Ptr -> Int -> IO String) pointer iCol

192

193column_decltype : DBPointer -> Int -> IO String

194column_decltype (MkDBPointer pointer) iCol =

195− mkForeign (FFun "sqlite3_column_decltype_idr" [FPtr, FInt] FString) pointer iCol

195+ foreign FFI_C "sqlite3_column_decltype_idr" (Ptr -> Int -> IO String) pointer iCol

196−

197

196

198column_bytes : DBPointer -> Int -> IO Int

197column_bytes : DBPointer -> Int -> IO Int

199column_bytes (MkDBPointer pointer) iCol =

198column_bytes (MkDBPointer pointer) iCol =

200− mkForeign (FFun "sqlite3_column_bytes_idr" [FPtr, FInt] FInt) pointer iCol

199+ foreign FFI_C "sqlite3_column_bytes_idr" (Ptr -> Int -> IO Int) pointer iCol

201−

202

200

203column_blob : DBPointer -> Int -> IO String

201column_blob : DBPointer -> Int -> IO String

204column_blob (MkDBPointer pointer) iCol =

202column_blob (MkDBPointer pointer) iCol =

205− mkForeign (FFun "sqlite3_column_bytes_idr" [FPtr, FInt] FString) pointer iCol

203+ foreign FFI_C "sqlite3_column_bytes_idr" (Ptr -> Int -> IO String) pointer iCol

206−

207

204

208column_text : DBPointer -> Int -> IO String

205column_text : DBPointer -> Int -> IO String

209column_text (MkDBPointer pointer) iCol =

206column_text (MkDBPointer pointer) iCol =

210− mkForeign (FFun "sqlite3_column_text_idr" [FPtr, FInt] FString) pointer iCol

207+ foreign FFI_C "sqlite3_column_text_idr" (Ptr -> Int -> IO String) pointer iCol

211−

212

208

213column_Int : DBPointer -> Int -> IO Int

209column_Int : DBPointer -> Int -> IO Int

214column_Int (MkDBPointer pointer) iCol =

210column_Int (MkDBPointer pointer) iCol =

215− mkForeign (FFun "sqlite3_column_int_idr" [FPtr, FInt] FInt) pointer iCol

211+ foreign FFI_C "sqlite3_column_int_idr" (Ptr -> Int -> IO Int) pointer iCol

216

212

217-----------------------------------------------------------------------------

213-----------------------------------------------------------------------------

218-- | These routines support some of SQLite backup functions.

214-- | These routines support some of SQLite backup functions.

@@ -220,22 +216,21 @@ column_Int (MkDBPointer pointer) iCol =

220

216

221backup_init : DBPointer -> String -> DBPointer -> String -> IO DBPointer

217backup_init : DBPointer -> String -> DBPointer -> String -> IO DBPointer

222backup_init (MkDBPointer des_pointer) destName (MkDBPointer src_pointer) srcName =

218backup_init (MkDBPointer des_pointer) destName (MkDBPointer src_pointer) srcName =

223− do x <- mkForeign (FFun "sqlite3_backup_init_idr" [FPtr,FString, FPtr, FString] FPtr)

219+ do x <- foreign FFI_C "sqlite3_backup_init_idr" (Ptr -> String -> Ptr -> String -> IO Ptr)

224 des_pointer destName src_pointer srcName

220 des_pointer destName src_pointer srcName

225 return (MkDBPointer x)

221 return (MkDBPointer x)

226

222

227backup_step : DBPointer -> Int -> IO Int

223backup_step : DBPointer -> Int -> IO Int

228backup_step (MkDBPointer pointer) nPage =

224backup_step (MkDBPointer pointer) nPage =

229− mkForeign (FFun "sqlite3_backup_step_idr" [FPtr, FInt] FInt) pointer nPage

225+ foreign FFI_C "sqlite3_backup_step_idr" (Ptr -> Int -> IO Int) pointer nPage

230

226

231backup_finish : DBPointer -> IO Int

227backup_finish : DBPointer -> IO Int

232backup_finish (MkDBPointer pointer) =

228backup_finish (MkDBPointer pointer) =

233− mkForeign (FFun "sqlite3_backup_finish_idr" [FPtr] FInt) pointer

229+ foreign FFI_C "sqlite3_backup_finish_idr" (Ptr -> IO Int) pointer

234

230

235backup_remaining : DBPointer -> IO Int

231backup_remaining : DBPointer -> IO Int

236backup_remaining (MkDBPointer pointer) =

232backup_remaining (MkDBPointer pointer) =

237− mkForeign (FFun "sqlite3_backup_remaining_idr" [FPtr] FInt) pointer

233+ foreign FFI_C "sqlite3_backup_remaining_idr" (Ptr -> IO Int) pointer

238−

239

234

240-----------------------------------------------------------------------------

235-----------------------------------------------------------------------------

241-- | Use of this interface is not recommended.

236-- | Use of this interface is not recommended.

@@ -246,19 +241,18 @@ backup_remaining (MkDBPointer pointer) =

246

241

247get_table : DBPointer -> String -> DB TBPointer

242get_table : DBPointer -> String -> DB TBPointer

248get_table (MkDBPointer pointer) name = do

243get_table (MkDBPointer pointer) name = do

249− x <- liftIO(mkForeign (FFun "sqlite3_get_table_idr" [FPtr, FString] FPtr) pointer name)

244+ x <- liftIO(foreign FFI_C "sqlite3_get_table_idr" (Ptr -> String -> IO Ptr) pointer name)

250 flag <- liftIO (nullPtr x)

245 flag <- liftIO (nullPtr x)

251 if flag

246 if flag

252 then do x <- liftIO(get_error_table pointer) ; fail x

247 then do x <- liftIO(get_error_table pointer) ; fail x

253 else return (MkTBPointer x)

248 else return (MkTBPointer x)

254 where

249 where

255 get_error_table : Ptr-> IO String

250 get_error_table : Ptr-> IO String

256− get_error_table pointer = do x <- mkForeign (FFun "sqlite3_get_error" [FPtr] FString) pointer

251+ get_error_table pointer = do x <- foreign FFI_C "sqlite3_get_error" (Ptr -> IO String) pointer

257 return x

252 return x

258

253

259−

260free_table : TBPointer -> IO ()

254free_table : TBPointer -> IO ()

261−free_table (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_free_table_idr" [FPtr] FUnit) pointer

255+free_table (MkTBPointer pointer) = do x <- foreign FFI_C "sqlite3_free_table_idr" (Ptr -> IO ()) pointer

262 return ()

256 return ()

263

257

264-----------------------------------------------------------------------------

258-----------------------------------------------------------------------------

@@ -267,11 +261,11 @@ free_table (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_free_table_i

267-----------------------------------------------------------------------------

261-----------------------------------------------------------------------------

268

262

269num_row : TBPointer -> IO Int

263num_row : TBPointer -> IO Int

270−num_row (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_row" [FPtr] FInt) pointer

264+num_row (MkTBPointer pointer) = do x <- foreign FFI_C "sqlite3_get_num_row" (Ptr -> IO Int) pointer

271 return x

265 return x

272

266

273num_col : TBPointer -> IO Int

267num_col : TBPointer -> IO Int

274−num_col (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_col" [FPtr] FInt) pointer

268+num_col (MkTBPointer pointer) = do x <- foreign FFI_C "sqlite3_get_num_col" (Ptr -> IO Int) pointer

275 return x

269 return x

276

270

277-----------------------------------------------------------------------------

271-----------------------------------------------------------------------------

@@ -280,11 +274,11 @@ num_col (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_col" [F

280-----------------------------------------------------------------------------

274-----------------------------------------------------------------------------

281

275

282num_row_v2 : DBPointer -> IO Int

276num_row_v2 : DBPointer -> IO Int

283−num_row_v2 (MkDBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_row_v2" [FPtr] FInt) pointer

277+num_row_v2 (MkDBPointer pointer) = do x <- foreign FFI_C "sqlite3_get_num_row_v2" (Ptr -> IO Int) pointer

284 return x

278 return x

285

279

286num_col_v2 : DBPointer -> IO Int

280num_col_v2 : DBPointer -> IO Int

287−num_col_v2 (MkDBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_col_v2" [FPtr] FInt) pointer

281+num_col_v2 (MkDBPointer pointer) = do x <- foreign FFI_C "sqlite3_get_num_col_v2" (Ptr -> IO Int) pointer

288 return x

282 return x

289

283

290-----------------------------------------------------------------------------

284-----------------------------------------------------------------------------

@@ -299,18 +293,18 @@ get_data (MkDBPointer pointer) row col = do

299 helper ty

293 helper ty

300 where get_data_type : Ptr ->Int -> Int -> IO Int

294 where get_data_type : Ptr ->Int -> Int -> IO Int

301 get_data_type pointer row col =

295 get_data_type pointer row col =

302− mkForeign (FFun "sqlite3_get_data_type" [FPtr, FInt, FInt] FInt) pointer row col

296+ foreign FFI_C "sqlite3_get_data_type" (Ptr -> Int -> Int -> IO Int) pointer row col

303 get_data_val_int : Ptr -> Int -> IO Int

297 get_data_val_int : Ptr -> Int -> IO Int

304 get_data_val_int pointer col =

298 get_data_val_int pointer col =

305− mkForeign (FFun "sqlite3_get_val_int" [FPtr,FInt] FInt) pointer col

299+ foreign FFI_C "sqlite3_get_val_int" (Ptr -> Int -> IO Int) pointer col

306

300

307 get_data_val_text : Ptr -> Int -> IO String

301 get_data_val_text : Ptr -> Int -> IO String

308 get_data_val_text pointer col =

302 get_data_val_text pointer col =

309− mkForeign (FFun "sqlite3_get_val_text" [FPtr, FInt] FString) pointer col

303+ foreign FFI_C "sqlite3_get_val_text" (Ptr -> Int -> IO String) pointer col

310

304

311 get_data_val_float : Ptr -> Int -> IO Float

305 get_data_val_float : Ptr -> Int -> IO Float

312 get_data_val_float pointer col =

306 get_data_val_float pointer col =

313− mkForeign (FFun "sqlite3_get_float" [FPtr, FInt] FFloat) pointer col

307+ foreign FFI_C "sqlite3_get_float" (Ptr -> Int -> IO Float) pointer col

314

308

315 helper : Int -> IO DBVal

309 helper : Int -> IO DBVal

316 helper 1 = do i <- get_data_val_int pointer col ; return (DBInt i)

310 helper 1 = do i <- get_data_val_int pointer col ; return (DBInt i)

@@ -360,7 +354,7 @@ strcat str1 str2 = str1 ++ str2

360

354

361bind_int : StmtPtr -> Int -> Int -> DB StmtPtr

355bind_int : StmtPtr -> Int -> Int -> DB StmtPtr

362bind_int (MkStmtPtr pointer) indexval val = do

356bind_int (MkStmtPtr pointer) indexval val = do

363− x <- liftIO (mkForeign (FFun "sqlite3_bind_int_idr" [FPtr, FInt, FInt] FPtr) pointer indexval val)

357+ x <- liftIO (foreign FFI_C "sqlite3_bind_int_idr" (Ptr -> Int -> Int -> IO Ptr) pointer indexval val)

364 flag <- liftIO (nullPtr x)

358 flag <- liftIO (nullPtr x)

365 if flag

359 if flag

366 then fail "Could not bind int."

360 then fail "Could not bind int."

@@ -369,7 +363,7 @@ bind_int (MkStmtPtr pointer) indexval val = do

369

363

370bind_float : StmtPtr -> Int -> Float -> DB StmtPtr

364bind_float : StmtPtr -> Int -> Float -> DB StmtPtr

371bind_float (MkStmtPtr pointer) indexval val = do

365bind_float (MkStmtPtr pointer) indexval val = do

372− x <- liftIO (mkForeign (FFun "sqlite3_bind_float_idr" [FPtr, FInt, FFloat] FPtr) pointer indexval val)

366+ x <- liftIO (foreign FFI_C "sqlite3_bind_float_idr" (Ptr -> Int -> Float -> IO Ptr) pointer indexval val)

373 flag <- liftIO (nullPtr x)

367 flag <- liftIO (nullPtr x)

374 if flag

368 if flag

375 then fail "Could not bind float."

369 then fail "Could not bind float."

@@ -377,7 +371,7 @@ bind_float (MkStmtPtr pointer) indexval val = do

377

371

378bind_text : StmtPtr -> String -> Int -> Int -> DB StmtPtr

372bind_text : StmtPtr -> String -> Int -> Int -> DB StmtPtr

379bind_text (MkStmtPtr pointer) text indexval lengthval = do

373bind_text (MkStmtPtr pointer) text indexval lengthval = do

380− x <- liftIO (mkForeign (FFun "sqlite3_bind_text_idr" [FPtr, FString, FInt, FInt] FPtr)

374+ x <- liftIO (foreign FFI_C "sqlite3_bind_text_idr" (Ptr -> String -> Int -> Int -> IO Ptr)

381 pointer text indexval lengthval)

375 pointer text indexval lengthval)

382 flag <- liftIO(nullPtr x)

376 flag <- liftIO(nullPtr x)

383 if flag

377 if flag

@@ -386,7 +380,7 @@ bind_text (MkStmtPtr pointer) text indexval lengthval = do

386

380

387bind_null : StmtPtr -> Int -> DB StmtPtr

381bind_null : StmtPtr -> Int -> DB StmtPtr

388bind_null (MkStmtPtr pointer) indexval = do

382bind_null (MkStmtPtr pointer) indexval = do

389− x <- liftIO (mkForeign (FFun "sqlite3_bind_null_idr" [FPtr, FInt] FPtr) pointer indexval)

383+ x <- liftIO (foreign FFI_C "sqlite3_bind_null_idr" (Ptr -> Int -> IO Ptr) pointer indexval)

390 flag <- liftIO (nullPtr x)

384 flag <- liftIO (nullPtr x)

391 if flag

385 if flag

392 then fail "Could not bind null."

386 then fail "Could not bind null."

@@ -397,7 +391,7 @@ bind_null (MkStmtPtr pointer) indexval = do

397-----------------------------------------------------------------------------

391-----------------------------------------------------------------------------

398

392

399strlen : String -> DB Int

393strlen : String -> DB Int

400−strlen str = liftIO (mkForeign (FFun "strLength" [FString] FInt) str)

394+strlen str = liftIO (foreign FFI_C "strLength" (String -> IO Int) str)

401

395

402instance Show DBVal where

396instance Show DBVal where

403 show (DBInt i) = "Int val: " ++ show i ++ "\n"

397 show (DBInt i) = "Int val: " ++ show i ++ "\n"

idris.cabal+10−1

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

286 test/reg057/run

287 test/reg057/*.idr

288 test/reg057/expected

289+ test/reg058/run

290+ test/reg058/*.idr

291+ test/reg058/expected

289

292

290 test/basic001/run

293 test/basic001/run

291 test/basic001/*.idr

294 test/basic001/*.idr

@@ -494,6 +497,9 @@ Extra-source-files:

494 test/proof004/run

497 test/proof004/run

495 test/proof004/*.idr

498 test/proof004/*.idr

496 test/proof004/expected

499 test/proof004/expected

500+ test/proof008/run

501+ test/proof008/*.idr

502+ test/proof008/expected

497

503

498 test/quasiquote001/run

504 test/quasiquote001/run

499 test/quasiquote001/*.idr

505 test/quasiquote001/*.idr

@@ -507,6 +513,9 @@ Extra-source-files:

507 test/quasiquote004/run

513 test/quasiquote004/run

508 test/quasiquote004/*.idr

514 test/quasiquote004/*.idr

509 test/quasiquote004/expected

515 test/quasiquote004/expected

516+ test/quasiquote005/run

517+ test/quasiquote005/*.idr

518+ test/quasiquote005/expected

510

519

511

520

512 test/records001/run

521 test/records001/run

@@ -682,7 +691,7 @@ Library

682 , Idris.ErrReverse

691 , Idris.ErrReverse

683 , Idris.Help

692 , Idris.Help

684 , Idris.IBC

693 , Idris.IBC

685− , Idris.IdeSlave

694+ , Idris.IdeMode

686 , Idris.IdrisDoc

695 , Idris.IdrisDoc

687 , Idris.Imports

696 , Idris.Imports

688 , Idris.Inliner

697 , Idris.Inliner

jsrts/Runtime-common.js+11−13

@@ -68,20 +68,18 @@ var i$ffiWrap = function(fid,oldbase,myoldbase) {

68 var res = fid;

70 for(var i = 0; i < (arguments.length ? arguments.length : 1); ++i) {

71− while (res instanceof i$CON) {

72− i$valstack_top += 1;

71+ i$valstack_top += 1;

73− i$valstack[i$valstack_top] = res;

72+ i$valstack[i$valstack_top] = res;

74− i$valstack[i$valstack_top + 1] = arguments[i];

73+ i$valstack[i$valstack_top + 1] = arguments[i];

75− i$SLIDE(2);

74+ i$SLIDE(2);

76− i$valstack_top = i$valstack_base + 2;

75+ i$valstack_top = i$valstack_base + 2;

77− i$CALL(_idris__123_APPLY0_125_,[oldbase])

76+ i$CALL(_idris__123_APPLY0_125_,[oldbase])

78− while (i$callstack.length) {

77+ while (i$callstack.length) {

79− var func = i$callstack.pop();

78+ var func = i$callstack.pop();

80− var args = i$callstack.pop();

79+ var args = i$callstack.pop();

81− func.apply(this,args);

80+ func.apply(this,args);

82− }

83− res = i$ret;

84 }

81 }

82+ res = i$ret;

85 }

83 }

87 i$callstack = i$vm.callstack;

85 i$callstack = i$vm.callstack;

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

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

1module Data.Sign

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

4−data Sign = Plus | Minus

4+data Sign = Plus | Zero | Minus

6||| Discover the sign of some type

7class Signed t where

libs/base/Data/ZZ.idr+1

@@ -15,6 +15,7 @@ import Data.Sign

15data ZZ = Pos Nat | NegS Nat

17instance Signed ZZ where

18+ sign (Pos Z) = Zero

18 sign (Pos _) = Plus

19 sign (Pos _) = Plus

19 sign (NegS _) = Minus

20 sign (NegS _) = Minus

libs/base/Network/Socket.idr+1−1

@@ -31,7 +31,7 @@ data SocketFamily =

31instance Show SocketFamily where

32 show AF_UNSPEC = "AF_UNSPEC"

33 show AF_INET = "AF_INET"

34− show AF_INET6 = "AF_INET4"

34+ show AF_INET6 = "AF_INET6"

36instance ToCode SocketFamily where

37 toCode AF_UNSPEC = 0

libs/base/System/Concurrency/Process.idr+11

@@ -41,6 +41,10 @@ send (MkPID p) m = Lift (sendToThread p (prim__vm, m))

41msgWaiting : Process msg Bool

42msgWaiting = Lift checkMsgs

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

45+msgWaitingFrom : ProcID msg -> Process msg Bool

46+msgWaitingFrom (MkPID p) = Lift (checkMsgsFrom p)

47+

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

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

45recv : Process msg msg

49recv : Process msg msg

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

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

@@ -48,6 +52,13 @@ recv {msg} = do (senderid, m) <- Lift get

48 where get : IO (Ptr, msg)

52 where get : IO (Ptr, msg)

49 get = getMsg

53 get = getMsg

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

56+recvFrom : ProcID msg -> Process msg msg

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

58+ return m

59+ where get : IO (Ptr, msg)

60+ get = getMsgFrom p

61+

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

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

52recvWithSender : Process msg (ProcID msg, msg)

63recvWithSender : Process msg (ProcID msg, msg)

53recvWithSender {msg}

64recvWithSender {msg}

libs/base/System/Concurrency/Raw.idr+49−4

@@ -12,14 +12,59 @@ sendToThread {a} dest val

12 = foreign FFI_C "idris_sendMessage" (Ptr -> Ptr -> Raw a -> IO ())

13 prim__vm dest (MkRaw val)

15+||| Check for messages in the process inbox

15checkMsgs : IO Bool

16checkMsgs : IO Bool

16−checkMsgs = do msgs <- foreign FFI_C "idris_checkMessages" (Ptr -> IO Int)

17+checkMsgs = do msgs <- foreign FFI_C "idris_checkMessages" (Ptr -> IO Ptr)

17 prim__vm

18 prim__vm

18− return (intToBool msgs)

19+ null <- nullPtr msgs

20+ return (not null)

21+

22+||| Check for messages in the process inbox.

23+||| Returns either 'Nothing', if none, or 'Just pid' as pid of sender.

24+listenMsgs : IO (Maybe Ptr)

25+listenMsgs = do sender <- foreign FFI_C "idris_checkMessages" (Ptr -> IO Ptr)

26+ prim__vm

27+ null <- nullPtr sender

28+ return (if null

29+ then Nothing

30+ else Just sender)

31+

32+||| Check for messages from a specific sender in the process inbox

33+checkMsgsFrom : Ptr -> IO Bool

34+checkMsgsFrom sender

35+ = do msgs <- foreign FFI_C "idris_checkMessagesFrom" (Ptr -> Ptr -> IO Ptr)

36+ prim__vm sender

37+ null <- nullPtr msgs

38+ return (not null)

20||| Check inbox for messages. If there are none, blocks until a message

40||| Check inbox for messages. If there are none, blocks until a message

21||| arrives.

41||| arrives.

42+||| Note that this is not at all type safe! It is intended to be used in

43+||| a type safe wrapper.

22getMsg : IO a

44getMsg : IO a

23−getMsg {a} = do MkRaw x <- foreign FFI_C "idris_recvMessage"

45+getMsg {a} = do m <- foreign FFI_C "idris_recvMessage"

24− (Ptr -> IO (Raw a)) prim__vm

46+ (Ptr -> IO Ptr) prim__vm

47+ MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m

25 return x

48 return x

49+

50+||| Check inbox for messages. If there are none, blocks until a message

51+||| arrives. Return pair of sender's ID and the message.

52+||| Note that this is not at all type safe! It is intended to be used in

53+||| a type safe wrapper.

54+getMsgWithSender : IO (Ptr, a)

55+getMsgWithSender {a}

56+ = do m <- foreign FFI_C "idris_recvMessage"

57+ (Ptr -> IO Ptr) prim__vm

58+ MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m

59+ vm <- foreign FFI_C "idris_getSender" (Ptr -> IO Ptr) m

60+ foreign FFI_C "idris_freeMsg" (Ptr -> IO ()) m

61+ return (vm, x)

62+

63+getMsgFrom : Ptr -> IO a

64+getMsgFrom {a} sender

65+ = do m <- foreign FFI_C "idris_recvMessageFrom"

66+ (Ptr -> Ptr -> IO Ptr) prim__vm sender

67+ MkRaw x <- foreign FFI_C "idris_getMsg" (Ptr -> IO (Raw a)) m

68+ foreign FFI_C "idris_freeMsg" (Ptr -> IO ()) m

69+ return x

70+

libs/effects/Effects.idr+1

@@ -310,4 +310,5 @@ when : Bool -> Lazy ({xs} Eff ()) -> {xs} Eff ()

310when True e = Force e

311when False e = pure ()

312

313+

313-- --------------------------------------------------------------------- [ EOF ]

314-- --------------------------------------------------------------------- [ EOF ]

libs/prelude/Builtins.idr+10

@@ -19,6 +19,16 @@ namespace Builtins

19 ||| @b the right element of the pair

20 MkPair : {A, B : Type} -> (a : A) -> (b : B) -> Pair A B

22+ ||| The non-dependent pair type, also known as conjunction, usable with

23+ ||| UniqueTypes.

24+ ||| @A the type of the left elements in the pair

25+ ||| @B the type of the left elements in the pair

26+ data UPair : (A : Type*) -> (B : Type*) -> Type where

27+ ||| A pair of elements

28+ ||| @a the left element of the pair

29+ ||| @b the right element of the pair

30+ MkUPair : {A, B : Type*} -> (a : A) -> (b : B) -> UPair A B

31+

22 ||| Dependent pairs

32 ||| Dependent pairs

23 |||

33 |||

24 ||| Dependent pairs represent existential quantification - they consist of a

34 ||| Dependent pairs represent existential quantification - they consist of a

libs/prelude/Language/Reflection.idr+23−3

@@ -49,7 +49,7 @@ data Const = I Int | BI Integer | Fl Float | Ch Char | Str String

49 | B32V Bits32x4 | B64V Bits64x2

50 | AType ArithTy | StrType

52−

52+ | WorldType | TheWorld

53%name Const c, c'

55abstract class ReflConst (a : Type) where

@@ -146,6 +146,8 @@ instance Traversable Binder where

146 traverse f (PVar x) = [| PVar (f x) |]

147 traverse f (PVTy x) = [| PVTy (f x) |]

148

149+||| Universes

150+data Universe = NullType | UniqueType | AllTypes

149

151

150||| Reflection of the well typed core language

152||| Reflection of the well typed core language

151data TT =

153data TT =

@@ -166,7 +168,8 @@ data TT =

166 ||| Impossible terms

168 ||| Impossible terms

167 Impossible |

169 Impossible |

168 ||| The type of types along (with universe constraints)

170 ||| The type of types along (with universe constraints)

169− TType TTUExp

171+ TType TTUExp |

172+ UType Universe

170%name TT tm, tm'

173%name TT tm, tm'

171

174

172||| Raw terms without types

175||| Raw terms without types

@@ -179,6 +182,7 @@ data Raw =

179 RApp Raw Raw |

182 RApp Raw Raw |

180 ||| The type of types

183 ||| The type of types

181 RType |

184 RType |

185+ RUType Universe |

182 RForce Raw |

186 RForce Raw |

183 ||| Embed a constant

187 ||| Embed a constant

184 RConstant Const

188 RConstant Const

@@ -213,6 +217,10 @@ data Tactic =

213 Refine TTName |

217 Refine TTName |

214 ||| Apply both tactics in sequence

218 ||| Apply both tactics in sequence

215 Seq Tactic Tactic |

219 Seq Tactic Tactic |

220+ ||| Introduce a new hole with a particular type

221+ Claim TTName TT |

222+ ||| Move the current hole to the end

223+ Unfocus |

216 ||| Intelligently construct the proof target from the context

224 ||| Intelligently construct the proof target from the context

217 Trivial |

225 Trivial |

218 ||| Build a proof by applying contructors up to a maximum depth

226 ||| Build a proof by applying contructors up to a maximum depth

@@ -395,13 +403,20 @@ instance Quotable Const where

395 quote BufferType = `(BufferType)

403 quote BufferType = `(BufferType)

396 quote VoidType = `(VoidType)

404 quote VoidType = `(VoidType)

397 quote Forgot = `(Forgot)

405 quote Forgot = `(Forgot)

398−

406+ quote WorldType = `(WorldType)

407+ quote TheWorld = `(TheWorld)

399

408

400instance Quotable TTUExp where

409instance Quotable TTUExp where

401 quotedTy = `(TTUExp)

410 quotedTy = `(TTUExp)

402 quote (UVar x) = `(UVar ~(quote x))

411 quote (UVar x) = `(UVar ~(quote x))

403 quote (UVal x) = `(UVal ~(quote x))

412 quote (UVal x) = `(UVal ~(quote x))

404

413

414+instance Quotable Universe where

415+ quotedTy = `(Universe)

416+ quote Reflection.NullType = `(NullType)

417+ quote Reflection.UniqueType = `(UniqueType)

418+ quote Reflection.AllTypes = `(AllTypes)

419+

405mutual

420mutual

406 instance Quotable TT where

421 instance Quotable TT where

407 quotedTy = `(TT)

422 quotedTy = `(TT)

@@ -414,6 +429,7 @@ mutual

414 quote Erased = `(Erased)

429 quote Erased = `(Erased)

415 quote Impossible = `(Impossible)

430 quote Impossible = `(Impossible)

416 quote (TType uexp) = `(TType ~(quote uexp))

431 quote (TType uexp) = `(TType ~(quote uexp))

432+ quote (UType u) = `(UType ~(quote u))

417

433

418 instance Quotable (Binder TT) where

434 instance Quotable (Binder TT) where

419 quotedTy = `(Binder TT)

435 quotedTy = `(Binder TT)

@@ -445,6 +461,7 @@ mutual

445 quoteRaw (RBind n b tm) = `(RBind ~(quote n) ~(assert_total $ quoteRawBinder b) ~(quoteRaw tm))

461 quoteRaw (RBind n b tm) = `(RBind ~(quote n) ~(assert_total $ quoteRawBinder b) ~(quoteRaw tm))

446 quoteRaw (RApp tm tm') = `(RApp ~(quoteRaw tm) ~(quoteRaw tm'))

462 quoteRaw (RApp tm tm') = `(RApp ~(quoteRaw tm) ~(quoteRaw tm'))

447 quoteRaw RType = `(RType)

463 quoteRaw RType = `(RType)

464+ quoteRaw (RUType u) = `(RUType ~(quote u))

448 quoteRaw (RForce tm) = `(RForce ~(quoteRaw tm))

465 quoteRaw (RForce tm) = `(RForce ~(quoteRaw tm))

449 quoteRaw (RConstant c) = `(RConstant ~(quote c))

466 quoteRaw (RConstant c) = `(RConstant ~(quote c))

450

467

@@ -472,6 +489,8 @@ instance Quotable Tactic where

472 quote (Try tac tac') = `(Try ~(quote tac) ~(quote tac'))

489 quote (Try tac tac') = `(Try ~(quote tac) ~(quote tac'))

473 quote (GoalType x tac) = `(GoalType ~(quote x) ~(quote tac))

490 quote (GoalType x tac) = `(GoalType ~(quote x) ~(quote tac))

474 quote (Refine n) = `(Refine ~(quote n))

491 quote (Refine n) = `(Refine ~(quote n))

492+ quote (Claim n ty) = `(Claim ~(quote n) ~(quote ty))

493+ quote Unfocus = `(Unfocus)

475 quote (Seq tac tac') = `(Seq ~(quote tac) ~(quote tac'))

494 quote (Seq tac tac') = `(Seq ~(quote tac) ~(quote tac'))

476 quote Trivial = `(Trivial)

495 quote Trivial = `(Trivial)

477 quote (Search x) = `(Search ~(quote x))

496 quote (Search x) = `(Search ~(quote x))

@@ -494,3 +513,4 @@ instance Quotable Tactic where

494 quote Skip = `(Skip)

513 quote Skip = `(Skip)

495 quote (Fail xs) = `(Fail ~(quote xs))

514 quote (Fail xs) = `(Fail ~(quote xs))

496 quote SourceFC = `(SourceFC)

515 quote SourceFC = `(SourceFC)

516+

libs/prelude/Language/Reflection/Tactical.idrnew file+95

@@ -0,0 +1,95 @@

1+module Language.Reflection.Tactical

3+import Builtins

4+import Prelude.Applicative

5+import Prelude.Functor

6+import Prelude.List

7+import Prelude.Maybe

8+import Prelude.Monad

9+import Language.Reflection

10+

11+abstract

12+data Tactical : Type -> Type where

13+ -- obligatory control stuff

14+ prim__PureTactical : a -> Tactical a

15+ prim__BindTactical : {a, b : Type} -> Tactical a -> (a -> Tactical b) -> Tactical b

16+

17+ prim__Try : {a : Type} -> Tactical a -> Tactical a -> Tactical a

18+ prim__Fail : {a : Type} -> List ErrorReportPart -> Tactical a

19+

20+ prim__Env : Tactical (List (TTName, Binder TT))

21+ prim__Goal : Tactical (TTName, TT)

22+ prim__Holes : Tactical (List TTName)

23+ prim__Guess : Tactical (Maybe TT)

24+

25+ prim__Forget : TT -> Tactical Raw

26+

27+ prim__Gensym : String -> Tactical TTName

28+

29+ prim__Solve : Tactical ()

30+ prim__Fill : Raw -> Tactical ()

31+ prim__Focus : TTName -> Tactical ()

32+ prim__Unfocus : TTName -> Tactical ()

33+ prim__Attack : Tactical ()

34+

35+ prim__Claim : TTName -> Raw -> Tactical ()

36+

37+-------------

38+-- Public API

39+-------------

40+%access public

41+

42+instance Functor Tactical where

43+ map f t = prim__BindTactical t (\x => prim__PureTactical (f x))

44+

45+instance Applicative Tactical where

46+ pure x = prim__PureTactical x

47+ f <$> x = prim__BindTactical f $ \g =>

48+ prim__BindTactical x $ \y =>

49+ prim__PureTactical $ g y

50+

51+instance Alternative Tactical where

52+ empty = prim__Fail [TextPart "empty"]

53+ x <|> y = prim__Try x y

54+

55+instance Monad Tactical where

56+ x >>= f = prim__BindTactical x f

57+

58+fail : List ErrorReportPart -> Tactical a

59+fail err = prim__Fail err

60+

61+getEnv : Tactical (List (TTName, Binder TT))

62+getEnv = prim__Env

63+

64+getGoal : Tactical (TTName, TT)

65+getGoal = prim__Goal

66+

67+getHoles : Tactical (List TTName)

68+getHoles = prim__Holes

69+

70+getGuess : Tactical (Maybe TT)

71+getGuess = prim__Guess

72+

73+forgetTypes : TT -> Tactical Raw

74+forgetTypes tt = prim__Forget tt

75+

76+gensym : (hint : String) -> Tactical TTName

77+gensym hint = prim__Gensym hint

78+

79+solve : Tactical ()

80+solve = prim__Solve

81+

82+fill : Raw -> Tactical ()

83+fill tm = prim__Fill tm

84+

85+focus : (hole : TTName) -> Tactical ()

86+focus hole = prim__Focus hole

87+

88+unfocus : TTName -> Tactical ()

89+unfocus hole = prim__Unfocus hole

90+

91+attack : Tactical ()

92+attack = prim__Attack

93+

94+claim : TTName -> Raw -> Tactical ()

95+claim n ty = prim__Claim n ty

libs/prelude/Prelude/Foldable.idr+1−1

@@ -11,7 +11,7 @@ import Prelude.Algebra

12class Foldable (t : Type -> Type) where

13 foldr : (elt -> acc -> acc) -> acc -> t elt -> acc

14− foldl : Foldable t => (acc -> elt -> acc) -> acc -> t elt -> acc

14+ foldl : (acc -> elt -> acc) -> acc -> t elt -> acc

15 foldl f z t = foldr (flip (.) . flip f) id t z

17||| Combine each element of a structure into a monoid

libs/prelude/Prelude/Strings.idr+88−59

@@ -17,8 +17,9 @@ import Decidable.Equality

18||| Appends two strings together.

19|||

20+||| ```idris example

20−||| Idris> "AB" ++ "C"

21+||| "AB" ++ "C"

21−||| "ABC" : String

22+||| ```

22(++) : String -> String -> String

23(++) : String -> String -> String

23(++) = prim__concat

24(++) = prim__concat

@@ -26,8 +27,9 @@ import Decidable.Equality

26|||

27|||

27||| Doesn't work for empty strings.

28||| Doesn't work for empty strings.

28|||

29|||

30+||| ```idris example

29−||| Idris> strHead "A"

31+||| strHead "A"

30−||| 'A' : Char

32+||| ```

31partial

33partial

32strHead : String -> Char

34strHead : String -> Char

33strHead = prim__strHead

35strHead = prim__strHead

@@ -36,20 +38,24 @@ strHead = prim__strHead

36|||

38|||

37||| Doesn't work for empty strings.

39||| Doesn't work for empty strings.

38|||

40|||

41+||| ```idris example

39−||| Idris> strTail "AB"

42+||| strTail "AB"

40−||| "B" : String

43+||| ```

44+||| ```idris example

41−||| Idris> strTail "A"

45+||| strTail "A"

42−||| "" : String

46+||| ```

43partial

47partial

44strTail : String -> String

48strTail : String -> String

45strTail = prim__strTail

49strTail = prim__strTail

47||| Adds a character to the front of the specified string.

51||| Adds a character to the front of the specified string.

48|||

52|||

53+||| ```idris example

49−||| Idris> strCons 'A' "B"

54+||| strCons 'A' "B"

50−||| "AB" : String

55+||| ```

56+||| ```idris example

51−||| Idris> strCons 'A' ""

57+||| strCons 'A' ""

52−||| "A" : String

58+||| ```

53strCons : Char -> String -> String

59strCons : Char -> String -> String

54strCons = prim__strCons

60strCons = prim__strCons

@@ -57,18 +63,21 @@ strCons = prim__strCons

57|||

63|||

58||| Precondition: '0 < i < length s' for 'strIndex s i'.

64||| Precondition: '0 < i < length s' for 'strIndex s i'.

59|||

65|||

66+||| ```idris example

60−||| Idris> strIndex "AB" 1

67+||| strIndex "AB" 1

61−||| 'B' : Char

68+||| ```

62partial

69partial

63strIndex : String -> Int -> Char

70strIndex : String -> Int -> Char

64strIndex = prim__strIndex

71strIndex = prim__strIndex

66||| Reverses the elements within a String.

73||| Reverses the elements within a String.

67|||

74|||

75+||| ```idris example

68−||| Idris> reverse "ABC"

76+||| reverse "ABC"

69−||| "CBA" : String

77+||| ```

78+||| ```idris example

70−||| Idris> reverse ""

79+||| reverse ""

71−||| "" : String

80+||| ```

72reverse : String -> String

81reverse : String -> String

73reverse = prim__strRev

82reverse = prim__strRev

@@ -103,8 +112,9 @@ strM x with (decEq (not (x == "")) True)

103

112

104||| Turns a string into a list of characters.

113||| Turns a string into a list of characters.

105|||

114|||

115+||| ```idris example

106−||| Idris> unpack "ABC"

116+||| unpack "ABC"

107−||| ['A', 'B', 'C'] : List Char

117+||| ```

108unpack : String -> List Char

118unpack : String -> List Char

109unpack s with (strM s)

119unpack s with (strM s)

110 unpack "" | StrNil = []

120 unpack "" | StrNil = []

@@ -116,8 +126,9 @@ pack = foldr strCons ""

116

126

117||| Creates a string of a single character.

127||| Creates a string of a single character.

118|||

128|||

129+||| ```idris example

119−||| Idris> singleton 'A'

130+||| singleton 'A'

120−||| "A" : String

131+||| ```

121singleton : Char -> String

132singleton : Char -> String

122singleton c = strCons c ""

133singleton c = strCons c ""

123

134

@@ -139,10 +150,12 @@ instance Monoid String where

139||| Splits the string into a part before the predicate

150||| Splits the string into a part before the predicate

140||| returns False and the rest of the string.

151||| returns False and the rest of the string.

141|||

152|||

153+||| ```idris example

142−||| Idris> span (/= 'C') "ABCD"

154+||| span (/= 'C') "ABCD"

143−||| ("AB", "CD") : (String, String)

155+||| ```

156+||| ```idris example

144−||| Idris> span (/= 'C') "EFGH"

157+||| span (/= 'C') "EFGH"

145−||| ("EFGH", "") : (String, String)

158+||| ```

146span : (Char -> Bool) -> String -> (String, String)

159span : (Char -> Bool) -> String -> (String, String)

147span p xs with (strM xs)

160span p xs with (strM xs)

148 span p "" | StrNil = ("", "")

161 span p "" | StrNil = ("", "")

@@ -154,28 +167,33 @@ span p xs with (strM xs)

154||| Splits the string into a part before the predicate

167||| Splits the string into a part before the predicate

155||| returns True and the rest of the string.

168||| returns True and the rest of the string.

156|||

169|||

170+||| ```idris example

157−||| Idris> break (== 'C') "ABCD"

171+||| break (== 'C') "ABCD"

158−||| ("AB", "CD") : (String, String)

172+||| ```

173+||| ```idris example

159−||| Idris> break (== 'C') "EFGH"

174+||| break (== 'C') "EFGH"

160−||| ("EFGH", "") : (String, String)

175+||| ```

161break : (Char -> Bool) -> String -> (String, String)

176break : (Char -> Bool) -> String -> (String, String)

162break p = span (not . p)

177break p = span (not . p)

163

178

164||| Splits the string into parts with the predicate

179||| Splits the string into parts with the predicate

165||| indicating separator characters.

180||| indicating separator characters.

166|||

181|||

182+||| ```idris example

167−||| Idris> split (== '.') ".AB.C..D"

183+||| split (== '.') ".AB.C..D"

168−||| ["", "AB", "C", "", "D"] : List String

184+||| ```

169split : (Char -> Bool) -> String -> List String

185split : (Char -> Bool) -> String -> List String

170split p xs = map pack (split p (unpack xs))

186split p xs = map pack (split p (unpack xs))

171

187

172||| Removes whitespace (determined with 'isSpace') from

188||| Removes whitespace (determined with 'isSpace') from

173||| the start of the string.

189||| the start of the string.

174|||

190|||

191+||| ```idris example

175−||| Idris> ltrim " A\nB"

192+||| ltrim " A\nB"

176−||| "A\nB" : String

193+||| ```

194+||| ```idris example

177−||| Idris> ltrim " \nAB"

195+||| ltrim " \nAB"

178−||| "AB" : String

196+||| ```

179ltrim : String -> String

197ltrim : String -> String

180ltrim xs with (strM xs)

198ltrim xs with (strM xs)

181 ltrim "" | StrNil = ""

199 ltrim "" | StrNil = ""

@@ -185,15 +203,17 @@ ltrim xs with (strM xs)

185||| Removes whitespace (determined with 'isSpace') from

203||| Removes whitespace (determined with 'isSpace') from

186||| the start and end of the string.

204||| the start and end of the string.

187|||

205|||

206+||| ```idris example

188−||| Idris> trim " A\nB C "

207+||| trim " A\nB C "

189−||| "A\nB C" : String

208+||| ```

190trim : String -> String

209trim : String -> String

191trim xs = ltrim (reverse (ltrim (reverse xs)))

210trim xs = ltrim (reverse (ltrim (reverse xs)))

192

211

193||| Splits a character list into a list of whitespace separated character lists.

212||| Splits a character list into a list of whitespace separated character lists.

194|||

213|||

214+||| ```idris example

195−||| Idris> words' (unpack " A B C D E ")

215+||| words' (unpack " A B C D E ")

196−||| [['A'], ['B'], ['C'], ['D'], ['E']] : List (List Char)

216+||| ```

197words' : List Char -> List (List Char)

217words' : List Char -> List (List Char)

198words' s = case dropWhile isSpace s of

218words' s = case dropWhile isSpace s of

199 [] => []

219 [] => []

@@ -202,15 +222,17 @@ words' s = case dropWhile isSpace s of

202

222

203||| Splits a string into a list of whitespace separated strings.

223||| Splits a string into a list of whitespace separated strings.

204|||

224|||

225+||| ```idris example

205−||| Idris> words " A B C D E "

226+||| words " A B C D E "

206−||| ["A", "B", "C", "D", "E"] : List String

227+||| ```

207words : String -> List String

228words : String -> List String

208words s = map pack $ words' $ unpack s

229words s = map pack $ words' $ unpack s

209

230

210||| Splits a character list into a list of newline separated character lists.

231||| Splits a character list into a list of newline separated character lists.

211|||

232|||

233+||| ```idris example

212−||| Idris> lines' (unpack "\rA BC\nD\r\nE\n")

234+||| lines' (unpack "\rA BC\nD\r\nE\n")

213−||| [['A', ' ', 'B', 'C'], ['D'], ['E']] : List (List Char)

235+||| ```

214lines' : List Char -> List (List Char)

236lines' : List Char -> List (List Char)

215lines' s = case dropWhile isNL s of

237lines' s = case dropWhile isNL s of

216 [] => []

238 [] => []

@@ -219,8 +241,9 @@ lines' s = case dropWhile isNL s of

219

241

220||| Splits a string into a list of newline separated strings.

242||| Splits a string into a list of newline separated strings.

221|||

243|||

244+||| ```idris example

222−||| Idris> lines "\rA BC\nD\r\nE\n"

245+||| lines "\rA BC\nD\r\nE\n"

223−||| ["A BC", "D", "E"] : List String

246+||| ```

224lines : String -> List String

247lines : String -> List String

225lines s = map pack $ lines' $ unpack s

248lines s = map pack $ lines' $ unpack s

226

249

@@ -235,8 +258,9 @@ foldl1 f (x::xs) = foldl f x xs

235

258

236||| Joins the character lists by spaces into a single character list.

259||| Joins the character lists by spaces into a single character list.

237|||

260|||

261+||| ```idris example

238−||| Idris> unwords' [['A'], ['B', 'C'], ['D'], ['E']]

262+||| unwords' [['A'], ['B', 'C'], ['D'], ['E']]

239−||| ['A', ' ', 'B', 'C', ' ', 'D', ' ', 'E'] : List Char

263+||| ```

240unwords' : List (List Char) -> List Char

264unwords' : List (List Char) -> List Char

241unwords' [] = []

265unwords' [] = []

242unwords' ws = assert_total (foldr1 addSpace ws)

266unwords' ws = assert_total (foldr1 addSpace ws)

@@ -246,24 +270,28 @@ unwords' ws = assert_total (foldr1 addSpace ws)

246

270

247||| Joins the strings by spaces into a single string.

271||| Joins the strings by spaces into a single string.

248|||

272|||

273+||| ```idris example

249−||| Idris> unwords ["A", "BC", "D", "E"]

274+||| unwords ["A", "BC", "D", "E"]

250−||| "A BC D E" : String

275+||| ```

251unwords : List String -> String

276unwords : List String -> String

252unwords = pack . unwords' . map unpack

277unwords = pack . unwords' . map unpack

253

278

254||| Returns the length of the string.

279||| Returns the length of the string.

255|||

280|||

281+||| ```idris example

256−||| Idris> length ""

282+||| length ""

257−||| 0 : Nat

283+||| ```

284+||| ```idris example

258−||| Idris> length "ABC"

285+||| length "ABC"

259−||| 3 : Nat

286+||| ```

260length : String -> Nat

287length : String -> Nat

261length = fromInteger . prim__zextInt_BigInt . prim_lenString

288length = fromInteger . prim__zextInt_BigInt . prim_lenString

262

289

263||| Lowercases all characters in the string.

290||| Lowercases all characters in the string.

264|||

291|||

292+||| ```idris example

265−||| Idris> toLower "aBc12!"

293+||| toLower "aBc12!"

266−||| "abc12!" : String

294+||| ```

267toLower : String -> String

295toLower : String -> String

268toLower x with (strM x)

296toLower x with (strM x)

269 strToLower "" | StrNil = ""

297 strToLower "" | StrNil = ""

@@ -272,14 +300,15 @@ toLower x with (strM x)

272

300

273||| Uppercases all characters in the string.

301||| Uppercases all characters in the string.

274|||

302|||

303+||| ```idris example

275−||| Idris> toLower "aBc12!"

304+||| toLower "aBc12!"

276−||| "ABC12!" : String

305+||| ```

277toUpper : String -> String

306toUpper : String -> String

278toUpper x with (strM x)

307toUpper x with (strM x)

279 strToLower "" | StrNil = ""

308 strToLower "" | StrNil = ""

280 strToLower (strCons c cs) | (StrCons c cs) =

309 strToLower (strCons c cs) | (StrCons c cs) =

281 strCons (toUpper c) (toUpper (assert_smaller (strCons c cs) cs ))

310 strCons (toUpper c) (toUpper (assert_smaller (strCons c cs) cs ))

282−

311+

283--------------------------------------------------------------------------------

312--------------------------------------------------------------------------------

284-- Predicates

313-- Predicates

285--------------------------------------------------------------------------------

314--------------------------------------------------------------------------------

libs/prelude/prelude.ipkg+1−1

@@ -10,7 +10,7 @@ modules = Builtins, Prelude, IO,

10 Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,

11 Prelude.Uninhabited, Prelude.Pairs,

13− Language.Reflection, Language.Reflection.Errors,

13+ Language.Reflection, Language.Reflection.Errors, Language.Reflection.Tactical,

15 Decidable.Equality

rts/Makefile+1−1

@@ -18,7 +18,7 @@ endif

18endif

20ifeq ($(OS), windows)

21− OBJS += windows/idris_stdfgn.o windows/idris_net.o

21+ OBJS += windows/idris_stdfgn.o windows/idris_net.o windows/win_utils.o

22else

23 OBJS += idris_stdfgn.o idris_net.o

24endif

rts/idris_gc.c+4−2

@@ -137,8 +137,10 @@ void idris_gc(VM* vm) {

137 }

138

139#ifdef HAS_PTHREAD

140+ Msg* msg;

141+

140− for(root = vm->inbox_ptr; root < vm->inbox_write; ++root) {

142+ for(msg = vm->inbox; msg < vm->inbox_write; ++msg) {

141− *root = copy(vm, *root);

143+ msg->msg = copy(vm, msg->msg);

142 }

144 }

143#endif

145#endif

144 vm->ret = copy(vm, vm->ret);

146 vm->ret = copy(vm, vm->ret);

rts/idris_gmp.c+12−2

@@ -27,6 +27,7 @@ VAL MKBIGC(VM* vm, char* val) {

27 mpz_t* bigint;

29 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

30+ idris_doneAlloc();

30 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

31 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

32 mpz_init(*bigint);

33 mpz_init(*bigint);

@@ -43,6 +44,7 @@ VAL MKBIGM(VM* vm, void* big) {

44 mpz_t* bigint;

45 mpz_t* bigint;

45 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

46 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

47+ idris_doneAlloc();

46 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

48 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

48 mpz_init(*bigint);

50 mpz_init(*bigint);

@@ -59,6 +61,7 @@ VAL MKBIGMc(VM* vm, void* big) {

60 mpz_t* bigint;

62 mpz_t* bigint;

61 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

63 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

64+ idris_doneAlloc();

62 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

65 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

64 mpz_init_set(*bigint, *((mpz_t*)big));

67 mpz_init_set(*bigint, *((mpz_t*)big));

@@ -74,6 +77,7 @@ VAL MKBIGUI(VM* vm, unsigned long val) {

75 mpz_t* bigint;

78 mpz_t* bigint;

76 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

79 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

80+ idris_doneAlloc();

77 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

81 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

79 mpz_init_set_ui(*bigint, val);

83 mpz_init_set_ui(*bigint, val);

@@ -89,6 +93,7 @@ VAL MKBIGSI(VM* vm, signed long val) {

90 mpz_t* bigint;

94 mpz_t* bigint;

91 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

95 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

96+ idris_doneAlloc();

92 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

97 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

94 mpz_init_set_si(*bigint, val);

99 mpz_init_set_si(*bigint, val);

@@ -105,6 +110,7 @@ VAL GETBIG(VM * vm, VAL x) {

105 if (ISINT(x)) {

110 if (ISINT(x)) {

106 mpz_t* bigint;

111 mpz_t* bigint;

107 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

112 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

113+ idris_doneAlloc();

108 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

114 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

109

115

110 mpz_init(*bigint);

116 mpz_init(*bigint);

@@ -115,6 +121,7 @@ VAL GETBIG(VM * vm, VAL x) {

115

121

116 return cl;

122 return cl;

117 } else {

123 } else {

124+ idris_doneAlloc();

118 switch(GETTY(x)) {

125 switch(GETTY(x)) {

119 case FWD:

126 case FWD:

120 return GETBIG(vm, x->info.ptr);

127 return GETBIG(vm, x->info.ptr);

@@ -129,6 +136,7 @@ VAL bigAdd(VM* vm, VAL x, VAL y) {

129

136

130 mpz_t* bigint;

137 mpz_t* bigint;

131 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

138 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

139+ idris_doneAlloc();

132 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

140 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

133 mpz_add(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

141 mpz_add(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

134 SETTY(cl, BIGINT);

142 SETTY(cl, BIGINT);

@@ -141,6 +149,7 @@ VAL bigSub(VM* vm, VAL x, VAL y) {

141

149

142 mpz_t* bigint;

150 mpz_t* bigint;

143 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

151 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

152+ idris_doneAlloc();

144 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

153 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

145 mpz_sub(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

154 mpz_sub(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

146 SETTY(cl, BIGINT);

155 SETTY(cl, BIGINT);

@@ -153,6 +162,7 @@ VAL bigMul(VM* vm, VAL x, VAL y) {

153

162

154 mpz_t* bigint;

163 mpz_t* bigint;

155 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

164 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

165+ idris_doneAlloc();

156 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

166 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

157 mpz_mul(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

167 mpz_mul(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

158 SETTY(cl, BIGINT);

168 SETTY(cl, BIGINT);

@@ -165,6 +175,7 @@ VAL bigDiv(VM* vm, VAL x, VAL y) {

165

175

166 mpz_t* bigint;

176 mpz_t* bigint;

167 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

177 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

178+ idris_doneAlloc();

168 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

179 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

169 mpz_tdiv_q(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

180 mpz_tdiv_q(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

170 SETTY(cl, BIGINT);

181 SETTY(cl, BIGINT);

@@ -177,6 +188,7 @@ VAL bigMod(VM* vm, VAL x, VAL y) {

177

188

178 mpz_t* bigint;

189 mpz_t* bigint;

179 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

190 VAL cl = allocate(sizeof(Closure) + sizeof(mpz_t), 0);

191+ idris_doneAlloc();

180 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

192 bigint = (mpz_t*)(((char*)cl) + sizeof(Closure));

181 mpz_mod(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

193 mpz_mod(*bigint, GETMPZ(GETBIG(vm,x)), GETMPZ(GETBIG(vm,y)));

182 SETTY(cl, BIGINT);

194 SETTY(cl, BIGINT);

@@ -258,8 +270,6 @@ VAL idris_bigMod(VM* vm, VAL x, VAL y) {

258}

270}

259

271

260int bigEqConst(VAL x, int c) {

272int bigEqConst(VAL x, int c) {

261− idris_requireAlloc(IDRIS_MAXGMP);

262−

263 if (ISINT(x)) { return (GETINT(x) == c); }

273 if (ISINT(x)) { return (GETINT(x) == c); }

264 else {

274 else {

265 int rv = mpz_cmp_si(GETMPZ(x), c);

275 int rv = mpz_cmp_si(GETMPZ(x), c);

rts/idris_rts.c+88−30

@@ -1,11 +1,4 @@

1−#include <stdlib.h>

2−#include <stdio.h>

3−#include <string.h>

4−#include <stdarg.h>

5#include <assert.h>

1#include <assert.h>

6−#ifdef HAS_PTHREAD

7−#include <pthread.h>

8−#endif

10#include "idris_rts.h"

3#include "idris_rts.h"

11#include "idris_gc.h"

4#include "idris_gc.h"

@@ -44,7 +37,6 @@ VM* init_vm(int stack_size, size_t heap_size,

44 vm->inbox = malloc(1024*sizeof(VAL));

37 vm->inbox = malloc(1024*sizeof(VAL));

45 memset(vm->inbox, 0, 1024*sizeof(VAL));

38 memset(vm->inbox, 0, 1024*sizeof(VAL));

46 vm->inbox_end = vm->inbox + 1024;

39 vm->inbox_end = vm->inbox + 1024;

47− vm->inbox_ptr = vm->inbox;

48 vm->inbox_write = vm->inbox;

40 vm->inbox_write = vm->inbox;

50 // The allocation lock must be reentrant. The lock exists to ensure that

42 // The allocation lock must be reentrant. The lock exists to ensure that

@@ -72,7 +64,9 @@ VM* init_vm(int stack_size, size_t heap_size,

72}

64}

74void init_threadkeys() {

66void init_threadkeys() {

67+#ifdef HAS_PTHREAD

75 pthread_key_create(&vm_key, (void*)free_key);

68 pthread_key_create(&vm_key, (void*)free_key);

69+#endif

76}

70}

78void init_threaddata(VM *vm) {

72void init_threaddata(VM *vm) {

@@ -1005,7 +999,7 @@ void* vmThread(VM* callvm, func f, VAL arg) {

1005

999

1006// VM is assumed to be a different vm from the one x lives on

1000// VM is assumed to be a different vm from the one x lives on

1007

1001

1008−VAL copyTo(VM* vm, VAL x) {

1002+VAL doCopyTo(VM* vm, VAL x) {

1009 int i, ar;

1003 int i, ar;

1010 VAL* argptr;

1004 VAL* argptr;

1011 Closure* cl;

1005 Closure* cl;

@@ -1022,7 +1016,7 @@ VAL copyTo(VM* vm, VAL x) {

1022

1016

1023 argptr = (VAL*)(cl->info.c.args);

1017 argptr = (VAL*)(cl->info.c.args);

1024 for(i = 0; i < ar; ++i) {

1018 for(i = 0; i < ar; ++i) {

1025− *argptr = copyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version

1019+ *argptr = doCopyTo(vm, *((VAL*)(x->info.c.args)+i)); // recursive version

1026 argptr++;

1020 argptr++;

1027 }

1021 }

1028 }

1022 }

@@ -1063,6 +1057,14 @@ VAL copyTo(VM* vm, VAL x) {

1063 return cl;

1057 return cl;

1064}

1058}

1065

1059

1060+VAL copyTo(VM* vm, VAL x) {

1061+ VM* current = pthread_getspecific(vm_key);

1062+ pthread_setspecific(vm_key, vm);

1063+ VAL ret = doCopyTo(vm, x);

1064+ pthread_setspecific(vm_key, current);

1065+ return ret;

1066+}

1067+

1066// Add a message to another VM's message queue

1068// Add a message to another VM's message queue

1067void idris_sendMessage(VM* sender, VM* dest, VAL msg) {

1069void idris_sendMessage(VM* sender, VM* dest, VAL msg) {

1068 // FIXME: If GC kicks in in the middle of the copy, we're in trouble.

1070 // FIXME: If GC kicks in in the middle of the copy, we're in trouble.

@@ -1088,18 +1090,19 @@ void idris_sendMessage(VM* sender, VM* dest, VAL msg) {

1088 }

1090 }

1089

1091

1090 pthread_mutex_lock(&(dest->inbox_lock));

1092 pthread_mutex_lock(&(dest->inbox_lock));

1091− *(dest->inbox_write) = dmsg;

1093+

1092−

1093− dest->inbox_write++;

1094 if (dest->inbox_write >= dest->inbox_end) {

1095− dest->inbox_write = dest->inbox;

1095+ // FIXME: This is obviously bad in the long run. This should

1096− }

1096+ // either block, make the inbox bigger, or return an error code,

1097−

1097+ // or possibly make it user configurable

1098− if (dest->inbox_write == dest->inbox_ptr) {

1099− fprintf(stderr, "Inbox full"); // Maybe grow it instead...

1098+ fprintf(stderr, "Inbox full");

1100 exit(-1);

1099 exit(-1);

1101 }

1100 }

1102

1101

1102+ dest->inbox_write->msg = dmsg;

1103+ dest->inbox_write->sender = sender;

1104+ dest->inbox_write++;

1105+

1103 // Wake up the other thread

1106 // Wake up the other thread

1104 pthread_mutex_lock(&dest->inbox_block);

1107 pthread_mutex_lock(&dest->inbox_block);

1105 pthread_cond_signal(&dest->inbox_waiting);

1108 pthread_cond_signal(&dest->inbox_waiting);

@@ -1111,19 +1114,47 @@ void idris_sendMessage(VM* sender, VM* dest, VAL msg) {

1111// printf("Sending [unlock]...\n");

1114// printf("Sending [unlock]...\n");

1112}

1115}

1113

1116

1114−int idris_checkMessages(VM* vm) {

1117+VM* idris_checkMessages(VM* vm) {

1115− VAL msg = *(vm->inbox_ptr);

1118+ return idris_checkMessagesFrom(vm, NULL);

1116− return (msg != NULL);

1119+}

1120+

1121+VM* idris_checkMessagesFrom(VM* vm, VM* sender) {

1122+ Msg* msg;

1123+

1124+ for (msg = vm->inbox; msg < vm->inbox_end && msg->msg != NULL; ++msg) {

1125+ if (sender == NULL || msg->sender == sender) {

1126+ return msg->sender;

1127+ }

1128+ }

1129+ return 0;

1130+}

1131+

1132+Msg* idris_getMessageFrom(VM* vm, VM* sender) {

1133+ Msg* msg;

1134+

1135+ for (msg = vm->inbox; msg < vm->inbox_write; ++msg) {

1136+ if (sender == NULL || msg->sender == sender) {

1137+ return msg;

1138+ }

1139+ }

1140+ return NULL;

1117}

1141}

1118

1142

1119// block until there is a message in the queue

1143// block until there is a message in the queue

1120−VAL idris_recvMessage(VM* vm) {

1144+Msg* idris_recvMessage(VM* vm) {

1145+ return idris_recvMessageFrom(vm, NULL);

1146+}

1147+

1148+Msg* idris_recvMessageFrom(VM* vm, VM* sender) {

1121− VAL msg;

1149+ Msg* msg;

1150+ Msg* ret = malloc(sizeof(Msg));

1151+

1122 struct timespec timeout;

1152 struct timespec timeout;

1123 int status;

1153 int status;

1124

1154

1125 pthread_mutex_lock(&vm->inbox_block);

1155 pthread_mutex_lock(&vm->inbox_block);

1126− msg = *(vm->inbox_ptr);

1156+ msg = idris_getMessageFrom(vm, sender);

1157+

1127 while (msg == NULL) {

1158 while (msg == NULL) {

1128// printf("No message yet\n");

1159// printf("No message yet\n");

1129// printf("Waiting [lock]...\n");

1160// printf("Waiting [lock]...\n");

@@ -1133,27 +1164,54 @@ VAL idris_recvMessage(VM* vm) {

1133 &timeout);

1164 &timeout);

1134 (void)(status); //don't emit 'unused' warning

1165 (void)(status); //don't emit 'unused' warning

1135// printf("Waiting [unlock]... %d\n", status);

1166// printf("Waiting [unlock]... %d\n", status);

1136− msg = *(vm->inbox_ptr);

1167+ msg = idris_getMessageFrom(vm, sender);

1137 }

1168 }

1138 pthread_mutex_unlock(&vm->inbox_block);

1169 pthread_mutex_unlock(&vm->inbox_block);

1139

1170

1140 if (msg != NULL) {

1171 if (msg != NULL) {

1172+ ret->msg = msg->msg;

1173+ ret->sender = msg->sender;

1174+

1141 pthread_mutex_lock(&(vm->inbox_lock));

1175 pthread_mutex_lock(&(vm->inbox_lock));

1142− *(vm->inbox_ptr) = NULL;

1176+

1143− vm->inbox_ptr++;

1177+ // Slide everything down after the message in the inbox,

1178+ // Move the inbox_write pointer down, and clear the value at the

1179+ // end - O(n) but it's easier since the message from a specific

1180+ // sender could be anywhere in the inbox

1181+

1182+ for(;msg < vm->inbox_write; ++msg) {

1144− if (vm->inbox_ptr >= vm->inbox_end) {

1183+ if (msg+1 != vm->inbox_end) {

1145− vm->inbox_ptr = vm->inbox;

1184+ msg->sender = (msg + 1)->sender;

1185+ msg->msg = (msg + 1)->msg;

1186+ }

1146 }

1187 }

1188+

1189+ vm->inbox_write->msg = NULL;

1190+ vm->inbox_write->sender = NULL;

1191+ vm->inbox_write--;

1192+

1147 pthread_mutex_unlock(&(vm->inbox_lock));

1193 pthread_mutex_unlock(&(vm->inbox_lock));

1148 } else {

1194 } else {

1149 fprintf(stderr, "No messages waiting");

1195 fprintf(stderr, "No messages waiting");

1150 exit(-1);

1196 exit(-1);

1151 }

1197 }

1152

1198

1153− return msg;

1199+ return ret;

1154}

1200}

1155#endif

1201#endif

1156

1202

1203+VAL idris_getMsg(Msg* msg) {

1204+ return msg->msg;

1205+}

1206+

1207+VM* idris_getSender(Msg* msg) {

1208+ return msg->sender;

1209+}

1210+

1211+void idris_freeMsg(Msg* msg) {

1212+ free(msg);

1213+}

1214+

1157VAL* nullary_cons;

1215VAL* nullary_cons;

1158

1216

1159void init_nullaries() {

1217void init_nullaries() {

rts/idris_rts.h+29−9

@@ -80,7 +80,16 @@ typedef struct Closure {

80 } info;

81} Closure;

83+struct VM_t;

84+

85+struct Msg_t {

86+ struct VM_t* sender;

87+ VAL msg;

88+};

89+

83−typedef struct {

90+typedef struct Msg_t Msg;

91+

92+struct VM_t {

84 VAL* valstack;

93 VAL* valstack;

85 VAL* valstack_top;

94 VAL* valstack_top;

86 VAL* valstack_base;

95 VAL* valstack_base;

@@ -93,11 +102,9 @@ typedef struct {

93 pthread_mutex_t alloc_lock;

102 pthread_mutex_t alloc_lock;

94 pthread_cond_t inbox_waiting;

103 pthread_cond_t inbox_waiting;

104

96− VAL* inbox; // Block of memory for storing messages

105+ Msg* inbox; // Block of memory for storing messages

97− VAL* inbox_end; // End of block of memory

106+ Msg* inbox_end; // End of block of memory

98−

99− VAL* inbox_ptr; // Next message to read

100− VAL* inbox_write; // Location of next message to write

107+ Msg* inbox_write; // Location of next message to write

101

108

102 int processes; // Number of child processes

109 int processes; // Number of child processes

103 int max_threads; // maximum number of threads to run in parallel

110 int max_threads; // maximum number of threads to run in parallel

@@ -106,7 +113,9 @@ typedef struct {

106

113

107 VAL ret;

114 VAL ret;

108 VAL reg1;

115 VAL reg1;

109−} VM;

116+};

117+

118+typedef struct VM_t VM;

110

119

111// Create a new VM

120// Create a new VM

112VM* init_vm(int stack_size, size_t heap_size,

121VM* init_vm(int stack_size, size_t heap_size,

@@ -277,10 +286,21 @@ VAL copyTo(VM* newVM, VAL x);

277

286

278// Add a message to another VM's message queue

287// Add a message to another VM's message queue

279void idris_sendMessage(VM* sender, VM* dest, VAL msg);

288void idris_sendMessage(VM* sender, VM* dest, VAL msg);

289+// Check whether there are any messages in the queue and return PID of

290+// sender if so (null if not)

291+VM* idris_checkMessages(VM* vm);

280// Check whether there are any messages in the queue

292// Check whether there are any messages in the queue

281−int idris_checkMessages(VM* vm);

293+VM* idris_checkMessagesFrom(VM* vm, VM* sender);

282// block until there is a message in the queue

294// block until there is a message in the queue

283−VAL idris_recvMessage(VM* vm);

295+Msg* idris_recvMessage(VM* vm);

296+// block until there is a message in the queue

297+Msg* idris_recvMessageFrom(VM* vm, VM* sender);

298+

299+// Query/free structure used to return message data (recvMessage will malloc,

300+// so needs an explicit free)

301+VAL idris_getMsg(Msg* msg);

302+VM* idris_getSender(Msg* msg);

303+void idris_freeMsg(Msg* msg);

284

304

285void dumpVal(VAL r);

305void dumpVal(VAL r);

286void dumpStack(VM* vm);

306void dumpStack(VM* vm);

rts/windows/idris_stdfgn.c+10−3

@@ -5,9 +5,12 @@

5#include <fcntl.h>

6#include <stdio.h>

7#include <time.h>

8+#include <io.h>

9extern char** environ;

10extern char** environ;

12+int win_fpoll(void* h);

13+

11void putStr(char* str) {

14void putStr(char* str) {

12 printf("%s", str);

15 printf("%s", str);

13}

16}

@@ -32,14 +35,18 @@ int fileError(void* h) {

32 return ferror(f);

35 return ferror(f);

33}

36}

35−void fputStr(void* h, char* str) {

38+int idris_writeStr(void* h, char* str) {

36 FILE* f = (FILE*)h;

39 FILE* f = (FILE*)h;

37− fputs(str, f);

40+ if (fputs(str, f)) {

41+ return 0;

42+ } else {

43+ return -1;

44+ }

38}

45}

40int fpoll(void* h)

47int fpoll(void* h)

41{

48{

42− return 0;

49+ return win_fpoll(h);

43}

50}

45void* do_popen(const char* cmd, const char* mode) {

52void* do_popen(const char* cmd, const char* mode) {

rts/windows/win_utils.cnew file+21

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

1+#include <windows.h>

2+#include <io.h>

3+#include <stdio.h>

5+// THis file exists to avoid clashes between windows.h and idris_rts.h

6+//

8+int win_fpoll(void* h)

9+{

10+ HANDLE wh =(HANDLE) _get_osfhandle(_fileno((FILE*)h));

11+ if (wh == INVALID_HANDLE_VALUE) {

12+ return -1;

13+ }

14+ DWORD ret = WaitForSingleObject(wh, 1000);

15+ // Imitate the return values of select()

16+ if (ret == WAIT_OBJECT_0)

17+ return 1;

18+ if (ret == WAIT_TIMEOUT)

19+ return 0;

20+ return -1;

21+}

src/IRTS/Lang.hs+4−1

@@ -281,7 +281,10 @@ usedIn env (LLazyExp e) = usedIn env e

281usedIn env (LForce e) = usedIn env e

282usedIn env (LLet n v e) = usedIn env v ++ usedIn (env \\ [n]) e

283usedIn env (LLam ns e) = usedIn (env \\ ns) e

284−usedIn env (LCon loc i n args) = concatMap (usedIn env) args

284+usedIn env (LCon v i n args) = let rest = concatMap (usedIn env) args in

285+ case v of

286+ Nothing -> rest

287+ Just (Glob n) -> usedArg env n ++ rest

285usedIn env (LProj t i) = usedIn env t

288usedIn env (LProj t i) = usedIn env t

286usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts

289usedIn env (LCase up e alts) = usedIn env e ++ concatMap (usedInA env) alts

287 where usedInA env (LConCase i n ns e) = usedIn env e

290 where usedInA env (LConCase i n ns e) = usedIn env e

src/Idris/AbsSyntax.hs+29−11

@@ -10,7 +10,7 @@ import Idris.Core.Typecheck

10import Idris.AbsSyntaxTree

11import Idris.Colours

12import Idris.Docstrings

13−import Idris.IdeSlave hiding (Opt(..))

13+import Idris.IdeMode hiding (Opt(..))

14import IRTS.CodegenCommon

15import Util.DynamicLinker

@@ -601,7 +601,7 @@ type1Doc = (annotate (AnnType "Type" "The type of types, one level up") $ text "

601isetPrompt :: String -> Idris ()

602isetPrompt p = do i <- getIState

603 case idris_outputmode i of

604− IdeSlave n h -> runIO . hPutStrLn h $ convSExp "set-prompt" p n

604+ IdeMode n h -> runIO . hPutStrLn h $ convSExp "set-prompt" p n

605

606-- | Tell clients how much was parsed and loaded

607isetLoadedRegion :: Idris ()

@@ -610,7 +610,7 @@ isetLoadedRegion = do i <- getIState

610 case span of

611 Just fc ->

612 case idris_outputmode i of

613− IdeSlave n h ->

613+ IdeMode n h ->

614 runIO . hPutStrLn h $

615 convSExp "set-loaded-region" fc n

616 Nothing -> return ()

@@ -752,10 +752,12 @@ outputTy :: Idris OutputType

752outputTy = do i <- getIState

753 return $ opt_outputTy $ idris_options i

754

755−setIdeSlave :: Bool -> Handle -> Idris ()

755+setIdeMode :: Bool -> Handle -> Idris ()

756−setIdeSlave True h = do i <- getIState

756+setIdeMode True h = do i <- getIState

757− putIState $ i { idris_outputmode = (IdeSlave 0 h), idris_colourRepl = False }

757+ putIState $ i { idris_outputmode = IdeMode 0 h

758+ , idris_colourRepl = False

759+ }

758−setIdeSlave False _ = return ()

760+setIdeMode False _ = return ()

759

761

760setTargetTriple :: String -> Idris ()

762setTargetTriple :: String -> Idris ()

761setTargetTriple t = do i <- getIState

763setTargetTriple t = do i <- getIState

@@ -870,7 +872,7 @@ logLvl l str = do i <- getIState

870 when (lvl >= l) $

872 when (lvl >= l) $

871 case idris_outputmode i of

873 case idris_outputmode i of

872 RawOutput h -> do runIO $ hPutStrLn h str

874 RawOutput h -> do runIO $ hPutStrLn h str

873− IdeSlave n h ->

875+ IdeMode n h ->

874 do let good = SexpList [IntegerAtom (toInteger l), toSExp str]

876 do let good = SexpList [IntegerAtom (toInteger l), toSExp str]

875 runIO . hPutStrLn h $ convSExp "log" good n

877 runIO . hPutStrLn h $ convSExp "log" good n

876

878

@@ -972,6 +974,7 @@ expandParams dec ps ns infs tm = en tm

972 en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)

974 en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)

973 en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as)

975 en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as)

974 en (PCase fc c os) = PCase fc (en c) (map (pmap en) os)

976 en (PCase fc c os) = PCase fc (en c) (map (pmap en) os)

977+ en (PRunTactics fc tm) = PRunTactics fc (en tm)

975 en t = t

978 en t = t

976

979

977 nselem x [] = False

980 nselem x [] = False

@@ -1014,7 +1017,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

1014 (map (expandParams dec ps'' ns' []) ws)

1017 (map (expandParams dec ps'' ns' []) ws)

1015 (expandParams dec ps'' ns' [] rhs)

1018 (expandParams dec ps'' ns' [] rhs)

1016 (map (expandParamsD True ist dec ps'' ns') ds)

1019 (map (expandParamsD True ist dec ps'' ns') ds)

1017− expandParamsC (PWith fc n lhs ws wval ds)

1020+ expandParamsC (PWith fc n lhs ws wval pn ds)

1018 = let -- ps' = updateps True (namesIn ist wval) (zip ps [0..])

1021 = let -- ps' = updateps True (namesIn ist wval) (zip ps [0..])

1019 ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..])

1022 ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..])

1020 lhs' = if rhsonly then lhs else (expandParams dec ps'' ns [] lhs)

1023 lhs' = if rhsonly then lhs else (expandParams dec ps'' ns [] lhs)

@@ -1023,6 +1026,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

1023 PWith fc n' lhs'

1026 PWith fc n' lhs'

1024 (map (expandParams dec ps'' ns' []) ws)

1027 (map (expandParams dec ps'' ns' []) ws)

1025 (expandParams dec ps'' ns' [] wval)

1028 (expandParams dec ps'' ns' [] wval)

1029+ pn

1026 (map (expandParamsD rhsonly ist dec ps'' ns') ds)

1030 (map (expandParamsD rhsonly ist dec ps'' ns') ds)

1027 updateps yn nm [] = []

1031 updateps yn nm [] = []

1028 updateps yn nm (((a, t), i):as)

1032 updateps yn nm (((a, t), i):as)

@@ -1441,6 +1445,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1441 imps top env (PHidden tm) = imps False env tm

1445 imps top env (PHidden tm) = imps False env tm

1442 imps top env (PUnifyLog tm) = imps False env tm

1446 imps top env (PUnifyLog tm) = imps False env tm

1443 imps top env (PNoImplicits tm) = imps False env tm

1447 imps top env (PNoImplicits tm) = imps False env tm

1448+ imps top env (PRunTactics fc tm) = imps False env tm

1444 imps top env _ = return ()

1449 imps top env _ = return ()

1445

1450

1446 pibind using [] sc = sc

1451 pibind using [] sc = sc

@@ -1562,6 +1567,7 @@ addImpl' inpat env infns ist ptm

1562 ai qq env ds (PQuasiquote tm g) = PQuasiquote (ai True env ds tm)

1567 ai qq env ds (PQuasiquote tm g) = PQuasiquote (ai True env ds tm)

1563 (fmap (ai True env ds) g)

1568 (fmap (ai True env ds) g)

1564 ai qq env ds (PUnquote tm) = PUnquote (ai False env ds tm)

1569 ai qq env ds (PUnquote tm) = PUnquote (ai False env ds tm)

1570+ ai qq env ds (PRunTactics fc tm) = PRunTactics fc (ai False env ds tm)

1565 ai qq env ds tm = tm

1571 ai qq env ds tm = tm

1566

1572

1567 handleErr (Left err) = PElabError err

1573 handleErr (Left err) = PElabError err

@@ -1708,6 +1714,10 @@ stripLinear i tm = evalState (sl tm) [] where

1708 return (a' : as')

1714 return (a' : as')

1709 slAlts ns [] = return []

1715 slAlts ns [] = return []

1710 sl (PPair fc p l r) = do l' <- sl l; r' <- sl r; return (PPair fc p l' r')

1716 sl (PPair fc p l r) = do l' <- sl l; r' <- sl r; return (PPair fc p l' r')

1717+ sl (PDPair fc p l t r) = do l' <- sl l

1718+ t' <- sl t

1719+ r' <- sl r

1720+ return (PDPair fc p l' t' r')

1711 sl (PApp fc fn args) = do -- Just the args, fn isn't matchable as a var

1721 sl (PApp fc fn args) = do -- Just the args, fn isn't matchable as a var

1712 args' <- mapM slA args

1722 args' <- mapM slA args

1713 return $ PApp fc fn args'

1723 return $ PApp fc fn args'

@@ -1734,7 +1744,11 @@ stripUnmatchable i (PApp fc fn args) = PApp fc fn (fmap (fmap su) args) where

1734 | (Bind n (Pi _ t _) sc :_) <- lookupTy f (tt_ctxt i)

1744 | (Bind n (Pi _ t _) sc :_) <- lookupTy f (tt_ctxt i)

1735 = Placeholder

1745 = Placeholder

1736 su (PApp fc f@(PRef _ fn) args)

1746 su (PApp fc f@(PRef _ fn) args)

1737− | isDConName fn ctxt

1747+ -- here we use canBeDConName because the impossible pattern

1748+ -- check will not necessarily fully resolve constructor names,

1749+ -- and these bare names will otherwise get in the way of

1750+ -- impossbility checking.

1751+ | canBeDConName fn ctxt

1738 = PApp fc f (fmap (fmap su) args)

1752 = PApp fc f (fmap (fmap su) args)

1739 su (PApp fc f args)

1753 su (PApp fc f args)

1740 = PHidden (PApp fc f args)

1754 = PHidden (PApp fc f args)

@@ -1968,8 +1982,11 @@ shadow :: Name -> Name -> PTerm -> PTerm

1968shadow n n' t = sm t where

1982shadow n n' t = sm t where

1969 sm (PRef fc x) | n == x = PRef fc n'

1983 sm (PRef fc x) | n == x = PRef fc n'

1970 sm (PLam fc x t sc) | n /= x = PLam fc x (sm t) (sm sc)

1984 sm (PLam fc x t sc) | n /= x = PLam fc x (sm t) (sm sc)

1985+ | otherwise = PLam fc x (sm t) sc

1971− sm (PPi p x t sc) | n /=x = PPi p x (sm t) (sm sc)

1986+ sm (PPi p x t sc) | n /= x = PPi p x (sm t) (sm sc)

1987+ | otherwise = PPi p x (sm t) sc

1972 sm (PLet fc x t v sc) | n /= x = PLet fc x (sm t) (sm v) (sm sc)

1988 sm (PLet fc x t v sc) | n /= x = PLet fc x (sm t) (sm v) (sm sc)

1989+ | otherwise = PLet fc x (sm t) (sm v) sc

1973 sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)

1990 sm (PApp f x as) = PApp f (sm x) (map (fmap sm) as)

1974 sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as)

1991 sm (PAppBind f x as) = PAppBind f (sm x) (map (fmap sm) as)

1975 sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)

1992 sm (PCase f x as) = PCase f (sm x) (map (pmap sm) as)

@@ -2082,4 +2099,5 @@ mkUniqueNames env tm = evalState (mkUniq tm) (S.fromList env) where

2082 mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t)

2099 mkUniq (PNoImplicits t) = liftM PNoImplicits (mkUniq t)

2083 mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts)

2100 mkUniq (PProof ts) = liftM PProof (mapM mkUniqT ts)

2084 mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts)

2101 mkUniq (PTactics ts) = liftM PTactics (mapM mkUniqT ts)

2102+ mkUniq (PRunTactics fc ts) = liftM (PRunTactics fc ) (mkUniq ts)

2085 mkUniq t = return t

2103 mkUniq t = return t

src/Idris/AbsSyntaxTree.hs+31−10

@@ -26,6 +26,7 @@ import qualified Control.Monad.Trans.Class as Trans (lift)

27import Data.Data (Data)

28import Data.Function (on)

29+import Data.Generics.Uniplate.Data (universe)

29import Data.List hiding (group)

30import Data.List hiding (group)

30import Data.Char

31import Data.Char

31import qualified Data.Map.Strict as M

32import qualified Data.Map.Strict as M

@@ -143,7 +144,7 @@ data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord

143

144

144-- | The output mode in use

145-- | The output mode in use

145data OutputMode = RawOutput Handle -- ^ Print user output directly to the handle

146data OutputMode = RawOutput Handle -- ^ Print user output directly to the handle

146− | IdeSlave Integer Handle -- ^ Send IDE output for some request ID to the handle

147+ | IdeMode Integer Handle -- ^ Send IDE output for some request ID to the handle

147 deriving Show

148 deriving Show

148

149

149-- | How wide is the console?

150-- | How wide is the console?

@@ -404,8 +405,8 @@ data Opt = Filename String

404 | Quiet

405 | Quiet

405 | NoBanner

406 | NoBanner

406 | ColourREPL Bool

407 | ColourREPL Bool

407− | Ideslave

408+ | Idemode

408− | IdeslaveSocket

409+ | IdemodeSocket

409 | ShowLibs

410 | ShowLibs

410 | ShowLibdir

411 | ShowLibdir

411 | ShowIncs

412 | ShowIncs

@@ -636,10 +637,10 @@ type ElabD a = Elab' EState a

636--

637--

637-- 4. The where block (PDecl' t)

638-- 4. The where block (PDecl' t)

638

639

639−data PClause' t = PClause FC Name t [t] t [PDecl' t] -- ^ A normal top-level definition.

640+data PClause' t = PClause FC Name t [t] t [PDecl' t] -- ^ A normal top-level definition.

640− | PWith FC Name t [t] t [PDecl' t]

641+ | PWith FC Name t [t] t (Maybe Name) [PDecl' t]

641− | PClauseR FC [t] t [PDecl' t]

642+ | PClauseR FC [t] t [PDecl' t]

642− | PWithR FC [t] t [PDecl' t]

643+ | PWithR FC [t] t (Maybe Name) [PDecl' t]

643 deriving Functor

644 deriving Functor

644{-!

645{-!

645deriving instance Binary PClause'

646deriving instance Binary PClause'

@@ -758,6 +759,7 @@ data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level langua

758 | PLet FC Name PTerm PTerm PTerm -- ^ A let binding

759 | PLet FC Name PTerm PTerm PTerm -- ^ A let binding

759 | PTyped PTerm PTerm -- ^ Term with explicit type

760 | PTyped PTerm PTerm -- ^ Term with explicit type

760 | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x

761 | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x

762+ | PAppImpl PTerm [ImplicitInfo] -- ^ Implicit argument application (introduced during elaboration only)

761 | PAppBind FC PTerm [PArg] -- ^ implicitly bound application

763 | PAppBind FC PTerm [PArg] -- ^ implicitly bound application

762 | PMatchApp FC Name -- ^ Make an application by type matching

764 | PMatchApp FC Name -- ^ Make an application by type matching

763 | PCase FC PTerm [(PTerm, PTerm)] -- ^ A case expression. Args are source location, scrutinee, and a list of pattern/RHS pairs

765 | PCase FC PTerm [(PTerm, PTerm)] -- ^ A case expression. Args are source location, scrutinee, and a list of pattern/RHS pairs

@@ -789,7 +791,8 @@ data PTerm = PQuote Raw -- ^ Inclusion of a core term into the high-level langua

789 | PUnifyLog PTerm -- ^ dump a trace of unifications when building term

791 | PUnifyLog PTerm -- ^ dump a trace of unifications when building term

790 | PNoImplicits PTerm -- ^ never run implicit converions on the term

792 | PNoImplicits PTerm -- ^ never run implicit converions on the term

791 | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])

793 | PQuasiquote PTerm (Maybe PTerm) -- ^ `(Term [: Term])

792− | PUnquote PTerm -- ^ ,Term

794+ | PUnquote PTerm -- ^ ~Term

795+ | PRunTactics FC PTerm -- ^ %runTactics tm - New-style proof script

793 deriving (Eq, Data, Typeable)

796 deriving (Eq, Data, Typeable)

794

797

795

798

@@ -829,6 +832,8 @@ data PTactic' t = Intro [Name] | Intros | Focus Name

829 | Induction t

832 | Induction t

830 | CaseTac t

833 | CaseTac t

831 | Equiv t

834 | Equiv t

835+ | Claim Name t

836+ | Unfocus

832 | MatchRefine Name

837 | MatchRefine Name

833 | LetTac Name t | LetTacTy Name t t

838 | LetTac Name t | LetTacTy Name t t

834 | Exact t | Compute | Trivial | TCInstance

839 | Exact t | Compute | Trivial | TCInstance

@@ -1243,6 +1248,9 @@ falseTy = sUN "Void"

1243pairTy = sNS (sUN "Pair") ["Builtins"]

1248pairTy = sNS (sUN "Pair") ["Builtins"]

1244pairCon = sNS (sUN "MkPair") ["Builtins"]

1249pairCon = sNS (sUN "MkPair") ["Builtins"]

1245

1250

1251+upairTy = sNS (sUN "UPair") ["Builtins"]

1252+upairCon = sNS (sUN "MkUPair") ["Builtins"]

1253+

1246eqTy = sUN "="

1254eqTy = sUN "="

1247eqCon = sUN "Refl"

1255eqCon = sUN "Refl"

1248eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

1256eqDoc = fmap (const (Left $ Msg "")) . parseDocstring . T.pack $

@@ -1376,6 +1384,7 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1376 where

1384 where

1377 startPrec = 0

1385 startPrec = 0

1378 funcAppPrec = 10

1386 funcAppPrec = 10

1387+

1379 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

1388 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

1380 prettySe p bnd (PQuote r) =

1389 prettySe p bnd (PQuote r) =

1381 text "![" <> pretty r <> text "]"

1390 text "![" <> pretty r <> text "]"

@@ -1641,6 +1650,16 @@ pprintPTerm ppo bnd docArgs infixes = prettySe startPrec bnd

1641 getFixity :: String -> Maybe Fixity

1650 getFixity :: String -> Maybe Fixity

1642 getFixity = flip M.lookup fixities

1651 getFixity = flip M.lookup fixities

1643

1652

1653+-- | Determine whether a name was the one inserted for a hole or

1654+-- guess by the delaborator

1655+isHoleName :: Name -> Bool

1656+isHoleName (UN n) = n == T.pack "[__]"

1657+isHoleName _ = False

1658+

1659+-- | Check whether a PTerm has been delaborated from a Term containing a Hole or Guess

1660+containsHole :: PTerm -> Bool

1661+containsHole pterm = or [isHoleName n | PRef _ n <- take 1000 $ universe pterm]

1662+

1644-- | Pretty-printer helper for the binding site of a name

1663-- | Pretty-printer helper for the binding site of a name

1645bindingOf :: Name -- ^^ the bound name

1664bindingOf :: Name -- ^^ the bound name

1646 -> Bool -- ^^ whether the name is implicit

1665 -> Bool -- ^^ whether the name is implicit

@@ -1656,7 +1675,7 @@ prettyName

1656 -> Doc OutputAnnotation

1675 -> Doc OutputAnnotation

1657prettyName infixParen showNS bnd n

1676prettyName infixParen showNS bnd n

1658 | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"

1677 | (MN _ s) <- n, isPrefixOf "_" $ T.unpack s = text "_"

1659− | (UN n') <- n, isPrefixOf "_" $ T.unpack n' = text "_"

1678+ | (UN n') <- n, T.unpack n' == "_" = text "_"

1660 | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName

1679 | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) fullName

1661 | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName

1680 | otherwise = annotate (AnnName n Nothing Nothing Nothing) fullName

1662 where fullName = text nameSpace <> parenthesise (text (baseName n))

1681 where fullName = text nameSpace <> parenthesise (text (baseName n))

@@ -1680,7 +1699,7 @@ showCImp ppo (PClause _ n l ws r w)

1680 where

1699 where

1681 showWs [] = empty

1700 showWs [] = empty

1682 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

1701 showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

1683−showCImp ppo (PWith _ n l ws r w)

1702+showCImp ppo (PWith _ n l ws r pn w)

1684 = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

1703 = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

1685 <+> braces (text (show w))

1704 <+> braces (text (show w))

1686 where

1705 where

@@ -1728,6 +1747,8 @@ getShowArgs :: [PArg] -> [PArg]

1728getShowArgs [] = []

1747getShowArgs [] = []

1729getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs

1748getShowArgs (e@(PExp _ _ _ tm) : xs) = e : getShowArgs xs

1730getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs

1749getShowArgs (e : xs) | AlwaysShow `elem` argopts e = e : getShowArgs xs

1750+ | PImp _ _ _ _ tm <- e

1751+ , containsHole tm = e : getShowArgs xs

1731getShowArgs (_ : xs) = getShowArgs xs

1752getShowArgs (_ : xs) = getShowArgs xs

1732

1753

1733getConsts :: [PArg] -> [PTerm]

1754getConsts :: [PArg] -> [PTerm]

src/Idris/CmdOptions.hs+5−3

@@ -26,7 +26,7 @@ runArgParser = do opts <- execParser $ info parser

26 idrisProgDesc = PP.vsep [PP.empty,

27 PP.text "Idris is a general purpose pure functional programming language with dependent",

28 PP.text "types. Dependent types allow types to be predicated on values, meaning that",

29− PP.text "some aspects of a program’s behaviour can be specified precisely in the type.",

29+ PP.text "some aspects of a program's behaviour can be specified precisely in the type.",

30 PP.text "It is compiled, with eager evaluation. Its features are influenced by Haskell",

31 PP.text "and ML.",

32 PP.empty,

@@ -71,8 +71,10 @@ parseFlags :: Parser [Opt]

71parseFlags = many $

72 flag' NoBanner (long "nobanner" <> help "Suppress the banner")

73 <|> flag' Quiet (short 'q' <> long "quiet" <> help "Quiet verbosity")

74− <|> flag' Ideslave (long "ideslave")

74+ <|> flag' Idemode (long "ide-mode" <> help "Run the Idris REPL with machine-readable syntax")

75− <|> flag' IdeslaveSocket (long "ideslave-socket")

75+ <|> flag' IdemodeSocket (long "ide-mode-socket" <> help "Choose a socket for IDE mode to listen on")

76+ <|> flag' Idemode (long "ideslave" <> help "Deprecated version of --ide-mode") -- TODO: Remove in v0.9.18

77+ <|> flag' IdemodeSocket (long "ideslave-socket" <> help "Deprecated version of --ide-mode-socket") -- TODO: Remove in v0.9.18

76 <|> (Client <$> strOption (long "client"))

78 <|> (Client <$> strOption (long "client"))

77 <|> (OLogging <$> option auto (long "log" <> metavar "LEVEL" <> help "Debugging log level"))

79 <|> (OLogging <$> option auto (long "log" <> metavar "LEVEL" <> help "Debugging log level"))

78 <|> flag' NoBasePkgs (long "nobasepkgs" <> help "Do not use the given base package")

80 <|> flag' NoBasePkgs (long "nobasepkgs" <> help "Do not use the given base package")

src/Idris/Core/Elaborate.hs+18−17

@@ -173,30 +173,30 @@ elaborating_app = do ES (ps, _) _ _ <- get

173

174-- Some handy gadgets for pulling out bits of state

175

176−-- get the global context

176+-- | Get the global context

177get_context :: Elab' aux Context

178get_context = do ES p _ _ <- get

179 return $! (context (fst p))

180

181−-- update the context

181+-- | Update the context.

182-- (should only be used for adding temporary definitions or all sorts of

183-- stuff could go wrong)

184set_context :: Context -> Elab' aux ()

185set_context ctxt = do ES (p, a) logs prev <- get

186 put (ES (p { context = ctxt }, a) logs prev)

187

188−-- get the proof term

188+-- | get the proof term

189get_term :: Elab' aux Term

190get_term = do ES p _ _ <- get

191 return $! (getProofTerm (pterm (fst p)))

192

193−-- get the proof term

193+-- | modify the proof term

194update_term :: (Term -> Term) -> Elab' aux ()

195update_term f = do ES (p,a) logs prev <- get

196 let p' = p { pterm = mkProofTerm (f (getProofTerm (pterm p))) }

197 put (ES (p', a) logs prev)

198

199−-- get the local context at the currently in focus hole

199+-- | get the local context at the currently in focus hole

200get_env :: Elab' aux Env

201get_env = do ES p _ _ <- get

202 lift $ envAtFocus (fst p)

@@ -213,14 +213,14 @@ get_probs :: Elab' aux Fails

213get_probs = do ES p _ _ <- get

214 return $! (problems (fst p))

215

216−-- Return recently solved names (that is, the names solved since the

216+-- | Return recently solved names (that is, the names solved since the

217-- last call to get_recents)

218get_recents :: Elab' aux [Name]

219get_recents = do ES (p, a) l prev <- get

220 put (ES (p { recents = [] }, a) l prev)

221 return (recents p)

222

223−-- get the current goal type

223+-- | get the current goal type

224goal :: Elab' aux Type

225goal = do ES p _ _ <- get

226 b <- lift $ goalAtFocus (fst p)

@@ -233,15 +233,15 @@ is_guess = do ES p _ _ <- get

233 Guess _ _ -> return True

234 _ -> return False

235

236−-- Get the guess at the current hole, if there is one

236+-- | Get the guess at the current hole, if there is one

237−get_guess :: Elab' aux Type

237+get_guess :: Elab' aux Term

238get_guess = do ES p _ _ <- get

239 b <- lift $ goalAtFocus (fst p)

240 case b of

241 Guess t v -> return $! v

242 _ -> fail "Not a guess"

243

244−-- typecheck locally

244+-- | Typecheck locally

245get_type :: Raw -> Elab' aux Type

246get_type tm = do ctxt <- get_context

247 env <- get_env

@@ -254,7 +254,7 @@ get_type_val tm = do ctxt <- get_context

254 (val, ty) <- lift $ check ctxt env tm

255 return $! (finalise val, finalise ty)

256

257−-- get holes we've deferred for later definition

257+-- | get holes we've deferred for later definition

258get_deferred :: Elab' aux [Name]

259get_deferred = do ES p _ _ <- get

260 return $! (deferred (fst p))

@@ -271,17 +271,18 @@ checkInjective (tm, l, r) = do ctxt <- get_context

271 isInj ctxt (Bind _ (Pi _ _ _) sc) = True

272 isInj ctxt _ = False

273

274−-- get instance argument names

274+-- | get instance argument names

275get_instances :: Elab' aux [Name]

276get_instances = do ES p _ _ <- get

277 return $! (instances (fst p))

278

279−-- get auto argument names

279+-- | get auto argument names

280get_autos :: Elab' aux [(Name, [Name])]

281get_autos = do ES p _ _ <- get

282 return $! (autos (fst p))

283

284−-- given a desired hole name, return a unique hole name

284+-- | given a desired hole name, return a unique hole name

285+unique_hole :: Name -> Elab' aux Name

285unique_hole = unique_hole' False

286unique_hole = unique_hole' False

286

287

287unique_hole' :: Bool -> Name -> Elab' aux Name

288unique_hole' :: Bool -> Name -> Elab' aux Name

@@ -674,7 +675,7 @@ checkPiGoal n

674 focus f

675 focus f

675

676

676simple_app :: Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

677simple_app :: Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()

677−simple_app infer fun arg app0str =

678+simple_app infer fun arg str =

678 do a <- getNameFrom (sMN 0 "argTy")

679 do a <- getNameFrom (sMN 0 "argTy")

679 b <- getNameFrom (sMN 0 "retTy")

680 b <- getNameFrom (sMN 0 "retTy")

680 f <- getNameFrom (sMN 0 "f")

681 f <- getNameFrom (sMN 0 "f")

@@ -705,8 +706,8 @@ simple_app infer fun arg app0str =

705 when (a `elem` hs) $ do movelast a

706 when (a `elem` hs) $ do movelast a

706 when (b `elem` hs) $ do movelast b

707 when (b `elem` hs) $ do movelast b

707 end_unify

708 end_unify

709+ where

708− where regretWith err = try regret

710+ regretWith err = try regret (lift $ tfail err)

709− (lift $ tfail err)

710

711

711-- Abstract over an argument of unknown type, giving a name for the hole

712-- Abstract over an argument of unknown type, giving a name for the hole

712-- which we'll fill with the argument type too.

713-- which we'll fill with the argument type too.

src/Idris/Core/Evaluate.hs+29−24

@@ -11,7 +11,7 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,

11 lookupNames, lookupTyName, lookupTyNameExact, lookupTy, lookupTyExact,

12 lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupDefAccExact, lookupVal,

13 mapDefCtxt,

14− lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, isTConName, isConName, isFnName,

14+ lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isTCDict, isDConName, canBeDConName, isTConName, isConName, isFnName,

15 Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions,

16 isUniverse) where

@@ -971,47 +971,52 @@ isConName n ctxt = isTConName n ctxt || isDConName n ctxt

971

972isTConName :: Name -> Context -> Bool

973isTConName n ctxt

974− = or $ do def <- lookupCtxt n (definitions ctxt)

974+ = case lookupDefExact n ctxt of

975− case tfst def of

976− (TyDecl (TCon _ _) _) -> return True

975+ Just (TyDecl (TCon _ _) _) -> True

977− _ -> return False

976+ _ -> False

978

977

978+-- | Check whether a resolved name is certainly a data constructor

979isDConName :: Name -> Context -> Bool

980isDConName n ctxt

981+ = case lookupDefExact n ctxt of

982+ Just (TyDecl (DCon _ _ _) _) -> True

983+ _ -> False

984+

985+-- | Check whether any overloading of a name is a data constructor

986+canBeDConName :: Name -> Context -> Bool

987+canBeDConName n ctxt

981 = or $ do def <- lookupCtxt n (definitions ctxt)

988 = or $ do def <- lookupCtxt n (definitions ctxt)

982 case tfst def of

989 case tfst def of

983− (TyDecl (DCon _ _ _) _) -> return True

990+ (TyDecl (DCon _ _ _) _) -> return True

984− _ -> return False

991+ _ -> return False

985

992

986isFnName :: Name -> Context -> Bool

993isFnName :: Name -> Context -> Bool

987isFnName n ctxt

994isFnName n ctxt

988− = let def = lookupCtxtExact n (definitions ctxt) in

995+ = case lookupDefExact n ctxt of

989− case def of

990− Just (Function _ _, _, _, _) -> True

996+ Just (Function _ _) -> True

991− Just (Operator _ _ _, _, _, _) -> True

997+ Just (Operator _ _ _) -> True

992− Just (CaseOp _ _ _ _ _ _, _, _, _) -> True

998+ Just (CaseOp _ _ _ _ _ _) -> True

993− _ -> False

999+ _ -> False

994

1000

995isTCDict :: Name -> Context -> Bool

1001isTCDict :: Name -> Context -> Bool

996isTCDict n ctxt

1002isTCDict n ctxt

997− = let def = lookupCtxtExact n (definitions ctxt) in

1003+ = case lookupDefExact n ctxt of

998− case def of

999− Just (Function _ _, _, _, _) -> False

1004+ Just (Function _ _) -> False

1000− Just (Operator _ _ _, _, _, _) -> False

1005+ Just (Operator _ _ _) -> False

1001− Just (CaseOp ci _ _ _ _ _, _, _, _) -> tc_dictionary ci

1006+ Just (CaseOp ci _ _ _ _ _) -> tc_dictionary ci

1002− _ -> False

1007+ _ -> False

1003

1008

1004lookupP :: Name -> Context -> [Term]

1009lookupP :: Name -> Context -> [Term]

1005lookupP n ctxt

1010lookupP n ctxt

1006 = do def <- lookupCtxt n (definitions ctxt)

1011 = do def <- lookupCtxt n (definitions ctxt)

1007 p <- case def of

1012 p <- case def of

1008− (Function ty tm, a, _, _) -> return (P Ref n ty, a)

1013+ (Function ty tm, a, _, _) -> return (P Ref n ty, a)

1009− (TyDecl nt ty, a, _, _) -> return (P nt n ty, a)

1014+ (TyDecl nt ty, a, _, _) -> return (P nt n ty, a)

1010 (CaseOp _ ty _ _ _ _, a, _, _) -> return (P Ref n ty, a)

1015 (CaseOp _ ty _ _ _ _, a, _, _) -> return (P Ref n ty, a)

1011− (Operator ty _ _, a, _, _) -> return (P Ref n ty, a)

1016+ (Operator ty _ _, a, _, _) -> return (P Ref n ty, a)

1012 case snd p of

1017 case snd p of

1013− Hidden -> []

1018+ Hidden -> []

1014− _ -> return (fst p)

1019+ _ -> return (fst p)

1015

1020

1016lookupDefExact :: Name -> Context -> Maybe Def

1021lookupDefExact :: Name -> Context -> Maybe Def

1017lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)

1022lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)

src/Idris/Core/ProofState.hs+34−29

@@ -23,23 +23,23 @@ import Debug.Trace

23import Util.Pretty hiding (fill)

25data ProofState = PS { thname :: Name,

26− holes :: [Name], -- holes still to be solved

26+ holes :: [Name], -- ^ holes still to be solved

27− usedns :: [Name], -- used names, don't use again

27+ usedns :: [Name], -- ^ used names, don't use again

28− nextname :: Int, -- name supply

28+ nextname :: Int, -- ^ name supply

29− pterm :: ProofTerm, -- current proof term

29+ pterm :: ProofTerm, -- ^ current proof term

30− ptype :: Type, -- original goal

30+ ptype :: Type, -- ^ original goal

31− dontunify :: [Name], -- explicitly given by programmer, leave it

31+ dontunify :: [Name], -- ^ explicitly given by programmer, leave it

32 unified :: (Name, [(Name, Term)]),

33 notunified :: [(Name, Term)],

34− dotted :: [(Name, [Name])], -- dot pattern holes + environment

34+ dotted :: [(Name, [Name])], -- ^ dot pattern holes + environment

35− -- either hole or something in env must turn up in the 'notunified' list during elaboration

35+ -- either hole or something in env must turn up in the 'notunified' list during elaboration

36 solved :: Maybe (Name, Term),

37 problems :: Fails,

38 injective :: [Name],

39− deferred :: [Name], -- names we'll need to define

39+ deferred :: [Name], -- ^ names we'll need to define

40− instances :: [Name], -- instance arguments (for type classes)

40+ instances :: [Name], -- ^ instance arguments (for type classes)

41− autos :: [(Name, [Name])], -- unsolved 'auto' implicits with their holes

41+ autos :: [(Name, [Name])], -- ^ unsolved 'auto' implicits with their holes

42− previous :: Maybe ProofState, -- for undo

42+ previous :: Maybe ProofState, -- ^ for undo

43 context :: Context,

44 plog :: String,

45 unifylog :: Bool,

@@ -290,12 +290,12 @@ addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

290

291newProof :: Name -> Context -> Type -> ProofState

292newProof n ctxt ty = let h = holeName 0

293− ty' = vToP ty in

293+ ty' = vToP ty

294− PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')

294+ in PS n [h] [] 1 (mkProofTerm (Bind h (Hole ty')

295− (P Bound h ty'))) ty [] (h, []) [] []

295+ (P Bound h ty'))) ty [] (h, []) [] []

296− Nothing [] []

296+ Nothing [] []

297− [] [] []

297+ [] [] []

298− Nothing ctxt "" False False [] []

298+ Nothing ctxt "" False False [] []

299

300type TState = ProofState -- [TacticAction])

301type RunTactic = RunTactic' TState

@@ -530,6 +530,7 @@ solve ctxt env (Bind x (Guess ty val) sc)

530 action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping hole " ++ show x) $

531 holes ps \\ [x],

532 solved = Just (x, val),

533+ dontunify = filter (/= x) (dontunify ps),

533 notunified = updateNotunified [(x,val)]

534 notunified = updateNotunified [(x,val)]

534 (notunified ps),

535 (notunified ps),

535 recents = x : recents ps,

536 recents = x : recents ps,

@@ -602,6 +603,7 @@ patvar n ctxt env (Bind x (Hole t) sc) =

602 do action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping pattern hole " ++ show x) $

603 do action (\ps -> ps { holes = traceWhen (unifylog ps) ("Dropping pattern hole " ++ show x) $

603 holes ps \\ [x],

604 holes ps \\ [x],

604 solved = Just (x, P Bound n t),

605 solved = Just (x, P Bound n t),

606+ dontunify = filter (/=x) (dontunify ps),

605 notunified = updateNotunified [(x,P Bound n t)]

607 notunified = updateNotunified [(x,P Bound n t)]

606 (notunified ps),

608 (notunified ps),

607 injective = addInj n x (injective ps)

609 injective = addInj n x (injective ps)

@@ -851,6 +853,7 @@ updateProblems ps updates probs = up updates probs where

851 hs = holes ps

853 hs = holes ps

852 inj = injective ps

854 inj = injective ps

853 ctxt = context ps

855 ctxt = context ps

856+ ulog = unifylog ps

854 usupp = map fst (notunified ps)

857 usupp = map fst (notunified ps)

855

858

856 up ns [] = (ns, [])

859 up ns [] = (ns, [])

@@ -862,8 +865,8 @@ updateProblems ps updates probs = up updates probs where

862 if newx || newy || ready ||

865 if newx || newy || ready ||

863 any (\n -> n `elem` inj) (refsIn x ++ refsIn y) then

866 any (\n -> n `elem` inj) (refsIn x ++ refsIn y) then

864 case unify ctxt env' x' y' inj hs usupp while of

867 case unify ctxt env' x' y' inj hs usupp while of

865− OK (v, []) -> -- trace ("DID " ++ show (x',y',ready,v)) $

868+ OK (v, []) -> traceWhen ulog ("DID " ++ show (x',y',ready,v)) $

866− up (ns ++ v) ps

869+ up (ns ++ v) ps

867 e -> -- trace ("FAILED " ++ show (x',y',ready,e)) $

870 e -> -- trace ("FAILED " ++ show (x',y',ready,e)) $

868 let (ns', ps') = up ns ps in

871 let (ns', ps') = up ns ps in

869 (ns', (x',y', False, env',err', while, um) : ps')

872 (ns', (x',y', False, env',err', while, um) : ps')

@@ -911,7 +914,7 @@ processTactic EndUnify ps

911 ns' = map (\ (n, t) -> (n, updateSolvedTerm ns t)) ns

914 ns' = map (\ (n, t) -> (n, updateSolvedTerm ns t)) ns

912 (ns'', probs') = updateProblems ps ns' (problems ps)

915 (ns'', probs') = updateProblems ps ns' (problems ps)

913 tm' = updateSolved ns'' (pterm ps) in

916 tm' = updateSolved ns'' (pterm ps) in

914− traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $

917+ traceWhen (unifylog ps) ("(EndUnify) Dropping holes: " ++ show (map fst ns'')) $

915 return (ps { pterm = tm',

918 return (ps { pterm = tm',

916 unified = (h, []),

919 unified = (h, []),

917 problems = probs',

920 problems = probs',

@@ -934,7 +937,7 @@ processTactic (ComputeLet n) ps

934processTactic UnifyProblems ps

937processTactic UnifyProblems ps

935 = do let (ns', probs') = updateProblems ps [] (problems ps)

938 = do let (ns', probs') = updateProblems ps [] (problems ps)

936 pterm' = updateSolved ns' (pterm ps)

939 pterm' = updateSolved ns' (pterm ps)

937− traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $

940+ traceWhen (unifylog ps) ("(UnifyProblems) Dropping holes: " ++ show (map fst ns')) $

938 return (ps { pterm = pterm', solved = Nothing, problems = probs',

941 return (ps { pterm = pterm', solved = Nothing, problems = probs',

939 previous = Just ps, plog = "",

942 previous = Just ps, plog = "",

940 notunified = updateNotunified ns' (notunified ps),

943 notunified = updateNotunified ns' (notunified ps),

@@ -944,7 +947,7 @@ processTactic (MatchProblems all) ps

944 = do let (ns', probs') = matchProblems all ps [] (problems ps)

947 = do let (ns', probs') = matchProblems all ps [] (problems ps)

945 (ns'', probs'') = matchProblems all ps ns' probs'

948 (ns'', probs'') = matchProblems all ps ns' probs'

946 pterm' = updateSolved ns'' (pterm ps)

949 pterm' = updateSolved ns'' (pterm ps)

947− traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns'')) $

950+ traceWhen (unifylog ps) ("(MatchProblems) Dropping holes: " ++ show (map fst ns'')) $

948 return (ps { pterm = pterm', solved = Nothing, problems = probs'',

951 return (ps { pterm = pterm', solved = Nothing, problems = probs'',

949 previous = Just ps, plog = "",

952 previous = Just ps, plog = "",

950 notunified = updateNotunified ns'' (notunified ps),

953 notunified = updateNotunified ns'' (notunified ps),

@@ -954,16 +957,19 @@ processTactic t ps

954 = case holes ps of

957 = case holes ps of

955 [] -> fail "Nothing to fill in."

958 [] -> fail "Nothing to fill in."

956 (h:_) -> do ps' <- execStateT (process t h) ps

959 (h:_) -> do ps' <- execStateT (process t h) ps

957− let (ns', probs')

960+ let (ns_in, probs')

958 = case solved ps' of

961 = case solved ps' of

959− Just s -> traceWhen (unifylog ps')

962+ Just s -> traceWhen (unifylog ps)

960− ("SOLVED " ++ show s) $

963+ ("SOLVED " ++ show s ++ " " ++ show (dontunify ps')) $

961− updateProblems ps [s] (problems ps')

964+ updateProblems ps' [s] (problems ps')

962 _ -> ([], problems ps')

965 _ -> ([], problems ps')

963 -- rechecking problems may find more solutions, so

966 -- rechecking problems may find more solutions, so

964 -- apply them here

967 -- apply them here

968+ let ns' = dropGiven (dontunify ps') ns_in (holes ps')

965 let pterm'' = updateSolved ns' (pterm ps')

969 let pterm'' = updateSolved ns' (pterm ps')

970+ traceWhen (unifylog ps)

971+ ("Updated problems after solve " ++ qshow probs' ++ "\n" ++

966− traceWhen (unifylog ps) ("Dropping holes: " ++ show (map fst ns')) $

972+ "(Toplevel) Dropping holes: " ++ show (map fst ns')) $

967 return (ps' { pterm = pterm'',

973 return (ps' { pterm = pterm'',

968 solved = Nothing,

974 solved = Nothing,

969 problems = probs',

975 problems = probs',

@@ -986,7 +992,6 @@ process t h = tactic (Just h) (mktac t)

986 mktac (MatchFill r) = match_fill r

992 mktac (MatchFill r) = match_fill r

987 mktac (PrepFill n ns) = prep_fill n ns

993 mktac (PrepFill n ns) = prep_fill n ns

988 mktac CompleteFill = complete_fill

994 mktac CompleteFill = complete_fill

989− mktac Regret = regret

990 mktac Solve = solve

995 mktac Solve = solve

991 mktac (StartUnify n) = start_unify n

996 mktac (StartUnify n) = start_unify n

992 mktac Compute = compute

997 mktac Compute = compute

src/Idris/Core/ProofTerm.hs+37−14

@@ -1,8 +1,9 @@

1{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, PatternGuards #-}

3−{- Implements a proof state, some primitive tactics for manipulating

3+{- | Implements a proof state, some primitive tactics for manipulating

4− proofs, and some high level commands for introducing new theorems,

4+proofs, and some high level commands for introducing new theorems,

5− evaluation/checking inside the proof system, etc. --}

5+evaluation/checking inside the proof system, etc.

6+-}

7module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm,

8module Idris.Core.ProofTerm(ProofTerm, Goal(..), mkProofTerm, getProofTerm,

8 updateSolved, updateSolvedTerm, updateSolvedTerm',

9 updateSolved, updateSolvedTerm, updateSolvedTerm',

@@ -18,6 +19,7 @@ import Control.Monad.State.Strict

18import Data.List

19import Data.List

19import Debug.Trace

20import Debug.Trace

22+-- | A zipper over terms, in order to efficiently update proof terms.

21data TermPath = Top

23data TermPath = Top

22 | AppL TermPath Term

24 | AppL TermPath Term

23 | AppR Term TermPath

25 | AppR Term TermPath

@@ -25,6 +27,7 @@ data TermPath = Top

25 | InScope Name (Binder Term) TermPath

27 | InScope Name (Binder Term) TermPath

26 deriving Show

28 deriving Show

30+-- | A zipper over binders, because terms and binders are mutually defined.

28data BinderPath = Binder (Binder TermPath)

31data BinderPath = Binder (Binder TermPath)

29 | LetT TermPath Term

32 | LetT TermPath Term

30 | LetV Term TermPath

33 | LetV Term TermPath

@@ -32,6 +35,8 @@ data BinderPath = Binder (Binder TermPath)

32 | GuessV Term TermPath

35 | GuessV Term TermPath

33 deriving Show

36 deriving Show

38+-- | Replace the top of a term path with another term path. In other

39+-- words, "graft" one term path into another.

35replaceTop :: TermPath -> TermPath -> TermPath

40replaceTop :: TermPath -> TermPath -> TermPath

36replaceTop p Top = p

41replaceTop p Top = p

37replaceTop p (AppL l t) = AppL (replaceTop p l) t

42replaceTop p (AppL l t) = AppL (replaceTop p l) t

@@ -45,6 +50,7 @@ replaceTop p (InBind n bp sc) = InBind n (replaceTopB p bp) sc

45 replaceTopB p (GuessV t v) = GuessV t (replaceTop p v)

50 replaceTopB p (GuessV t v) = GuessV t (replaceTop p v)

46replaceTop p (InScope n b sc) = InScope n b (replaceTop p sc)

51replaceTop p (InScope n b sc) = InScope n b (replaceTop p sc)

53+-- | Build a term from a zipper, given something to put in the hole.

48rebuildTerm :: Term -> TermPath -> Term

54rebuildTerm :: Term -> TermPath -> Term

49rebuildTerm tm Top = tm

55rebuildTerm tm Top = tm

50rebuildTerm tm (AppL p a) = App (rebuildTerm tm p) a

56rebuildTerm tm (AppL p a) = App (rebuildTerm tm p) a

@@ -52,6 +58,7 @@ rebuildTerm tm (AppR f p) = App f (rebuildTerm tm p)

52rebuildTerm tm (InScope n b p) = Bind n b (rebuildTerm tm p)

58rebuildTerm tm (InScope n b p) = Bind n b (rebuildTerm tm p)

53rebuildTerm tm (InBind n bp sc) = Bind n (rebuildBinder tm bp) sc

59rebuildTerm tm (InBind n bp sc) = Bind n (rebuildBinder tm bp) sc

61+-- | Build a binder from a zipper, given something to put in the hole.

55rebuildBinder :: Term -> BinderPath -> Binder Term

62rebuildBinder :: Term -> BinderPath -> Binder Term

56rebuildBinder tm (Binder p) = fmap (rebuildTerm tm) p

63rebuildBinder tm (Binder p) = fmap (rebuildTerm tm) p

57rebuildBinder tm (LetT p t) = Let (rebuildTerm tm p) t

64rebuildBinder tm (LetT p t) = Let (rebuildTerm tm p) t

@@ -59,6 +66,9 @@ rebuildBinder tm (LetV v p) = Let v (rebuildTerm tm p)

59rebuildBinder tm (GuessT p t) = Guess (rebuildTerm tm p) t

66rebuildBinder tm (GuessT p t) = Guess (rebuildTerm tm p) t

60rebuildBinder tm (GuessV v p) = Guess v (rebuildTerm tm p)

67rebuildBinder tm (GuessV v p) = Guess v (rebuildTerm tm p)

69+-- | Find the binding of a hole in a term. If present, return the path

70+-- to the hole's binding, the environment extended by the binders that

71+-- are crossed, and the actual binding term.

62findHole :: Name -> Env -> Term -> Maybe (TermPath, Env, Term)

72findHole :: Name -> Env -> Term -> Maybe (TermPath, Env, Term)

63findHole n env t = fh' env Top t where

73findHole n env t = fh' env Top t where

64 fh' env path tm@(Bind x h sc)

74 fh' env path tm@(Bind x h sc)

@@ -80,7 +90,7 @@ findHole n env t = fh' env Top t where

80 fhB env path b

90 fhB env path b

81 | Just (p, env', tm) <- fh' env path (binderTy b)

91 | Just (p, env', tm) <- fh' env path (binderTy b)

82 = Just (Binder (fmap (\_ -> p) b), env', tm)

92 = Just (Binder (fmap (\_ -> p) b), env', tm)

83− fhB _ _ _ = Nothing

93+ fhB _ _ _ = Nothing

85data ProofTerm = PT { -- wholeterm :: Term,

95data ProofTerm = PT { -- wholeterm :: Term,

86 path :: TermPath,

96 path :: TermPath,

@@ -92,13 +102,17 @@ data ProofTerm = PT { -- wholeterm :: Term,

92type RunTactic' a = Context -> Env -> Term -> StateT a TC Term

102type RunTactic' a = Context -> Env -> Term -> StateT a TC Term

93type Hole = Maybe Name -- Nothing = default hole, first in list in proof state

103type Hole = Maybe Name -- Nothing = default hole, first in list in proof state

104

105+-- | Refocus the proof term zipper on a particular hole, if it

106+-- exists. If not, return the original proof term.

95refocus :: Hole -> ProofTerm -> ProofTerm

107refocus :: Hole -> ProofTerm -> ProofTerm

96refocus h t = let res = refocus' h t in res

108refocus h t = let res = refocus' h t in res

97-- trace ("OLD: " ++ show t ++ "\n" ++

109-- trace ("OLD: " ++ show t ++ "\n" ++

98-- "REFOCUSSED " ++ show h ++ ": " ++ show res) res

110-- "REFOCUSSED " ++ show h ++ ": " ++ show res) res

99refocus' (Just n) pt@(PT path env tm ups)

111refocus' (Just n) pt@(PT path env tm ups)

112+ -- First look for the hole in the proof term as-is

100 | Just (p', env', tm') <- findHole n env tm

113 | Just (p', env', tm') <- findHole n env tm

101 = PT (replaceTop p' path) env' tm' ups

114 = PT (replaceTop p' path) env' tm' ups

115+ -- Next apply the updates, and look for the hole in the resulting term

102 | Just (p', env', tm') <- findHole n [] (rebuildTerm tm (updateSolvedPath ups path))

116 | Just (p', env', tm') <- findHole n [] (rebuildTerm tm (updateSolvedPath ups path))

103 = PT p' env' tm' []

117 = PT p' env' tm' []

104 | otherwise = pt

118 | otherwise = pt

@@ -118,27 +132,32 @@ same :: Eq a => Maybe a -> a -> Bool

118same Nothing n = True

132same Nothing n = True

119same (Just x) n = x == n

133same (Just x) n = x == n

120

134

135+-- | Is a particular binder a hole or a guess?

121hole :: Binder b -> Bool

136hole :: Binder b -> Bool

122hole (Hole _) = True

137hole (Hole _) = True

123hole (Guess _ _) = True

138hole (Guess _ _) = True

124hole _ = False

139hole _ = False

125

140

141+-- | Given a list of solved holes, fill out the solutions in a term

126−updateSolvedTerm :: [(Name, Term)] -> Term -> Term

142+updateSolvedTerm :: [(Name, Term)] -> Term -> Term

127updateSolvedTerm xs x = fst $ updateSolvedTerm' xs x

143updateSolvedTerm xs x = fst $ updateSolvedTerm' xs x

128

144

145+-- | Given a list of solved holes, fill out the solutions in a

146+-- term. Return whether updates were performed, to facilitate sharing

147+-- when there are no updates.

148+updateSolvedTerm' :: [(Name, Term)] -> Term -> (Term, Bool)

129updateSolvedTerm' [] x = (x, False)

149updateSolvedTerm' [] x = (x, False)

130−updateSolvedTerm' xs x = -- updateSolved' xs x where

150+updateSolvedTerm' xs x = updateSolved' xs x where

131−-- This version below saves allocations, because it doesn't need to reallocate

151+ -- This version below saves allocations, because it doesn't need to reallocate

132−-- the term if there are no updates to do.

152+ -- the term if there are no updates to do.

133−-- The Bool is ugly, and probably 'Maybe' would be less ugly, but >>= is

153+ -- The Bool is ugly, and probably 'Maybe' would be less ugly, but >>= is

134−-- the wrong combinator. Feel free to tidy up as long as it's still as cheap :).

154+ -- the wrong combinator. Feel free to tidy up as long as it's still as cheap :).

135− updateSolved' xs x where

136 updateSolved' [] x = (x, False)

155 updateSolved' [] x = (x, False)

137 updateSolved' xs (Bind n (Hole ty) t)

156 updateSolved' xs (Bind n (Hole ty) t)

138− | Just v <- lookup n xs

157+ | Just v <- lookup n xs

139 = case xs of

158 = case xs of

140 [_] -> (subst n v t, True) -- some may be Vs! Can't assume

159 [_] -> (subst n v t, True) -- some may be Vs! Can't assume

141− -- explicit names

160+ -- explicit names

142 _ -> let (t', _) = updateSolved' xs t in

161 _ -> let (t', _) = updateSolved' xs t in

143 (subst n v t', True)

162 (subst n v t', True)

144 updateSolved' xs tm@(Bind n b t)

163 updateSolved' xs tm@(Bind n b t)

@@ -146,7 +165,7 @@ updateSolvedTerm' xs x = -- updateSolved' xs x where

146 (b', ub) = updateSolvedB' xs b in

165 (b', ub) = updateSolvedB' xs b in

147 if ut || ub then (Bind n b' t', True)

166 if ut || ub then (Bind n b' t', True)

148 else (tm, False)

167 else (tm, False)

149− updateSolved' xs t@(App f a)

168+ updateSolved' xs t@(App f a)

150 = let (f', uf) = updateSolved' xs f

169 = let (f', uf) = updateSolved' xs f

151 (a', ua) = updateSolved' xs a in

170 (a', ua) = updateSolved' xs a in

152 if uf || ua then (App f' a', True)

171 if uf || ua then (App f' a', True)

@@ -176,10 +195,14 @@ updateSolvedTerm' xs x = -- updateSolved' xs x where

176 noneOfB ns b = noneOf ns (binderTy b)

195 noneOfB ns b = noneOf ns (binderTy b)

177 noneOf ns _ = True

196 noneOf ns _ = True

178

197

198+-- | Apply solutions to an environment.

199+updateEnv :: [(Name, Term)] -> Env -> Env

179updateEnv [] e = e

200updateEnv [] e = e

180updateEnv ns [] = []

201updateEnv ns [] = []

181updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env

202updateEnv ns ((n, b) : env) = (n, fmap (updateSolvedTerm ns) b) : updateEnv ns env

182

203

204+-- | Fill out solved holes in a term zipper.

205+updateSolvedPath :: [(Name, Term)] -> TermPath -> TermPath

183updateSolvedPath [] t = t

206updateSolvedPath [] t = t

184updateSolvedPath ns Top = Top

207updateSolvedPath ns Top = Top

185updateSolvedPath ns (AppL p r) = AppL (updateSolvedPath ns p) (updateSolvedTerm ns r)

208updateSolvedPath ns (AppL p r) = AppL (updateSolvedPath ns p) (updateSolvedTerm ns r)

src/Idris/Core/TT.hs+3

@@ -1345,6 +1345,8 @@ showEnv' env t dbg = se 10 env t where

1345 = (show $ fst $ env!!i) ++

1346 if dbg then "{" ++ show i ++ "}" else ""

1347 | otherwise = "!!V " ++ show i ++ "!!"

1348+ se p env (Bind n b@(Pi (Just _) t k) sc)

1349+ = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc

1348 se p env (Bind n b@(Pi _ t k) sc)

1350 se p env (Bind n b@(Pi _ t k) sc)

1349 | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ arrow k ++ se 10 ((n,b):env) sc

1351 | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ arrow k ++ se 10 ((n,b):env) sc

1350 where arrow (TType _) = " -> "

1352 where arrow (TType _) = " -> "

@@ -1361,6 +1363,7 @@ showEnv' env t dbg = se 10 env t where

1361 sb env n (Lam t) = showb env "\\ " " => " n t

1363 sb env n (Lam t) = showb env "\\ " " => " n t

1362 sb env n (Hole t) = showb env "? " ". " n t

1364 sb env n (Hole t) = showb env "? " ". " n t

1363 sb env n (GHole i t) = showb env "?defer " ". " n t

1365 sb env n (GHole i t) = showb env "?defer " ". " n t

1366+ sb env n (Pi (Just _) t _) = showb env "{" "} -> " n t

1364 sb env n (Pi _ t _) = showb env "(" ") -> " n t

1367 sb env n (Pi _ t _) = showb env "(" ") -> " n t

1365 sb env n (PVar t) = showb env "pat " ". " n t

1368 sb env n (PVar t) = showb env "pat " ". " n t

1366 sb env n (PVTy t) = showb env "pty " ". " n t

1369 sb env n (PVTy t) = showb env "pty " ". " n t

src/Idris/Core/Unify.hs+3−3

@@ -153,7 +153,7 @@ match_unify ctxt env topx topy inj holes from =

153 h2 <- un bnames vx vy

154 combine bnames h1 h2

155 uB bnames (Lam tx) (Lam ty) = un bnames tx ty

156− uB bnames (Pi _ tx _) (Pi _ ty _) = un bnames tx ty

156+ uB bnames (Pi i tx _) (Pi i' ty _) = un bnames tx ty

157 uB bnames x y = do UI s f <- get

158 let r = recoverable (normalise ctxt env (binderTy x))

159 (normalise ctxt env (binderTy y))

@@ -461,8 +461,8 @@ unify ctxt env topx topy inj holes usersupp from =

461 h2 <- un' False (((x,y),binderTy bx):bnames) sx sy

462 combine bnames h1 h2

463 where sameBinder (Lam _) (Lam _) = True

464− sameBinder (Pi _ _ _) (Pi _ _ _) = True

464+ sameBinder (Pi i _ _) (Pi i' _ _) = True

465− sameBinder _ _ = False

465+ sameBinder _ _ = False -- never unify holes/guesses/etc

466 un' fn bnames x y

467 | OK True <- convEq' ctxt holes x y = do sc 1; return []

468 | isUniverse x && isUniverse y = do sc 1; return []

src/Idris/Coverage.hs+10−11

@@ -18,18 +18,18 @@ import Debug.Trace

19import Control.Monad.State.Strict

21−-- Generate a pattern from an 'impossible' LHS. (Need this to eliminate the

21+-- | Generate a pattern from an 'impossible' LHS.

22+--

23+-- We need this to eliminate the pattern clauses which have been

22−-- pattern clauses which have been provided explicitly from new clause

24+-- provided explicitly from new clause generation.

23−-- generation.)

24−

25mkPatTm :: PTerm -> Idris Term

26mkPatTm t = do i <- getIState

27 let timp = addImpl' True [] [] i t

28 evalStateT (toTT (mapPT deNS timp)) 0

29 where

30 toTT (PRef _ n) = do i <- lift getIState

31− case lookupDef n (tt_ctxt i) of

31+ case lookupNameDef n (tt_ctxt i) of

32− [TyDecl nt _] -> return $ P nt n Erased

32+ [(n', TyDecl nt _)] -> return $ P nt n' Erased

33 _ -> return $ P Ref n Erased

34 toTT (PApp _ t args) = do t' <- toTT t

35 args' <- mapM (toTT . getTm) args

@@ -44,13 +44,12 @@ mkPatTm t = do i <- getIState

44 deNS (PRef f (NS n _)) = PRef f n

45 deNS t = t

47−-- Given a list of LHSs, generate a extra clauses which cover the remaining

47+-- | Given a list of LHSs, generate a extra clauses which cover the remaining

48−-- cases. The ones which haven't been provided are marked 'absurd' so that the

48+-- cases. The ones which haven't been provided are marked 'absurd' so

49−-- checker will make sure they can't happen.

49+-- that the checker will make sure they can't happen.

50−

50+--

51-- This will only work after the given clauses have been typechecked and the

52-- names are fully explicit!

53−

54genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm]

53genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm]

55genClauses fc n xs given

54genClauses fc n xs given

56 = do i <- getIState

55 = do i <- getIState

src/Idris/DSL.hs+2

@@ -76,6 +76,7 @@ expandDo dsl (PDoBlock ds)

76 block b _ = PElabError (Msg "Invalid statement in do block")

78expandDo dsl (PIdiom fc e) = expandDo dsl $ unIdiom (dsl_apply dsl) (dsl_pure dsl) fc e

79+expandDo dsl (PRunTactics fc tm) = PRunTactics fc $ expandDo dsl tm

79expandDo dsl t = t

80expandDo dsl t = t

81-- | Replace DSL-bound variable in a term

82-- | Replace DSL-bound variable in a term

@@ -162,6 +163,7 @@ debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in

162 db' (PDPair fc p l t r) = do l' <- db' l

163 db' (PDPair fc p l t r) = do l' <- db' l

163 r' <- db' r

164 r' <- db' r

164 return (PDPair fc p l' t r')

165 return (PDPair fc p l' t r')

166+ db' (PRunTactics fc t) = fmap (PRunTactics fc) (db' t)

165 db' t = return t

167 db' t = return t

166

168

167 dbArg a = do t' <- db' (getTm a)

169 dbArg a = do t' <- db' (getTm a)

src/Idris/DeepSeq.hs+8−4

@@ -178,13 +178,13 @@ instance (NFData t) => NFData (PClause' t) where

178 rnf (PClause x1 x2 x3 x4 x5 x6)

179 = rnf x1 `seq`

180 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

181− rnf (PWith x1 x2 x3 x4 x5 x6)

181+ rnf (PWith x1 x2 x3 x4 x5 x6 x7)

182 = rnf x1 `seq`

183− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

183+ rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()

184 rnf (PClauseR x1 x2 x3 x4)

185 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

186− rnf (PWithR x1 x2 x3 x4)

186+ rnf (PWithR x1 x2 x3 x4 x5)

187− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

187+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

188

189instance (NFData t) => NFData (PData' t) where

190 rnf (PDatadecl x1 x2 x3)

@@ -202,6 +202,7 @@ instance NFData PTerm where

202 rnf (PLet _ x1 x2 x3 x4)

203 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

204 rnf (PTyped x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

205+ rnf (PAppImpl x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

205 rnf (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

206 rnf (PApp x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

206 rnf (PAppBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

207 rnf (PAppBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

207 rnf (PMatchApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

208 rnf (PMatchApp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

@@ -238,6 +239,7 @@ instance NFData PTerm where

238 rnf (PNoImplicits x1) = rnf x1 `seq` ()

239 rnf (PNoImplicits x1) = rnf x1 `seq` ()

239 rnf (PQuasiquote x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

240 rnf (PQuasiquote x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

240 rnf (PUnquote x1) = rnf x1 `seq` ()

241 rnf (PUnquote x1) = rnf x1 `seq` ()

242+ rnf (PRunTactics x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

241

243

242instance (NFData t) => NFData (PTactic' t) where

244instance (NFData t) => NFData (PTactic' t) where

243 rnf (Intro x1) = rnf x1 `seq` ()

245 rnf (Intro x1) = rnf x1 `seq` ()

@@ -249,6 +251,7 @@ instance (NFData t) => NFData (PTactic' t) where

249 rnf (Induction x1) = rnf x1 `seq` ()

251 rnf (Induction x1) = rnf x1 `seq` ()

250 rnf (CaseTac x1) = rnf x1 `seq` ()

252 rnf (CaseTac x1) = rnf x1 `seq` ()

251 rnf (Equiv x1) = rnf x1 `seq` ()

253 rnf (Equiv x1) = rnf x1 `seq` ()

254+ rnf (Claim x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

252 rnf (MatchRefine x1) = rnf x1 `seq` ()

255 rnf (MatchRefine x1) = rnf x1 `seq` ()

253 rnf (LetTac x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

256 rnf (LetTac x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

254 rnf (LetTacTy x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

257 rnf (LetTacTy x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

@@ -279,6 +282,7 @@ instance (NFData t) => NFData (PTactic' t) where

279 rnf Skip = ()

282 rnf Skip = ()

280 rnf (TFail x1) = rnf x1 `seq` ()

283 rnf (TFail x1) = rnf x1 `seq` ()

281 rnf SourceFC = ()

284 rnf SourceFC = ()

285+ rnf Unfocus = ()

282

286

283instance NFData ErrorReportPart where

287instance NFData ErrorReportPart where

284 rnf (TermPart x1) = rnf x1 `seq` ()

288 rnf (TermPart x1) = rnf x1 `seq` ()

src/Idris/Delaborate.hs+2−2

@@ -308,7 +308,7 @@ pprintErr' i (ElaboratingArg f x _ e)

308 where whatIsName = let ctxt = tt_ctxt i

309 in if isTConName f ctxt

310 then text "type constructor" <> space

311− else if isConName f ctxt

311+ else if isDConName f ctxt

312 then text "constructor" <> space

313 else if isFnName f ctxt

314 then text "function" <> space

@@ -488,7 +488,7 @@ fancifyAnnots ist annot@(AnnName n _ _ _) =

488 _ | isTConName n ctxt -> AnnName n (Just TypeOutput) docs ty

489 _ | isMetavarName n ist -> AnnName n (Just MetavarOutput) docs ty

490 _ | isPostulateName n ist -> AnnName n (Just PostulateOutput) docs ty

491− _ | otherwise -> annot

491+ _ | otherwise -> annot

492 where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs

493 docOverview ist n = do docs <- lookupCtxtExact n (idris_docstrings ist)

494 let o = overview (fst docs)

src/Idris/Elab/Clause.hs+43−25

@@ -648,9 +648,9 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

648 -- Now build the RHS, using the type of the LHS as the goal.

649 i <- getIState -- new implicits from where block

650 logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))

651− let rhs = addImplBoundInf i (map fst newargs) (defs \\ decls)

651+ let rhs = addImplBoundInf i (map fst newargs_all) (defs \\ decls)

652 (expandParams decorate newargs defs (defs \\ decls) rhs_in)

653− logLvl 2 $ "RHS: " ++ showTmImpls rhs

653+ logLvl 2 $ "RHS: " ++ show (map fst newargs_all) ++ " " ++ showTmImpls rhs

654 ctxt <- getContext -- new context with where block added

655 logLvl 5 "STARTING CHECK"

656 ((rhs', defer, is, probs), _) <-

@@ -673,7 +673,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

673 when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_,_) -> (x,y)) probs)

674

675 logLvl 5 "DONE CHECK"

676− logLvl 2 $ "---> " ++ show rhs'

676+ logLvl 4 $ "---> " ++ show rhs'

677 when (not (null defer)) $ iLOG $ "DEFERRED " ++

678 show (map (\ (n, (_,_,t)) -> (n, t)) defer)

679 def' <- checkDef fc defer

@@ -796,7 +796,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in_as withs rhs_in_as wherebloc

796 isArg' _ = False

797 isArg _ _ = False

798

799−elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

799+elabClause info opts (_, PWith fc fname lhs_in withs wval_in pn_in withblock)

800 = do let tcgen = Dictionary `elem` opts

801 ctxt <- getContext

802 -- Build the LHS as an "Infer", and pull out its type and

@@ -859,6 +859,11 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

859 -- rather than a de Bruijn index.

860 let pdeps = usedNamesIn pvars i (delab i cwvalty)

861 let (bargs_pre, bargs_post) = split pdeps bargs []

862+

863+ let mpn = case pn_in of

864+ Nothing -> Nothing

865+ Just n -> Just (uniqueName n (map fst bargs))

866+

862 logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

867 logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

863 " depends on " ++ show pdeps ++ " from " ++ show pvars)

868 " depends on " ++ show pdeps ++ " from " ++ show pvars)

864 logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)

869 logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)

@@ -867,12 +872,19 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

867 -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty

872 -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty

868 let wargval = getRetTy cwvalN

873 let wargval = getRetTy cwvalN

869 let wargtype = getRetTy cwvaltyN

874 let wargtype = getRetTy cwvaltyN

875+ let wargname = sMN windex "warg"

876+

870 logLvl 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)

877 logLvl 5 ("Abstract over " ++ show wargval ++ " in " ++ show wargtype)

871 let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar 0))) (bargs_pre ++

878 let wtype = bindTyArgs (flip (Pi Nothing) (TType (UVar 0))) (bargs_pre ++

872− (sMN 0 "warg", wargtype) :

879+ (wargname, wargtype) :

873− map (abstract (sMN 0 "warg") wargval wargtype) bargs_post)

880+ map (abstract wargname wargval wargtype) bargs_post ++

881+ case mpn of

882+ Just pn -> [(pn, mkApp (P Ref eqTy Erased)

883+ [wargtype, wargtype,

884+ P Bound wargname Erased, wargval])]

885+ Nothing -> [])

874− (substTerm wargval (P Bound (sMN 0 "warg") wargtype) ret_ty)

886+ (substTerm wargval (P Bound wargname wargtype) ret_ty)

875− logLvl 5 ("New function type " ++ show wtype)

887+ logLvl 3 ("New function type " ++ show wtype)

876 let wname = SN (WithN windex fname)

888 let wname = SN (WithN windex fname)

877

889

878 let imps = getImps wtype -- add to implicits context

890 let imps = getImps wtype -- add to implicits context

@@ -893,18 +905,21 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

893 -- in the subdecls, lhs becomes:

905 -- in the subdecls, lhs becomes:

894 -- fname pats | wpat [rest]

906 -- fname pats | wpat [rest]

895 -- ==> fname' ps wpat [rest], match pats against toplevel for ps

907 -- ==> fname' ps wpat [rest], match pats against toplevel for ps

896− wb <- mapM (mkAuxC wname lhs (map fst bargs_pre) (map fst bargs_post))

908+ wb <- mapM (mkAuxC mpn wname lhs (map fst bargs_pre) (map fst bargs_post))

897 withblock

909 withblock

898 logLvl 3 ("with block " ++ show wb)

910 logLvl 3 ("with block " ++ show wb)

899 -- propagate totality assertion to the new definitions

911 -- propagate totality assertion to the new definitions

900 when (AssertTotal `elem` opts) $ setFlags wname [AssertTotal]

912 when (AssertTotal `elem` opts) $ setFlags wname [AssertTotal]

901 mapM_ (rec_elabDecl info EAll info) wb

913 mapM_ (rec_elabDecl info EAll info) wb

902

914

903− -- rhs becomes: fname' ps wval

915+ -- rhs becomes: fname' ps_pre wval ps_post Refl

904 let rhs = PApp fc (PRef fc wname)

916 let rhs = PApp fc (PRef fc wname)

905 (map (pexp . (PRef fc) . fst) bargs_pre ++

917 (map (pexp . (PRef fc) . fst) bargs_pre ++

906 pexp wval :

918 pexp wval :

907− (map (pexp . (PRef fc) . fst) bargs_post))

919+ (map (pexp . (PRef fc) . fst) bargs_post) ++

920+ case mpn of

921+ Nothing -> []

922+ Just _ -> [pexp (PRefl fc Placeholder)])

908 logLvl 5 ("New RHS " ++ showTmImpls rhs)

923 logLvl 5 ("New RHS " ++ showTmImpls rhs)

909 ctxt <- getContext -- New context with block added

924 ctxt <- getContext -- New context with block added

910 i <- getIState

925 i <- getIState

@@ -927,13 +942,13 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

927 getImps (Bind n (Pi _ _ _) t) = pexp Placeholder : getImps t

942 getImps (Bind n (Pi _ _ _) t) = pexp Placeholder : getImps t

928 getImps _ = []

943 getImps _ = []

929

944

930− mkAuxC wname lhs ns ns' (PClauses fc o n cs)

945+ mkAuxC pn wname lhs ns ns' (PClauses fc o n cs)

931− | True = do cs' <- mapM (mkAux wname lhs ns ns') cs

946+ | True = do cs' <- mapM (mkAux pn wname lhs ns ns') cs

932 return $ PClauses fc o wname cs'

947 return $ PClauses fc o wname cs'

933 | otherwise = ifail $ show fc ++ "with clause uses wrong function name " ++ show n

948 | otherwise = ifail $ show fc ++ "with clause uses wrong function name " ++ show n

934− mkAuxC wname lhs ns ns' d = return $ d

949+ mkAuxC pn wname lhs ns ns' d = return $ d

935

950

936− mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)

951+ mkAux pn wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)

937 = do i <- getIState

952 = do i <- getIState

938 let tm = addImplPat i tm_in

953 let tm = addImplPat i tm_in

939 logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++

954 logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++

@@ -942,33 +957,36 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

942 Left (a,b) -> ifail $ show fc ++ ":with clause does not match top level"

957 Left (a,b) -> ifail $ show fc ++ ":with clause does not match top level"

943 Right mvars ->

958 Right mvars ->

944 do logLvl 3 ("Match vars : " ++ show mvars)

959 do logLvl 3 ("Match vars : " ++ show mvars)

945− lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

960+ lhs <- updateLHS n pn wname mvars ns ns' (fullApp tm) w

946 return $ PClause fc wname lhs ws rhs wheres

961 return $ PClause fc wname lhs ws rhs wheres

947− mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs)

962+ mkAux pn wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval pn' withs)

948 = do i <- getIState

963 = do i <- getIState

949 let tm = addImplPat i tm_in

964 let tm = addImplPat i tm_in

950 logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++

965 logLvl 2 ("Matching " ++ showTmImpls tm ++ " against " ++

951 showTmImpls toplhs)

966 showTmImpls toplhs)

952− withs' <- mapM (mkAuxC wname toplhs ns ns') withs

967+ withs' <- mapM (mkAuxC pn wname toplhs ns ns') withs

953 case matchClause i toplhs tm of

968 case matchClause i toplhs tm of

954 Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ "with clause does not match top level")

969 Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ "with clause does not match top level")

955 Right mvars ->

970 Right mvars ->

956− do lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

971+ do lhs <- updateLHS n pn wname mvars ns ns' (fullApp tm) w

957− return $ PWith fc wname lhs ws wval withs'

972+ return $ PWith fc wname lhs ws wval pn' withs'

958− mkAux wname toplhs ns ns' c

973+ mkAux pn wname toplhs ns ns' c

959 = ifail $ show fc ++ ":badly formed with clause"

974 = ifail $ show fc ++ ":badly formed with clause"

960

975

961 addArg (PApp fc f args) w = PApp fc f (args ++ [pexp w])

976 addArg (PApp fc f args) w = PApp fc f (args ++ [pexp w])

962 addArg (PRef fc f) w = PApp fc (PRef fc f) [pexp w]

977 addArg (PRef fc f) w = PApp fc (PRef fc f) [pexp w]

963

978

964− updateLHS n wname mvars ns_in ns_in' (PApp fc (PRef fc' n') args) w

979+ updateLHS n pn wname mvars ns_in ns_in' (PApp fc (PRef fc' n') args) w

965 = let ns = map (keepMvar (map fst mvars) fc') ns_in

980 = let ns = map (keepMvar (map fst mvars) fc') ns_in

966 ns' = map (keepMvar (map fst mvars) fc') ns_in' in

981 ns' = map (keepMvar (map fst mvars) fc') ns_in' in

967 return $ substMatches mvars $

982 return $ substMatches mvars $

968 PApp fc (PRef fc' wname)

983 PApp fc (PRef fc' wname)

969− (map pexp ns ++ pexp w : (map pexp ns'))

984+ (map pexp ns ++ pexp w : (map pexp ns') ++

985+ case pn of

986+ Nothing -> []

987+ Just pnm -> [pexp (PRef fc pnm)])

970− updateLHS n wname mvars ns_in ns_in' tm w

988+ updateLHS n pn wname mvars ns_in ns_in' tm w

971− = updateLHS n wname mvars ns_in ns_in' (PApp fc tm []) w

989+ = updateLHS n pn wname mvars ns_in ns_in' (PApp fc tm []) w

972

990

973 keepMvar mvs fc v | v `elem` mvs = PRef fc v

991 keepMvar mvs fc v | v `elem` mvs = PRef fc v

974 | otherwise = Placeholder

992 | otherwise = Placeholder

src/Idris/Elab/Data.hs+4−2

@@ -316,11 +316,13 @@ elabCaseFun ind paramPos n ty cons info = do

316 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

317 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

318 elimLog $ "-- case function definition: " ++ (show . showDeclImp verbosePPOption) eliminatorDef

319− State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorTyDecl) (\err -> return ())

319+ State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorTyDecl)

320+ (ierror . Elaborating "type declaration of " elimDeclName)

320 -- Do not elaborate clauses if there aren't any

321 -- Do not elaborate clauses if there aren't any

321 case eliminatorClauses of

322 case eliminatorClauses of

322 [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type

323 [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type

323− _ -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef) (\err -> return ())

324+ _ -> State.lift $ idrisCatch (rec_elabDecl info EAll info eliminatorDef)

325+ (ierror . Elaborating "clauses of " elimDeclName)

324 where elimLog :: String -> EliminatorState ()

326 where elimLog :: String -> EliminatorState ()

325 elimLog s = State.lift (logLvl 2 s)

327 elimLog s = State.lift (logLvl 2 s)

326

328

src/Idris/Elab/Provider.hs+16−10

@@ -74,9 +74,9 @@ elabProvider info syn fc what n

74 (e, et) <- case what of

75 ProvTerm _ tm -> elabVal info ERHS tm

76 ProvPostulate tm -> elabVal info ERHS tm

77− unless (isProviderOf (normalise ctxt [] ty') et) $

77+ unless (isProviderOf ctxt ty' et) $

78− ifail $ "Expected provider type IO (Provider (" ++

78+ ifail $ "Expected provider type " ++ show (providerOf ty') ++

79− show ty' ++ "))" ++ ", got " ++ show et ++ " instead."

79+ ", got " ++ show et ++ " instead."

81 -- Execute the type provider and normalise the result

82 -- use 'run__provider' to convert to a primitive IO action

@@ -107,11 +107,17 @@ elabProvider info syn fc what n

107 isTType (TType _) = True

108 isTType _ = False

109

110+ -- Note: IO (Providers.Provider ty) is used instead of IO'

111+ -- (MkFFI C_FFI) (Providers.Provider ty) in hopes of better

112+ -- error messages with less normalisation

113+ providerOf :: Type -> Type

114+ providerOf ty = App (P Ref (sUN "IO") Erased) $

115+ App (P Ref (sNS (sUN "Provider") ["Providers"]) Erased)

116+ ty

117+

110− isProviderOf :: TT Name -> TT Name -> Bool

118+ isProviderOf :: Context -> TT Name -> TT Name -> Bool

111− isProviderOf tp prov

119+ isProviderOf ctxt tp prov =

112− | (P _ (UN io) _, [prov']) <- unApply prov

120+ case converts ctxt [] (providerOf tp) prov of

113− , (P _ (NS (UN prov) [provs]) _, [tp']) <- unApply prov'

121+ OK _ -> True

114− , tp == tp', io == txt "IO"

115− , prov == txt "Provider" && provs == txt "Providers" = True

116− isProviderOf _ _ = False

122+ _ -> False

117

123

src/Idris/Elab/Utils.hs+2−2

@@ -120,8 +120,8 @@ decorateid decorate (PTy doc argdocs s f o n t) = PTy doc argdocs s f o (decorat

120decorateid decorate (PClauses f o n cs)

121 = PClauses f o (decorate n) (map dc cs)

122 where dc (PClause fc n t as w ds) = PClause fc (decorate n) (dappname t) as w ds

123− dc (PWith fc n t as w ds)

123+ dc (PWith fc n t as w pn ds)

124− = PWith fc (decorate n) (dappname t) as w

124+ = PWith fc (decorate n) (dappname t) as w pn

125 (map (decorateid decorate) ds)

126 dappname (PApp fc (PRef fc' n) as) = PApp fc (PRef fc' (decorate n)) as

127 dappname t = t

src/Idris/ElabQuasiquote.hs+3

@@ -36,6 +36,7 @@ extractTUnquotes n (GoalType s tac)

36 return (GoalType s tac', ex)

37extractTUnquotes n (TCheck t) = extract1 n TCheck t

38extractTUnquotes n (TEval t) = extract1 n TEval t

39+extractTUnquotes n (Claim name t) = extract1 n (Claim name) t

39extractTUnquotes n tac = return (tac, []) -- the rest don't contain PTerms

40extractTUnquotes n tac = return (tac, []) -- the rest don't contain PTerms

41extractPArgUnquotes :: Int -> PArg -> Elab' aux (PArg, [(Name, PTerm)])

42extractPArgUnquotes :: Int -> PArg -> Elab' aux (PArg, [(Name, PTerm)])

@@ -169,6 +170,8 @@ extractUnquotes n (PUnquote tm)

169 return (PRef (fileFC "(unquote)") n, [(n, tm)])

170 return (PRef (fileFC "(unquote)") n, [(n, tm)])

170 | otherwise = fmap (\(tm', ex) -> (PUnquote tm', ex)) $

171 | otherwise = fmap (\(tm', ex) -> (PUnquote tm', ex)) $

171 extractUnquotes (n-1) tm

172 extractUnquotes (n-1) tm

173+extractUnquotes n (PRunTactics fc tm)

174+ = fmap (\(tm', ex) -> (PRunTactics fc tm', ex)) $ extractUnquotes n tm

172extractUnquotes n x = return (x, []) -- no subterms!

175extractUnquotes n x = return (x, []) -- no subterms!

173

176

174

177

src/Idris/ElabTerm.hs+493−174

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

1−{-# LANGUAGE PatternGuards #-}

1+{-# LANGUAGE PatternGuards, ViewPatterns #-}

2−

2+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3module Idris.ElabTerm where

5import Idris.AbsSyntax

@@ -164,13 +164,14 @@ getUnmatchable ctxt n | isDConName n ctxt && n /= inferCon

164getUnmatchable ctxt n = []

165

166data ElabCtxt = ElabCtxt { e_inarg :: Bool,

167+ e_isfn :: Bool, -- ^ Function part of application

167 e_guarded :: Bool,

168 e_guarded :: Bool,

168 e_intype :: Bool,

169 e_intype :: Bool,

169 e_qq :: Bool,

170 e_qq :: Bool,

170 e_nomatching :: Bool -- ^ can't pattern match

171 e_nomatching :: Bool -- ^ can't pattern match

171 }

172 }

172

173

173−initElabCtxt = ElabCtxt False False False False False

174+initElabCtxt = ElabCtxt False False False False False False

174

175

175goal_polymorphic :: ElabD Bool

176goal_polymorphic :: ElabD Bool

176goal_polymorphic =

177goal_polymorphic =

@@ -244,7 +245,7 @@ elab ist info emode opts fn tm

244 then solveAuto ist fn False a

245 then solveAuto ist fn False a

245 else return ()) as

246 else return ()) as

246

247

247− itm <- if not pattern then insertImpLam t else return t

248+ itm <- if not pattern then insertImpLam ina t else return t

248 ct <- insertCoerce ina itm

249 ct <- insertCoerce ina itm

249 t' <- insertLazy ct

250 t' <- insertLazy ct

250 g <- goal

251 g <- goal

@@ -308,7 +309,7 @@ elab ist info emode opts fn tm

308 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

309 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

309 && isTypeConst c

310 && isTypeConst c

310 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

311 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

311− | pattern && not reflection && e_nomatching ina

312+ | pattern && not reflection && not (e_qq ina) && e_nomatching ina

312 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

313 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

313 | otherwise = do apply (RConstant c) []; solve

314 | otherwise = do apply (RConstant c) []; solve

314 elab' ina fc (PQuote r) = do fill r; solve

315 elab' ina fc (PQuote r) = do fill r; solve

@@ -317,6 +318,7 @@ elab ist info emode opts fn tm

317 g <- goal

318 g <- goal

318 case g of

319 case g of

319 TType _ -> elab' ina (Just fc) (PRef fc unitTy)

320 TType _ -> elab' ina (Just fc) (PRef fc unitTy)

321+ UType _ -> elab' ina (Just fc) (PRef fc unitTy)

320 _ -> elab' ina (Just fc) (PRef fc unitCon)

322 _ -> elab' ina (Just fc) (PRef fc unitCon)

321 elab' ina fc (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

323 elab' ina fc (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

322 = do g <- goal; resolveTC False 5 g fn ist

324 = do g <- goal; resolveTC False 5 g fn ist

@@ -352,13 +354,32 @@ elab ist info emode opts fn tm

352 elab' ina _ (PPair fc _ l r)

354 elab' ina _ (PPair fc _ l r)

353 = do hnf_compute

355 = do hnf_compute

354 g <- goal

356 g <- goal

357+ let (tc, _) = unApply g

355 case g of

358 case g of

356 TType _ -> elab' ina (Just fc) (PApp fc (PRef fc pairTy)

359 TType _ -> elab' ina (Just fc) (PApp fc (PRef fc pairTy)

357 [pexp l,pexp r])

360 [pexp l,pexp r])

361+ UType _ -> elab' ina (Just fc) (PApp fc (PRef fc upairTy)

362+ [pexp l,pexp r])

363+ _ -> case tc of

364+ P _ n _ | n == upairTy

365+ -> elab' ina (Just fc) (PApp fc (PRef fc upairCon)

366+ [pimp (sUN "A") Placeholder False,

367+ pimp (sUN "B") Placeholder False,

368+ pexp l, pexp r])

358− _ -> elab' ina (Just fc) (PApp fc (PRef fc pairCon)

369+ _ -> elab' ina (Just fc) (PApp fc (PRef fc pairCon)

359 [pimp (sUN "A") Placeholder False,

370 [pimp (sUN "A") Placeholder False,

360 pimp (sUN "B") Placeholder False,

371 pimp (sUN "B") Placeholder False,

361 pexp l, pexp r])

372 pexp l, pexp r])

373+-- _ -> try' (elab' ina (Just fc) (PApp fc (PRef fc pairCon)

374+-- [pimp (sUN "A") Placeholder False,

375+-- pimp (sUN "B") Placeholder False,

376+-- pexp l, pexp r]))

377+-- (elab' ina (Just fc) (PApp fc (PRef fc upairCon)

378+-- [pimp (sUN "A") Placeholder False,

379+-- pimp (sUN "B") Placeholder False,

380+-- pexp l, pexp r]))

381+-- True

382+

362 elab' ina _ (PDPair fc p l@(PRef _ n) t r)

383 elab' ina _ (PDPair fc p l@(PRef _ n) t r)

363 = case t of

384 = case t of

364 Placeholder ->

385 Placeholder ->

@@ -399,6 +420,7 @@ elab ist info emode opts fn tm

399 where -- if none work, take the error from the first

420 where -- if none work, take the error from the first

400 trySeq (x : xs) = let e1 = elab' ina fc x in

421 trySeq (x : xs) = let e1 = elab' ina fc x in

401 try' e1 (trySeq' e1 xs) True

422 try' e1 (trySeq' e1 xs) True

423+ trySeq [] = fail "Nothing to try in sequence"

402 trySeq' deferr [] = proofFail deferr

424 trySeq' deferr [] = proofFail deferr

403 trySeq' deferr (x : xs)

425 trySeq' deferr (x : xs)

404 = try' (do elab' ina fc x

426 = try' (do elab' ina fc x

@@ -411,7 +433,7 @@ elab ist info emode opts fn tm

411 | pattern && not reflection && not (e_qq ec) && not (e_intype ec)

433 | pattern && not reflection && not (e_qq ec) && not (e_intype ec)

412 && isTConName n (tt_ctxt ist)

434 && isTConName n (tt_ctxt ist)

413 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

435 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

414− | pattern && not reflection && e_nomatching ec

436+ | pattern && not reflection && not (e_qq ec) && e_nomatching ec

415 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

437 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

416 | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not (e_qq ec)

438 | (pattern || (bindfree && bindable n)) && not (inparamBlock n) && not (e_qq ec)

417 = do let ina = e_inarg ec

439 = do let ina = e_inarg ec

@@ -439,7 +461,7 @@ elab ist info emode opts fn tm

439 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

461 | pattern && not reflection && not (e_qq ina) && not (e_intype ina)

440 && isTConName n (tt_ctxt ist)

462 && isTConName n (tt_ctxt ist)

441 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

463 = lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

442− | pattern && not reflection && e_nomatching ina

464+ | pattern && not reflection && not (e_qq ina) && e_nomatching ina

443 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

465 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

444 | otherwise =

466 | otherwise =

445 do fty <- get_type (Var n) -- check for implicits

467 do fty <- get_type (Var n) -- check for implicits

@@ -525,7 +547,8 @@ elab ist info emode opts fn tm

525 -- HACK: If the name leaks into its type, it may leak out of

547 -- HACK: If the name leaks into its type, it may leak out of

526 -- scope outside, so substitute in the outer scope.

548 -- scope outside, so substitute in the outer scope.

527 expandLet n (case lookup n env of

549 expandLet n (case lookup n env of

528− Just (Let t v) -> v)

550+ Just (Let t v) -> v

551+ other -> error ("Value not a let binding: " ++ show other))

529 solve

552 solve

530 elab' ina _ (PGoal fc r n sc) = do

553 elab' ina _ (PGoal fc r n sc) = do

531 rty <- goal

554 rty <- goal

@@ -596,17 +619,13 @@ elab ist info emode opts fn tm

596 _ -> lift $ tfail (NoSuchVariable fn)

619 _ -> lift $ tfail (NoSuchVariable fn)

597 ns <- match_apply (Var fn') (map (\x -> (x,0)) imps)

620 ns <- match_apply (Var fn') (map (\x -> (x,0)) imps)

598 solve

621 solve

599− -- This isn't a sound way of checking for Typecase - we need a

600− -- better way!

601−-- elab' (_, _, inty, qq) (PApp fc (PRef _ f) args')

602−-- | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty && not qq

603−-- = lift $ tfail (Msg "Typecase is not allowed")

604 -- if f is local, just do a simple_app

622 -- if f is local, just do a simple_app

623+ -- FIXME: Anyone feel like refactoring this mess? - EB

605− elab' ina _ tm@(PApp fc (PRef _ f) args_in)

624+ elab' ina topfc tm@(PApp fc (PRef _ f) args_in)

606− | pattern && not reflection && e_nomatching ina

625+ | pattern && not reflection && not (e_qq ina) && e_nomatching ina

607 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

626 = lift $ tfail $ Msg ("Attempting concrete match on polymorphic argument: " ++ show tm)

608− | otherwise

627+ | otherwise = implicitApp $

609− = do env <- get_env

628+ do env <- get_env

610 ty <- goal

629 ty <- goal

611 fty <- get_type (Var f)

630 fty <- get_type (Var f)

612 ctxt <- get_context

631 ctxt <- get_context

@@ -614,18 +633,18 @@ elab ist info emode opts fn tm

614 let unmatchableArgs = if pattern

633 let unmatchableArgs = if pattern

615 then getUnmatchable (tt_ctxt ist) f

634 then getUnmatchable (tt_ctxt ist) f

616 else []

635 else []

617− -- Dot it if we're in a pattern and it isn't a constructor

636+-- trace ("BEFORE " ++ show f ++ ": " ++ show ty) $

618−-- when (pattern && not (isDConName f ctxt) && f /= fn) $ dotterm

619−

620 when (pattern && not reflection && not (e_qq ina) && not (e_intype ina)

637 when (pattern && not reflection && not (e_qq ina) && not (e_intype ina)

621 && isTConName f (tt_ctxt ist)) $

638 && isTConName f (tt_ctxt ist)) $

622 lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

639 lift $ tfail $ Msg ("No explicit types on left hand side: " ++ show tm)

623 if (f `elem` map fst env && length args == 1 && length args_in == 1)

640 if (f `elem` map fst env && length args == 1 && length args_in == 1)

624 then -- simple app, as below

641 then -- simple app, as below

625− do simple_app False (elabE ina (Just fc) (PRef fc f))

642+ do simple_app False

643+ (elabE (ina { e_isfn = True }) (Just fc) (PRef fc f))

626 (elabE (ina { e_inarg = True }) (Just fc) (getTm (head args)))

644 (elabE (ina { e_inarg = True }) (Just fc) (getTm (head args)))

627 (show tm)

645 (show tm)

628 solve

646 solve

647+ return []

629 else

648 else

630 do ivs <- get_instances

649 do ivs <- get_instances

631 ps <- get_probs

650 ps <- get_probs

@@ -656,22 +675,58 @@ elab ist info emode opts fn tm

656 (zip ns' (unmatchableArgs ++ repeat False))

675 (zip ns' (unmatchableArgs ++ repeat False))

657 (f == sUN "Force")

676 (f == sUN "Force")

658 (map (\x -> getTm x) eargs) -- TODO: remove this False arg

677 (map (\x -> getTm x) eargs) -- TODO: remove this False arg

678+ imp <- if (e_isfn ina) then

679+ do guess <- get_guess

680+ gty <- get_type (forget guess)

681+ env <- get_env

682+ let ty_n = normalise ctxt env gty

683+ return $ getReqImps ty_n

684+ else return []

685+ -- Now we find out how many implicits we needed at the

686+ -- end of the application by looking at the goal again

687+ -- - Have another go, but this time add the

688+ -- implicits (can't think of a better way than this...)

689+ case imp of

690+ rs@(_:_) | not pattern -> return rs -- quit, try again

659− solve

691+ _ -> do solve

692+ hs <- get_holes

660− ivs' <- get_instances

693+ ivs' <- get_instances

661− -- Attempt to resolve any type classes which have 'complete' types,

694+ -- Attempt to resolve any type classes which have 'complete' types,

662− -- i.e. no holes in them

695+ -- i.e. no holes in them

663− when (not pattern || (e_inarg ina && not tcgen &&

696+ when (not pattern || (e_inarg ina && not tcgen &&

664− not (e_guarded ina))) $

697+ not (e_guarded ina))) $

665− mapM_ (\n -> do focus n

698+ mapM_ (\n -> do focus n

666− g <- goal

699+ g <- goal

667− env <- get_env

700+ env <- get_env

668− hs <- get_holes

701+ hs <- get_holes

669− if all (\n -> not (n `elem` hs)) (freeNames g)

702+ if all (\n -> not (n `elem` hs)) (freeNames g)

670− then try (resolveTC False 7 g fn ist)

703+ then try (resolveTC False 7 g fn ist)

671− (movelast n)

704+ (movelast n)

672− else movelast n)

705+ else movelast n)

673− (ivs' \\ ivs)

706+ (ivs' \\ ivs)

707+ return []

708+ where

709+ -- Run the elaborator, which returns how many implicit

710+ -- args were needed, then run it again with those args. We need

711+ -- this because we have to elaborate the whole application to

712+ -- find out whether any computations have caused more implicits

713+ -- to be needed.

714+ implicitApp :: ElabD [ImplicitInfo] -> ElabD ()

715+ implicitApp elab

716+ | pattern = do elab; return ()

717+ | otherwise

718+ = do s <- get

719+ imps <- elab

720+ case imps of

721+ [] -> return ()

722+ es -> do put s

723+ elab' ina topfc (PAppImpl tm es)

724+

725+ getReqImps (Bind x (Pi (Just i) ty _) sc)

726+ = i : getReqImps sc

727+ getReqImps _ = []

728+

674− where -- normal < alternatives < lambdas < rewrites < tactic < default tactic

729+ -- normal < alternatives < lambdas < rewrites < tactic < default tactic

675 -- reason for lambdas after alternatives is that having

730 -- reason for lambdas after alternatives is that having

676 -- the alternative resolved can help with typechecking the lambda

731 -- the alternative resolved can help with typechecking the lambda

677 -- or the rewrite. Rewrites/tactics need as much information

732 -- or the rewrite. Rewrites/tactics need as much information

@@ -744,15 +799,24 @@ elab ist info emode opts fn tm

744 setInjective (PApp _ (PRef _ n) _) = setinj n

799 setInjective (PApp _ (PRef _ n) _) = setinj n

745 setInjective _ = return ()

800 setInjective _ = return ()

746

801

747− elab' ina _ tm@(PApp fc f [arg])

802+ elab' ina _ tm@(PApp fc f [arg]) =

748− = erun fc $

803+ erun fc $

749 do simple_app (not $ headRef f)

804 do simple_app (not $ headRef f)

805+ (elabE (ina { e_isfn = True }) (Just fc) f)

750− (elabE ina (Just fc) f) (elabE (ina { e_inarg = True }) (Just fc) (getTm arg))

806+ (elabE (ina { e_inarg = True }) (Just fc) (getTm arg))

751 (show tm)

807 (show tm)

752 solve

808 solve

753 where headRef (PRef _ _) = True

809 where headRef (PRef _ _) = True

754 headRef (PApp _ f _) = headRef f

810 headRef (PApp _ f _) = headRef f

755 headRef _ = False

811 headRef _ = False

812+

813+ elab' ina fc (PAppImpl f es) = do appImpl (reverse es) -- not that we look...

814+ solve

815+ where appImpl [] = elab' (ina { e_isfn = False }) fc f -- e_isfn not set, so no recursive expansion of implicits

816+ appImpl (e : es) = simple_app False

817+ (appImpl es)

818+ (elab' ina fc Placeholder)

819+ (show f)

756 elab' ina fc Placeholder

820 elab' ina fc Placeholder

757 = do (h : hs) <- get_holes

821 = do (h : hs) <- get_holes

758 movelast h

822 movelast h

@@ -826,9 +890,21 @@ elab ist info emode opts fn tm

826 envU <- mapM (getKind args) args

890 envU <- mapM (getKind args) args

827 let namesUsedInRHS = nub $ scvn : concatMap (\(_,rhs) -> allNamesIn rhs) opts

891 let namesUsedInRHS = nub $ scvn : concatMap (\(_,rhs) -> allNamesIn rhs) opts

828

892

829− -- Drop the unique arguments used in the scrutinee (since it's

893+ -- Drop the unique arguments used in the term already

894+ -- and in the scrutinee (since it's

830− -- not valid to use them again anyway)

895+ -- not valid to use them again anyway)

896+ --

897+ -- Also drop unique arguments which don't appear explicitly

898+ -- in either case branch so they don't count as used

899+ -- unnecessarily (can only do this for unique things, since we

900+ -- assume they don't appear implicitly in types)

901+ ptm <- get_term

902+ let inOpts = (filter (/= scvn) (map fst args)) \\ (concatMap (\x -> allNamesIn (snd x)) opts)

903+

831− let argsDropped = filter (isUnique envU) (nub $ allNamesIn scr)

904+ let argsDropped = filter (isUnique envU)

905+ (nub $ allNamesIn scr ++ inApp ptm ++

906+ inOpts)

907+

832 let args' = filter (\(n, _) -> n `notElem` argsDropped) args

908 let args' = filter (\(n, _) -> n `notElem` argsDropped) args

833

909

834 cname <- unique_hole' True (mkCaseName fn)

910 cname <- unique_hole' True (mkCaseName fn)

@@ -855,6 +931,13 @@ elab ist info emode opts fn tm

855 Just xs@(_:_) -> sNS n xs

931 Just xs@(_:_) -> sNS n xs

856 _ -> n

932 _ -> n

857

933

934+ inApp (P _ n _) = [n]

935+ inApp (App f a) = inApp f ++ inApp a

936+ inApp (Bind n (Let _ v) sc) = inApp v ++ inApp sc

937+ inApp (Bind n (Guess _ v) sc) = inApp v ++ inApp sc

938+ inApp (Bind n b sc) = inApp sc

939+ inApp _ = []

940+

858 isUnique envk n = case lookup n envk of

941 isUnique envk n = case lookup n envk of

859 Just u -> u

942 Just u -> u

860 _ -> False

943 _ -> False

@@ -882,13 +965,16 @@ elab ist info emode opts fn tm

882 elab' ina fc (PUnifyLog t) = do unifyLog True

965 elab' ina fc (PUnifyLog t) = do unifyLog True

883 elab' ina fc t

966 elab' ina fc t

884 unifyLog False

967 unifyLog False

885− elab' ina fc (PQuasiquote t goal) -- TODO: goal type

968+ elab' ina fc (PQuasiquote t goal)

886 = do -- First extract the unquoted subterms, replacing them with fresh

969 = do -- First extract the unquoted subterms, replacing them with fresh

887 -- names in the quasiquoted term. Claim their reflections to be

970 -- names in the quasiquoted term. Claim their reflections to be

888− -- of type TT.

971+ -- an inferred type (to support polytypic quasiquotes).

889 (t, unq) <- extractUnquotes 0 t

972 (t, unq) <- extractUnquotes 0 t

890 let unquoteNames = map fst unq

973 let unquoteNames = map fst unq

974+ mapM_ (\uqn -> do uqh <- getNameFrom (sMN 0 "uqh")

975+ claim uqh RType

976+ movelast uqh

891− mapM_ (flip claim (Var tt)) unquoteNames

977+ claim uqn (Var uqh)) unquoteNames

892

978

893

979

894 -- Save the old state - we need a fresh proof state to avoid

980 -- Save the old state - we need a fresh proof state to avoid

@@ -897,7 +983,7 @@ elab ist info emode opts fn tm

897 saveState

983 saveState

898 updatePS (const .

984 updatePS (const .

899 newProof (sMN 0 "q") ctxt $

985 newProof (sMN 0 "q") ctxt $

900− P Ref tt Erased)

986+ P Ref (reflm "TT") Erased)

901

987

902 -- Re-add the unquotes, letting Idris infer the (fictional)

988 -- Re-add the unquotes, letting Idris infer the (fictional)

903 -- types. Here, they represent the real type rather than the type

989 -- types. Here, they represent the real type rather than the type

@@ -944,18 +1030,22 @@ elab ist info emode opts fn tm

944 Just q -> do ctxt <- get_context

1030 Just q -> do ctxt <- get_context

945 (q', _, _) <- lift $ recheck ctxt [(uq, Lam Erased) | uq <- unquoteNames] (forget q) q

1031 (q', _, _) <- lift $ recheck ctxt [(uq, Lam Erased) | uq <- unquoteNames] (forget q) q

946 if pattern

1032 if pattern

947− then reflectQuotePattern unquoteNames q'

1033+ then do try' (reflectTTQuotePattern unquoteNames q')

1034+ (reflectRawQuotePattern unquoteNames (forget q'))

1035+ True

1036+ else do try' (fill $ reflectTTQuote unquoteNames q')

1037+ -- we forget q' instead of using q to ensure rechecking

948− else do fill $ reflectQuote unquoteNames q'

1038+ (fill $ reflectRawQuote unquoteNames (forget q'))

1039+ True -- ignore errors like proof search does

949 solve

1040 solve

1041+

950 Nothing -> lift . tfail . Msg $ "Broken elaboration of quasiquote"

1042 Nothing -> lift . tfail . Msg $ "Broken elaboration of quasiquote"

951

1043

952 -- Finally fill in the terms or patterns from the unquotes. This

1044 -- Finally fill in the terms or patterns from the unquotes. This

953 -- happens last so that their holes still exist while elaborating

1045 -- happens last so that their holes still exist while elaborating

954 -- the main quotation.

1046 -- the main quotation.

955 mapM_ elabUnquote unq

1047 mapM_ elabUnquote unq

956− where tt = sNS (sUN "TT") ["Reflection", "Language"]

957−

958− elabUnquote (n, tm)

1048+ where elabUnquote (n, tm)

959 = do focus n

1049 = do focus n

960 elabE (ina { e_qq = False }) fc tm

1050 elabE (ina { e_qq = False }) fc tm

961

1051

@@ -976,6 +1066,20 @@ elab ist info emode opts fn tm

976 delayElab $ do focus h

1066 delayElab $ do focus h

977 dotterm

1067 dotterm

978 elab' ina fc t

1068 elab' ina fc t

1069+ elab' ina _ (PRunTactics fc tm) =

1070+ do attack

1071+ n <- getNameFrom (sMN 0 "tacticScript")

1072+ n' <- getNameFrom (sMN 0 "tacticExpr")

1073+ let scriptTy = RApp (Var (sNS (sUN "Tactical") ["Tactical", "Reflection", "Language"])) (Var unitTy)

1074+ claim n scriptTy

1075+ movelast n

1076+ letbind n' scriptTy (Var n)

1077+ focus n

1078+ elab' ina (Just fc) tm

1079+ env <- get_env

1080+ ctxt <- get_context

1081+ runTactical fc ctxt env (P Bound n' Erased)

1082+ solve

979 elab' ina fc x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x

1083 elab' ina fc x = fail $ "Unelaboratable syntactic form " ++ showTmImpls x

980

1084

981 delayElab t = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [t] })

1085 delayElab t = updateAux (\e -> e { delayed_elab = delayed_elab e ++ [t] })

@@ -999,6 +1103,7 @@ elab ist info emode opts fn tm

999 findScr [(n, (_, t))] = [(n, (True, t))]

1103 findScr [(n, (_, t))] = [(n, (True, t))]

1000 findScr (x : xs) = x : findScr xs

1104 findScr (x : xs) = x : findScr xs

1001 -- [] can't happen since scrutinee is in the environment!

1105 -- [] can't happen since scrutinee is in the environment!

1106+ findScr [] = error "The impossible happened - the scrutinee was not in the environment"

1002

1107

1003 -- To make sure top level pattern name remains in scope, put

1108 -- To make sure top level pattern name remains in scope, put

1004 -- it at the end of the environment

1109 -- it at the end of the environment

@@ -1072,16 +1177,20 @@ elab ist info emode opts fn tm

1072 = x : insertScopedImps fc sc xs

1177 = x : insertScopedImps fc sc xs

1073 insertScopedImps _ _ xs = xs

1178 insertScopedImps _ _ xs = xs

1074

1179

1075− insertImpLam t =

1180+ insertImpLam ina t =

1076 do ty <- goal

1181 do ty <- goal

1077 env <- get_env

1182 env <- get_env

1078 let ty' = normalise (tt_ctxt ist) env ty

1183 let ty' = normalise (tt_ctxt ist) env ty

1079 addLam ty' t

1184 addLam ty' t

1080 where

1185 where

1081 -- just one level at a time

1186 -- just one level at a time

1082− addLam (Bind n (Pi (Just _) _ _) sc) t

1187+ addLam (Bind n (Pi (Just _) _ _) sc) t =

1083− = do impn <- unique_hole (sMN 0 "imp")

1188+ do impn <- unique_hole (sMN 0 "imp")

1189+ if e_isfn ina -- apply to an implicit immediately

1190+ then return (PApp emptyFC

1191+ (PLam emptyFC impn Placeholder t)

1192+ [pexp Placeholder])

1084− return (PLam emptyFC impn Placeholder t)

1193+ else return (PLam emptyFC impn Placeholder t)

1085 addLam _ t = return t

1194 addLam _ t = return t

1086

1195

1087 insertCoerce ina t@(PCase _ _ _) = return t

1196 insertCoerce ina t@(PCase _ _ _) = return t

@@ -1156,7 +1265,8 @@ elab ist info emode opts fn tm

1156 lift (tfail (elaboratingArgErr while' e))

1265 lift (tfail (elaboratingArgErr while' e))

1157 put newState

1266 put newState

1158 return result

1267 return result

1159−

1268+ elabArgs _ _ _ _ _ _ (((arg, hole), _) : _) _ [] =

1269+ fail $ "Can't elaborate these args: " ++ show arg ++ " " ++ show hole

1160

1270

1161-- For every alternative, look at the function at the head. Automatically resolve

1271-- For every alternative, look at the function at the head. Automatically resolve

1162-- any nested alternatives where that function is also at the head

1272-- any nested alternatives where that function is also at the head

@@ -1334,6 +1444,7 @@ resTC' tcs defaultOn depth topg fn ist

1334 let imps = case lookupCtxtName n (idris_implicits ist) of

1444 let imps = case lookupCtxtName n (idris_implicits ist) of

1335 [] -> []

1445 [] -> []

1336 [args] -> map isImp (snd args) -- won't be overloaded!

1446 [args] -> map isImp (snd args) -- won't be overloaded!

1447+ xs -> error "The impossible happened - overloading is not expected here!"

1337 ps <- get_probs

1448 ps <- get_probs

1338 tm <- get_term

1449 tm <- get_term

1339 args <- map snd <$> try' (apply (Var n) imps)

1450 args <- map snd <$> try' (apply (Var n) imps)

@@ -1394,6 +1505,86 @@ case_ ind autoSolve ist fn tm = do

1394 else casetac (forget val)

1505 else casetac (forget val)

1395 when autoSolve solveAll

1506 when autoSolve solveAll

1396

1507

1508+runTactical :: FC -> Context -> Env -> Term -> ElabD ()

1509+runTactical fc ctxt env tm = runTacTm (eval tm) >> return ()

1510+ where

1511+ eval = normaliseAll ctxt env

1512+ tacN str = sNS (sUN str) ["Tactical", "Reflection", "Language"]

1513+ returnUnit = fmap fst $ get_type_val (Var unitCon)

1514+

1515+ -- | Do a step in the reflected elaborator monad. The input is the

1516+ -- step, the output is the (reflected) term returned.

1517+ runTacTm :: Term -> ElabD Term

1518+ runTacTm (unApply -> tac@(P _ n _, args))

1519+ | n == tacN "prim__Solve", [] <- args

1520+ = do solve

1521+ returnUnit

1522+ | n == tacN "prim__Goal", [] <- args

1523+ = do (h:_) <- get_holes

1524+ t <- goal

1525+ fmap fst . get_type_val $

1526+ rawPair (Var (reflm "TTName"), Var (reflm "TT"))

1527+ (reflectName h, reflect t)

1528+ | n == tacN "prim__Holes", [] <- args

1529+ = do hs <- get_holes

1530+ fmap fst . get_type_val $

1531+ mkList (Var $ reflm "TTName") (map reflectName hs)

1532+ | n == tacN "prim__Guess", [] <- args

1533+ = do ok <- is_guess

1534+ if ok

1535+ then do guess <- fmap forget get_guess

1536+ fmap fst . get_type_val $

1537+ RApp (RApp (Var (sNS (sUN "Just") ["Maybe", "Prelude"]))

1538+ (Var (reflm "TT")))

1539+ guess

1540+ else fmap fst . get_type_val $

1541+ RApp (Var (sNS (sUN "Nothing") ["Maybe", "Prelude"]))

1542+ (Var (reflm "TT"))

1543+ | n == tacN "prim__Env", [] <- args

1544+ = do env <- get_env

1545+ fmap fst . get_type_val $ reflectEnv env

1546+ | n == tacN "prim__Fail", [_a, errs] <- args

1547+ = do parts <- reifyReportParts (eval errs)

1548+ lift . tfail $ ReflectionError [parts] (Msg "")

1549+ | n == tacN "prim__PureTactical", [_a, tm] <- args

1550+ = return tm

1551+ | n == tacN "prim__BindTactical", [_a, _b, first, andThen] <- args

1552+ = do let first' = eval first

1553+ res <- runTacTm first'

1554+ let next = eval (App andThen res)

1555+ runTacTm next

1556+ | n == tacN "prim__Try", [_a, first, alt] <- args

1557+ = do let first' = eval first

1558+ let alt' = eval alt

1559+ try' (runTacTm first') (runTacTm alt') True

1560+ | n == tacN "prim__Fill", [raw] <- args

1561+ = do raw' <- reifyRaw raw

1562+ apply raw' []

1563+ returnUnit

1564+ | n == tacN "prim__Gensym", [eval -> Constant (Str hint)] <- args

1565+ = do n <- getNameFrom (sMN 0 hint)

1566+ fmap fst $ get_type_val (reflectName n)

1567+ | n == tacN "prim__Claim", [n, ty] <- args

1568+ = do n' <- reifyTTName n

1569+ ty' <- reifyRaw ty

1570+ claim n' ty'

1571+ returnUnit

1572+ | n == tacN "prim__Forget", [tt] <- args

1573+ = do tt' <- reifyTT tt

1574+ fmap fst . get_type_val $ reflect tt'

1575+ | n == tacN "prim__Attack", [] <- args

1576+ = do attack

1577+ returnUnit

1578+ | n == tacN "prim__Focus", [what] <- args

1579+ = do n' <- reifyTTName what

1580+ focus n'

1581+ returnUnit

1582+ | n == tacN "prim__Unfocus", [what] <- args

1583+ = do n' <- reifyTTName what

1584+ movelast n'

1585+ returnUnit

1586+ runTacTm x = lift . tfail . InternalMsg $ "tactical is not implemented for " ++ show x

1587+

1397-- Running tactics directly

1588-- Running tactics directly

1398-- if a tactic adds unification problems, return an error

1589-- if a tactic adds unification problems, return an error

1399

1590

@@ -1460,6 +1651,12 @@ runTac autoSolve ist perhapsFC fn tac

1460 when autoSolve solveAll

1651 when autoSolve solveAll

1461 runT DoUnify = do unify_all

1652 runT DoUnify = do unify_all

1462 when autoSolve solveAll

1653 when autoSolve solveAll

1654+ runT (Claim n tm) = do tmHole <- getNameFrom (sMN 0 "newGoal")

1655+ claim tmHole RType

1656+ claim n (Var tmHole)

1657+ focus tmHole

1658+ elab ist toplevel ERHS [] (sMN 0 "tac") tm

1659+ focus n

1463 runT (Equiv tm) -- let bind tm, then

1660 runT (Equiv tm) -- let bind tm, then

1464 = do attack

1661 = do attack

1465 tyn <- getNameFrom (sMN 0 "ety")

1662 tyn <- getNameFrom (sMN 0 "ety")

@@ -1520,6 +1717,10 @@ runTac autoSolve ist perhapsFC fn tac

1520 = do proofSearch' ist rec False depth prover top fn hints

1717 = do proofSearch' ist rec False depth prover top fn hints

1521 when autoSolve solveAll

1718 when autoSolve solveAll

1522 runT (Focus n) = focus n

1719 runT (Focus n) = focus n

1720+ runT Unfocus = do hs <- get_holes

1721+ case hs of

1722+ [] -> return ()

1723+ (h : _) -> movelast h

1523 runT Solve = solve

1724 runT Solve = solve

1524 runT (Try l r) = do try' (runT l) (runT r) True

1725 runT (Try l r) = do try' (runT l) (runT r) True

1525 runT (TSeq l r) = do runT l; runT r

1726 runT (TSeq l r) = do runT l; runT r

@@ -1664,6 +1865,7 @@ reify _ (P _ n _) | n == reflm "Solve" = return Solve

1664reify _ (P _ n _) | n == reflm "Compute" = return Compute

1865reify _ (P _ n _) | n == reflm "Compute" = return Compute

1665reify _ (P _ n _) | n == reflm "Skip" = return Skip

1866reify _ (P _ n _) | n == reflm "Skip" = return Skip

1666reify _ (P _ n _) | n == reflm "SourceFC" = return SourceFC

1867reify _ (P _ n _) | n == reflm "SourceFC" = return SourceFC

1868+reify _ (P _ n _) | n == reflm "Unfocus" = return Unfocus

1667reify ist t@(App _ _)

1869reify ist t@(App _ _)

1668 | (P _ f _, args) <- unApply t = reifyApp ist f args

1870 | (P _ f _, args) <- unApply t = reifyApp ist f args

1669reify _ t = fail ("Unknown tactic " ++ show t)

1871reify _ t = fail ("Unknown tactic " ++ show t)

@@ -1675,6 +1877,9 @@ reifyApp _ t [Constant (I i)]

1675reifyApp _ t [x]

1877reifyApp _ t [x]

1676 | t == reflm "Refine" = do n <- reifyTTName x

1878 | t == reflm "Refine" = do n <- reifyTTName x

1677 return $ Refine n []

1879 return $ Refine n []

1880+reifyApp ist t [n, ty] | t == reflm "Claim" = do n' <- reifyTTName n

1881+ goal <- reifyTT ty

1882+ return $ Claim n' (delab ist goal)

1678reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)

1883reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)

1679reifyApp ist t [Constant (Str n), x]

1884reifyApp ist t [Constant (Str n), x]

1680 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

1885 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

@@ -1705,16 +1910,20 @@ reifyApp ist t [n, tt', t']

1705 t'' <- reifyTT t'

1910 t'' <- reifyTT t'

1706 return $ LetTacTy n' (delab ist tt'') (delab ist t'')

1911 return $ LetTacTy n' (delab ist tt'') (delab ist t'')

1707reifyApp ist t [errs]

1912reifyApp ist t [errs]

1708− | t == reflm "Fail" = case unList errs of

1913+ | t == reflm "Fail" = fmap TFail (reifyReportParts errs)

1709− Nothing -> fail "Failed to reify errors"

1710− Just errs' ->

1711− let parts = mapM reifyReportPart errs' in

1712− case parts of

1713− Left err -> fail $ "Couldn't reify \"Fail\" tactic - " ++ show err

1714− Right errs'' ->

1715− return $ TFail errs''

1716reifyApp _ f args = fail ("Unknown tactic " ++ show (f, args)) -- shouldn't happen

1914reifyApp _ f args = fail ("Unknown tactic " ++ show (f, args)) -- shouldn't happen

1717

1915

1916+reifyReportParts :: Term -> ElabD [ErrorReportPart]

1917+reifyReportParts errs =

1918+ case unList errs of

1919+ Nothing -> fail "Failed to reify errors"

1920+ Just errs' ->

1921+ let parts = mapM reifyReportPart errs' in

1922+ case parts of

1923+ Left err -> fail $ "Couldn't reify \"Fail\" tactic - " ++ show err

1924+ Right errs'' ->

1925+ return errs''

1926+

1718-- | Reify terms from their reflected representation

1927-- | Reify terms from their reflected representation

1719reifyTT :: Term -> ElabD Term

1928reifyTT :: Term -> ElabD Term

1720reifyTT t@(App _ _)

1929reifyTT t@(App _ _)

@@ -1894,6 +2103,7 @@ reifyIntTy (P _ n _) | n == reflm "ITBig" = return ITBig

1894reifyIntTy (P _ n _) | n == reflm "ITChar" = return ITChar

2103reifyIntTy (P _ n _) | n == reflm "ITChar" = return ITChar

1895reifyIntTy (App (App (P _ n _) nt) (Constant (I i))) | n == reflm "ITVec" = fmap (flip ITVec i)

2104reifyIntTy (App (App (P _ n _) nt) (Constant (I i))) | n == reflm "ITVec" = fmap (flip ITVec i)

1896 (reifyNativeTy nt)

2105 (reifyNativeTy nt)

2106+reifyIntTy tm = fail $ "The term " ++ show tm ++ " is not a reflected IntTy"

1897

2107

1898reifyTTUExp :: Term -> ElabD UExp

2108reifyTTUExp :: Term -> ElabD UExp

1899reifyTTUExp t@(App _ _)

2109reifyTTUExp t@(App _ _)

@@ -1910,7 +2120,11 @@ reflCall funName args

1910

2120

1911-- | Lift a term into its Language.Reflection.TT representation

2121-- | Lift a term into its Language.Reflection.TT representation

1912reflect :: Term -> Raw

2122reflect :: Term -> Raw

1913−reflect = reflectQuote []

2123+reflect = reflectTTQuote []

2124+

2125+-- | Lift a term into its Language.Reflection.Raw representation

2126+reflectRaw :: Raw -> Raw

2127+reflectRaw = reflectRawQuote []

1914

2128

1915claimTT :: Name -> ElabD Name

2129claimTT :: Name -> ElabD Name

1916claimTT n = do n' <- getNameFrom n

2130claimTT n = do n' <- getNameFrom n

@@ -1921,8 +2135,8 @@ claimTT n = do n' <- getNameFrom n

1921-- In particular, the less-interesting bits are elaborated to _ patterns. This

2135-- In particular, the less-interesting bits are elaborated to _ patterns. This

1922-- happens to NameTypes, universe levels, names that are bound but not used,

2136-- happens to NameTypes, universe levels, names that are bound but not used,

1923-- and the type annotation field of the P constructor.

2137-- and the type annotation field of the P constructor.

1924−reflectQuotePattern :: [Name] -> Term -> ElabD ()

2138+reflectTTQuotePattern :: [Name] -> Term -> ElabD ()

1925−reflectQuotePattern unq (P _ n _)

2139+reflectTTQuotePattern unq (P _ n _)

1926 | n `elem` unq = -- the unquoted names have been claimed as TT already - just use them

2140 | n `elem` unq = -- the unquoted names have been claimed as TT already - just use them

1927 do fill (Var n) ; solve

2141 do fill (Var n) ; solve

1928 | otherwise =

2142 | otherwise =

@@ -1936,10 +2150,10 @@ reflectQuotePattern unq (P _ n _)

1936 fill $ reflCall "P" [Var nt, Var n', Var tyannot]

2150 fill $ reflCall "P" [Var nt, Var n', Var tyannot]

1937 solve

2151 solve

1938 focus n'; reflectNameQuotePattern n

2152 focus n'; reflectNameQuotePattern n

1939−reflectQuotePattern unq (V n)

2153+reflectTTQuotePattern unq (V n)

1940 = do fill $ reflCall "V" [RConstant (I n)]

2154 = do fill $ reflCall "V" [RConstant (I n)]

1941 solve

2155 solve

1942−reflectQuotePattern unq (Bind n b x)

2156+reflectTTQuotePattern unq (Bind n b x)

1943 = do x' <- claimTT (sMN 0 "sc")

2157 = do x' <- claimTT (sMN 0 "sc")

1944 movelast x'

2158 movelast x'

1945 b' <- getNameFrom (sMN 0 "binder")

2159 b' <- getNameFrom (sMN 0 "binder")

@@ -1959,111 +2173,215 @@ reflectQuotePattern unq (Bind n b x)

1959 Var b',

2173 Var b',

1960 Var x']

2174 Var x']

1961 solve

2175 solve

1962− focus x'; reflectQuotePattern unq x

2176+ focus x'; reflectTTQuotePattern unq x

1963− focus b'; reflectBinderQuotePattern unq b

2177+ focus b'; reflectBinderQuotePattern reflectTTQuotePattern unq b

1964−

2178+reflectTTQuotePattern unq (App f x)

1965− where

1966− reflectBinderQuotePattern :: [Name] -> Binder Term -> ElabD ()

1967− reflectBinderQuotePattern unq (Lam t)

1968− = do t' <- claimTT (sMN 0 "ty"); movelast t'

1969− fill $ reflCall "Lam" [Var (reflm "TT"), Var t']

1970− solve

1971− focus t'; reflectQuotePattern unq t

1972− reflectBinderQuotePattern unq (Pi _ t k)

1973− = do t' <- claimTT (sMN 0 "ty") ; movelast t'

1974− k' <- claimTT (sMN 0 "k"); movelast k';

1975− fill $ reflCall "Pi" [Var (reflm "TT"), Var t', Var k']

1976− solve

1977− focus t'; reflectQuotePattern unq t

1978− reflectBinderQuotePattern unq (Let x y)

1979− = do x' <- claimTT (sMN 0 "ty"); movelast x';

1980− y' <- claimTT (sMN 0 "v"); movelast y';

1981− fill $ reflCall "Let" [Var (reflm "TT"), Var x', Var y']

1982− solve

1983− focus x'; reflectQuotePattern unq x

1984− focus y'; reflectQuotePattern unq y

1985− reflectBinderQuotePattern unq (NLet x y)

1986− = do x' <- claimTT (sMN 0 "ty"); movelast x'

1987− y' <- claimTT (sMN 0 "v"); movelast y'

1988− fill $ reflCall "NLet" [Var (reflm "TT"), Var x', Var y']

1989− solve

1990− focus x'; reflectQuotePattern unq x

1991− focus y'; reflectQuotePattern unq y

1992− reflectBinderQuotePattern unq (Hole t)

1993− = do t' <- claimTT (sMN 0 "ty"); movelast t'

1994− fill $ reflCall "Hole" [Var (reflm "TT"), Var t']

1995− solve

1996− focus t'; reflectQuotePattern unq t

1997− reflectBinderQuotePattern unq (GHole _ t)

1998− = do t' <- claimTT (sMN 0 "ty"); movelast t'

1999− fill $ reflCall "GHole" [Var (reflm "TT"), Var t']

2000− solve

2001− focus t'; reflectQuotePattern unq t

2002− reflectBinderQuotePattern unq (Guess x y)

2003− = do x' <- claimTT (sMN 0 "ty"); movelast x'

2004− y' <- claimTT (sMN 0 "v"); movelast y'

2005− fill $ reflCall "Guess" [Var (reflm "TT"), Var x', Var y']

2006− solve

2007− focus x'; reflectQuotePattern unq x

2008− focus y'; reflectQuotePattern unq y

2009− reflectBinderQuotePattern unq (PVar t)

2010− = do t' <- claimTT (sMN 0 "ty"); movelast t'

2011− fill $ reflCall "PVar" [Var (reflm "TT"), Var t']

2012− solve

2013− focus t'; reflectQuotePattern unq t

2014− reflectBinderQuotePattern unq (PVTy t)

2015− = do t' <- claimTT (sMN 0 "ty"); movelast t'

2016− fill $ reflCall "PVTy" [Var (reflm "TT"), Var t']

2017− solve

2018− focus t'; reflectQuotePattern unq t

2019−reflectQuotePattern unq (App f x)

2020 = do f' <- claimTT (sMN 0 "f"); movelast f'

2179 = do f' <- claimTT (sMN 0 "f"); movelast f'

2021 x' <- claimTT (sMN 0 "x"); movelast x'

2180 x' <- claimTT (sMN 0 "x"); movelast x'

2022 fill $ reflCall "App" [Var f', Var x']

2181 fill $ reflCall "App" [Var f', Var x']

2023 solve

2182 solve

2024− focus f'; reflectQuotePattern unq f

2183+ focus f'; reflectTTQuotePattern unq f

2025− focus x'; reflectQuotePattern unq x

2184+ focus x'; reflectTTQuotePattern unq x

2026−reflectQuotePattern unq (Constant c)

2185+reflectTTQuotePattern unq (Constant c)

2027 = do fill $ reflCall "TConst" [reflectConstant c]

2186 = do fill $ reflCall "TConst" [reflectConstant c]

2028 solve

2187 solve

2029−reflectQuotePattern unq (Proj t i)

2188+reflectTTQuotePattern unq (Proj t i)

2030 = do t' <- claimTT (sMN 0 "t"); movelast t'

2189 = do t' <- claimTT (sMN 0 "t"); movelast t'

2031 fill $ reflCall "Proj" [Var t', RConstant (I i)]

2190 fill $ reflCall "Proj" [Var t', RConstant (I i)]

2032 solve

2191 solve

2033− focus t'; reflectQuotePattern unq t

2192+ focus t'; reflectTTQuotePattern unq t

2034−reflectQuotePattern unq (Erased)

2193+reflectTTQuotePattern unq (Erased)

2035 = do erased <- claimTT (sMN 0 "erased")

2194 = do erased <- claimTT (sMN 0 "erased")

2036 movelast erased

2195 movelast erased

2037 fill $ (Var erased)

2196 fill $ (Var erased)

2038 solve

2197 solve

2039−reflectQuotePattern unq (Impossible)

2198+reflectTTQuotePattern unq (Impossible)

2040 = do fill $ Var (reflm "Impossible")

2199 = do fill $ Var (reflm "Impossible")

2041 solve

2200 solve

2042−reflectQuotePattern unq (TType exp)

2201+reflectTTQuotePattern unq (TType exp)

2043 = do ue <- getNameFrom (sMN 0 "uexp")

2202 = do ue <- getNameFrom (sMN 0 "uexp")

2044 claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))

2203 claim ue (Var (sNS (sUN "TTUExp") ["Reflection", "Language"]))

2045 movelast ue

2204 movelast ue

2046 fill $ reflCall "TType" [Var ue]

2205 fill $ reflCall "TType" [Var ue]

2047 solve

2206 solve

2207+reflectTTQuotePattern unq (UType u)

2208+ = do uH <- getNameFrom (sMN 0 "someUniv")

2209+ claim uH (Var (reflm "Universe"))

2210+ movelast uH

2211+ fill $ reflCall "UType" [Var uH]

2212+ solve

2213+ focus uH

2214+ fill (Var (reflm (case u of

2215+ NullType -> "NullType"

2216+ UniqueType -> "UniqueType"

2217+ AllTypes -> "AllTypes")))

2218+ solve

2048

2219

2220+reflectRawQuotePattern :: [Name] -> Raw -> ElabD ()

2221+reflectRawQuotePattern unq (Var n)

2222+ -- the unquoted names already have types, just use them

2223+ | n `elem` unq = do fill (Var n); solve

2224+ | otherwise = do fill (reflCall "Var" [reflectName n]); solve

2225+reflectRawQuotePattern unq (RBind n b sc) =

2226+ do scH <- getNameFrom (sMN 0 "sc")

2227+ claim scH (Var (reflm "Raw"))

2228+ movelast scH

2229+ bH <- getNameFrom (sMN 0 "binder")

2230+ claim bH (RApp (Var (reflm "Binder"))

2231+ (Var (reflm "Raw")))

2232+ if n `elem` freeNamesR sc

2233+ then do fill $ reflCall "RBind" [reflectName n,

2234+ Var bH,

2235+ Var scH]

2236+ solve

2237+ else do any <- getNameFrom (sMN 0 "anyName")

2238+ claim any (Var (reflm "TTName"))

2239+ movelast any

2240+ fill $ reflCall "RBind" [Var any, Var bH, Var scH]

2241+ solve

2242+ focus scH; reflectRawQuotePattern unq sc

2243+ focus bH; reflectBinderQuotePattern reflectRawQuotePattern unq b

2244+ where freeNamesR (Var n) = [n]

2245+ freeNamesR (RBind n (Let t v) body) = concat [freeNamesR v,

2246+ freeNamesR body \\ [n],

2247+ freeNamesR t]

2248+ freeNamesR (RBind n b body) = freeNamesR (binderTy b) ++

2249+ (freeNamesR body \\ [n])

2250+ freeNamesR (RApp f x) = freeNamesR f ++ freeNamesR x

2251+ freeNamesR RType = []

2252+ freeNamesR (RUType _) = []

2253+ freeNamesR (RForce r) = freeNamesR r

2254+ freeNamesR (RConstant _) = []

2255+reflectRawQuotePattern unq (RApp f x) =

2256+ do fH <- getNameFrom (sMN 0 "f")

2257+ claim fH (Var (reflm "Raw"))

2258+ movelast fH

2259+ xH <- getNameFrom (sMN 0 "x")

2260+ claim xH (Var (reflm "Raw"))

2261+ movelast xH

2262+ fill $ reflCall "RApp" [Var fH, Var xH]

2263+ solve

2264+ focus fH; reflectRawQuotePattern unq f

2265+ focus xH; reflectRawQuotePattern unq x

2266+reflectRawQuotePattern unq RType =

2267+ do fill (Var (reflm "RType"))

2268+ solve

2269+reflectRawQuotePattern unq (RUType univ) =

2270+ do uH <- getNameFrom (sMN 0 "universe")

2271+ claim uH (Var (reflm "Universe"))

2272+ movelast uH

2273+ fill $ reflCall "RUType" [Var uH]

2274+ solve

2275+ focus uH; fill (reflectUniverse univ); solve

2276+reflectRawQuotePattern unq (RForce r) =

2277+ do rH <- getNameFrom (sMN 0 "raw")

2278+ claim rH (Var (reflm "Raw"))

2279+ movelast rH

2280+ fill $ reflCall "RForce" [Var rH]

2281+ solve

2282+ focus rH; reflectRawQuotePattern unq r

2283+reflectRawQuotePattern unq (RConstant c) =

2284+ do cH <- getNameFrom (sMN 0 "const")

2285+ claim cH (Var (reflm "Constant"))

2286+ movelast cH

2287+ fill (reflCall "RConstant" [Var cH]); solve

2288+ focus cH

2289+ fill (reflectConstant c); solve

2290+

2291+reflectBinderQuotePattern :: ([Name] -> a -> ElabD ()) -> [Name] -> Binder a -> ElabD ()

2292+reflectBinderQuotePattern q unq (Lam t)

2293+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

2294+ fill $ reflCall "Lam" [Var (reflm "TT"), Var t']

2295+ solve

2296+ focus t'; q unq t

2297+reflectBinderQuotePattern q unq (Pi _ t k)

2298+ = do t' <- claimTT (sMN 0 "ty") ; movelast t'

2299+ k' <- claimTT (sMN 0 "k"); movelast k';

2300+ fill $ reflCall "Pi" [Var (reflm "TT"), Var t', Var k']

2301+ solve

2302+ focus t'; q unq t

2303+reflectBinderQuotePattern q unq (Let x y)

2304+ = do x' <- claimTT (sMN 0 "ty"); movelast x';

2305+ y' <- claimTT (sMN 0 "v"); movelast y';

2306+ fill $ reflCall "Let" [Var (reflm "TT"), Var x', Var y']

2307+ solve

2308+ focus x'; q unq x

2309+ focus y'; q unq y

2310+reflectBinderQuotePattern q unq (NLet x y)

2311+ = do x' <- claimTT (sMN 0 "ty"); movelast x'

2312+ y' <- claimTT (sMN 0 "v"); movelast y'

2313+ fill $ reflCall "NLet" [Var (reflm "TT"), Var x', Var y']

2314+ solve

2315+ focus x'; q unq x

2316+ focus y'; q unq y

2317+reflectBinderQuotePattern q unq (Hole t)

2318+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

2319+ fill $ reflCall "Hole" [Var (reflm "TT"), Var t']

2320+ solve

2321+ focus t'; q unq t

2322+reflectBinderQuotePattern q unq (GHole _ t)

2323+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

2324+ fill $ reflCall "GHole" [Var (reflm "TT"), Var t']

2325+ solve

2326+ focus t'; q unq t

2327+reflectBinderQuotePattern q unq (Guess x y)

2328+ = do x' <- claimTT (sMN 0 "ty"); movelast x'

2329+ y' <- claimTT (sMN 0 "v"); movelast y'

2330+ fill $ reflCall "Guess" [Var (reflm "TT"), Var x', Var y']

2331+ solve

2332+ focus x'; q unq x

2333+ focus y'; q unq y

2334+reflectBinderQuotePattern q unq (PVar t)

2335+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

2336+ fill $ reflCall "PVar" [Var (reflm "TT"), Var t']

2337+ solve

2338+ focus t'; q unq t

2339+reflectBinderQuotePattern q unq (PVTy t)

2340+ = do t' <- claimTT (sMN 0 "ty"); movelast t'

2341+ fill $ reflCall "PVTy" [Var (reflm "TT"), Var t']

2342+ solve

2343+ focus t'; q unq t

2344+

2345+reflectUniverse :: Universe -> Raw

2346+reflectUniverse u =

2347+ (Var (reflm (case u of

2348+ NullType -> "NullType"

2349+ UniqueType -> "UniqueType"

2350+ AllTypes -> "AllTypes")))

2351+

2049−-- | Create a reflected term, but leave refs to the provided name intact

2352+-- | Create a reflected TT term, but leave refs to the provided name intact

2050−reflectQuote :: [Name] -> Term -> Raw

2353+reflectTTQuote :: [Name] -> Term -> Raw

2051−reflectQuote unq (P nt n t)

2354+reflectTTQuote unq (P nt n t)

2052 | n `elem` unq = Var n

2355 | n `elem` unq = Var n

2053− | otherwise = reflCall "P" [reflectNameType nt, reflectName n, reflectQuote unq t]

2356+ | otherwise = reflCall "P" [reflectNameType nt, reflectName n, reflectTTQuote unq t]

2054−reflectQuote unq (V n)

2357+reflectTTQuote unq (V n)

2055 = reflCall "V" [RConstant (I n)]

2358 = reflCall "V" [RConstant (I n)]

2056−reflectQuote unq (Bind n b x)

2359+reflectTTQuote unq (Bind n b x)

2057− = reflCall "Bind" [reflectName n, reflectBinderQuote unq b, reflectQuote unq x]

2360+ = reflCall "Bind" [reflectName n, reflectBinderQuote reflectTTQuote unq b, reflectTTQuote unq x]

2058−reflectQuote unq (App f x)

2361+reflectTTQuote unq (App f x)

2059− = reflCall "App" [reflectQuote unq f, reflectQuote unq x]

2362+ = reflCall "App" [reflectTTQuote unq f, reflectTTQuote unq x]

2060−reflectQuote unq (Constant c)

2363+reflectTTQuote unq (Constant c)

2061 = reflCall "TConst" [reflectConstant c]

2364 = reflCall "TConst" [reflectConstant c]

2062−reflectQuote unq (Proj t i)

2365+reflectTTQuote unq (Proj t i)

2063− = reflCall "Proj" [reflectQuote unq t, RConstant (I i)]

2366+ = reflCall "Proj" [reflectTTQuote unq t, RConstant (I i)]

2064−reflectQuote unq (Erased) = Var (reflm "Erased")

2367+reflectTTQuote unq (Erased) = Var (reflm "Erased")

2065−reflectQuote unq (Impossible) = Var (reflm "Impossible")

2368+reflectTTQuote unq (Impossible) = Var (reflm "Impossible")

2066−reflectQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]

2369+reflectTTQuote unq (TType exp) = reflCall "TType" [reflectUExp exp]

2370+reflectTTQuote unq (UType u) = reflCall "UType" [reflectUniverse u]

2371+

2372+reflectRawQuote :: [Name] -> Raw -> Raw

2373+reflectRawQuote unq (Var n)

2374+ | n `elem` unq = Var n

2375+ | otherwise = reflCall "Var" [reflectName n]

2376+reflectRawQuote unq (RBind n b r) =

2377+ reflCall "RBind" [reflectName n, reflectBinderQuote reflectRawQuote unq b, reflectRawQuote unq r]

2378+reflectRawQuote unq (RApp f x) =

2379+ reflCall "RApp" [reflectRawQuote unq f, reflectRawQuote unq x]

2380+reflectRawQuote unq RType = Var (reflm "RType")

2381+reflectRawQuote unq (RUType u) =

2382+ reflCall "RUType" [reflectUniverse u]

2383+reflectRawQuote unq (RForce r) = reflCall "RForce" [reflectRawQuote unq r]

2384+reflectRawQuote unq (RConstant cst) = reflCall "RConstant" [reflectConstant cst]

2067

2385

2068reflectNameType :: NameType -> Raw

2386reflectNameType :: NameType -> Raw

2069reflectNameType (Bound) = Var (reflm "Bound")

2387reflectNameType (Bound) = Var (reflm "Bound")

@@ -2114,27 +2432,27 @@ reflectNameQuotePattern _ -- for all other names, match any

2114 solve

2432 solve

2115

2433

2116reflectBinder :: Binder Term -> Raw

2434reflectBinder :: Binder Term -> Raw

2117−reflectBinder = reflectBinderQuote []

2435+reflectBinder = reflectBinderQuote reflectTTQuote []

2118−

2436+

2119−reflectBinderQuote :: [Name] -> Binder Term -> Raw

2437+reflectBinderQuote :: ([Name] -> a -> Raw) -> [Name] -> Binder a -> Raw

2120−reflectBinderQuote unq (Lam t)

2438+reflectBinderQuote q unq (Lam t)

2121− = reflCall "Lam" [Var (reflm "TT"), reflectQuote unq t]

2439+ = reflCall "Lam" [Var (reflm "TT"), q unq t]

2122−reflectBinderQuote unq (Pi _ t k)

2440+reflectBinderQuote q unq (Pi _ t k)

2123− = reflCall "Pi" [Var (reflm "TT"), reflectQuote unq t, reflectQuote unq k]

2441+ = reflCall "Pi" [Var (reflm "TT"), q unq t, q unq k]

2124−reflectBinderQuote unq (Let x y)

2442+reflectBinderQuote q unq (Let x y)

2125− = reflCall "Let" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y]

2443+ = reflCall "Let" [Var (reflm "TT"), q unq x, q unq y]

2126−reflectBinderQuote unq (NLet x y)

2444+reflectBinderQuote q unq (NLet x y)

2127− = reflCall "NLet" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y]

2445+ = reflCall "NLet" [Var (reflm "TT"), q unq x, q unq y]

2128−reflectBinderQuote unq (Hole t)

2446+reflectBinderQuote q unq (Hole t)

2129− = reflCall "Hole" [Var (reflm "TT"), reflectQuote unq t]

2447+ = reflCall "Hole" [Var (reflm "TT"), q unq t]

2130−reflectBinderQuote unq (GHole _ t)

2448+reflectBinderQuote q unq (GHole _ t)

2131− = reflCall "GHole" [Var (reflm "TT"), reflectQuote unq t]

2449+ = reflCall "GHole" [Var (reflm "TT"), q unq t]

2132−reflectBinderQuote unq (Guess x y)

2450+reflectBinderQuote q unq (Guess x y)

2133− = reflCall "Guess" [Var (reflm "TT"), reflectQuote unq x, reflectQuote unq y]

2451+ = reflCall "Guess" [Var (reflm "TT"), q unq x, q unq y]

2134−reflectBinderQuote unq (PVar t)

2452+reflectBinderQuote q unq (PVar t)

2135− = reflCall "PVar" [Var (reflm "TT"), reflectQuote unq t]

2453+ = reflCall "PVar" [Var (reflm "TT"), q unq t]

2136−reflectBinderQuote unq (PVTy t)

2454+reflectBinderQuote q unq (PVTy t)

2137− = reflCall "PVTy" [Var (reflm "TT"), reflectQuote unq t]

2455+ = reflCall "PVTy" [Var (reflm "TT"), q unq t]

2138

2456

2139mkList :: Raw -> [Raw] -> Raw

2457mkList :: Raw -> [Raw] -> Raw

2140mkList ty [] = RApp (Var (sNS (sUN "Nil") ["List", "Prelude"])) ty

2458mkList ty [] = RApp (Var (sNS (sUN "Nil") ["List", "Prelude"])) ty

@@ -2174,7 +2492,8 @@ reflectConstant ManagedPtrType = Var (reflm "ManagedPtrType")

2174reflectConstant BufferType = Var (reflm "BufferType")

2492reflectConstant BufferType = Var (reflm "BufferType")

2175reflectConstant VoidType = Var (reflm "VoidType")

2493reflectConstant VoidType = Var (reflm "VoidType")

2176reflectConstant Forgot = Var (reflm "Forgot")

2494reflectConstant Forgot = Var (reflm "Forgot")

2177−

2495+reflectConstant WorldType = Var (reflm "WorldType")

2496+reflectConstant TheWorld = Var (reflm "TheWorld")

2178

2497

2179reflectUExp :: UExp -> Raw

2498reflectUExp :: UExp -> Raw

2180reflectUExp (UVar i) = reflCall "UVar" [RConstant (I i)]

2499reflectUExp (UVar i) = reflCall "UVar" [RConstant (I i)]

src/Idris/Erasure.hs+1

@@ -468,6 +468,7 @@ buildDepMap ci used ctx mainName = addPostulates used $

468 -- the easy cases

469 getDepsTerm vs bs cd (Constant _) = M.empty

470 getDepsTerm vs bs cd (TType _) = M.empty

471+ getDepsTerm vs bs cd (UType _) = M.empty

471 getDepsTerm vs bs cd Erased = M.empty

472 getDepsTerm vs bs cd Erased = M.empty

472 getDepsTerm vs bs cd Impossible = M.empty

473 getDepsTerm vs bs cd Impossible = M.empty

473

474

src/Idris/Error.hs+3

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

1{-# LANGUAGE DeriveDataTypeable #-}

2+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3module Idris.Error where

4module Idris.Error where

@@ -146,3 +147,5 @@ warnDisamb ist (PQuasiquote tm goal) = warnDisamb ist tm >>

146 Foldable.mapM_ (warnDisamb ist) goal

147 Foldable.mapM_ (warnDisamb ist) goal

147warnDisamb ist (PUnquote tm) = warnDisamb ist tm

148warnDisamb ist (PUnquote tm) = warnDisamb ist tm

148warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm

149warnDisamb ist (PAs _ _ tm) = warnDisamb ist tm

150+warnDisamb ist (PAppImpl tm _) = warnDisamb ist tm

151+warnDisamb ist (PRunTactics _ tm) = warnDisamb ist tm

src/Idris/IBC.hs+169−15

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

1{-# LANGUAGE TypeSynonymInstances #-}

2+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

3module Idris.IBC where

4module Idris.IBC where

@@ -36,7 +37,7 @@ import Codec.Compression.Zlib (compress)

36import Util.Zlib (decompressEither)

37import Util.Zlib (decompressEither)

38ibcVersion :: Word8

39ibcVersion :: Word8

39−ibcVersion = 95

40+ibcVersion = 98

41data IBCFile = IBCFile { ver :: Word8,

42data IBCFile = IBCFile { ver :: Word8,

42 sourcefile :: FilePath,

43 sourcefile :: FilePath,

@@ -610,6 +611,7 @@ instance Binary a => Binary (D.Block a) where

610 4 -> liftM3 D.CodeBlock get get get

611 4 -> liftM3 D.CodeBlock get get get

611 5 -> liftM D.HtmlBlock get

612 5 -> liftM D.HtmlBlock get

612 6 -> return D.HRule

613 6 -> return D.HRule

614+ _ -> error "Corrupted binary data for Block"

613

615

614instance Binary a => Binary (D.Inline a) where

616instance Binary a => Binary (D.Inline a) where

615 put (D.Str txt) = do putWord8 0 ; put txt

617 put (D.Str txt) = do putWord8 0 ; put txt

@@ -636,6 +638,7 @@ instance Binary a => Binary (D.Inline a) where

636 8 -> liftM3 D.Image get get get

638 8 -> liftM3 D.Image get get get

637 9 -> liftM D.Entity get

639 9 -> liftM D.Entity get

638 10 -> liftM D.RawHtml get

640 10 -> liftM D.RawHtml get

641+ _ -> error "Corrupted binary data for Inline"

639

642

640instance Binary CT.ListType where

643instance Binary CT.ListType where

641 put (CT.Bullet c) = putWord8 0 >> put c

644 put (CT.Bullet c) = putWord8 0 >> put c

@@ -644,6 +647,7 @@ instance Binary CT.ListType where

644 case i of

647 case i of

645 0 -> liftM CT.Bullet get

648 0 -> liftM CT.Bullet get

646 1 -> liftM2 CT.Numbered get get

649 1 -> liftM2 CT.Numbered get get

650+ _ -> error "Corrupted binary data for ListType"

647

651

648instance Binary CT.CodeAttr where

652instance Binary CT.CodeAttr where

649 put (CT.CodeAttr a b) = put a >> put b

653 put (CT.CodeAttr a b) = put a >> put b

@@ -656,6 +660,7 @@ instance Binary CT.NumWrapper where

656 case i of

660 case i of

657 0 -> return CT.PeriodFollowing

661 0 -> return CT.PeriodFollowing

658 1 -> return CT.ParenFollowing

662 1 -> return CT.ParenFollowing

663+ _ -> error "Corrupted binary data for NumWrapper"

659

664

660----- Generated by 'derive'

665----- Generated by 'derive'

661

666

@@ -868,6 +873,9 @@ instance Binary PReason where

868 put x1

873 put x1

869 NotProductive -> putWord8 5

874 NotProductive -> putWord8 5

870 BelieveMe -> putWord8 6

875 BelieveMe -> putWord8 6

876+ UseUndef x1 -> do putWord8 7

877+ put x1

878+ ExternalIO -> putWord8 8

871 get

879 get

872 = do i <- getWord8

880 = do i <- getWord8

873 case i of

881 case i of

@@ -880,6 +888,9 @@ instance Binary PReason where

880 return (Mutual x1)

888 return (Mutual x1)

881 5 -> return NotProductive

889 5 -> return NotProductive

882 6 -> return BelieveMe

890 6 -> return BelieveMe

891+ 7 -> do x1 <- get

892+ return (UseUndef x1)

893+ 8 -> return ExternalIO

883 _ -> error "Corrupted binary data for PReason"

894 _ -> error "Corrupted binary data for PReason"

884

895

885instance Binary Totality where

896instance Binary Totality where

@@ -913,6 +924,7 @@ instance Binary MetaInformation where

913 0 -> return EmptyMI

924 0 -> return EmptyMI

914 1 -> do x1 <- get

925 1 -> do x1 <- get

915 return (DataMI x1)

926 return (DataMI x1)

927+ _ -> error "Corrupted binary data for MetaInformation"

916

928

917instance Binary IBCFile where

929instance Binary IBCFile where

918 put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42)

930 put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42)

@@ -1019,6 +1031,7 @@ instance Binary DataOpt where

1019 1 -> return DefaultEliminator

1031 1 -> return DefaultEliminator

1020 2 -> return DataErrRev

1032 2 -> return DataErrRev

1021 3 -> return DefaultCaseFun

1033 3 -> return DefaultCaseFun

1034+ _ -> error "Corrupted binary data for DataOpt"

1022

1035

1023instance Binary FnOpt where

1036instance Binary FnOpt where

1024 put x

1037 put x

@@ -1038,6 +1051,8 @@ instance Binary FnOpt where

1038 CoveringFn -> putWord8 11

1051 CoveringFn -> putWord8 11

1039 NoImplicit -> putWord8 12

1052 NoImplicit -> putWord8 12

1040 Constructor -> putWord8 13

1053 Constructor -> putWord8 13

1054+ CExport x1 -> do putWord8 14

1055+ put x1

1041 get

1056 get

1042 = do i <- getWord8

1057 = do i <- getWord8

1043 case i of

1058 case i of

@@ -1056,6 +1071,8 @@ instance Binary FnOpt where

1056 11 -> return CoveringFn

1071 11 -> return CoveringFn

1057 12 -> return NoImplicit

1072 12 -> return NoImplicit

1058 13 -> return Constructor

1073 13 -> return Constructor

1074+ 14 -> do x1 <- get

1075+ return $ CExport x1

1059 _ -> error "Corrupted binary data for FnOpt"

1076 _ -> error "Corrupted binary data for FnOpt"

1060

1077

1061instance Binary Fixity where

1078instance Binary Fixity where

@@ -1250,6 +1267,20 @@ instance (Binary t) => Binary (PDecl' t) where

1250 put x4

1267 put x4

1251 put x5

1268 put x5

1252 put x6

1269 put x6

1270+ PSyntax x1 x2 -> do putWord8 13

1271+ put x1

1272+ put x2

1273+ PDirective x1 -> error "Cannot serialize PDirective"

1274+ PProvider x1 x2 x3 x4 -> do putWord8 15

1275+ put x1

1276+ put x2

1277+ put x3

1278+ put x4

1279+ PTransform x1 x2 x3 x4 -> do putWord8 16

1280+ put x1

1281+ put x2

1282+ put x3

1283+ put x4

1253 get

1284 get

1254 = do i <- getWord8

1285 = do i <- getWord8

1255 case i of

1286 case i of

@@ -1330,8 +1361,37 @@ instance (Binary t) => Binary (PDecl' t) where

1330 x5 <- get

1361 x5 <- get

1331 x6 <- get

1362 x6 <- get

1332 return (PPostulate x1 x2 x3 x4 x5 x6)

1363 return (PPostulate x1 x2 x3 x4 x5 x6)

1364+ 13 -> do x1 <- get

1365+ x2 <- get

1366+ return (PSyntax x1 x2)

1367+ 14 -> do error "Cannot deserialize PDirective"

1368+ 15 -> do x1 <- get

1369+ x2 <- get

1370+ x3 <- get

1371+ x4 <- get

1372+ return (PProvider x1 x2 x3 x4)

1373+ 16 -> do x1 <- get

1374+ x2 <- get

1375+ x3 <- get

1376+ x4 <- get

1377+ return (PTransform x1 x2 x3 x4)

1333 _ -> error "Corrupted binary data for PDecl'"

1378 _ -> error "Corrupted binary data for PDecl'"

1334

1379

1380+instance Binary t => Binary (ProvideWhat' t) where

1381+ put (ProvTerm x1 x2) = do putWord8 0

1382+ put x1

1383+ put x2

1384+ put (ProvPostulate x1) = do putWord8 1

1385+ put x1

1386+ get = do y <- getWord8

1387+ case y of

1388+ 0 -> do x1 <- get

1389+ x2 <- get

1390+ return (ProvTerm x1 x2)

1391+ 1 -> do x1 <- get

1392+ return (ProvPostulate x1)

1393+ _ -> error "Corrupted binary data for ProvideWhat"

1394+

1335instance Binary Using where

1395instance Binary Using where

1336 put (UImplicit x1 x2) = do putWord8 0; put x1; put x2

1396 put (UImplicit x1 x2) = do putWord8 0; put x1; put x2

1337 put (UConstraint x1 x2) = do putWord8 1; put x1; put x2

1397 put (UConstraint x1 x2) = do putWord8 1; put x1; put x2

@@ -1340,6 +1400,7 @@ instance Binary Using where

1340 case i of

1400 case i of

1341 0 -> do x1 <- get; x2 <- get; return (UImplicit x1 x2)

1401 0 -> do x1 <- get; x2 <- get; return (UImplicit x1 x2)

1342 1 -> do x1 <- get; x2 <- get; return (UConstraint x1 x2)

1402 1 -> do x1 <- get; x2 <- get; return (UConstraint x1 x2)

1403+ _ -> error "Corrupted binary data for Using"

1343

1404

1344instance Binary SyntaxInfo where

1405instance Binary SyntaxInfo where

1345 put (Syn x1 x2 x3 x4 _ x5 x6 _ _ x7 _)

1406 put (Syn x1 x2 x3 x4 _ x5 x6 _ _ x7 _)

@@ -1370,23 +1431,25 @@ instance (Binary t) => Binary (PClause' t) where

1370 put x4

1431 put x4

1371 put x5

1432 put x5

1372 put x6

1433 put x6

1373− PWith x1 x2 x3 x4 x5 x6 -> do putWord8 1

1434+ PWith x1 x2 x3 x4 x5 x6 x7 -> do putWord8 1

1374− put x1

1435+ put x1

1375− put x2

1436+ put x2

1376− put x3

1437+ put x3

1377− put x4

1438+ put x4

1378− put x5

1439+ put x5

1379− put x6

1440+ put x6

1441+ put x7

1380 PClauseR x1 x2 x3 x4 -> do putWord8 2

1442 PClauseR x1 x2 x3 x4 -> do putWord8 2

1381 put x1

1443 put x1

1382 put x2

1444 put x2

1383 put x3

1445 put x3

1384 put x4

1446 put x4

1385− PWithR x1 x2 x3 x4 -> do putWord8 3

1447+ PWithR x1 x2 x3 x4 x5 -> do putWord8 3

1386− put x1

1448+ put x1

1387− put x2

1449+ put x2

1388− put x3

1450+ put x3

1389− put x4

1451+ put x4

1452+ put x5

1390 get

1453 get

1391 = do i <- getWord8

1454 = do i <- getWord8

1392 case i of

1455 case i of

@@ -1403,7 +1466,8 @@ instance (Binary t) => Binary (PClause' t) where

1403 x4 <- get

1466 x4 <- get

1404 x5 <- get

1467 x5 <- get

1405 x6 <- get

1468 x6 <- get

1469+ x7 <- get

1406− return (PWith x1 x2 x3 x4 x5 x6)

1470+ return (PWith x1 x2 x3 x4 x5 x6 x7)

1407 2 -> do x1 <- get

1471 2 -> do x1 <- get

1408 x2 <- get

1472 x2 <- get

1409 x3 <- get

1473 x3 <- get

@@ -1413,7 +1477,8 @@ instance (Binary t) => Binary (PClause' t) where

1413 x2 <- get

1477 x2 <- get

1414 x3 <- get

1478 x3 <- get

1415 x4 <- get

1479 x4 <- get

1480+ x5 <- get

1416− return (PWithR x1 x2 x3 x4)

1481+ return (PWithR x1 x2 x3 x4 x5)

1417 _ -> error "Corrupted binary data for PClause'"

1482 _ -> error "Corrupted binary data for PClause'"

1418

1483

1419instance (Binary t) => Binary (PData' t) where

1484instance (Binary t) => Binary (PData' t) where

@@ -1450,6 +1515,7 @@ instance Binary PunInfo where

1450 0 -> return TypeOrTerm

1515 0 -> return TypeOrTerm

1451 1 -> return IsType

1516 1 -> return IsType

1452 2 -> return IsTerm

1517 2 -> return IsTerm

1518+ _ -> error "Corrupted binary data for PunInfo"

1453

1519

1454instance Binary PTerm where

1520instance Binary PTerm where

1455 put x

1521 put x

@@ -1484,6 +1550,7 @@ instance Binary PTerm where

1484 PTyped x1 x2 -> do putWord8 7

1550 PTyped x1 x2 -> do putWord8 7

1485 put x1

1551 put x1

1486 put x2

1552 put x2

1553+ PAppImpl x1 x2 -> error "PAppImpl in final term"

1487 PApp x1 x2 x3 -> do putWord8 8

1554 PApp x1 x2 x3 -> do putWord8 8

1488 put x1

1555 put x1

1489 put x2

1556 put x2

@@ -1568,6 +1635,21 @@ instance Binary PTerm where

1568 put x2

1635 put x2

1569 PUniverse x1 -> do putWord8 38

1636 PUniverse x1 -> do putWord8 38

1570 put x1

1637 put x1

1638+ PRunTactics x1 x2 -> do putWord8 39

1639+ put x1

1640+ put x2

1641+ PAs x1 x2 x3 -> do putWord8 40

1642+ put x1

1643+ put x2

1644+ put x3

1645+ PElabError x1 -> do putWord8 41

1646+ put x1

1647+ PQuasiquote x1 x2 -> do putWord8 42

1648+ put x1

1649+ put x2

1650+ PUnquote x1 -> do putWord8 43

1651+ put x1

1652+

1571

1653

1572 get

1654 get

1573 = do i <- getWord8

1655 = do i <- getWord8

@@ -1686,6 +1768,20 @@ instance Binary PTerm where

1686 return (PDisamb x1 x2)

1768 return (PDisamb x1 x2)

1687 38 -> do x1 <- get

1769 38 -> do x1 <- get

1688 return (PUniverse x1)

1770 return (PUniverse x1)

1771+ 39 -> do x1 <- get

1772+ x2 <- get

1773+ return (PRunTactics x1 x2)

1774+ 40 -> do x1 <- get

1775+ x2 <- get

1776+ x3 <- get

1777+ return (PAs x1 x2 x3)

1778+ 41 -> do x1 <- get

1779+ return (PElabError x1)

1780+ 42 -> do x1 <- get

1781+ x2 <- get

1782+ return (PQuasiquote x1 x2)

1783+ 43 -> do x1 <- get

1784+ return (PUnquote x1)

1689 _ -> error "Corrupted binary data for PTerm"

1785 _ -> error "Corrupted binary data for PTerm"

1690

1786

1691instance (Binary t) => Binary (PTactic' t) where

1787instance (Binary t) => Binary (PTactic' t) where

@@ -1739,6 +1835,35 @@ instance (Binary t) => Binary (PTactic' t) where

1739 CaseTac x1 -> do putWord8 23

1835 CaseTac x1 -> do putWord8 23

1740 put x1

1836 put x1

1741 SourceFC -> putWord8 24

1837 SourceFC -> putWord8 24

1838+ Intros -> putWord8 25

1839+ Equiv x1 -> do putWord8 26

1840+ put x1

1841+ Claim x1 x2 -> do putWord8 27

1842+ put x1

1843+ put x2

1844+ Unfocus -> putWord8 28

1845+ MatchRefine x1 -> do putWord8 29

1846+ put x1

1847+ LetTacTy x1 x2 x3 -> do putWord8 30

1848+ put x1

1849+ put x2

1850+ put x3

1851+ TCInstance -> putWord8 31

1852+ GoalType x1 x2 -> do putWord8 32

1853+ put x1

1854+ put x2

1855+ TCheck x1 -> do putWord8 33

1856+ put x1

1857+ TEval x1 -> do putWord8 34

1858+ put x1

1859+ TDocStr x1 -> do putWord8 35

1860+ put x1

1861+ TSearch x1 -> do putWord8 36

1862+ put x1

1863+ Skip -> putWord8 37

1864+ TFail x1 -> do putWord8 38

1865+ put x1

1866+ Abandon -> putWord8 39

1742 get

1867 get

1743 = do i <- getWord8

1868 = do i <- getWord8

1744 case i of

1869 case i of

@@ -1790,6 +1915,35 @@ instance (Binary t) => Binary (PTactic' t) where

1790 23 -> do x1 <- get

1915 23 -> do x1 <- get

1791 return (CaseTac x1)

1916 return (CaseTac x1)

1792 24 -> return SourceFC

1917 24 -> return SourceFC

1918+ 25 -> return Intros

1919+ 26 -> do x1 <- get

1920+ return (Equiv x1)

1921+ 27 -> do x1 <- get

1922+ x2 <- get

1923+ return (Claim x1 x2)

1924+ 28 -> return Unfocus

1925+ 29 -> do x1 <- get

1926+ return (MatchRefine x1)

1927+ 30 -> do x1 <- get

1928+ x2 <- get

1929+ x3 <- get

1930+ return (LetTacTy x1 x2 x3)

1931+ 31 -> return TCInstance

1932+ 32 -> do x1 <- get

1933+ x2 <- get

1934+ return (GoalType x1 x2)

1935+ 33 -> do x1 <- get

1936+ return (TCheck x1)

1937+ 34 -> do x1 <- get

1938+ return (TEval x1)

1939+ 35 -> do x1 <- get

1940+ return (TDocStr x1)

1941+ 36 -> do x1 <- get

1942+ return (TSearch x1)

1943+ 37 -> return Skip

1944+ 38 -> do x1 <- get

1945+ return (TFail x1)

1946+ 39 -> return Abandon

1793 _ -> error "Corrupted binary data for PTactic'"

1947 _ -> error "Corrupted binary data for PTactic'"

1794

1948

1795

1949

src/Idris/IdeSlave.hs → src/Idris/IdeMode.hsrenamed+33−29

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

3{-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-}

5−module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable, Opt(..), ideSlaveEpoch, getLen, getNChar) where

5+module Idris.IdeMode(parseMessage, convSExp, IdeModeCommand(..), sexpToCommand, toSExp, SExp(..), SExpable, Opt(..), ideModeEpoch, getLen, getNChar) where

7import Text.Printf

8import Numeric

@@ -206,32 +206,33 @@ parseSExp = parseString pSExp (Directed (UTF8.fromString "(unknown)") 0 0 0 0)

206

207data Opt = ShowImpl | ErrContext deriving Show

208

209−data IdeSlaveCommand = REPLCompletions String

209+data IdeModeCommand = REPLCompletions String

210− | Interpret String

210+ | Interpret String

211− | TypeOf String

211+ | TypeOf String

212− | CaseSplit Int String

212+ | CaseSplit Int String

213− | AddClause Int String

213+ | AddClause Int String

214− | AddProofClause Int String

214+ | AddProofClause Int String

215− | AddMissing Int String

215+ | AddMissing Int String

216− | MakeWithBlock Int String

216+ | MakeWithBlock Int String

217− | ProofSearch Bool Int String [String] (Maybe Int) -- ^^ Recursive?, line, name, hints, depth

217+ | ProofSearch Bool Int String [String] (Maybe Int) -- ^^ Recursive?, line, name, hints, depth

218− | MakeLemma Int String

218+ | MakeLemma Int String

219− | LoadFile String (Maybe Int)

219+ | LoadFile String (Maybe Int)

220− | DocsFor String

220+ | DocsFor String

221− | Apropos String

221+ | Apropos String

222− | GetOpts

222+ | GetOpts

223− | SetOpt Opt Bool

223+ | SetOpt Opt Bool

224− | Metavariables Int -- ^^ the Int is the column count for pretty-printing

224+ | Metavariables Int -- ^^ the Int is the column count for pretty-printing

225− | WhoCalls String

225+ | WhoCalls String

226− | CallsWho String

226+ | CallsWho String

227− | TermNormalise [(Name, Bool)] Term

227+ | TermNormalise [(Name, Bool)] Term

228− | TermShowImplicits [(Name, Bool)] Term

228+ | TermShowImplicits [(Name, Bool)] Term

229− | TermNoImplicits [(Name, Bool)] Term

229+ | TermNoImplicits [(Name, Bool)] Term

230− | PrintDef String

230+ | PrintDef String

231− | ErrString Err

231+ | ErrString Err

232− | ErrPPrint Err

232+ | ErrPPrint Err

233−

233+ | GetIdrisVersion

234+

234−sexpToCommand :: SExp -> Maybe IdeSlaveCommand

235+sexpToCommand :: SExp -> Maybe IdeModeCommand

235sexpToCommand (SexpList (x:[])) = sexpToCommand x

236sexpToCommand (SexpList (x:[])) = sexpToCommand x

236sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd)

237sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd)

237sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix)

238sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix)

@@ -275,6 +276,7 @@ sexpToCommand (SexpList [SymbolAtom "hide-term-implicits", StringAtom encoded])

275sexpToCommand (SexpList [SymbolAtom "print-definition", StringAtom name]) = Just (PrintDef name)

276sexpToCommand (SexpList [SymbolAtom "print-definition", StringAtom name]) = Just (PrintDef name)

276sexpToCommand (SexpList [SymbolAtom "error-string", StringAtom encoded]) = Just . ErrString . decodeErr $ encoded

277sexpToCommand (SexpList [SymbolAtom "error-string", StringAtom encoded]) = Just . ErrString . decodeErr $ encoded

277sexpToCommand (SexpList [SymbolAtom "error-pprint", StringAtom encoded]) = Just . ErrPPrint . decodeErr $ encoded

278sexpToCommand (SexpList [SymbolAtom "error-pprint", StringAtom encoded]) = Just . ErrPPrint . decodeErr $ encoded

279+sexpToCommand (SymbolAtom "version") = Just GetIdrisVersion

278sexpToCommand _ = Nothing

280sexpToCommand _ = Nothing

279

281

280parseMessage :: String -> Either Err (SExp, Integer)

282parseMessage :: String -> Either Err (SExp, Integer)

@@ -298,5 +300,7 @@ convSExp pre s id =

298getHexLength :: String -> String

300getHexLength :: String -> String

299getHexLength s = printf "%06x" (1 + (length s))

301getHexLength s = printf "%06x" (1 + (length s))

300

302

301−ideSlaveEpoch :: Int

303+-- | The version of the IDE mode command set. Increment this when you

302−ideSlaveEpoch = 1

304+-- change it so clients can adapt.

305+ideModeEpoch :: Int

306+ideModeEpoch = 1

src/Idris/IdrisDoc.hs+1

@@ -318,6 +318,7 @@ extractPTermNames (PCoerced p) = extract p

318extractPTermNames (PDisamb _ p) = extract p

319extractPTermNames (PUnifyLog p) = extract p

320extractPTermNames (PNoImplicits p) = extract p

321+extractPTermNames (PRunTactics _ p) = extract p

321extractPTermNames _ = []

322extractPTermNames _ = []

322

323

323-- | Shorter name for extractPTermNames

324-- | Shorter name for extractPTermNames

src/Idris/Interactive.hs+3−3

@@ -16,7 +16,7 @@ import Idris.ElabTerm

16import Idris.Error

17import Idris.Delaborate

18import Idris.Output

19−import Idris.IdeSlave hiding (IdeSlaveCommand(..))

19+import Idris.IdeMode hiding (IdeModeCommand(..))

21import Idris.Elab.Value

@@ -271,7 +271,7 @@ makeLemma fn updatefile l n

271 runIO $ copyFile fb fn

272 else case idris_outputmode i of

273 RawOutput _ -> iPrintResult $ lem ++ "\n" ++ lem_app

274− IdeSlave n h ->

274+ IdeMode n h ->

275 let good = SexpList [SymbolAtom "ok",

276 SexpList [SymbolAtom "metavariable-lemma",

277 SexpList [SymbolAtom "replace-metavariable",

@@ -289,7 +289,7 @@ makeLemma fn updatefile l n

289 runIO $ copyFile fb fn

290 else case idris_outputmode i of

291 RawOutput _ -> iPrintResult $ lem_app

292− IdeSlave n h ->

292+ IdeMode n h ->

293 let good = SexpList [SymbolAtom "ok",

294 SexpList [SymbolAtom "provisional-definition-lemma",

295 SexpList [SymbolAtom "definition-clause",

src/Idris/Output.hs+24−22

@@ -8,7 +8,7 @@ import Idris.Core.Evaluate (isDConName, isTConName, isFnName, normaliseAll)

8import Idris.AbsSyntax

9import Idris.Delaborate

10import Idris.Docstrings

11−import Idris.IdeSlave

11+import Idris.IdeMode

13import Util.Pretty

14import Util.ScreenSize (getScreenWidth)

@@ -43,7 +43,7 @@ iWarn fc err =

43 then text (show fc) <> colon <//> err

44 else err

45 runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'

46− IdeSlave n h ->

46+ IdeMode n h ->

47 do err' <- iRender . fmap (fancifyAnnots i) $ err

48 let (str, spans) = displaySpans err'

49 runIO . hPutStrLn h $

@@ -52,8 +52,8 @@ iWarn fc err =

52iRender :: Doc a -> Idris (SimpleDoc a)

53iRender d = do w <- getWidth

54 ist <- getIState

55− let ideSlave = case idris_outputmode ist of

55+ let ideMode = case idris_outputmode ist of

56− IdeSlave _ _ -> True

56+ IdeMode _ _ -> True

57 _ -> False

58 case w of

59 InfinitelyWide -> return $ renderPretty 1.0 1000000000 d

@@ -61,7 +61,7 @@ iRender d = do w <- getWidth

61 if n < 1

62 then renderPretty 1.0 1000000000 d

63 else renderPretty 0.8 n d

64− AutomaticWidth | ideSlave -> return $ renderPretty 1.0 1000000000 d

64+ AutomaticWidth | ideMode -> return $ renderPretty 1.0 1000000000 d

65 | otherwise -> do width <- runIO getScreenWidth

66 return $ renderPretty 0.8 width d

@@ -76,7 +76,7 @@ consoleDisplayAnnotated h output = do ist <- getIState

76iPrintTermWithType :: Doc OutputAnnotation -> Doc OutputAnnotation -> Idris ()

77iPrintTermWithType tm ty = iRenderResult (tm <+> colon <+> align ty)

79−-- | Pretty-print a collection of overloadings to REPL or IDESlave - corresponds to :t name

79+-- | Pretty-print a collection of overloadings to REPL or IDEMode - corresponds to :t name

80iPrintFunTypes :: [(Name, Bool)] -> Name -> [(Name, Doc OutputAnnotation)] -> Idris ()

81iPrintFunTypes bnd n [] = iPrintError $ "No such variable " ++ show n

82iPrintFunTypes bnd n overloads = do ist <- getIState

@@ -94,7 +94,7 @@ iRenderOutput doc =

94 case idris_outputmode i of

95 RawOutput h -> do out <- iRender doc

96 runIO $ putStrLn (displayDecorated (consoleDecorate i) out)

97− IdeSlave n h ->

97+ IdeMode n h ->

98 do (str, spans) <- fmap displaySpans . iRender . fmap (fancifyAnnots i) $ doc

99 let out = [toSExp str, toSExp spans]

100 runIO . hPutStrLn h $ convSExp "write-decorated" out n

@@ -103,10 +103,10 @@ iRenderResult :: Doc OutputAnnotation -> Idris ()

103iRenderResult d = do ist <- getIState

104 case idris_outputmode ist of

105 RawOutput h -> consoleDisplayAnnotated h d

106− IdeSlave n h -> ideSlaveReturnAnnotated n h d

106+ IdeMode n h -> ideModeReturnAnnotated n h d

107

108−ideSlaveReturnWithStatus :: String -> Integer -> Handle -> Doc OutputAnnotation -> Idris ()

108+ideModeReturnWithStatus :: String -> Integer -> Handle -> Doc OutputAnnotation -> Idris ()

109−ideSlaveReturnWithStatus status n h out = do

109+ideModeReturnWithStatus status n h out = do

110 ist <- getIState

111 (str, spans) <- fmap displaySpans .

112 iRender .

@@ -116,16 +116,16 @@ ideSlaveReturnWithStatus status n h out = do

116 runIO . hPutStrLn h $ convSExp "return" good n

117

118

119−-- | Write pretty-printed output to IDESlave with semantic annotations

119+-- | Write pretty-printed output to IDEMode with semantic annotations

120−ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()

120+ideModeReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()

121−ideSlaveReturnAnnotated = ideSlaveReturnWithStatus "ok"

121+ideModeReturnAnnotated = ideModeReturnWithStatus "ok"

122

123-- | Show an error with semantic highlighting

124iRenderError :: Doc OutputAnnotation -> Idris ()

125iRenderError e = do ist <- getIState

126 case idris_outputmode ist of

127 RawOutput h -> consoleDisplayAnnotated h e

128− IdeSlave n h -> ideSlaveReturnWithStatus "error" n h e

128+ IdeMode n h -> ideModeReturnWithStatus "error" n h e

129

130iPrintWithStatus :: String -> String -> Idris ()

131iPrintWithStatus status s = do

@@ -134,7 +134,7 @@ iPrintWithStatus status s = do

134 RawOutput h -> case s of

135 "" -> return ()

136 s -> runIO $ hPutStrLn h s

137− IdeSlave n h ->

137+ IdeMode n h ->

138 let good = SexpList [SymbolAtom status, toSExp s] in

139 runIO $ hPutStrLn h $ convSExp "return" good n

140

@@ -149,21 +149,23 @@ iputStrLn :: String -> Idris ()

149iputStrLn s = do i <- getIState

150 case idris_outputmode i of

151 RawOutput h -> runIO $ hPutStrLn h s

152− IdeSlave n h -> runIO . hPutStrLn h $ convSExp "write-string" s n

152+ IdeMode n h -> runIO . hPutStrLn h $ convSExp "write-string" s n

153

154

155−ideslavePutSExp :: SExpable a => String -> a -> Idris ()

155+idemodePutSExp :: SExpable a => String -> a -> Idris ()

156−ideslavePutSExp cmd info = do i <- getIState

156+idemodePutSExp cmd info = do i <- getIState

157− case idris_outputmode i of

157+ case idris_outputmode i of

158+ IdeMode n h ->

159+ runIO . hPutStrLn h $

158− IdeSlave n h -> runIO . hPutStrLn h $ convSExp cmd info n

160+ convSExp cmd info n

159− _ -> return ()

161+ _ -> return ()

160

162

161-- TODO: send structured output similar to the metavariable list

163-- TODO: send structured output similar to the metavariable list

162iputGoal :: SimpleDoc OutputAnnotation -> Idris ()

164iputGoal :: SimpleDoc OutputAnnotation -> Idris ()

163iputGoal g = do i <- getIState

165iputGoal g = do i <- getIState

164 case idris_outputmode i of

166 case idris_outputmode i of

165 RawOutput h -> runIO $ hPutStrLn h (displayDecorated (consoleDecorate i) g)

167 RawOutput h -> runIO $ hPutStrLn h (displayDecorated (consoleDecorate i) g)

166− IdeSlave n h ->

168+ IdeMode n h ->

167 let (str, spans) = displaySpans . fmap (fancifyAnnots i) $ g

169 let (str, spans) = displaySpans . fmap (fancifyAnnots i) $ g

168 goal = [toSExp str, toSExp spans]

170 goal = [toSExp str, toSExp spans]

169 in runIO . hPutStrLn h $ convSExp "write-goal" goal n

171 in runIO . hPutStrLn h $ convSExp "write-goal" goal n

src/Idris/ParseExpr.hs+20−1

@@ -221,6 +221,7 @@ InternalExpr ::=

221internalExpr :: SyntaxInfo -> IdrisParser PTerm

222internalExpr syn =

223 unifyLog syn

224+ <|> runTactics syn

224 <|> disamb syn

225 <|> disamb syn

225 <|> noImplicits syn

226 <|> noImplicits syn

226 <|> recordType syn

227 <|> recordType syn

@@ -487,6 +488,19 @@ unifyLog syn = do try (lchar '%' *> reserved "unifyLog")

487 return (PUnifyLog tm)

488 return (PUnifyLog tm)

488 <?> "unification log expression"

489 <?> "unification log expression"

489

490

491+{- | Parses a new-style tactics expression

492+RunTactics ::=

493+ '%' 'runTactics' SimpleExpr

494+ ;

495+-}

496+runTactics :: SyntaxInfo -> IdrisParser PTerm

497+runTactics syn = do try (lchar '%' *> reserved "runTactics")

498+ fc <- getFC

499+ tm <- simpleExpr syn

500+ i <- get

501+ return $ PRunTactics fc tm

502+ <?> "new-style tactics expression"

503+

490{- | Parses a disambiguation expression

504{- | Parses a disambiguation expression

491Disamb ::=

505Disamb ::=

492 '%' 'disamb' NameList Expr

506 '%' 'disamb' NameList Expr

@@ -1251,10 +1265,15 @@ tactics =

1251 [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)

1265 [ (["intro"], Nothing, const $ -- FIXME syntax for intro (fresh name)

1252 do ns <- sepBy (spaced name) (lchar ','); return $ Intro ns)

1266 do ns <- sepBy (spaced name) (lchar ','); return $ Intro ns)

1253 , noArgs ["intros"] Intros

1267 , noArgs ["intros"] Intros

1268+ , noArgs ["unfocus"] Unfocus

1254 , (["refine"], Just ExprTArg, const $

1269 , (["refine"], Just ExprTArg, const $

1255 do n <- spaced fnName

1270 do n <- spaced fnName

1256 imps <- many imp

1271 imps <- many imp

1257 return $ Refine n imps)

1272 return $ Refine n imps)

1273+ , (["claim"], Nothing, \syn ->

1274+ do n <- indentPropHolds gtProp *> name

1275+ goal <- indentPropHolds gtProp *> expr syn

1276+ return $ Claim n goal)

1258 , (["mrefine"], Just ExprTArg, const $

1277 , (["mrefine"], Just ExprTArg, const $

1259 do n <- spaced fnName

1278 do n <- spaced fnName

1260 return $ MatchRefine n)

1279 return $ MatchRefine n)

@@ -1329,7 +1348,7 @@ tactics =

1329

1348

1330

1349

1331tactic :: SyntaxInfo -> IdrisParser PTactic

1350tactic :: SyntaxInfo -> IdrisParser PTactic

1332−tactic syn = choice [ do choice (map reserved names); parser syn

1351+tactic syn = choice [ do choice (map reserved names); parser syn

1333 | (names, _, parser) <- tactics ]

1352 | (names, _, parser) <- tactics ]

1334 <|> do lchar '{'

1353 <|> do lchar '{'

1335 t <- tactic syn;

1354 t <- tactic syn;

src/Idris/ParseHelpers.hs+16−16

@@ -105,30 +105,28 @@ isEol :: Char -> Bool

105isEol '\n' = True

106isEol _ = False

107

108+-- | A parser that succeeds at the end of the line

108eol :: MonadicParsing m => m ()

109eol :: MonadicParsing m => m ()

109eol = (satisfy isEol *> pure ()) <|> lookAhead eof <?> "end of line"

110eol = (satisfy isEol *> pure ()) <|> lookAhead eof <?> "end of line"

110

111

111{- | Consumes a single-line comment

112{- | Consumes a single-line comment

112

113

113@

114@

114− SingleLineComment_t ::= '--' EOL_t

115+ SingleLineComment_t ::= '--' ~EOL_t* EOL_t ;

115− | '--' ~DocCommentMarker_t ~EOL_t* EOL_t

116− ;

117@

116@

118 -}

117 -}

119singleLineComment :: MonadicParsing m => m ()

118singleLineComment :: MonadicParsing m => m ()

120−singleLineComment = try (string "--" *> eol *> pure ())

119+singleLineComment = (string "--" *>

121− <|> try (string "--" *> many simpleWhiteSpace *>

122− many (satisfy (not . isEol)) *>

120+ many (satisfy (not . isEol)) *>

123− eol *> pure ())

121+ eol *> pure ())

124− <?> ""

122+ <?> "single-line comment"

125

123

126{- | Consumes a multi-line comment

124{- | Consumes a multi-line comment

127

125

128@

126@

129 MultiLineComment_t ::=

127 MultiLineComment_t ::=

130 '{ -- }'

128 '{ -- }'

131− | '{ -' ~DocCommentMarker_t InCommentChars_t

129+ | '{ -' InCommentChars_t

132 ;

130 ;

133@

131@

134

132

@@ -154,7 +152,7 @@ multiLineComment = try (string "{-" *> (string "-}") *> pure ())

154 startEnd :: String

152 startEnd :: String

155 startEnd = "{}-"

153 startEnd = "{}-"

156

154

157−{-| Parses a documentation comment (similar to haddock) given a marker character

155+{-| Parses a documentation comment

158

156

159@

157@

160 DocComment_t ::= '|||' ~EOL_t* EOL_t

158 DocComment_t ::= '|||' ~EOL_t* EOL_t

@@ -224,7 +222,7 @@ float = Tok.double

224idrisStyle :: MonadicParsing m => IdentifierStyle m

222idrisStyle :: MonadicParsing m => IdentifierStyle m

225idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier

223idrisStyle = IdentifierStyle _styleName _styleStart _styleLetter _styleReserved Hi.Identifier Hi.ReservedIdentifier

226 where _styleName = "Idris"

224 where _styleName = "Idris"

227− _styleStart = satisfy isAlpha

225+ _styleStart = satisfy isAlpha <|> oneOf "_"

228 _styleLetter = satisfy isAlphaNum <|> oneOf "_'."

226 _styleLetter = satisfy isAlphaNum <|> oneOf "_'."

229 _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "corecord", "Type",

227 _styleReserved = HS.fromList ["let", "in", "data", "codata", "record", "corecord", "Type",

230 "do", "dsl", "import", "impossible",

228 "do", "dsl", "import", "impossible",

@@ -262,7 +260,9 @@ reservedOp name = token $ try $

262

260

263-- | Parses an identifier as a token

261-- | Parses an identifier as a token

264identifier :: MonadicParsing m => m String

262identifier :: MonadicParsing m => m String

265−identifier = token $ Tok.ident idrisStyle

263+identifier = try(do i <- token $ Tok.ident idrisStyle

264+ when (i == "_") $ unexpected "wildcard"

265+ return i)

266

267-- | Parses an identifier with possible namespace as a name

268iName :: MonadicParsing m => [String] -> m Name

@@ -562,17 +562,17 @@ collect (c@(PClauses _ o _ _) : ds)

562 where clauses :: Maybe Name -> [PClause] -> [PDecl] -> [PDecl]

563 clauses j@(Just n) acc (PClauses fc _ _ [PClause fc' n' l ws r w] : ds)

564 | n == n' = clauses j (PClause fc' n' l ws r (collect w) : acc) ds

565− clauses j@(Just n) acc (PClauses fc _ _ [PWith fc' n' l ws r w] : ds)

565+ clauses j@(Just n) acc (PClauses fc _ _ [PWith fc' n' l ws r pn w] : ds)

566− | n == n' = clauses j (PWith fc' n' l ws r (collect w) : acc) ds

566+ | n == n' = clauses j (PWith fc' n' l ws r pn (collect w) : acc) ds

567 clauses (Just n) acc xs = PClauses (fcOf c) o n (reverse acc) : collect xs

568 clauses Nothing acc (x:xs) = collect xs

569 clauses Nothing acc [] = []

570

571 cname :: PDecl -> Maybe Name

572 cname (PClauses fc _ _ [PClause _ n _ _ _ _]) = Just n

573− cname (PClauses fc _ _ [PWith _ n _ _ _ _]) = Just n

573+ cname (PClauses fc _ _ [PWith _ n _ _ _ _ _]) = Just n

574 cname (PClauses fc _ _ [PClauseR _ _ _ _]) = Nothing

575− cname (PClauses fc _ _ [PWithR _ _ _ _]) = Nothing

575+ cname (PClauses fc _ _ [PWithR _ _ _ _ _]) = Nothing

576 fcOf :: PDecl -> FC

577 fcOf (PClauses fc _ _ _) = fc

578collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds

src/Idris/Parser.hs+29−6

@@ -826,11 +826,12 @@ clause syn

826 popIndent

827 reserved "with"

828 wval <- simpleExpr syn

829+ pn <- optProof

829 openBlock

830 openBlock

830 ds <- some $ fnDecl syn

831 ds <- some $ fnDecl syn

831 let withs = concat ds

832 let withs = concat ds

832 closeBlock

833 closeBlock

833− return $ PWithR fc wargs wval withs)

834+ return $ PWithR fc wargs wval pn withs)

834 <|> do ty <- try (do pushIndent

835 <|> do ty <- try (do pushIndent

835 ty <- simpleExpr syn

836 ty <- simpleExpr syn

836 symbol "<=="

837 symbol "<=="

@@ -878,6 +879,7 @@ clause syn

878 popIndent

879 popIndent

879 reserved "with"

880 reserved "with"

880 wval <- bracketed syn

881 wval <- bracketed syn

882+ pn <- optProof

881 openBlock

883 openBlock

882 ds <- some $ fnDecl syn

884 ds <- some $ fnDecl syn

883 closeBlock

885 closeBlock

@@ -885,7 +887,7 @@ clause syn

885 let capp = PApp fc (PRef fc n) [pexp l, pexp r]

887 let capp = PApp fc (PRef fc n) [pexp l, pexp r]

886 let withs = map (fillLHSD n capp wargs) $ concat ds

888 let withs = map (fillLHSD n capp wargs) $ concat ds

887 put (ist { lastParse = Just n })

889 put (ist { lastParse = Just n })

888− return $ PWith fc n capp wargs wval withs)

890+ return $ PWith fc n capp wargs wval pn withs)

889 <|> do pushIndent

891 <|> do pushIndent

890 n_in <- fnName; let n = expandNS syn n_in

892 n_in <- fnName; let n = expandNS syn n_in

891 cargs <- many (constraintArg syn)

893 cargs <- many (constraintArg syn)

@@ -911,19 +913,24 @@ clause syn

911 ist <- get

913 ist <- get

912 put (ist { lastParse = Just n })

914 put (ist { lastParse = Just n })

913 wval <- bracketed syn

915 wval <- bracketed syn

916+ pn <- optProof

914 openBlock

917 openBlock

915 ds <- some $ fnDecl syn

918 ds <- some $ fnDecl syn

916 let withs = map (fillLHSD n capp wargs) $ concat ds

919 let withs = map (fillLHSD n capp wargs) $ concat ds

917 closeBlock

920 closeBlock

918 popIndent

921 popIndent

919− return $ PWith fc n capp wargs wval withs)

922+ return $ PWith fc n capp wargs wval pn withs)

920 <?> "function clause"

923 <?> "function clause"

921 where

924 where

925+ optProof = option Nothing (do reserved "proof"

926+ n <- fnName

927+ return (Just n))

928+

922 fillLHS :: Name -> PTerm -> [PTerm] -> PClause -> PClause

929 fillLHS :: Name -> PTerm -> [PTerm] -> PClause -> PClause

923 fillLHS n capp owargs (PClauseR fc wargs v ws)

930 fillLHS n capp owargs (PClauseR fc wargs v ws)

924 = PClause fc n capp (owargs ++ wargs) v ws

931 = PClause fc n capp (owargs ++ wargs) v ws

925− fillLHS n capp owargs (PWithR fc wargs v ws)

932+ fillLHS n capp owargs (PWithR fc wargs v pn ws)

926− = PWith fc n capp (owargs ++ wargs) v

933+ = PWith fc n capp (owargs ++ wargs) v pn

927 (map (fillLHSD n capp (owargs ++ wargs)) ws)

934 (map (fillLHSD n capp (owargs ++ wargs)) ws)

928 fillLHS _ _ _ c = c

935 fillLHS _ _ _ c = c

929

936

@@ -1192,7 +1199,7 @@ parseProg syn fname input mrk

1192 i <- getIState

1199 i <- getIState

1193 case idris_outputmode i of

1200 case idris_outputmode i of

1194 RawOutput h -> iputStrLn (show $ fixColour (idris_colourRepl i) doc)

1201 RawOutput h -> iputStrLn (show $ fixColour (idris_colourRepl i) doc)

1195− IdeSlave n h -> iWarn fc (P.text msg)

1202+ IdeMode n h -> iWarn fc (P.text msg)

1196 putIState (i { errSpan = Just fc })

1203 putIState (i { errSpan = Just fc })

1197 return []

1204 return []

1198 Success (x, i) -> do putIState i

1205 Success (x, i) -> do putIState i

@@ -1304,8 +1311,24 @@ loadSource lidr f toline

1304 mapM_ (addIBC . IBCImport) [(reexport, realName) | (reexport, realName, alias, fc) <- imports]

1311 mapM_ (addIBC . IBCImport) [(reexport, realName) | (reexport, realName, alias, fc) <- imports]

1305 let syntax = defaultSyntax{ syn_namespace = reverse mname,

1312 let syntax = defaultSyntax{ syn_namespace = reverse mname,

1306 maxline = toline }

1313 maxline = toline }

1314+ ist <- getIState

1315+ -- Save the span from parsing the module header, because

1316+ -- an empty program parse might obliterate it.

1317+ let oldSpan = idris_parsedSpan ist

1307 ds' <- parseProg syntax f file pos

1318 ds' <- parseProg syntax f file pos

1308

1319

1320+ case (ds', oldSpan) of

1321+ ([], Just fc) ->

1322+ -- If no program elements were parsed, we dind't

1323+ -- get a loaded region in the IBC file. That

1324+ -- means we need to add it back.

1325+ do ist <- getIState

1326+ putIState ist { idris_parsedSpan = oldSpan

1327+ , ibc_write = IBCParsedRegion fc :

1328+ ibc_write ist

1329+ }

1330+ _ -> return ()

1331+

1309 -- Parsing done, now process declarations

1332 -- Parsing done, now process declarations

1310

1333

1311 let ds = namespaces mname ds'

1334 let ds = namespaces mname ds'

src/Idris/Prover.hs+18−18

@@ -20,7 +20,7 @@ import Idris.Parser hiding (params)

20import Idris.Error

21import Idris.DataOpts

22import Idris.Completion

23−import qualified Idris.IdeSlave as IdeSlave

23+import qualified Idris.IdeMode as IdeMode

24import Idris.Output

25import Idris.TypeSearch (searchByType)

@@ -67,12 +67,12 @@ assumptionNames e

67prove :: Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()

68prove opt ctxt lit n ty

69 = do let ps = initElaborator n ctxt ty

70− ideslavePutSExp "start-proof-mode" n

70+ idemodePutSExp "start-proof-mode" n

71 (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, initEState) "" Nothing) Nothing

72 iLOG $ "Adding " ++ show tm

73 i <- getIState

74 case idris_outputmode i of

75− IdeSlave _ _ -> ideslavePutSExp "end-proof-mode" (n, showProof lit n prf)

75+ IdeMode _ _ -> idemodePutSExp "end-proof-mode" (n, showProof lit n prf)

76 _ -> iputStrLn $ showProof lit n prf

77 let proofs = proof_list i

78 putIState (i { proof_list = (n, prf) : proofs })

@@ -95,8 +95,8 @@ prove opt ctxt lit n ty

95 [([], P Ref n ty, ptm')] ty)

96 solveDeferred n

97 case idris_outputmode i of

98− IdeSlave n h ->

98+ IdeMode n h ->

99− runIO . hPutStrLn h $ IdeSlave.convSExp "return" (IdeSlave.SymbolAtom "ok", "") n

99+ runIO . hPutStrLn h $ IdeMode.convSExp "return" (IdeMode.SymbolAtom "ok", "") n

100 _ -> return ()

101

102elabStep :: ElabState EState -> ElabD a -> Idris (a, ElabState EState)

@@ -185,24 +185,24 @@ receiveInput :: Handle -> ElabState EState -> Idris (Maybe String)

185receiveInput h e =

186 do i <- getIState

187 let inh = if h == stdout then stdin else h

188− len' <- runIO $ IdeSlave.getLen inh

188+ len' <- runIO $ IdeMode.getLen inh

189 len <- case len' of

190 Left err -> ierror err

191 Right n -> return n

192− l <- runIO $ IdeSlave.getNChar inh len ""

192+ l <- runIO $ IdeMode.getNChar inh len ""

193− (sexp, id) <- case IdeSlave.parseMessage l of

193+ (sexp, id) <- case IdeMode.parseMessage l of

194 Left err -> ierror err

195 Right (sexp, id) -> return (sexp, id)

196− putIState $ i { idris_outputmode = (IdeSlave id h) }

196+ putIState $ i { idris_outputmode = (IdeMode id h) }

197− case IdeSlave.sexpToCommand sexp of

197+ case IdeMode.sexpToCommand sexp of

198− Just (IdeSlave.REPLCompletions prefix) ->

198+ Just (IdeMode.REPLCompletions prefix) ->

199 do (unused, compls) <- proverCompletion (assumptionNames e) (reverse prefix, "")

200− let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok", IdeSlave.toSExp (map replacement compls, reverse unused)]

200+ let good = IdeMode.SexpList [IdeMode.SymbolAtom "ok", IdeMode.toSExp (map replacement compls, reverse unused)]

201− ideslavePutSExp "return" good

201+ idemodePutSExp "return" good

202 receiveInput h e

203− Just (IdeSlave.Interpret cmd) -> return (Just cmd)

203+ Just (IdeMode.Interpret cmd) -> return (Just cmd)

204− Just (IdeSlave.TypeOf str) -> return (Just (":t " ++ str))

204+ Just (IdeMode.TypeOf str) -> return (Just (":t " ++ str))

205− Just (IdeSlave.DocsFor str) -> return (Just (":doc " ++ str))

205+ Just (IdeMode.DocsFor str) -> return (Just (":doc " ++ str))

206 _ -> return Nothing

207

208ploop :: Name -> Bool -> String -> [String] -> ElabState EState -> Maybe History -> Idris (Term, [String])

@@ -221,7 +221,7 @@ ploop fn d prompt prf e h

221 l <- getInputLine (prompt ++ "> ")

222 h' <- getHistory

223 return (l, Just h')

224− IdeSlave _ handle ->

224+ IdeMode _ handle ->

225 do isetPrompt prompt

226 i <- receiveInput handle e

227 return (i, h)

@@ -254,7 +254,7 @@ ploop fn d prompt prf e h

254 (_, st) <- elabStep e (runTac autoSolve i (Just proverFC) fn tac)

255 return (True, st, False, prf ++ [step], Right $ iPrintResult ""))

256 (\err -> return (False, e, False, prf, Left err))

257− ideslavePutSExp "write-proof-state" (prf', length prf')

257+ idemodePutSExp "write-proof-state" (prf', length prf')

258 case res of

259 Left err -> do ist <- getIState

260 iRenderError $ pprintErr ist err

src/Idris/REPL.hs+190−175

@@ -22,7 +22,7 @@ import Idris.Primitives

22import Idris.Coverage

23import Idris.Docs hiding (Doc)

24import Idris.Completion

25−import qualified Idris.IdeSlave as IdeSlave

25+import qualified Idris.IdeMode as IdeMode

26import Idris.Chaser

27import Idris.Imports

28import Idris.Colours hiding (colourise)

@@ -165,7 +165,7 @@ startServer port orig fn_in = do tid <- runIO $ forkOS (serverLoop port)

165 cmd <- hGetLine h

166 let isth = case idris_outputmode ist of

167 RawOutput _ -> ist {idris_outputmode = RawOutput h}

168− IdeSlave n _ -> ist {idris_outputmode = IdeSlave n h}

168+ IdeMode n _ -> ist {idris_outputmode = IdeMode n h}

169 (ist', fn) <- processNetCmd orig isth h fn cmd

170 hClose h

171 loop fn ist' sock

@@ -204,7 +204,7 @@ processNetCmd orig i h fn cmd

204 do ist <- getIState

205 putIState $ case idris_outputmode ist of

206 RawOutput _ -> ist {idris_outputmode = RawOutput h}

207− IdeSlave n _ -> ist {idris_outputmode = IdeSlave n h}

207+ IdeMode n _ -> ist {idris_outputmode = IdeMode n h}

208

209-- | Run a command on the server on localhost

210runClient :: PortID -> String -> IO ()

@@ -232,62 +232,62 @@ runClient port str = withSocketsDo $ do

232 putStrLn "Unable to connect to a running Idris repl"

233

234

235−initIdeslaveSocket :: IO Handle

235+initIdemodeSocket :: IO Handle

236−initIdeslaveSocket = do

236+initIdemodeSocket = do

237 (sock, port) <- listenOnLocalhostAnyPort

238 putStrLn $ show port

239 (h, _, _) <- accept sock

240 hSetEncoding h utf8

241 return h

242

243−-- | Run the IdeSlave

243+-- | Run the IdeMode

244−ideslaveStart :: Bool -> IState -> [FilePath] -> Idris ()

244+idemodeStart :: Bool -> IState -> [FilePath] -> Idris ()

245−ideslaveStart s orig mods

245+idemodeStart s orig mods

246− = do h <- runIO $ if s then initIdeslaveSocket else return stdout

246+ = do h <- runIO $ if s then initIdemodeSocket else return stdout

247− setIdeSlave True h

247+ setIdeMode True h

248 i <- getIState

249 case idris_outputmode i of

250− IdeSlave n h ->

250+ IdeMode n h ->

251− do runIO $ hPutStrLn h $ IdeSlave.convSExp "protocol-version" IdeSlave.ideSlaveEpoch n

251+ do runIO $ hPutStrLn h $ IdeMode.convSExp "protocol-version" IdeMode.ideModeEpoch n

252 case mods of

253− a:_ -> runIdeSlaveCommand h n i "" [] (IdeSlave.LoadFile a Nothing)

253+ a:_ -> runIdeModeCommand h n i "" [] (IdeMode.LoadFile a Nothing)

254 _ -> return ()

255− ideslave h orig mods

255+ idemode h orig mods

256

257−ideslave :: Handle -> IState -> [FilePath] -> Idris ()

257+idemode :: Handle -> IState -> [FilePath] -> Idris ()

258−ideslave h orig mods

258+idemode h orig mods

259 = do idrisCatch

260 (do let inh = if h == stdout then stdin else h

261− len' <- runIO $ IdeSlave.getLen inh

261+ len' <- runIO $ IdeMode.getLen inh

262 len <- case len' of

263 Left err -> ierror err

264 Right n -> return n

265− l <- runIO $ IdeSlave.getNChar inh len ""

265+ l <- runIO $ IdeMode.getNChar inh len ""

266− (sexp, id) <- case IdeSlave.parseMessage l of

266+ (sexp, id) <- case IdeMode.parseMessage l of

267 Left err -> ierror err

268 Right (sexp, id) -> return (sexp, id)

269 i <- getIState

270− putIState $ i { idris_outputmode = (IdeSlave id h) }

270+ putIState $ i { idris_outputmode = (IdeMode id h) }

271 idrisCatch -- to report correct id back!

272 (do let fn = case mods of

273 (f:_) -> f

274 _ -> ""

275− case IdeSlave.sexpToCommand sexp of

275+ case IdeMode.sexpToCommand sexp of

276− Just cmd -> runIdeSlaveCommand h id orig fn mods cmd

276+ Just cmd -> runIdeModeCommand h id orig fn mods cmd

277 Nothing -> iPrintError "did not understand" )

278 (\e -> do iPrintError $ show e))

279 (\e -> do iPrintError $ show e)

280− ideslave h orig mods

280+ idemode h orig mods

281

282−-- | Run IDESlave commands

282+-- | Run IDEMode commands

283−runIdeSlaveCommand :: Handle -- ^^ The handle for communication

283+runIdeModeCommand :: Handle -- ^^ The handle for communication

284 -> Integer -- ^^ The continuation ID for the client

285 -> IState -- ^^ The original IState

286 -> FilePath -- ^^ The current open file

287 -> [FilePath] -- ^^ The currently loaded modules

288− -> IdeSlave.IdeSlaveCommand -- ^^ The command to process

288+ -> IdeMode.IdeModeCommand -- ^^ The command to process

289 -> Idris ()

290−runIdeSlaveCommand h id orig fn mods (IdeSlave.Interpret cmd) =

290+runIdeModeCommand h id orig fn mods (IdeMode.Interpret cmd) =

291 do c <- colourise

292 i <- getIState

293 case parseCmd i "(input)" cmd of

@@ -297,96 +297,96 @@ runIdeSlaveCommand h id orig fn mods (IdeSlave.Interpret cmd) =

297 (do process fn (Prove n')

298 isetPrompt (mkPrompt mods)

299 case idris_outputmode i of

300− IdeSlave n h -> -- signal completion of proof to ide

300+ IdeMode n h -> -- signal completion of proof to ide

301 runIO . hPutStrLn h $

302− IdeSlave.convSExp "return"

302+ IdeMode.convSExp "return"

303− (IdeSlave.SymbolAtom "ok", "")

303+ (IdeMode.SymbolAtom "ok", "")

304 n

305 _ -> return ())

306 (\e -> do ist <- getIState

307 isetPrompt (mkPrompt mods)

308 case idris_outputmode i of

309− IdeSlave n h ->

309+ IdeMode n h ->

310 runIO . hPutStrLn h $

311− IdeSlave.convSExp "abandon-proof" "Abandoned" n

311+ IdeMode.convSExp "abandon-proof" "Abandoned" n

312 _ -> return ()

313 iRenderError $ pprintErr ist e)

314 Success (Right cmd) -> idrisCatch

315− (ideslaveProcess fn cmd)

315+ (idemodeProcess fn cmd)

316 (\e -> getIState >>= iRenderError . flip pprintErr e)

317 Success (Left err) -> iPrintError err

318−runIdeSlaveCommand h id orig fn mods (IdeSlave.REPLCompletions str) =

318+runIdeModeCommand h id orig fn mods (IdeMode.REPLCompletions str) =

319 do (unused, compls) <- replCompletion (reverse str, "")

320− let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",

320+ let good = IdeMode.SexpList [IdeMode.SymbolAtom "ok",

321− IdeSlave.toSExp (map replacement compls,

321+ IdeMode.toSExp (map replacement compls,

322 reverse unused)]

323− runIO . hPutStrLn h $ IdeSlave.convSExp "return" good id

323+ runIO . hPutStrLn h $ IdeMode.convSExp "return" good id

324−runIdeSlaveCommand h id orig fn mods (IdeSlave.LoadFile filename toline) =

324+runIdeModeCommand h id orig fn mods (IdeMode.LoadFile filename toline) =

325 do i <- getIState

326 clearErr

327 putIState (orig { idris_options = idris_options i,

328− idris_outputmode = (IdeSlave id h) })

328+ idris_outputmode = (IdeMode id h) })

329 mods <- loadInputs [filename] toline

330 isetPrompt (mkPrompt mods)

331 -- Report either success or failure

332 i <- getIState

333 case (errSpan i) of

334− Nothing -> let msg = maybe (IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",

334+ Nothing -> let msg = maybe (IdeMode.SexpList [IdeMode.SymbolAtom "ok",

335− IdeSlave.SexpList []])

335+ IdeMode.SexpList []])

336− (\fc -> IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",

336+ (\fc -> IdeMode.SexpList [IdeMode.SymbolAtom "ok",

337− IdeSlave.toSExp fc])

337+ IdeMode.toSExp fc])

338 (idris_parsedSpan i)

339− in runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id

339+ in runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

340 Just x -> iPrintError $ "didn't load " ++ filename

341− ideslave h orig mods

341+ idemode h orig mods

342−runIdeSlaveCommand h id orig fn mods (IdeSlave.TypeOf name) =

342+runIdeModeCommand h id orig fn mods (IdeMode.TypeOf name) =

343 case splitName name of

344 Left err -> iPrintError err

345− Right n -> process "(ideslave)"

345+ Right n -> process "(idemode)"

346− (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))

346+ (Check (PRef (FC "(idemode)" (0,0) (0,0)) n))

347−runIdeSlaveCommand h id orig fn mods (IdeSlave.DocsFor name) =

347+runIdeModeCommand h id orig fn mods (IdeMode.DocsFor name) =

348 case parseConst orig name of

349− Success c -> process "(ideslave)" (DocStr (Right c))

349+ Success c -> process "(idemode)" (DocStr (Right c))

350 Failure _ ->

351 case splitName name of

352 Left err -> iPrintError err

353− Right n -> process "(ideslave)" (DocStr (Left n))

353+ Right n -> process "(idemode)" (DocStr (Left n))

354−runIdeSlaveCommand h id orig fn mods (IdeSlave.CaseSplit line name) =

354+runIdeModeCommand h id orig fn mods (IdeMode.CaseSplit line name) =

355 process fn (CaseSplitAt False line (sUN name))

356−runIdeSlaveCommand h id orig fn mods (IdeSlave.AddClause line name) =

356+runIdeModeCommand h id orig fn mods (IdeMode.AddClause line name) =

357 process fn (AddClauseFrom False line (sUN name))

358−runIdeSlaveCommand h id orig fn mods (IdeSlave.AddProofClause line name) =

358+runIdeModeCommand h id orig fn mods (IdeMode.AddProofClause line name) =

359 process fn (AddProofClauseFrom False line (sUN name))

360−runIdeSlaveCommand h id orig fn mods (IdeSlave.AddMissing line name) =

360+runIdeModeCommand h id orig fn mods (IdeMode.AddMissing line name) =

361 process fn (AddMissing False line (sUN name))

362−runIdeSlaveCommand h id orig fn mods (IdeSlave.MakeWithBlock line name) =

362+runIdeModeCommand h id orig fn mods (IdeMode.MakeWithBlock line name) =

363 process fn (MakeWith False line (sUN name))

364−runIdeSlaveCommand h id orig fn mods (IdeSlave.ProofSearch r line name hints depth) =

364+runIdeModeCommand h id orig fn mods (IdeMode.ProofSearch r line name hints depth) =

365 doProofSearch fn False r line (sUN name) (map sUN hints) depth

366−runIdeSlaveCommand h id orig fn mods (IdeSlave.MakeLemma line name) =

366+runIdeModeCommand h id orig fn mods (IdeMode.MakeLemma line name) =

367 case splitName name of

368 Left err -> iPrintError err

369 Right n -> process fn (MakeLemma False line n)

370−runIdeSlaveCommand h id orig fn mods (IdeSlave.Apropos a) =

370+runIdeModeCommand h id orig fn mods (IdeMode.Apropos a) =

371 process fn (Apropos [] a)

372−runIdeSlaveCommand h id orig fn mods (IdeSlave.GetOpts) =

372+runIdeModeCommand h id orig fn mods (IdeMode.GetOpts) =

373 do ist <- getIState

374 let opts = idris_options ist

375 let impshow = opt_showimp opts

376 let errCtxt = opt_errContext opts

377− let options = (IdeSlave.SymbolAtom "ok",

377+ let options = (IdeMode.SymbolAtom "ok",

378− [(IdeSlave.SymbolAtom "show-implicits", impshow),

378+ [(IdeMode.SymbolAtom "show-implicits", impshow),

379− (IdeSlave.SymbolAtom "error-context", errCtxt)])

379+ (IdeMode.SymbolAtom "error-context", errCtxt)])

380− runIO . hPutStrLn h $ IdeSlave.convSExp "return" options id

380+ runIO . hPutStrLn h $ IdeMode.convSExp "return" options id

381−runIdeSlaveCommand h id orig fn mods (IdeSlave.SetOpt IdeSlave.ShowImpl b) =

381+runIdeModeCommand h id orig fn mods (IdeMode.SetOpt IdeMode.ShowImpl b) =

382 do setImpShow b

383− let msg = (IdeSlave.SymbolAtom "ok", b)

383+ let msg = (IdeMode.SymbolAtom "ok", b)

384− runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id

384+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

385−runIdeSlaveCommand h id orig fn mods (IdeSlave.SetOpt IdeSlave.ErrContext b) =

385+runIdeModeCommand h id orig fn mods (IdeMode.SetOpt IdeMode.ErrContext b) =

386 do setErrContext b

387− let msg = (IdeSlave.SymbolAtom "ok", b)

387+ let msg = (IdeMode.SymbolAtom "ok", b)

388− runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id

388+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

389−runIdeSlaveCommand h id orig fn mods (IdeSlave.Metavariables cols) =

389+runIdeModeCommand h id orig fn mods (IdeMode.Metavariables cols) =

390 do ist <- getIState

391 let mvs = reverse $ map fst (idris_metavars ist) \\ primDefs

392 let ppo = ppOptionIst ist

@@ -403,7 +403,7 @@ runIdeSlaveCommand h id orig fn mods (IdeSlave.Metavariables cols) =

403 render ist bnd c pc))

404 splitMvs

405 runIO . hPutStrLn h $

406− IdeSlave.convSExp "return" (IdeSlave.SymbolAtom "ok", mvOutput) id

406+ IdeMode.convSExp "return" (IdeMode.SymbolAtom "ok", mvOutput) id

407 where mapPair f g xs = zip (map (f . fst) xs) (map (g . snd) xs)

408 mapSnd f xs = zip (map fst xs) (map (f . snd) xs)

409

@@ -447,32 +447,32 @@ runIdeSlaveCommand h id orig fn mods (IdeSlave.Metavariables cols) =

447 let (out, spans) = render ist bnd t pt in

448 (show n , out, spans)

449

450−runIdeSlaveCommand h id orig fn mods (IdeSlave.WhoCalls n) =

450+runIdeModeCommand h id orig fn mods (IdeMode.WhoCalls n) =

451 case splitName n of

452 Left err -> iPrintError err

453 Right n -> do calls <- whoCalls n

454 ist <- getIState

455− let msg = (IdeSlave.SymbolAtom "ok",

455+ let msg = (IdeMode.SymbolAtom "ok",

456 map (\ (n,ns) -> (pn ist n, map (pn ist) ns)) calls)

457− runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id

457+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

458 where pn ist = displaySpans .

459 renderPretty 0.9 1000 .

460 fmap (fancifyAnnots ist) .

461 prettyName True True []

462−runIdeSlaveCommand h id orig fn mods (IdeSlave.CallsWho n) =

462+runIdeModeCommand h id orig fn mods (IdeMode.CallsWho n) =

463 case splitName n of

464 Left err -> iPrintError err

465 Right n -> do calls <- callsWho n

466 ist <- getIState

467− let msg = (IdeSlave.SymbolAtom "ok",

467+ let msg = (IdeMode.SymbolAtom "ok",

468 map (\ (n,ns) -> (pn ist n, map (pn ist) ns)) calls)

469− runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id

469+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

470 where pn ist = displaySpans .

471 renderPretty 0.9 1000 .

472 fmap (fancifyAnnots ist) .

473 prettyName True True []

474

475−runIdeSlaveCommand h id orig fn modes (IdeSlave.TermNormalise bnd tm) =

475+runIdeModeCommand h id orig fn modes (IdeMode.TermNormalise bnd tm) =

476 do ctxt <- getContext

477 ist <- getIState

478 let tm' = force (normaliseAll ctxt [] tm)

@@ -482,46 +482,54 @@ runIdeSlaveCommand h id orig fn modes (IdeSlave.TermNormalise bnd tm) =

482 []

483 (idris_infixes ist)

484 (delab ist tm'))

485− msg = (IdeSlave.SymbolAtom "ok",

485+ msg = (IdeMode.SymbolAtom "ok",

486 displaySpans .

487 renderPretty 0.9 80 .

488 fmap (fancifyAnnots ist) $ ptm)

489− runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id

489+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

490−runIdeSlaveCommand h id orig fn modes (IdeSlave.TermShowImplicits bnd tm) =

490+runIdeModeCommand h id orig fn modes (IdeMode.TermShowImplicits bnd tm) =

491− ideSlaveForceTermImplicits h id bnd True tm

491+ ideModeForceTermImplicits h id bnd True tm

492−runIdeSlaveCommand h id orig fn modes (IdeSlave.TermNoImplicits bnd tm) =

492+runIdeModeCommand h id orig fn modes (IdeMode.TermNoImplicits bnd tm) =

493− ideSlaveForceTermImplicits h id bnd False tm

493+ ideModeForceTermImplicits h id bnd False tm

494−runIdeSlaveCommand h id orig fn mods (IdeSlave.PrintDef name) =

494+runIdeModeCommand h id orig fn mods (IdeMode.PrintDef name) =

495 case splitName name of

496 Left err -> iPrintError err

497− Right n -> process "(ideslave)" (PrintDef n)

497+ Right n -> process "(idemode)" (PrintDef n)

498−runIdeSlaveCommand h id orig fn modes (IdeSlave.ErrString e) =

498+runIdeModeCommand h id orig fn modes (IdeMode.ErrString e) =

499 do ist <- getIState

500 let out = displayS . renderPretty 1.0 60 $ pprintErr ist e

501− msg = (IdeSlave.SymbolAtom "ok", IdeSlave.StringAtom $ out "")

501+ msg = (IdeMode.SymbolAtom "ok", IdeMode.StringAtom $ out "")

502− runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id

502+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

503−runIdeSlaveCommand h id orig fn modes (IdeSlave.ErrPPrint e) =

503+runIdeModeCommand h id orig fn modes (IdeMode.ErrPPrint e) =

504 do ist <- getIState

505 let (out, spans) =

506 displaySpans .

507 renderPretty 0.9 80 .

508 fmap (fancifyAnnots ist) $ pprintErr ist e

509− msg = (IdeSlave.SymbolAtom "ok", out, spans)

509+ msg = (IdeMode.SymbolAtom "ok", out, spans)

510+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

511+runIdeModeCommand h id orig fn modes IdeMode.GetIdrisVersion =

512+ let idrisVersion = (versionBranch version,

513+ if not (null gitHash)

514+ then [gitHash]

515+ else [])

516+ msg = (IdeMode.SymbolAtom "ok", idrisVersion)

510− runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id

517+ in runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

511−

518+

519+

512−-- | Show a term for IDESlave with the specified implicitness

520+-- | Show a term for IDEMode with the specified implicitness

513−ideSlaveForceTermImplicits :: Handle -> Integer -> [(Name, Bool)] -> Bool -> Term -> Idris ()

521+ideModeForceTermImplicits :: Handle -> Integer -> [(Name, Bool)] -> Bool -> Term -> Idris ()

514−ideSlaveForceTermImplicits h id bnd impl tm =

522+ideModeForceTermImplicits h id bnd impl tm =

515 do ist <- getIState

523 do ist <- getIState

516 let expl = annotate (AnnTerm bnd tm)

524 let expl = annotate (AnnTerm bnd tm)

517 (pprintPTerm ((ppOptionIst ist) { ppopt_impl = impl })

525 (pprintPTerm ((ppOptionIst ist) { ppopt_impl = impl })

518 bnd [] (idris_infixes ist)

526 bnd [] (idris_infixes ist)

519 (delab ist tm))

527 (delab ist tm))

520− msg = (IdeSlave.SymbolAtom "ok",

528+ msg = (IdeMode.SymbolAtom "ok",

521 displaySpans .

529 displaySpans .

522 renderPretty 0.9 80 .

530 renderPretty 0.9 80 .

523 fmap (fancifyAnnots ist) $ expl)

531 fmap (fancifyAnnots ist) $ expl)

524− runIO . hPutStrLn h $ IdeSlave.convSExp "return" msg id

532+ runIO . hPutStrLn h $ IdeMode.convSExp "return" msg id

525

533

526splitName :: String -> Either String Name

534splitName :: String -> Either String Name

527splitName s = case reverse $ splitOn "." s of

535splitName s = case reverse $ splitOn "." s of

@@ -532,75 +540,76 @@ splitName s = case reverse $ splitOn "." s of

532 unparen ('(':x:xs) | last xs == ')' = init (x:xs)

540 unparen ('(':x:xs) | last xs == ')' = init (x:xs)

533 unparen str = str

541 unparen str = str

534

542

535−ideslaveProcess :: FilePath -> Command -> Idris ()

543+idemodeProcess :: FilePath -> Command -> Idris ()

536−ideslaveProcess fn Warranty = process fn Warranty

544+idemodeProcess fn Warranty = process fn Warranty

537−ideslaveProcess fn Help = process fn Help

545+idemodeProcess fn Help = process fn Help

538−ideslaveProcess fn (ChangeDirectory f) = do process fn (ChangeDirectory f)

546+idemodeProcess fn (ChangeDirectory f) = do process fn (ChangeDirectory f)

539− iPrintResult "changed directory to"

547+ iPrintResult "changed directory to"

548+idemodeProcess fn (ModImport f) = process fn (ModImport f)

540−ideslaveProcess fn (Eval t) = process fn (Eval t)

549+idemodeProcess fn (Eval t) = process fn (Eval t)

541−ideslaveProcess fn (NewDefn decls) = do process fn (NewDefn decls)

550+idemodeProcess fn (NewDefn decls) = do process fn (NewDefn decls)

542− iPrintResult "defined"

551+ iPrintResult "defined"

543−ideslaveProcess fn (Undefine n) = process fn (Undefine n)

552+idemodeProcess fn (Undefine n) = process fn (Undefine n)

544−ideslaveProcess fn (ExecVal t) = process fn (ExecVal t)

553+idemodeProcess fn (ExecVal t) = process fn (ExecVal t)

545−ideslaveProcess fn (Check (PRef x n)) = process fn (Check (PRef x n))

554+idemodeProcess fn (Check (PRef x n)) = process fn (Check (PRef x n))

546−ideslaveProcess fn (Check t) = process fn (Check t)

555+idemodeProcess fn (Check t) = process fn (Check t)

547−ideslaveProcess fn (DocStr n) = process fn (DocStr n)

556+idemodeProcess fn (DocStr n) = process fn (DocStr n)

548−ideslaveProcess fn Universes = process fn Universes

557+idemodeProcess fn Universes = process fn Universes

549−ideslaveProcess fn (Defn n) = do process fn (Defn n)

558+idemodeProcess fn (Defn n) = do process fn (Defn n)

550− iPrintResult ""

551−ideslaveProcess fn (TotCheck n) = process fn (TotCheck n)

552−ideslaveProcess fn (DebugInfo n) = do process fn (DebugInfo n)

553− iPrintResult ""

554−ideslaveProcess fn (Search ps t) = process fn (Search ps t)

555−ideslaveProcess fn (Spec t) = process fn (Spec t)

556−-- RmProof and AddProof not supported!

557−ideslaveProcess fn (ShowProof n') = process fn (ShowProof n')

558−ideslaveProcess fn (HNF t) = process fn (HNF t)

559−--ideslaveProcess fn TTShell = process fn TTShell -- need some prove mode!

560−ideslaveProcess fn (TestInline t) = process fn (TestInline t)

561−

562−ideslaveProcess fn Execute = do process fn Execute

563 iPrintResult ""

559 iPrintResult ""

560+idemodeProcess fn (TotCheck n) = process fn (TotCheck n)

561+idemodeProcess fn (DebugInfo n) = do process fn (DebugInfo n)

562+ iPrintResult ""

563+idemodeProcess fn (Search ps t) = process fn (Search ps t)

564+idemodeProcess fn (Spec t) = process fn (Spec t)

565+-- RmProof and AddProof not supported!

566+idemodeProcess fn (ShowProof n') = process fn (ShowProof n')

567+idemodeProcess fn (HNF t) = process fn (HNF t)

568+--idemodeProcess fn TTShell = process fn TTShell -- need some prove mode!

569+idemodeProcess fn (TestInline t) = process fn (TestInline t)

570+

571+idemodeProcess fn Execute = do process fn Execute

572+ iPrintResult ""

564−ideslaveProcess fn (Compile codegen f) = do process fn (Compile codegen f)

573+idemodeProcess fn (Compile codegen f) = do process fn (Compile codegen f)

565− iPrintResult ""

574+ iPrintResult ""

566−ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i)

575+idemodeProcess fn (LogLvl i) = do process fn (LogLvl i)

576+ iPrintResult ""

577+idemodeProcess fn (Pattelab t) = process fn (Pattelab t)

578+idemodeProcess fn (Missing n) = process fn (Missing n)

579+idemodeProcess fn (DynamicLink l) = do process fn (DynamicLink l)

580+ iPrintResult ""

581+idemodeProcess fn ListDynamic = do process fn ListDynamic

567 iPrintResult ""

582 iPrintResult ""

568−ideslaveProcess fn (Pattelab t) = process fn (Pattelab t)

569−ideslaveProcess fn (Missing n) = process fn (Missing n)

570−ideslaveProcess fn (DynamicLink l) = do process fn (DynamicLink l)

571− iPrintResult ""

572−ideslaveProcess fn ListDynamic = do process fn ListDynamic

573− iPrintResult ""

574−ideslaveProcess fn Metavars = process fn Metavars

583+idemodeProcess fn Metavars = process fn Metavars

575−ideslaveProcess fn (SetOpt ErrContext) = do process fn (SetOpt ErrContext)

584+idemodeProcess fn (SetOpt ErrContext) = do process fn (SetOpt ErrContext)

576− iPrintResult ""

585+ iPrintResult ""

577−ideslaveProcess fn (UnsetOpt ErrContext) = do process fn (UnsetOpt ErrContext)

586+idemodeProcess fn (UnsetOpt ErrContext) = do process fn (UnsetOpt ErrContext)

578− iPrintResult ""

579−ideslaveProcess fn (SetOpt ShowImpl) = do process fn (SetOpt ShowImpl)

580− iPrintResult ""

581−ideslaveProcess fn (UnsetOpt ShowImpl) = do process fn (UnsetOpt ShowImpl)

582− iPrintResult ""

583−ideslaveProcess fn (SetOpt ShowOrigErr) = do process fn (SetOpt ShowOrigErr)

584 iPrintResult ""

587 iPrintResult ""

585−ideslaveProcess fn (UnsetOpt ShowOrigErr) = do process fn (UnsetOpt ShowOrigErr)

588+idemodeProcess fn (SetOpt ShowImpl) = do process fn (SetOpt ShowImpl)

586− iPrintResult ""

589+ iPrintResult ""

587−ideslaveProcess fn (SetOpt x) = process fn (SetOpt x)

590+idemodeProcess fn (UnsetOpt ShowImpl) = do process fn (UnsetOpt ShowImpl)

588−ideslaveProcess fn (UnsetOpt x) = process fn (UnsetOpt x)

591+ iPrintResult ""

589−ideslaveProcess fn (CaseSplitAt False pos str) = process fn (CaseSplitAt False pos str)

592+idemodeProcess fn (SetOpt ShowOrigErr) = do process fn (SetOpt ShowOrigErr)

590−ideslaveProcess fn (AddProofClauseFrom False pos str) = process fn (AddProofClauseFrom False pos str)

591−ideslaveProcess fn (AddClauseFrom False pos str) = process fn (AddClauseFrom False pos str)

592−ideslaveProcess fn (AddMissing False pos str) = process fn (AddMissing False pos str)

593−ideslaveProcess fn (MakeWith False pos str) = process fn (MakeWith False pos str)

594−ideslaveProcess fn (DoProofSearch False r pos str xs) = process fn (DoProofSearch False r pos str xs)

595−ideslaveProcess fn (SetConsoleWidth w) = do process fn (SetConsoleWidth w)

596 iPrintResult ""

593 iPrintResult ""

594+idemodeProcess fn (UnsetOpt ShowOrigErr) = do process fn (UnsetOpt ShowOrigErr)

595+ iPrintResult ""

596+idemodeProcess fn (SetOpt x) = process fn (SetOpt x)

597+idemodeProcess fn (UnsetOpt x) = process fn (UnsetOpt x)

598+idemodeProcess fn (CaseSplitAt False pos str) = process fn (CaseSplitAt False pos str)

599+idemodeProcess fn (AddProofClauseFrom False pos str) = process fn (AddProofClauseFrom False pos str)

600+idemodeProcess fn (AddClauseFrom False pos str) = process fn (AddClauseFrom False pos str)

601+idemodeProcess fn (AddMissing False pos str) = process fn (AddMissing False pos str)

602+idemodeProcess fn (MakeWith False pos str) = process fn (MakeWith False pos str)

603+idemodeProcess fn (DoProofSearch False r pos str xs) = process fn (DoProofSearch False r pos str xs)

604+idemodeProcess fn (SetConsoleWidth w) = do process fn (SetConsoleWidth w)

605+ iPrintResult ""

597−ideslaveProcess fn (Apropos pkg a) = do process fn (Apropos pkg a)

606+idemodeProcess fn (Apropos pkg a) = do process fn (Apropos pkg a)

598− iPrintResult ""

607+ iPrintResult ""

599−ideslaveProcess fn (WhoCalls n) = process fn (WhoCalls n)

608+idemodeProcess fn (WhoCalls n) = process fn (WhoCalls n)

600−ideslaveProcess fn (CallsWho n) = process fn (CallsWho n)

609+idemodeProcess fn (CallsWho n) = process fn (CallsWho n)

601−ideslaveProcess fn (PrintDef n) = process fn (PrintDef n)

610+idemodeProcess fn (PrintDef n) = process fn (PrintDef n)

602−ideslaveProcess fn (PPrint fmt n tm) = process fn (PPrint fmt n tm)

611+idemodeProcess fn (PPrint fmt n tm) = process fn (PPrint fmt n tm)

603−ideslaveProcess fn _ = iPrintError "command not recognized or not supported"

612+idemodeProcess fn _ = iPrintError "command not recognized or not supported"

604

613

605

614

606-- | The prompt consists of the currently loaded modules, or "Idris" if there are none

615-- | The prompt consists of the currently loaded modules, or "Idris" if there are none

@@ -722,6 +731,10 @@ process fn Warranty = iPrintResult warranty

722process fn (ChangeDirectory f)

731process fn (ChangeDirectory f)

723 = do runIO $ setCurrentDirectory f

732 = do runIO $ setCurrentDirectory f

724 return ()

733 return ()

734+process fn (ModImport f) = do fmod <- loadModule f

735+ case fmod of

736+ Just pr -> isetPrompt pr

737+ Nothing -> iPrintError $ "Can't find import " ++ f

725process fn (Eval t)

738process fn (Eval t)

726 = withErrorReflection $ do logLvl 5 $ show t

739 = withErrorReflection $ do logLvl 5 $ show t

727 getIState >>= flip warnDisamb t

740 getIState >>= flip warnDisamb t

@@ -751,7 +764,7 @@ process fn (NewDefn decls) = do

751 getName _ = Nothing

764 getName _ = Nothing

752 -- getClauseName is partial and I am not sure it's used safely! -- trillioneyes

765 -- getClauseName is partial and I am not sure it's used safely! -- trillioneyes

753 getClauseName (PClause fc name whole with rhs whereBlock) = name

766 getClauseName (PClause fc name whole with rhs whereBlock) = name

754− getClauseName (PWith fc name whole with rhs whereBlock) = name

767+ getClauseName (PWith fc name whole with rhs pn whereBlock) = name

755 defineName :: [PDecl] -> Idris ()

768 defineName :: [PDecl] -> Idris ()

756 defineName (tyDecl@(PTy docs argdocs syn fc opts name ty) : decls) = do

769 defineName (tyDecl@(PTy docs argdocs syn fc opts name ty) : decls) = do

757 elabDecl EAll recinfo tyDecl

770 elabDecl EAll recinfo tyDecl

@@ -780,9 +793,9 @@ process fn (NewDefn decls) = do

780 getClauses _ = []

793 getClauses _ = []

781 getRHS :: PClause -> PTerm

794 getRHS :: PClause -> PTerm

782 getRHS (PClause fc name whole with rhs whereBlock) = rhs

795 getRHS (PClause fc name whole with rhs whereBlock) = rhs

783− getRHS (PWith fc name whole with rhs whereBlock) = rhs

796+ getRHS (PWith fc name whole with rhs pn whereBlock) = rhs

784 getRHS (PClauseR fc with rhs whereBlock) = rhs

797 getRHS (PClauseR fc with rhs whereBlock) = rhs

785− getRHS (PWithR fc with rhs whereBlock) = rhs

798+ getRHS (PWithR fc with rhs pn whereBlock) = rhs

786 setReplDefined :: Maybe Name -> Idris ()

799 setReplDefined :: Maybe Name -> Idris ()

787 setReplDefined Nothing = return ()

800 setReplDefined Nothing = return ()

788 setReplDefined (Just n) = do

801 setReplDefined (Just n) = do

@@ -808,7 +821,7 @@ process fn (Undefine names) = undefine names

808 -- Keep track of which names you've removed so you can

821 -- Keep track of which names you've removed so you can

809 -- print them out to the user afterward

822 -- print them out to the user afterward

810 undefine names = undefine' names []

823 undefine names = undefine' names []

811− undefine' [] list = do iRenderOutput $ printUndefinedNames list

824+ undefine' [] list = do iRenderResult $ printUndefinedNames list

812 return ()

825 return ()

813 undefine' (n:names) already = do

826 undefine' (n:names) already = do

814 allDefined <- idris_repl_defs `fmap` get

827 allDefined <- idris_repl_defs `fmap` get

@@ -1091,13 +1104,15 @@ process fn Execute

1091 (tmpn, tmph) <- runIO tempfile

1104 (tmpn, tmph) <- runIO tempfile

1092 runIO $ hClose tmph

1105 runIO $ hClose tmph

1093 t <- codegen

1106 t <- codegen

1107+ -- gcc adds .exe when it builds windows programs

1108+ progName <- return $ if isWindows then tmpn ++ ".exe" else tmpn

1094 ir <- compile t tmpn m

1109 ir <- compile t tmpn m

1095 runIO $ generate t (fst (head (idris_imported ist))) ir

1110 runIO $ generate t (fst (head (idris_imported ist))) ir

1096 case idris_outputmode ist of

1111 case idris_outputmode ist of

1097− RawOutput h -> do runIO $ rawSystem tmpn []

1112+ RawOutput h -> do runIO $ rawSystem progName []

1098 return ()

1113 return ()

1099− IdeSlave n h -> runIO . hPutStrLn h $

1114+ IdeMode n h -> runIO . hPutStrLn h $

1100− IdeSlave.convSExp "run-program" tmpn n)

1115+ IdeMode.convSExp "run-program" tmpn n)

1101 (\e -> getIState >>= iRenderError . flip pprintErr e)

1116 (\e -> getIState >>= iRenderError . flip pprintErr e)

1102 where fc = fileFC "main"

1117 where fc = fileFC "main"

1103process fn (Compile codegen f)

1118process fn (Compile codegen f)

@@ -1482,7 +1497,7 @@ idrisMain opts =

1482 do let inputs = opt getFile opts

1497 do let inputs = opt getFile opts

1483 let quiet = Quiet `elem` opts

1498 let quiet = Quiet `elem` opts

1484 let nobanner = NoBanner `elem` opts

1499 let nobanner = NoBanner `elem` opts

1485− let idesl = Ideslave `elem` opts || IdeslaveSocket `elem` opts

1500+ let idesl = Idemode `elem` opts || IdemodeSocket `elem` opts

1486 let runrepl = not (NoREPL `elem` opts)

1501 let runrepl = not (NoREPL `elem` opts)

1487 let verbose = runrepl || Verbose `elem` opts

1502 let verbose = runrepl || Verbose `elem` opts

1488 let output = opt getOutput opts

1503 let output = opt getOutput opts

@@ -1607,8 +1622,8 @@ idrisMain opts =

1607-- clearOrigPats

1622-- clearOrigPats

1608 startServer port orig mods

1623 startServer port orig mods

1609 runInputT (replSettings (Just historyFile)) $ repl orig mods efile

1624 runInputT (replSettings (Just historyFile)) $ repl orig mods efile

1610− let idesock = IdeslaveSocket `elem` opts

1625+ let idesock = IdemodeSocket `elem` opts

1611− when (idesl) $ ideslaveStart idesock orig inputs

1626+ when (idesl) $ idemodeStart idesock orig inputs

1612 ok <- noErrors

1627 ok <- noErrors

1613 when (not ok) $ runIO (exitWith (ExitFailure 1))

1628 when (not ok) $ runIO (exitWith (ExitFailure 1))

1614 where

1629 where

@@ -1793,7 +1808,7 @@ getPort (_:xs) = getPort xs

1793opt :: (Opt -> Maybe a) -> [Opt] -> [a]

1808opt :: (Opt -> Maybe a) -> [Opt] -> [a]

1794opt = mapMaybe

1809opt = mapMaybe

1795

1810

1796−ver = showVersion version ++ gitHash

1811+ver = showVersion version ++ "-" ++ gitHash

1797

1812

1798defaultPort :: PortID

1813defaultPort :: PortID

1799defaultPort = PortNumber (fromIntegral 4294)

1814defaultPort = PortNumber (fromIntegral 4294)

src/Idris/TypeSearch.hs+10−2

@@ -57,7 +57,7 @@ searchByType pkgs pterm = do

57 case idris_outputmode i of

58 RawOutput _ -> do mapM_ iRenderOutput docs

59 iPrintResult ""

60− IdeSlave _ _ -> iRenderResult (vsep docs)

60+ IdeMode _ _ -> iRenderResult (vsep docs)

61 putIState i -- don't actually make any changes

62 where

63 numLimit = 50

@@ -99,6 +99,14 @@ typeFromDef (def, _, _, _) = get def where

99 get (CaseOp _ ty _ _ _ _) = Just ty

100 get _ = Nothing

101

102+-- Replace all occurences of `Lazy' s t` with `t` in a type

103+unLazy :: Type -> Type

104+unLazy typ = case typ of

105+ App (App (P _ lazy _) _) ty | lazy == sUN "Lazy'" -> unLazy ty

106+ Bind name binder ty -> Bind name (fmap unLazy binder) (unLazy ty)

107+ App t1 t2 -> App (unLazy t1) (unLazy t2)

108+ Proj ty i -> Proj (unLazy ty) i

109+ _ -> typ

102

110

103-- | reverse the edges for a directed acyclic graph

111-- | reverse the edges for a directed acyclic graph

104reverseDag :: Ord k => [((k, a), Set k)] -> [((k, a), Set k)]

112reverseDag :: Ord k => [((k, a), Set k)] -> [((k, a), Set k)]

@@ -362,7 +370,7 @@ matchTypesBulk istate maxScore type1 types = getAllResults startQueueOfQueues wh

362 argNames1 = map fst dag1

370 argNames1 = map fst dag1

363 makeDag :: Type -> (ArgsDAG, Classes, Type)

371 makeDag :: Type -> (ArgsDAG, Classes, Type)

364 makeDag = first3 (zipWith (\i (ty, deps) -> (ty, (i, deps))) [0..] . reverseDag) .

372 makeDag = first3 (zipWith (\i (ty, deps) -> (ty, (i, deps))) [0..] . reverseDag) .

365− computeDagP (isTypeClassArg classInfo) . vToP

373+ computeDagP (isTypeClassArg classInfo) . vToP . unLazy

366 first3 f (a,b,c) = (f a, b, c)

374 first3 f (a,b,c) = (f a, b, c)

367

375

368 -- update our state with the unification resolutions

376 -- update our state with the unification resolutions

src/Pkg/PParser.hs+2−2

@@ -16,7 +16,7 @@ import Idris.CmdOptions

16import Control.Monad.State.Strict

17import Control.Applicative

19−import System.Info (os)

19+import Util.System

22type PParser = StateT PkgDesc IdrisInnerParser

@@ -63,7 +63,7 @@ pClause :: PParser ()

63pClause = do reserved "executable"; lchar '=';

64 exec <- iName []

65 st <- get

66− put (st { execout = Just (if os `elem` ["win32", "mingw32", "cygwin32"]

66+ put (st { execout = Just (if isWindows

67 then ((show exec) ++ ".exe")

68 else ( show exec )

69 ) })

src/Util/System.hs+5−1

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

1−module Util.System(tempfile,withTempdir,rmFile,catchIO) where

1+module Util.System(tempfile,withTempdir,rmFile,catchIO, isWindows) where

3-- System helper functions.

4import Control.Monad (when)

@@ -9,6 +9,7 @@ import System.Directory (getTemporaryDirectory

9 )

10import System.FilePath ((</>), normalise)

11import System.IO

12+import System.Info

12import System.IO.Error

13import System.IO.Error

13import Control.Exception as CE

14import Control.Exception as CE

@@ -18,6 +19,9 @@ catchIO = CE.catch

18throwIO :: IOError -> IO a

19throwIO :: IOError -> IO a

19throwIO = CE.throw

20throwIO = CE.throw

22+isWindows :: Bool

23+isWindows = os `elem` ["win32", "mingw32", "cygwin32"]

24+

21tempfile :: IO (FilePath, Handle)

25tempfile :: IO (FilePath, Handle)

22tempfile = do dir <- getTemporaryDirectory

26tempfile = do dir <- getTemporaryDirectory

23 openTempFile (normalise dir) "idris"

27 openTempFile (normalise dir) "idris"

test/proof008/ClaimAndUnfocus.idrnew file+17

@@ -0,0 +1,17 @@

1+module ClaimAndUnfocus

3+foo : Nat -> Nat

4+foo = ?foo_rhs

6+---------- Proofs ----------

8+ClaimAndUnfocus.foo_rhs = proof

9+ claim bar Nat -> Nat -> Nat

10+ unfocus

11+ intro x

12+ exact bar x x

13+ intro x,y

14+ refine plus

15+ refine x

16+ refine y

17+

test/proof008/expectednew file

No changes to the content.

test/proof008/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris --check $@ ClaimAndUnfocus.idr

3+rm -f *.ibc

test/quasiquote005/Quasiquote005.idrnew file+22

@@ -0,0 +1,22 @@

1+module Quasiquote005

3+-- Test Raw quasiquotes

5+test : the Language.Reflection.Raw `(plus (S Z) (S Z)) =

6+ RApp (RApp (Var (NS (UN "plus") ["Nat", "Prelude"]))

7+ (RApp (Var (NS (UN "S") ["Nat", "Prelude"]))

8+ (Var (NS (UN "Z") ["Nat", "Prelude"]))))

9+ (RApp (Var (NS (UN "S") ["Nat", "Prelude"]))

10+ (Var (NS (UN "Z") ["Nat", "Prelude"])))

11+test = Refl

12+

13+firstAddend : Raw -> Maybe Raw

14+firstAddend `(plus ~first ~_) = Just first

15+firstAddend _ = Nothing

16+

17+firstAddendOk : firstAddend (RApp (RApp (Var (NS (UN "plus") ["Nat", "Prelude"]))

18+ (RApp (Var (NS (UN "S") ["Nat", "Prelude"]))

19+ (Var (NS (UN "Z") ["Nat", "Prelude"]))))

20+ (Var (NS (UN "Z") ["Nat", "Prelude"]))) =

21+ the (Maybe Raw) (Just `(S Z))

22+firstAddendOk = Refl

test/quasiquote005/expectednew file

No changes to the content.

test/quasiquote005/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ --check --nocolour Quasiquote005.idr

3+rm -f *.ibc

test/reg050/expected+2−1

@@ -23,6 +23,7 @@ When elaborating an application of function Prelude.Monad.>>=:

23 ambiguous use of a non-associative operator,

24 ambiguous use of a right-associative operator,

25 end of input, function argument,

26− matching application expression

26+ matching application expression,

27+ single-line comment

27doubleBang mmn = do pure !!mmn

28doubleBang mmn = do pure !!mmn

28 ^

29 ^

test/reg058/expectednew file

No changes to the content.

test/reg058/implicits.idrnew file+14

@@ -0,0 +1,14 @@

1+%default total

3+InterpBool : () -> Type

4+InterpBool () = {x : Type} -> x -> Nat

6+class IdrisBug (u : ()) where

7+ idrisBug : InterpBool u

9+instance IdrisBug () where

10+ idrisBug _ = Z

11+

12+f : Nat

13+f = idrisBug {u = ()} 'a'

14+

test/reg058/implicits2.idrnew file+19

@@ -0,0 +1,19 @@

1+import Data.Vect

3+impTy : Bool -> Type

4+impTy True = Int

5+impTy False = {n : Nat} -> Vect n Int -> Vect n Int

7+wibble : impTy False

8+wibble [] = []

9+wibble (x :: xs) = x * 2 :: wibble xs

10+

11+wobble : (b : Bool) -> impTy b

12+wobble True = 42

13+wobble False = wibble

14+

15+foo : Vect 4 Int

16+foo = wobble False [1,2,3,4]

17+

18+bar : Int

19+bar = wobble True

test/reg058/runnew file+5

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

1+#!/usr/bin/env bash

2+idris $@ implicits.idr --check

3+idris $@ implicits2.idr --check

5+rm -f *.ibc

test/totality006/expected+1

@@ -1,2 +1,3 @@

1totality006.idr:8:1:Main.prf is not total as there are missing cases

2totality006a.idr:11:6:prf' (S _) (S _) Oh is a valid case

3+totality006b.idr:10:1:totality006b.blargh is not total as there are missing cases

test/totality006/run+1

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

1#!/usr/bin/env bash

2idris $@ totality006.idr --check

3idris $@ totality006a.idr --check

4+idris $@ totality006b.idr --check

4rm -f *.ibc

5rm -f *.ibc

test/totality006/totality006b.idrnew file+14

@@ -0,0 +1,14 @@

1+module totality006b

3+import Data.So

6+-- There are approaches to impossibility checking that break on this

7+-- case but not on test006.idr, due to the extra computation.

8+total

9+blargh : (xs, ys : List a) -> So (length xs > length ys) -> GT (length xs) (length ys)

10+blargh [] [] Oh impossible

11+blargh [] (y :: xs) so = absurd so

12+blargh (y :: xs) [] Oh = LTESucc LTEZero

13+

14+-- Missing: blargh (y :: xs) (z :: ys) x = ?blargh_rhs_3

test/unique001/expected+1−1

@@ -15,6 +15,6 @@ unique001a.idr:55:12:Can't convert

15with

16 [94mInt[0m -> [94mString[0m

17unique001b.idr:16:7:Borrowed name xs must not be used on RHS

18−unique001c.idr:49:6:Unique name f is used more than once

18+unique001c.idr:46:6:Unique name f is used more than once

19unique001d.idr:3:7:Borrowed name x must not be used on RHS

20unique001e.idr:4:11:Constructor Main.:: has a UniqueType, but the data type does not

test/unique001/unique001c.idr+4−7

@@ -11,14 +11,11 @@ data UTree : UniqueType where

11 ULeaf : UTree

12 UNode : UTree -> Int -> UTree -> UTree

14−data UPair : UniqueType -> UniqueType -> UniqueType where

15− MkUPair : {a,b:UniqueType} -> a -> b -> UPair a b

16−

17dup : UTree -> UPair UTree UTree

14dup : UTree -> UPair UTree UTree

18−dup ULeaf = MkUPair ULeaf ULeaf

15+dup ULeaf = (ULeaf, ULeaf)

19−dup (UNode l y r) = let MkUPair l1 l2 = dup l

16+dup (UNode l y r) = let (l1, l2) = dup l

20− MkUPair r1 r2 = dup r in

17+ (r1, r2) = dup r in

21− MkUPair (UNode l1 y r1) (UNode l2 y r2)

18+ (UNode l1 y r1, UNode l2 y r2)

23data Tree : Type where

20data Tree : Type where

24 Leaf : Tree

21 Leaf : Tree