569a30c · Idris-dev · git.iko.soy

.travis.yml−1

compare with master

unifiedsplit

@@ -21,6 +21,5 @@ script:

21env:

22 # TESTS=doc

23 - TESTS=test_c

24− - TESTS=test_java

25 - TESTS=test_llvm

24 - TESTS=test_llvm

26 - TESTS=test_js

25 - TESTS=test_js

CHANGELOG+18−9

@@ -4,18 +4,27 @@ New in 0.9.12:

4* Proof search now works for metavariables in types, giving some interactive

5 type inference.

6* New 'Lazy' type, replacing laziness annotations.

7−* JavaScript and Node codegen now understand the %include directive

7+* JavaScript and Node codegen now understand the %include directive.

8−* Concept up 'null' is now understood in the JavaScript and Node codegen

8+* Concept up 'null' is now understood in the JavaScript and Node codegen.

9−* Lots of performance patches for generated JavaScript

9+* Lots of performance patches for generated JavaScript.

10* New commands :eval (:e) and :type (:t) in the prover, which either normalise

11− or show the type of expressions

11+ or show the type of expressions.

12−* Allow type providers to return postulates in addition to terms

12+* Allow type providers to return postulates in addition to terms.

13+* Syntax for dealing with match failure in <- and pattern matching let.

13* New syntax for inline documentation. Documentation starts with |||, and

14* New syntax for inline documentation. Documentation starts with |||, and

14 arguments are documented by preceding their name with @. Example:

15 arguments are documented by preceding their name with @. Example:

15−||| Add two natural numbers

16+ ||| Add two natural numbers

16−||| @ n the first number (examined by the function)

17+ ||| @ n the first number (examined by the function)

17−||| @ m the second number (not examined)

18+ ||| @ m the second number (not examined)

18−plus (n, m : Nat) -> Nat

19+ plus (n, m : Nat) -> Nat

20+* Allow the auto-solve behavior in the prover to be disabled, for easier debugging

21+ of proof automation. Use ":set autosolve" and ":unset autosolve".

22+* Updated 'effects' library

23+* New :apropos command at REPL to search documentation, names, and types

24+* Unification errors are now slightly more informative

25+* Support mixed induction/coinduction with 'Inf' type

26+* Add 'covering' function option, which checks whether a function and all

27+ descendants cover all possible inputs

19

28

20New in 0.9.11:

29New in 0.9.11:

21--------------

30--------------

Makefile+1−1

@@ -39,7 +39,7 @@ relib: lib_clean

39 $(CABAL) install $(CABALFLAGS)

40

41linecount:

42− wc -l src/Idris/*.hs src/Core/*.hs src/IRTS/*.hs src/Pkg/*.hs

42+ wc -l src/Idris/*.hs src/Idris/Core/*.hs src/IRTS/*.hs src/Pkg/*.hs

43

44#Note: this doesn't yet link to Hackage properly

45doc: dist/setup-config

contribs/idrislang.sty+7−80

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

24\RequirePackage{ifthen}

25\RequirePackage{listings}

26\RequirePackage{xspace}

27+\RequirePackage{textcomp}

27%% ----------------------------------------------------------------- [ Options ]

28%% ----------------------------------------------------------------- [ Options ]

28\newboolean{literate}

29\newboolean{literate}

29\setboolean{literate}{false}

30\setboolean{literate}{false}

@@ -48,8 +49,9 @@

48\lstdefinelanguage{idris}{%

49\lstdefinelanguage{idris}{%

49 sensitive,%

50 sensitive,%

50%% ----------------------------------------------------------- [ Default Style ]

51%% ----------------------------------------------------------- [ Default Style ]

51− xleftmargin=\parindent,

52+ xleftmargin=1.5em,

52 tabsize=2,

53 tabsize=2,

54+ upquote=true,

53 basicstyle=\ttfamily,

55 basicstyle=\ttfamily,

54 flexiblecolumns=false,

56 flexiblecolumns=false,

55 commentstyle=\footnotesize\sffamily,

57 commentstyle=\footnotesize\sffamily,

@@ -63,78 +65,9 @@

63 total, trivial, try, using, where, with

65 total, trivial, try, using, where, with

64},

66},

65%% ------------------------------------------------------- [ Prelude Functions ]

67%% ------------------------------------------------------- [ Prelude Functions ]

66−%% Generated using

67−%% find lib/ -name "*.idr" | xargs grep -e "^[a-zA-Z0-9]* :" | awk -F : '{printf $2", "}'

68 morekeywords={%

69− class, data, instance, record, dsl, postulate, default, assert_total,

69+ class, data, instance, record, dsl, postulate, default,

70 lambda, variable, index_first, index_next

71− % trace, unsafePerformPrimIO, FInt, FChar, FByte, FShort, FLong,

72− % FBits8, FBits16, FBits32, FBits64, FBits8x16, FBits16x8,

73− % FBits32x4, FBits64x2, interpFTy, ForeignTy, mkForeignPrim,

74− % mkLazyForeignPrim, liftPrimIO, fork, unsafePerformIO, listens,

75− % censor, Writer, liftReaderT, asks, Reader, modify, gets, State,

76− % RWS, nGTSm, decideNatLTE, lte, vectInjective1, vectInjective2,

77− % run, myID, send, msgWaiting, recv, recvWithSender, create,

78− % sendToThread, checkMsgs, getMsg, viewB8x16, viewB16x8, viewB32x4,

79− % viewB64x2, pow, exp, log, pi, sin, cos, tan, asin, acos, atan,

80− % atan2, sinh, cosh, tanh, sqrt, floor, ceiling, count, countFrom,

81− % curry, uncurry, uniformB8x16, uniformB16x8, uniformB32x4,

82− % uniformB64x2, putStr, putStrLn, print, getLine, putChar, getChar,

83− % fopen, openFile, closeFile, fread, fwrite, feof, ferror, nullPtr,

84− % nullStr, validFile, while, readFile, userSuppliedName, seq, try,

85− % mkPair, getUName, unApply, mkApp, binderTy, divCeil, nextPow2,

86− % nextBytes, machineTy, bitsUsed, natToBits, getPad, pad8, pad16,

87− % pad32, pad64, shiftLeft, shiftRightLogical, shiftRightArithmetic,

88− % and, or, xor, plus, minus, times, sdiv, udiv, srem, urem, lt, lte,

89− % eq, gte, gt, complement, zeroExtend, intToBits, bitsToInt, bitAt,

90− % getBit, setBit, unsetBit, bitsToStr, findElem, replaceElem,

91− % replaceByElem, mapElem, anyNilAbsurd, anyElim, any, negAnyAll,

92− % notAllHere, notAllThere, all, length, index, weaken, take, toList,

93− % fromList, replicate, foldl, foldr, map, pad, zeroBoundIsEmpty,

94− % empty, insert, delete, contains, fromList, toList, applyKleisli,

95− % applyMor, applyEndo, absZ, negZ, negNat, minusNatZ, plusZ, subZ,

96− % multZ, fromInt, natPlusZPlus, natMultZMult, doubleNegElim,

97− % posInjective, negSInjective, posNotNeg, plusZeroLeftNeutralZ,

98− % plusZeroRightNeutralZ, plusCommutativeZ, modBin, modComp, div,

99− % rem, intToMod, modToStr, branch4, branch5, branch6, branch7,

100− % merge1, merge2, merge3, treeLookup, treeInsert, delType,

101− % treeDelete, treeToList, empty, lookup, insert, delete, fromList,

102− % toList, getWitness, getProof, FalseElim, replace, sym, trans,

103− % lazy, par, malloc, Not, id, the, const, fst, snd, flip, cong,

104− % boolElim, not, intToBool, boolOp, div, mod, strHead, strTail,

105− % strCons, strIndex, reverse, null, getArgs, getEnv, setEnv,

106− % unsetEnv, getEnvironment, exit, usleep, sequence, toHexDigit,

107− % b8ToString, b16ToString, b32ToString, b64ToString, tail, head,

108− % last, init, index, deleteAt, replaceAt, take, drop, fromList,

109− % replicate, zipWith, zip, unzip, concat, elemBy, elem, lookupBy,

110− % lookup, hasAnyBy, hasAny, find, findIndex, elemIndexBy, elemIndex,

111− % nubBy, nub, isPrefixOfBy, isPrefixOf, isSuffixOfBy, isSuffixOf,

112− % catMaybes, diag, range, isLeft, isRight, choose, either, lefts,

113− % rights, partitionEithers, fromEither, maybeToEither, strM, unpack,

114− % pack, span, break, split, ltrim, trim, words, lines, foldr1,

115− % unwords, length, realPart, imagPart, mkPolar, cis, magnitude,

116− % phase, conjugate, isNothing, isJust, maybe, fromMaybe, toMaybe,

117− % justInjective, lowerMaybe, raiseToMaybe, isNil, isCons, head,

118− % tail, last, init, take, drop, takeWhile, dropWhile, list, length,

119− % repeat, replicate, zipWith, zipWith3, zip, zip3, unzip, unzip3,

120− % mapMaybe, toList, reverse, intersperse, intercalate, elemBy, elem,

121− % lookupBy, lookup, hasAnyBy, hasAny, find, findIndex, findIndices,

122− % elemIndexBy, elemIndex, elemIndicesBy, elemIndices, filter, nubBy,

123− % nub, span, break, split, partition, isPrefixOfBy, isPrefixOf,

124− % isSuffixOfBy, isSuffixOf, sorted, mergeBy, merge, sort,

125− % maybeToList, listToMaybe, catMaybes, appendNilRightNeutral,

126− % appendAssociative, lengthAppend, mapPreservesLength,

127− % mapDistributesOverAppend, mapFusion, hasAnyByNilFalse,

128− % hasAnyNilFalse, fromIntegerNat, toIntegerNat, hyper, log2, gcd,

129− % liftA, liftA2, liftA3, guard, when, finToNat, finToInt, weaken,

130− % strengthen, last, natToFin, integerToFin, fromInteger, flatten,

131− % return, isUpper, isLower, isAlpha, isDigit, isAlphaNum, isSpace,

132− % isNL, toUpper, toLower, isHexDigit, isValidHeap, merge, insert,

133− % findMinimum, deleteMinimum, toList, fromList, sort, main, foldl,

134− % concat, concatMap, and, or, any, all, sum, product, Vars,

135− % getAction, setInfo, getInfo, lift, output, queryVars, postVars,

136− % cookieVars, queryVar, getOutput, getHeaders, flushHeaders, flush,

137− % getVars, getContent, getCgiEnv, runCGI, mult

138 },

71 },

139%% ---------------------------------------------------------------- [ Comments ]

72%% ---------------------------------------------------------------- [ Comments ]

140 morecomment=[l]--,%

73 morecomment=[l]--,%

@@ -166,13 +99,9 @@

166%% -------------------------------------------------- [ Default Listings Style ]

99%% -------------------------------------------------- [ Default Listings Style ]

167

100

168\lstdefinestyle{default}{%

101\lstdefinestyle{default}{%

169− xleftmargin=\parindent,

170− tabsize=2,

171 basicstyle=\ttfamily

102 basicstyle=\ttfamily

172}

103}

173\lstdefinestyle{numbers}{%

104\lstdefinestyle{numbers}{%

174− xleftmargin=\parindent,

175− tabsize=2,

176 numbers=left,

105 numbers=left,

177 numbersep=10pt,

106 numbersep=10pt,

178 numberstyle=\footnotesize\sffamily,

107 numberstyle=\footnotesize\sffamily,

@@ -186,11 +115,9 @@

186 {\ifthenelse{\boolean{literate}}{%

115 {\ifthenelse{\boolean{literate}}{%

187 \lstset{language=literateidris}}{%

116 \lstset{language=literateidris}}{%

188 \lstset{language=idris}}

117 \lstset{language=idris}}

189− \ifthenelse{\boolean{numbers}}{%

118+ \ifthenelse{\boolean{numbers}}{%

190− \lstset{style=numbers, #1}}{%

119+ \lstset{style=numbers, #1}}{%

191− \lstset{style=default, #1}}

120+ \lstset{style=default, #1}}}{}

192− }

193− {}

194%% ---------------------------------------------------------- [ Input Listings ]

121%% ---------------------------------------------------------- [ Input Listings ]

195%% Command to add externally defined Idris code to the document.

122%% Command to add externally defined Idris code to the document.

196\newcommand{\inputIdrisListing}[2][]{%

123\newcommand{\inputIdrisListing}[2][]{%

idris.cabal+33−4

@@ -97,10 +97,10 @@ Extra-source-files:

97 libs/effects/Effect/*.idr

98 libs/effects/*.idr

99

100− libs/neweffects/Makefile

100+ libs/oldeffects/Makefile

101− libs/neweffects/neweffects.ipkg

101+ libs/oldeffects/oldeffects.ipkg

102− libs/neweffects/Effect/*.idr

102+ libs/oldeffects/Effect/*.idr

103− libs/neweffects/*.idr

103+ libs/oldeffects/*.idr

104

105 libs/javascript/*.idr

106 libs/javascript/JavaScript/*.idr

@@ -381,6 +381,31 @@ Extra-source-files:

381 test/totality003/run

382 test/totality003/*.idr

383 test/totality003/expected

384+ test/totality004/run

385+ test/totality004/*.idr

386+ test/totality004/expected

387+ test/totality005/run

388+ test/totality005/*.idr

389+ test/totality005/expected

390+

391+ test/tutorial001/run

392+ test/tutorial001/*.idr

393+ test/tutorial001/expected

394+ test/tutorial002/run

395+ test/tutorial002/*.idr

396+ test/tutorial002/expected

397+ test/tutorial003/run

398+ test/tutorial003/*.idr

399+ test/tutorial003/expected

400+ test/tutorial004/run

401+ test/tutorial004/*.idr

402+ test/tutorial004/expected

403+ test/tutorial005/run

404+ test/tutorial005/*.idr

405+ test/tutorial005/expected

406+ test/tutorial006/run

407+ test/tutorial006/*.idr

408+ test/tutorial006/expected

384

409

385source-repository head

410source-repository head

386 type: git

411 type: git

@@ -430,6 +455,7 @@ Library

430

455

431 , Idris.AbsSyntax

456 , Idris.AbsSyntax

432 , Idris.AbsSyntaxTree

457 , Idris.AbsSyntaxTree

458+ , Idris.Apropos

433 , Idris.CaseSplit

459 , Idris.CaseSplit

434 , Idris.Chaser

460 , Idris.Chaser

435 , Idris.Colours

461 , Idris.Colours

@@ -440,6 +466,7 @@ Library

440 , Idris.DeepSeq

466 , Idris.DeepSeq

441 , Idris.Delaborate

467 , Idris.Delaborate

442 , Idris.Docs

468 , Idris.Docs

469+ , Idris.Docstrings

443 , Idris.ElabDecls

470 , Idris.ElabDecls

444 , Idris.ElabTerm

471 , Idris.ElabTerm

445 , Idris.Error

472 , Idris.Error

@@ -506,12 +533,14 @@ Library

506 , ansi-wl-pprint

533 , ansi-wl-pprint

507 , binary

534 , binary

508 , bytestring

535 , bytestring

536+ , cheapskate

509 , containers >= 0.5

537 , containers >= 0.5

510 , directory

538 , directory

511 , directory >= 1.2

539 , directory >= 1.2

512 , filepath

540 , filepath

513 , haskeline >= 0.7

541 , haskeline >= 0.7

514 , language-java >= 0.2.6

542 , language-java >= 0.2.6

543+ , lens >= 4.1.1

515 , mtl

544 , mtl

516 , parsers >= 0.9

545 , parsers >= 0.9

517 , pretty

546 , pretty

libs/Makefile+3−3

@@ -2,7 +2,7 @@ build:

2 $(MAKE) -C prelude build

3 $(MAKE) -C base build

4 $(MAKE) -C effects build

5− $(MAKE) -C neweffects build

5+ $(MAKE) -C oldeffects build

6 $(MAKE) -C javascript build

7

8

@@ -10,14 +10,14 @@ install:

10 $(MAKE) -C prelude install

11 $(MAKE) -C base install

12 $(MAKE) -C effects install

13− $(MAKE) -C neweffects install

13+ $(MAKE) -C oldeffects install

14 $(MAKE) -C javascript install

15

16clean:

17 $(MAKE) -C prelude clean

18 $(MAKE) -C base clean

19 $(MAKE) -C effects clean

20− $(MAKE) -C neweffects clean

20+ $(MAKE) -C oldeffects clean

21 $(MAKE) -C javascript clean

22

23.PHONY: build install clean

libs/base/Control/Isomorphism.idr+28−3

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

4

5%default total

6

7−-- An isomorphism between two types

7+||| An isomorphism between two types

8data Iso : Type -> Type -> Type where

9 MkIso : (to : a -> b) ->

10 (from : b -> a) ->

@@ -14,9 +14,11 @@ data Iso : Type -> Type -> Type where

14

15-- Isomorphism properties

16

17+||| Isomorphism is reflexive

17isoRefl : Iso a a

18isoRefl : Iso a a

18isoRefl = MkIso id id (\x => refl) (\x => refl)

19isoRefl = MkIso id id (\x => refl) (\x => refl)

19

20

21+||| Isomorphism is transitive

20isoTrans : Iso a b -> Iso b c -> Iso a c

22isoTrans : Iso a b -> Iso b c -> Iso a c

21isoTrans (MkIso to from toFrom fromTo) (MkIso to' from' toFrom' fromTo') =

23isoTrans (MkIso to from toFrom fromTo) (MkIso to' from' toFrom' fromTo') =

22 MkIso (\x => to' (to x))

24 MkIso (\x => to' (to x))

@@ -28,11 +30,13 @@ isoTrans (MkIso to from toFrom fromTo) (MkIso to' from' toFrom' fromTo') =

28 (from (to x)) ={ fromTo x }=

30 (from (to x)) ={ fromTo x }=

29 x QED)

31 x QED)

30

32

33+||| Isomorphism is symmetric

31isoSym : Iso a b -> Iso b a

34isoSym : Iso a b -> Iso b a

32isoSym (MkIso to from toFrom fromTo) = MkIso from to fromTo toFrom

35isoSym (MkIso to from toFrom fromTo) = MkIso from to fromTo toFrom

33

36

34-- Isomorphisms over sums

37-- Isomorphisms over sums

35

38

39+||| Disjunction is commutative

36eitherComm : Iso (Either a b) (Either b a)

40eitherComm : Iso (Either a b) (Either b a)

37eitherComm = MkIso swap swap swapSwap swapSwap

41eitherComm = MkIso swap swap swapSwap swapSwap

38 where swap : Either a' b' -> Either b' a' -- a & b are parameters, so fixed!

42 where swap : Either a' b' -> Either b' a' -- a & b are parameters, so fixed!

@@ -42,6 +46,7 @@ eitherComm = MkIso swap swap swapSwap swapSwap

42 swapSwap (Left x) = refl

46 swapSwap (Left x) = refl

43 swapSwap (Right x) = refl

47 swapSwap (Right x) = refl

44

48

49+||| Disjunction is associative

45eitherAssoc : Iso (Either (Either a b) c) (Either a (Either b c))

50eitherAssoc : Iso (Either (Either a b) c) (Either a (Either b c))

46eitherAssoc = MkIso eitherAssoc1 eitherAssoc2 ok1 ok2

51eitherAssoc = MkIso eitherAssoc1 eitherAssoc2 ok1 ok2

47 where eitherAssoc1 : Either (Either a b) c -> Either a (Either b c)

52 where eitherAssoc1 : Either (Either a b) c -> Either a (Either b c)

@@ -64,6 +69,7 @@ eitherAssoc = MkIso eitherAssoc1 eitherAssoc2 ok1 ok2

64 ok2 (Left (Right x)) = refl

69 ok2 (Left (Right x)) = refl

65 ok2 (Right x) = refl

70 ok2 (Right x) = refl

66

71

72+||| Disjunction with false is a no-op

67eitherBotLeft : Iso (Either _|_ a) a

73eitherBotLeft : Iso (Either _|_ a) a

68eitherBotLeft = MkIso to from ok1 ok2

74eitherBotLeft = MkIso to from ok1 ok2

69 where to : Either _|_ a -> a

75 where to : Either _|_ a -> a

@@ -77,10 +83,11 @@ eitherBotLeft = MkIso to from ok1 ok2

77 ok2 (Left x) = FalseElim x

83 ok2 (Left x) = FalseElim x

78 ok2 (Right x) = refl

84 ok2 (Right x) = refl

79

85

86+||| Disjunction with false is a no-op

80eitherBotRight : Iso (Either a _|_) a

87eitherBotRight : Iso (Either a _|_) a

81eitherBotRight = isoTrans eitherComm eitherBotLeft

88eitherBotRight = isoTrans eitherComm eitherBotLeft

82

89

83−

90+||| Isomorphism is a congruence with regards to disjunction

84eitherCong : Iso a a' -> Iso b b' -> Iso (Either a b) (Either a' b')

91eitherCong : Iso a a' -> Iso b b' -> Iso (Either a b) (Either a' b')

85eitherCong {a = a} {a' = a'} {b = b} {b' = b'}

92eitherCong {a = a} {a' = a'} {b = b} {b' = b'}

86 (MkIso to from toFrom fromTo)

93 (MkIso to from toFrom fromTo)

@@ -96,21 +103,25 @@ eitherCong {a = a} {a' = a'} {b = b} {b' = b'}

96 ok2 (Left x) = cong (fromTo x)

103 ok2 (Left x) = cong (fromTo x)

97 ok2 (Right x) = cong (fromTo' x)

104 ok2 (Right x) = cong (fromTo' x)

98

105

106+||| Isomorphism is a congruence with regards to disjunction on the left

99eitherCongLeft : Iso a a' -> Iso (Either a b) (Either a' b)

107eitherCongLeft : Iso a a' -> Iso (Either a b) (Either a' b)

100eitherCongLeft i = eitherCong i isoRefl

108eitherCongLeft i = eitherCong i isoRefl

101

109

110+||| Isomorphism is a congruence with regards to disjunction on the right

102eitherCongRight : Iso b b' -> Iso (Either a b) (Either a b')

111eitherCongRight : Iso b b' -> Iso (Either a b) (Either a b')

103eitherCongRight i = eitherCong isoRefl i

112eitherCongRight i = eitherCong isoRefl i

104

113

105-- Isomorphisms over products

114-- Isomorphisms over products

115+||| Conjunction is commutative

106pairComm : Iso (a, b) (b, a)

116pairComm : Iso (a, b) (b, a)

107pairComm = MkIso swap swap swapSwap swapSwap

117pairComm = MkIso swap swap swapSwap swapSwap

108 where swap : (a', b') -> (b', a')

118 where swap : (a', b') -> (b', a')

109 swap (x, y) = (y, x)

119 swap (x, y) = (y, x)

110−

120+

111 swapSwap : (x : (a', b')) -> swap (swap x) = x

121 swapSwap : (x : (a', b')) -> swap (swap x) = x

112 swapSwap (x, y) = refl

122 swapSwap (x, y) = refl

113

123

124+||| Conjunction is associative

114pairAssoc : Iso (a, (b, c)) ((a, b), c)

125pairAssoc : Iso (a, (b, c)) ((a, b), c)

115pairAssoc = MkIso to from ok1 ok2

126pairAssoc = MkIso to from ok1 ok2

116 where

127 where

@@ -123,20 +134,25 @@ pairAssoc = MkIso to from ok1 ok2

123 ok2 : (x : (a, (b, c))) -> from (to x) = x

134 ok2 : (x : (a, (b, c))) -> from (to x) = x

124 ok2 (x, (y, z)) = refl

135 ok2 (x, (y, z)) = refl

125

136

137+||| Conjunction with truth is a no-op

126pairUnitRight : Iso (a, ()) a

138pairUnitRight : Iso (a, ()) a

127pairUnitRight = MkIso fst (\x => (x, ())) (\x => refl) ok

139pairUnitRight = MkIso fst (\x => (x, ())) (\x => refl) ok

128 where ok : (x : (a, ())) -> (fst x, ()) = x

140 where ok : (x : (a, ())) -> (fst x, ()) = x

129 ok (x, ()) = refl

141 ok (x, ()) = refl

130

142

143+||| Conjunction with truth is a no-op

131pairUnitLeft : Iso ((), a) a

144pairUnitLeft : Iso ((), a) a

132pairUnitLeft = isoTrans pairComm pairUnitRight

145pairUnitLeft = isoTrans pairComm pairUnitRight

133

146

147+||| Conjunction preserves falsehood

134pairBotLeft : Iso (_|_, a) _|_

148pairBotLeft : Iso (_|_, a) _|_

135pairBotLeft = MkIso fst FalseElim (\x => FalseElim x) (\y => FalseElim (fst y))

149pairBotLeft = MkIso fst FalseElim (\x => FalseElim x) (\y => FalseElim (fst y))

136

150

151+||| Conjunction preserves falsehood

137pairBotRight : Iso (a, _|_) _|_

152pairBotRight : Iso (a, _|_) _|_

138pairBotRight = isoTrans pairComm pairBotLeft

153pairBotRight = isoTrans pairComm pairBotLeft

139

154

155+||| Isomorphism is a congruence with regards to conjunction

140pairCong : Iso a a' -> Iso b b' -> Iso (a, b) (a', b')

156pairCong : Iso a a' -> Iso b b' -> Iso (a, b) (a', b')

141pairCong {a = a} {a' = a'} {b = b} {b' = b'}

157pairCong {a = a} {a' = a'} {b = b} {b' = b'}

142 (MkIso to from toFrom fromTo)

158 (MkIso to from toFrom fromTo)

@@ -155,13 +171,16 @@ pairCong {a = a} {a' = a'} {b = b} {b' = b'}

155 rewrite fromTo' y in

171 rewrite fromTo' y in

156 refl

172 refl

157

173

174+||| Isomorphism is a congruence with regards to conjunction on the left

158pairCongLeft : Iso a a' -> Iso (a, b) (a', b)

175pairCongLeft : Iso a a' -> Iso (a, b) (a', b)

159pairCongLeft i = pairCong i isoRefl

176pairCongLeft i = pairCong i isoRefl

160

177

178+||| Isomorphism is a congruence with regards to conjunction on the right

161pairCongRight : Iso b b' -> Iso (a, b) (a, b')

179pairCongRight : Iso b b' -> Iso (a, b) (a, b')

162pairCongRight = pairCong isoRefl

180pairCongRight = pairCong isoRefl

163

181

164-- Distributivity of products over sums

182-- Distributivity of products over sums

183+||| Products distribute over sums

165distribLeft : Iso (Either a b, c) (Either (a, c) (b, c))

184distribLeft : Iso (Either a b, c) (Either (a, c) (b, c))

166distribLeft = MkIso to from toFrom fromTo

185distribLeft = MkIso to from toFrom fromTo

167 where to : (Either a b, c) -> Either (a, c) (b, c)

186 where to : (Either a b, c) -> Either (a, c) (b, c)

@@ -177,20 +196,24 @@ distribLeft = MkIso to from toFrom fromTo

177 fromTo (Left x, y) = refl

196 fromTo (Left x, y) = refl

178 fromTo (Right x, y) = refl

197 fromTo (Right x, y) = refl

179

198

199+||| Products distribute over sums

180distribRight : Iso (a, Either b c) (Either (a, b) (a, c))

200distribRight : Iso (a, Either b c) (Either (a, b) (a, c))

181distribRight {a} {b} {c} = (pairComm `isoTrans` distribLeft) `isoTrans` eitherCong pairComm pairComm

201distribRight {a} {b} {c} = (pairComm `isoTrans` distribLeft) `isoTrans` eitherCong pairComm pairComm

182

202

183

203

184-- Enable preorder reasoning syntax over isomorphisms

204-- Enable preorder reasoning syntax over isomorphisms

205+||| Used for preorder reasoning syntax. Not intended for direct use.

185qed : (a : Type) -> Iso a a

206qed : (a : Type) -> Iso a a

186qed a = isoRefl

207qed a = isoRefl

187

208

209+||| Used for preorder reasoning syntax. Not intended for direct use.

188step : (a : Type) -> Iso a b -> Iso b c -> Iso a c

210step : (a : Type) -> Iso a b -> Iso b c -> Iso a c

189step a iso1 iso2 = isoTrans iso1 iso2

211step a iso1 iso2 = isoTrans iso1 iso2

190

212

191

213

192

214

193-- Isomorphisms over Maybe

215-- Isomorphisms over Maybe

216+||| Isomorphism is a congruence with respect to Maybe

194maybeCong : Iso a b -> Iso (Maybe a) (Maybe b)

217maybeCong : Iso a b -> Iso (Maybe a) (Maybe b)

195maybeCong {a} {b} (MkIso to from toFrom fromTo) = MkIso (map to) (map from) ok1 ok2

218maybeCong {a} {b} (MkIso to from toFrom fromTo) = MkIso (map to) (map from) ok1 ok2

196 where ok1 : (y : Maybe b) -> map to (map from y) = y

219 where ok1 : (y : Maybe b) -> map to (map from y) = y

@@ -200,6 +223,7 @@ maybeCong {a} {b} (MkIso to from toFrom fromTo) = MkIso (map to) (map from) ok1

200 ok2 Nothing = refl

223 ok2 Nothing = refl

201 ok2 (Just x) = (Just (from (to x))) ={ cong (fromTo x) }= (Just x) QED

224 ok2 (Just x) = (Just (from (to x))) ={ cong (fromTo x) }= (Just x) QED

202

225

226+||| `Maybe a` is the same as `Either a ()`

203maybeEither : Iso (Maybe a) (Either a ())

227maybeEither : Iso (Maybe a) (Either a ())

204maybeEither = MkIso to from iso1 iso2

228maybeEither = MkIso to from iso1 iso2

205 where to : Maybe a -> Either a ()

229 where to : Maybe a -> Either a ()

@@ -215,6 +239,7 @@ maybeEither = MkIso to from iso1 iso2

215 iso2 Nothing = refl

239 iso2 Nothing = refl

216 iso2 (Just x) = refl

240 iso2 (Just x) = refl

217

241

242+||| Maybe of void is just unit

218maybeVoidUnit : Iso (Maybe _|_) ()

243maybeVoidUnit : Iso (Maybe _|_) ()

219maybeVoidUnit = (Maybe _|_) ={ maybeEither }=

244maybeVoidUnit = (Maybe _|_) ={ maybeEither }=

220 (Either _|_ ()) ={ eitherBotLeft }=

245 (Either _|_ ()) ={ eitherBotLeft }=

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

@@ -23,7 +23,7 @@ module Data.Buffer

23-- and offset rather than storing the offset in Buffer itself, which

24-- would require exposing the offset argument of prim__appendBuffer

25

26−-- A contiguous chunk of n bytes

26+||| A contiguous chunk of n bytes

27abstract

28record Buffer : Nat -> Type where

29 MkBuffer : ( offset : Nat ) -> ( realBuffer : prim__UnsafeBuffer ) -> Buffer n

libs/base/Data/HVect.idr+4

@@ -6,10 +6,12 @@ import Data.Vect

6%default total

7

8using (k : Nat, ts : Vect k Type)

9+ ||| Heterogeneous vectors where the type index gives, element-wise, the types of the contents

9 data HVect : Vect k Type -> Type where

10 data HVect : Vect k Type -> Type where

10 Nil : HVect []

11 Nil : HVect []

11 (::) : t -> HVect ts -> HVect (t::ts)

12 (::) : t -> HVect ts -> HVect (t::ts)

12

13

14+ ||| Extract an element from an HVect

13 index : (i : Fin k) -> HVect ts -> index i ts

15 index : (i : Fin k) -> HVect ts -> index i ts

14 index fZ (x::xs) = x

16 index fZ (x::xs) = x

15 index (fS j) (x::xs) = index j xs

17 index (fS j) (x::xs) = index j xs

@@ -49,6 +51,8 @@ using (k : Nat, ts : Vect k Type)

49 instance (Shows k ts) => Show (HVect ts) where

51 instance (Shows k ts) => Show (HVect ts) where

50 show xs = show (shows xs)

52 show xs = show (shows xs)

51

53

54+ ||| Extract an arbitrary element of the correct type

55+ ||| @ t the goal type

52 get : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> HVect ts -> t

56 get : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> HVect ts -> t

53 get {p = Here} (x::xs) = x

57 get {p = Here} (x::xs) = x

54 get {p = There p'} (x::xs) = get {p = p'} xs

58 get {p = There p'} (x::xs) = get {p = p'} xs

libs/base/Data/Sign.idr+2

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

1module Data.Sign

2

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

3data Sign = Plus | Minus

4data Sign = Plus | Minus

4

5

6+||| Discover the sign of some type

5class Signed t where

7class Signed t where

6 total sign : t -> Sign

8 total sign : t -> Sign

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

@@ -10,11 +10,14 @@ import Language.Reflection

10--------------------------------------------------------------------------------

11

12using (xs : Vect k a)

13+ ||| A proof that some element is found in a vector

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

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

14 Here : Elem x (x::xs)

15 Here : Elem x (x::xs)

15 There : Elem x xs -> Elem x (y::xs)

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

16

17

18+||| A tactic for discovering where, if anywhere, an element is in a vector

19+||| @ n how many elements to search before giving up

17−findElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic

20+findElem : (n : Nat) -> List (TTName, Binder TT) -> TT -> Tactic

18findElem Z ctxt goal = Refine "Here" `Seq` Solve

21findElem Z ctxt goal = Refine "Here" `Seq` Solve

19findElem (S n) ctxt goal = GoalType "Elem" (Try (Refine "Here" `Seq` Solve) (Refine "There" `Seq` (Solve `Seq` findElem n ctxt goal)))

22findElem (S n) ctxt goal = GoalType "Elem" (Try (Refine "Here" `Seq` Solve) (Refine "There" `Seq` (Solve `Seq` findElem n ctxt goal)))

20

23

libs/base/Language/Reflection.idr+2

@@ -180,6 +180,8 @@ data Tactic = Try Tactic Tactic

180 -- ^ invoke the reflected rep. of another tactic

181 | Reflect TT

182 -- ^ turn a value into its reflected representation

183+ | ByReflection TT

184+ -- ^ use a %reflection function

183 | Fill Raw

185 | Fill Raw

184 -- ^ turn a raw value back into a term

186 -- ^ turn a raw value back into a term

185 | Exact TT

187 | Exact TT

libs/base/Language/Reflection/Errors.idr+1−3

@@ -3,7 +3,7 @@ module Language.Reflection.Errors

3import Language.Reflection

4

5data SourceLocation : Type where

6− FileLoc : (filename : String) -> (line : Int) -> (col : Int) -> SourceLocation

6+ FileLoc : (filename : String) -> (start : (Int, Int)) -> (end : (Int, Int)) -> SourceLocation

7

8%name SourceLocation loc

9

@@ -35,8 +35,6 @@ data Err = Msg String

35 | AlreadyDefined TTName

36 | ProofSearchFail Err

37 | NoRewriting TT

38− | At SourceLocation Err

39− | Elaborating String TTName Err

40 | ProviderError String

38 | ProviderError String

41 | LoadingFailed String Err

39 | LoadingFailed String Err

42

40

libs/base/Language/Reflection/Utils.idr−2

@@ -252,8 +252,6 @@ instance Show Err where

252 show (AlreadyDefined n) = "AlreadyDefined " ++ show n

253 show (ProofSearchFail err) = "ProofSearchFail " ++ show err

254 show (NoRewriting tm) = "NoRewriting " ++ show tm

255− show (At loc err) = "At " ++ show loc ++ " " ++ show err

256− show (Elaborating x n err) = "Elaborating " ++ show x ++ " " ++ show x ++ " " ++ show n ++ " (" ++ show err ++ ")"

257 show (ProviderError x) = "ProviderError \"" ++ show x ++ "\""

255 show (ProviderError x) = "ProviderError \"" ++ show x ++ "\""

258 show (LoadingFailed x err) = "LoadingFailed " ++ show x ++ " (" ++ show err ++ ")"

256 show (LoadingFailed x err) = "LoadingFailed " ++ show x ++ " (" ++ show err ++ ")"

259

257

libs/neweffects/Effect/Default.idr → libs/effects/Effect/Default.idrrenamed

The content is the same.

libs/effects/Effect/Exception.idr+6−4

@@ -4,12 +4,15 @@ import Effects

4import System

5import Control.IOExcept

6

7−data Exception : Type -> Type -> Type -> Type -> Type where

7+data Exception : Type -> Effect where

8− Raise : a -> Exception a () () b

8+ Raise : a -> { () } Exception a b

9

10instance Handler (Exception a) Maybe where

11 handle _ (Raise e) k = Nothing

12

13+instance Handler (Exception a) List where

14+ handle _ (Raise e) k = []

15+

13instance Show a => Handler (Exception a) IO where

16instance Show a => Handler (Exception a) IO where

14 handle _ (Raise e) k = do print e

17 handle _ (Raise e) k = do print e

15 believe_me (exit 1)

18 believe_me (exit 1)

@@ -23,7 +26,7 @@ instance Handler (Exception a) (Either a) where

23EXCEPTION : Type -> EFFECT

26EXCEPTION : Type -> EFFECT

24EXCEPTION t = MkEff () (Exception t)

27EXCEPTION t = MkEff () (Exception t)

25

28

26−raise : a -> Eff m [EXCEPTION a] b

29+raise : a -> { [EXCEPTION a ] } Eff m b

27raise err = Raise err

30raise err = Raise err

28

31

29

32

@@ -31,7 +34,6 @@ raise err = Raise err

31

34

32

35

33

36

34−

35-- TODO: Catching exceptions mid program?

37-- TODO: Catching exceptions mid program?

36-- probably need to invoke a new interpreter

38-- probably need to invoke a new interpreter

37

39

libs/effects/Effect/File.idr+24−31

@@ -6,62 +6,55 @@ import Control.IOExcept

6data OpenFile : Mode -> Type where

7 FH : File -> OpenFile m

8

9−data FileIO : Effect where

9+openOK : Mode -> Bool -> Type

10− Open : String -> (m : Mode) -> FileIO () (Either () (OpenFile m)) Bool

11− Close : FileIO (OpenFile m) () ()

10+openOK m True = OpenFile m

11+openOK m False = ()

12

13− ReadLine : FileIO (OpenFile Read) (OpenFile Read) String

13+data FileIO : Effect where

14− WriteLine : String -> FileIO (OpenFile Write) (OpenFile Write) ()

14+ Open : String -> (m : Mode) ->

15− EOF : FileIO (OpenFile Read) (OpenFile Read) Bool

15+ {() ==> {res} if res then OpenFile m else ()} FileIO Bool

16+ Close : {OpenFile m ==> ()} FileIO ()

16

17

18+ ReadLine : {OpenFile Read} FileIO String

19+ WriteLine : String -> {OpenFile Write} FileIO ()

20+ EOF : {OpenFile Read} FileIO Bool

17

21

18instance Handler FileIO IO where

22instance Handler FileIO IO where

19 handle () (Open fname m) k = do h <- openFile fname m

23 handle () (Open fname m) k = do h <- openFile fname m

20 valid <- validFile h

24 valid <- validFile h

21− if valid then k (Right (FH h)) True

25+ if valid then k True (FH h)

22− else k (Left ()) False

26+ else k False ()

23 handle (FH h) Close k = do closeFile h

27 handle (FH h) Close k = do closeFile h

24 k () ()

28 k () ()

25 handle (FH h) ReadLine k = do str <- fread h

29 handle (FH h) ReadLine k = do str <- fread h

26− k (FH h) str

30+ k str (FH h)

27 handle (FH h) (WriteLine str) k = do fwrite h str

31 handle (FH h) (WriteLine str) k = do fwrite h str

28− k (FH h) ()

32+ k () (FH h)

29 handle (FH h) EOF k = do e <- feof h

33 handle (FH h) EOF k = do e <- feof h

30− k (FH h) e

34+ k e (FH h)

31−

32−instance Handler FileIO (IOExcept String) where

33− handle () (Open fname m) k

34− = do h <- ioe_lift (openFile fname m)

35− valid <- ioe_lift (validFile h)

36− if valid then k (Right (FH h)) True

37− else k (Left ()) False

38− handle (FH h) Close k = do ioe_lift (closeFile h); k () ()

39− handle (FH h) ReadLine k = do str <- ioe_lift (fread h)

40− k (FH h) str

41− handle (FH h) (WriteLine str) k = do ioe_lift (fwrite h str)

42− k (FH h) ()

43− handle (FH h) EOF k = do e <- ioe_lift (feof h)

44− k (FH h) e

45

35

46FILE_IO : Type -> EFFECT

36FILE_IO : Type -> EFFECT

47FILE_IO t = MkEff t FileIO

37FILE_IO t = MkEff t FileIO

48

38

49open : Handler FileIO e =>

39open : Handler FileIO e =>

50− String -> (m : Mode) -> EffM e [FILE_IO ()]

40+ String -> (m : Mode) ->

51− [FILE_IO (Either () (OpenFile m))] Bool

41+ { [FILE_IO ()] ==> [FILE_IO (if result then OpenFile m else ())] } Eff e Bool

52open f m = Open f m

42open f m = Open f m

53

43

54close : Handler FileIO e =>

44close : Handler FileIO e =>

55− EffM e [FILE_IO (OpenFile m)] [FILE_IO ()] ()

45+ { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e ()

56close = Close

46close = Close

57

47

48+readLine : Handler FileIO e =>

58−readLine : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] String

49+ { [FILE_IO (OpenFile Read)] } Eff e String

59readLine = ReadLine

50readLine = ReadLine

60

51

52+writeLine : Handler FileIO e =>

61−writeLine : Handler FileIO e => String -> Eff e [FILE_IO (OpenFile Write)] ()

53+ String -> { [FILE_IO (OpenFile Write)] } Eff e ()

62writeLine str = WriteLine str

54writeLine str = WriteLine str

63

55

56+eof : Handler FileIO e =>

64−eof : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] Bool

57+ { [FILE_IO (OpenFile Read)] } Eff e Bool

65eof = EOF

58eof = EOF

66

59

67

60

libs/effects/Effect/Memory.idr+31−25

@@ -12,29 +12,30 @@ data MemoryChunk : Nat -> Nat -> Type where

12abstract

13data RawMemory : Effect where

14 Allocate : (n : Nat) ->

15− RawMemory () (MemoryChunk n 0) ()

15+ RawMemory () () (\v => MemoryChunk n 0)

16− Free : RawMemory (MemoryChunk n i) () ()

16+ Free : RawMemory () (MemoryChunk n i) (\v => ())

17 Initialize : Bits8 ->

18 (size : Nat) ->

19 so (i + size <= n) ->

20− RawMemory (MemoryChunk n i) (MemoryChunk n (i + size)) ()

20+ RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size))

21 Peek : (offset : Nat) ->

22 (size : Nat) ->

23 so (offset + size <= i) ->

24− RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect size Bits8)

24+ RawMemory (Vect size Bits8)

25+ (MemoryChunk n i) (\v => MemoryChunk n i)

25 Poke : (offset : Nat) ->

26 Poke : (offset : Nat) ->

26 (Vect size Bits8) ->

27 (Vect size Bits8) ->

27 so (offset <= i && offset + size <= n) ->

28 so (offset <= i && offset + size <= n) ->

28− RawMemory (MemoryChunk n i) (MemoryChunk n (max i (offset + size))) ()

29+ RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size)))

29 Move : (src : MemoryChunk src_size src_init) ->

30 Move : (src : MemoryChunk src_size src_init) ->

30 (dst_offset : Nat) ->

31 (dst_offset : Nat) ->

31 (src_offset : Nat) ->

32 (src_offset : Nat) ->

32 (size : Nat) ->

33 (size : Nat) ->

33 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

34 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

34 so (src_offset + size <= src_init) ->

35 so (src_offset + size <= src_init) ->

35− RawMemory (MemoryChunk dst_size dst_init)

36+ RawMemory () (MemoryChunk dst_size dst_init)

36− (MemoryChunk dst_size (max dst_init (dst_offset + size))) ()

37+ (\v => MemoryChunk dst_size (max dst_init (dst_offset + size)))

37− GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (MemoryChunk n i)

38+ GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i)

38

39

39private

40private

40do_malloc : Nat -> IOExcept String Ptr

41do_malloc : Nat -> IOExcept String Ptr

@@ -79,27 +80,28 @@ do_poke ptr offset (b::bs)

79instance Handler RawMemory (IOExcept String) where

80instance Handler RawMemory (IOExcept String) where

80 handle () (Allocate n) k

81 handle () (Allocate n) k

81 = do ptr <- do_malloc n

82 = do ptr <- do_malloc n

82− k (CH ptr) ()

83+ k () (CH ptr)

83− handle (CH ptr) (Initialize {i} c size _) k

84+ handle {-{res = MemoryChunk _ offset}-} (CH ptr) (Initialize {i} c size _) k

84− = ioe_lift (do_memset ptr i c size) $> k (CH ptr) ()

85+ = ioe_lift (do_memset ptr i c size) $> k () (CH ptr)

85 handle (CH ptr) (Free) k

86 handle (CH ptr) (Free) k

86 = ioe_lift (do_free ptr) $> k () ()

87 = ioe_lift (do_free ptr) $> k () ()

87 handle (CH ptr) (Peek offset size _) k

88 handle (CH ptr) (Peek offset size _) k

88 = do res <- ioe_lift (do_peek ptr offset size)

89 = do res <- ioe_lift (do_peek ptr offset size)

89− k (CH ptr) res

90+ k res (CH ptr)

90 handle (CH ptr) (Poke offset content _) k

91 handle (CH ptr) (Poke offset content _) k

91 = do ioe_lift (do_poke ptr offset content)

92 = do ioe_lift (do_poke ptr offset content)

92− k (CH ptr) ()

93+ k () (CH ptr)

93 handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k

94 handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k

94 = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)

95 = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)

95− k (CH dest_ptr) ()

96+ k () (CH dest_ptr)

96 handle chunk (GetRawPtr) k

97 handle chunk (GetRawPtr) k

97 = k chunk chunk

98 = k chunk chunk

98

99

99RAW_MEMORY : Type -> EFFECT

100RAW_MEMORY : Type -> EFFECT

100RAW_MEMORY t = MkEff t RawMemory

101RAW_MEMORY t = MkEff t RawMemory

101

102

103+allocate : (n : Nat) ->

102−allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] ()

104+ Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

103allocate size = Allocate size

105allocate size = Allocate size

104

106

105initialize : {i : Nat} ->

107initialize : {i : Nat} ->

@@ -107,17 +109,18 @@ initialize : {i : Nat} ->

107 Bits8 ->

109 Bits8 ->

108 (size : Nat) ->

110 (size : Nat) ->

109 so (i + size <= n) ->

111 so (i + size <= n) ->

112+ Eff m () [RAW_MEMORY (MemoryChunk n i)]

110− EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] ()

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

111initialize c size prf = Initialize c size prf

114initialize c size prf = Initialize c size prf

112

115

113−free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] ()

116+free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

114free = Free

117free = Free

115

118

116peek : {i : Nat} ->

119peek : {i : Nat} ->

117 (offset : Nat) ->

120 (offset : Nat) ->

118 (size : Nat) ->

121 (size : Nat) ->

119 so (offset + size <= i) ->

122 so (offset + size <= i) ->

120− Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect size Bits8)

123+ { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8)

121peek offset size prf = Peek offset size prf

124peek offset size prf = Peek offset size prf

122

125

123poke : {n : Nat} ->

126poke : {n : Nat} ->

@@ -125,11 +128,12 @@ poke : {n : Nat} ->

125 (offset : Nat) ->

128 (offset : Nat) ->

126 Vect size Bits8 ->

129 Vect size Bits8 ->

127 so (offset <= i && offset + size <= n) ->

130 so (offset <= i && offset + size <= n) ->

131+ Eff m () [RAW_MEMORY (MemoryChunk n i)]

128− EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] ()

132+ (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))])

129poke offset content prf = Poke offset content prf

133poke offset content prf = Poke offset content prf

130

134

131private

135private

132−getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i)

136+getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i)

133getRawPtr = GetRawPtr

137getRawPtr = GetRawPtr

134

138

135private

139private

@@ -142,8 +146,8 @@ move' : {dst_size : Nat} ->

142 (size : Nat) ->

146 (size : Nat) ->

143 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

147 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

144 so (src_offset + size <= src_init) ->

148 so (src_offset + size <= src_init) ->

145− EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)]

149+ Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]

146− [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] ()

150+ (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))])

147move' src_ptr dst_offset src_offset size dst_bounds src_bounds

151move' src_ptr dst_offset src_offset size dst_bounds src_bounds

148 = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

152 = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

149

153

@@ -158,10 +162,12 @@ move : {dst_size : Nat} ->

158 (size : Nat) ->

162 (size : Nat) ->

159 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

163 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

160 so (src_offset + size <= src_init) ->

164 so (src_offset + size <= src_init) ->

165+ Eff m ()

161− EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)

166+ [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)

162 , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]

167 , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]

168+ (\v =>

163− [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))

169+ [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))

164− , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] ()

170+ , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)])

165move dst_offset src_offset size dst_bounds src_bounds

171move dst_offset src_offset size dst_bounds src_bounds

166 = do src_ptr <- Src :- getRawPtr

172 = do src_ptr <- Src :- getRawPtr

167 Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds

173 Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds

libs/effects/Effect/Monad.idr+4−4

@@ -5,17 +5,17 @@ import Effects

5-- Eff is a monad too, so we can happily use it in a monad transformer.

6

7using (xs : List EFFECT, m : Type -> Type)

8− instance Functor (EffM m xs xs) where

8+ instance Functor (\a => EffM m a xs (\v => xs)) where

9 map f prog = do t <- prog

10 value (f t)

11

12− instance Applicative (EffM m xs xs) where

12+ instance Applicative (\a => EffM m a xs (\v => xs)) where

13 pure = value

14 (<$>) f a = do f' <- f

15 a' <- a

16 value (f' a')

17

18− instance Monad (EffM m xs xs) where

18+ instance Monad (\a => Eff m a xs (\v => xs)) where

19− (>>=) = ebind

19+ (>>=) = Effects.(>>=)

20

21

libs/effects/Effect/Random.idr+14−6

@@ -2,24 +2,32 @@ module Effect.Random

2

3import Effects

4

5−data Random : Type -> Type -> Type -> Type where

5+data Random : Effect where

6− getRandom : Random Integer Integer Integer

6+ getRandom : { Integer } Random Integer

7− setSeed : Integer -> Random Integer Integer ()

7+ setSeed : Integer -> { Integer } Random ()

8

9using (m : Type -> Type)

10 instance Handler Random m where

11 handle seed getRandom k

12 = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in

13 k seed' seed'

14− handle seed (setSeed n) k = k n ()

14+ handle seed (setSeed n) k = k () n

15

16RND : EFFECT

17RND = MkEff Integer Random

18

19−rndInt : Integer -> Integer -> Eff m [RND] Integer

19+rndInt : Integer -> Integer -> { [RND] } Eff m Integer

20rndInt lower upper = do v <- getRandom

21 return (v `prim__sremBigInt` (upper - lower) + lower)

22

23+rndFin : (k : Nat) -> { [RND] } Eff m (Fin (S k))

24+rndFin k = do let v = !getRandom `prim__sremBigInt` (cast k)

25+ return (toFin v)

26+ where toFin : Integer -> Fin (S k)

27+ toFin x = case integerToFin x (S k) of

28+ Just v => v

29+ Nothing => toFin (assert_smaller x (x - cast (S k)))

30+

23−srand : Integer -> Eff m [RND] ()

31+srand : Integer -> { [RND] } Eff m ()

24srand n = setSeed n

32srand n = setSeed n

25

33

libs/effects/Effect/Select.idr+4−4

@@ -3,21 +3,21 @@ module Effect.Select

3import Effects

4

5data Selection : Effect where

6− Select : List a -> Selection () () a

6+ Select : List a -> { () } Selection a

7

8instance Handler Selection Maybe where

9 handle _ (Select xs) k = tryAll xs where

10 tryAll [] = Nothing

11− tryAll (x :: xs) = case k () x of

11+ tryAll (x :: xs) = case k x () of

12 Nothing => tryAll xs

13 Just v => Just v

14

15instance Handler Selection List where

16− handle r (Select xs) k = concatMap (k r) xs

16+ handle r (Select xs) k = concatMap (\x => k x r) xs

17

18SELECT : EFFECT

19SELECT = MkEff () Selection

20

21−select : List a -> Eff m [SELECT] a

21+select : List a -> { [SELECT] } Eff m a

22select xs = Select xs

23

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

@@ -5,33 +5,33 @@ import Effects

5%access public

6

7data State : Effect where

8− Get : State a a a

8+ Get : { a } State a

9− Put : b -> State a b ()

9+ Put : b -> { a ==> b } State ()

10

11using (m : Type -> Type)

12 instance Handler State m where

13 handle st Get k = k st st

14− handle st (Put n) k = k n ()

14+ handle st (Put n) k = k () n

15

16STATE : Type -> EFFECT

17STATE t = MkEff t State

18

19−get : Eff m [STATE x] x

19+get : { [STATE x] } Eff m x

20get = Get

21

22−put : x -> Eff m [STATE x] ()

22+put : x -> { [STATE x] } Eff m ()

23put val = Put val

24

25−putM : y -> EffM m [STATE x] [STATE y] ()

25+putM : y -> { [STATE x] ==> [STATE y] } Eff m ()

26putM val = Put val

27

28−update : (x -> x) -> Eff m [STATE x] ()

28+update : (x -> x) -> { [STATE x] } Eff m ()

29update f = put (f !get)

30

31−updateM : (x -> y) -> EffM m [STATE x] [STATE y] ()

31+updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff m ()

32updateM f = putM (f !get)

33

34−locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t

34+locally : x -> ({ [STATE x] } Eff m t) -> { [STATE y] } Eff m t

35locally newst prog = do st <- get

36 putM newst

37 val <- prog

libs/effects/Effect/StdIO.idr+19−36

@@ -4,57 +4,40 @@ import Effects

4import Control.IOExcept

5

6data StdIO : Effect where

7− PutStr : String -> StdIO () () ()

7+ PutStr : String -> { () } StdIO ()

8− GetStr : StdIO () () String

8+ GetStr : { () } StdIO String

9+ PutCh : Char -> { () } StdIO ()

10+ GetCh : { () } StdIO Char

9

11

10instance Handler StdIO IO where

12instance Handler StdIO IO where

11 handle () (PutStr s) k = do putStr s; k () ()

13 handle () (PutStr s) k = do putStr s; k () ()

12− handle () GetStr k = do x <- getLine; k () x

14+ handle () GetStr k = do x <- getLine; k x ()

15+ handle () (PutCh c) k = do putChar c; k () ()

16+ handle () GetCh k = do x <- getChar; k x ()

13

17

14instance Handler StdIO (IOExcept a) where

18instance Handler StdIO (IOExcept a) where

15− handle () (PutStr s) k = do ioe_lift (putStr s); k () ()

19+ handle () (PutStr s) k = do ioe_lift $ putStr s; k () ()

16− handle () GetStr k = do x <- ioe_lift getLine; k () x

20+ handle () GetStr k = do x <- ioe_lift $ getLine; k x ()

17−

21+ handle () (PutCh c) k = do ioe_lift $ putChar c; k () ()

18−-- Handle effects in a pure way, for simulating IO for unit testing/proof

22+ handle () GetCh k = do x <- ioe_lift $ getChar; k x ()

19−

20−data IOStream a = MkStream (List String -> (a, List String))

21−

22−instance Handler StdIO IOStream where

23− handle () (PutStr s) k

24− = MkStream (\x => case k () () of

25− MkStream f => let (res, str) = f x in

26− (res, s :: str))

27− handle {a} () GetStr k

28− = MkStream (\x => case x of

29− [] => cont "" []

30− (t :: ts) => cont t ts)

31− where

32− cont : String -> List String -> (a, List String)

33− cont t ts = case k () t of

34− MkStream f => f ts

35

23

36--- The Effect and associated functions

24--- The Effect and associated functions

37

25

38STDIO : EFFECT

26STDIO : EFFECT

39STDIO = MkEff () StdIO

27STDIO = MkEff () StdIO

40

28

41−putStr : Handler StdIO e => String -> Eff e [STDIO] ()

29+putStr : Handler StdIO e => String -> { [STDIO] } Eff e ()

42putStr s = PutStr s

30putStr s = PutStr s

43

31

32+putChar : Handler StdIO e => Char -> { [STDIO] } Eff e ()

33+putChar c = PutCh c

34+

44−putStrLn : Handler StdIO e => String -> Eff e [STDIO] ()

35+putStrLn : Handler StdIO e => String -> { [STDIO] } Eff e ()

45putStrLn s = putStr (s ++ "\n")

36putStrLn s = putStr (s ++ "\n")

46

37

47−getStr : Handler StdIO e => Eff e [STDIO] String

38+getStr : Handler StdIO e => { [STDIO] } Eff e String

48getStr = GetStr

39getStr = GetStr

49

40

50−mkStrFn : Env IOStream xs ->

41+getChar : Handler StdIO e => { [STDIO] } Eff e Char

51− Eff IOStream xs a ->

42+getChar = GetCh

52− List String -> (a, List String)

53−mkStrFn {a} env p input = case mkStrFn' of

54− MkStream f => f input

55− where injStream : a -> IOStream a

56− injStream v = MkStream (\x => (v, []))

57− mkStrFn' : IOStream a

58− mkStrFn' = runWith injStream env p

59−

60

43

libs/neweffects/Effect/System.idr → libs/effects/Effect/System.idrrenamed

The content is the same.

libs/effects/Effects.idr+191−157

@@ -2,23 +2,59 @@ module Effects

2

3import Language.Reflection

4import Control.Catchable

5+import Effect.Default

5

6

6−%access public

7+--- Effectful computations are described as algebraic data types that

7−

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

8−---- Effects

9

10+%access public

11+-- ----------------------------------------------------------------- [ Effects ]

12+||| The Effect type describes effectful computations.

13+|||

14+||| This type is parameterised by:

15+||| + The input resource.

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

17+||| + The computation to run on the resource.

10Effect : Type

18Effect : Type

11−Effect = Type -> Type -> Type -> Type

19+Effect = (x : Type) -> Type -> (x -> Type) -> Type

12

20

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

22+||| description into a concrete effect.

13%error_reverse

23%error_reverse

14data EFFECT : Type where

24data EFFECT : Type where

15 MkEff : Type -> Effect -> EFFECT

25 MkEff : Type -> Effect -> EFFECT

16

26

27+||| Handler classes describe how an effect `e` is translated to the

28+||| underlying computation context `m` for execution.

17class Handler (e : Effect) (m : Type -> Type) where

29class Handler (e : Effect) (m : Type -> Type) where

30+ ||| How to handle the effect.

31+ |||

32+ ||| @ r The resource being handled.

33+ ||| @ eff The effect to be applied.

34+ ||| @ ctxt The context in which to handle the effect.

18− handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a

35+ handle : (r : res) -> (eff : e t res resk) ->

36+ (ctxt : ((x : t) -> resk x -> m a)) -> m a

37+

38+||| Get the resource type (handy at the REPL to find out about an effect)

39+resourceType : EFFECT -> Type

40+resourceType (MkEff t e) = t

41+

42+-- --------------------------------------------------------- [ Syntactic Sugar ]

43+

44+-- A bit of syntactic sugar ('syntax' is not very flexible so we only go

45+-- up to a small number of parameters...)

19

46

20−---- Properties and proof construction

47+-- No state transition

48+syntax "{" [inst] "}" [eff] = eff inst (\result => inst)

21

49

50+-- The state transition is dependent on a result `b`, a bound variable.

51+syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff]

52+ = eff inst (\b => outst)

53+

54+--- A simple state transition

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

56+

57+-- --------------------------------------- [ Properties and Proof Construction ]

22using (xs : List a, ys : List a)

58using (xs : List a, ys : List a)

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

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

24 SubNil : SubList {a} [] []

60 SubNil : SubList {a} [] []

@@ -29,16 +65,17 @@ using (xs : List a, ys : List a)

29 subListId {xs = Nil} = SubNil

65 subListId {xs = Nil} = SubNil

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

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

31

67

68+namespace Env

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

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

33− Nil : Env m Nil

70+ Nil : Env m Nil

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

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

35−

72+

36−data EffElem : (Type -> Type -> Type -> Type) -> Type ->

73+data EffElem : Effect -> Type ->

37 List EFFECT -> Type where

74 List EFFECT -> Type where

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

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

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

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

40

77

41−-- make an environment corresponding to a sub-list

78+||| make an environment corresponding to a sub-list

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

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

43dropEnv [] SubNil = []

80dropEnv [] SubNil = []

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

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

@@ -52,7 +89,7 @@ updateWith [] [] SubNil = []

52updateWith (y :: ys) [] SubNil = y :: ys

89updateWith (y :: ys) [] SubNil = y :: ys

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

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

54

91

55−-- put things back, replacing old with new in the sub-environment

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

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

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

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

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

58rebuildEnv [] SubNil env = env

95rebuildEnv [] SubNil env = env

@@ -60,8 +97,7 @@ rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

60rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

97rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

61rebuildEnv (x :: xs) SubNil [] = x :: xs

98rebuildEnv (x :: xs) SubNil [] = x :: xs

62

99

63−---- The Effect EDSL itself ----

100+-- -------------------------------------------------- [ The Effect EDSL itself ]

64−

65-- some proof automation

101-- some proof automation

66

102

67%reflection

103%reflection

@@ -79,7 +115,7 @@ reflectListEffElem _ = Refine "Here" `Seq` Solve

79

115

80%reflection

116%reflection

81reflectSubList : List a -> Tactic

117reflectSubList : List a -> Tactic

82−reflectSubList [] = Refine "SubNil" `Seq` Solve

118+reflectSubList [] = Refine "subListId" `Seq` Solve

83reflectSubList (x :: xs)

119reflectSubList (x :: xs)

84 = Try (Refine "subListId" `Seq` Solve)

120 = Try (Refine "subListId" `Seq` Solve)

85 (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))

121 (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))

@@ -87,22 +123,34 @@ reflectSubList (x :: xs)

87reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve

123reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve

88reflectSubList _ = Refine "subListId" `Seq` Solve

124reflectSubList _ = Refine "subListId" `Seq` Solve

89

125

126+%reflection

127+reflectDefaultList : List a -> Tactic

128+reflectDefaultList [] = Refine "enil" `Seq` Solve

129+reflectDefaultList (x :: xs)

130+ = Refine "econs" `Seq`

131+ (Solve `Seq`

132+ (Instance `Seq`

133+ (Refine "default" `Seq`

134+ (Solve `Seq`

135+ (Instance `Seq`

136+ (reflectDefaultList xs))))))

137+reflectDefaultList (x ++ y) = Refine "Nil" `Seq` Solve

138+reflectDefaultList _ = Refine "Nil" `Seq` Solve

139+

90%reflection

140%reflection

91reflectEff : (P : Type) -> Tactic

141reflectEff : (P : Type) -> Tactic

92reflectEff (EffElem m a xs)

142reflectEff (EffElem m a xs)

93 = reflectListEffElem xs `Seq` Solve

143 = reflectListEffElem xs `Seq` Solve

94reflectEff (SubList xs ys)

144reflectEff (SubList xs ys)

95 = reflectSubList ys `Seq` Solve

145 = reflectSubList ys `Seq` Solve

146+reflectEff (Env m xs)

147+ = reflectDefaultList xs `Seq` Solve

96

148

149+updateResTy : (val : t) ->

97−updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t ->

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

98 List EFFECT

151 List EFFECT

99−updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs

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

100−updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n

153+updateResTy val (x :: xs) (There p) n = x :: updateResTy val xs p n

101−

102−updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->

103− List EFFECT

104−updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs

105−updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b

106

154

107infix 5 :::, :-, :=

155infix 5 :::, :-, :=

108

156

@@ -110,148 +158,103 @@ data LRes : lbl -> Type -> Type where

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

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

111

159

112(:::) : lbl -> EFFECT -> EFFECT

160(:::) : lbl -> EFFECT -> EFFECT

113−(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff

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

162+

163+using (lbl : Type)

164+ instance Default a => Default (LRes lbl a) where

165+ default = lbl := default

114

166

115private

167private

116unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]

168unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]

117unlabel {m} {x = MkEff a eff} [l := v] = [v]

169unlabel {m} {x = MkEff a eff} [l := v] = [v]

118

170

119private

171private

120−relabel : (l : ty) -> Env m [x] -> Env m [l ::: x]

172+relabel : (l : ty) -> Env m xs -> Env m (map (\x => l ::: x) xs)

173+relabel {xs = []} l [] = []

121−relabel {x = MkEff a eff} l [v] = [l := v]

174+relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

122−

175+

123−-- the language of Effects

176+-- ------------------------------------------------- [ The Language of Effects ]

124−

177+||| Definition of an Effect.

178+|||

179+||| @ m The computation context

180+||| @ x The return type of the result.

181+||| @ es The list of allowed side-effects.

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

125−data EffM : (m : Type -> Type) ->

183+data Eff : (m : Type -> Type)

184+ -> (x : Type)

126− List EFFECT -> List EFFECT -> Type -> Type where

185+ -> (es : List EFFECT)

186+ -> (ce : x -> List EFFECT) -> Type where

127− value : a -> EffM m xs xs a

187+ value : a -> Eff m a xs (\v => xs)

188+ with_val : (val : a) -> Eff m () xs (\v => xs' val) ->

189+ Eff m a xs xs'

128− ebind : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b

190+ ebind : Eff m a xs xs' ->

191+ ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''

129− effect : (prf : EffElem e a xs) ->

192+ effect : (prf : EffElem e a xs) ->

130− (eff : e a b t) ->

193+ (eff : e t a b) ->

131− EffM m xs (updateResTy xs prf eff) t

194+ Eff m t xs (\v => updateResTy v xs prf eff)

195+

132− lift : (prf : SubList ys xs) ->

196+ lift : (prf : SubList ys xs) ->

133− EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t

197+ Eff m t ys ys' -> Eff m t xs (\v => updateWith (ys' v) xs prf)

134− new : Handler e m =>

198+ newInit : Handler e m =>

199+ res ->

135− res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a ->

200+ Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->

136− EffM m xs xs' a

201+ Eff m a xs (\v => xs')

137− test : (prf : EffElem e (Either l r) xs) ->

138− EffM m (updateResTyImm xs prf l) xs' t ->

139− EffM m (updateResTyImm xs prf r) xs' t ->

140− EffM m xs xs' t

141− test_lbl : {x : lbl} ->

142− (prf : EffElem e (LRes x (Either l r)) xs) ->

143− EffM m (updateResTyImm xs prf (LRes x l)) xs' t ->

144− EffM m (updateResTyImm xs prf (LRes x r)) xs' t ->

145− EffM m xs xs' t

146− catch : Catchable m err =>

202+ catch : Catchable m err =>

147− EffM m xs xs' a -> (err -> EffM m xs xs' a) ->

203+ Eff m a xs xs' -> (err -> Eff m a xs xs') ->

148− EffM m xs xs' a

204+ Eff m a xs xs'

149− (:-) : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t

205+

150−

206+ (:-) : (l : ty) ->

151−syntax [tag] ":!" [val] = !(tag :- val)

207+ Eff m t [x] xs' -> -- [x] (\v => xs) ->

152−

208+ Eff m t [l ::: x] (\v => map (l :::) (xs' v))

153−-- Eff : List (EFFECT m) -> Type -> Type

209+

154−

210+(>>=) : Eff m a xs xs' ->

155−-- For making proofs implicitly for 'test' and 'test_lbl'

211+ ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''

156−

212+(>>=) = ebind

157−syntax if_valid then [e] else [t] =

213+

158− test (tactics { byReflection reflectEff; }) t e

214+return : a -> Eff m a xs (\v => xs)

159−

160−syntax if_valid [lbl] then [e] else [t] =

161− test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

162−

163−syntax if_error then [t] else [e] =

164− test (tactics { byReflection reflectEff; }) t e

165−

166−syntax if_error [lbl] then [t] else [e] =

167− test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

168−

169−-- These may read better in some contexts

170−

171−syntax if_right then [e] else [t] =

172− test (tactics { byReflection reflectEff; }) t e

173−

174−syntax if_right [lbl] then [e] else [t] =

175− test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

176−

177−syntax if_left then [t] else [e] =

178− test (tactics { byReflection reflectEff; }) t e

179−

180−syntax if_left [lbl] then [t] else [e] =

181− test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

182−

183−

184−-- for 'do' notation

185−

186−return : a -> EffM m xs xs a

187return x = value x

215return x = value x

188

216

189−(>>=) : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b

190−(>>=) = ebind

191−

192−-- for idiom brackets

217+-- ------------------------------------------------------ [ for idiom brackets ]

193

218

194infixl 2 <$>

219infixl 2 <$>

195

220

196−pure : a -> EffM m xs xs a

221+pure : a -> Eff m a xs (\v => xs)

197pure = value

222pure = value

198

223

199−(<$>) : EffM m xs xs (a -> b) -> EffM m xs xs a -> EffM m xs xs b

224+syntax pureM [val] = with_val val (pure ())

225+

226+(<$>) : Eff m (a -> b) xs (\v => xs) ->

227+ Eff m a xs (\v => xs) -> Eff m b xs (\v => xs)

200(<$>) prog v = do fn <- prog

228(<$>) prog v = do fn <- prog

201 arg <- v

229 arg <- v

202 return (fn arg)

230 return (fn arg)

203

231

204−-- an interpreter

232+-- ---------------------------------------------------------- [ an interpreter ]

205

233

206private

234private

207execEff : Env m xs -> (p : EffElem e res xs) ->

235execEff : Env m xs -> (p : EffElem e res xs) ->

208− (eff : e res b a) ->

236+ (eff : e a res resk) ->

209− (Env m (updateResTy xs p eff) -> a -> m t) -> m t

237+ ((v : a) -> Env m (updateResTy v xs p eff) -> m t) -> m t

210execEff (val :: env) Here eff' k

238execEff (val :: env) Here eff' k

211− = handle val eff' (\res, v => k (res :: env) v)

239+ = handle val eff' (\v, res => k v (res :: env))

240+-- FIXME: Teach the elaborator to propagate parameters here

212−execEff {e} {res} {b} {a} (val :: env) (There p) eff k

241+execEff {e} {a} {res} {resk} (val :: env) (There p) eff k

213− = execEff {e} {res} {b} {a} env p eff (\env', v => k (val :: env') v)

242+ = execEff {e} {a} {res} {resk} env p eff (\v, env' => k v (val :: env'))

214−

215−private

216−testEff : Env m xs -> (p : EffElem e (Either l r) xs) ->

217− (Env m (updateResTyImm xs p l) -> m b) ->

218− (Env m (updateResTyImm xs p r) -> m b) ->

219− m b

220−testEff (Left err :: env) Here lk rk = lk (err :: env)

221−testEff (Right ok :: env) Here lk rk = rk (ok :: env)

222−testEff (val :: env) (There p) lk rk

223− = testEff env p (\envk => lk (val :: envk))

224− (\envk => rk (val :: envk))

225−

226−private

227−testEffLbl : {x : lblTy} ->

228− Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) ->

229− (Env m (updateResTyImm xs p (LRes x l)) -> m b) ->

230− (Env m (updateResTyImm xs p (LRes x r)) -> m b) ->

231− m b

232−testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env)

233−testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env)

234−testEffLbl (val :: env) (There p) lk rk

235− = testEffLbl env p (\envk => lk (val :: envk))

236− (\envk => rk (val :: envk))

237

243

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

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

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

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

240

246

241−eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b

247+eff : Env m xs -> Eff m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

242−eff env (value x) k = k env x

248+eff env (value x) k = k x env

249+eff env (with_val x prog) k = eff env prog (\p', env' => k x env')

243eff env (prog `ebind` c) k

250eff env (prog `ebind` c) k

244− = eff env prog (\env', p' => eff env' (c p') k)

251+ = eff env prog (\p', env' => eff env' (c p') k)

245eff env (effect prf effP) k = execEff env prf effP k

252eff env (effect prf effP) k = execEff env prf effP k

246eff env (lift prf effP) k

253eff env (lift prf effP) k

247 = let env' = dropEnv env prf in

254 = let env' = dropEnv env prf in

248− eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p')

255+ eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))

249−eff env (new r prog) k

256+eff env (newInit r prog) k

250− = eff (r :: env) prog (\(v :: envk), p' => k envk p')

257+ = eff (r :: env) prog (\p' => \ (v :: envk) => k p' envk)

251−eff env (test prf l r) k

252− = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)

253−eff env (test_lbl prf l r) k

254− = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k)

255eff env (catch prog handler) k

258eff env (catch prog handler) k

256 = catch (eff env prog k)

259 = catch (eff env prog k)

257 (\e => eff env (handler e) k)

260 (\e => eff env (handler e) k)

@@ -261,48 +264,79 @@ eff env (catch prog handler) k

261-- end so that everything is in scope when it needs to be.

264-- end so that everything is in scope when it needs to be.

262eff {xs = [l ::: x]} env (l :- prog) k

265eff {xs = [l ::: x]} env (l :- prog) k

263 = let env' = unlabel env in

266 = let env' = unlabel env in

264− eff env' prog (\envk, p' => k (relabel l envk) p')

267+ eff env' prog (\p', envk => k p' (relabel l envk))

268+

269+-- yuck :) Haven't got type class instances working nicely in tactic

270+-- proofs yet, so just brute force it.

271+syntax MkDefaultEnv = with Env

272+ (| [], [default], [default, default],

273+ [default, default, default],

274+ [default, default, default, default],

275+ [default, default, default, default, default],

276+ [default, default, default, default, default, default],

277+ [default, default, default, default, default, default, default],

278+ [default, default, default, default, default, default, default, default] |)

265

279

266implicit

280implicit

267−lift' : EffM m ys ys' t ->

281+lift' : Eff m t ys ys' ->

268 {default tactics { byReflection reflectEff; }

282 {default tactics { byReflection reflectEff; }

269 prf : SubList ys xs} ->

283 prf : SubList ys xs} ->

270− EffM m xs (updateWith ys' xs prf) t

284+ Eff m t xs (\v => updateWith (ys' v) xs prf)

271lift' e {prf} = lift prf e

285lift' e {prf} = lift prf e

272

286

273implicit

287implicit

274effect' : {a, b: _} -> {e : Effect} ->

288effect' : {a, b: _} -> {e : Effect} ->

275− (eff : e a b t) ->

289+ (eff : e t a b) ->

276 {default tactics { byReflection reflectEff; }

290 {default tactics { byReflection reflectEff; }

277 prf : EffElem e a xs} ->

291 prf : EffElem e a xs} ->

278− EffM m xs (updateResTy xs prf eff) t

292+ Eff m t xs (\v => updateResTy v xs prf eff)

279effect' e {prf} = effect prf e

293effect' e {prf} = effect prf e

280

294

295+new : Handler e m =>

296+ {default default r : res} ->

297+ Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->

298+ Eff m a xs (\v => xs')

299+new {r} e = newInit r e

281

300

282−run : Applicative m => Env m xs -> EffM m xs xs' a -> m a

301+-- --------------------------------------------------------- [ Running Effects ]

283−run env prog = eff env prog (\env, r => pure r)

284

302

303+||| Run an effectful program

285−runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a)

304+run : Applicative m => {default MkDefaultEnv env : Env m xs} -> Eff m a xs xs' -> m a

286−runEnv env prog = eff env prog (\env, r => pure (env, r))

305+run {env} prog = eff env prog (\r, env => pure r)

287

306

288−runPure : Env id xs -> EffM id xs xs' a -> a

307+runPure : {default MkDefaultEnv env : Env id xs} -> Eff id a xs xs' -> a

289−runPure env prog = eff env prog (\env, r => r)

308+runPure {env} prog = eff env prog (\r, env => r)

290

309

291−-- runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a)

310+runInit : Applicative m => Env m xs -> Eff m a xs xs' -> m a

292−-- runPureEnv env prog = eff env prog (\env, r => (env, r))

311+runInit env prog = eff env prog (\r, env => pure r)

293

312

294−runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a

313+runPureInit : Env id xs -> Eff id a xs xs' -> a

295−runWith inj env prog = eff env prog (\env, r => inj r)

314+runPureInit env prog = eff env prog (\r, env => r)

296

315

297−Eff : (Type -> Type) -> List EFFECT -> Type -> Type

316+runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a

298−Eff m xs t = EffM m xs xs t

317+runWith inj env prog = eff env prog (\r, env => inj r)

299

318

300−-- some higher order things

319+runEnv : Applicative m => Env m xs -> Eff m a xs xs' ->

320+ m (x : a ** Env m (xs' x))

321+runEnv env prog = eff env prog (\r, env => pure (r ** env))

301

322

323+-- ----------------------------------------------- [ some higher order things ]

324+

302−mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b)

325+mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b)

303mapE f [] = pure []

326mapE f [] = pure []

304mapE f (x :: xs) = [| f x :: mapE f xs |]

327mapE f (x :: xs) = [| f x :: mapE f xs |]

305

328

329+

330+mapVE : Applicative m =>

331+ (a -> {xs} Eff m b) ->

332+ Vect n a ->

333+ {xs} Eff m (Vect n b)

334+mapVE f [] = pure []

335+mapVE f (x :: xs) = [| f x :: mapVE f xs |]

336+

337+

306−when : Applicative m => Bool -> Eff m xs () -> Eff m xs ()

338+when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m ()

307when True e = e

339when True e = e

308when False e = pure ()

340when False e = pure ()

341+

342+-- --------------------------------------------------------------------- [ EOF ]

libs/effects/effects.ipkg+3−2

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

1package effects

2

3opts = "--nobasepkgs -i ../prelude -i ../base"

4−modules = Effects,

4+modules = Effects, Effect.Default,

5+

5 Effect.Exception, Effect.File, Effect.State,

6 Effect.Exception, Effect.File, Effect.State,

6 Effect.Random, Effect.StdIO, Effect.Select,

7 Effect.Random, Effect.StdIO, Effect.Select,

7− Effect.Memory, Effect.Monad

8+ Effect.Memory, Effect.System

8

9

libs/neweffects/Effect/File.idrdeleted−62

@@ -1,62 +0,0 @@

1−module Effect.File

2−

3−import Effects

4−import Control.IOExcept

5−

6−data OpenFile : Mode -> Type where

7− FH : File -> OpenFile m

8−

9−openOK : Mode -> Bool -> Type

10−openOK m True = OpenFile m

11−openOK m False = ()

12−

13−data FileIO : Effect where

14− Open : String -> (m : Mode) ->

15− {() ==> {res} if res then OpenFile m else ()} FileIO Bool

16− Close : {OpenFile m ==> ()} FileIO ()

17−

18− ReadLine : {OpenFile Read} FileIO String

19− WriteLine : String -> {OpenFile Write} FileIO ()

20− EOF : {OpenFile Read} FileIO Bool

21−

22−instance Handler FileIO IO where

23− handle () (Open fname m) k = do h <- openFile fname m

24− valid <- validFile h

25− if valid then k True (FH h)

26− else k False ()

27− handle (FH h) Close k = do closeFile h

28− k () ()

29− handle (FH h) ReadLine k = do str <- fread h

30− k str (FH h)

31− handle (FH h) (WriteLine str) k = do fwrite h str

32− k () (FH h)

33− handle (FH h) EOF k = do e <- feof h

34− k e (FH h)

35−

36−FILE_IO : Type -> EFFECT

37−FILE_IO t = MkEff t FileIO

38−

39−open : Handler FileIO e =>

40− String -> (m : Mode) ->

41− { [FILE_IO ()] ==> [FILE_IO (if result then OpenFile m else ())] } Eff e Bool

42−open f m = Open f m

43−

44−close : Handler FileIO e =>

45− { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e ()

46−close = Close

47−

48−readLine : Handler FileIO e =>

49− { [FILE_IO (OpenFile Read)] } Eff e String

50−readLine = ReadLine

51−

52−writeLine : Handler FileIO e =>

53− String -> { [FILE_IO (OpenFile Write)] } Eff e ()

54−writeLine str = WriteLine str

55−

56−eof : Handler FileIO e =>

57− { [FILE_IO (OpenFile Read)] } Eff e Bool

58−eof = EOF

59−

60−

61−

62−

libs/neweffects/Effect/Random.idrdeleted−33

@@ -1,33 +0,0 @@

1−module Effect.Random

2−

3−import Effects

4−

5−data Random : Effect where

6− getRandom : { Integer } Random Integer

7− setSeed : Integer -> { Integer } Random ()

8−

9−using (m : Type -> Type)

10− instance Handler Random m where

11− handle seed getRandom k

12− = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in

13− k seed' seed'

14− handle seed (setSeed n) k = k () n

15−

16−RND : EFFECT

17−RND = MkEff Integer Random

18−

19−rndInt : Integer -> Integer -> { [RND] } Eff m Integer

20−rndInt lower upper = do v <- getRandom

21− return (v `prim__sremBigInt` (upper - lower) + lower)

22−

23−rndFin : (k : Nat) -> { [RND] } Eff m (Fin (S k))

24−rndFin k = do let v = !getRandom `prim__sremBigInt` (cast k)

25− return (toFin v)

26− where toFin : Integer -> Fin (S k)

27− toFin x = case integerToFin x (S k) of

28− Just v => v

29− Nothing => toFin (assert_smaller x (x - cast (S k)))

30−

31−srand : Integer -> { [RND] } Eff m ()

32−srand n = setSeed n

33−

libs/neweffects/Effect/StdIO.idrdeleted−43

@@ -1,43 +0,0 @@

1−module Effect.StdIO

2−

3−import Effects

4−import Control.IOExcept

5−

6−data StdIO : Effect where

7− PutStr : String -> { () } StdIO ()

8− GetStr : { () } StdIO String

9− PutCh : Char -> { () } StdIO ()

10− GetCh : { () } StdIO Char

11−

12−instance Handler StdIO IO where

13− handle () (PutStr s) k = do putStr s; k () ()

14− handle () GetStr k = do x <- getLine; k x ()

15− handle () (PutCh c) k = do putChar c; k () ()

16− handle () GetCh k = do x <- getChar; k x ()

17−

18−instance Handler StdIO (IOExcept a) where

19− handle () (PutStr s) k = do ioe_lift $ putStr s; k () ()

20− handle () GetStr k = do x <- ioe_lift $ getLine; k x ()

21− handle () (PutCh c) k = do ioe_lift $ putChar c; k () ()

22− handle () GetCh k = do x <- ioe_lift $ getChar; k x ()

23−

24−--- The Effect and associated functions

25−

26−STDIO : EFFECT

27−STDIO = MkEff () StdIO

28−

29−putStr : Handler StdIO e => String -> { [STDIO] } Eff e ()

30−putStr s = PutStr s

31−

32−putChar : Handler StdIO e => Char -> { [STDIO] } Eff e ()

33−putChar c = PutCh c

34−

35−putStrLn : Handler StdIO e => String -> { [STDIO] } Eff e ()

36−putStrLn s = putStr (s ++ "\n")

37−

38−getStr : Handler StdIO e => { [STDIO] } Eff e String

39−getStr = GetStr

40−

41−getChar : Handler StdIO e => { [STDIO] } Eff e Char

42−getChar = GetCh

43−

libs/neweffects/Effects.idrdeleted−311

@@ -1,311 +0,0 @@

1−module Effects

2−

3−import Language.Reflection

4−import Control.Catchable

5−import Effect.Default

6−

7−%access public

8−

9−---- Effects

10−

11−Effect : Type

12−Effect = (x : Type) -> Type -> (x -> Type) -> Type

13−

14−%error_reverse

15−data EFFECT : Type where

16− MkEff : Type -> Effect -> EFFECT

17−

18−class Handler (e : Effect) (m : Type -> Type) where

19− handle : res -> (eff : e t res resk) ->

20− ((x : t) -> resk x -> m a) -> m a

21−

22−-- Get the resource type (handy at the REPL to find out about an effect)

23−resourceType : EFFECT -> Type

24−resourceType (MkEff t e) = t

25−

26−-- A bit of syntactic sugar ('syntax' is not very flexible so we only go

27−-- up to a small number of parameters...)

28−

29−syntax "{" [inst] "}" [eff] = eff inst (\result => inst)

30−syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff]

31− = eff inst (\b => outst)

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

33−

34−---- Properties and proof construction

35−

36−using (xs : List a, ys : List a)

37− data SubList : List a -> List a -> Type where

38− SubNil : SubList {a} [] []

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

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

41−

42− subListId : SubList xs xs

43− subListId {xs = Nil} = SubNil

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

45−

46−namespace Env

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

48− Nil : Env m Nil

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

50−

51−data EffElem : Effect -> Type ->

52− List EFFECT -> Type where

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

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

55−

56−-- make an environment corresponding to a sub-list

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

58−dropEnv [] SubNil = []

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

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

61−

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

63− SubList ys xs -> List a

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

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

66−updateWith [] [] SubNil = []

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

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

69−

70−-- put things back, replacing old with new in the sub-environment

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

72− Env m xs -> Env m (updateWith ys' xs prf)

73−rebuildEnv [] SubNil env = env

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

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

76−rebuildEnv (x :: xs) SubNil [] = x :: xs

77−

78−---- The Effect EDSL itself ----

79−

80−-- some proof automation

81−

82−%reflection

83−reflectListEffElem : List a -> Tactic

84−reflectListEffElem [] = Refine "Here" `Seq` Solve

85−reflectListEffElem (x :: xs)

86− = Try (Refine "Here" `Seq` Solve)

87− (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))

88−-- TMP HACK! FIXME!

89−-- The evaluator needs a 'function case' to know its a reflection function

90−-- until we propagate that information! Without this, the _ case won't get

91−-- matched.

92−reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve

93−reflectListEffElem _ = Refine "Here" `Seq` Solve

94−

95−%reflection

96−reflectSubList : List a -> Tactic

97−reflectSubList [] = Refine "subListId" `Seq` Solve

98−reflectSubList (x :: xs)

99− = Try (Refine "subListId" `Seq` Solve)

100− (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))

101− (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))

102−reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve

103−reflectSubList _ = Refine "subListId" `Seq` Solve

104−

105−%reflection

106−reflectDefaultList : List a -> Tactic

107−reflectDefaultList [] = Refine "enil" `Seq` Solve

108−reflectDefaultList (x :: xs)

109− = Refine "econs" `Seq`

110− (Solve `Seq`

111− (Instance `Seq`

112− (Refine "default" `Seq`

113− (Solve `Seq`

114− (Instance `Seq`

115− (reflectDefaultList xs))))))

116−reflectDefaultList (x ++ y) = Refine "Nil" `Seq` Solve

117−reflectDefaultList _ = Refine "Nil" `Seq` Solve

118−

119−%reflection

120−reflectEff : (P : Type) -> Tactic

121−reflectEff (EffElem m a xs)

122− = reflectListEffElem xs `Seq` Solve

123−reflectEff (SubList xs ys)

124− = reflectSubList ys `Seq` Solve

125−reflectEff (Env m xs)

126− = reflectDefaultList xs `Seq` Solve

127−

128−updateResTy : (val : t) ->

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

130− List EFFECT

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

132−updateResTy val (x :: xs) (There p) n = x :: updateResTy val xs p n

133−

134−-- updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->

135−-- List EFFECT

136−-- updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs

137−-- updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b

138−

139−infix 5 :::, :-, :=

140−

141−data LRes : lbl -> Type -> Type where

142− (:=) : (x : lbl) -> res -> LRes x res

143−

144−(:::) : lbl -> EFFECT -> EFFECT

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

146−

147−using (lbl : Type)

148− instance Default a => Default (LRes lbl a) where

149− default = lbl := default

150−

151−private

152−unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]

153−unlabel {m} {x = MkEff a eff} [l := v] = [v]

154−

155−private

156−relabel : (l : ty) -> Env m xs -> Env m (map (\x => l ::: x) xs)

157−relabel {xs = []} l [] = []

158−relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

159−

160−-- the language of Effects

161−

162−data Eff : (m : Type -> Type) ->

163− (x : Type) ->

164− List EFFECT -> (x -> List EFFECT) -> Type where

165− value : a -> Eff m a xs (\v => xs)

166− ebind : Eff m a xs xs' ->

167− ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''

168− effect : (prf : EffElem e a xs) ->

169− (eff : e t a b) ->

170− Eff m t xs (\v => updateResTy v xs prf eff)

171−

172− lift : (prf : SubList ys xs) ->

173− Eff m t ys ys' -> Eff m t xs (\v => updateWith (ys' v) xs prf)

174− newInit : Handler e m =>

175− res ->

176− Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->

177− Eff m a xs (\v => xs')

178− catch : Catchable m err =>

179− Eff m a xs xs' -> (err -> Eff m a xs xs') ->

180− Eff m a xs xs'

181−

182− (:-) : (l : ty) ->

183− Eff m t [x] xs' -> -- [x] (\v => xs) ->

184− Eff m t [l ::: x] (\v => map (l :::) (xs' v))

185−

186−(>>=) : Eff m a xs xs' ->

187− ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''

188−(>>=) = ebind

189−

190−return : a -> Eff m a xs (\v => xs)

191−return x = value x

192−

193−-- for idiom brackets

194−

195−infixl 2 <$>

196−

197−pure : a -> Eff m a xs (\v => xs)

198−pure = value

199−

200−(<$>) : Eff m (a -> b) xs (\v => xs) ->

201− Eff m a xs (\v => xs) -> Eff m b xs (\v => xs)

202−(<$>) prog v = do fn <- prog

203− arg <- v

204− return (fn arg)

205−

206−-- an interpreter

207−

208−private

209−execEff : Env m xs -> (p : EffElem e res xs) ->

210− (eff : e a res resk) ->

211− ((v : a) -> Env m (updateResTy v xs p eff) -> m t) -> m t

212−execEff (val :: env) Here eff' k

213− = handle val eff' (\v, res => k v (res :: env))

214−-- FIXME: Teach the elaborator to propagate parameters here

215−execEff {e} {a} {res} {resk} (val :: env) (There p) eff k

216− = execEff {e} {a} {res} {resk} env p eff (\v, env' => k v (val :: env'))

217−

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

219−-- updates can be propagated even through failing computations?

220−

221−eff : Env m xs -> Eff m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

222−eff env (value x) k = k x env

223−eff env (prog `ebind` c) k

224− = eff env prog (\p', env' => eff env' (c p') k)

225−eff env (effect prf effP) k = execEff env prf effP k

226−eff env (lift prf effP) k

227− = let env' = dropEnv env prf in

228− eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))

229−eff env (newInit r prog) k

230− = eff (r :: env) prog (\p' => \ (v :: envk) => k p' envk)

231−eff env (catch prog handler) k

232− = catch (eff env prog k)

233− (\e => eff env (handler e) k)

234−-- FIXME:

235−-- xs is needed explicitly because otherwise the pattern binding for

236−-- 'l' appears too late. Solution seems to be to reorder patterns at the

237−-- end so that everything is in scope when it needs to be.

238−eff {xs = [l ::: x]} env (l :- prog) k

239− = let env' = unlabel env in

240− eff env' prog (\p', envk => k p' (relabel l envk))

241−

242−-- yuck :) Haven't got type class instances working nicely in tactic

243−-- proofs yet, so just brute force it.

244−syntax MkDefaultEnv = with Env

245− (| [], [default], [default, default],

246− [default, default, default],

247− [default, default, default, default],

248− [default, default, default, default, default],

249− [default, default, default, default, default, default],

250− [default, default, default, default, default, default, default],

251− [default, default, default, default, default, default, default, default] |)

252−

253−implicit

254−lift' : Eff m t ys ys' ->

255− {default tactics { byReflection reflectEff; }

256− prf : SubList ys xs} ->

257− Eff m t xs (\v => updateWith (ys' v) xs prf)

258−lift' e {prf} = lift prf e

259−

260−implicit

261−effect' : {a, b: _} -> {e : Effect} ->

262− (eff : e t a b) ->

263− {default tactics { byReflection reflectEff; }

264− prf : EffElem e a xs} ->

265− Eff m t xs (\v => updateResTy v xs prf eff)

266−effect' e {prf} = effect prf e

267−

268−new : Handler e m =>

269− {default default r : res} ->

270− Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->

271− Eff m a xs (\v => xs')

272−new {r} e = newInit r e

273−

274−run : Applicative m => {default MkDefaultEnv env : Env m xs} -> Eff m a xs xs' -> m a

275−run {env} prog = eff env prog (\r, env => pure r)

276−

277−runPure : {default MkDefaultEnv env : Env id xs} -> Eff id a xs xs' -> a

278−runPure {env} prog = eff env prog (\r, env => r)

279−

280−runInit : Applicative m => Env m xs -> Eff m a xs xs' -> m a

281−runInit env prog = eff env prog (\r, env => pure r)

282−

283−runPureInit : Env id xs -> Eff id a xs xs' -> a

284−runPureInit env prog = eff env prog (\r, env => r)

285−

286−runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a

287−runWith inj env prog = eff env prog (\r, env => inj r)

288−

289−runEnv : Applicative m => Env m xs -> Eff m a xs xs' ->

290− m (x : a ** Env m (xs' x))

291−runEnv env prog = eff env prog (\r, env => pure (r ** env))

292−

293−-- some higher order things

294−

295−mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b)

296−mapE f [] = pure []

297−mapE f (x :: xs) = [| f x :: mapE f xs |]

298−

299−

300−mapVE : Applicative m =>

301− (a -> {xs} Eff m b) ->

302− Vect n a ->

303− {xs} Eff m (Vect n b)

304−mapVE f [] = pure []

305−mapVE f (x :: xs) = [| f x :: mapVE f xs |]

306−

307−

308−when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m ()

309−when True e = e

310−when False e = pure ()

311−

libs/neweffects/Effect/Exception.idr → libs/oldeffects/Effect/Exception.idrrenamed+4−6

@@ -4,15 +4,12 @@ import Effects

4import System

5import Control.IOExcept

6

7−data Exception : Type -> Effect where

7+data Exception : Type -> Type -> Type -> Type -> Type where

8− Raise : a -> { () } Exception a b

8+ Raise : a -> Exception a () () b

9

10instance Handler (Exception a) Maybe where

11 handle _ (Raise e) k = Nothing

12

13−instance Handler (Exception a) List where

14− handle _ (Raise e) k = []

15−

16instance Show a => Handler (Exception a) IO where

13instance Show a => Handler (Exception a) IO where

17 handle _ (Raise e) k = do print e

14 handle _ (Raise e) k = do print e

18 believe_me (exit 1)

15 believe_me (exit 1)

@@ -26,7 +23,7 @@ instance Handler (Exception a) (Either a) where

26EXCEPTION : Type -> EFFECT

23EXCEPTION : Type -> EFFECT

27EXCEPTION t = MkEff () (Exception t)

24EXCEPTION t = MkEff () (Exception t)

28

25

29−raise : a -> { [EXCEPTION a ] } Eff m b

26+raise : a -> Eff m [EXCEPTION a] b

30raise err = Raise err

27raise err = Raise err

31

28

32

29

@@ -34,6 +31,7 @@ raise err = Raise err

34

31

35

32

36

33

34+

37-- TODO: Catching exceptions mid program?

35-- TODO: Catching exceptions mid program?

38-- probably need to invoke a new interpreter

36-- probably need to invoke a new interpreter

39

37

libs/oldeffects/Effect/File.idrnew file+69

@@ -0,0 +1,69 @@

1+module Effect.File

2+

3+import Effects

4+import Control.IOExcept

5+

6+data OpenFile : Mode -> Type where

7+ FH : File -> OpenFile m

8+

9+data FileIO : Effect where

10+ Open : String -> (m : Mode) -> FileIO () (Either () (OpenFile m)) Bool

11+ Close : FileIO (OpenFile m) () ()

12+

13+ ReadLine : FileIO (OpenFile Read) (OpenFile Read) String

14+ WriteLine : String -> FileIO (OpenFile Write) (OpenFile Write) ()

15+ EOF : FileIO (OpenFile Read) (OpenFile Read) Bool

16+

17+

18+instance Handler FileIO IO where

19+ handle () (Open fname m) k = do h <- openFile fname m

20+ valid <- validFile h

21+ if valid then k (Right (FH h)) True

22+ else k (Left ()) False

23+ handle (FH h) Close k = do closeFile h

24+ k () ()

25+ handle (FH h) ReadLine k = do str <- fread h

26+ k (FH h) str

27+ handle (FH h) (WriteLine str) k = do fwrite h str

28+ k (FH h) ()

29+ handle (FH h) EOF k = do e <- feof h

30+ k (FH h) e

31+

32+instance Handler FileIO (IOExcept String) where

33+ handle () (Open fname m) k

34+ = do h <- ioe_lift (openFile fname m)

35+ valid <- ioe_lift (validFile h)

36+ if valid then k (Right (FH h)) True

37+ else k (Left ()) False

38+ handle (FH h) Close k = do ioe_lift (closeFile h); k () ()

39+ handle (FH h) ReadLine k = do str <- ioe_lift (fread h)

40+ k (FH h) str

41+ handle (FH h) (WriteLine str) k = do ioe_lift (fwrite h str)

42+ k (FH h) ()

43+ handle (FH h) EOF k = do e <- ioe_lift (feof h)

44+ k (FH h) e

45+

46+FILE_IO : Type -> EFFECT

47+FILE_IO t = MkEff t FileIO

48+

49+open : Handler FileIO e =>

50+ String -> (m : Mode) -> EffM e [FILE_IO ()]

51+ [FILE_IO (Either () (OpenFile m))] Bool

52+open f m = Open f m

53+

54+close : Handler FileIO e =>

55+ EffM e [FILE_IO (OpenFile m)] [FILE_IO ()] ()

56+close = Close

57+

58+readLine : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] String

59+readLine = ReadLine

60+

61+writeLine : Handler FileIO e => String -> Eff e [FILE_IO (OpenFile Write)] ()

62+writeLine str = WriteLine str

63+

64+eof : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] Bool

65+eof = EOF

66+

67+

68+

69+

libs/neweffects/Effect/Memory.idr → libs/oldeffects/Effect/Memory.idrrenamed+25−31

@@ -12,30 +12,29 @@ data MemoryChunk : Nat -> Nat -> Type where

12abstract

13data RawMemory : Effect where

14 Allocate : (n : Nat) ->

15− RawMemory () () (\v => MemoryChunk n 0)

15+ RawMemory () (MemoryChunk n 0) ()

16− Free : RawMemory () (MemoryChunk n i) (\v => ())

16+ Free : RawMemory (MemoryChunk n i) () ()

17 Initialize : Bits8 ->

18 (size : Nat) ->

19 so (i + size <= n) ->

20− RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size))

20+ RawMemory (MemoryChunk n i) (MemoryChunk n (i + size)) ()

21 Peek : (offset : Nat) ->

22 (size : Nat) ->

23 so (offset + size <= i) ->

24− RawMemory (Vect size Bits8)

24+ RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect size Bits8)

25− (MemoryChunk n i) (\v => MemoryChunk n i)

26 Poke : (offset : Nat) ->

25 Poke : (offset : Nat) ->

27 (Vect size Bits8) ->

26 (Vect size Bits8) ->

28 so (offset <= i && offset + size <= n) ->

27 so (offset <= i && offset + size <= n) ->

29− RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size)))

28+ RawMemory (MemoryChunk n i) (MemoryChunk n (max i (offset + size))) ()

30 Move : (src : MemoryChunk src_size src_init) ->

29 Move : (src : MemoryChunk src_size src_init) ->

31 (dst_offset : Nat) ->

30 (dst_offset : Nat) ->

32 (src_offset : Nat) ->

31 (src_offset : Nat) ->

33 (size : Nat) ->

32 (size : Nat) ->

34 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

33 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

35 so (src_offset + size <= src_init) ->

34 so (src_offset + size <= src_init) ->

36− RawMemory () (MemoryChunk dst_size dst_init)

35+ RawMemory (MemoryChunk dst_size dst_init)

37− (\v => MemoryChunk dst_size (max dst_init (dst_offset + size)))

36+ (MemoryChunk dst_size (max dst_init (dst_offset + size))) ()

38− GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i)

37+ GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (MemoryChunk n i)

39

38

40private

39private

41do_malloc : Nat -> IOExcept String Ptr

40do_malloc : Nat -> IOExcept String Ptr

@@ -80,28 +79,27 @@ do_poke ptr offset (b::bs)

80instance Handler RawMemory (IOExcept String) where

79instance Handler RawMemory (IOExcept String) where

81 handle () (Allocate n) k

80 handle () (Allocate n) k

82 = do ptr <- do_malloc n

81 = do ptr <- do_malloc n

83− k () (CH ptr)

82+ k (CH ptr) ()

84− handle {-{res = MemoryChunk _ offset}-} (CH ptr) (Initialize {i} c size _) k

83+ handle (CH ptr) (Initialize {i} c size _) k

85− = ioe_lift (do_memset ptr i c size) $> k () (CH ptr)

84+ = ioe_lift (do_memset ptr i c size) $> k (CH ptr) ()

86 handle (CH ptr) (Free) k

85 handle (CH ptr) (Free) k

87 = ioe_lift (do_free ptr) $> k () ()

86 = ioe_lift (do_free ptr) $> k () ()

88 handle (CH ptr) (Peek offset size _) k

87 handle (CH ptr) (Peek offset size _) k

89 = do res <- ioe_lift (do_peek ptr offset size)

88 = do res <- ioe_lift (do_peek ptr offset size)

90− k res (CH ptr)

89+ k (CH ptr) res

91 handle (CH ptr) (Poke offset content _) k

90 handle (CH ptr) (Poke offset content _) k

92 = do ioe_lift (do_poke ptr offset content)

91 = do ioe_lift (do_poke ptr offset content)

93− k () (CH ptr)

92+ k (CH ptr) ()

94 handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k

93 handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k

95 = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)

94 = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)

96− k () (CH dest_ptr)

95+ k (CH dest_ptr) ()

97 handle chunk (GetRawPtr) k

96 handle chunk (GetRawPtr) k

98 = k chunk chunk

97 = k chunk chunk

99

98

100RAW_MEMORY : Type -> EFFECT

99RAW_MEMORY : Type -> EFFECT

101RAW_MEMORY t = MkEff t RawMemory

100RAW_MEMORY t = MkEff t RawMemory

102

101

103−allocate : (n : Nat) ->

104− Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

102+allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] ()

105allocate size = Allocate size

103allocate size = Allocate size

106

104

107initialize : {i : Nat} ->

105initialize : {i : Nat} ->

@@ -109,18 +107,17 @@ initialize : {i : Nat} ->

109 Bits8 ->

107 Bits8 ->

110 (size : Nat) ->

108 (size : Nat) ->

111 so (i + size <= n) ->

109 so (i + size <= n) ->

112− Eff m () [RAW_MEMORY (MemoryChunk n i)]

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

110+ EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] ()

114initialize c size prf = Initialize c size prf

111initialize c size prf = Initialize c size prf

115

112

116−free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

113+free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] ()

117free = Free

114free = Free

118

115

119peek : {i : Nat} ->

116peek : {i : Nat} ->

120 (offset : Nat) ->

117 (offset : Nat) ->

121 (size : Nat) ->

118 (size : Nat) ->

122 so (offset + size <= i) ->

119 so (offset + size <= i) ->

123− { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8)

120+ Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect size Bits8)

124peek offset size prf = Peek offset size prf

121peek offset size prf = Peek offset size prf

125

122

126poke : {n : Nat} ->

123poke : {n : Nat} ->

@@ -128,12 +125,11 @@ poke : {n : Nat} ->

128 (offset : Nat) ->

125 (offset : Nat) ->

129 Vect size Bits8 ->

126 Vect size Bits8 ->

130 so (offset <= i && offset + size <= n) ->

127 so (offset <= i && offset + size <= n) ->

131− Eff m () [RAW_MEMORY (MemoryChunk n i)]

132− (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))])

128+ EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] ()

133poke offset content prf = Poke offset content prf

129poke offset content prf = Poke offset content prf

134

130

135private

131private

136−getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i)

132+getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i)

137getRawPtr = GetRawPtr

133getRawPtr = GetRawPtr

138

134

139private

135private

@@ -146,8 +142,8 @@ move' : {dst_size : Nat} ->

146 (size : Nat) ->

142 (size : Nat) ->

147 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

143 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

148 so (src_offset + size <= src_init) ->

144 so (src_offset + size <= src_init) ->

149− Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]

145+ EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)]

150− (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))])

146+ [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] ()

151move' src_ptr dst_offset src_offset size dst_bounds src_bounds

147move' src_ptr dst_offset src_offset size dst_bounds src_bounds

152 = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

148 = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

153

149

@@ -162,12 +158,10 @@ move : {dst_size : Nat} ->

162 (size : Nat) ->

158 (size : Nat) ->

163 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

159 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

164 so (src_offset + size <= src_init) ->

160 so (src_offset + size <= src_init) ->

165− Eff m ()

166− [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)

161+ EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)

167 , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]

162 , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]

168− (\v =>

169− [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))

163+ [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))

170− , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)])

164+ , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] ()

171move dst_offset src_offset size dst_bounds src_bounds

165move dst_offset src_offset size dst_bounds src_bounds

172 = do src_ptr <- Src :- getRawPtr

166 = do src_ptr <- Src :- getRawPtr

173 Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds

167 Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds

libs/neweffects/Effect/Monad.idr → libs/oldeffects/Effect/Monad.idrrenamed+4−4

@@ -5,17 +5,17 @@ import Effects

5-- Eff is a monad too, so we can happily use it in a monad transformer.

6

7using (xs : List EFFECT, m : Type -> Type)

8− instance Functor (\a => EffM m a xs (\v => xs)) where

8+ instance Functor (EffM m xs xs) where

9 map f prog = do t <- prog

10 value (f t)

11

12− instance Applicative (\a => EffM m a xs (\v => xs)) where

12+ instance Applicative (EffM m xs xs) where

13 pure = value

14 (<$>) f a = do f' <- f

15 a' <- a

16 value (f' a')

17

18− instance Monad (\a => Eff m a xs (\v => xs)) where

18+ instance Monad (EffM m xs xs) where

19− (>>=) = Effects.(>>=)

19+ (>>=) = ebind

20

21

libs/oldeffects/Effect/Random.idrnew file+25

@@ -0,0 +1,25 @@

1+module Effect.Random

2+

3+import Effects

4+

5+data Random : Type -> Type -> Type -> Type where

6+ getRandom : Random Integer Integer Integer

7+ setSeed : Integer -> Random Integer Integer ()

8+

9+using (m : Type -> Type)

10+ instance Handler Random m where

11+ handle seed getRandom k

12+ = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in

13+ k seed' seed'

14+ handle seed (setSeed n) k = k n ()

15+

16+RND : EFFECT

17+RND = MkEff Integer Random

18+

19+rndInt : Integer -> Integer -> Eff m [RND] Integer

20+rndInt lower upper = do v <- getRandom

21+ return (v `prim__sremBigInt` (upper - lower) + lower)

22+

23+srand : Integer -> Eff m [RND] ()

24+srand n = setSeed n

25+

libs/neweffects/Effect/Select.idr → libs/oldeffects/Effect/Select.idrrenamed+4−4

@@ -3,21 +3,21 @@ module Effect.Select

3import Effects

4

5data Selection : Effect where

6− Select : List a -> { () } Selection a

6+ Select : List a -> Selection () () a

7

8instance Handler Selection Maybe where

9 handle _ (Select xs) k = tryAll xs where

10 tryAll [] = Nothing

11− tryAll (x :: xs) = case k x () of

11+ tryAll (x :: xs) = case k () x of

12 Nothing => tryAll xs

13 Just v => Just v

14

15instance Handler Selection List where

16− handle r (Select xs) k = concatMap (\x => k x r) xs

16+ handle r (Select xs) k = concatMap (k r) xs

17

18SELECT : EFFECT

19SELECT = MkEff () Selection

20

21−select : List a -> { [SELECT] } Eff m a

21+select : List a -> Eff m [SELECT] a

22select xs = Select xs

23

libs/neweffects/Effect/State.idr → libs/oldeffects/Effect/State.idrrenamed+9−9

@@ -5,33 +5,33 @@ import Effects

5%access public

6

7data State : Effect where

8− Get : { a } State a

8+ Get : State a a a

9− Put : b -> { a ==> b } State ()

9+ Put : b -> State a b ()

10

11using (m : Type -> Type)

12 instance Handler State m where

13 handle st Get k = k st st

14− handle st (Put n) k = k () n

14+ handle st (Put n) k = k n ()

15

16STATE : Type -> EFFECT

17STATE t = MkEff t State

18

19−get : { [STATE x] } Eff m x

19+get : Eff m [STATE x] x

20get = Get

21

22−put : x -> { [STATE x] } Eff m ()

22+put : x -> Eff m [STATE x] ()

23put val = Put val

24

25−putM : y -> { [STATE x] ==> [STATE y] } Eff m ()

25+putM : y -> EffM m [STATE x] [STATE y] ()

26putM val = Put val

27

28−update : (x -> x) -> { [STATE x] } Eff m ()

28+update : (x -> x) -> Eff m [STATE x] ()

29update f = put (f !get)

30

31−updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff m ()

31+updateM : (x -> y) -> EffM m [STATE x] [STATE y] ()

32updateM f = putM (f !get)

33

34−locally : x -> ({ [STATE x] } Eff m t) -> { [STATE y] } Eff m t

34+locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t

35locally newst prog = do st <- get

36 putM newst

37 val <- prog

libs/oldeffects/Effect/StdIO.idrnew file+60

@@ -0,0 +1,60 @@

1+module Effect.StdIO

2+

3+import Effects

4+import Control.IOExcept

5+

6+data StdIO : Effect where

7+ PutStr : String -> StdIO () () ()

8+ GetStr : StdIO () () String

9+

10+instance Handler StdIO IO where

11+ handle () (PutStr s) k = do putStr s; k () ()

12+ handle () GetStr k = do x <- getLine; k () x

13+

14+instance Handler StdIO (IOExcept a) where

15+ handle () (PutStr s) k = do ioe_lift (putStr s); k () ()

16+ handle () GetStr k = do x <- ioe_lift getLine; k () x

17+

18+-- Handle effects in a pure way, for simulating IO for unit testing/proof

19+

20+data IOStream a = MkStream (List String -> (a, List String))

21+

22+instance Handler StdIO IOStream where

23+ handle () (PutStr s) k

24+ = MkStream (\x => case k () () of

25+ MkStream f => let (res, str) = f x in

26+ (res, s :: str))

27+ handle {a} () GetStr k

28+ = MkStream (\x => case x of

29+ [] => cont "" []

30+ (t :: ts) => cont t ts)

31+ where

32+ cont : String -> List String -> (a, List String)

33+ cont t ts = case k () t of

34+ MkStream f => f ts

35+

36+--- The Effect and associated functions

37+

38+STDIO : EFFECT

39+STDIO = MkEff () StdIO

40+

41+putStr : Handler StdIO e => String -> Eff e [STDIO] ()

42+putStr s = PutStr s

43+

44+putStrLn : Handler StdIO e => String -> Eff e [STDIO] ()

45+putStrLn s = putStr (s ++ "\n")

46+

47+getStr : Handler StdIO e => Eff e [STDIO] String

48+getStr = GetStr

49+

50+mkStrFn : Env IOStream xs ->

51+ Eff IOStream xs a ->

52+ List String -> (a, List String)

53+mkStrFn {a} env p input = case mkStrFn' of

54+ MkStream f => f input

55+ where injStream : a -> IOStream a

56+ injStream v = MkStream (\x => (v, []))

57+ mkStrFn' : IOStream a

58+ mkStrFn' = runWith injStream env p

59+

60+

libs/oldeffects/Effects.idrnew file+308

@@ -0,0 +1,308 @@

1+module Effects

2+

3+import Language.Reflection

4+import Control.Catchable

5+

6+%access public

7+

8+---- Effects

9+

10+Effect : Type

11+Effect = Type -> Type -> Type -> Type

12+

13+%error_reverse

14+data EFFECT : Type where

15+ MkEff : Type -> Effect -> EFFECT

16+

17+class Handler (e : Effect) (m : Type -> Type) where

18+ handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a

19+

20+---- Properties and proof construction

21+

22+using (xs : List a, ys : List a)

23+ data SubList : List a -> List a -> Type where

24+ SubNil : SubList {a} [] []

25+ Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

26+ Drop : SubList xs ys -> SubList xs (x :: ys)

27+

28+ subListId : SubList xs xs

29+ subListId {xs = Nil} = SubNil

30+ subListId {xs = x :: xs} = Keep subListId

31+

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

33+ Nil : Env m Nil

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

35+

36+data EffElem : (Type -> Type -> Type -> Type) -> Type ->

37+ List EFFECT -> Type where

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

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

40+

41+-- make an environment corresponding to a sub-list

42+dropEnv : Env m ys -> SubList xs ys -> Env m xs

43+dropEnv [] SubNil = []

44+dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

45+dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

46+

47+updateWith : (ys' : List a) -> (xs : List a) ->

48+ SubList ys xs -> List a

49+updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

50+updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest

51+updateWith [] [] SubNil = []

52+updateWith (y :: ys) [] SubNil = y :: ys

53+updateWith [] (x :: xs) (Keep rest) = []

54+

55+-- put things back, replacing old with new in the sub-environment

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

57+ Env m xs -> Env m (updateWith ys' xs prf)

58+rebuildEnv [] SubNil env = env

59+rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

60+rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

61+rebuildEnv (x :: xs) SubNil [] = x :: xs

62+

63+---- The Effect EDSL itself ----

64+

65+-- some proof automation

66+

67+%reflection

68+reflectListEffElem : List a -> Tactic

69+reflectListEffElem [] = Refine "Here" `Seq` Solve

70+reflectListEffElem (x :: xs)

71+ = Try (Refine "Here" `Seq` Solve)

72+ (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))

73+-- TMP HACK! FIXME!

74+-- The evaluator needs a 'function case' to know its a reflection function

75+-- until we propagate that information! Without this, the _ case won't get

76+-- matched.

77+reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve

78+reflectListEffElem _ = Refine "Here" `Seq` Solve

79+

80+%reflection

81+reflectSubList : List a -> Tactic

82+reflectSubList [] = Refine "SubNil" `Seq` Solve

83+reflectSubList (x :: xs)

84+ = Try (Refine "subListId" `Seq` Solve)

85+ (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))

86+ (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))

87+reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve

88+reflectSubList _ = Refine "subListId" `Seq` Solve

89+

90+%reflection

91+reflectEff : (P : Type) -> Tactic

92+reflectEff (EffElem m a xs)

93+ = reflectListEffElem xs `Seq` Solve

94+reflectEff (SubList xs ys)

95+ = reflectSubList ys `Seq` Solve

96+

97+updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t ->

98+ List EFFECT

99+updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs

100+updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n

101+

102+updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->

103+ List EFFECT

104+updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs

105+updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b

106+

107+infix 5 :::, :-, :=

108+

109+data LRes : lbl -> Type -> Type where

110+ (:=) : (x : lbl) -> res -> LRes x res

111+

112+(:::) : lbl -> EFFECT -> EFFECT

113+(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff

114+

115+private

116+unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]

117+unlabel {m} {x = MkEff a eff} [l := v] = [v]

118+

119+private

120+relabel : (l : ty) -> Env m [x] -> Env m [l ::: x]

121+relabel {x = MkEff a eff} l [v] = [l := v]

122+

123+-- the language of Effects

124+

125+data EffM : (m : Type -> Type) ->

126+ List EFFECT -> List EFFECT -> Type -> Type where

127+ value : a -> EffM m xs xs a

128+ ebind : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b

129+ effect : (prf : EffElem e a xs) ->

130+ (eff : e a b t) ->

131+ EffM m xs (updateResTy xs prf eff) t

132+ lift : (prf : SubList ys xs) ->

133+ EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t

134+ new : Handler e m =>

135+ res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a ->

136+ EffM m xs xs' a

137+ test : (prf : EffElem e (Either l r) xs) ->

138+ EffM m (updateResTyImm xs prf l) xs' t ->

139+ EffM m (updateResTyImm xs prf r) xs' t ->

140+ EffM m xs xs' t

141+ test_lbl : {x : lbl} ->

142+ (prf : EffElem e (LRes x (Either l r)) xs) ->

143+ EffM m (updateResTyImm xs prf (LRes x l)) xs' t ->

144+ EffM m (updateResTyImm xs prf (LRes x r)) xs' t ->

145+ EffM m xs xs' t

146+ catch : Catchable m err =>

147+ EffM m xs xs' a -> (err -> EffM m xs xs' a) ->

148+ EffM m xs xs' a

149+ (:-) : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t

150+

151+syntax [tag] ":!" [val] = !(tag :- val)

152+

153+-- Eff : List (EFFECT m) -> Type -> Type

154+

155+-- For making proofs implicitly for 'test' and 'test_lbl'

156+

157+syntax if_valid then [e] else [t] =

158+ test (tactics { byReflection reflectEff; }) t e

159+

160+syntax if_valid [lbl] then [e] else [t] =

161+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

162+

163+syntax if_error then [t] else [e] =

164+ test (tactics { byReflection reflectEff; }) t e

165+

166+syntax if_error [lbl] then [t] else [e] =

167+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

168+

169+-- These may read better in some contexts

170+

171+syntax if_right then [e] else [t] =

172+ test (tactics { byReflection reflectEff; }) t e

173+

174+syntax if_right [lbl] then [e] else [t] =

175+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

176+

177+syntax if_left then [t] else [e] =

178+ test (tactics { byReflection reflectEff; }) t e

179+

180+syntax if_left [lbl] then [t] else [e] =

181+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

182+

183+

184+-- for 'do' notation

185+

186+return : a -> EffM m xs xs a

187+return x = value x

188+

189+(>>=) : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b

190+(>>=) = ebind

191+

192+-- for idiom brackets

193+

194+infixl 2 <$>

195+

196+pure : a -> EffM m xs xs a

197+pure = value

198+

199+(<$>) : EffM m xs xs (a -> b) -> EffM m xs xs a -> EffM m xs xs b

200+(<$>) prog v = do fn <- prog

201+ arg <- v

202+ return (fn arg)

203+

204+-- an interpreter

205+

206+private

207+execEff : Env m xs -> (p : EffElem e res xs) ->

208+ (eff : e res b a) ->

209+ (Env m (updateResTy xs p eff) -> a -> m t) -> m t

210+execEff (val :: env) Here eff' k

211+ = handle val eff' (\res, v => k (res :: env) v)

212+execEff {e} {res} {b} {a} (val :: env) (There p) eff k

213+ = execEff {e} {res} {b} {a} env p eff (\env', v => k (val :: env') v)

214+

215+private

216+testEff : Env m xs -> (p : EffElem e (Either l r) xs) ->

217+ (Env m (updateResTyImm xs p l) -> m b) ->

218+ (Env m (updateResTyImm xs p r) -> m b) ->

219+ m b

220+testEff (Left err :: env) Here lk rk = lk (err :: env)

221+testEff (Right ok :: env) Here lk rk = rk (ok :: env)

222+testEff (val :: env) (There p) lk rk

223+ = testEff env p (\envk => lk (val :: envk))

224+ (\envk => rk (val :: envk))

225+

226+private

227+testEffLbl : {x : lblTy} ->

228+ Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) ->

229+ (Env m (updateResTyImm xs p (LRes x l)) -> m b) ->

230+ (Env m (updateResTyImm xs p (LRes x r)) -> m b) ->

231+ m b

232+testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env)

233+testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env)

234+testEffLbl (val :: env) (There p) lk rk

235+ = testEffLbl env p (\envk => lk (val :: envk))

236+ (\envk => rk (val :: envk))

237+

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

239+-- updates can be propagated even through failing computations?

240+

241+eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b

242+eff env (value x) k = k env x

243+eff env (prog `ebind` c) k

244+ = eff env prog (\env', p' => eff env' (c p') k)

245+eff env (effect prf effP) k = execEff env prf effP k

246+eff env (lift prf effP) k

247+ = let env' = dropEnv env prf in

248+ eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p')

249+eff env (new r prog) k

250+ = eff (r :: env) prog (\(v :: envk), p' => k envk p')

251+eff env (test prf l r) k

252+ = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)

253+eff env (test_lbl prf l r) k

254+ = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k)

255+eff env (catch prog handler) k

256+ = catch (eff env prog k)

257+ (\e => eff env (handler e) k)

258+-- FIXME:

259+-- xs is needed explicitly because otherwise the pattern binding for

260+-- 'l' appears too late. Solution seems to be to reorder patterns at the

261+-- end so that everything is in scope when it needs to be.

262+eff {xs = [l ::: x]} env (l :- prog) k

263+ = let env' = unlabel env in

264+ eff env' prog (\envk, p' => k (relabel l envk) p')

265+

266+implicit

267+lift' : EffM m ys ys' t ->

268+ {default tactics { byReflection reflectEff; }

269+ prf : SubList ys xs} ->

270+ EffM m xs (updateWith ys' xs prf) t

271+lift' e {prf} = lift prf e

272+

273+implicit

274+effect' : {a, b: _} -> {e : Effect} ->

275+ (eff : e a b t) ->

276+ {default tactics { byReflection reflectEff; }

277+ prf : EffElem e a xs} ->

278+ EffM m xs (updateResTy xs prf eff) t

279+effect' e {prf} = effect prf e

280+

281+

282+run : Applicative m => Env m xs -> EffM m xs xs' a -> m a

283+run env prog = eff env prog (\env, r => pure r)

284+

285+runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a)

286+runEnv env prog = eff env prog (\env, r => pure (env, r))

287+

288+runPure : Env id xs -> EffM id xs xs' a -> a

289+runPure env prog = eff env prog (\env, r => r)

290+

291+-- runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a)

292+-- runPureEnv env prog = eff env prog (\env, r => (env, r))

293+

294+runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a

295+runWith inj env prog = eff env prog (\env, r => inj r)

296+

297+Eff : (Type -> Type) -> List EFFECT -> Type -> Type

298+Eff m xs t = EffM m xs xs t

299+

300+-- some higher order things

301+

302+mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b)

303+mapE f [] = pure []

304+mapE f (x :: xs) = [| f x :: mapE f xs |]

305+

306+when : Applicative m => Bool -> Eff m xs () -> Eff m xs ()

307+when True e = e

308+when False e = pure ()

libs/neweffects/Makefile → libs/oldeffects/Makefilerenamed+3−3

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

1IDRIS := idris

2

3build:

4− $(IDRIS) --build neweffects.ipkg

4+ $(IDRIS) --build oldeffects.ipkg

5

6clean:

7− $(IDRIS) --clean neweffects.ipkg

7+ $(IDRIS) --clean oldeffects.ipkg

8

9install:

10− $(IDRIS) --install neweffects.ipkg

10+ $(IDRIS) --install oldeffects.ipkg

11

12rebuild: clean build

13

libs/neweffects/neweffects.ipkg → libs/oldeffects/oldeffects.ipkgrenamed+3−4

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

1−package neweffects

1+package oldeffects

2

3opts = "--nobasepkgs -i ../prelude -i ../base"

4−modules = Effects, Effect.Default,

4+modules = Effects,

5−

6 Effect.Exception, Effect.File, Effect.State,

5 Effect.Exception, Effect.File, Effect.State,

7 Effect.Random, Effect.StdIO, Effect.Select,

6 Effect.Random, Effect.StdIO, Effect.Select,

8− Effect.Memory, Effect.System

7+ Effect.Memory, Effect.Monad

9

8

libs/prelude/Builtins.idr+17−6

@@ -23,7 +23,9 @@ FalseElim : _|_ -> a

23data Symbol_ : String -> Type where

24

25-- ------------------------------------------------------ [ For rewrite tactic ]

26+||| Perform substitution in a term according to some equality.

27+|||

26−||| Perform substitution in a term. This is used by the `rewrite` tactic and term.

28+||| This is used by the `rewrite` tactic and term.

27replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y

29replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y

28replace refl prf = prf

30replace refl prf = prf

29

31

@@ -41,14 +43,23 @@ lazy x = x -- compiled specially

41force : a -> a

43force : a -> a

42force x = x -- compiled specially

44force x = x -- compiled specially

43

45

44−data Lazy : Type -> Type where

46+data LazyType = LazyCodata | LazyEval

45− Delay : (val : a) -> Lazy a

46

47

48+data Lazy' : LazyType -> Type -> Type where

49+ Delay : {t, a : _} -> (val : a) -> Lazy' t a

50+

47−Force : Lazy a -> a

51+Force : {t, a : _} -> Lazy' t a -> a

48Force (Delay x) = x

52Force (Delay x) = x

49

53

50−par : Lazy a -> a

54+Lazy : Type -> Type

55+Lazy t = Lazy' LazyEval t

56+

57+Inf : Type -> Type

58+Inf t = Lazy' LazyCodata t

59+

60+par : Lazy a -> a -- Doesn't actually do anything yet. Maybe a 'Par a' type

61+ -- is better in any case?

51−par (Delay x) = x -- compiled specially

62+par (Delay x) = x

52

63

53malloc : Int -> a -> a

64malloc : Int -> a -> a

54malloc size x = x -- compiled specially

65malloc size x = x -- compiled specially

libs/prelude/Decidable/Equality.idr+25−18

@@ -12,6 +12,7 @@ import Prelude.Maybe

12-- Utility lemmas

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

14

15+||| The negation of equality is symmetric (follows from symmetry of equality)

15total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_)

16total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_)

16negEqSym p h = p (sym h)

17negEqSym p h = p (sym h)

17

18

@@ -20,7 +21,9 @@ negEqSym p h = p (sym h)

20-- Decidable equality

21-- Decidable equality

21--------------------------------------------------------------------------------

22--------------------------------------------------------------------------------

22

23

24+||| Decision procedures for propositional equality

23class DecEq t where

25class DecEq t where

26+ ||| Decide whether two elements of `t` are propositionally equal

24 total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)

27 total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)

25

28

26--------------------------------------------------------------------------------

29--------------------------------------------------------------------------------

@@ -33,7 +36,6 @@ instance DecEq () where

33--------------------------------------------------------------------------------

36--------------------------------------------------------------------------------

34-- Booleans

37-- Booleans

35--------------------------------------------------------------------------------

38--------------------------------------------------------------------------------

36−

37total trueNotFalse : True = False -> _|_

39total trueNotFalse : True = False -> _|_

38trueNotFalse refl impossible

40trueNotFalse refl impossible

39

41

@@ -122,13 +124,13 @@ lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} ->

122lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl

124lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl

123

125

124instance (DecEq a, DecEq b) => DecEq (a, b) where

126instance (DecEq a, DecEq b) => DecEq (a, b) where

125− decEq (a, b) (a', b') with (decEq a a')

127+ decEq (a, b) (a', b') with (decEq a a')

126− decEq (a, b) (a, b') | (Yes refl) with (decEq b b')

128+ decEq (a, b) (a, b') | (Yes refl) with (decEq b b')

127− decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl

129+ decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl

128− decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq)

130+ decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq)

129− decEq (a, b) (a', b') | (No p) with (decEq b b')

131+ decEq (a, b) (a', b') | (No p) with (decEq b b')

130− decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq)

132+ decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq)

131− decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq)

133+ decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq)

132

134

133

135

134--------------------------------------------------------------------------------

136--------------------------------------------------------------------------------

@@ -188,39 +190,44 @@ instance DecEq a => DecEq (Vect n a) where

188--------------------------------------------------------------------------------

190--------------------------------------------------------------------------------

189

191

190instance DecEq Int where

192instance DecEq Int where

191− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

193+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

192− else No (really_believe_me _|_)

194+ where postulate primitiveEq : x = y

195+ postulate primitiveNotEq : x = y -> _|_

193

196

194--------------------------------------------------------------------------------

197--------------------------------------------------------------------------------

195-- Char

198-- Char

196--------------------------------------------------------------------------------

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

197

200

198instance DecEq Char where

201instance DecEq Char where

199− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

202+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

200− else No (really_believe_me _|_)

203+ where postulate primitiveEq : x = y

204+ postulate primitiveNotEq : x = y -> _|_

201

205

202--------------------------------------------------------------------------------

206--------------------------------------------------------------------------------

203-- Integer

207-- Integer

204--------------------------------------------------------------------------------

208--------------------------------------------------------------------------------

205

209

206instance DecEq Integer where

210instance DecEq Integer where

207− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

211+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

208− else No (really_believe_me _|_)

212+ where postulate primitiveEq : x = y

213+ postulate primitiveNotEq : x = y -> _|_

209

214

210--------------------------------------------------------------------------------

215--------------------------------------------------------------------------------

211-- Float

216-- Float

212--------------------------------------------------------------------------------

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

213

218

214instance DecEq Float where

219instance DecEq Float where

215− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

220+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

216− else No (really_believe_me _|_)

221+ where postulate primitiveEq : x = y

222+ postulate primitiveNotEq : x = y -> _|_

217

223

218--------------------------------------------------------------------------------

224--------------------------------------------------------------------------------

219-- String

225-- String

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

226--------------------------------------------------------------------------------

221

227

222instance DecEq String where

228instance DecEq String where

223− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

229+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

224− else No (really_believe_me _|_)

230+ where postulate primitiveEq : x = y

231+ postulate primitiveNotEq : x = y -> _|_

225

232

226

233

libs/prelude/IO.idr+10−1

@@ -4,8 +4,10 @@ import Prelude.List

4

5%access public

6

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

7abstract data PrimIO a = prim__IO a

8abstract data PrimIO a = prim__IO a

8

9

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

9abstract data World = TheWorld

11abstract data World = TheWorld

10

12

11abstract WorldRes : Type -> Type

13abstract WorldRes : Type -> Type

@@ -26,7 +28,10 @@ abstract

26prim_io_return : a -> PrimIO a

28prim_io_return : a -> PrimIO a

27prim_io_return x = prim__IO x

29prim_io_return x = prim__IO x

28

30

31+||| Descriptions of the various sorts of Ints that Idris supports

29data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2

32data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2

33+

34+||| Types available for foreign function calls

30data FTy = FIntT IntTy

35data FTy = FIntT IntTy

31 | FFunction FTy FTy

36 | FFunction FTy FTy

32 | FFloat

37 | FFloat

@@ -75,6 +80,7 @@ FBits32x4 = FIntT IT32x4

75FBits64x2 : FTy

80FBits64x2 : FTy

76FBits64x2 = FIntT IT64x2

81FBits64x2 = FIntT IT64x2

77

82

83+||| Interpret an FFI type as the type of the Idris function that it will become

78interpFTy : FTy -> Type

84interpFTy : FTy -> Type

79interpFTy (FIntT ITNative) = Int

85interpFTy (FIntT ITNative) = Int

80interpFTy (FIntT ITChar) = Char

86interpFTy (FIntT ITChar) = Char

@@ -95,7 +101,10 @@ interpFTy FUnit = ()

95

101

96interpFTy (FFunction a b) = interpFTy a -> interpFTy b

102interpFTy (FFunction a b) = interpFTy a -> interpFTy b

97

103

104+||| Type signatures for foreign functions

105+||| @ xs the argument types

106+||| @ t the return type

98−ForeignTy : (xs:List FTy) -> (t:FTy) -> Type

107+ForeignTy : (xs : List FTy) -> (t : FTy) -> Type

99ForeignTy Nil rt = World -> PrimIO (interpFTy rt)

108ForeignTy Nil rt = World -> PrimIO (interpFTy rt)

100ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt

109ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt

101

110

libs/prelude/Prelude.idr+20−2

@@ -439,26 +439,32 @@ uniformB64x2 x = prim__mkB64x2 x x

439

440---- some basic io

441

442+||| Output a string to stdout without a trailing newline

442partial

443partial

443putStr : String -> IO ()

444putStr : String -> IO ()

444putStr x = mkForeign (FFun "putStr" [FString] FUnit) x

445putStr x = mkForeign (FFun "putStr" [FString] FUnit) x

445

446

447+||| Output a string to stdout with a trailing newline

446partial

448partial

447putStrLn : String -> IO ()

449putStrLn : String -> IO ()

448putStrLn x = putStr (x ++ "\n")

450putStrLn x = putStr (x ++ "\n")

449

451

452+||| Output something showable to stdout, with a trailing newline

450partial

453partial

451print : Show a => a -> IO ()

454print : Show a => a -> IO ()

452print x = putStrLn (show x)

455print x = putStrLn (show x)

453

456

457+||| Read one line of input from stdin

454partial

458partial

455getLine : IO String

459getLine : IO String

456getLine = prim_fread prim__stdin

460getLine = prim_fread prim__stdin

457

461

462+||| Write a single character to stdout

458partial

463partial

459putChar : Char -> IO ()

464putChar : Char -> IO ()

460putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)

465putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)

461

466

467+||| Read a single character from stdin

462partial

468partial

463getChar : IO Char

469getChar : IO Char

464getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

470getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

@@ -468,21 +474,30 @@ getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

468abstract

474abstract

469data File = FHandle Ptr

475data File = FHandle Ptr

470

476

477+||| Standard input

471partial stdin : File

478partial stdin : File

472stdin = FHandle prim__stdin

479stdin = FHandle prim__stdin

473

480

481+||| Call the RTS's file opening function

474do_fopen : String -> String -> IO Ptr

482do_fopen : String -> String -> IO Ptr

475do_fopen f m

483do_fopen f m

476 = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m

484 = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m

477

485

486+||| Open a file

487+||| @ f the filename

488+||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

478−fopen : String -> String -> IO File

489+fopen : (f : String) -> (m : String) -> IO File

479fopen f m = do h <- do_fopen f m

490fopen f m = do h <- do_fopen f m

480 return (FHandle h)

491 return (FHandle h)

481

492

493+||| Modes for opening files

482data Mode = Read | Write | ReadWrite

494data Mode = Read | Write | ReadWrite

483

495

496+||| Open a file

497+||| @ f the filename

498+||| @ m the mode

484partial

499partial

485−openFile : String -> Mode -> IO File

500+openFile : (f : String) -> (m : Mode) -> IO File

486openFile f m = fopen f (modeStr m) where

501openFile f m = fopen f (modeStr m) where

487 modeStr Read = "r"

502 modeStr Read = "r"

488 modeStr Write = "w"

503 modeStr Write = "w"

@@ -567,15 +582,18 @@ nullPtr : Ptr -> IO Bool

567nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

582nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

568 return (ok /= 0)

583 return (ok /= 0)

569

584

585+||| Check if a supposed string was actually a null pointer

570partial

586partial

571nullStr : String -> IO Bool

587nullStr : String -> IO Bool

572nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p

588nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p

573 return (ok /= 0)

589 return (ok /= 0)

574

590

591+||| Pointer equality

575eqPtr : Ptr -> Ptr -> IO Bool

592eqPtr : Ptr -> Ptr -> IO Bool

576eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y

593eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y

577 return (eq /= 0)

594 return (eq /= 0)

578

595

596+||| Check whether a file handle is actually a null pointer

579partial

597partial

580validFile : File -> IO Bool

598validFile : File -> IO Bool

581validFile (FHandle h) = do x <- nullPtr h

599validFile (FHandle h) = do x <- nullPtr h

libs/prelude/Prelude/Bool.idr+3−1

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

1module Prelude.Bool

2

3+import Builtins

4+

3||| Boolean Data Type

5||| Boolean Data Type

4data Bool = False | True

6data Bool = False | True

5

7

@@ -14,7 +16,7 @@ boolElim False t e = e

14||| Defines a predicate on Bool which guarantees that the value is true.

16||| Defines a predicate on Bool which guarantees that the value is true.

15data so : Bool -> Type where oh : so True

17data so : Bool -> Type where oh : so True

16

18

17−-- Syntaxtic sugar for boolean elimination.

19+-- Syntactic sugar for boolean elimination.

18syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)

20syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)

19

21

20-- Boolean Operator Precedence

22-- Boolean Operator Precedence

libs/prelude/Prelude/Either.idr+11−1

@@ -16,10 +16,12 @@ data Either a b =

16-- Syntactic tests

17--------------------------------------------------------------------------------

18

19+||| True if the argument is Left, False otherwise

19isLeft : Either a b -> Bool

20isLeft : Either a b -> Bool

20isLeft (Left l) = True

21isLeft (Left l) = True

21isLeft (Right r) = False

22isLeft (Right r) = False

22

23

24+||| True if the argument is Right, False otherwise

23isRight : Either a b -> Bool

25isRight : Either a b -> Bool

24isRight (Left l) = False

26isRight (Left l) = False

25isRight (Right r) = True

27isRight (Right r) = True

@@ -41,6 +43,7 @@ either : (f : a -> c) -> (g : b -> c) -> (e : Either a b) -> c

41either l r (Left x) = l x

43either l r (Left x) = l x

42either l r (Right x) = r x

44either l r (Right x) = r x

43

45

46+||| Keep the payloads of all Left constructors in a list of Eithers

44lefts : List (Either a b) -> List a

47lefts : List (Either a b) -> List a

45lefts [] = []

48lefts [] = []

46lefts (x::xs) =

49lefts (x::xs) =

@@ -48,6 +51,7 @@ lefts (x::xs) =

48 Left l => l :: lefts xs

51 Left l => l :: lefts xs

49 Right r => lefts xs

52 Right r => lefts xs

50

53

54+||| Keep the payloads of all Right constructors in a list of Eithers

51rights : List (Either a b) -> List b

55rights : List (Either a b) -> List b

52rights [] = []

56rights [] = []

53rights (x::xs) =

57rights (x::xs) =

@@ -55,9 +59,11 @@ rights (x::xs) =

55 Left l => rights xs

59 Left l => rights xs

56 Right r => r :: rights xs

60 Right r => r :: rights xs

57

61

62+||| Split a list of Eithers into a list of the left elements and a list of the right elements

58partitionEithers : List (Either a b) -> (List a, List b)

63partitionEithers : List (Either a b) -> (List a, List b)

59partitionEithers l = (lefts l, rights l)

64partitionEithers l = (lefts l, rights l)

60

65

66+||| Remove a "useless" Either by collapsing the case distinction

61fromEither : Either a a -> a

67fromEither : Either a a -> a

62fromEither (Left l) = l

68fromEither (Left l) = l

63fromEither (Right r) = r

69fromEither (Right r) = r

@@ -66,7 +72,9 @@ fromEither (Right r) = r

66-- Conversions

72-- Conversions

67--------------------------------------------------------------------------------

73--------------------------------------------------------------------------------

68

74

75+||| Convert a Maybe to an Either by using a default value in case of Nothing

76+||| @ e the default value

69−maybeToEither : e -> Maybe a -> Either e a

77+maybeToEither : (def : e) -> Maybe a -> Either e a

70maybeToEither def (Just j) = Right j

78maybeToEither def (Just j) = Right j

71maybeToEither def Nothing = Left def

79maybeToEither def Nothing = Left def

72

80

@@ -86,10 +94,12 @@ instance (Eq a, Eq b) => Eq (Either a b) where

86-- Injectivity of constructors

94-- Injectivity of constructors

87--------------------------------------------------------------------------------

95--------------------------------------------------------------------------------

88

96

97+||| Left is injective

89total leftInjective : {b : Type} -> {x : a} -> {y : a}

98total leftInjective : {b : Type} -> {x : a} -> {y : a}

90 -> (Left {b = b} x = Left {b = b} y) -> (x = y)

99 -> (Left {b = b} x = Left {b = b} y) -> (x = y)

91leftInjective refl = refl

100leftInjective refl = refl

92

101

102+||| Right is injective

93total rightInjective : {a : Type} -> {x : b} -> {y : b}

103total rightInjective : {a : Type} -> {x : b} -> {y : b}

94 -> (Right {a = a} x = Right {a = a} y) -> (x = y)

104 -> (Right {a = a} x = Right {a = a} y) -> (x = y)

95rightInjective refl = refl

105rightInjective refl = refl

libs/prelude/Prelude/Fin.idr+16−3

@@ -88,6 +88,18 @@ instance MaxBound (Fin (S n)) where

88 maxBound = last

89

90

91+||| Add two Fins, extending the bound

92+(+) : Fin n -> Fin m -> Fin (n + m)

93+(+) {n=S n} {m=m} fZ f' = rewrite plusCommutative n m in weaken (weakenN n f')

94+(+) (fS f) f' = fS (f + f')

95+

96+||| Multiply two Fins, extending the bound

97+(*) : Fin n -> Fin m -> Fin (n * m)

98+(*) {n=Z} f f' = FinZElim f

99+(*) {m=Z} f f' = FinZElim f'

100+(*) {n=S n} {m=S m} fZ f' = fZ

101+(*) {n=S n} {m=S m} (fS f) f' = f' + (f * f')

102+

91-- Construct a Fin from an integer literal which must fit in the given Fin

103-- Construct a Fin from an integer literal which must fit in the given Fin

92

104

93natToFin : Nat -> (n : Nat) -> Maybe (Fin n)

105natToFin : Nat -> (n : Nat) -> Maybe (Fin n)

@@ -101,11 +113,12 @@ integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)

101integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing

113integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing

102

114

103data IsJust : Maybe a -> Type where

115data IsJust : Maybe a -> Type where

104− ItIsJust : IsJust {a} (Just x)

116+ ItIsJust : IsJust {a} (Just x)

105

117

106fromInteger : (x : Integer) ->

118fromInteger : (x : Integer) ->

107− {default ItIsJust

119+ {default ItIsJust

108− prf : (IsJust (integerToFin x n))} -> Fin n

120+ prf : (IsJust (integerToFin x n))} ->

121+ Fin n

109fromInteger {n} x {prf} with (integerToFin x n)

122fromInteger {n} x {prf} with (integerToFin x n)

110 fromInteger {n} x {prf = ItIsJust} | Just y = y

123 fromInteger {n} x {prf = ItIsJust} | Just y = y

111

124

libs/prelude/Prelude/List.idr+5−2

@@ -236,9 +236,12 @@ mapMaybe f (x::xs) =

236-- Folds

237--------------------------------------------------------------------------------

238

239+total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> List t -> acc

240+foldrImpl f e go [] = go e

241+foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs

242+

239instance Foldable List where

243instance Foldable List where

240− foldr f e [] = e

244+ foldr f e xs = foldrImpl f e id xs

241− foldr f e (x::xs) = f x (foldr f e xs)

242

245

243--------------------------------------------------------------------------------

246--------------------------------------------------------------------------------

244-- Special folds

247-- Special folds

libs/prelude/Prelude/Monad.idr+4−1

@@ -13,8 +13,11 @@ infixl 5 >>=

13class Applicative m => Monad (m : Type -> Type) where

14 (>>=) : m a -> (a -> m b) -> m b

15

16+||| Also called `join` or mu

16flatten : Monad m => m (m a) -> m a

17flatten : Monad m => m (m a) -> m a

17flatten a = a >>= id

18flatten a = a >>= id

18

19

20+||| For compatibility with Haskell. Note that monads are **not** free to

21+||| define `return` and `pure` differently!

19return : Monad m => a -> m a

22return : Monad m => a -> m a

20−return = pure

23+return = pure

libs/prelude/Prelude/Stream.idr+3

@@ -10,6 +10,9 @@ import Prelude.Vect

10codata Stream : Type -> Type where

11 (::) : a -> Stream a -> Stream a

12

13+-- Hints for interactive editing

14+%name Stream xs,ys,zs,ws

15+

13instance Functor Stream where

16instance Functor Stream where

14 map f (x::xs) = f x :: map f xs

17 map f (x::xs) = f x :: map f xs

15

18

libs/prelude/Prelude/Vect.idr+122−37

@@ -20,39 +20,69 @@ infixr 7 ::

20-- Hints for interactive editing

21%name Vect xs,ys,zs,ws

22

23+--------------------------------------------------------------------------------

24+-- Length

25+--------------------------------------------------------------------------------

26+

27+||| Calculate the length of a `Vect`.

28+|||

29+||| **Note**: this is only useful if you don't already statically know the length

30+||| and you want to avoid matching the implicit argument for erasure reasons.

31+||| @ n the length (provably equal to the return value)

32+||| @ xs the vector

33+length : (xs : Vect n a) -> Nat

34+length [] = 0

35+length (x::xs) = 1 + length xs

36+

37+||| Show that the length function on vectors in fact calculates the length

38+private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n

39+lengthCorrect Z [] = refl

40+lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in refl

41+

23--------------------------------------------------------------------------------

42--------------------------------------------------------------------------------

24-- Indexing into vectors

43-- Indexing into vectors

25--------------------------------------------------------------------------------

44--------------------------------------------------------------------------------

26

45

46+||| All but the first element of the vector

27tail : Vect (S n) a -> Vect n a

47tail : Vect (S n) a -> Vect n a

28tail (x::xs) = xs

48tail (x::xs) = xs

29

49

50+||| Only the first element of the vector

30head : Vect (S n) a -> a

51head : Vect (S n) a -> a

31head (x::xs) = x

52head (x::xs) = x

32

53

54+||| The last element of the vector

33last : Vect (S n) a -> a

55last : Vect (S n) a -> a

34last (x::[]) = x

56last (x::[]) = x

35last (x::y::ys) = last $ y::ys

57last (x::y::ys) = last $ y::ys

36

58

59+||| All but the last element of the vector

37init : Vect (S n) a -> Vect n a

60init : Vect (S n) a -> Vect n a

38init (x::[]) = []

61init (x::[]) = []

39init (x::y::ys) = x :: init (y::ys)

62init (x::y::ys) = x :: init (y::ys)

40

63

64+||| Extract a particular element from a vector

41index : Fin n -> Vect n a -> a

65index : Fin n -> Vect n a -> a

42index fZ (x::xs) = x

66index fZ (x::xs) = x

43index (fS k) (x::xs) = index k xs

67index (fS k) (x::xs) = index k xs

44index fZ [] impossible

68index fZ [] impossible

45

69

70+||| Construct a new vector consisting of all but the indicated element

46deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a

71deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a

47deleteAt fZ (x::xs) = xs

72deleteAt fZ (x::xs) = xs

48deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs

73deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs

49deleteAt _ [] impossible

74deleteAt _ [] impossible

50

75

76+||| Replace an element at a particlar index with another

51replaceAt : Fin n -> t -> Vect n t -> Vect n t

77replaceAt : Fin n -> t -> Vect n t -> Vect n t

52replaceAt fZ y (x::xs) = y :: xs

78replaceAt fZ y (x::xs) = y :: xs

53replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs

79replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs

54

80

81+||| Replace the element at a particular index with the result of applying a function to it

82+||| @ i the index to replace at

83+||| @ f the update function

84+||| @ xs the vector to replace in

55−updateAt : Fin n -> (t -> t) -> Vect n t -> Vect n t

85+updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t

56updateAt fZ f (x::xs) = f x :: xs

86updateAt fZ f (x::xs) = f x :: xs

57updateAt (fS k) f (x::xs) = x :: updateAt k f xs

87updateAt (fS k) f (x::xs) = x :: updateAt k f xs

58

88

@@ -60,33 +90,82 @@ updateAt (fS k) f (x::xs) = x :: updateAt k f xs

60-- Subvectors

90-- Subvectors

61--------------------------------------------------------------------------------

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

62

92

93+||| Get the first m elements of a Vect

94+||| @ m the number of elements to take

63take : {n : Nat} -> (m : Fin (S n)) -> Vect n a -> Vect (cast m) a

95take : {n : Nat} -> (m : Fin (S n)) -> Vect n a -> Vect (cast m) a

64take (fS k) [] = FinZElim k

96take (fS k) [] = FinZElim k

65take fZ _ = []

97take fZ _ = []

66take (fS k) (x::xs) = x :: take k xs

98take (fS k) (x::xs) = x :: take k xs

67

99

100+||| Remove the first m elements of a Vect

101+||| @ m the number of elements to remove

68drop : (m : Fin (S n)) -> Vect n a -> Vect (n - cast m) a

102drop : (m : Fin (S n)) -> Vect n a -> Vect (n - cast m) a

69drop (fS k) [] = FinZElim k

103drop (fS k) [] = FinZElim k

70drop fZ xs ?= xs

104drop fZ xs ?= xs

71drop (fS k) (x::xs) = drop k xs

105drop (fS k) (x::xs) = drop k xs

72

106

107+--------------------------------------------------------------------------------

108+-- Transformations

109+--------------------------------------------------------------------------------

110+

111+||| Reverse the order of the elements of a vector

112+total reverse : {n : Nat} -> Vect n a -> Vect n a

113+reverse {n} xs = reverse' [] (plusZeroRightNeutral n) xs

114+ where

115+ total reverse' : {m, j, l : Nat} ->

116+ Vect m a -> (j + m = l) -> Vect j a -> Vect l a

117+ reverse' {m} {j = Z } {l} acc prf [] ?= acc

118+ reverse' {m} {j = S k} {l} acc prf (x::xs) =

119+ let prf1 : (m + (S k) = l) = rewrite plusCommutative m (S k) in prf in

120+ let prf2 : (S (m + k) = l) = rewrite plusSuccRightSucc m k in prf1 in

121+ let prf3 : (S (k + m) = l) = rewrite plusCommutative k m in prf2 in

122+ let prf4 : (k + (S m) = l) = rewrite sym $ plusSuccRightSucc k m in prf3 in

123+ reverse' (x::acc) prf4 xs

124+

125+||| Alternate an element between the other elements of a vector

126+||| @ sep the element to intersperse

127+||| @ xs the vector to separate with `sep`

128+intersperse : (sep : a) -> (xs : Vect n a) -> Vect (n + pred n) a

129+intersperse sep [] = []

130+intersperse sep (x::xs) = x :: intersperse' sep xs

131+ where

132+ intersperse' : a -> Vect n a -> Vect (n + n) a

133+ intersperse' sep [] = []

134+ intersperse' sep (x::xs) ?= sep :: x :: intersperse' sep xs

135+

73--------------------------------------------------------------------------------

136--------------------------------------------------------------------------------

74-- Conversion from list (toList is provided by Foldable)

137-- Conversion from list (toList is provided by Foldable)

75--------------------------------------------------------------------------------

138--------------------------------------------------------------------------------

76

139

140+

141+fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a

142+fromList' ys [] = ys

143+fromList' {n} ys (x::xs) =

144+ rewrite (plusSuccRightSucc (length xs) n) ==>

145+ Vect (plus (length xs) (S n)) a in

146+ fromList' (x::ys) xs

147+

148+||| Convert a list to a vector.

149+|||

150+||| The length of the list should be statically known.

77fromList : (l : List a) -> Vect (length l) a

151fromList : (l : List a) -> Vect (length l) a

78−fromList [] = []

152+fromList l =

79−fromList (x::xs) = x :: fromList xs

153+ rewrite (sym $ plusZeroRightNeutral (length l)) in

154+ reverse $ fromList' [] l

80

155

81--------------------------------------------------------------------------------

156--------------------------------------------------------------------------------

82-- Building (bigger) vectors

157-- Building (bigger) vectors

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

158--------------------------------------------------------------------------------

84

159

160+||| Append two vectors

85(++) : Vect m a -> Vect n a -> Vect (m + n) a

161(++) : Vect m a -> Vect n a -> Vect (m + n) a

86(++) [] ys = ys

162(++) [] ys = ys

87(++) (x::xs) ys = x :: xs ++ ys

163(++) (x::xs) ys = x :: xs ++ ys

88

164

165+||| Repeate some value n times

166+||| @ n the number of times to repeat it

167+||| @ x the value to repeat

89−replicate : (n : Nat) -> a -> Vect n a

168+replicate : (n : Nat) -> (x : a) -> Vect n a

90replicate Z x = []

169replicate Z x = []

91replicate (S k) x = x :: replicate k x

170replicate (S k) x = x :: replicate k x

92

171

@@ -94,18 +173,21 @@ replicate (S k) x = x :: replicate k x

94-- Zips and unzips

173-- Zips and unzips

95--------------------------------------------------------------------------------

174--------------------------------------------------------------------------------

96

175

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

97zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

177zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

98zipWith f [] [] = []

178zipWith f [] [] = []

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

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

100

180

181+||| Combine two equal-length vectors pairwise

101zip : Vect n a -> Vect n b -> Vect n (a, b)

182zip : Vect n a -> Vect n b -> Vect n (a, b)

102zip = zipWith (\x => \y => (x,y))

183zip = zipWith (\x => \y => (x,y))

103

184

185+||| Convert a vector of pairs to a pair of vectors

104unzip : Vect n (a, b) -> (Vect n a, Vect n b)

186unzip : Vect n (a, b) -> (Vect n a, Vect n b)

105unzip [] = ([], [])

187unzip [] = ([], [])

106unzip ((l, r)::xs) with (unzip xs)

188unzip ((l, r)::xs) with (unzip xs)

107 | (lefts, rights) = (l::lefts, r::rights)

189 | (lefts, rights) = (l::lefts, r::rights)

108−

190+

109--------------------------------------------------------------------------------

191--------------------------------------------------------------------------------

110-- Equality

192-- Equality

111--------------------------------------------------------------------------------

193--------------------------------------------------------------------------------

@@ -154,65 +236,66 @@ instance Functor (Vect n) where

154-- Folds

236-- Folds

155--------------------------------------------------------------------------------

237--------------------------------------------------------------------------------

156

238

239+total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc

240+foldrImpl f e go [] = go e

241+foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs

242+

157instance Foldable (Vect n) where

243instance Foldable (Vect n) where

158− foldr f e [] = e

244+ foldr f e xs = foldrImpl f e id xs

159− foldr f e (x::xs) = f x (foldr f e xs)

160

245

161--------------------------------------------------------------------------------

246--------------------------------------------------------------------------------

162-- Special folds

247-- Special folds

163--------------------------------------------------------------------------------

248--------------------------------------------------------------------------------

164

249

250+||| Flatten a vector of equal-length vectors

165concat : Vect m (Vect n a) -> Vect (m * n) a

251concat : Vect m (Vect n a) -> Vect (m * n) a

166concat [] = []

252concat [] = []

167concat (v::vs) = v ++ concat vs

253concat (v::vs) = v ++ concat vs

168

254

169−--------------------------------------------------------------------------------

170−-- Transformations

171−--------------------------------------------------------------------------------

172−

173−total reverse : Vect n a -> Vect n a

174−reverse = reverse' []

175− where

176− total reverse' : Vect m a -> Vect n a -> Vect (m + n) a

177− reverse' acc [] ?= acc

178− reverse' acc (x::xs) ?= reverse' (x::acc) xs

179−

180−intersperse : a -> Vect n a -> Vect (n + pred n) a

181−intersperse sep [] = []

182−intersperse sep (x::xs) = x :: intersperse' sep xs

183− where

184− intersperse' : a -> Vect n a -> Vect (n + n) a

185− intersperse' sep [] = []

186− intersperse' sep (x::xs) ?= sep :: x :: intersperse' sep xs

187−

188--------------------------------------------------------------------------------

255--------------------------------------------------------------------------------

189-- Membership tests

256-- Membership tests

190--------------------------------------------------------------------------------

257--------------------------------------------------------------------------------

191

258

259+||| Search for an item using a user-provided test

260+||| @ p the equality test

261+||| @ e the item to search for

262+||| @ xs the vector to search in

192−elemBy : (a -> a -> Bool) -> a -> Vect n a -> Bool

263+elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool

193elemBy p e [] = False

264elemBy p e [] = False

194elemBy p e (x::xs) with (p e x)

265elemBy p e (x::xs) with (p e x)

195 | True = True

266 | True = True

196 | False = elemBy p e xs

267 | False = elemBy p e xs

197

268

269+||| Use the default Boolean equality on elements to search for an item

270+||| @ x what to search for

271+||| @ xs where to search

198−elem : Eq a => a -> Vect n a -> Bool

272+elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool

199elem = elemBy (==)

273elem = elemBy (==)

200

274

275+||| Find the association of some key with a user-provided comparison

276+||| @ p the comparison operator for keys (True if they match)

277+||| @ e the key to look for

201−lookupBy : (a -> a -> Bool) -> a -> Vect n (a, b) -> Maybe b

278+lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b

202lookupBy p e [] = Nothing

279lookupBy p e [] = Nothing

203lookupBy p e ((l, r)::xs) with (p e l)

280lookupBy p e ((l, r)::xs) with (p e l)

204 | True = Just r

281 | True = Just r

205 | False = lookupBy p e xs

282 | False = lookupBy p e xs

206

283

284+||| Find the assocation of some key using the default Boolean equality test

207lookup : Eq a => a -> Vect n (a, b) -> Maybe b

285lookup : Eq a => a -> Vect n (a, b) -> Maybe b

208lookup = lookupBy (==)

286lookup = lookupBy (==)

209

287

288+||| Check if any element of xs is found in elems by a user-provided comparison

289+||| @ p the comparison operator

290+||| @ elems the vector to search

291+||| @ xs what to search for

210−hasAnyBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool

292+hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool

211hasAnyBy p elems [] = False

293hasAnyBy p elems [] = False

212hasAnyBy p elems (x::xs) with (elemBy p x elems)

294hasAnyBy p elems (x::xs) with (elemBy p x elems)

213 | True = True

295 | True = True

214 | False = hasAnyBy p elems xs

296 | False = hasAnyBy p elems xs

215

297

298+||| Check if any element of xs is found in elems using the default Boolean equality test

216hasAny : Eq a => Vect m a -> Vect n a -> Bool

299hasAny : Eq a => Vect m a -> Vect n a -> Bool

217hasAny = hasAnyBy (==)

300hasAny = hasAnyBy (==)

218

301

@@ -220,12 +303,15 @@ hasAny = hasAnyBy (==)

220-- Searching with a predicate

303-- Searching with a predicate

221--------------------------------------------------------------------------------

304--------------------------------------------------------------------------------

222

305

306+||| Find the first element of the vector that satisfies some test

307+||| @ p the test to satisfy

223−find : (a -> Bool) -> Vect n a -> Maybe a

308+find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a

224find p [] = Nothing

309find p [] = Nothing

225find p (x::xs) with (p x)

310find p (x::xs) with (p x)

226 | True = Just x

311 | True = Just x

227 | False = find p xs

312 | False = find p xs

228

313

314+||| Find the index of the first element of the vector that satisfies some test

229findIndex : (a -> Bool) -> Vect n a -> Maybe Nat

315findIndex : (a -> Bool) -> Vect n a -> Maybe Nat

230findIndex = findIndex' 0

316findIndex = findIndex' 0

231 where

317 where

@@ -235,6 +321,7 @@ findIndex = findIndex' 0

235 | True = Just cnt

321 | True = Just cnt

236 | False = findIndex' (S cnt) p xs

322 | False = findIndex' (S cnt) p xs

237

323

324+||| Find the indices of all elements that satisfy some test

238total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)

325total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)

239findIndices = findIndices' 0

326findIndices = findIndices' 0

240 where

327 where

@@ -263,6 +350,7 @@ elemIndices = elemIndicesBy (==)

263-- Filters

350-- Filters

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

351--------------------------------------------------------------------------------

265

352

353+||| Find all elements of a vector that satisfy some test

266total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)

354total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)

267filter p [] = ( _ ** [] )

355filter p [] = ( _ ** [] )

268filter p (x::xs) with (filter p xs)

356filter p (x::xs) with (filter p xs)

@@ -272,6 +360,7 @@ filter p (x::xs) with (filter p xs)

272 else

360 else

273 (_ ** tail)

361 (_ ** tail)

274

362

363+||| Make the elements of some vector unique by some test

275nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)

364nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)

276nubBy = nubBy' []

365nubBy = nubBy' []

277 where

366 where

@@ -282,6 +371,7 @@ nubBy = nubBy' []

282 | False with (nubBy' (x::acc) p xs)

371 | False with (nubBy' (x::acc) p xs)

283 | (_ ** tail) = (_ ** x::tail)

372 | (_ ** tail) = (_ ** x::tail)

284

373

374+||| Make the elements of some vector unique by the default Boolean equality

285nub : Eq a => Vect n a -> (p ** Vect p a)

375nub : Eq a => Vect n a -> (p ** Vect p a)

286nub = nubBy (==)

376nub = nubBy (==)

287

377

@@ -349,14 +439,9 @@ Prelude.Vect.drop_lemma_1 = proof {

349 trivial;

439 trivial;

350}

440}

351

441

352−Prelude.Vect.reverse'_lemma_2 = proof {

353− intros;

354− rewrite (plusSuccRightSucc m n1);

355− exact value;

356−}

357−

358Prelude.Vect.reverse'_lemma_1 = proof {

442Prelude.Vect.reverse'_lemma_1 = proof {

359 intros;

443 intros;

444+ rewrite prf;

360 rewrite sym (plusZeroRightNeutral m);

445 rewrite sym (plusZeroRightNeutral m);

361 exact value;

446 exact value;

362}

447}

src/IRTS/CodegenC.hs+4−4

@@ -132,10 +132,10 @@ bcc i (ASSIGNCONST l c)

132 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

133 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

134 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"

135− mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"

135+ mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"

136− mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"

136+ mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"

137− mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"

137+ mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"

138− mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")"

138+ mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"

139 mkConst _ = "MKINT(42424242)"

140bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

141bcc i (MKCON l tag args)

src/IRTS/CodegenJavaScript.hs+7−4

@@ -100,18 +100,18 @@ data FFI = FFICode Char | FFIArg Int | FFIError String

100ffi :: String -> [String] -> String

101ffi code args = let parsed = ffiParse code in

102 case ffiError parsed of

103− Just err -> compileJS $ jsError err

103+ Just err -> error err

104 Nothing -> renderFFI parsed args

105 where

106 ffiParse :: String -> [FFI]

107 ffiParse "" = []

108− ffiParse ['%'] = [FFIError "Invalid positional argument"]

108+ ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]

109 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss

110 ffiParse ('%':s:ss)

111 | isDigit s =

112 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)

113 | otherwise =

114− [FFIError "Invalid positional argument"]

114+ [FFIError $ "FFI - Invalid positional argument"]

115 ffiParse (s:ss) = FFICode s : ffiParse ss

116

117

@@ -126,7 +126,7 @@ ffi code args = let parsed = ffiParse code in

126 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args

127 renderFFI ((FFIArg i) : fs) args

128 | i < length args && i >= 0 = args !! i ++ renderFFI fs args

129− | otherwise = "Argument index out of bounds"

129+ | otherwise = error "FFI - Argument index out of bounds"

130

131

132compileJS :: JS -> String

@@ -1964,6 +1964,9 @@ translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =

1964translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =

1965 JSBinOp "==" (JSVar lhs) (JSVar rhs)

1966

1967+translateExpression (SForeign _ _ "idris_time" []) =

1968+ JSRaw "(new Date()).getTime()"

1969+

1967translateExpression (SForeign _ _ fun args) =

1970translateExpression (SForeign _ _ fun args) =

1968 JSFFI fun (map generateWrapper args)

1971 JSFFI fun (map generateWrapper args)

1969 where

1972 where

src/IRTS/Compiler.hs+2−2

@@ -163,7 +163,7 @@ mkLDecl n (CaseOp ci _ _ _ pats cd)

163 return (declArgs [] (case_inlinable ci) n e)

164mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a

165mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a

166−mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n)))

166+mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run

167

168instance ToIR (TT Name) where

169 ir tm = ir' [] tm where

@@ -193,7 +193,7 @@ instance ToIR (TT Name) where

193 l == txt "Delay"

194 = do arg' <- ir' env arg

195 return $ LLazyExp arg'

196− | (P _ (UN l) _, [_, arg]) <- unApply tm,

196+ | (P _ (UN l) _, [_, _, arg]) <- unApply tm,

197 l == txt "Force"

198 = do arg' <- ir' env arg

199 return $ LForce arg'

src/Idris/AbsSyntax.hs+28−18

@@ -9,7 +9,8 @@ import Idris.Core.Elaborate hiding (Tactic(..))

9import Idris.Core.Typecheck

10import Idris.AbsSyntaxTree

11import Idris.Colours

12−import Idris.IdeSlave

12+import Idris.Docstrings

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

13import IRTS.CodegenCommon

14import IRTS.CodegenCommon

14import Util.DynamicLinker

15import Util.DynamicLinker

15

16

@@ -262,7 +263,7 @@ addCoercion :: Name -> Idris ()

262addCoercion n = do i <- getIState

263addCoercion n = do i <- getIState

263 putIState $ i { idris_coercions = nub $ n : idris_coercions i }

264 putIState $ i { idris_coercions = nub $ n : idris_coercions i }

264

265

265−addDocStr :: Name -> String -> [(Name, String)] -> Idris ()

266+addDocStr :: Name -> Docstring -> [(Name, Docstring)] -> Idris ()

266addDocStr n doc args

267addDocStr n doc args

267 = do i <- getIState

268 = do i <- getIState

268 putIState $ i { idris_docstrings = addDef n (doc, args) (idris_docstrings i) }

269 putIState $ i { idris_docstrings = addDef n (doc, args) (idris_docstrings i) }

@@ -356,15 +357,15 @@ addNameIdx' i n

356getHdrs :: Codegen -> Idris [String]

357getHdrs :: Codegen -> Idris [String]

357getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

358getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

358

359

359−setErrLine :: Int -> Idris ()

360+setErrSpan :: FC -> Idris ()

360−setErrLine x = do i <- getIState;

361+setErrSpan x = do i <- getIState;

361− case (errLine i) of

362+ case (errSpan i) of

362− Nothing -> putIState $ i { errLine = Just x }

363+ Nothing -> putIState $ i { errSpan = Just x }

363 Just _ -> return ()

364 Just _ -> return ()

364

365

365clearErr :: Idris ()

366clearErr :: Idris ()

366clearErr = do i <- getIState

367clearErr = do i <- getIState

367− putIState $ i { errLine = Nothing }

368+ putIState $ i { errSpan = Nothing }

368

369

369getSO :: Idris (Maybe String)

370getSO :: Idris (Maybe String)

370getSO = do i <- getIState

371getSO = do i <- getIState

@@ -391,6 +392,8 @@ getName = do i <- getIState;

391 putIState $ (i { idris_name = idx + 1 })

392 putIState $ (i { idris_name = idx + 1 })

392 return idx

393 return idx

393

394

395+-- InternalApp keeps track of the real function application for making case splits from, not the application the

396+-- programmer wrote, which doesn't have the whole context in any case other than top level definitions

394addInternalApp :: FilePath -> Int -> PTerm -> Idris ()

397addInternalApp :: FilePath -> Int -> PTerm -> Idris ()

395addInternalApp fp l t

398addInternalApp fp l t

396 = do i <- getIState

399 = do i <- getIState

@@ -564,7 +567,7 @@ ihPrintFunTypes h bnd n overloads = do imp <- impShow

564 RawOutput -> consoleDisplayAnnotated h output

567 RawOutput -> consoleDisplayAnnotated h output

565 IdeSlave n -> ideSlaveReturnAnnotated n h output

568 IdeSlave n -> ideSlaveReturnAnnotated n h output

566 where fullName n = prettyName True bnd n

569 where fullName n = prettyName True bnd n

567− ppOverload imp n tm = fullName n <+> colon <+> align (pprintPTerm imp bnd tm)

570+ ppOverload imp n tm = fullName n <+> colon <+> align (pprintPTerm imp bnd [] tm)

568

571

569ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris ()

572ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris ()

570ihRenderResult h d = do ist <- getIState

573ihRenderResult h d = do ist <- getIState

@@ -640,15 +643,16 @@ isetPrompt p = do i <- getIState

640

643

641ihWarn :: Handle -> FC -> Doc OutputAnnotation -> Idris ()

644ihWarn :: Handle -> FC -> Doc OutputAnnotation -> Idris ()

642ihWarn h fc err = do i <- getIState

645ihWarn h fc err = do i <- getIState

643− err' <- iRender . fmap (fancifyAnnots i) $ err

644 case idris_outputmode i of

646 case idris_outputmode i of

645 RawOutput ->

647 RawOutput ->

646− runIO $

648+ do err' <- iRender . fmap (fancifyAnnots i) $

649+ text (show fc) <> colon <//> err

647− hPutStrLn h (show fc ++ ":" ++ displayDecorated (consoleDecorate i) err')

650+ runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'

648 IdeSlave n ->

651 IdeSlave n ->

652+ do err' <- iRender . fmap (fancifyAnnots i) $ err

649− do let (str, spans) = displaySpans err'

653+ let (str, spans) = displaySpans err'

650 runIO . hPutStrLn h $

654 runIO . hPutStrLn h $

651− convSExp "warning" (fc_fname fc, fc_line fc, fc_column fc, str, spans) n

655+ convSExp "warning" (fc_fname fc, fc_start fc, fc_end fc, str, spans) n

652

656

653setLogLevel :: Int -> Idris ()

657setLogLevel :: Int -> Idris ()

654setLogLevel l = do i <- getIState

658setLogLevel l = do i <- getIState

@@ -713,6 +717,12 @@ setShowOrigErr b = do i <- getIState

713 let opt' = opts { opt_origerr = b }

717 let opt' = opts { opt_origerr = b }

714 putIState $ i { idris_options = opt' }

718 putIState $ i { idris_options = opt' }

715

719

720+setAutoSolve :: Bool -> Idris ()

721+setAutoSolve b = do i <- getIState

722+ let opts = idris_options i

723+ let opt' = opts { opt_autoSolve = b }

724+ putIState $ i { idris_options = opt' }

725+

716setNoBanner :: Bool -> Idris ()

726setNoBanner :: Bool -> Idris ()

717setNoBanner n = do i <- getIState

727setNoBanner n = do i <- getIState

718 let opts = idris_options i

728 let opts = idris_options i

@@ -899,7 +909,7 @@ iLOG = logLvl 1

899

909

900noErrors :: Idris Bool

910noErrors :: Idris Bool

901noErrors = do i <- getIState

911noErrors = do i <- getIState

902− case errLine i of

912+ case errSpan i of

903 Nothing -> return True

913 Nothing -> return True

904 _ -> return False

914 _ -> return False

905

915

@@ -1061,14 +1071,14 @@ expandParamsD rhs ist dec ps ns (PData doc argDocs syn fc co pd)

1061 (map econ cons)

1071 (map econ cons)

1062 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

1072 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

1063 econ (doc, argDocs, n, t, fc, fs)

1073 econ (doc, argDocs, n, t, fc, fs)

1064− = (doc, argDocs, dec n, piBindp impl ps (expandParams dec ps ns [] t), fc, fs)

1074+ = (doc, argDocs, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)

1065expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty cdoc cn cty)

1075expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty cdoc cn cty)

1066 = if tn `elem` ns

1076 = if tn `elem` ns

1067 then PRecord doc syn fc (dec tn) (piBind ps (expandParams dec ps ns [] tty))

1077 then PRecord doc syn fc (dec tn) (piBind ps (expandParams dec ps ns [] tty))

1068 cdoc (dec cn) conty

1078 cdoc (dec cn) conty

1069 else PRecord doc syn fc (dec tn) (expandParams dec ps ns [] tty)

1079 else PRecord doc syn fc (dec tn) (expandParams dec ps ns [] tty)

1070 cdoc (dec cn) conty

1080 cdoc (dec cn) conty

1071− where conty = piBindp impl ps (expandParams dec ps ns [] cty)

1081+ where conty = piBindp expl ps (expandParams dec ps ns [] cty)

1072expandParamsD rhs ist dec ps ns (PParams f params pds)

1082expandParamsD rhs ist dec ps ns (PParams f params pds)

1073 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

1083 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

1074 (map (expandParamsD True ist dec ps ns) pds)

1084 (map (expandParamsD True ist dec ps ns) pds)

@@ -1544,9 +1554,9 @@ stripLinear i tm = evalState (sl tm) [] where

1544 return (PPatvar fc f)

1554 return (PPatvar fc f)

1545 sl t@(PAlternative _ (a : as)) = do sl a

1555 sl t@(PAlternative _ (a : as)) = do sl a

1546 return t

1556 return t

1547− sl (PApp fc fn args) = do fn' <- sl fn

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

1548 args' <- mapM slA args

1558 args' <- mapM slA args

1549− return $ PApp fc fn' args'

1559+ return $ PApp fc fn args'

1550 where slA (PImp p m l n t) = do t' <- sl t

1560 where slA (PImp p m l n t) = do t' <- sl t

1551 return $ PImp p m l n t'

1561 return $ PImp p m l n t'

1552 slA (PExp p l t) = do t' <- sl t

1562 slA (PExp p l t) = do t' <- sl t

src/Idris/AbsSyntaxTree.hs+56−42

@@ -7,6 +7,7 @@ import Idris.Core.TT

7import Idris.Core.Evaluate

8import Idris.Core.Elaborate hiding (Tactic(..))

9import Idris.Core.Typecheck

10+import Idris.Docstrings

10import IRTS.Lang

11import IRTS.Lang

11import IRTS.CodegenCommon

12import IRTS.CodegenCommon

12import Util.Pretty

13import Util.Pretty

@@ -53,7 +54,8 @@ data IOption = IOption { opt_logLevel :: Int,

53 opt_cpu :: String,

54 opt_cpu :: String,

54 opt_optLevel :: Word,

55 opt_optLevel :: Word,

55 opt_cmdline :: [Opt], -- remember whole command line

56 opt_cmdline :: [Opt], -- remember whole command line

56− opt_origerr :: Bool

57+ opt_origerr :: Bool,

58+ opt_autoSolve :: Bool -- ^ automatically apply "solve" tactic in prover

57 }

59 }

58 deriving (Show, Eq)

60 deriving (Show, Eq)

59

61

@@ -76,6 +78,7 @@ defaultOpts = IOption { opt_logLevel = 0

76 , opt_optLevel = 2

78 , opt_optLevel = 2

77 , opt_cmdline = []

79 , opt_cmdline = []

78 , opt_origerr = False

80 , opt_origerr = False

81+ , opt_autoSolve = True

79 }

82 }

80

83

81data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord)

84data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord)

@@ -111,7 +114,7 @@ data IState = IState {

111 idris_flags :: Ctxt [FnOpt],

114 idris_flags :: Ctxt [FnOpt],

112 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

115 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

113 idris_calledgraph :: Ctxt [Name],

116 idris_calledgraph :: Ctxt [Name],

114− idris_docstrings :: Ctxt (String, [(Name, String)]),

117+ idris_docstrings :: Ctxt (Docstring, [(Name, Docstring)]),

115 idris_tyinfodata :: Ctxt TIData,

118 idris_tyinfodata :: Ctxt TIData,

116 idris_totcheck :: [(FC, Name)], -- names to check totality on

119 idris_totcheck :: [(FC, Name)], -- names to check totality on

117 idris_defertotcheck :: [(FC, Name)], -- names to check at the end

120 idris_defertotcheck :: [(FC, Name)], -- names to check at the end

@@ -132,11 +135,12 @@ data IState = IState {

132 idris_cgflags :: [(Codegen, String)],

135 idris_cgflags :: [(Codegen, String)],

133 idris_hdrs :: [(Codegen, String)],

136 idris_hdrs :: [(Codegen, String)],

134 proof_list :: [(Name, [String])],

137 proof_list :: [(Name, [String])],

135− errLine :: Maybe Int,

138+ errSpan :: Maybe FC,

136 parserWarnings :: [(FC, Err)],

139 parserWarnings :: [(FC, Err)],

137 lastParse :: Maybe Name,

140 lastParse :: Maybe Name,

138 indent_stack :: [Int],

141 indent_stack :: [Int],

139 brace_stack :: [Maybe Int],

142 brace_stack :: [Maybe Int],

143+ lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

140 hide_list :: [(Name, Maybe Accessibility)],

144 hide_list :: [(Name, Maybe Accessibility)],

141 default_access :: Accessibility,

145 default_access :: Accessibility,

142 default_total :: Bool,

146 default_total :: Bool,

@@ -221,7 +225,7 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

221 emptyContext emptyContext emptyContext emptyContext

225 emptyContext emptyContext emptyContext emptyContext

222 emptyContext emptyContext

226 emptyContext emptyContext

223 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

227 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

224− [] Nothing [] Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

228+ [] Nothing [] Nothing [] [] Nothing [] Hidden False [] Nothing [] [] RawOutput

225 True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty

229 True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty

226 AutomaticWidth

230 AutomaticWidth

227

231

@@ -288,6 +292,7 @@ data Command = Quit

288 | ColourOff

292 | ColourOff

289 | ListErrorHandlers

293 | ListErrorHandlers

290 | SetConsoleWidth ConsoleWidth

294 | SetConsoleWidth ConsoleWidth

295+ | Apropos String

291

296

292data Opt = Filename String

297data Opt = Filename String

293 | Ver

298 | Ver

@@ -336,6 +341,7 @@ data Opt = Filename String

336 | Client String

341 | Client String

337 | ShowOrigErr

342 | ShowOrigErr

338 | AutoWidth -- ^ Automatically adjust terminal width

343 | AutoWidth -- ^ Automatically adjust terminal width

344+ | AutoSolve -- ^ Automatically issue "solve" tactic in interactive prover

339 deriving (Show, Eq)

345 deriving (Show, Eq)

340

346

341-- Parsed declarations

347-- Parsed declarations

@@ -407,7 +413,7 @@ constraint = Constraint [] Dynamic

407tacimpl t = TacImp [] Dynamic t

413tacimpl t = TacImp [] Dynamic t

408

414

409data FnOpt = Inlinable -- always evaluate when simplifying

415data FnOpt = Inlinable -- always evaluate when simplifying

410− | TotalFn | PartialFn

416+ | TotalFn | PartialFn | CoveringFn

411 | Coinductive | AssertTotal

417 | Coinductive | AssertTotal

412 | Dictionary -- type class dictionary, eval only when

418 | Dictionary -- type class dictionary, eval only when

413 -- a function argument, and further evaluation resutls

419 -- a function argument, and further evaluation resutls

@@ -450,15 +456,15 @@ data ProvideWhat = ProvTerm -- ^ only allow providing terms

450-- datatypes and typeclasses.

456-- datatypes and typeclasses.

451data PDecl' t

457data PDecl' t

452 = PFix FC Fixity [String] -- ^ Fixity declaration

458 = PFix FC Fixity [String] -- ^ Fixity declaration

453− | PTy String [(Name, String)] SyntaxInfo FC FnOpts Name t -- ^ Type declaration

459+ | PTy Docstring [(Name, Docstring)] SyntaxInfo FC FnOpts Name t -- ^ Type declaration

454− | PPostulate String SyntaxInfo FC FnOpts Name t -- ^ Postulate

460+ | PPostulate Docstring SyntaxInfo FC FnOpts Name t -- ^ Postulate

455 | PClauses FC FnOpts Name [PClause' t] -- ^ Pattern clause

461 | PClauses FC FnOpts Name [PClause' t] -- ^ Pattern clause

456 | PCAF FC Name t -- ^ Top level constant

462 | PCAF FC Name t -- ^ Top level constant

457− | PData String [(Name, String)] SyntaxInfo FC DataOpts (PData' t) -- ^ Data declaration.

463+ | PData Docstring [(Name, Docstring)] SyntaxInfo FC DataOpts (PData' t) -- ^ Data declaration.

458 | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block

464 | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block

459 | PNamespace String [PDecl' t] -- ^ New namespace

465 | PNamespace String [PDecl' t] -- ^ New namespace

460− | PRecord String SyntaxInfo FC Name t String Name t -- ^ Record declaration

466+ | PRecord Docstring SyntaxInfo FC Name t Docstring Name t -- ^ Record declaration

461− | PClass String SyntaxInfo FC

467+ | PClass Docstring SyntaxInfo FC

462 [t] -- constraints

468 [t] -- constraints

463 Name

469 Name

464 [(Name, t)] -- parameters

470 [(Name, t)] -- parameters

@@ -512,7 +518,7 @@ deriving instance NFData PClause'

512-- | Data declaration

518-- | Data declaration

513data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

519data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

514 d_tcon :: t, -- ^ Type constructor

520 d_tcon :: t, -- ^ Type constructor

515− d_cons :: [(String, [(Name, String)], Name, t, FC, [Name])] -- ^ Constructors

521+ d_cons :: [(Docstring, [(Name, Docstring)], Name, t, FC, [Name])] -- ^ Constructors

516 }

522 }

517 -- ^ Data declaration

523 -- ^ Data declaration

518 | PLaterdecl { d_name :: Name, d_tcon :: t }

524 | PLaterdecl { d_name :: Name, d_tcon :: t }

@@ -737,7 +743,7 @@ type PTactic = PTactic' PTerm

737

743

738data PDo' t = DoExp FC t

744data PDo' t = DoExp FC t

739 | DoBind FC Name t

745 | DoBind FC Name t

740− | DoBindP FC t t

746+ | DoBindP FC t t [(t,t)]

741 | DoLet FC Name t t

747 | DoLet FC Name t t

742 | DoLetP FC t t

748 | DoLetP FC t t

743 deriving (Eq, Functor)

749 deriving (Eq, Functor)

@@ -749,7 +755,7 @@ deriving instance NFData PDo'

749instance Sized a => Sized (PDo' a) where

755instance Sized a => Sized (PDo' a) where

750 size (DoExp fc t) = 1 + size fc + size t

756 size (DoExp fc t) = 1 + size fc + size t

751 size (DoBind fc nm t) = 1 + size fc + size nm + size t

757 size (DoBind fc nm t) = 1 + size fc + size nm + size t

752− size (DoBindP fc l r) = 1 + size fc + size l + size r

758+ size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts

753 size (DoLet fc nm l r) = 1 + size fc + size nm + size l + size r

759 size (DoLet fc nm l r) = 1 + size fc + size nm + size l + size r

754 size (DoLetP fc l r) = 1 + size fc + size l + size r

760 size (DoLetP fc l r) = 1 + size fc + size l + size r

755

761

@@ -948,9 +954,9 @@ inferTy = sMN 0 "__Infer"

948inferCon = sMN 0 "__infer"

954inferCon = sMN 0 "__infer"

949inferDecl = PDatadecl inferTy

955inferDecl = PDatadecl inferTy

950 PType

956 PType

951− [("", [], inferCon, PPi impl (sMN 0 "iType") PType (

957+ [(emptyDocstring, [], inferCon, PPi impl (sMN 0 "iType") PType (

952− PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

958+ PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

953− (PRef bi inferTy)), bi, [])]

959+ (PRef bi inferTy)), bi, [])]

954inferOpts = []

960inferOpts = []

955

961

956infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t]

962infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t]

@@ -978,7 +984,7 @@ primNames = [unitTy, unitCon,

978unitTy = sMN 0 "__Unit"

984unitTy = sMN 0 "__Unit"

979unitCon = sMN 0 "__II"

985unitCon = sMN 0 "__II"

980unitDecl = PDatadecl unitTy PType

986unitDecl = PDatadecl unitTy PType

981− [("", [], unitCon, PRef bi unitTy, bi, [])]

987+ [(emptyDocstring, [], unitCon, PRef bi unitTy, bi, [])]

982unitOpts = [DefaultEliminator]

988unitOpts = [DefaultEliminator]

983

989

984falseTy = sMN 0 "__False"

990falseTy = sMN 0 "__False"

@@ -988,12 +994,12 @@ falseOpts = []

988pairTy = sMN 0 "__Pair"

994pairTy = sMN 0 "__Pair"

989pairCon = sMN 0 "__MkPair"

995pairCon = sMN 0 "__MkPair"

990pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

996pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

991− [("", [], pairCon, PPi impl (n "A") PType (

997+ [(emptyDocstring, [], pairCon, PPi impl (n "A") PType (

992− PPi impl (n "B") PType (

998+ PPi impl (n "B") PType (

993− PPi expl (n "a") (PRef bi (n "A")) (

999+ PPi expl (n "a") (PRef bi (n "A")) (

994− PPi expl (n "b") (PRef bi (n "B"))

1000+ PPi expl (n "b") (PRef bi (n "B"))

995− (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

1001+ (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

996− pexp (PRef bi (n "B"))])))), bi, [])]

1002+ pexp (PRef bi (n "B"))])))), bi, [])]

997 where n a = sMN 0 a

1003 where n a = sMN 0 a

998pairOpts = []

1004pairOpts = []

999

1005

@@ -1002,21 +1008,21 @@ eqCon = sUN "refl"

1002eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),

1008eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),

1003 (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

1009 (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

1004 PType)

1010 PType)

1005− [("", [], eqCon, PPi impl (n "A") PType (

1011+ [(emptyDocstring, [], eqCon, PPi impl (n "A") PType (

1006− PPi impl (n "x") (PRef bi (n "A"))

1012+ PPi impl (n "x") (PRef bi (n "A"))

1007− (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1013+ (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1008− pimp (n "B") Placeholder False,

1014+ pimp (n "B") Placeholder False,

1009− pexp (PRef bi (n "x")),

1015+ pexp (PRef bi (n "x")),

1010− pexp (PRef bi (n "x"))])), bi, [])]

1016+ pexp (PRef bi (n "x"))])), bi, [])]

1011 where n a = sMN 0 a

1017 where n a = sMN 0 a

1012eqOpts = []

1018eqOpts = []

1013

1019

1014elimName = sUN "__Elim"

1020elimName = sUN "__Elim"

1015elimMethElimTy = sUN "__elimTy"

1021elimMethElimTy = sUN "__elimTy"

1016elimMethElim = sUN "elim"

1022elimMethElim = sUN "elim"

1017−elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]

1023+elimDecl = PClass (parseDocstring . T.pack $ "Type class for eliminators") defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]

1018− [PTy "" [] defaultSyntax bi [TotalFn] elimMethElimTy PType,

1024+ [PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElimTy PType,

1019− PTy "" [] defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

1025+ PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

1020

1026

1021-- Defined in builtins.idr

1027-- Defined in builtins.idr

1022sigmaTy = sUN "Exists"

1028sigmaTy = sUN "Exists"

@@ -1061,6 +1067,7 @@ consoleDecorate ist AnnConstType = let theme = idris_colourTheme ist

1061 in colouriseType theme

1067 in colouriseType theme

1062consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist)

1068consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist)

1063consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)

1069consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)

1070+consoleDecorate ist AnnKeyword = colouriseKeyword (idris_colourTheme ist)

1064consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist

1071consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist

1065 theme = idris_colourTheme ist

1072 theme = idris_colourTheme ist

1066 in case () of

1073 in case () of

@@ -1069,19 +1076,24 @@ consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist

1069 _ | isTConName n ctxt -> colouriseType theme

1076 _ | isTConName n ctxt -> colouriseType theme

1070 _ | otherwise -> id -- don't colourise unknown names

1077 _ | otherwise -> id -- don't colourise unknown names

1071consoleDecorate ist (AnnFC _) = id

1078consoleDecorate ist (AnnFC _) = id

1079+consoleDecorate ist (AnnTextFmt fmt) = Idris.Colours.colourise (colour fmt)

1080+ where colour BoldText = IdrisColour Nothing True False True False

1081+ colour UnderlineText = IdrisColour Nothing True True False False

1082+ colour ItalicText = IdrisColour Nothing True False False True

1072

1083

1073-- | Pretty-print a high-level closed Idris term

1084-- | Pretty-print a high-level closed Idris term

1074prettyImp :: Bool -- ^^ whether to show implicits

1085prettyImp :: Bool -- ^^ whether to show implicits

1075 -> PTerm -- ^^ the term to pretty-print

1086 -> PTerm -- ^^ the term to pretty-print

1076 -> Doc OutputAnnotation

1087 -> Doc OutputAnnotation

1077−prettyImp impl = pprintPTerm impl []

1088+prettyImp impl = pprintPTerm impl [] []

1078

1089

1079-- | Pretty-print a high-level Idris term in some bindings context

1090-- | Pretty-print a high-level Idris term in some bindings context

1080pprintPTerm :: Bool -- ^^ whether to show implicits

1091pprintPTerm :: Bool -- ^^ whether to show implicits

1081 -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit

1092 -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit

1093+ -> [Name] -- ^^ names to always show in pi, even if not used

1082 -> PTerm -- ^^ the term to pretty-print

1094 -> PTerm -- ^^ the term to pretty-print

1083 -> Doc OutputAnnotation

1095 -> Doc OutputAnnotation

1084−pprintPTerm impl bnd = prettySe 10 bnd

1096+pprintPTerm impl bnd docArgs = prettySe 10 bnd

1085 where

1097 where

1086 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

1098 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

1087 prettySe p bnd (PQuote r) =

1099 prettySe p bnd (PQuote r) =

@@ -1097,11 +1109,11 @@ pprintPTerm impl bnd = prettySe 10 bnd

1097 prettySe 10 ((n, False):bnd) sc

1109 prettySe 10 ((n, False):bnd) sc

1098 prettySe p bnd (PLet n ty v sc) =

1110 prettySe p bnd (PLet n ty v sc) =

1099 bracket p 2 $

1111 bracket p 2 $

1100− text "let" <+> bindingOf n False <+> text "=" </>

1112+ kwd "let" <+> bindingOf n False <+> text "=" </>

1101− prettySe 10 bnd v <+> text "in" </>

1113+ prettySe 10 bnd v <+> kwd "in" </>

1102 prettySe 10 ((n, False):bnd) sc

1114 prettySe 10 ((n, False):bnd) sc

1103 prettySe p bnd (PPi (Exp l s _) n ty sc)

1115 prettySe p bnd (PPi (Exp l s _) n ty sc)

1104− | n `elem` allNamesIn sc || impl =

1116+ | n `elem` allNamesIn sc || impl || n `elem` docArgs =

1105 let open = if Lazy `elem` l then text "|" <> lparen else lparen in

1117 let open = if Lazy `elem` l then text "|" <> lparen else lparen in

1106 bracket p 2 . group $

1118 bracket p 2 . group $

1107 enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

1119 enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

@@ -1131,7 +1143,7 @@ pprintPTerm impl bnd = prettySe 10 bnd

1131 prettySe 10 bnd ty <+> text "=>" </> prettySe 10 ((n, True):bnd) sc

1143 prettySe 10 bnd ty <+> text "=>" </> prettySe 10 ((n, True):bnd) sc

1132 prettySe p bnd (PPi (TacImp _ _ s) n ty sc) =

1144 prettySe p bnd (PPi (TacImp _ _ s) n ty sc) =

1133 bracket p 2 $

1145 bracket p 2 $

1134− lbrace <> text "tacimp" <+> pretty n <+> colon <+> prettySe 10 bnd ty <>

1146+ lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe 10 bnd ty <>

1135 rbrace <+> text "->" </> prettySe 10 ((n, True):bnd) sc

1147 rbrace <+> text "->" </> prettySe 10 ((n, True):bnd) sc

1136 prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args

1148 prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args

1137 | UN nm <- basename f

1149 | UN nm <- basename f

@@ -1171,7 +1183,7 @@ pprintPTerm impl bnd = prettySe 10 bnd

1171 then fp

1183 then fp

1172 else fp <+> align (vsep (map (prettyArgSe bnd) args))

1184 else fp <+> align (vsep (map (prettyArgSe bnd) args))

1173 prettySe p bnd (PCase _ scr opts) =

1185 prettySe p bnd (PCase _ scr opts) =

1174− text "case" <+> prettySe 10 bnd scr <+> text "of" <> prettyBody

1186+ kwd "case" <+> prettySe 10 bnd scr <+> kwd "of" <> prettyBody

1175 where

1187 where

1176 prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts

1188 prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts

1177

1189

@@ -1238,8 +1250,8 @@ pprintPTerm impl bnd = prettySe 10 bnd

1238 prettySe p bnd (PTactics ts) =

1250 prettySe p bnd (PTactics ts) =

1239 text "tactics" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

1251 text "tactics" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

1240 prettySe p bnd (PMetavar n) = text "?" <> pretty n

1252 prettySe p bnd (PMetavar n) = text "?" <> pretty n

1241− prettySe p bnd (PReturn f) = text "return"

1253+ prettySe p bnd (PReturn f) = kwd "return"

1242− prettySe p bnd PImpossible = text "impossible"

1254+ prettySe p bnd PImpossible = kwd "impossible"

1243 prettySe p bnd Placeholder = text "_"

1255 prettySe p bnd Placeholder = text "_"

1244 prettySe p bnd (PDoBlock _) = text "do block pretty not implemented"

1256 prettySe p bnd (PDoBlock _) = text "do block pretty not implemented"

1245 prettySe p bnd (PElabError s) = pretty s

1257 prettySe p bnd (PElabError s) = pretty s

@@ -1254,7 +1266,7 @@ pprintPTerm impl bnd = prettySe 10 bnd

1254 prettyArgSe bnd arg = prettySe 0 bnd arg

1266 prettyArgSe bnd arg = prettySe 0 bnd arg

1255 prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1267 prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1256 prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace

1268 prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace

1257− prettyArgSti bnd (n, val) = lbrace <> text "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1269+ prettyArgSti bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1258

1270

1259 basename :: Name -> Name

1271 basename :: Name -> Name

1260 basename (NS n _) = basename n

1272 basename (NS n _) = basename n

@@ -1307,6 +1319,8 @@ pprintPTerm impl bnd = prettySe 10 bnd

1307 | inner > outer = lparen <> doc <> rparen

1319 | inner > outer = lparen <> doc <> rparen

1308 | otherwise = doc

1320 | otherwise = doc

1309

1321

1322+ kwd = annotate AnnKeyword . text

1323+

1310-- | Pretty-printer helper for the binding site of a name

1324-- | Pretty-printer helper for the binding site of a name

1311bindingOf :: Name -- ^^ the bound name

1325bindingOf :: Name -- ^^ the bound name

1312 -> Bool -- ^^ whether the name is implicit

1326 -> Bool -- ^^ whether the name is implicit

src/Idris/Apropos.hsnew file+87

@@ -0,0 +1,87 @@

1+module Idris.Apropos where

2+

3+import Idris.AbsSyntax

4+import Idris.Core.Evaluate (ctxtAlist, Def(..))

5+import Idris.Core.TT (Name(..), Type, TT(..), NameType(..), Binder(..), Const(..),

6+ lookupCtxtExact, toAlist)

7+import Idris.Docstrings (Docstring, containsText)

8+

9+import Data.List (nub)

10+import qualified Data.Text as T

11+

12+-- | Find definitions that are relevant to some string. Relevance is one or

13+-- more of the following:

14+--

15+-- * the string is a substring of the name

16+--

17+-- * the string occurs in the documentation string

18+--

19+-- * the type of the definition is apropos

20+apropos :: IState -> T.Text -> [Name]

21+apropos ist what = let defs = ctxtAlist (tt_ctxt ist)

22+ docs = toAlist (idris_docstrings ist)

23+ in nub (map fst (filter (isApropos what) defs) ++

24+ map fst (filter (isApropos what) docs))

25+

26+textIn :: T.Text -> T.Text -> Bool

27+textIn a b = T.isInfixOf (T.toLower a) (T.toLower b)

28+

29+class Apropos a where

30+ isApropos :: T.Text -> a -> Bool

31+

32+instance Apropos Name where

33+ isApropos str (UN n) = textIn str n

34+ isApropos str (NS n' ns) = isApropos str n' || any (textIn str) ns

35+ -- Handle special names from stdlib

36+ isApropos str n | (n == unitTy || n == unitCon) && str == T.pack "()" = True

37+ | n == falseTy && str == T.pack "_|_" = True

38+ | (n == pairTy || n == pairCon) && str == T.pack "," = True

39+ | n == eqTy && str == T.pack "=" = True

40+ | n == eqCon && (T.toLower str) == T.pack "refl" = True

41+ | (n == sigmaTy || n == existsCon) && str == T.pack "**" = True

42+ isApropos _ _ = False -- we don't care about case blocks, MNs, etc

43+

44+instance Apropos Def where

45+ isApropos str (Function ty tm) = isApropos str ty

46+ isApropos str (TyDecl _ ty) = isApropos str ty

47+ isApropos str (Operator ty _ _) = isApropos str ty

48+ isApropos str (CaseOp _ ty ty' _ _ _) = isApropos str ty

49+

50+instance Apropos (Binder (TT Name)) where

51+ isApropos str (Lam ty) = isApropos str ty

52+ isApropos str (Pi ty) = isApropos str ty

53+ isApropos str (Let ty val) = isApropos str ty || isApropos str val

54+ isApropos str (NLet ty val) = isApropos str ty || isApropos str val

55+ isApropos str _ = False -- these shouldn't occur in defined libraries

56+

57+instance Apropos (TT Name) where

58+ isApropos str (P Ref n ty) = isApropos str n || isApropos str ty

59+ isApropos str (P (TCon _ _) n ty) = isApropos str n || isApropos str ty

60+ isApropos str (P (DCon _ _) n ty) = isApropos str n || isApropos str ty

61+ isApropos str (P Bound _ ty) = isApropos str ty

62+ isApropos str (Bind n b tm) = isApropos str b || isApropos str tm

63+ isApropos str (App t1 t2) = isApropos str t1 || isApropos str t2

64+ isApropos str (Constant const) = isApropos str const

65+ isApropos str _ = False

66+

67+instance Apropos Const where

68+ isApropos str c = textIn str (T.pack (show c))

69+

70+instance Apropos Docstring where

71+ isApropos str d = containsText str d

72+

73+instance (Apropos a, Apropos b) => Apropos (a, b) where

74+ isApropos str (x, y) = isApropos str x || isApropos str y

75+

76+instance (Apropos a) => Apropos (Maybe a) where

77+ isApropos str (Just x) = isApropos str x

78+ isApropos _ Nothing = False

79+

80+instance (Apropos a) => Apropos [a] where

81+ isApropos str xs = any (isApropos str) xs

82+

83+defType :: Def -> Type

84+defType (Function t _) = t

85+defType (TyDecl _ t) = t

86+defType (Operator t _ _) = t

87+defType (CaseOp _ t _ _ _ _) = t

src/Idris/CaseSplit.hs+2

@@ -51,6 +51,8 @@ names over '_', patterns over names, etc.

51split :: Name -> PTerm -> Idris [[(Name, PTerm)]]

52split n t'

53 = do ist <- getIState

54+ -- Make sure all the names in the term are accessible

55+ mapM_ (\n -> setAccessibility n Public) (allNamesIn t')

54 (tm, ty, pats) <- elabValBind toplevel True (addImplPat ist t')

56 (tm, ty, pats) <- elabValBind toplevel True (addImplPat ist t')

55 logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats)

57 logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats)

56-- iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty))

58-- iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty))

src/Idris/Colours.hs+7−5

@@ -3,9 +3,8 @@ module Idris.Colours (

3 ColourTheme(..),

4 defaultTheme,

5 colouriseKwd, colouriseBound, colouriseImplicit,

6− colouriseType, colouriseFun, colouriseData,

6+ colouriseType, colouriseFun, colouriseData, colouriseKeyword,

7− colourisePrompt,

7+ colourisePrompt, colourise, ColourType(..)) where

8− ColourType(..)) where

9

8

10import System.Console.ANSI

9import System.Console.ANSI

11

10

@@ -30,8 +29,9 @@ data ColourTheme = ColourTheme { keywordColour :: IdrisColour

30 }

29 }

31 deriving (Eq, Show)

30 deriving (Eq, Show)

32

31

32+-- | Idris's default console colour theme

33defaultTheme :: ColourTheme

34−defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True True True False

34+defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True False True False

35 , boundVarColour = mkColour Magenta

36 , implicitColour = IdrisColour (Just Magenta) True True False False

37 , functionColour = mkColour Green

@@ -40,7 +40,7 @@ defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True True True

40 , promptColour = IdrisColour Nothing True False True False

41 }

42

43−-- Set the colour of a string using POSIX escape codes

43+-- | Set the colour of a string using POSIX escape codes

44colourise :: IdrisColour -> String -> String

45colourise (IdrisColour c v u b i) str = setSGRCode sgr ++ str ++ setSGRCode [Reset]

46 where sgr = fg c ++

@@ -71,6 +71,8 @@ colouriseData t = colourise (dataColour t)

71colourisePrompt :: ColourTheme -> String -> String

72colourisePrompt t = colourise (promptColour t)

73

74+colouriseKeyword :: ColourTheme -> String -> String

75+colouriseKeyword t = colourise (keywordColour t)

74

76

75data ColourType = KeywordColour

77data ColourType = KeywordColour

76 | BoundVarColour

78 | BoundVarColour

src/Idris/Completion.hs+5−1

@@ -108,7 +108,11 @@ completeMetaVar = completeWord Nothing (" \t(){}:" ++ opChars) completeM

108

109completeOption :: CompletionFunc Idris

110completeOption = completeWord Nothing " \t" completeOpt

111− where completeOpt = return . completeWith ["errorcontext", "showimplicits", "originalerrors"]

111+ where completeOpt = return . completeWith [ "errorcontext"

112+ , "showimplicits"

113+ , "originalerrors"

114+ , "autosolve"

115+ ]

112

116

113completeConsoleWidth :: CompletionFunc Idris

117completeConsoleWidth :: CompletionFunc Idris

114completeConsoleWidth = completeWord Nothing " \t" completeW

118completeConsoleWidth = completeWord Nothing " \t" completeW

src/Idris/Core/CaseTree.hs+2−2

@@ -159,7 +159,7 @@ directUse fn@(App f a)

159 | (P Ref (UN pfk) _, [App e w]) <- unApply fn,

160 pfk == txt "prim_fork"

161 = directUse e ++ directUse w -- HACK so that fork works

162− | (P Ref (UN fce) _, [_, a]) <- unApply fn,

162+ | (P Ref (UN fce) _, [_, _, a]) <- unApply fn,

163 fce == txt "Force"

164 = directUse a -- forcing a value counts as a use

165 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

@@ -626,7 +626,7 @@ prune proj (Case n alts)

626

627 forceTm n arg t = subst arg (forceArg n) t

628

629− forceArg n = App (App (P Ref (sUN "Force") Erased) Erased)

629+ forceArg n = App (App (App (P Ref (sUN "Force") Erased) Erased) Erased)

630 (P Bound n Erased)

631

632 mkProj n i [] sc = prune proj sc

src/Idris/Core/Elaborate.hs+33−8

@@ -131,14 +131,17 @@ force_term :: Elab' aux ()

131force_term = do ES (ps, a) l p <- get

132 put (ES (ps { pterm = force (pterm ps) }, a) l p)

133

134+-- | Modify the auxiliary state

134updateAux :: (aux -> aux) -> Elab' aux ()

135updateAux :: (aux -> aux) -> Elab' aux ()

135updateAux f = do ES (ps, a) l p <- get

136updateAux f = do ES (ps, a) l p <- get

136 put (ES (ps, f a) l p)

137 put (ES (ps, f a) l p)

137

138

139+-- | Get the auxiliary state

138getAux :: Elab' aux aux

140getAux :: Elab' aux aux

139getAux = do ES (ps, a) _ _ <- get

141getAux = do ES (ps, a) _ _ <- get

140 return $! a

142 return $! a

141

143

144+-- | Set whether to show the unifier log

142unifyLog :: Bool -> Elab' aux ()

145unifyLog :: Bool -> Elab' aux ()

143unifyLog log = do ES (ps, a) l p <- get

146unifyLog log = do ES (ps, a) l p <- get

144 put (ES (ps { unifylog = log }, a) l p)

147 put (ES (ps { unifylog = log }, a) l p)

@@ -147,11 +150,28 @@ getUnifyLog :: Elab' aux Bool

147getUnifyLog = do ES (ps, a) l p <- get

150getUnifyLog = do ES (ps, a) l p <- get

148 return (unifylog ps)

151 return (unifylog ps)

149

152

153+-- | Process a tactic within the current elaborator state

154+processTactic' :: Tactic -> Elab' aux ()

150processTactic' t = do ES (p, a) logs prev <- get

155processTactic' t = do ES (p, a) logs prev <- get

151 (p', log) <- lift $ processTactic t p

156 (p', log) <- lift $ processTactic t p

152 put (ES (p', a) (logs ++ log) prev)

157 put (ES (p', a) (logs ++ log) prev)

153 return $! ()

158 return $! ()

154

159

160+updatePS :: (ProofState -> ProofState) -> Elab' aux ()

161+updatePS f = do ES (ps, a) logs prev <- get

162+ put $ ES (f ps, a) logs prev

163+

164+now_elaborating :: FC -> Name -> Name -> Elab' aux ()

165+now_elaborating fc f a = updatePS (nowElaboratingPS fc f a)

166+done_elaborating_app :: Name -> Elab' aux ()

167+done_elaborating_app f = updatePS (doneElaboratingAppPS f)

168+done_elaborating_arg :: Name -> Name -> Elab' aux ()

169+done_elaborating_arg f a = updatePS (doneElaboratingArgPS f a)

170+elaborating_app :: Elab' aux [(FC, Name, Name)]

171+elaborating_app = do ES (ps, _) _ _ <- get

172+ return $ map (\ (FailContext x y z) -> (x, y, z))

173+ (while_elaborating ps)

174+

155-- Some handy gadgets for pulling out bits of state

175-- Some handy gadgets for pulling out bits of state

156

176

157-- get the global context

177-- get the global context

@@ -595,10 +615,10 @@ simple_app fun arg appstr =

595 hs <- get_holes

615 hs <- get_holes

596 env <- get_env

616 env <- get_env

597 -- We don't need a and b in the hole queue any more since they were

617 -- We don't need a and b in the hole queue any more since they were

598− -- just for checking f, so discard them if they are still there.

618+ -- just for checking f, so move them to the end. If they never end up

599− -- If they haven't been solved, regret will fail

619+ -- getting solved, we'll get an 'Incomplete term' error.

600− when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr)

620+ when (a `elem` hs) $ do movelast a

601− when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr)

621+ when (b `elem` hs) $ do movelast b

602 end_unify

622 end_unify

603 where regretWith err = try regret

623 where regretWith err = try regret

604 (lift $ tfail err)

624 (lift $ tfail err)

@@ -625,9 +645,12 @@ no_errors tac err

625 ps' <- get_probs

645 ps' <- get_probs

626 if (length ps' > length ps) then

646 if (length ps' > length ps) then

627 case reverse ps' of

647 case reverse ps' of

628− ((x,y,env,err,_) : _) ->

648+ ((x, y, env, inerr, while, _) : _) ->

629 let env' = map (\(x, b) -> (x, binderTy b)) env in

649 let env' = map (\(x, b) -> (x, binderTy b)) env in

650+ lift $ tfail $

651+ case err of

630− lift $ tfail $ CantUnify False x y err env' 0

652+ Nothing -> CantUnify False x y inerr env' 0

653+ Just e -> e

631 else return $! ()

654 else return $! ()

632

655

633-- Try a tactic, if it fails, try another

656-- Try a tactic, if it fails, try another

@@ -668,6 +691,8 @@ try' t1 t2 proofSearch

668 r || proofSearch

691 r || proofSearch

669 recoverableErr (CantSolveGoal _ _) = False

692 recoverableErr (CantSolveGoal _ _) = False

670 recoverableErr (ProofSearchFail _) = False

693 recoverableErr (ProofSearchFail _) = False

694+ recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e

695+ recoverableErr (At _ e) = recoverableErr e

671 recoverableErr _ = True

696 recoverableErr _ = True

672

697

673tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a

698tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a

@@ -716,12 +741,12 @@ prunStateT pmax zok ps x s

716 newpmax = if newps < 0 then 0 else newps in

741 newpmax = if newps < 0 then 0 else newps in

717 if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))

742 if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))

718 then case reverse (problems p) of

743 then case reverse (problems p) of

719− ((_,_,_,e,_):_) -> Error e

744+ ((_,_,_,e,_,_):_) -> Error e

720 else OK ((v, newpmax, problems p), s')

745 else OK ((v, newpmax, problems p), s')

721 Error e -> Error e

746 Error e -> Error e

722

747

723qshow :: Fails -> String

748qshow :: Fails -> String

724−qshow fs = show (map (\ (x, y, _, _, _) -> (x, y)) fs)

749+qshow fs = show (map (\ (x, y, _, _, _, _) -> (x, y)) fs)

725

750

726dumpprobs [] = ""

751dumpprobs [] = ""

727dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es

752dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es

src/Idris/Core/Evaluate.hs+19−6

@@ -262,6 +262,19 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

262 n' b' (\x -> ev ntimes stk False ((n', x):env) sc)

263 where vbind env t

264 = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t

265+ -- block reduction immediately under codata (and not forced)

266+ ev ntimes stk top env

267+ (App (App (App d@(P _ (UN dly) _) l@(P _ (UN lco) _)) t) arg)

268+ | dly == txt "Delay" && lco == txt "LazyCodata" && not simpl

269+ = do let (f, _) = unApply arg

270+ let ntimes' = case f of

271+ P _ fn _ -> (fn, 0) : ntimes

272+ _ -> ntimes

273+ d' <- ev ntimes' stk False env d

274+ l' <- ev ntimes' stk False env l

275+ t' <- ev ntimes' stk False env t

276+ arg' <- ev ntimes' stk False env arg

277+ evApply ntimes' stk top env [l',t',arg'] d'

265 -- Treat "assert_total" specially, as long as it's defined!

278 -- Treat "assert_total" specially, as long as it's defined!

266 ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)

279 ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)

267 | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

280 | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

@@ -876,12 +889,12 @@ isDConName n ctxt

876

889

877isFnName :: Name -> Context -> Bool

890isFnName :: Name -> Context -> Bool

878isFnName n ctxt

891isFnName n ctxt

879− = or $ do def <- lookupCtxt n (definitions ctxt)

892+ = let def = lookupCtxtExact n (definitions ctxt) in

880− case tfst def of

893+ case def of

881− (Function _ _) -> return True

894+ Just (Function _ _, _, _, _) -> True

882− (Operator _ _ _) -> return True

895+ Just (Operator _ _ _, _, _, _) -> True

883− (CaseOp _ _ _ _ _ _) -> return True

896+ Just (CaseOp _ _ _ _ _ _, _, _, _) -> True

884− _ -> return False

897+ _ -> False

885

898

886lookupP :: Name -> Context -> [Term]

899lookupP :: Name -> Context -> [Term]

887lookupP n ctxt

900lookupP n ctxt

src/Idris/Core/ProofState.hs+55−25

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

5 evaluation/checking inside the proof system, etc. --}

6

7module Idris.Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,

8− Tactic(..), Goal(..), processTactic,

8+ Tactic(..), Goal(..), processTactic, nowElaboratingPS, doneElaboratingAppPS,

9− dropGiven, keepGiven) where

9+ doneElaboratingArgPS, dropGiven, keepGiven) where

10

11import Idris.Core.Typecheck

12import Idris.Core.Evaluate

@@ -15,6 +15,7 @@ import Idris.Core.Unify

15

16import Control.Monad.State.Strict

17import Control.Applicative hiding (empty)

18+import Control.Arrow (first)

18import Data.List

19import Data.List

19import Debug.Trace

20import Debug.Trace

20

21

@@ -38,7 +39,8 @@ data ProofState = PS { thname :: Name,

38 context :: Context,

39 context :: Context,

39 plog :: String,

40 plog :: String,

40 unifylog :: Bool,

41 unifylog :: Bool,

41− done :: Bool

42+ done :: Bool,

43+ while_elaborating :: [FailContext]

42 }

44 }

43

45

44data Goal = GD { premises :: Env,

46data Goal = GD { premises :: Env,

@@ -89,9 +91,9 @@ data Tactic = Attack

89-- Some utilites on proof and tactic states

91-- Some utilites on proof and tactic states

90

92

91instance Show ProofState where

93instance Show ProofState where

92− show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _)

94+ show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)

93 = show nm ++ ": no more goals"

95 = show nm ++ ": no more goals"

94− show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _)

96+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _)

95 = let OK g = goal (Just h) tm

97 = let OK g = goal (Just h) tm

96 wkenv = premises g in

98 wkenv = premises g in

97 "Other goals: " ++ show hs ++ "\n" ++

99 "Other goals: " ++ show hs ++ "\n" ++

@@ -114,9 +116,9 @@ instance Show ProofState where

114 showG ps b = showEnv ps (binderTy b)

116 showG ps b = showEnv ps (binderTy b)

115

117

116instance Pretty ProofState OutputAnnotation where

118instance Pretty ProofState OutputAnnotation where

117− pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

119+ pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

118 pretty nm <+> colon <+> text " no more goals."

120 pretty nm <+> colon <+> text " no more goals."

119− pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _) =

121+ pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _) =

120 let OK g = goal (Just h) tm in

122 let OK g = goal (Just h) tm in

121 let wkEnv = premises g in

123 let wkEnv = premises g in

122 text "Other goals" <+> colon <+> pretty hs <+>

124 text "Other goals" <+> colon <+> pretty hs <+>

@@ -147,12 +149,13 @@ hole _ = False

147holeName i = sMN i "hole"

149holeName i = sMN i "hole"

148

150

149qshow :: Fails -> String

151qshow :: Fails -> String

150−qshow fs = show (map (\ (x, y, _, _, t) -> (t, x, y)) fs)

152+qshow fs = show (map (\ (x, y, _, _, _, t) -> (t, x, y)) fs)

151

153

152match_unify' :: Context -> Env -> TT Name -> TT Name ->

154match_unify' :: Context -> Env -> TT Name -> TT Name ->

153 StateT TState TC [(Name, TT Name)]

155 StateT TState TC [(Name, TT Name)]

154match_unify' ctxt env topx topy =

156match_unify' ctxt env topx topy =

155 do ps <- get

157 do ps <- get

158+ let while = while_elaborating ps

156 let dont = dontunify ps

159 let dont = dontunify ps

157 let inj = injective ps

160 let inj = injective ps

158 traceWhen (unifylog ps)

161 traceWhen (unifylog ps)

@@ -162,11 +165,11 @@ match_unify' ctxt env topx topy =

162 ++ "\n"

165 ++ "\n"

163 ++ "\n" ++ show (pterm ps) ++ "\n\n"

166 ++ "\n" ++ show (pterm ps) ++ "\n\n"

164 ) $

167 ) $

165− case match_unify ctxt env topx topy inj (holes ps) of

168+ case match_unify ctxt env topx topy inj (holes ps) while of

166 OK u -> do let (h, ns) = unified ps

169 OK u -> do let (h, ns) = unified ps

167 put (ps { unified = (h, u ++ ns) })

170 put (ps { unified = (h, u ++ ns) })

168 return u

171 return u

169− Error e -> do put (ps { problems = (topx, topy, env, e, Match) :

172+ Error e -> do put (ps { problems = (topx, topy, env, e, while, Match) :

170 problems ps })

173 problems ps })

171 return []

174 return []

172-- traceWhen (unifylog ps)

175-- traceWhen (unifylog ps)

@@ -180,24 +183,25 @@ unify' :: Context -> Env -> TT Name -> TT Name ->

180 StateT TState TC [(Name, TT Name)]

183 StateT TState TC [(Name, TT Name)]

181unify' ctxt env topx topy =

184unify' ctxt env topx topy =

182 do ps <- get

185 do ps <- get

186+ let while = while_elaborating ps

183 let dont = dontunify ps

187 let dont = dontunify ps

184 let inj = injective ps

188 let inj = injective ps

185 (u, fails) <- traceWhen (unifylog ps)

189 (u, fails) <- traceWhen (unifylog ps)

186 ("Trying " ++ show (topx, topy) ++

190 ("Trying " ++ show (topx, topy) ++

187 "\nNormalised " ++ show (normalise ctxt env topx,

191 "\nNormalised " ++ show (normalise ctxt env topx,

188− normalise ctxt env topy) ++

192+ normalise ctxt env topy) ++

189 " in " ++ show env ++

193 " in " ++ show env ++

190 "\nHoles: " ++ show (holes ps)

194 "\nHoles: " ++ show (holes ps)

191− ++ "\nInjective: " ++ show (injective ps)

195+ ++ "\nInjective: " ++ show (injective ps)

192 ++ "\n") $

196 ++ "\n") $

193− lift $ unify ctxt env topx topy inj (holes ps)

197+ lift $ unify ctxt env topx topy inj (holes ps) while

194 let notu = filter (\ (n, t) -> case t of

198 let notu = filter (\ (n, t) -> case t of

195 P _ _ _ -> False

199 P _ _ _ -> False

196 _ -> n `elem` dont) u

200 _ -> n `elem` dont) u

197 traceWhen (unifylog ps)

201 traceWhen (unifylog ps)

198 ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

202 ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

199 "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

203 "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

200− ++ "\nNot unified:\n" ++ show (notunified ps)

204+ ++ "\nNot unified:\n" ++ show (notunified ps)

201 ++ "\nCurrent problems:\n" ++ qshow (problems ps)

205 ++ "\nCurrent problems:\n" ++ qshow (problems ps)

202-- ++ show (pterm ps)

206-- ++ show (pterm ps)

203 ++ "\n----------") $

207 ++ "\n----------") $

@@ -220,6 +224,24 @@ unify' ctxt env topx topy =

220 updateInj (_ : us) inj = updateInj us inj

224 updateInj (_ : us) inj = updateInj us inj

221 updateInj [] inj = inj

225 updateInj [] inj = inj

222

226

227+nowElaboratingPS :: FC -> Name -> Name -> ProofState -> ProofState

228+nowElaboratingPS fc f arg ps = ps { while_elaborating = FailContext fc f arg : while_elaborating ps }

229+

230+dropUntil :: (a -> Bool) -> [a] -> [a]

231+dropUntil p [] = []

232+dropUntil p (x:xs) | p x = xs

233+ | otherwise = dropUntil p xs

234+

235+doneElaboratingAppPS :: Name -> ProofState -> ProofState

236+doneElaboratingAppPS f ps = let while = while_elaborating ps

237+ while' = dropUntil (\ (FailContext _ f' _) -> f == f') while

238+ in ps { while_elaborating = while' }

239+

240+doneElaboratingArgPS :: Name -> Name -> ProofState -> ProofState

241+doneElaboratingArgPS f x ps = let while = while_elaborating ps

242+ while' = dropUntil (\ (FailContext _ f' x') -> f == f' && x == x') while

243+ in ps { while_elaborating = while' }

244+

223getName :: Monad m => String -> StateT TState m Name

245getName :: Monad m => String -> StateT TState m Name

224getName tag = do ps <- get

246getName tag = do ps <- get

225 let n = nextname ps

247 let n = nextname ps

@@ -230,6 +252,10 @@ action :: Monad m => (ProofState -> ProofState) -> StateT TState m ()

230action a = do ps <- get

252action a = do ps <- get

231 put (a ps)

253 put (a ps)

232

254

255+query :: Monad m => (ProofState -> r) -> StateT TState m r

256+query q = do ps <- get

257+ return $ q ps

258+

233addLog :: Monad m => String -> StateT TState m ()

259addLog :: Monad m => String -> StateT TState m ()

234addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

260addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

235

261

@@ -240,7 +266,7 @@ newProof n ctxt ty = let h = holeName 0

240 (P Bound h ty')) ty [] (h, []) []

266 (P Bound h ty')) ty [] (h, []) []

241 Nothing [] []

267 Nothing [] []

242 [] []

268 [] []

243− Nothing ctxt "" False False

269+ Nothing ctxt "" False False []

244

270

245type TState = ProofState -- [TacticAction])

271type TState = ProofState -- [TacticAction])

246type RunTactic = Context -> Env -> Term -> StateT TState TC Term

272type RunTactic = Context -> Env -> Term -> StateT TState TC Term

@@ -491,7 +517,8 @@ solve ctxt env (Bind x (Guess ty val) sc)

491 = do ps <- get

517 = do ps <- get

492 let (uh, uns) = unified ps

518 let (uh, uns) = unified ps

493 case lookup x (notunified ps) of

519 case lookup x (notunified ps) of

520+ Just tm -> -- trace ("NEED MATCH: " ++ show (tm, val)) $

494− Just tm -> match_unify' ctxt env tm val

521+ match_unify' ctxt env tm val

495 _ -> return []

522 _ -> return []

496 action (\ps -> ps { holes = holes ps \\ [x],

523 action (\ps -> ps { holes = holes ps \\ [x],

497 solved = Just (x, val),

524 solved = Just (x, val),

@@ -637,10 +664,11 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

637 let scr = last $ tail args'

664 let scr = last $ tail args'

638 let indxnames = makeIndexNames indicies

665 let indxnames = makeIndexNames indicies

639 prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t

666 prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t

667+ consargs' <- query (\ps -> map (first $ flip (uniqueNameCtxt (context ps)) (holes ps)) consargs)

640− let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0)))

668+ let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0)))

641− (params ++ [prop] ++ map makeConsArg consargs ++ indicies ++ [tmv])))

669+ (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))

642 action (\ps -> ps {holes = holes ps \\ [x]})

670 action (\ps -> ps {holes = holes ps \\ [x]})

643− mapM_ addConsHole (reverse consargs)

671+ mapM_ addConsHole (reverse consargs')

644 let res' = forget $ res

672 let res' = forget $ res

645 (scv, sct) <- lift $ check ctxt env res'

673 (scv, sct) <- lift $ check ctxt env res'

646 let scv' = specialise ctxt env [] scv

674 let scv' = specialise ctxt env [] scv

@@ -788,36 +816,38 @@ updateNotunified ns nu = up nu where

788 up ((n, t) : nus) = let t' = updateSolved ns t in

816 up ((n, t) : nus) = let t' = updateSolved ns t in

789 ((n, t') : up nus)

817 ((n, t') : up nus)

790

818

819+updateProblems :: Context -> [(Name, TT Name)] -> Fails -> [Name] -> [Name]

820+ -> ([(Name, TT Name)], Fails)

791updateProblems ctxt [] ps inj holes = ([], ps)

821updateProblems ctxt [] ps inj holes = ([], ps)

792updateProblems ctxt ns ps inj holes = up ns ps where

822updateProblems ctxt ns ps inj holes = up ns ps where

793 up ns [] = (ns, [])

823 up ns [] = (ns, [])

794− up ns ((x, y, env, err, um) : ps) =

824+ up ns ((x, y, env, err, while, um) : ps) =

795 let x' = updateSolved ns x

825 let x' = updateSolved ns x

796 y' = updateSolved ns y

826 y' = updateSolved ns y

797 err' = updateError ns err

827 err' = updateError ns err

798 env' = updateEnv ns env in

828 env' = updateEnv ns env in

799-- trace ("Updating " ++ show (x',y')) $

829-- trace ("Updating " ++ show (x',y')) $

800− case unify ctxt env' x' y' inj holes of

830+ case unify ctxt env' x' y' inj holes while of

801 OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

831 OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

802 up (ns ++ v) ps

832 up (ns ++ v) ps

803 e -> -- trace ("Failed " ++ show e) $

833 e -> -- trace ("Failed " ++ show e) $

804 let (ns', ps') = up ns ps in

834 let (ns', ps') = up ns ps in

805− (ns', (x',y',env',err', um) : ps')

835+ (ns', (x',y',env',err', while, um) : ps')

806

836

807-- attempt to solve remaining problems with match_unify

837-- attempt to solve remaining problems with match_unify

808matchProblems all ns ctxt ps inj holes = up ns ps where

838matchProblems all ns ctxt ps inj holes = up ns ps where

809 up ns [] = (ns, [])

839 up ns [] = (ns, [])

810− up ns ((x, y, env, err, um) : ps)

840+ up ns ((x, y, env, err, while, um) : ps)

811 | all || um == Match =

841 | all || um == Match =

812 let x' = updateSolved ns x

842 let x' = updateSolved ns x

813 y' = updateSolved ns y

843 y' = updateSolved ns y

814 err' = updateError ns err

844 err' = updateError ns err

815 env' = updateEnv ns env in

845 env' = updateEnv ns env in

816− case match_unify ctxt env' x' y' inj holes of

846+ case match_unify ctxt env' x' y' inj holes while of

817 OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

847 OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

818 up (ns ++ v) ps

848 up (ns ++ v) ps

819 _ -> let (ns', ps') = up ns ps in

849 _ -> let (ns', ps') = up ns ps in

820− (ns', (x',y',env',err',um) : ps')

850+ (ns', (x', y', env', err', while, um) : ps')

821 up ns (p : ps) = let (ns', ps') = up ns ps in

851 up ns (p : ps) = let (ns', ps') = up ns ps in

822 (ns', p : ps')

852 (ns', p : ps')

823

853

src/Idris/Core/TT.hs+19−6

@@ -44,8 +44,8 @@ data Option = TTypeInTType

44

45-- | Source location. These are typically produced by the parser 'Idris.Parser.getFC'

46data FC = FC { fc_fname :: String, -- ^ Filename

47− fc_line :: Int, -- ^ Line number

47+ fc_start :: (Int, Int), -- ^ Line and column numbers for the start of the location span

48− fc_column :: Int -- ^ Column number

48+ fc_end :: (Int, Int) -- ^ Line and column numbers for the end of the location span

49 }

50

51-- | Ignore source location equality (so deriving classes do not compare FCs)

@@ -57,7 +57,7 @@ newtype FC' = FC' { unwrapFC :: FC }

57

58instance Eq FC' where

59 FC' fc == FC' fc' = fcEq fc fc'

60− where fcEq (FC n l c) (FC n' l' c') = n == n' && l == l' && c == c'

60+ where fcEq (FC n s e) (FC n' s' e') = n == n' && s == s' && e == e'

61

62-- | Empty source location

63emptyFC :: FC

@@ -65,7 +65,7 @@ emptyFC = fileFC ""

65

66-- | Source location with file only

67fileFC :: String -> FC

68−fileFC s = FC s 0 0

68+fileFC s = FC s (0, 0) (0, 0)

69

70{-!

71deriving instance Binary FC

@@ -73,20 +73,28 @@ deriving instance NFData FC

73!-}

74

75instance Sized FC where

76− size (FC f l c) = 1 + length f

76+ size (FC f s e) = 4 + length f

77

78instance Show FC where

79− show (FC f l c) = f ++ ":" ++ show l ++ ":" ++ show c

79+ show (FC f s e) = f ++ ":" ++ showLC s e

80+ where showLC (sl, sc) (el, ec) | sl == el && sc == ec = show sl ++ ":" ++ show sc

81+ | sl == el = show sl ++ ":" ++ show sc ++ "-" ++ show ec

82+ | otherwise = show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec

80

83

81-- | Output annotation for pretty-printed name - decides colour

84-- | Output annotation for pretty-printed name - decides colour

82data NameOutput = TypeOutput | FunOutput | DataOutput

85data NameOutput = TypeOutput | FunOutput | DataOutput

83

86

87+-- | Text formatting output

88+data TextFormatting = BoldText | ItalicText | UnderlineText

89+

84-- | Output annotations for pretty-printing

90-- | Output annotations for pretty-printing

85data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe Type)

91data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe Type)

86 | AnnBoundName Name Bool

92 | AnnBoundName Name Bool

87 | AnnConstData

93 | AnnConstData

88 | AnnConstType

94 | AnnConstType

95+ | AnnKeyword

89 | AnnFC FC

96 | AnnFC FC

97+ | AnnTextFmt TextFormatting

90

98

91-- | Used for error reflection

99-- | Used for error reflection

92data ErrorReportPart = TextPart String

100data ErrorReportPart = TextPart String

@@ -132,6 +140,7 @@ data Err' t

132 | NoRewriting t

140 | NoRewriting t

133 | At FC (Err' t)

141 | At FC (Err' t)

134 | Elaborating String Name (Err' t)

142 | Elaborating String Name (Err' t)

143+ | ElaboratingArg Name Name [(Name, Name)] (Err' t)

135 | ProviderError String

144 | ProviderError String

136 | LoadingFailed String (Err' t)

145 | LoadingFailed String (Err' t)

137 | ReflectionError [[ErrorReportPart]] (Err' t)

146 | ReflectionError [[ErrorReportPart]] (Err' t)

@@ -162,6 +171,7 @@ instance Sized Err where

162 size ProgramLineComment = 1

171 size ProgramLineComment = 1

163 size (At fc err) = size fc + size err

172 size (At fc err) = size fc + size err

164 size (Elaborating _ n err) = size err

173 size (Elaborating _ n err) = size err

174+ size (ElaboratingArg _ _ _ err) = size err

165 size (ProviderError msg) = length msg

175 size (ProviderError msg) = length msg

166 size (LoadingFailed fn e) = 1 + length fn + size e

176 size (LoadingFailed fn e) = 1 + length fn + size e

167 size _ = 1

177 size _ = 1

@@ -186,6 +196,9 @@ instance Show Err where

186 show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e

196 show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e

187 show ProgramLineComment = "Program line next to comment"

197 show ProgramLineComment = "Program line next to comment"

188 show (At f e) = show f ++ ":" ++ show e

198 show (At f e) = show f ++ ":" ++ show e

199+ show (ElaboratingArg f x prev e) = "Elaborating " ++ show f ++ " arg " ++

200+ show x ++ ": " ++ show e

201+ show (Elaborating what n e) = "Elaborating " ++ what ++ show n ++ ":" ++ show e

189 show _ = "Error"

202 show _ = "Error"

190

203

191instance Pretty Err OutputAnnotation where

204instance Pretty Err OutputAnnotation where

src/Idris/Core/Unify.hs+57−35

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

1{-# LANGUAGE PatternGuards #-}

2

3−module Idris.Core.Unify(match_unify, unify, Fails, FailAt(..)) where

3+module Idris.Core.Unify(match_unify, unify, Fails, FailContext(..), FailAt(..)) where

4

5import Idris.Core.TT

6import Idris.Core.Evaluate

@@ -21,8 +21,14 @@ import Debug.Trace

21data FailAt = Match | Unify

22 deriving (Show, Eq)

23

24+data FailContext = FailContext { fail_sourceloc :: FC,

25+ fail_fn :: Name,

26+ fail_param :: Name

27+ }

28+ deriving (Eq, Show)

29+

24type Injs = [(TT Name, TT Name, TT Name)]

30type Injs = [(TT Name, TT Name, TT Name)]

25−type Fails = [(TT Name, TT Name, Env, Err, FailAt)]

31+type Fails = [(TT Name, TT Name, Env, Err, [FailContext], FailAt)]

26

32

27data UInfo = UI Int Fails

33data UInfo = UI Int Fails

28 deriving Show

34 deriving Show

@@ -31,13 +37,21 @@ data UResult a = UOK a

31 | UPartOK a

37 | UPartOK a

32 | UFail Err

38 | UFail Err

33

39

40+-- | Smart constructor for unification errors that takes into account the FailContext

41+cantUnify :: [FailContext] -> Bool -> t -> t -> (Err' t) -> [(Name, t)] -> Int -> Err' t

42+cantUnify [] r t1 t2 e ctxt i = CantUnify r t1 t2 e ctxt i

43+cantUnify (FailContext fc f x : prev) r t1 t2 e ctxt i =

44+ At fc (ElaboratingArg f x

45+ (map (\(FailContext _ f' x') -> (f', x')) prev)

46+ (CantUnify r t1 t2 e ctxt i))

47+

34-- Solve metavariables by matching terms against each other

48-- Solve metavariables by matching terms against each other

35-- Not really unification, of course!

49-- Not really unification, of course!

36

50

37−match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

51+match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->

38 TC [(Name, TT Name)]

52 TC [(Name, TT Name)]

39−match_unify ctxt env topx topy inj holes =

53+match_unify ctxt env topx topy inj holes from =

40− case runStateT (un [] (renameBindersTm env topx)

54+ case runStateT (un [] (renameBindersTm env topx)

41 (renameBindersTm env topy)) (UI 0 []) of

55 (renameBindersTm env topy)) (UI 0 []) of

42 OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v))

56 OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v))

43 res ->

57 res ->

@@ -82,11 +96,12 @@ match_unify ctxt env topx topy inj holes =

82 un names x y

96 un names x y

83 | OK True <- convEq' ctxt holes x y = do sc 1; return []

97 | OK True <- convEq' ctxt holes x y = do sc 1; return []

84 | otherwise = do UI s f <- get

98 | otherwise = do UI s f <- get

85− let r = recoverable x y

99+ let r = recoverable (normalise ctxt env x)

86− let err = CantUnify r

100+ (normalise ctxt env y)

101+ let err = cantUnify from r

87 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

102 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

88 if (not r) then lift $ tfail err

103 if (not r) then lift $ tfail err

89− else do put (UI s ((x, y, env, err, Match) : f))

104+ else do put (UI s ((x, y, env, err, from, Match) : f))

90 lift $ tfail err

105 lift $ tfail err

91

106

92

107

@@ -96,11 +111,12 @@ match_unify ctxt env topx topy inj holes =

96 uB bnames (Lam tx) (Lam ty) = un bnames tx ty

111 uB bnames (Lam tx) (Lam ty) = un bnames tx ty

97 uB bnames (Pi tx) (Pi ty) = un bnames tx ty

112 uB bnames (Pi tx) (Pi ty) = un bnames tx ty

98 uB bnames x y = do UI s f <- get

113 uB bnames x y = do UI s f <- get

99− let r = recoverable (binderTy x) (binderTy y)

114+ let r = recoverable (normalise ctxt env (binderTy x))

115+ (normalise ctxt env (binderTy y))

100− let err = CantUnify r topx topy

116+ let err = cantUnify from r topx topy

101− (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

117+ (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

102− (errEnv env) s

118+ (errEnv env) s

103− put (UI s ((binderTy x, binderTy y, env, err, Match) : f))

119+ put (UI s ((binderTy x, binderTy y, env, err, from, Match) : f))

104 return []

120 return []

105

121

106 -- TODO: there's an annoying amount of repetition between this and the

122 -- TODO: there's an annoying amount of repetition between this and the

@@ -110,10 +126,11 @@ match_unify ctxt env topx topy inj holes =

110 put (UI (s+i) f)

126 put (UI (s+i) f)

111

127

112 unifyFail x y = do UI s f <- get

128 unifyFail x y = do UI s f <- get

113− let r = recoverable x y

129+ let r = recoverable (normalise ctxt env x)

114− let err = CantUnify r

130+ (normalise ctxt env y)

131+ let err = cantUnify from r

115 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

132 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

116− put (UI s ((x, y, env, err, Match) : f))

133+ put (UI s ((x, y, env, err, from, Match) : f))

117 lift $ tfail err

134 lift $ tfail err

118 combine bnames as [] = return as

135 combine bnames as [] = return as

119 combine bnames as ((n, t) : bs)

136 combine bnames as ((n, t) : bs)

@@ -188,9 +205,9 @@ expandLets env (x, tm) = (x, doSubst (reverse env) tm)

188 = doSubst env tm

205 = doSubst env tm

189

206

190

207

191−unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

208+unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->

192 TC ([(Name, TT Name)], Fails)

209 TC ([(Name, TT Name)], Fails)

193−unify ctxt env topx topy inj holes =

210+unify ctxt env topx topy inj holes from =

194-- trace ("Unifying " ++ show (topx, topy)) $

211-- trace ("Unifying " ++ show (topx, topy)) $

195 -- don't bother if topx and topy are different at the head

212 -- don't bother if topx and topy are different at the head

196 case runStateT (un False [] (renameBindersTm env topx)

213 case runStateT (un False [] (renameBindersTm env topx)

@@ -363,17 +380,18 @@ unify ctxt env topx topy inj holes =

363 un' fn bnames x y

380 un' fn bnames x y

364 | OK True <- convEq' ctxt holes x y = do sc 1; return []

381 | OK True <- convEq' ctxt holes x y = do sc 1; return []

365 | otherwise = do UI s f <- get

382 | otherwise = do UI s f <- get

366− let r = recoverable x y

383+ let r = recoverable (normalise ctxt env x)

367− let err = CantUnify r

384+ (normalise ctxt env y)

385+ let err = cantUnify from r

368 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

386 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

369 if (not r) then lift $ tfail err

387 if (not r) then lift $ tfail err

370− else do put (UI s ((x, y, env, err, Unify) : f))

388+ else do put (UI s ((x, y, env, err, from, Unify) : f))

371 return [] -- lift $ tfail err

389 return [] -- lift $ tfail err

372

390

373 unApp fn bnames appx@(App fx ax) appy@(App fy ay)

391 unApp fn bnames appx@(App fx ax) appy@(App fy ay)

374 | (injectiveApp fx && injectiveApp fy)

392 | (injectiveApp fx && injectiveApp fy)

375− || (injectiveApp fx && rigid appx && metavarApp appy)

393+ || (injectiveApp fx && rigid appx && metavarApp appy && numArgs appx == numArgs appy)

376− || (injectiveApp fy && rigid appy && metavarApp appx)

394+ || (injectiveApp fy && rigid appy && metavarApp appx && numArgs appx == numArgs appy)

377 || (injectiveApp fx && metavarApp fy && ax == ay)

395 || (injectiveApp fx && metavarApp fy && ax == ay)

378 || (injectiveApp fy && metavarApp fx && ax == ay)

396 || (injectiveApp fy && metavarApp fx && ax == ay)

379 = do let (headx, _) = unApply fx

397 = do let (headx, _) = unApply fx

@@ -418,6 +436,8 @@ unify ctxt env topx topy inj holes =

418 vs <- combine bnames as as'

436 vs <- combine bnames as as'

419 unArgs vs xs ys

437 unArgs vs xs ys

420

438

439+ numArgs tm = let (f, args) = unApply tm in length args

440+

421 metavarApp tm = let (f, args) = unApply tm in

441 metavarApp tm = let (f, args) = unApply tm in

422 (metavar f &&

442 (metavar f &&

423 all (\x -> metavarApp x) args

443 all (\x -> metavarApp x) args

@@ -461,18 +481,18 @@ unify ctxt env topx topy inj holes =

461 unifyTmpFail :: Term -> Term -> StateT UInfo TC [(Name, TT Name)]

481 unifyTmpFail :: Term -> Term -> StateT UInfo TC [(Name, TT Name)]

462 unifyTmpFail x y

482 unifyTmpFail x y

463 = do UI s f <- get

483 = do UI s f <- get

464− let r = recoverable x y

484+ let r = recoverable (normalise ctxt env x) (normalise ctxt env y)

465− let err = CantUnify r

485+ let err = cantUnify from r

466 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

486 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

467− put (UI s ((topx, topy, env, err, Unify) : f))

487+ put (UI s ((topx, topy, env, err, from, Unify) : f))

468 return []

488 return []

469

489

470 -- shortcut failure, if we *know* nothing can fix it

490 -- shortcut failure, if we *know* nothing can fix it

471 unifyFail x y = do UI s f <- get

491 unifyFail x y = do UI s f <- get

472− let r = recoverable x y

492+ let r = recoverable (normalise ctxt env x) (normalise ctxt env y)

473− let err = CantUnify r

493+ let err = cantUnify from r

474 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

494 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

475− put (UI s ((topx, topy, env, err, Unify) : f))

495+ put (UI s ((topx, topy, env, err, from, Unify) : f))

476 lift $ tfail err

496 lift $ tfail err

477

497

478

498

@@ -491,11 +511,12 @@ unify ctxt env topx topy inj holes =

491 uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty

511 uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty

492 uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty

512 uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty

493 uB bnames x y = do UI s f <- get

513 uB bnames x y = do UI s f <- get

494− let r = recoverable (binderTy x) (binderTy y)

514+ let r = recoverable (normalise ctxt env (binderTy x))

515+ (normalise ctxt env (binderTy y))

495− let err = CantUnify r topx topy

516+ let err = cantUnify from r topx topy

496− (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

517+ (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

497− (errEnv env) s

518+ (errEnv env) s

498− put (UI s ((binderTy x, binderTy y, env, err, Unify) : f))

519+ put (UI s ((binderTy x, binderTy y, env, err, from, Unify) : f))

499 return [] -- lift $ tfail err

520 return [] -- lift $ tfail err

500

521

501 checkCycle ns p@(x, P _ _ _) = return [p]

522 checkCycle ns p@(x, P _ _ _) = return [p]

@@ -561,6 +582,7 @@ envPos x i ((y, _) : ys) | x == y = i

561-- more work may help.

582-- more work may help.

562-- FIXME: Depending on how overloading gets used, this may cause problems. Better

583-- FIXME: Depending on how overloading gets used, this may cause problems. Better

563-- rethink overloading properly...

584-- rethink overloading properly...

585+-- ASSUMPTION: inputs are in normal form

564

586

565recoverable t@(App _ _) _

587recoverable t@(App _ _) _

566 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False

588 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False

@@ -581,7 +603,7 @@ recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False

581recoverable p@(Constant _) (App f a) = recoverable p f

603recoverable p@(Constant _) (App f a) = recoverable p f

582recoverable (App f a) p@(Constant _) = recoverable f p

604recoverable (App f a) p@(Constant _) = recoverable f p

583recoverable p@(P _ n _) (App f a) = recoverable p f

605recoverable p@(P _ n _) (App f a) = recoverable p f

584−-- recoverable (App f a) p@(P _ _ _) = recoverable f p

606+recoverable (App f a) p@(P _ _ _) = recoverable f p

585recoverable (App f a) (App f' a')

607recoverable (App f a) (App f' a')

586 = recoverable f f' -- && recoverable a a'

608 = recoverable f f' -- && recoverable a a'

587recoverable f (Bind _ (Pi _) sc)

609recoverable f (Bind _ (Pi _) sc)

src/Idris/Coverage.hs+63−128

@@ -218,6 +218,23 @@ genAll i args

218

219upd p' p = p { getTm = p' }

220

221+-- Check whether function and all descendants cover all cases (partial is

222+-- okay, as long as it's due to recursion)

223+

224+checkAllCovering :: FC -> [Name] -> Name -> Name -> Idris ()

225+checkAllCovering fc done top n | not (n `elem` done)

226+ = do i <- get

227+ case lookupTotal n (tt_ctxt i) of

228+ [tot@(Partial NotCovering)] ->

229+ tclift $ tfail (At fc (Msg (show top ++ " is " ++ show tot

230+ ++ " due to " ++ show n)))

231+ _ -> return ()

232+ case lookupCtxt n (idris_callgraph i) of

233+ [cg] -> mapM_ (checkAllCovering fc (n : done) top)

234+ (map fst (calls cg))

235+ _ -> return ()

236+checkAllCovering _ _ _ _ = return ()

237+

221-- Check if, in a given type n, the constructor cn : ty is strictly positive,

238-- Check if, in a given type n, the constructor cn : ty is strictly positive,

222-- and update the context accordingly

239-- and update the context accordingly

223

240

@@ -256,7 +273,7 @@ calcProd i fc topn pats

256

273

257 prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

274 prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

258 prodRec n done _ | n `elem` done = return True

275 prodRec n done _ | n `elem` done = return True

259− prodRec n done (_, _, tm) = prod n done False (delazy tm)

276+ prodRec n done (_, _, tm) = prod n done False (delazy' True tm)

260

277

261 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

278 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

262 prod n done ok ap@(App _ _)

279 prod n done ok ap@(App _ _)

@@ -292,9 +309,12 @@ calcProd i fc topn pats

292 _ -> False

309 _ -> False

293 cotype nt n ty = False

310 cotype nt n ty = False

294

311

312+-- Calculate the totality of a function from its patterns.

313+-- Either follow the size change graph (if inductive) or check for

314+-- productivity (if coinductive)

315+

295−calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]

316+calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality

296− -> Idris Totality

297−calcTotality path fc n pats

317+calcTotality fc n pats

298 = do i <- getIState

318 = do i <- getIState

299 let opts = case lookupCtxt n (idris_flags i) of

319 let opts = case lookupCtxt n (idris_flags i) of

300 [fs] -> fs

320 [fs] -> fs

@@ -329,20 +349,10 @@ checkTotality path fc n

329 [CaseOp _ _ _ _ pats _] ->

349 [CaseOp _ _ _ _ pats _] ->

330 do t' <- if AssertTotal `elem` opts

350 do t' <- if AssertTotal `elem` opts

331 then return $ Total []

351 then return $ Total []

332− else calcTotality path fc n pats

352+ else calcTotality fc n pats

333 setTotality n t'

353 setTotality n t'

334 addIBC (IBCTotal n t')

354 addIBC (IBCTotal n t')

335 return t'

355 return t'

336− -- if it's not total, it can't reduce, to keep

337− -- typechecking decidable

338−-- case t' of

339−-- p@(Partial _) ->

340−-- do setAccessibility n Frozen

341−-- addIBC (IBCAccess n Frozen)

342−-- logLvl 5 $ "HIDDEN: "

343−-- ++ show n ++ show p

344−-- _ -> return ()

345−-- return t'

346 _ -> return $ Total []

356 _ -> return $ Total []

347 x -> return x

357 x -> return x

348 case t' of

358 case t' of

@@ -411,41 +421,57 @@ buildSCG (_, n) = do

411 [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

421 [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

412 x -> error $ "buildSCG: " ++ show (n, x)

422 x -> error $ "buildSCG: " ++ show (n, x)

413

423

424+delazy = delazy' False -- not lazy codata

414−delazy t@(App f a)

425+delazy' all t@(App f a)

415− | (P _ (UN l) _, [_, arg]) <- unApply t,

426+ | (P _ (UN l) _, [_, _, arg]) <- unApply t,

416− l == txt "Force" = delazy arg

427+ l == txt "Force" = delazy' all arg

417− | (P _ (UN l) _, [_, arg]) <- unApply t,

428+ | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,

418− l == txt "Delay" = delazy arg

429+ l == txt "Delay" && (all || lty == txt "LazyEval") = delazy arg

419− | (P _ (UN l) _, [arg]) <- unApply t,

430+ | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,

420− l == txt "Lazy" = delazy arg

431+ l == txt "Lazy'" && (all || lty == txt "LazyEval") = delazy' all arg

421−delazy (App f a) = App (delazy f) (delazy a)

432+delazy' all (App f a) = App (delazy' all f) (delazy' all a)

422−delazy (Bind n b sc) = Bind n (fmap delazy b) (delazy sc)

433+delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc)

423−delazy t = t

434+delazy' all t = t

435+

436+data Guardedness = Toplevel | Unguarded | Guarded

424

437

425buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry]

438buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry]

426buildSCG' ist pats args = nub $ concatMap scgPat pats where

439buildSCG' ist pats args = nub $ concatMap scgPat pats where

427 scgPat (lhs, rhs) = let lhs' = delazy lhs

440 scgPat (lhs, rhs) = let lhs' = delazy lhs

428 rhs' = delazy rhs

441 rhs' = delazy rhs

429 (f, pargs) = unApply (dePat lhs') in

442 (f, pargs) = unApply (dePat lhs') in

430− findCalls (dePat rhs') (patvars lhs') pargs

443+ findCalls Toplevel (dePat rhs') (patvars lhs') pargs

431

444

432− findCalls ap@(App f a) pvs pargs

445+ findCalls guarded ap@(App f a) pvs pargs

433 -- under a call to "assert_total", don't do any checking, just believe

446 -- under a call to "assert_total", don't do any checking, just believe

434 -- that it is total.

447 -- that it is total.

435 | (P _ (UN at) _, [_, _]) <- unApply ap,

448 | (P _ (UN at) _, [_, _]) <- unApply ap,

436 at == txt "assert_total" = []

449 at == txt "assert_total" = []

450+ -- under a call to "Delay LazyCodata", don't do any checking of the

451+ -- immediate call, as long as the call is guarded.

452+ -- Then check its arguments

453+ | (P _ (UN del) _, [_,_,arg]) <- unApply ap,

454+ guarded <- Guarded,

455+ del == txt "Delay"

456+ = let (capp, args) = unApply arg in

457+ concatMap (\x -> findCalls Toplevel x pvs pargs) args

437 | (P _ n _, args) <- unApply ap

458 | (P _ n _, args) <- unApply ap

438− = mkChange n args pargs ++

459+ = let nguarded = case guarded of

460+ Unguarded -> Unguarded

461+ _ -> if isConName n (tt_ctxt ist)

462+ then Guarded

463+ else Unguarded in

464+ mkChange n args pargs ++

439− concatMap (\x -> findCalls x pvs pargs) args

465+ concatMap (\x -> findCalls nguarded x pvs pargs) args

440− findCalls (App f a) pvs pargs

466+ findCalls guarded (App f a) pvs pargs

441− = findCalls f pvs pargs ++ findCalls a pvs pargs

467+ = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs

442− findCalls (Bind n (Let t v) e) pvs pargs

468+ findCalls guarded (Bind n (Let t v) e) pvs pargs

443− = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs

469+ = findCalls Unguarded v pvs pargs ++ findCalls guarded e (n : pvs) pargs

444− findCalls (Bind n _ e) pvs pargs

470+ findCalls guarded (Bind n _ e) pvs pargs

445− = findCalls e (n : pvs) pargs

471+ = findCalls guarded e (n : pvs) pargs

446− findCalls (P _ f _ ) pvs pargs

472+ findCalls guarded (P _ f _ ) pvs pargs

447 | not (f `elem` pvs) = [(f, [])]

473 | not (f `elem` pvs) = [(f, [])]

448− findCalls _ _ _ = []

474+ findCalls _ _ _ _ = []

449

475

450 expandToArity n args

476 expandToArity n args

451 = case lookupTy n (tt_ctxt ist) of

477 = case lookupTy n (tt_ctxt ist) of

@@ -498,103 +524,12 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

498 nty == nty' && not co

524 nty == nty' && not co

499 isInductive _ _ = False

525 isInductive _ _ = False

500

526

501−-- getTypeFam t | (P _ n _, _) <- unApply t

502−

503 dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)

527 dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)

504 dePat t = t

528 dePat t = t

505

529

506 patvars (Bind x (PVar _) sc) = x : patvars sc

530 patvars (Bind x (PVar _) sc) = x : patvars sc

507 patvars _ = []

531 patvars _ = []

508

532

509−{-

510−buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]

511−buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

512− nub $ scg sc (zip args args)

513− (zip args (zip args (repeat Same)))

514− where

515− scg :: SC -> [(Name, Name)] -> -- local var, originating top level var

516− [(Name, (Name, SizeChange))] -> -- orig to new, and relationship

517− [SCGEntry]

518− scg (Case x alts) vars szs

519− = let x' = findTL x vars in

520− concatMap (scgAlt x' vars szs) alts

521− where

522− findTL x vars

523− | Just x' <- lookup x vars

524− = if x' `elem` args then x'

525− else findTL x' vars

526− | otherwise = x

527−

528− scg (STerm tm) vars szs = scgTerm tm vars szs

529− scg _ _ _ = []

530−

531− -- how the arguments relate - either Smaller or Unknown

532− argRels :: Name -> [(Name, SizeChange)]

533− argRels n = let ctxt = tt_ctxt ist

534− [ty] = lookupTy n ctxt -- must exist!

535− P _ nty _ = fst (unApply (getRetTy ty))

536− co = case lookupCtxt nty (idris_datatypes ist) of

537− [TI _ x _ _] -> x

538− _ -> False

539− args = map snd (getArgTys ty) in

540− map (getRel co nty) (map (fst . unApply . getRetTy) args)

541− where

542− getRel True _ _ = (n, Unknown) -- coinductive

543− getRel _ ty (P _ n' _) | n' == ty = (n, Smaller)

544− getRel _ ty t = (n, Unknown)

545−

546− scgAlt x vars szs (ConCase n _ args sc)

547− -- all args smaller than top variable of x in sc

548− -- (as long as they are in the same type family, and it's

549− -- not coinductive)

550− | Just tvar <- lookup x vars

551− = let arel = argRels n

552− szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel

553− ++ szs

554− vars' = nub (zip args (repeat tvar) ++ vars) in

555− scg sc vars' szs'

556− | otherwise = scg sc vars szs

557− scgAlt x vars szs (ConstCase _ sc) = scg sc vars szs

558− scgAlt x vars szs (DefaultCase sc) = scg sc vars szs

559−

560− scgTerm f@(App _ _) vars szs

561− | (P _ (UN "lazy") _, [_, arg]) <- unApply f

562− = scgTerm arg vars szs

563− | (P _ fn _, args) <- unApply f

564− = let rest = concatMap (\x -> scgTerm x vars szs) args in

565− case lookup fn vars of

566− Just _ -> rest

567− Nothing -> nub $ (fn, map (mkChange szs) args) : rest

568− scgTerm (App f a) vars szs

569− = scgTerm f vars szs ++ scgTerm a vars szs

570− scgTerm (Bind n (Let t v) e) vars szs

571− = scgTerm v vars szs ++ scgTerm e vars szs

572− scgTerm (Bind n _ e) vars szs

573− = scgTerm e (nub ((n, n) : vars)) szs

574− scgTerm (P _ fn _) vars szs

575− = case lookup fn vars of

576− Just _ -> []

577− Nothing -> [(fn, [])]

578− scgTerm _ _ _ = []

579−

580− mkChange :: [(Name, (Name, SizeChange))] -> Term

581− -> Maybe (Int, SizeChange)

582− mkChange szs tm

583− | (P _ (UN "lazy") _, [_, arg]) <- unApply tm = mkChange szs arg

584− | (P _ n ty, _) <- unApply tm -- get higher order args too

585− = do sc <- lookup n szs

586− case sc of

587− (_, Unknown) -> Nothing

588− (o, sc) -> do i <- getArgPos 0 o args

589− return (i, sc)

590− mkChange _ _ = Nothing

591−

592− getArgPos :: Int -> Name -> [Name] -> Maybe Int

593− getArgPos i n [] = Nothing

594− getArgPos i n (x : xs) | n == x = Just i

595− | otherwise = getArgPos (i + 1) n xs

596−-}

597−

598checkSizeChange :: Name -> Idris Totality

533checkSizeChange :: Name -> Idris Totality

599checkSizeChange n = do

534checkSizeChange n = do

600 ist <- getIState

535 ist <- getIState

src/Idris/DSL.hs+2−2

@@ -57,10 +57,10 @@ expandDo dsl (PDoBlock ds)

57 block b [a] = PElabError (Msg "Last statement in do block must be an expression")

58 block b (DoBind fc n tm : rest)

59 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

60− block b (DoBindP fc p tm : rest)

60+ block b (DoBindP fc p tm alts : rest)

61 = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder

62 (PCase fc (PRef fc (sMN 0 "bpat"))

63− [(p, block b rest)]))]

63+ ((p, block b rest) : alts)))]

64 block b (DoLet fc n ty tm : rest)

65 = PLet n ty tm (block b rest)

66 block b (DoLetP fc p tm : rest)

src/Idris/DeepSeq.hs+43−1

@@ -6,6 +6,48 @@ import Idris.AbsSyntaxTree

6

7import Control.DeepSeq

8

9+import qualified Cheapskate.Types as CT

10+

11+-- Manual from imported libs

12+instance NFData CT.Doc where

13+ rnf (CT.Doc opts contents) = rnf opts `seq` rnf contents `seq` ()

14+

15+instance NFData CT.Options where

16+ rnf (CT.Options x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

17+

18+instance NFData CT.Block where

19+ rnf (CT.Para lines) = rnf lines `seq` ()

20+ rnf (CT.Header i lines) = rnf i `seq` rnf lines `seq` ()

21+ rnf (CT.Blockquote bs) = rnf bs `seq` ()

22+ rnf (CT.List b t xs) = rnf b `seq` rnf t `seq` rnf xs `seq` ()

23+ rnf (CT.CodeBlock attr txt) = rnf attr `seq` rnf txt `seq` ()

24+ rnf (CT.HtmlBlock txt) = rnf txt `seq` ()

25+ rnf CT.HRule = ()

26+

27+instance NFData CT.Inline where

28+ rnf (CT.Str txt) = rnf txt `seq` ()

29+ rnf CT.Space = ()

30+ rnf CT.SoftBreak = ()

31+ rnf CT.LineBreak = ()

32+ rnf (CT.Emph xs) = rnf xs `seq` ()

33+ rnf (CT.Strong xs) = rnf xs `seq` ()

34+ rnf (CT.Code xs) = rnf xs `seq` ()

35+ rnf (CT.Link a b xs) = rnf a `seq` rnf b `seq` rnf xs `seq` ()

36+ rnf (CT.Image a b c) = rnf a `seq` rnf b `seq` rnf c `seq` ()

37+ rnf (CT.Entity a) = rnf a `seq` ()

38+ rnf (CT.RawHtml x) = rnf x `seq` ()

39+

40+instance NFData CT.ListType where

41+ rnf (CT.Bullet c) = rnf c `seq` ()

42+ rnf (CT.Numbered nw i) = rnf nw `seq` rnf i `seq` ()

43+

44+instance NFData CT.CodeAttr where

45+ rnf (CT.CodeAttr a b) = rnf a `seq` rnf b `seq` ()

46+

47+instance NFData CT.NumWrapper where

48+ rnf CT.PeriodFollowing = ()

49+ rnf CT.ParenFollowing = ()

50+

9-- All generated by 'derive'

51-- All generated by 'derive'

10

52

11instance NFData Forceability where

53instance NFData Forceability where

@@ -226,7 +268,7 @@ instance (NFData t) => NFData (PTactic' t) where

226instance (NFData t) => NFData (PDo' t) where

268instance (NFData t) => NFData (PDo' t) where

227 rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

269 rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

228 rnf (DoBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

270 rnf (DoBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

229− rnf (DoBindP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

271+ rnf (DoBindP x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

230 rnf (DoLet x1 x2 x3 x4)

272 rnf (DoLet x1 x2 x3 x4)

231 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

273 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

232 rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

274 rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

src/Idris/Delaborate.hs+29−6

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

1{-# LANGUAGE PatternGuards #-}

2−

3module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', pshow, pprintErr) where

2module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', pshow, pprintErr) where

4

3

5-- Convert core TT back into high level syntax, primarily for display

4-- Convert core TT back into high level syntax, primarily for display

@@ -13,6 +12,7 @@ import Idris.Core.Evaluate

13import Idris.ErrReverse

12import Idris.ErrReverse

14

13

15import Data.List (intersperse)

14import Data.List (intersperse)

15+import qualified Data.Text as T

16

17import Debug.Trace

18

@@ -138,7 +138,7 @@ pprintTerm :: IState -> PTerm -> Doc OutputAnnotation

138pprintTerm ist = pprintTerm' ist []

139

140pprintTerm' :: IState -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

141−pprintTerm' ist = pprintPTerm (opt_showimp (idris_options ist))

141+pprintTerm' ist bnd tm = pprintPTerm (opt_showimp (idris_options ist)) bnd [] tm

142

143pshow :: IState -> Err -> String

144pshow ist err = displayDecorated (consoleDecorate ist) .

@@ -200,7 +200,7 @@ pprintErr' i (NotInjective p x y) =

200 pprintTerm i (delab i y)

201pprintErr' i (CantResolve c) = text "Can't resolve type class" <+> pprintTerm i (delab i c)

202pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+>

203− cat (punctuate (comma <> space) (map text as))

203+ align (cat (punctuate (comma <> space) (map text as)))

204pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n

205pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n

206pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> pprintTerm i (delab i t)

@@ -217,16 +217,33 @@ pprintErr' i (At f e) = annotate (AnnFC f) (text (show f)) <> colon <> pprintErr

217pprintErr' i (Elaborating s n e) = text "When elaborating" <+> text s <>

218 annName' n (showqual i n) <> colon <$>

219 pprintErr' i e

220+pprintErr' i (ElaboratingArg f x _ e)

221+ | isUN x =

222+ text "When elaborating argument" <+>

223+ annotate (AnnBoundName x False) (text (showbasic x)) <+> --TODO check plicity

224+ text "to" <+> whatIsName <> annName f <> colon <>

225+ indented (pprintErr' i e)

226+ | otherwise =

227+ text "When elaborating an application of" <+> whatIsName <>

228+ annName f <> colon <> indented (pprintErr' i e)

229+ where whatIsName = let ctxt = tt_ctxt i

230+ in if isTConName f ctxt

231+ then text "type constructor" <> space

232+ else if isConName f ctxt

233+ then text "constructor" <> space

234+ else if isFnName f ctxt

235+ then text "function" <> space

236+ else empty

220pprintErr' i (ProviderError msg) = text ("Type provider error: " ++ msg)

237pprintErr' i (ProviderError msg) = text ("Type provider error: " ++ msg)

221pprintErr' i (LoadingFailed fn e) = text "Loading" <+> text fn <+> text "failed:" <+> pprintErr' i e

238pprintErr' i (LoadingFailed fn e) = text "Loading" <+> text fn <+> text "failed:" <+> pprintErr' i e

222pprintErr' i (ReflectionError parts orig) =

239pprintErr' i (ReflectionError parts orig) =

223− let parts' = map (hsep . map showPart) parts in

240+ let parts' = map (fillSep . map showPart) parts in

224− vsep parts' <>

241+ align (fillSep parts') <>

225 if (opt_origerr (idris_options i))

242 if (opt_origerr (idris_options i))

226 then line <> line <> text "Original error:" <$> indented (pprintErr' i orig)

243 then line <> line <> text "Original error:" <$> indented (pprintErr' i orig)

227 else empty

244 else empty

228 where showPart :: ErrorReportPart -> Doc OutputAnnotation

245 where showPart :: ErrorReportPart -> Doc OutputAnnotation

229− showPart (TextPart str) = text str

246+ showPart (TextPart str) = fillSep . map text . words $ str

230 showPart (NamePart n) = annName n

247 showPart (NamePart n) = annName n

231 showPart (TermPart tm) = pprintTerm i (delab i tm)

248 showPart (TermPart tm) = pprintTerm i (delab i tm)

232 showPart (SubReport rs) = indented . hsep . map showPart $ rs

249 showPart (SubReport rs) = indented . hsep . map showPart $ rs

@@ -235,6 +252,11 @@ pprintErr' i (ReflectionFailed msg err) =

235 indented (pprintErr' i err) <>

252 indented (pprintErr' i err) <>

236 text ("This is probably a bug. Please consider reporting it at " ++ bugaddr)

253 text ("This is probably a bug. Please consider reporting it at " ++ bugaddr)

237

254

255+isUN :: Name -> Bool

256+isUN (UN n) = not $ T.isPrefixOf (T.pack "__") n -- TODO figure out why MNs are getting rewritte to UNs for top-level pattern-matching functions

257+isUN (NS n _) = isUN n

258+isUN _ = False

259+

238annName :: Name -> Doc OutputAnnotation

260annName :: Name -> Doc OutputAnnotation

239annName n = annName' n (showbasic n)

261annName n = annName' n (showbasic n)

240

262

@@ -259,6 +281,7 @@ showqual i n = showName (Just i) [] False False (dens n)

259 _ -> ns

281 _ -> ns

260 dens n = n

282 dens n = n

261

283

284+showbasic :: Name -> String

262showbasic n@(UN _) = show n

285showbasic n@(UN _) = show n

263showbasic (MN _ s) = str s

286showbasic (MN _ s) = str s

264showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

287showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

src/Idris/Docs.hs+23−18

@@ -1,3 +1,4 @@

1+{-# LANGUAGE PatternGuards #-}

1module Idris.Docs where

2module Idris.Docs where

2

3

3import Idris.AbsSyntax

4import Idris.AbsSyntax

@@ -5,16 +6,18 @@ import Idris.AbsSyntaxTree

5import Idris.Delaborate

6import Idris.Delaborate

6import Idris.Core.TT

7import Idris.Core.TT

7import Idris.Core.Evaluate

8import Idris.Core.Evaluate

9+import Idris.Docstrings

8

10

9import Util.Pretty

11import Util.Pretty

10

12

11import Data.Maybe

13import Data.Maybe

12import Data.List

14import Data.List

15+import qualified Data.Text as T

13

16

14-- TODO: Only include names with public/abstract accessibility

17-- TODO: Only include names with public/abstract accessibility

15

18

16−data FunDoc = FD Name String

19+data FunDoc = FD Name Docstring

17− [(Name, PTerm, Plicity, Maybe String)] -- args: name, ty, implicit, docs

20+ [(Name, PTerm, Plicity, Maybe Docstring)] -- args: name, ty, implicit, docs

18 PTerm -- function type

21 PTerm -- function type

19 (Maybe Fixity)

22 (Maybe Fixity)

20 deriving Show

23 deriving Show

@@ -22,39 +25,41 @@ data FunDoc = FD Name String

22data Docs = FunDoc FunDoc

25data Docs = FunDoc FunDoc

23 | DataDoc FunDoc -- type constructor docs

26 | DataDoc FunDoc -- type constructor docs

24 [FunDoc] -- data constructor docs

27 [FunDoc] -- data constructor docs

25− | ClassDoc Name String -- class docs

28+ | ClassDoc Name Docstring -- class docs

26 [FunDoc] -- method docs

29 [FunDoc] -- method docs

27 deriving Show

30 deriving Show

28

31

29−showDoc "" = empty

32+showDoc d | nullDocstring d = empty

30−showDoc x = text " -- " <> text x

33+ | otherwise = text " -- " <> renderDocstring d

31

34

32pprintFD :: Bool -> FunDoc -> Doc OutputAnnotation

35pprintFD :: Bool -> FunDoc -> Doc OutputAnnotation

33pprintFD imp (FD n doc args ty f)

36pprintFD imp (FD n doc args ty f)

34− = nest 4 (prettyName imp [] n <+> colon <+> prettyImp imp ty <$> showDoc doc <$>

37+ = nest 4 (prettyName imp [] n <+> colon <+>

38+ pprintPTerm imp [] [ n | (n@(UN n'),_,_,_) <- args

39+ , not (T.isPrefixOf (T.pack "__") n') ] ty <$>

40+ renderDocstring doc <$>

35 maybe empty (\f -> text (show f) <> line) f <>

41 maybe empty (\f -> text (show f) <> line) f <>

36 let argshow = showArgs args [] in

42 let argshow = showArgs args [] in

37 if not (null argshow)

43 if not (null argshow)

38 then nest 4 $ text "Arguments:" <$> vsep argshow

44 then nest 4 $ text "Arguments:" <$> vsep argshow

39 else empty)

45 else empty)

40

46

41− where showArgs ((n, ty, Exp {}, d):args) bnd

47+ where showArgs ((n, ty, Exp {}, Just d):args) bnd

42 = bindingOf n False <+> colon <+>

48 = bindingOf n False <+> colon <+>

43− pprintPTerm imp bnd ty <>

49+ pprintPTerm imp bnd [] ty <>

44− showDoc (maybe "" id d) <> line

50+ showDoc d <> line

45 :

51 :

46 showArgs args ((n, False):bnd)

52 showArgs args ((n, False):bnd)

47− showArgs ((n, ty, Constraint {}, d):args) bnd

53+ showArgs ((n, ty, Constraint {}, Just d):args) bnd

48 = text "Class constraint" <+>

54 = text "Class constraint" <+>

49− pprintPTerm imp bnd ty <> showDoc (maybe "" id d) <> line

55+ pprintPTerm imp bnd [] ty <> showDoc d <> line

50 :

56 :

51 showArgs args ((n, True):bnd)

57 showArgs args ((n, True):bnd)

52− showArgs ((n, ty, Imp {}, d):args) bnd

58+ showArgs ((n, ty, Imp {}, Just d):args) bnd

53− | not (null doc)

54 = text "(implicit)" <+>

59 = text "(implicit)" <+>

55 bindingOf n True <+> colon <+>

60 bindingOf n True <+> colon <+>

56− pprintPTerm imp bnd ty <>

61+ pprintPTerm imp bnd [] ty <>

57− showDoc (maybe "" id d) <> line

62+ showDoc d <> line

58 :

63 :

59 showArgs args ((n, True):bnd)

64 showArgs args ((n, True):bnd)

60 showArgs ((n, _, _, _):args) bnd = showArgs args ((n, True):bnd)

65 showArgs ((n, _, _, _):args) bnd = showArgs args ((n, True):bnd)

@@ -93,7 +98,7 @@ docClass n ci

93 = do i <- getIState

98 = do i <- getIState

94 let docstr = case lookupCtxt n (idris_docstrings i) of

99 let docstr = case lookupCtxt n (idris_docstrings i) of

95 [str] -> fst str

100 [str] -> fst str

96− _ -> ""

101+ _ -> emptyDocstring

97 mdocs <- mapM docFun (map fst (class_methods ci))

102 mdocs <- mapM docFun (map fst (class_methods ci))

98 return (ClassDoc n docstr mdocs)

103 return (ClassDoc n docstr mdocs)

99

104

@@ -102,7 +107,7 @@ docFun n

102 = do i <- getIState

107 = do i <- getIState

103 let (docstr, argDocs) = case lookupCtxt n (idris_docstrings i) of

108 let (docstr, argDocs) = case lookupCtxt n (idris_docstrings i) of

104 [d] -> d

109 [d] -> d

105− _ -> ("", [])

110+ _ -> noDocs

106 let ty = delabTy i n

111 let ty = delabTy i n

107 let args = getPArgNames ty argDocs

112 let args = getPArgNames ty argDocs

108 let infixes = idris_infixes i

113 let infixes = idris_infixes i

@@ -116,7 +121,7 @@ docFun n

116 funName (UN n) = str n

121 funName (UN n) = str n

117 funName (NS n _) = funName n

122 funName (NS n _) = funName n

118

123

119−getPArgNames :: PTerm -> [(Name, String)] -> [(Name, PTerm, Plicity, Maybe String)]

124+getPArgNames :: PTerm -> [(Name, Docstring)] -> [(Name, PTerm, Plicity, Maybe Docstring)]

120getPArgNames (PPi plicity name ty body) ds =

125getPArgNames (PPi plicity name ty body) ds =

121 (name, ty, plicity, lookup name ds) : getPArgNames body ds

126 (name, ty, plicity, lookup name ds) : getPArgNames body ds

122getPArgNames _ _ = []

127getPArgNames _ _ = []

src/Idris/Docstrings.hsnew file+119

@@ -0,0 +1,119 @@

1+-- | Wrapper around Markdown library

2+module Idris.Docstrings (

3+ Docstring, parseDocstring, renderDocstring, emptyDocstring, nullDocstring, noDocs,

4+ overview, containsText

5+ ) where

6+

7+import qualified Cheapskate as C

8+import qualified Cheapskate.Types as CT

9+

10+import Util.Pretty

11+

12+import Idris.Core.TT (OutputAnnotation(..), TextFormatting(..), Name)

13+

14+import qualified Data.Text as T

15+import qualified Data.Foldable as F

16+import qualified Data.Sequence as S

17+

18+-- | Representation of Idris's inline documentation

19+type Docstring = CT.Doc

20+

21+-- | Construct a docstring from a Text that contains Markdown-formatted docs

22+parseDocstring :: T.Text -> CT.Doc

23+parseDocstring = C.markdown options

24+

25+

26+options = CT.Options { CT.sanitize = True

27+ , CT.allowRawHtml = False

28+ , CT.preserveHardBreaks = True

29+ , CT.debug = False

30+ }

31+

32+-- | Convert a docstring to be shown by the pretty-printer

33+renderDocstring :: Docstring -> Doc OutputAnnotation

34+renderDocstring (CT.Doc _ blocks) = renderBlocks blocks

35+

36+-- | Construct a docstring consisting of the first block-level element of the

37+-- argument docstring, for use in summaries.

38+overview :: Docstring -> Docstring

39+overview (CT.Doc opts blocks) = CT.Doc opts (S.take 1 blocks)

40+

41+renderBlocks :: CT.Blocks -> Doc OutputAnnotation

42+renderBlocks blocks | S.length blocks > 1 = F.foldr1 (\b1 b2 -> b1 <> line <> line <> b2) $

43+ fmap renderBlock blocks

44+ | S.length blocks == 1 = renderBlock (S.index blocks 0)

45+ | otherwise = empty

46+

47+renderBlock :: CT.Block -> Doc OutputAnnotation

48+renderBlock (CT.Para inlines) = renderInlines inlines

49+renderBlock (CT.Header lvl inlines) = renderInlines inlines <+> parens (text (show lvl))

50+renderBlock (CT.Blockquote blocks) = indent 8 $ renderBlocks blocks

51+renderBlock (CT.List b ty blockss) = renderList b ty blockss

52+renderBlock (CT.CodeBlock attr src) = indent 8 $ text (T.unpack src)

53+renderBlock (CT.HtmlBlock txt) = text "<html block>" -- TODO

54+renderBlock CT.HRule = text "----------------------"

55+

56+renderList :: Bool -> CT.ListType -> [CT.Blocks] -> Doc OutputAnnotation

57+renderList b (CT.Bullet c) blockss = vsep $ map (hang 4 . (char c <+>) . renderBlocks) blockss

58+renderList b (CT.Numbered nw i) blockss =

59+ vsep $

60+ zipWith3 (\n p txt -> hang 4 $ text (show n) <> p <+> txt)

61+ [i..] (repeat punc) (map renderBlocks blockss)

62+ where punc = case nw of

63+ CT.PeriodFollowing -> char '.'

64+ CT.ParenFollowing -> char '('

65+

66+renderInlines :: CT.Inlines -> Doc OutputAnnotation

67+renderInlines = F.foldr (<>) empty . fmap renderInline

68+

69+renderInline :: CT.Inline -> Doc OutputAnnotation

70+renderInline (CT.Str s) = text $ T.unpack s

71+renderInline CT.Space = space

72+renderInline CT.SoftBreak = softline

73+renderInline CT.LineBreak = line

74+renderInline (CT.Emph txt) = annotate (AnnTextFmt ItalicText) $ renderInlines txt -- TODO

75+renderInline (CT.Strong txt) = annotate (AnnTextFmt BoldText) $ renderInlines txt -- TODO

76+renderInline (CT.Code txt) = text $ T.unpack txt

77+renderInline (CT.Link body url title) = annotate (AnnTextFmt UnderlineText) (renderInlines body) <+>

78+ parens (text $ T.unpack url)

79+renderInline (CT.Image body url title) = text "<image>" -- TODO

80+renderInline (CT.Entity a) = text $ "<entity " ++ T.unpack a ++ ">" -- TODO

81+renderInline (CT.RawHtml txt) = text "<html content>" --TODO

82+

83+-- | The empty docstring

84+emptyDocstring :: Docstring

85+emptyDocstring = CT.Doc options S.empty

86+

87+-- | Check whether a docstring is emtpy

88+nullDocstring :: Docstring -> Bool

89+nullDocstring (CT.Doc _ blocks) = S.null blocks

90+

91+-- | Empty documentation for a definition

92+noDocs :: (Docstring, [(Name, Docstring)])

93+noDocs = (emptyDocstring, [])

94+

95+-- | Does a string occur in the docstring?

96+containsText :: T.Text -> Docstring -> Bool

97+containsText str (CT.Doc _ blocks) = F.any (blockContains (T.toLower str)) blocks

98+ -- blockContains and inlineContains should always be called with a lower-case search string

99+ where blockContains :: T.Text -> CT.Block -> Bool

100+ blockContains str (CT.Para inlines) = F.any (inlineContains str) inlines

101+ blockContains str (CT.Header lvl inlines) = F.any (inlineContains str) inlines

102+ blockContains str (CT.Blockquote blocks) = F.any (blockContains str) blocks

103+ blockContains str (CT.List b ty blockss) = F.any (F.any (blockContains str)) blockss

104+ blockContains str (CT.CodeBlock attr src) = T.isInfixOf str (T.toLower src)

105+ blockContains str (CT.HtmlBlock txt) = False -- TODO

106+ blockContains str CT.HRule = False

107+

108+ inlineContains :: T.Text -> CT.Inline -> Bool

109+ inlineContains str (CT.Str s) = T.isInfixOf str (T.toLower s)

110+ inlineContains str CT.Space = False

111+ inlineContains str CT.SoftBreak = False

112+ inlineContains str CT.LineBreak = False

113+ inlineContains str (CT.Emph txt) = F.any (inlineContains str) txt

114+ inlineContains str (CT.Strong txt) = F.any (inlineContains str) txt

115+ inlineContains str (CT.Code txt) = T.isInfixOf str (T.toLower txt)

116+ inlineContains str (CT.Link body url title) = F.any (inlineContains str) body

117+ inlineContains str (CT.Image body url title) = False

118+ inlineContains str (CT.Entity a) = False

119+ inlineContains str (CT.RawHtml txt) = T.isInfixOf str (T.toLower txt)

src/Idris/ElabDecls.hs+61−54

@@ -26,6 +26,8 @@ import Idris.Core.Execute

26import Idris.Core.Typecheck

27import Idris.Core.CaseTree

28

29+import Idris.Docstrings

30+

29import Control.DeepSeq

31import Control.DeepSeq

30import Control.Monad

32import Control.Monad

31import Control.Monad.State.Strict as State

33import Control.Monad.State.Strict as State

@@ -63,12 +65,12 @@ checkAddDef add toplvl fc ((n, (i, top, t)) : ns)

63-- return (n, (i, top, t'))) ns

65-- return (n, (i, top, t'))) ns

64

66

65-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

67-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

66−elabType :: ElabInfo -> SyntaxInfo -> String -> [(Name, String)] ->

68+elabType :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->

67 FC -> FnOpts -> Name -> PTerm -> Idris Type

69 FC -> FnOpts -> Name -> PTerm -> Idris Type

68elabType = elabType' False

70elabType = elabType' False

69

71

70elabType' :: Bool -> -- normalise it

72elabType' :: Bool -> -- normalise it

71− ElabInfo -> SyntaxInfo -> String -> [(Name, String)] ->

73+ ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->

72 FC -> FnOpts -> Name -> PTerm -> Idris Type

74 FC -> FnOpts -> Name -> PTerm -> Idris Type

73elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in

75elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in

74 n = liftname info n_in in -}

76 n = liftname info n_in in -}

@@ -89,8 +91,7 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

89 -- if the type is not complete, note that we'll need to infer

91 -- if the type is not complete, note that we'll need to infer

90 -- things later (for solving metavariables)

92 -- things later (for solving metavariables)

91 when (not (null ds)) $ addTyInferred n

93 when (not (null ds)) $ addTyInferred n

92−-- let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds

94+

93−-- addDeferred ds'

94 mapM_ (elabCaseBlock info opts) is

95 mapM_ (elabCaseBlock info opts) is

95 ctxt <- getContext

96 ctxt <- getContext

96 logLvl 5 $ "Rechecking"

97 logLvl 5 $ "Rechecking"

@@ -106,8 +107,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

106 -- Add normalised type to internals

107 -- Add normalised type to internals

107 rep <- useREPL

108 rep <- useREPL

108 when rep $ do

109 when rep $ do

109− addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

110+ addInternalApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')) -- TODO: Should use span instead of line and filename?

110− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))

111+ addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')))

111

112

112 let (t, _) = unApply (getRetTy nty')

113 let (t, _) = unApply (getRetTy nty')

113 let corec = case t of

114 let corec = case t of

@@ -115,7 +116,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

115 [TI _ True _ _] -> True

116 [TI _ True _ _] -> True

116 _ -> False

117 _ -> False

118 _ -> False

119+ -- Productivity checking now via checking for guarded 'Delay'

118− let opts' = if corec then (Coinductive : opts) else opts

120+ let opts' = opts -- if corec then (Coinductive : opts) else opts

119 let usety = if norm then nty' else nty

121 let usety = if norm then nty' else nty

120 ds <- checkDef fc [(n, (-1, Nothing, usety))]

122 ds <- checkDef fc [(n, (-1, Nothing, usety))]

121 addIBC (IBCDef n)

123 addIBC (IBCDef n)

@@ -126,8 +128,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

126 addDocStr n doc argDocs

128 addDocStr n doc argDocs

127 addIBC (IBCDoc n)

129 addIBC (IBCDoc n)

128 addIBC (IBCFlags n opts')

130 addIBC (IBCFlags n opts')

129− when (Implicit `elem` opts) $ do addCoercion n

131+ when (Implicit `elem` opts') $ do addCoercion n

130− addIBC (IBCCoercion n)

132+ addIBC (IBCCoercion n)

131 -- If the function is declared as an error handler and the language

133 -- If the function is declared as an error handler and the language

132 -- extension is enabled, then add it to the list of error handlers.

134 -- extension is enabled, then add it to the list of error handlers.

133 errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState

135 errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState

@@ -142,8 +144,6 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

142 addIBC (IBCErrorHandler n)

144 addIBC (IBCErrorHandler n)

143 else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

145 else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

144 else ifail "Error handlers can only be defined when the ErrorReflection language extension is enabled."

146 else ifail "Error handlers can only be defined when the ErrorReflection language extension is enabled."

145− when corec $ do setAccessibility n Frozen

146− addIBC (IBCAccess n Frozen)

147 return usety

148 where

149 -- for making an internalapp, we only want the explicit ones, and don't

@@ -171,7 +171,7 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

171 tyIsHandler _ = False

172

173

174−elabPostulate :: ElabInfo -> SyntaxInfo -> String ->

174+elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring ->

175 FC -> FnOpts -> Name -> PTerm -> Idris ()

176elabPostulate info syn doc fc opts n ty

177 = do elabType info syn doc [] fc opts n ty

@@ -195,7 +195,7 @@ elabPostulate info syn doc fc opts n ty

195 -- remove it from the deferred definitions list

196 solveDeferred n

197

198−elabData :: ElabInfo -> SyntaxInfo -> String -> [(Name, String)] -> FC -> DataOpts -> PData -> Idris ()

198+elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris ()

199elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

200 = do let codata = Codata `elem` opts

201 iLOG (show (fc, doc))

@@ -253,12 +253,13 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

253 let metainf = DataMI params

254 addIBC (IBCMetaInformation n metainf)

255 -- TMP HACK! Make this a data option

256− when (n /= sUN "Lazy") $ collapseCons n cons

256+ when (n /= sUN "Lazy'") $ collapseCons n cons

257 updateContext (addDatatype (Data n ttag cty cons))

258 updateContext (setMetaInformation n metainf)

259 mapM_ (checkPositive n) cons

260+ if DefaultEliminator `elem` opts

260− if DefaultEliminator `elem` opts then evalStateT (elabEliminator params n t dcons info) Map.empty

261+ then evalStateT (elabEliminator params n t dcons info) Map.empty

261− else return ()

262+ else return ()

262 where

263 where

263 checkDefinedAs fc n t ctxt

264 checkDefinedAs fc n t ctxt

264 = case lookupDef n ctxt of

265 = case lookupDef n ctxt of

@@ -322,7 +323,7 @@ type EliminatorState = StateT (Map.Map String Int) Idris

322

323

323-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

324-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

324elabEliminator :: [Int] -> Name -> PTerm ->

325elabEliminator :: [Int] -> Name -> PTerm ->

325− [(String, [(Name, String)], Name, PTerm, FC, [Name])] ->

326+ [(Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])] ->

326 ElabInfo -> EliminatorState ()

327 ElabInfo -> EliminatorState ()

327elabEliminator paramPos n ty cons info = do

328elabEliminator paramPos n ty cons info = do

328 elimLog $ "Elaborating eliminator"

329 elimLog $ "Elaborating eliminator"

@@ -339,7 +340,7 @@ elabEliminator paramPos n ty cons info = do

339 let motiveConstr = [(motiveName, expl, motive)]

340 let motiveConstr = [(motiveName, expl, motive)]

340 let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))

341 let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))

341 let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC n) scrutineeIdxs) (PRef elimFC scrutineeName))

342 let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC n) scrutineeIdxs) (PRef elimFC scrutineeName))

342− let eliminatorTyDecl = PTy (show n) [] defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy

343+ let eliminatorTyDecl = PTy (parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy

343 let clauseConsElimArgs = map getPiName consTerms

344 let clauseConsElimArgs = map getPiName consTerms

344 let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs

345 let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs

345 let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'

346 let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'

@@ -488,7 +489,7 @@ elabEliminator paramPos n ty cons info = do

488 splitArgPms _ = ([],[])

489 splitArgPms _ = ([],[])

489

490

491

491− implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

492+ implicitIndexes :: (Docstring, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

492 implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

493 implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

493 i <- State.lift getIState

494 i <- State.lift getIState

494 implargs' <- case lookupCtxt cnm (idris_implicits i) of

495 implargs' <- case lookupCtxt cnm (idris_implicits i) of

@@ -503,7 +504,7 @@ elabEliminator paramPos n ty cons info = do

503 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

504 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

504 _ -> return implargs

505 _ -> return implargs

505

506

506− extractConsTerm :: (String, [(Name, String)], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

507+ extractConsTerm :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

507 extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do

508 extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do

508 let cons' = replaceParams paramPos generalParameters ty

509 let cons' = replaceParams paramPos generalParameters ty

509 let (args, resTy) = splitPi cons'

510 let (args, resTy) = splitPi cons'

@@ -539,7 +540,7 @@ elabEliminator paramPos n ty cons info = do

539 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

540 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

540 convertImplPi _ = Nothing

541 convertImplPi _ = Nothing

541

542

542− generateEliminatorClauses :: (String, [(Name, String)], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

543+ generateEliminatorClauses :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

543 generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

544 generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

544 let cons' = replaceParams paramPos generalParameters ty

545 let cons' = replaceParams paramPos generalParameters ty

545 let (args, resTy) = splitPi cons'

546 let (args, resTy) = splitPi cons'

@@ -561,7 +562,7 @@ elabEliminator paramPos n ty cons info = do

561

562

562elabPrims :: Idris ()

563elabPrims :: Idris ()

563elabPrims = do mapM_ (elabDecl EAll toplevel)

564elabPrims = do mapM_ (elabDecl EAll toplevel)

564− (map (\(opt, decl) -> PData "" [] defaultSyntax (fileFC "builtin") opt decl)

565+ (map (\(opt, decl) -> PData emptyDocstring [] defaultSyntax (fileFC "builtin") opt decl)

565 (zip

566 (zip

566 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

567 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

567 [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

568 [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

@@ -665,7 +666,7 @@ elabProvider info syn fc what n ty tm

665 Provide tm

666 Provide tm

666 | what `elem` [ProvTerm, ProvAny] ->

667 | what `elem` [ProvTerm, ProvAny] ->

667 do -- Finally add a top-level definition of the provided term

668 do -- Finally add a top-level definition of the provided term

668− elabType info syn "" [] fc [] n ty

669+ elabType info syn emptyDocstring [] fc [] n ty

669 elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc n) []) [] (delab i tm) []] -- ipapp

670 elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc n) []) [] (delab i tm) []] -- ipapp

670 logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

671 logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

671 | otherwise ->

672 | otherwise ->

@@ -673,7 +674,7 @@ elabProvider info syn fc what n ty tm

673 Postulate

674 Postulate

674 | what `elem` [ProvPostulate, ProvAny] ->

675 | what `elem` [ProvPostulate, ProvAny] ->

675 do -- Add the postulate

676 do -- Add the postulate

676− elabPostulate info syn "Provided postulate" fc [] n ty

677+ elabPostulate info syn (parseDocstring $ T.pack "Provided postulate") fc [] n ty

677 logLvl 3 $ "Elaborated provided postulate " ++ show n

678 logLvl 3 $ "Elaborated provided postulate " ++ show n

678 | otherwise ->

679 | otherwise ->

679 ierror . Msg $ "Attempted to provide a postulate where a term was expected."

680 ierror . Msg $ "Attempted to provide a postulate where a term was expected."

@@ -690,7 +691,6 @@ elabProvider info syn fc what n ty tm

690 , prov == txt "Provider" && provs == txt "Providers" = True

691 , prov == txt "Provider" && provs == txt "Providers" = True

691 isProviderOf _ _ = False

692 isProviderOf _ _ = False

692

693

693−-- | Elaborate a type provider

694elabTransform :: ElabInfo -> FC -> Bool -> PTerm -> PTerm -> Idris ()

695elabTransform info fc safe lhs_in rhs_in

696 = do ctxt <- getContext

@@ -724,8 +724,8 @@ elabTransform info fc safe lhs_in rhs_in

724 addIBC (IBCTrans (clhs_tm, crhs_tm))

725

726

727−elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

727+elabRecord :: ElabInfo -> SyntaxInfo -> Docstring -> FC -> Name ->

728− PTerm -> String -> Name -> PTerm -> Idris ()

728+ PTerm -> Docstring -> Name -> PTerm -> Idris ()

729elabRecord info syn doc fc tyn ty cdoc cn cty

730 = do elabData info syn doc [] fc [] (PDatadecl tyn ty [(cdoc, [], cn, cty, fc, [])])

731 cty' <- implicit syn cn cty

@@ -797,7 +797,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

797

798 mkProj recty substs cimp ((pn_in, pty), pos)

799 = do let pn = expandNS syn pn_in

800− let pfnTy = PTy "" [] defaultSyntax fc [] pn

800+ let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] pn

801 (PPi expl rec recty

802 (substMatches substs pty))

803 let pls = repeat Placeholder

@@ -818,7 +818,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

818 let valname = sMN 0 "updateval"

819 let pt = k (PPi expl pn pty

820 (PPi expl rec recty recty))

821− let pfnTy = PTy "" [] defaultSyntax fc [] setname pt

821+ let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] setname pt

822 let pls = map (\x -> PRef fc (sMN x "field")) [0..num-1]

823 let lhsArgs = pls

824 let rhsArgs = take pos pls ++ (PRef fc valname) :

@@ -834,7 +834,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

834 return (pn, pfnTy, PClauses fc [] setname [pclause])

835

836elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

837− (String, [(Name, String)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)

837+ (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)

838elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

839 = do checkUndefined fc n

840 ctxt <- getContext

@@ -873,12 +873,15 @@ elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

873

874 mkLazy (PPi pl n ty sc)

875 = let ty' = if getTyName ty

876− then PApp fc (PRef fc (sUN "Lazy")) [pexp ty] -- ipapp

876+ then PApp fc (PRef fc (sUN "Lazy'")) -- ipapp

877+ [pexp (PRef fc (sUN "LazyCodata")),

878+ pexp ty]

877 else ty in

879 else ty in

878 PPi pl n ty' (mkLazy sc)

880 PPi pl n ty' (mkLazy sc)

879 mkLazy t = t

881 mkLazy t = t

880

882

881 getTyName (PApp _ (PRef _ n) _) = n == nsroot tn

883 getTyName (PApp _ (PRef _ n) _) = n == nsroot tn

884+ getTyName (PRef _ n) = n == nsroot tn

882 getTyName _ = False

885 getTyName _ = False

883

886

884

887

@@ -988,7 +991,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

988 simpleCase tcase False reflect CompileTime fc atys pdef

991 simpleCase tcase False reflect CompileTime fc atys pdef

989 cov <- coverage

992 cov <- coverage

990 pmissing <-

993 pmissing <-

991− if cov

994+ if cov && not (hasDefault cs)

992 then do missing <- genClauses fc n (map getLHS pdef) cs

995 then do missing <- genClauses fc n (map getLHS pdef) cs

993 -- missing <- genMissing n scargs sc

996 -- missing <- genMissing n scargs sc

994 missing' <- filterM (checkPossible info fc True n) missing

997 missing' <- filterM (checkPossible info fc True n) missing

@@ -1017,6 +1020,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1017 let tot = if pcover || AssertTotal `elem` opts

1020 let tot = if pcover || AssertTotal `elem` opts

1018 then Unchecked -- finish checking later

1021 then Unchecked -- finish checking later

1019 else Partial NotCovering -- already know it's not total

1022 else Partial NotCovering -- already know it's not total

1023+

1020 -- case lookupCtxt (namespace info) n (idris_flags ist) of

1024 -- case lookupCtxt (namespace info) n (idris_flags ist) of

1021 -- [fs] -> if TotalFn `elem` fs

1025 -- [fs] -> if TotalFn `elem` fs

1022 -- then case tot of

1026 -- then case tot of

@@ -1072,7 +1076,10 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1072 return ()

1076 return ()

1073 -- addIBC (IBCTotal n tot)

1077 -- addIBC (IBCTotal n tot)

1074 [] -> return ()

1078 [] -> return ()

1075− return ()

1079+ -- Check it's covering, if 'covering' option is used. Chase

1080+ -- all called functions, and fail if any of them are also

1081+ -- 'Partial NotCovering'

1082+ when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n

1076 where

1083 where

1077 noMatch i cs tm = all (\x -> case matchClause i (delab' i x True True) tm of

1084 noMatch i cs tm = all (\x -> case matchClause i (delab' i x True True) tm of

1078 Right _ -> False

1085 Right _ -> False

@@ -1092,6 +1099,10 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1092 depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)

1099 depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)

1093 depat acc x = (acc, x)

1100 depat acc x = (acc, x)

1094

1101

1102+ hasDefault cs | (PClause _ _ last _ _ _ :_) <- reverse cs

1103+ , (PApp fn s args) <- last = all ((==Placeholder) . getTm) args

1104+ hasDefault _ = False

1105+

1095 getLHS (_, l, _) = l

1106 getLHS (_, l, _) = l

1096

1107

1097 simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x,

1108 simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x,

@@ -1162,7 +1173,7 @@ elabPE info fc caller r =

1162 (map (\ (lhs, rhs) ->

1173 (map (\ (lhs, rhs) ->

1163 (showTmImpls lhs ++ " = " ++

1174 (showTmImpls lhs ++ " = " ++

1164 showTmImpls rhs)) pats)

1175 showTmImpls rhs)) pats)

1165− elabType info defaultSyntax "" [] fc opts newnm specTy

1176+ elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy

1166 let def = map (\ (lhs, rhs) -> PClause fc newnm lhs [] rhs []) pats

1177 let def = map (\ (lhs, rhs) -> PClause fc newnm lhs [] rhs []) pats

1167 elabClauses info fc opts newnm def

1178 elabClauses info fc opts newnm def

1168 logLvl 2 $ "Specialised " ++ show newnm)

1179 logLvl 2 $ "Specialised " ++ show newnm)

@@ -1262,10 +1273,6 @@ checkPossible info fc tcgen fname lhs_in

1262 case recheck ctxt [] (forget lhs_tm) lhs_tm of

1273 case recheck ctxt [] (forget lhs_tm) lhs_tm of

1263 OK _ -> return True

1274 OK _ -> return True

1264 err -> return False

1275 err -> return False

1265−

1266−-- b <- inferredDiff fc (delab' i lhs_tm True) lhs

1267−-- return (not b) -- then return (Just lhs_tm) else return Nothing

1268−-- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)

1269 Error err -> if tcgen then return False

1276 Error err -> if tcgen then return False

1270 else return (impossibleError err)

1277 else return (impossibleError err)

1271 where impossibleError (CantUnify _ topx topy e _ _)

1278 where impossibleError (CantUnify _ topx topy e _ _)

@@ -1273,6 +1280,7 @@ checkPossible info fc tcgen fname lhs_in

1273 impossibleError (CantConvert _ _ _) = False

1280 impossibleError (CantConvert _ _ _) = False

1274 impossibleError (At _ e) = impossibleError e

1281 impossibleError (At _ e) = impossibleError e

1275 impossibleError (Elaborating _ _ e) = impossibleError e

1282 impossibleError (Elaborating _ _ e) = impossibleError e

1283+ impossibleError (ElaboratingArg _ _ _ e) = impossibleError e

1276 impossibleError _ = True

1284 impossibleError _ = True

1277

1285

1278 sameFam topx topy

1286 sameFam topx topy

@@ -1382,7 +1390,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1382 inj <- get_inj

1390 inj <- get_inj

1383 return (res, probs, inj))

1391 return (res, probs, inj))

1384

1392

1385− when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_) -> (x,y)) probs)

1393+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)

1386

1394

1387 let lhs_tm = orderPats (getInferTerm lhs')

1395 let lhs_tm = orderPats (getInferTerm lhs')

1388 let lhs_ty = getInferType lhs'

1396 let lhs_ty = getInferType lhs'

@@ -1401,8 +1409,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1401

1409

1402 rep <- useREPL

1410 rep <- useREPL

1403 when rep $ do

1411 when rep $ do

1404− addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1412+ addInternalApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs) -- TODO: Should use span instead of line and filename?

1405− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

1413+ addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs))

1406

1414

1407 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

1415 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

1408 -- Elaborate where block

1416 -- Elaborate where block

@@ -1446,14 +1454,16 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1446 probs <- get_probs

1454 probs <- get_probs

1447 return (tm, ds, is, probs))

1455 return (tm, ds, is, probs))

1448

1456

1449− when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_) -> (x,y)) probs)

1457+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)

1450

1458

1451 logLvl 5 "DONE CHECK"

1459 logLvl 5 "DONE CHECK"

1452 logLvl 2 $ "---> " ++ show rhs'

1460 logLvl 2 $ "---> " ++ show rhs'

1453− when (not (null defer)) $ iLOG $ "DEFERRED " ++ show (map fst defer)

1461+ when (not (null defer)) $ iLOG $ "DEFERRED " ++

1462+ show (map (\ (n, (_,_,t)) -> (n, t)) defer)

1454 def' <- checkDef fc defer

1463 def' <- checkDef fc defer

1455 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

1464 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

1456 addDeferred def''

1465 addDeferred def''

1466+ mapM_ (\(n, _) -> addIBC (IBCDef n)) def''

1457

1467

1458 when (not (null def')) $ do

1468 when (not (null def')) $ do

1459 mapM_ defer_totcheck (map (\x -> (fc, fst x)) def'')

1469 mapM_ defer_totcheck (map (\x -> (fc, fst x)) def'')

@@ -1721,7 +1731,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1721

1731

1722data MArgTy = IA | EA | CA deriving Show

1732data MArgTy = IA | EA | CA deriving Show

1723

1733

1724−elabClass :: ElabInfo -> SyntaxInfo -> String ->

1734+elabClass :: ElabInfo -> SyntaxInfo -> Docstring ->

1725 FC -> [PTerm] ->

1735 FC -> [PTerm] ->

1726 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

1736 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

1727elabClass info syn doc fc constraints tn ps ds

1737elabClass info syn doc fc constraints tn ps ds

@@ -1748,7 +1758,7 @@ elabClass info syn doc fc constraints tn ps ds

1748 let cty = impbind ps $ conbind constraints

1758 let cty = impbind ps $ conbind constraints

1749 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

1759 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

1750 constraint

1760 constraint

1751− let cons = [("", [], cn, cty, fc, [])]

1761+ let cons = [(emptyDocstring, [], cn, cty, fc, [])]

1752 let ddecl = PDatadecl tn tty cons

1762 let ddecl = PDatadecl tn tty cons

1753 logLvl 5 $ "Class data " ++ show (showDImp True ddecl)

1763 logLvl 5 $ "Class data " ++ show (showDImp True ddecl)

1754 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc [] fc [] ddecl

1764 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc [] fc [] ddecl

@@ -1803,7 +1813,7 @@ elabClass info syn doc fc constraints tn ps ds

1803 case lookup n mtys of

1813 case lookup n mtys of

1804 Just (syn, o, ty) -> do let ty' = insertConstraint c ty

1814 Just (syn, o, ty) -> do let ty' = insertConstraint c ty

1805 let ds = map (decorateid defaultdec)

1815 let ds = map (decorateid defaultdec)

1806− [PTy "" [] syn fc [] n ty',

1816+ [PTy emptyDocstring [] syn fc [] n ty',

1807 PClauses fc (o ++ opts) n cs]

1817 PClauses fc (o ++ opts) n cs]

1808 iLOG (show ds)

1818 iLOG (show ds)

1809 return (n, ((defaultdec n, ds!!1), ds))

1819 return (n, ((defaultdec n, ds!!1), ds))

@@ -1841,7 +1851,7 @@ elabClass info syn doc fc constraints tn ps ds

1841 addInstance False conn' cfn

1851 addInstance False conn' cfn

1842 addIBC (IBCInstance False conn' cfn)

1852 addIBC (IBCInstance False conn' cfn)

1843-- iputStrLn ("Added " ++ show (conn, cfn, ty))

1853-- iputStrLn ("Added " ++ show (conn, cfn, ty))

1844− return [PTy "" [] syn fc [] cfn ty,

1854+ return [PTy emptyDocstring [] syn fc [] cfn ty,

1845 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

1855 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

1846

1856

1847 -- Generate a top level function which looks up a method in a given

1857 -- Generate a top level function which looks up a method in a given

@@ -1905,7 +1915,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

1905 let constraint = PApp fc (PRef fc n) (map pexp ps) -- ipapp

1915 let constraint = PApp fc (PRef fc n) (map pexp ps) -- ipapp

1906 let iname = mkiname n ps expn

1916 let iname = mkiname n ps expn

1907 when (what /= EDefns) $ do

1917 when (what /= EDefns) $ do

1908− nty <- elabType' True info syn "" [] fc [] iname t

1918+ nty <- elabType' True info syn emptyDocstring [] fc [] iname t

1909 -- if the instance type matches any of the instances we have already,

1919 -- if the instance type matches any of the instances we have already,

1910 -- and it's not a named instance, then it's overlapping, so report an error

1920 -- and it's not a named instance, then it's overlapping, so report an error

1911 case expn of

1921 case expn of

@@ -1970,10 +1980,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

1970 iLOG (show idecls)

1980 iLOG (show idecls)

1971 mapM_ (elabDecl EAll info) idecls

1981 mapM_ (elabDecl EAll info) idecls

1972 addIBC (IBCInstance intInst n iname)

1982 addIBC (IBCInstance intInst n iname)

1973−-- -- for each constraint, build a top level function to chase it

1983+

1974−-- logLvl 5 $ "Building functions"

1975−-- fns <- mapM (cfun (instanceName ci) constraint syn idecls) cs

1976−-- mapM_ (elabDecl EAll info) (concat fns)

1977 where

1984 where

1978 intInst = case ps of

1985 intInst = case ps of

1979 [PConstant (AType (ATInt ITNative))] -> True

1986 [PConstant (AType (ATInt ITNative))] -> True

@@ -2057,7 +2064,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

2057 decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

2064 decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

2058 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

2065 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

2059

2066

2060− mkTyDecl (n, op, t, _) = PTy "" [] syn fc op n t

2067+ mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t

2061

2068

2062 conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

2069 conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

2063 conbind [] x = x

2070 conbind [] x = x

@@ -2304,7 +2311,7 @@ inferredDiff fc inf user =

2304-- | Check a PTerm against documentation and ensure that every documented

2311-- | Check a PTerm against documentation and ensure that every documented

2305-- argument actually exists. This must be run _after_ implicits have been

2312-- argument actually exists. This must be run _after_ implicits have been

2306-- found, or it will give spurious errors.

2313-- found, or it will give spurious errors.

2307−checkDocs :: FC -> [(Name, String)] -> PTerm -> Idris ()

2314+checkDocs :: FC -> [(Name, Docstring)] -> PTerm -> Idris ()

2308checkDocs fc args tm = cd (Map.fromList args) tm

2315checkDocs fc args tm = cd (Map.fromList args) tm

2309 where cd as (PPi _ n _ sc) = cd (Map.delete n as) sc

2316 where cd as (PPi _ n _ sc) = cd (Map.delete n as) sc

2310 cd as _ | Map.null as = return ()

2317 cd as _ | Map.null as = return ()

src/Idris/ElabTerm.hs+137−119

@@ -13,13 +13,14 @@ import Idris.Core.TT

13import Idris.Core.Evaluate

14import Idris.Core.Unify

15import Idris.Core.Typecheck (check)

16+import Idris.ErrReverse (errReverse)

16

17

17import Control.Applicative ((<$>))

18import Control.Applicative ((<$>))

18import Control.Monad

19import Control.Monad

19import Control.Monad.State.Strict

20import Control.Monad.State.Strict

20import Data.List

21import Data.List

21import qualified Data.Map as M

22import qualified Data.Map as M

22−import Data.Maybe (mapMaybe)

23+import Data.Maybe (mapMaybe, fromMaybe)

23import qualified Data.Set as S

24import qualified Data.Set as S

24import qualified Data.Text as T

25import qualified Data.Text as T

25

26

@@ -72,13 +73,16 @@ build ist info pattern opts fn tm

72 tm <- get_term

73 tm <- get_term

73 ctxt <- get_context

74 ctxt <- get_context

74 probs <- get_probs

75 probs <- get_probs

76+ u <- getUnifyLog

75

77

78+ when (not pattern) $

79+ traceWhen u ("Remaining problems:\n" ++ show probs) $

76− when (not pattern) $ do matchProblems True; unifyProblems

80+ do matchProblems True; unifyProblems

77 probs <- get_probs

81 probs <- get_probs

78 case probs of

82 case probs of

79 [] -> return ()

83 [] -> return ()

80− ((_,_,_,e,_):es) -> if inf then return ()

84+ ((_,_,_,e,_,_):es) -> if inf then return ()

81− else lift (Error e)

85+ else lift (Error e)

82 is <- getAux

86 is <- getAux

83 tt <- get_term

87 tt <- get_term

84 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

88 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

@@ -105,8 +109,8 @@ buildTC ist info pattern opts fn tm

105 tm <- get_term

109 tm <- get_term

106 case probs of

110 case probs of

107 [] -> return ()

111 [] -> return ()

108− ((_,_,_,e,_):es) -> if inf then return ()

112+ ((_,_,_,e,_,_):es) -> if inf then return ()

109− else lift (Error e)

113+ else lift (Error e)

110 is <- getAux

114 is <- getAux

111 tt <- get_term

115 tt <- get_term

112 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

116 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

@@ -154,39 +158,42 @@ elab ist info pattern opts fn tm

154

158

155 elabE :: (Bool, Bool, Bool) -> PTerm -> ElabD ()

159 elabE :: (Bool, Bool, Bool) -> PTerm -> ElabD ()

156 elabE ina t =

160 elabE ina t =

157−-- do g <- goal

161+ --do g <- goal

158−-- trace ("Elaborating " ++ show t ++ " : " ++ show g) $

162+ --trace ("Elaborating " ++ show t ++ " : " ++ show g) $

159 do ct <- insertCoerce ina t

163 do ct <- insertCoerce ina t

160 t' <- insertLazy ct

164 t' <- insertLazy ct

161 g <- goal

165 g <- goal

162 tm <- get_term

166 tm <- get_term

163 ps <- get_probs

167 ps <- get_probs

164 hs <- get_holes

168 hs <- get_holes

165−-- trace ("Elaborating " ++ show t' ++ " in " ++ show g

169+ --trace ("Elaborating " ++ show t' ++ " in " ++ show g

166−-- -- ++ "\n" ++ show tm

170+ -- ++ "\n" ++ show tm

167−-- ++ "\nholes " ++ show hs

171+ -- ++ "\nholes " ++ show hs

168−-- ++ "\nproblems " ++ show ps

172+ -- ++ "\nproblems " ++ show ps

169−-- ++ "\n-----------\n") $

173+ -- ++ "\n-----------\n") $

170−-- trace ("ELAB " ++ show t') $

174+ --trace ("ELAB " ++ show t') $

171 let fc = fileFC "Force"

175 let fc = fileFC "Force"

176+ env <- get_env

172− handleError forceErr

177+ handleError (forceErr env)

173 (elab' ina t')

178 (elab' ina t')

174 (elab' ina (PApp fc (PRef fc (sUN "Force")) -- ipapp

179 (elab' ina (PApp fc (PRef fc (sUN "Force")) -- ipapp

180+ [pimp (sUN "t") Placeholder True,

175− [pimp (sUN "a") Placeholder True,

181+ pimp (sUN "a") Placeholder True,

176 pexp ct])) True

182 pexp ct])) True

177

183

178− forceErr (CantUnify _ t t' _ _ _)

184+ forceErr env (CantUnify _ t t' _ _ _)

179− | (P _ (UN ht) _, _) <- unApply t,

185+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

180− ht == txt "Lazy" = True

186+ ht == txt "Lazy'" = True

181− forceErr (CantUnify _ t t' _ _ _)

187+ forceErr env (CantUnify _ t t' _ _ _)

182− | (P _ (UN ht) _, _) <- unApply t',

188+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t'),

183− ht == txt "Lazy" = True

189+ ht == txt "Lazy'" = True

184− forceErr (InfiniteUnify _ t _)

190+ forceErr env (InfiniteUnify _ t _)

185− | (P _ (UN ht) _, _) <- unApply t,

191+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

186− ht == txt "Lazy" = True

192+ ht == txt "Lazy'" = True

187− forceErr (Elaborating _ _ t) = forceErr t

193+ forceErr env (Elaborating _ _ t) = forceErr env t

194+ forceErr env (ElaboratingArg _ _ _ t) = forceErr env t

188− forceErr (At _ t) = forceErr t

195+ forceErr env (At _ t) = forceErr env t

189− forceErr t = False

196+ forceErr env t = False

190

197

191 local f = do e <- get_env

198 local f = do e <- get_env

192 return (f `elem` map fst e)

199 return (f `elem` map fst e)

@@ -458,6 +465,8 @@ elab ist info pattern opts fn tm

458-- trace ("ns is " ++ show ns) $ return ()

465-- trace ("ns is " ++ show ns) $ return ()

459 -- mark any type class arguments as injective

466 -- mark any type class arguments as injective

460 mapM_ checkIfInjective (map snd ns)

467 mapM_ checkIfInjective (map snd ns)

468+ unifyProblems -- try again with the new information,

469+ -- to help with disambiguation

461 -- Sort so that the implicit tactics and alternatives go last

470 -- Sort so that the implicit tactics and alternatives go last

462 let (ns', eargs) = unzip $

471 let (ns', eargs) = unzip $

463 sortBy cmpArg (zip ns args)

472 sortBy cmpArg (zip ns args)

@@ -480,12 +489,21 @@ elab ist info pattern opts fn tm

480 (movelast n)

489 (movelast n)

481 else movelast n)

490 else movelast n)

482 (ivs' \\ ivs)

491 (ivs' \\ ivs)

483− where -- normal < tactic < default tactic

492+ where -- normal < alternatives < lambdas < rewrites < tactic < default tactic

493+ -- reason for lambdas after alternatives is that having

494+ -- the alternative resolved can help with typechecking the lambda

495+ -- or the rewrite. Rewrites/tactics need as much information

496+ -- as possible about the type.

497+ -- FIXME: Better would be to allow alternative resolution to be

498+ -- retried after more information is in.

484 cmpArg (_, x) (_, y)

499 cmpArg (_, x) (_, y)

485 = compare (conDepth 0 (getTm x) + priority x + alt x)

500 = compare (conDepth 0 (getTm x) + priority x + alt x)

486 (conDepth 0 (getTm y) + priority y + alt y)

501 (conDepth 0 (getTm y) + priority y + alt y)

487 where alt t = case getTm t of

502 where alt t = case getTm t of

488 PAlternative False _ -> 5

503 PAlternative False _ -> 5

504+ PAlternative True _ -> 1

505+ PLam _ _ _ -> 2

506+ PRewrite _ _ _ _ -> 3

489 _ -> 0

507 _ -> 0

490

508

491 -- Score a point for every level where there is a non-constructor

509 -- Score a point for every level where there is a non-constructor

@@ -672,14 +690,14 @@ elab ist info pattern opts fn tm

672 let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)

690 let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)

673 let tries = if pattern then [t, mkDelay t] else [mkDelay t, t]

691 let tries = if pattern then [t, mkDelay t] else [mkDelay t, t]

674 case tyh of

692 case tyh of

675− P _ (UN l) _ | l == txt "Lazy"

693+ P _ (UN l) _ | l == txt "Lazy'"

676 -> return (PAlternative False tries)

694 -> return (PAlternative False tries)

677 _ -> return t

695 _ -> return t

678 where

696 where

679 mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)

697 mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)

680 mkDelay t = let fc = fileFC "Delay" in

698 mkDelay t = let fc = fileFC "Delay" in

681− addImpl ist (PApp fc (PRef fc (sUN "Delay")) [pexp t]) -- ipapp

699+ addImpl ist (PApp fc (PRef fc (sUN "Delay")) -- ipapp

682−

700+ [pexp t])

683

701

684 insertCoerce ina t =

702 insertCoerce ina t =

685 do ty <- goal

703 do ty <- goal

@@ -709,10 +727,7 @@ elab ist info pattern opts fn tm

709 -> Bool -- ^ under a 'force'

727 -> Bool -- ^ under a 'force'

710 -> [(Bool, PTerm)] -- ^ (Laziness, argument)

728 -> [(Bool, PTerm)] -- ^ (Laziness, argument)

711 -> ElabD ()

729 -> ElabD ()

712− elabArgs ist ina failed fc retry f [] force _

730+ elabArgs ist ina failed fc retry f [] force _ = return ()

713−-- | retry = let (ns, ts) = unzip (reverse failed) in

714−-- elabArgs ina [] False ns ts

715− | otherwise = return ()

716 elabArgs ist ina failed fc r f (n:ns) force ((_, Placeholder) : args)

731 elabArgs ist ina failed fc r f (n:ns) force ((_, Placeholder) : args)

717 = elabArgs ist ina failed fc r f ns force args

732 = elabArgs ist ina failed fc r f ns force args

718 elabArgs ist ina failed fc r f ((argName, holeName):ns) force ((lazy, t) : args)

733 elabArgs ist ina failed fc r f ((argName, holeName):ns) force ((lazy, t) : args)

@@ -722,54 +737,31 @@ elab ist info pattern opts fn tm

722 pexp t])

737 pexp t])

723 | otherwise = elabArg argName holeName t

738 | otherwise = elabArg argName holeName t

724 where elabArg argName holeName t =

739 where elabArg argName holeName t =

725− reflectFunctionErrors ist f argName $

740+ do now_elaborating fc f argName

741+ wrapErr f argName $ do

726− do hs <- get_holes

742+ hs <- get_holes

727− tm <- get_term

743+ tm <- get_term

728− -- No coercing under an explicit Force (or it can Force/Delay

744+ -- No coercing under an explicit Force (or it can Force/Delay

729− -- recursively!)

745+ -- recursively!)

730− let elab = if force then elab' else elabE

746+ let elab = if force then elab' else elabE

731− failed' <- -- trace (show (n, t, hs, tm)) $

747+ failed' <- -- trace (show (n, t, hs, tm)) $

732− -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

748+ -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

733− case holeName `elem` hs of

749+ case holeName `elem` hs of

734− True -> do focus holeName; elab ina t; return failed

750+ True -> do focus holeName; elab ina t; return failed

735− False -> return failed

751+ False -> return failed

752+ done_elaborating_arg f argName

736− elabArgs ist ina failed fc r f ns force args

753+ elabArgs ist ina failed fc r f ns force args

737−

754+ wrapErr f argName action =

738−-- | Perform error reflection for function applicaitons with specific error handlers

739−reflectFunctionErrors :: IState -> Name -> Name -> ElabD a -> ElabD a

740−reflectFunctionErrors ist f arg action =

741− do elabState <- get

755+ do elabState <- get

756+ while <- elaborating_app

757+ let while' = map (\(x, y, z)-> (y, z)) while

742− (result, newState) <- case runStateT action elabState of

758+ (result, newState) <- case runStateT action elabState of

743− OK (res, newState) -> return (res, newState)

759+ OK (res, newState) -> return (res, newState)

744− Error e@(ReflectionError _ _) -> (lift . tfail) e

760+ Error e -> do done_elaborating_arg f argName

745− Error e@(ReflectionFailed _ _) -> (lift . tfail) e

761+ lift (tfail (elaboratingArgErr while' e))

746− Error e -> handle e >>= lift . tfail

747− put newState

762+ put newState

748− return result

763+ return result

749− where handle :: Err -> ElabD Err

764+

750− handle e = do let funhandlers = (maybe M.empty id . lookupCtxtExact f . idris_function_errorhandlers) ist

751− handlers = (maybe [] S.toList . M.lookup arg) funhandlers

752− reports = map (\n -> RApp (Var n) (reflectErr e)) handlers

753−

754−

755− -- Typecheck error handlers - if this fails, then something else was wrong earlier!

756− handlers <- case mapM (check (tt_ctxt ist) []) reports of

757− Error e -> lift . tfail $

758− ReflectionFailed "Type error while constructing reflected error" e

759− OK hs -> return hs

760−

761− -- Normalize error handler terms to produce the new messages

762− let ctxt = tt_ctxt ist

763− results = map (normalise ctxt []) (map fst handlers)

764−

765− -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

766− let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

767− errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

768− Left err -> lift (tfail err)

769− Right ok -> return ok

770− return $ case errorparts of

771− [] -> e

772− parts -> ReflectionError errorparts e

773

765

774-- For every alternative, look at the function at the head. Automatically resolve

766-- For every alternative, look at the function at the head. Automatically resolve

775-- any nested alternatives where that function is also at the head

767-- any nested alternatives where that function is also at the head

@@ -787,6 +779,7 @@ pruneAlt xs = map prune xs

787 case fs of

779 case fs of

788 [a] -> a

780 [a] -> a

789 _ -> PAlternative a as'

781 _ -> PAlternative a as'

782+

790 choose f (PApp fc f' as) = PApp fc (choose f f') (fmap (fmap (choose f)) as) -- tpapp

783 choose f (PApp fc f' as) = PApp fc (choose f f') (fmap (fmap (choose f)) as) -- tpapp

791 choose f t = t

784 choose f t = t

792

785

@@ -1098,9 +1091,9 @@ runTac autoSolve ist fn tac

1098 runReflected tactic

1091 runReflected tactic

1099 where tacticTy = Var (reflm "Tactic")

1092 where tacticTy = Var (reflm "Tactic")

1100 listTy = Var (sNS (sUN "List") ["List", "Prelude"])

1093 listTy = Var (sNS (sUN "List") ["List", "Prelude"])

1101− scriptTy = (RBind (sUN "__pi_arg")

1094+ scriptTy = (RBind (sMN 0 "__pi_arg")

1102 (Pi (RApp listTy envTupleType))

1095 (Pi (RApp listTy envTupleType))

1103− (RBind (sUN "__pi_arg1")

1096+ (RBind (sMN 1 "__pi_arg")

1104 (Pi (Var $ reflm "TT")) tacticTy))

1097 (Pi (Var $ reflm "TT")) tacticTy))

1105 runT (ByReflection tm) -- run the reflection function 'tm' on the

1098 runT (ByReflection tm) -- run the reflection function 'tm' on the

1106 -- goal, then apply the resulting reflected Tactic

1099 -- goal, then apply the resulting reflected Tactic

@@ -1205,6 +1198,8 @@ reifyApp ist t [t']

1205 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

1198 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

1206reifyApp ist t [t']

1199reifyApp ist t [t']

1207 | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

1200 | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

1201+reifyApp ist t [t']

1202+ | t == reflm "ByReflection" = liftM (ByReflection . delab ist) (reifyTT t')

1208reifyApp _ t [t']

1203reifyApp _ t [t']

1209 | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')

1204 | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')

1210reifyApp ist t [t']

1205reifyApp ist t [t']

@@ -1603,24 +1598,20 @@ reflectErr (NonCollapsiblePostulate n) = raw_apply (Var $ reflErrName "NonCollab

1603reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n]

1598reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n]

1604reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]

1599reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]

1605reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm]

1600reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm]

1606−reflectErr (At fc err) = raw_apply (Var $ reflErrName "At") [reflectFC fc, reflectErr err]

1607− where reflectFC (FC source line col) = raw_apply (Var $ reflErrName "FileLoc")

1608− [ RConstant (Str source)

1609− , RConstant (I line)

1610− , RConstant (I col)

1611− ]

1612−reflectErr (Elaborating str n e) =

1613− raw_apply (Var $ reflErrName "Elaborating")

1614− [ RConstant (Str str)

1615− , reflectName n

1616− , reflectErr e

1617− ]

1618reflectErr (ProviderError str) =

1601reflectErr (ProviderError str) =

1619 raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

1602 raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

1620reflectErr (LoadingFailed str err) =

1603reflectErr (LoadingFailed str err) =

1621 raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

1604 raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

1622reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

1605reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

1623

1606

1607+elaboratingArgErr :: [(Name, Name)] -> Err -> Err

1608+elaboratingArgErr [] err = err

1609+elaboratingArgErr ((f,x):during) err = fromMaybe err (rewrite err)

1610+ where rewrite (ElaboratingArg _ _ _ _) = Nothing

1611+ rewrite (ProofSearchFail e) = fmap ProofSearchFail (rewrite e)

1612+ rewrite (At fc e) = fmap (At fc) (rewrite e)

1613+ rewrite err = Just (ElaboratingArg f x during err)

1614+

1624

1615

1625withErrorReflection :: Idris a -> Idris a

1616withErrorReflection :: Idris a -> Idris a

1626withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

1617withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

@@ -1629,30 +1620,57 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

1629 return e -- Don't do meta-reflection of errors

1620 return e -- Don't do meta-reflection of errors

1630 handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"

1621 handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"

1631 return e

1622 return e

1623+ -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them

1624+ handle e@(At fc err) = do logLvl 3 "Reflecting body of At"

1625+ err' <- handle err

1626+ return (At fc err')

1627+ handle e@(Elaborating what n err) = do logLvl 3 "Reflecting body of Elaborating"

1628+ err' <- handle err

1629+ return (Elaborating what n err')

1630+ handle e@(ElaboratingArg f a prev err) = do logLvl 3 "Reflecting body of ElaboratingArg"

1631+ hs <- getFnHandlers f a

1632+ err' <- if null hs

1633+ then handle err

1634+ else applyHandlers err hs

1635+ return (ElaboratingArg f a prev err')

1636+ -- TODO: argument-specific error handlers go here for ElaboratingArg

1632 handle e = do ist <- getIState

1637 handle e = do ist <- getIState

1633 logLvl 2 "Starting error reflection"

1638 logLvl 2 "Starting error reflection"

1634 let handlers = idris_errorhandlers ist

1639 let handlers = idris_errorhandlers ist

1640+ applyHandlers e handlers

1641+ getFnHandlers :: Name -> Name -> Idris [Name]

1642+ getFnHandlers f arg = do ist <- getIState

1643+ let funHandlers = maybe M.empty id .

1644+ lookupCtxtExact f .

1645+ idris_function_errorhandlers $ ist

1646+ return . maybe [] S.toList . M.lookup arg $ funHandlers

1647+

1648+

1649+ applyHandlers e handlers =

1650+ do ist <- getIState

1651+ let err = fmap (errReverse ist) e

1652+ logLvl 3 $ "Using reflection handlers " ++

1635− logLvl 3 $ "Using reflection handlers " ++ concat (intersperse ", " (map show handlers))

1653+ concat (intersperse ", " (map show handlers))

1636− let reports = map (\n -> RApp (Var n) (reflectErr e)) handlers

1654+ let reports = map (\n -> RApp (Var n) (reflectErr err)) handlers

1637−

1655+

1638− -- Typecheck error handlers - if this fails, then something else was wrong earlier!

1656+ -- Typecheck error handlers - if this fails, then something else was wrong earlier!

1639− handlers <- case mapM (check (tt_ctxt ist) []) reports of

1657+ handlers <- case mapM (check (tt_ctxt ist) []) reports of

1640− Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e

1658+ Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e

1641− OK hs -> return hs

1659+ OK hs -> return hs

1642−

1660+

1643− -- Normalize error handler terms to produce the new messages

1661+ -- Normalize error handler terms to produce the new messages

1644− ctxt <- getContext

1662+ ctxt <- getContext

1645− let results = map (normalise ctxt []) (map fst handlers)

1663+ let results = map (normalise ctxt []) (map fst handlers)

1646− logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

1664+ logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

1647−

1665+

1648− -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

1666+ -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

1649− let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

1667+ let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

1650− errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

1668+ errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

1651− Left err -> ierror err

1669+ Left err -> ierror err

1652− Right ok -> return ok

1670+ Right ok -> return ok

1653− return $ case errorparts of

1671+ return $ case errorparts of

1654− [] -> e

1672+ [] -> e

1655− parts -> ReflectionError errorparts e

1673+ parts -> ReflectionError errorparts e

1656

1674

1657fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

1675fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

1658fromTTMaybe (App (App (P (DCon _ _) (NS (UN just) _) _) ty) tm)

1676fromTTMaybe (App (App (P (DCon _ _) (NS (UN just) _) _) ty) tm)

src/Idris/Error.hs+8−13

@@ -23,7 +23,7 @@ iucheck = do tit <- typeInType

23 when (not tit) $

24 do ist <- getIState

25 (tclift $ ucheck (idris_constraints ist)) `idrisCatch`

26− (\e -> do setErrLine (getErrLine e)

26+ (\e -> do setErrSpan (getErrSpan e)

27 iputStrLn (pshow ist e))

28

29showErr :: Err -> Idris String

@@ -43,9 +43,9 @@ setAndReport :: Err -> Idris ()

43setAndReport e = do ist <- getIState

44 let h = idris_outh ist

45 case e of

46− At fc@(FC f l c) e -> do setErrLine l

46+ At fc e -> do setErrSpan fc

47− ihWarn h fc $ pprintErr ist e

47+ ihWarn h fc $ pprintErr ist e

48− _ -> do setErrLine (getErrLine e)

48+ _ -> do setErrSpan (getErrSpan e)

49 ihputStrLn h $ pshow ist e

50

51ifail :: String -> Idris a

@@ -56,7 +56,7 @@ ierror = throwError

56

57tclift :: TC a -> Idris a

58tclift (OK v) = return v

59−tclift (Error err@(At (FC f l c) e)) = do setErrLine l ; throwError err

59+tclift (Error err@(At fc e)) = do setErrSpan fc; throwError err

60tclift (Error err) = throwError err

61

62tctry :: TC a -> TC a -> Idris a

@@ -65,11 +65,6 @@ tctry tc1 tc2

65 OK v -> return v

66 Error err -> tclift tc2

67

68−getErrLine :: Err -> Int

68+getErrSpan :: Err -> FC

69−getErrLine (At (FC _ l _) _) = l

69+getErrSpan (At fc _) = fc

70−getErrLine _ = 0

70+getErrSpan _ = emptyFC

71−

72−getErrColumn :: Err -> Int

73−getErrColumn (At (FC _ _ c) _) = c

74−getErrColumn _ = 0

75−

src/Idris/Help.hs+1

@@ -29,6 +29,7 @@ help =

29 ([":t"], ExprArg, "Check the type of an expression"),

30 ([":miss", ":missing"], NameArg, "Show missing clauses"),

31 ([":doc"], NameArg, "Show internal documentation"),

32+ ([":apropos"], NoArg, "Search names, types, and documentation"),

32 ([":i", ":info"], NameArg, "Display information about a type class"),

33 ([":i", ":info"], NameArg, "Display information about a type class"),

33 ([":total"], NameArg, "Check the totality of a name"),

34 ([":total"], NameArg, "Check the totality of a name"),

34 ([":r",":reload"], NoArg, "Reload current file"),

35 ([":r",":reload"], NoArg, "Reload current file"),

src/Idris/IBC.hs+122−19

@@ -9,6 +9,9 @@ import Idris.AbsSyntax

9import Idris.Imports

10import Idris.Error

11import Idris.Delaborate

12+import Idris.Docstrings

13+

14+import qualified Cheapskate.Types as CT

12

15

13import Data.Binary

16import Data.Binary

14import Data.Vector.Binary

17import Data.Vector.Binary

@@ -25,8 +28,7 @@ import Codec.Compression.Zlib (compress)

25import Util.Zlib (decompressEither)

28import Util.Zlib (decompressEither)

26

29

27ibcVersion :: Word8

30ibcVersion :: Word8

28−ibcVersion = 62

31+ibcVersion = 65

29−

30

32

31data IBCFile = IBCFile { ver :: Word8,

33data IBCFile = IBCFile { ver :: Word8,

32 sourcefile :: FilePath,

34 sourcefile :: FilePath,

@@ -52,7 +54,7 @@ data IBCFile = IBCFile { ver :: Word8,

52 ibc_flags :: [(Name, [FnOpt])],

54 ibc_flags :: [(Name, [FnOpt])],

53 ibc_cg :: [(Name, CGInfo)],

55 ibc_cg :: [(Name, CGInfo)],

54 ibc_defs :: [(Name, Def)],

56 ibc_defs :: [(Name, Def)],

55− ibc_docstrings :: [(Name, (String, [(Name, String)]))],

57+ ibc_docstrings :: [(Name, (Docstring, [(Name, Docstring)]))],

56 ibc_transforms :: [(Term, Term)],

58 ibc_transforms :: [(Term, Term)],

57 ibc_errRev :: [(Term, Term)],

59 ibc_errRev :: [(Term, Term)],

58 ibc_coercions :: [Name],

60 ibc_coercions :: [Name],

@@ -61,7 +63,8 @@ data IBCFile = IBCFile { ver :: Word8,

61 ibc_metainformation :: [(Name, MetaInformation)],

63 ibc_metainformation :: [(Name, MetaInformation)],

62 ibc_errorhandlers :: [Name],

64 ibc_errorhandlers :: [Name],

63 ibc_function_errorhandlers :: [(Name, Name, Name)], -- fn, arg, handler

65 ibc_function_errorhandlers :: [(Name, Name, Name)], -- fn, arg, handler

64− ibc_metavars :: [(Name, (Maybe Name, Int, Bool))]

66+ ibc_metavars :: [(Name, (Maybe Name, Int, Bool))],

67+ ibc_patdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))]

65 }

68 }

66 deriving Show

69 deriving Show

67{-!

70{-!

@@ -69,7 +72,7 @@ deriving instance Binary IBCFile

69!-}

72!-}

70

73

71initIBC :: IBCFile

74initIBC :: IBCFile

72−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

75+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

73

76

74loadIBC :: FilePath -> Idris ()

77loadIBC :: FilePath -> Idris ()

75loadIBC fp = do iLOG $ "Loading ibc " ++ fp

78loadIBC fp = do iLOG $ "Loading ibc " ++ fp

@@ -142,10 +145,14 @@ ibc i (IBCLib tgt n) f = return f { ibc_libs = (tgt, n) : ibc_libs f }

142ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f }

145ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f }

143ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

146ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

144ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }

147ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }

148+ibc i (IBCDef n) f

145−ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of

149+ = do f' <- case lookupDef n (tt_ctxt i) of

146− [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))

150+ [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))

147− return f' { ibc_defs = (n,v) : ibc_defs f' }

151+ return f' { ibc_defs = (n,v) : ibc_defs f' }

148− _ -> ifail "IBC write failed"

152+ _ -> ifail "IBC write failed"

153+ case lookupCtxt n (idris_patdefs i) of

154+ [v] -> return f' { ibc_patdefs = (n,v) : ibc_patdefs f' }

155+ _ -> return f' -- Not a pattern definition

149 where

156 where

150 updateDef :: Def -> StateT (IBCFile, Int) Idris Def

157 updateDef :: Def -> StateT (IBCFile, Int) Idris Def

151 updateDef (CaseOp c t args o s cd)

158 updateDef (CaseOp c t args o s cd)

@@ -253,6 +260,7 @@ process i fn

253 pDyLibs (ibc_dynamic_libs i)

260 pDyLibs (ibc_dynamic_libs i)

254 pHdrs (ibc_hdrs i)

261 pHdrs (ibc_hdrs i)

255 pDefs (symbols i) (ibc_defs i)

262 pDefs (symbols i) (ibc_defs i)

263+ pPatdefs (ibc_patdefs i)

256 pAccess (ibc_access i)

264 pAccess (ibc_access i)

257 pTotal (ibc_total i)

265 pTotal (ibc_total i)

258 pCG (ibc_cg i)

266 pCG (ibc_cg i)

@@ -378,6 +386,13 @@ pDyLibs ls = do res <- mapM (addDyLib . return) ls

378pHdrs :: [(Codegen, String)] -> Idris ()

386pHdrs :: [(Codegen, String)] -> Idris ()

379pHdrs hs = mapM_ (uncurry addHdr) hs

387pHdrs hs = mapM_ (uncurry addHdr) hs

380

388

389+pPatdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))] -> Idris ()

390+pPatdefs ds

391+ = mapM_ (\ (n, d) ->

392+ do i <- getIState

393+ putIState (i { idris_patdefs = addDef n d (idris_patdefs i) }))

394+ ds

395+

381pDefs :: [Name] -> [(Name, Def)] -> Idris ()

396pDefs :: [Name] -> [(Name, Def)] -> Idris ()

382pDefs syms ds

397pDefs syms ds

383 = mapM_ (\ (n, d) ->

398 = mapM_ (\ (n, d) ->

@@ -405,7 +420,7 @@ pDefs syms ds

405 update (Proj t i) = Proj (update t) i

420 update (Proj t i) = Proj (update t) i

406 update t = t

421 update t = t

407

422

408−pDocs :: [(Name, (String, [(Name, String)]))] -> Idris ()

423+pDocs :: [(Name, (Docstring, [(Name, Docstring)]))] -> Idris ()

409pDocs ds = mapM_ (\ (n, a) -> addDocStr n (fst a) (snd a)) ds

424pDocs ds = mapM_ (\ (n, a) -> addDocStr n (fst a) (snd a)) ds

410

425

411pAccess :: [(Name, Accessibility)] -> Idris ()

426pAccess :: [(Name, Accessibility)] -> Idris ()

@@ -461,6 +476,86 @@ pMetavars ns = do i <- getIState

461 putIState $ i { idris_metavars = Data.List.reverse ns

476 putIState $ i { idris_metavars = Data.List.reverse ns

462 ++ idris_metavars i }

477 ++ idris_metavars i }

463

478

479+----- For Cheapskate

480+

481+instance Binary CT.Doc where

482+ put (CT.Doc opts lines) = do put opts ; put lines

483+ get = do opts <- get

484+ lines <- get

485+ return (CT.Doc opts lines)

486+

487+instance Binary CT.Options where

488+ put (CT.Options x1 x2 x3 x4) = do put x1 ; put x2 ; put x3 ; put x4

489+ get = do x1 <- get

490+ x2 <- get

491+ x3 <- get

492+ x4 <- get

493+ return (CT.Options x1 x2 x3 x4)

494+

495+instance Binary CT.Block where

496+ put (CT.Para lines) = do putWord8 0 ; put lines

497+ put (CT.Header i lines) = do putWord8 1 ; put i ; put lines

498+ put (CT.Blockquote bs) = do putWord8 2 ; put bs

499+ put (CT.List b t xs) = do putWord8 3 ; put b ; put t ; put xs

500+ put (CT.CodeBlock attr txt) = do putWord8 4 ; put attr ; put txt

501+ put (CT.HtmlBlock txt) = do putWord8 5 ; put txt

502+ put CT.HRule = putWord8 6

503+ get = do i <- getWord8

504+ case i of

505+ 0 -> fmap CT.Para get

506+ 1 -> liftM2 CT.Header get get

507+ 2 -> fmap CT.Blockquote get

508+ 3 -> liftM3 CT.List get get get

509+ 4 -> liftM2 CT.CodeBlock get get

510+ 5 -> liftM CT.HtmlBlock get

511+ 6 -> return CT.HRule

512+

513+instance Binary CT.Inline where

514+ put (CT.Str txt) = do putWord8 0 ; put txt

515+ put CT.Space = putWord8 1

516+ put CT.SoftBreak = putWord8 2

517+ put CT.LineBreak = putWord8 3

518+ put (CT.Emph xs) = putWord8 4 >> put xs

519+ put (CT.Strong xs) = putWord8 5 >> put xs

520+ put (CT.Code xs) = putWord8 6 >> put xs

521+ put (CT.Link a b c) = putWord8 7 >> put a >> put b >> put c

522+ put (CT.Image a b c) = putWord8 8 >> put a >> put b >> put c

523+ put (CT.Entity a) = putWord8 9 >> put a

524+ put (CT.RawHtml x) = putWord8 10 >> put x

525+ get = do i <- getWord8

526+ case i of

527+ 0 -> liftM CT.Str get

528+ 1 -> return CT.Space

529+ 2 -> return CT.SoftBreak

530+ 3 -> return CT.LineBreak

531+ 4 -> liftM CT.Emph get

532+ 5 -> liftM CT.Strong get

533+ 6 -> liftM CT.Code get

534+ 7 -> liftM3 CT.Link get get get

535+ 8 -> liftM3 CT.Image get get get

536+ 9 -> liftM CT.Entity get

537+ 10 -> liftM CT.RawHtml get

538+

539+instance Binary CT.ListType where

540+ put (CT.Bullet c) = putWord8 0 >> put c

541+ put (CT.Numbered nw i) = putWord8 1 >> put nw >> put i

542+ get = do i <- getWord8

543+ case i of

544+ 0 -> liftM CT.Bullet get

545+ 1 -> liftM2 CT.Numbered get get

546+

547+instance Binary CT.CodeAttr where

548+ put (CT.CodeAttr a b) = put a >> put b

549+ get = liftM2 CT.CodeAttr get get

550+

551+instance Binary CT.NumWrapper where

552+ put (CT.PeriodFollowing) = putWord8 0

553+ put (CT.ParenFollowing) = putWord8 1

554+ get = do i <- getWord8

555+ case i of

556+ 0 -> return CT.PeriodFollowing

557+ 1 -> return CT.ParenFollowing

558+

464----- Generated by 'derive'

559----- Generated by 'derive'

465

560

466instance Binary SizeChange where

561instance Binary SizeChange where

@@ -494,13 +589,15 @@ instance Binary CGInfo where

494 return (CGInfo x1 x2 [] x4 x5)

589 return (CGInfo x1 x2 [] x4 x5)

495

590

496instance Binary FC where

591instance Binary FC where

497− put (FC x1 x2 x3)

592+ put (FC x1 (x2, x3) (x4, x5))

498 = do put x1

593 = do put x1

499 put (x2 * 65536 + x3)

594 put (x2 * 65536 + x3)

595+ put (x4 * 65536 + x5)

500 get

596 get

501 = do x1 <- get

597 = do x1 <- get

502 x2x3 <- get

598 x2x3 <- get

599+ x4x5 <- get

503− return (FC x1 (x2x3 `div` 65536) (x2x3 `mod` 65536))

600+ return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))

504

601

505

602

506instance Binary Name where

603instance Binary Name where

@@ -1052,7 +1149,7 @@ instance Binary MetaInformation where

1052 return (DataMI x1)

1149 return (DataMI x1)

1053

1150

1054instance Binary IBCFile where

1151instance Binary IBCFile where

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

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

1056 = {-# SCC "putIBCFile" #-}

1153 = {-# SCC "putIBCFile" #-}

1057 do put x1

1154 do put x1

1058 put x2

1155 put x2

@@ -1088,6 +1185,7 @@ instance Binary IBCFile where

1088 put x32

1185 put x32

1089 put x33

1186 put x33

1090 put x34

1187 put x34

1188+ put x35

1091

1189

1092 get

1190 get

1093 = do x1 <- get

1191 = do x1 <- get

@@ -1125,7 +1223,8 @@ instance Binary IBCFile where

1125 x32 <- get

1223 x32 <- get

1126 x33 <- get

1224 x33 <- get

1127 x34 <- get

1225 x34 <- get

1226+ x35 <- get

1128− return (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)

1227+ return (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)

1129 else return (initIBC { ver = x1 })

1228 else return (initIBC { ver = x1 })

1130

1229

1131instance Binary DataOpt where

1230instance Binary DataOpt where

@@ -1154,6 +1253,7 @@ instance Binary FnOpt where

1154 Reflection -> putWord8 8

1253 Reflection -> putWord8 8

1155 ErrorHandler -> putWord8 9

1254 ErrorHandler -> putWord8 9

1156 ErrorReverse -> putWord8 10

1255 ErrorReverse -> putWord8 10

1256+ CoveringFn -> putWord8 11

1157 get

1257 get

1158 = do i <- getWord8

1258 = do i <- getWord8

1159 case i of

1259 case i of

@@ -1169,6 +1269,7 @@ instance Binary FnOpt where

1169 8 -> return Reflection

1269 8 -> return Reflection

1170 9 -> return ErrorHandler

1270 9 -> return ErrorHandler

1171 10 -> return ErrorReverse

1271 10 -> return ErrorReverse

1272+ 11 -> return CoveringFn

1172 _ -> error "Corrupted binary data for FnOpt"

1273 _ -> error "Corrupted binary data for FnOpt"

1173

1274

1174instance Binary Fixity where

1275instance Binary Fixity where

@@ -1878,10 +1979,11 @@ instance (Binary t) => Binary (PDo' t) where

1878 put x1

1979 put x1

1879 put x2

1980 put x2

1880 put x3

1981 put x3

1881− DoBindP x1 x2 x3 -> do putWord8 2

1982+ DoBindP x1 x2 x3 x4 -> do putWord8 2

1882− put x1

1983+ put x1

1883− put x2

1984+ put x2

1884− put x3

1985+ put x3

1986+ put x4

1885 DoLet x1 x2 x3 x4 -> do putWord8 3

1987 DoLet x1 x2 x3 x4 -> do putWord8 3

1886 put x1

1988 put x1

1887 put x2

1989 put x2

@@ -1904,7 +2006,8 @@ instance (Binary t) => Binary (PDo' t) where

1904 2 -> do x1 <- get

2006 2 -> do x1 <- get

1905 x2 <- get

2007 x2 <- get

1906 x3 <- get

2008 x3 <- get

2009+ x4 <- get

1907− return (DoBindP x1 x2 x3)

2010+ return (DoBindP x1 x2 x3 x4)

1908 3 -> do x1 <- get

2011 3 -> do x1 <- get

1909 x2 <- get

2012 x2 <- get

1910 x3 <- get

2013 x3 <- get

src/Idris/IdeSlave.hs+21−5

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

1{-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-}

2

3−module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable) where

3+module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..), SExpable, Opt(..)) where

4

5import Text.Printf

6import Numeric

@@ -89,10 +89,16 @@ instance SExpable OutputAnnotation where

89 (SymbolAtom "implicit", BoolAtom imp)]

90 toSExp AnnConstData = toSExp [(SymbolAtom "decor", SymbolAtom "data")]

91 toSExp AnnConstType = toSExp [(SymbolAtom "decor", SymbolAtom "type")]

92+ toSExp AnnKeyword = toSExp [(SymbolAtom "decor", SymbolAtom "keyword")]

92− toSExp (AnnFC (FC f l c)) = toSExp [(SymbolAtom "source-loc",

93+ toSExp (AnnFC (FC f (sl, sc) (el, ec))) = toSExp [(SymbolAtom "source-loc",

93− ((SymbolAtom "filename", StringAtom f),

94+ ((SymbolAtom "filename", StringAtom f),

94− (SymbolAtom "line", IntegerAtom (toInteger l)),

95+ (SymbolAtom "start", IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),

95− (SymbolAtom "column", IntegerAtom (toInteger c))))]

96+ (SymbolAtom "end", IntegerAtom (toInteger el), IntegerAtom (toInteger ec))))]

97+ toSExp (AnnTextFmt fmt) = toSExp [(SymbolAtom "text-formatting", SymbolAtom format)]

98+ where format = case fmt of

99+ BoldText -> "bold"

100+ ItalicText -> "italic"

101+ UnderlineText -> "underline"

96

102

97escape :: String -> String

103escape :: String -> String

98escape = concatMap escapeChar

104escape = concatMap escapeChar

@@ -124,6 +130,8 @@ quotedChar = try (string "\\\\" >> return '\\')

124parseSExp :: String -> Result SExp

130parseSExp :: String -> Result SExp

125parseSExp = parseString pSExp (Directed (UTF8.fromString "(unknown)") 0 0 0 0)

131parseSExp = parseString pSExp (Directed (UTF8.fromString "(unknown)") 0 0 0 0)

126

132

133+data Opt = ShowImpl | ErrContext deriving Show

134+

127data IdeSlaveCommand = REPLCompletions String

135data IdeSlaveCommand = REPLCompletions String

128 | Interpret String

136 | Interpret String

129 | TypeOf String

137 | TypeOf String

@@ -135,6 +143,9 @@ data IdeSlaveCommand = REPLCompletions String

135 | ProofSearch Int String [String]

143 | ProofSearch Int String [String]

136 | LoadFile String

144 | LoadFile String

137 | DocsFor String

145 | DocsFor String

146+ | Apropos String

147+ | GetOpts

148+ | SetOpt Opt Bool

138 deriving Show

149 deriving Show

139

150

140sexpToCommand :: SExp -> Maybe IdeSlaveCommand

151sexpToCommand :: SExp -> Maybe IdeSlaveCommand

@@ -153,6 +164,11 @@ sexpToCommand (SexpList [SymbolAtom "proof-search", IntegerAtom line, StringAtom

153 StringAtom s -> Just s

164 StringAtom s -> Just s

154 _ -> Nothing)

165 _ -> Nothing)

155sexpToCommand (SexpList [SymbolAtom "docs-for", StringAtom name]) = Just (DocsFor name)

166sexpToCommand (SexpList [SymbolAtom "docs-for", StringAtom name]) = Just (DocsFor name)

167+sexpToCommand (SexpList [SymbolAtom "apropos", StringAtom search]) = Just (Apropos search)

168+sexpToCommand (SymbolAtom "get-options") = Just GetOpts

169+sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])

170+ | Just opt <- lookup s opts = Just (SetOpt opt b)

171+ where opts = [("show-implicits", ShowImpl), ("error-context", ErrContext)] --TODO support more

156sexpToCommand _ = Nothing

172sexpToCommand _ = Nothing

157

173

158parseMessage :: String -> Either Err (SExp, Integer)

174parseMessage :: String -> Either Err (SExp, Integer)

src/Idris/ParseData.hs+8−6

@@ -20,6 +20,8 @@ import Idris.DSL

20import Idris.Core.TT

21import Idris.Core.Evaluate

22

23+import Idris.Docstrings

24+

23import Control.Applicative

25import Control.Applicative

24import Control.Monad

26import Control.Monad

25import Control.Monad.State.Strict

27import Control.Monad.State.Strict

@@ -41,7 +43,7 @@ Record ::=

41-}

43-}

42record :: SyntaxInfo -> IdrisParser PDecl

44record :: SyntaxInfo -> IdrisParser PDecl

43record syn = do (doc, acc) <- try (do

45record syn = do (doc, acc) <- try (do

44− doc <- option ("", []) docComment

46+ doc <- option noDocs docComment

45 acc <- optional accessibility

47 acc <- optional accessibility

46 reserved "record"

48 reserved "record"

47 return (doc, acc))

49 return (doc, acc))

@@ -103,7 +105,7 @@ SimpleConstructorList ::=

103-}

105-}

104data_ :: SyntaxInfo -> IdrisParser PDecl

106data_ :: SyntaxInfo -> IdrisParser PDecl

105data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

107data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

106− (doc, argDocs) <- option ("", []) docComment

108+ (doc, argDocs) <- option noDocs docComment

107 pushIndent

109 pushIndent

108 acc <- optional accessibility

110 acc <- optional accessibility

109 elim <- dataOpts []

111 elim <- dataOpts []

@@ -160,9 +162,9 @@ data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

160{- | Parses a type constructor declaration

162{- | Parses a type constructor declaration

161 Constructor ::= DocComment? FnName TypeSig;

163 Constructor ::= DocComment? FnName TypeSig;

162-}

164-}

163−constructor :: SyntaxInfo -> IdrisParser (String, [(Name, String)], Name, PTerm, FC, [Name])

165+constructor :: SyntaxInfo -> IdrisParser (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])

164constructor syn

166constructor syn

165− = do (doc, argDocs) <- option ("", []) docComment

167+ = do (doc, argDocs) <- option noDocs docComment

166 cn_in <- fnName; fc <- getFC

168 cn_in <- fnName; fc <- getFC

167 let cn = expandNS syn cn_in

169 let cn = expandNS syn cn_in

168 lchar ':'

170 lchar ':'

@@ -177,9 +179,9 @@ constructor syn

177{- | Parses a constructor for simple discriminative union data types

179{- | Parses a constructor for simple discriminative union data types

178 SimpleConstructor ::= FnName SimpleExpr* DocComment?

180 SimpleConstructor ::= FnName SimpleExpr* DocComment?

179-}

181-}

180−simpleConstructor :: SyntaxInfo -> IdrisParser (String, [(Name, String)], Name, [PTerm], FC, [Name])

182+simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring, [(Name, Docstring)], Name, [PTerm], FC, [Name])

181simpleConstructor syn

183simpleConstructor syn

182− = do doc <- option ("", []) (try docComment)

184+ = do doc <- option noDocs (try docComment)

183 cn_in <- fnName

185 cn_in <- fnName

184 let cn = expandNS syn cn_in

186 let cn = expandNS syn cn_in

185 fc <- getFC

187 fc <- getFC

src/Idris/ParseExpr.hs+27−8

@@ -167,7 +167,9 @@ extension syn (Rule ssym ptm _)

167 upd ns (DoBind fc n t : ds) = DoBind fc n (update ns t) : upd (dropn n ns) ds

168 upd ns (DoLet fc n ty t : ds) = DoLet fc n (update ns ty) (update ns t)

169 : upd (dropn n ns) ds

170+ upd ns (DoBindP fc i t ts : ds)

170− upd ns (DoBindP fc i t : ds) = DoBindP fc (update ns i) (update ns t)

171+ = DoBindP fc (update ns i) (update ns t)

172+ (map (\(l,r) -> (update ns l, update ns r)) ts)

171 : upd ns ds

173 : upd ns ds

172 upd ns (DoLetP fc i t : ds) = DoLetP fc (update ns i) (update ns t)

174 upd ns (DoLetP fc i t : ds) = DoLetP fc (update ns i) (update ns t)

173 : upd ns ds

175 : upd ns ds

@@ -245,7 +247,7 @@ ProofExpr ::=

245-}

247-}

246proofExpr :: SyntaxInfo -> IdrisParser PTerm

248proofExpr :: SyntaxInfo -> IdrisParser PTerm

247proofExpr syn = do reserved "proof"

249proofExpr syn = do reserved "proof"

248− ts <- indentedBlock (tactic syn)

250+ ts <- indentedBlock1 (tactic syn)

249 return $ PProof ts

251 return $ PProof ts

250 <?> "proof block"

252 <?> "proof block"

251

253

@@ -258,7 +260,7 @@ TacticsExpr :=

258-}

260-}

259tacticsExpr :: SyntaxInfo -> IdrisParser PTerm

261tacticsExpr :: SyntaxInfo -> IdrisParser PTerm

260tacticsExpr syn = do reserved "tactics"

262tacticsExpr syn = do reserved "tactics"

261− ts <- indentedBlock (tactic syn)

263+ ts <- indentedBlock1 (tactic syn)

262 return $ PTactics ts

264 return $ PTactics ts

263 <?> "tactics block"

265 <?> "tactics block"

264

266

@@ -736,16 +738,22 @@ TypeSig' ::=

736@

738@

737 -}

739 -}

738let_ :: SyntaxInfo -> IdrisParser PTerm

740let_ :: SyntaxInfo -> IdrisParser PTerm

739−let_ syn = try (do reserved "let"; n <- name;

741+let_ syn = try (do reserved "let"; fc <- getFC; n <- name;

740 ty <- option Placeholder (do lchar ':'; expr' syn)

742 ty <- option Placeholder (do lchar ':'; expr' syn)

741 lchar '='

743 lchar '='

742 v <- expr syn

744 v <- expr syn

745+ ts <- option [] (do lchar '|'

746+ sepBy1 (do_alt syn) (lchar '|'))

743 reserved "in"; sc <- expr syn

747 reserved "in"; sc <- expr syn

748+ case ts of

744− return (PLet n ty v sc))

749+ [] -> return (PLet n ty v sc)

750+ alts -> return (PCase fc v ((PRef fc n, sc) : ts)))

745 <|> (do reserved "let"; fc <- getFC; pat <- expr' (syn { inPattern = True } )

751 <|> (do reserved "let"; fc <- getFC; pat <- expr' (syn { inPattern = True } )

746 symbol "="; v <- expr syn

752 symbol "="; v <- expr syn

753+ ts <- option [] (do lchar '|'

754+ sepBy1 (do_alt syn) (lchar '|'))

747 reserved "in"; sc <- expr syn

755 reserved "in"; sc <- expr syn

748− return (PCase fc v [(pat, sc)]))

756+ return (PCase fc v ((pat, sc) : ts)))

749 <?> "let binding"

757 <?> "let binding"

750

758

751{- | Parses a quote goal

759{- | Parses a quote goal

@@ -967,17 +975,28 @@ do_ syn

967 symbol "<-"

975 symbol "<-"

968 fc <- getFC

976 fc <- getFC

969 e <- expr syn;

977 e <- expr syn;

970− return (DoBind fc i e))

978+ option (DoBind fc i e)

979+ (do lchar '|'

980+ ts <- sepBy1 (do_alt syn) (lchar '|')

981+ return (DoBindP fc (PRef fc i) e ts)))

971 <|> try (do i <- expr' syn

982 <|> try (do i <- expr' syn

972 symbol "<-"

983 symbol "<-"

973 fc <- getFC

984 fc <- getFC

974 e <- expr syn;

985 e <- expr syn;

986+ option (DoBindP fc i e [])

987+ (do lchar '|'

988+ ts <- sepBy1 (do_alt syn) (lchar '|')

975− return (DoBindP fc i e))

989+ return (DoBindP fc i e ts)))

976 <|> do e <- expr syn

990 <|> do e <- expr syn

977 fc <- getFC

991 fc <- getFC

978 return (DoExp fc e)

992 return (DoExp fc e)

979 <?> "do block expression"

993 <?> "do block expression"

980

994

995+do_alt syn = do l <- expr' syn

996+ symbol "=>"

997+ r <- expr' syn

998+ return (l, r)

999+

981{- | Parses an expression in idiom brackets

1000{- | Parses an expression in idiom brackets

982@

1001@

983Idiom ::= '[|' Expr '|]';

1002Idiom ::= '[|' Expr '|]';

src/Idris/ParseHelpers.hs+23−13

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

1−{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

1+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, OverlappingInstances, StandaloneDeriving #-}

2module Idris.ParseHelpers where

3

4import Prelude hiding (pi)

@@ -16,6 +16,7 @@ import Idris.AbsSyntax

16import Idris.Core.TT

17import Idris.Core.Evaluate

18import Idris.Delaborate (pprintErr)

19+import Idris.Docstrings

19

20

20import qualified Util.Pretty as Pretty (text)

21import qualified Util.Pretty as Pretty (text)

21

22

@@ -41,11 +42,19 @@ import Debug.Trace

41type IdrisParser = StateT IState IdrisInnerParser

42type IdrisParser = StateT IState IdrisInnerParser

42

43

43newtype IdrisInnerParser a = IdrisInnerParser { runInnerParser :: Parser a }

44newtype IdrisInnerParser a = IdrisInnerParser { runInnerParser :: Parser a }

44− deriving (Monad, Functor, MonadPlus, Applicative, Alternative, CharParsing, LookAheadParsing, Parsing, DeltaParsing, MarkParsing Delta, Monoid)

45+ deriving (Monad, Functor, MonadPlus, Applicative, Alternative, CharParsing, LookAheadParsing, DeltaParsing, MarkParsing Delta, Monoid, TokenParsing)

45

46

46−instance TokenParsing IdrisInnerParser where

47+deriving instance Parsing IdrisInnerParser

47− someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()

48

49+instance TokenParsing IdrisParser where

50+ someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()

51+ token p = do s <- get

52+ (FC fn (sl, sc) _) <- getFC --TODO: Update after fixing getFC

53+ r <- p

54+ (FC fn _ (el, ec)) <- getFC

55+ whiteSpace

56+ put (s { lastTokenSpan = Just (FC fn (sl, sc) (el, ec)) })

57+ return r

49-- | Generalized monadic parsing constraint type

58-- | Generalized monadic parsing constraint type

50type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)

59type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)

51

60

@@ -139,25 +148,26 @@ multiLineComment = try (string "{-" *> (string "-}") *> pure ())

139{-| Parses a documentation comment (similar to haddoc) given a marker character

148{-| Parses a documentation comment (similar to haddoc) given a marker character

140

149

141@

150@

142− DocComment_t ::= '--' DocCommentMarker_t ~EOL_t* EOL_t

151+ DocComment_t ::= '|||' ~EOL_t* EOL_t

143− | '{ -' DocCommentMarket_t ~'- }'* '- }'

144 ;

152 ;

145@

153@

146 -}

154 -}

147−docComment :: IdrisParser (String, [(Name, String)])

155+docComment :: IdrisParser (Docstring, [(Name, Docstring)])

148docComment = do dc <- pushIndent *> docCommentLine

156docComment = do dc <- pushIndent *> docCommentLine

149 rest <- many (indented docCommentLine)

157 rest <- many (indented docCommentLine)

150 args <- many (indented argDocCommentLine)

158 args <- many (indented argDocCommentLine)

151 popIndent

159 popIndent

152− return (T.unpack $ T.strip $ T.pack (dc ++ concat rest), args)

160+ return (parseDocstring $ T.pack (concat . intersperse "\n" $ dc:rest),

161+ map (\(n, d) -> (n, parseDocstring (T.pack d))) args)

153

162

154 where docCommentLine :: MonadicParsing m => m String

163 where docCommentLine :: MonadicParsing m => m String

155 docCommentLine = try (do string "|||"

164 docCommentLine = try (do string "|||"

156− many (satisfy isSpace)

165+ many (satisfy (==' '))

157− first <- satisfy (\c -> not (isEol c || c == '@'))

166+ contents <- option "" (do first <- satisfy (\c -> not (isEol c || c == '@'))

158− res <- many (satisfy (not . isEol))

167+ res <- many (satisfy (not . isEol))

168+ return $ first:res)

159 eol ; someSpace

169 eol ; someSpace

160− return (first:res))-- ++ concat rest))

170+ return contents)-- ++ concat rest))

161 <?> ""

171 <?> ""

162 argDocCommentLine = do string "|||"

172 argDocCommentLine = do string "|||"

163 many (satisfy isSpace)

173 many (satisfy isSpace)

@@ -328,7 +338,7 @@ getFC :: MonadicParsing m => m FC

328getFC = do s <- position

338getFC = do s <- position

329 let (dir, file) = splitFileName (fileName s)

339 let (dir, file) = splitFileName (fileName s)

330 let f = if dir == addTrailingPathSeparator "." then file else fileName s

340 let f = if dir == addTrailingPathSeparator "." then file else fileName s

331− return $ FC f (lineNum s) (columnNum s)

341+ return $ FC f (lineNum s, columnNum s) (lineNum s, columnNum s) -- TODO: Change to actual spanning

332

342

333{-* Syntax helpers-}

343{-* Syntax helpers-}

334-- | Bind constraints to term

344-- | Bind constraints to term

src/Idris/ParseOps.hs−1

@@ -59,7 +59,6 @@ binary name f = Infix (do fc <- getFC

59 indentPropHolds gtProp

60 reservedOp name

61 indentPropHolds gtProp

62− doc <- option ("", []) docComment

63 return (f fc))

62 return (f fc))

64

63

65-- | Prefix operator

64-- | Prefix operator

src/Idris/Parser.hs+13−9

@@ -35,6 +35,8 @@ import Idris.ParseOps

35import Idris.ParseExpr

36import Idris.ParseData

37

38+import Idris.Docstrings

39+

38import Paths_idris

40import Paths_idris

39

41

40import Util.DynamicLinker

42import Util.DynamicLinker

@@ -315,7 +317,7 @@ fnDecl' syn = checkFixity $

315 do (doc, fc, opts', n, acc) <- try (do

317 do (doc, fc, opts', n, acc) <- try (do

316 pushIndent

318 pushIndent

317 ist <- get

319 ist <- get

318− doc <- option ("", []) docComment

320+ doc <- option noDocs docComment

319 ist <- get

321 ist <- get

320 let initOpts = if default_total ist

322 let initOpts = if default_total ist

321 then [TotalFn]

323 then [TotalFn]

@@ -382,6 +384,7 @@ fnOpts :: [FnOpt] -> IdrisParser [FnOpt]

382fnOpts opts

384fnOpts opts

383 = do reserved "total"; fnOpts (TotalFn : opts)

385 = do reserved "total"; fnOpts (TotalFn : opts)

384 <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))

386 <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))

387+ <|> do reserved "covering"; fnOpts (CoveringFn : (opts \\ [TotalFn]))

385 <|> do try (lchar '%' *> reserved "export"); c <- stringLiteral;

388 <|> do try (lchar '%' *> reserved "export"); c <- stringLiteral;

386 fnOpts (CExport c : opts)

389 fnOpts (CExport c : opts)

387 <|> do try (lchar '%' *> reserved "assert_total");

390 <|> do try (lchar '%' *> reserved "assert_total");

@@ -413,7 +416,7 @@ Postulate ::=

413@

416@

414-}

417-}

415postulate :: SyntaxInfo -> IdrisParser PDecl

418postulate :: SyntaxInfo -> IdrisParser PDecl

416−postulate syn = do doc <- try $ do doc <- option ("", []) docComment

419+postulate syn = do doc <- try $ do doc <- option noDocs docComment

417 pushIndent

420 pushIndent

418 reserved "postulate"

421 reserved "postulate"

419 return doc

422 return doc

@@ -561,7 +564,7 @@ Class ::=

561-}

564-}

562class_ :: SyntaxInfo -> IdrisParser [PDecl]

565class_ :: SyntaxInfo -> IdrisParser [PDecl]

563class_ syn = do (doc, acc) <- try (do

566class_ syn = do (doc, acc) <- try (do

564− doc <- option ("", []) docComment

567+ doc <- option noDocs docComment

565 acc <- optional accessibility

568 acc <- optional accessibility

566 return (doc, acc))

569 return (doc, acc))

567 reserved "class"; fc <- getFC; cons <- constraintList syn; n_in <- fnName

570 reserved "class"; fc <- getFC; cons <- constraintList syn; n_in <- fnName

@@ -1003,8 +1006,8 @@ directive syn = do try (lchar '%' *> reserved "lib"); cgn <- codegen_; lib <- st

1003 mapM_ (addNameHint ty') ns

1006 mapM_ (addNameHint ty') ns

1004 mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]

1007 mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]

1005 <|> do try (lchar '%' *> reserved "error_handlers")

1008 <|> do try (lchar '%' *> reserved "error_handlers")

1006− fn <- iName []

1009+ fn <- fnName

1007− arg <- iName []

1010+ arg <- fnName

1008 ns <- sepBy1 name (lchar ',')

1011 ns <- sepBy1 name (lchar ',')

1009 return [PDirective (do fn' <- disambiguate fn

1012 return [PDirective (do fn' <- disambiguate fn

1010 ns' <- mapM disambiguate ns

1013 ns' <- mapM disambiguate ns

@@ -1113,7 +1116,8 @@ findFC x = let s = show (plain x) in

1113 case span (/= ':') s of

1116 case span (/= ':') s of

1114 (failname, ':':rest) -> case span isDigit rest of

1117 (failname, ':':rest) -> case span isDigit rest of

1115 (line, ':':rest') -> case span isDigit rest' of

1118 (line, ':':rest') -> case span isDigit rest' of

1119+ (col, ':':msg) -> let pos = (read line, read col) in

1116− (col, ':':msg) -> (FC failname (read line) (read col), msg)

1120+ (FC failname pos pos, msg)

1117

1121

1118-- | A program is a list of declarations, possibly with associated

1122-- | A program is a list of declarations, possibly with associated

1119-- documentation strings.

1123-- documentation strings.

@@ -1129,7 +1133,7 @@ parseProg syn fname input mrk

1129 case idris_outputmode i of

1133 case idris_outputmode i of

1130 RawOutput -> ihputStrLn (idris_outh i) (show doc)

1134 RawOutput -> ihputStrLn (idris_outh i) (show doc)

1131 IdeSlave n -> ihWarn (idris_outh i) fc (P.text msg)

1135 IdeSlave n -> ihWarn (idris_outh i) fc (P.text msg)

1132− putIState (i { errLine = Just (fc_line fc) }) -- Just errl })

1136+ putIState (i { errSpan = Just fc })

1133 return []

1137 return []

1134 Success (x, i) -> do putIState i

1138 Success (x, i) -> do putIState i

1135 reportParserWarnings

1139 reportParserWarnings

@@ -1147,7 +1151,7 @@ parseProg syn fname input mrk

1147loadModule :: Handle -> FilePath -> Idris String

1151loadModule :: Handle -> FilePath -> Idris String

1148loadModule outh f

1152loadModule outh f

1149 = idrisCatch (loadModule' outh f)

1153 = idrisCatch (loadModule' outh f)

1150− (\e -> do setErrLine (getErrLine e)

1154+ (\e -> do setErrSpan (getErrSpan e)

1151 ist <- getIState

1155 ist <- getIState

1152 msg <- showErr e

1156 msg <- showErr e

1153 ihputStrLn outh msg

1157 ihputStrLn outh msg

@@ -1195,7 +1199,7 @@ loadFromIFile h (LIDR fn) = loadSource' h True fn

1195loadSource' :: Handle -> Bool -> FilePath -> Idris ()

1199loadSource' :: Handle -> Bool -> FilePath -> Idris ()

1196loadSource' h lidr r

1200loadSource' h lidr r

1197 = idrisCatch (loadSource h lidr r)

1201 = idrisCatch (loadSource h lidr r)

1198− (\e -> do setErrLine (getErrLine e)

1202+ (\e -> do setErrSpan (getErrSpan e)

1199 ist <- getIState

1203 ist <- getIState

1200 ihRenderError h (pprintErr ist e))

1204 ihRenderError h (pprintErr ist e))

1201

1205

src/Idris/Prover.hs+9−8

@@ -89,10 +89,10 @@ elabStep st e = do case runStateT e st of

89 Error a -> ierror a

90

91dumpState :: IState -> ProofState -> Idris ()

92−dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

92+dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

93 do rendered <- iRender $ prettyName False [] nm <> colon <+> text "No more goals."

94 iputGoal rendered

95−dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = do

95+dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _ _) = do

96 let OK ty = goalAtFocus ps

97 let OK env = envAtFocus ps

98 let state = prettyOtherGoals hs <> line <>

@@ -104,7 +104,7 @@ dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = d

104 where

105 showImplicits = opt_showimp (idris_options ist)

106

107− tPretty bnd t = pprintPTerm showImplicits bnd $ delab ist t

107+ tPretty bnd t = pprintPTerm showImplicits bnd [] $ delab ist t

108

109 assumptionNames :: Env -> [Name]

110 assumptionNames = map fst

@@ -164,6 +164,7 @@ receiveInput e =

164ploop :: Name -> Bool -> String -> [String] -> ElabState [PDecl] -> Maybe History -> Idris (Term, [String])

165ploop fn d prompt prf e h

166 = do i <- getIState

167+ let autoSolve = opt_autoSolve (idris_options i)

167 when d $ dumpState i (proof e)

168 when d $ dumpState i (proof e)

168 (x, h') <-

169 (x, h') <-

169 case idris_outputmode i of

170 case idris_outputmode i of

@@ -235,8 +236,8 @@ ploop fn d prompt prf e h

235 TType _ ->

236 TType _ ->

236 ihPrintTermWithType h (prettyImp imp PType) type1Doc

237 ihPrintTermWithType h (prettyImp imp PType) type1Doc

237 _ -> let bnd = map (\x -> (fst x, False)) env in

238 _ -> let bnd = map (\x -> (fst x, False)) env in

238− ihPrintTermWithType h (pprintPTerm imp bnd (delab ist tm))

239+ ihPrintTermWithType h (pprintPTerm imp bnd [] (delab ist tm))

239− (pprintPTerm imp bnd (delab ist ty))

240+ (pprintPTerm imp bnd [] (delab ist ty))

240 putIState ist

241 putIState ist

241 return (False, e, False, prf))

242 return (False, e, False, prf))

242 (\err -> do putIState ist { tt_ctxt = ctxt } ; ierror err)

243 (\err -> do putIState ist { tt_ctxt = ctxt } ; ierror err)

@@ -253,14 +254,14 @@ ploop fn d prompt prf e h

253 let tm' = force (normaliseAll ctxt' env tm)

254 let tm' = force (normaliseAll ctxt' env tm)

254 ty' = force (normaliseAll ctxt' env ty)

255 ty' = force (normaliseAll ctxt' env ty)

255 imp = opt_showimp (idris_options ist')

256 imp = opt_showimp (idris_options ist')

256− tmDoc = pprintPTerm imp bnd (delab ist' tm')

257+ tmDoc = pprintPTerm imp bnd [] (delab ist' tm')

257− tyDoc = pprintPTerm imp bnd (delab ist' ty')

258+ tyDoc = pprintPTerm imp bnd [] (delab ist' ty')

258 ihPrintTermWithType (idris_outh ist') tmDoc tyDoc

259 ihPrintTermWithType (idris_outh ist') tmDoc tyDoc

259 putIState ist

260 putIState ist

260 return (False, e, False, prf))

261 return (False, e, False, prf))

261 (\err -> do putIState ist ; ierror err)

262 (\err -> do putIState ist ; ierror err)

262 Success tac -> do (_, e) <- elabStep e saveState

263 Success tac -> do (_, e) <- elabStep e saveState

263− (_, st) <- elabStep e (runTac True i fn tac)

264+ (_, st) <- elabStep e (runTac autoSolve i fn tac)

264-- trace (show (problems (proof st))) $

265-- trace (show (problems (proof st))) $

265 iPrintResult ""

266 iPrintResult ""

266 return (True, st, False, prf ++ [step]))

267 return (True, st, False, prf ++ [step]))

src/Idris/REPL.hs+51−10

@@ -4,12 +4,14 @@

4module Idris.REPL where

5

6import Idris.AbsSyntax

7+import Idris.Apropos (apropos)

7import Idris.REPLParser

8import Idris.REPLParser

8import Idris.ElabDecls

9import Idris.ElabDecls

9import Idris.ElabTerm

10import Idris.ElabTerm

10import Idris.Error

11import Idris.Error

11import Idris.ErrReverse

12import Idris.ErrReverse

12import Idris.Delaborate

13import Idris.Delaborate

14+import Idris.Docstrings (Docstring, overview, renderDocstring)

13import Idris.Prover

15import Idris.Prover

14import Idris.Parser

16import Idris.Parser

15import Idris.Primitives

17import Idris.Primitives

@@ -21,7 +23,7 @@ import Idris.Completion

21import qualified Idris.IdeSlave as IdeSlave

23import qualified Idris.IdeSlave as IdeSlave

22import Idris.Chaser

24import Idris.Chaser

23import Idris.Imports

25import Idris.Imports

24−import Idris.Colours

26+import Idris.Colours hiding (colourise)

25import Idris.Inliner

27import Idris.Inliner

26import Idris.CaseSplit

28import Idris.CaseSplit

27import Idris.DeepSeq

29import Idris.DeepSeq

@@ -42,6 +44,7 @@ import IRTS.Compiler

42import IRTS.CodegenCommon

44import IRTS.CodegenCommon

43

45

44import Data.List.Split (splitOn)

46import Data.List.Split (splitOn)

47+import qualified Data.Text as T

45

48

46import Text.Trifecta.Result(Result(..))

49import Text.Trifecta.Result(Result(..))

47

50

@@ -238,7 +241,7 @@ ideslave orig mods

238 isetPrompt (mkPrompt [filename])

241 isetPrompt (mkPrompt [filename])

239 -- Report either success or failure

242 -- Report either success or failure

240 i <- getIState

243 i <- getIState

241− case (errLine i) of

244+ case (errSpan i) of

242 Nothing -> iPrintResult $ "loaded " ++ filename

245 Nothing -> iPrintResult $ "loaded " ++ filename

243 Just x -> iPrintError $ "didn't load " ++ filename

246 Just x -> iPrintError $ "didn't load " ++ filename

244 ideslave orig [filename]

247 ideslave orig [filename]

@@ -246,7 +249,7 @@ ideslave orig mods

246 case splitName name of

249 case splitName name of

247 Left err -> iPrintError err

250 Left err -> iPrintError err

248 Right n -> process stdout "(ideslave)"

251 Right n -> process stdout "(ideslave)"

249− (Check (PRef (FC "(ideslave)" 0 0) n))

252+ (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))

250 Just (IdeSlave.DocsFor name) ->

253 Just (IdeSlave.DocsFor name) ->

251 case splitName name of

254 case splitName name of

252 Left err -> iPrintError err

255 Left err -> iPrintError err

@@ -263,6 +266,25 @@ ideslave orig mods

263 process stdout fn (MakeWith False line (sUN name))

266 process stdout fn (MakeWith False line (sUN name))

264 Just (IdeSlave.ProofSearch line name hints) ->

267 Just (IdeSlave.ProofSearch line name hints) ->

265 process stdout fn (DoProofSearch False line (sUN name) (map sUN hints))

268 process stdout fn (DoProofSearch False line (sUN name) (map sUN hints))

269+ Just (IdeSlave.Apropos a) ->

270+ process stdout fn (Apropos a)

271+ Just (IdeSlave.GetOpts) ->

272+ do ist <- getIState

273+ let opts = idris_options ist

274+ let impshow = opt_showimp opts

275+ let errCtxt = opt_errContext opts

276+ let options = (IdeSlave.SymbolAtom "ok",

277+ [(IdeSlave.SymbolAtom "show-implicits", impshow),

278+ (IdeSlave.SymbolAtom "error-context", errCtxt)])

279+ runIO . putStrLn $ IdeSlave.convSExp "return" options id

280+ Just (IdeSlave.SetOpt IdeSlave.ShowImpl b) ->

281+ do setImpShow b

282+ let msg = (IdeSlave.SymbolAtom "ok", b)

283+ runIO . putStrLn $ IdeSlave.convSExp "return" msg id

284+ Just (IdeSlave.SetOpt IdeSlave.ErrContext b) ->

285+ do setErrContext b

286+ let msg = (IdeSlave.SymbolAtom "ok", b)

287+ runIO . putStrLn $ IdeSlave.convSExp "return" msg id

266 Nothing -> do iPrintError "did not understand")

288 Nothing -> do iPrintError "did not understand")

267 (\e -> do iPrintError $ show e))

289 (\e -> do iPrintError $ show e))

268 (\e -> do iPrintError $ show e)

290 (\e -> do iPrintError $ show e)

@@ -334,6 +356,8 @@ ideslaveProcess fn (MakeWith False pos str) = process stdout fn (MakeWith False

334ideslaveProcess fn (DoProofSearch False pos str xs) = process stdout fn (DoProofSearch False pos str xs)

356ideslaveProcess fn (DoProofSearch False pos str xs) = process stdout fn (DoProofSearch False pos str xs)

335ideslaveProcess fn (SetConsoleWidth w) = do process stdout fn (SetConsoleWidth w)

357ideslaveProcess fn (SetConsoleWidth w) = do process stdout fn (SetConsoleWidth w)

336 iPrintResult ""

358 iPrintResult ""

359+ideslaveProcess fn (Apropos a) = do process stdout fn (Apropos a)

360+ iPrintResult ""

337ideslaveProcess fn _ = iPrintError "command not recognized or not supported"

361ideslaveProcess fn _ = iPrintError "command not recognized or not supported"

338

362

339

363

@@ -412,8 +436,8 @@ edit f orig

412 = do i <- getIState

436 = do i <- getIState

413 env <- runIO $ getEnvironment

437 env <- runIO $ getEnvironment

414 let editor = getEditor env

438 let editor = getEditor env

415− let line = case errLine i of

439+ let line = case errSpan i of

416− Just l -> " +" ++ show l ++ " "

440+ Just l -> " +" ++ show (fst (fc_start l)) ++ " "

417 Nothing -> " "

441 Nothing -> " "

418 let cmd = editor ++ line ++ fixName f

442 let cmd = editor ++ line ++ fixName f

419 runIO $ system cmd

443 runIO $ system cmd

@@ -511,7 +535,7 @@ process h fn (Check (PRef _ n))

511 annotate (AnnName n Nothing Nothing) (text $ show n) <+> colon <+>

535 annotate (AnnName n Nothing Nothing) (text $ show n) <+> colon <+>

512 align (tPretty bnd ist g)

536 align (tPretty bnd ist g)

513

537

514− tPretty bnd ist t = pprintPTerm (opt_showimp (idris_options ist)) bnd t

538+ tPretty bnd ist t = pprintPTerm (opt_showimp (idris_options ist)) bnd [] t

515

539

516

540

517process h fn (Check t)

541process h fn (Check t)

@@ -710,7 +734,7 @@ process h fn (MakeWith updatefile l n)

710 runIO $ copyFile fb fn

734 runIO $ copyFile fb fn

711 else ihPrintResult h with

735 else ihPrintResult h with

712 where getIndent s = length (takeWhile isSpace s)

736 where getIndent s = length (takeWhile isSpace s)

713−

737+

714process h fn (DoProofSearch updatefile l n hints)

738process h fn (DoProofSearch updatefile l n hints)

715 = do src <- runIO $ readFile fn

739 = do src <- runIO $ readFile fn

716 let (before, tyline : later) = splitAt (l-1) (lines src)

740 let (before, tyline : later) = splitAt (l-1) (lines src)

@@ -932,6 +956,8 @@ process h fn (SetOpt ShowImpl) = setImpShow True

932process h fn (UnsetOpt ShowImpl) = setImpShow False

956process h fn (UnsetOpt ShowImpl) = setImpShow False

933process h fn (SetOpt ShowOrigErr) = setShowOrigErr True

957process h fn (SetOpt ShowOrigErr) = setShowOrigErr True

934process h fn (UnsetOpt ShowOrigErr) = setShowOrigErr False

958process h fn (UnsetOpt ShowOrigErr) = setShowOrigErr False

959+process h fn (SetOpt AutoSolve) = setAutoSolve True

960+process h fn (UnsetOpt AutoSolve) = setAutoSolve False

935

961

936process h fn (SetOpt _) = iPrintError "Not a valid option"

962process h fn (SetOpt _) = iPrintError "Not a valid option"

937process h fn (UnsetOpt _) = iPrintError "Not a valid option"

963process h fn (UnsetOpt _) = iPrintError "Not a valid option"

@@ -950,6 +976,21 @@ process h fn ListErrorHandlers =

950 iPrintResult $ "Registered error handlers: " ++ (concat . intersperse ", " . map show) handlers

976 iPrintResult $ "Registered error handlers: " ++ (concat . intersperse ", " . map show) handlers

951process h fn (SetConsoleWidth w) = setWidth w

977process h fn (SetConsoleWidth w) = setWidth w

952

978

979+process h fn (Apropos a) =

980+ do ist <- getIState

981+ let impl = opt_showimp (idris_options ist)

982+ let names = apropos ist (T.pack a)

983+ let aproposInfo = [ (n,

984+ delabTy ist n,

985+ fmap (overview . fst) (lookupCtxtExact n (idris_docstrings ist)))

986+ | n <- sort names, isUN n ]

987+ ihRenderResult h $ vsep (map (renderApropos impl) aproposInfo)

988+ where renderApropos impl (name, ty, docs) =

989+ prettyName True [] name <+> colon <+> align (prettyImp impl ty) <$>

990+ fromMaybe empty (fmap (\d -> renderDocstring d <> line) docs)

991+ isUN (UN _) = True

992+ isUN (NS n _) = isUN n

993+ isUN _ = False

953

994

954classInfo :: ClassInfo -> Idris ()

995classInfo :: ClassInfo -> Idris ()

955classInfo ci = do iputStrLn "Methods:\n"

996classInfo ci = do iputStrLn "Methods:\n"

@@ -1123,7 +1164,7 @@ loadInputs h inputs

1123 -- to check everything worked consistently (in particular, will catch

1164 -- to check everything worked consistently (in particular, will catch

1124 -- if the ibc version is out of date) if we weren't loading per

1165 -- if the ibc version is out of date) if we weren't loading per

1125 -- module

1166 -- module

1126− case errLine inew of

1167+ case errSpan inew of

1127 Nothing ->

1168 Nothing ->

1128 do putIState ist

1169 do putIState ist

1129 when (not loadCode) $ tryLoad $ nub (concat ifiles)

1170 when (not loadCode) $ tryLoad $ nub (concat ifiles)

@@ -1131,10 +1172,10 @@ loadInputs h inputs

1131 putIState inew)

1172 putIState inew)

1132 (\e -> do i <- getIState

1173 (\e -> do i <- getIState

1133 case e of

1174 case e of

1134− At f _ -> do setErrLine (fc_line f)

1175+ At f _ -> do setErrSpan f

1135 ihRenderError stdout $ pprintErr i e

1176 ihRenderError stdout $ pprintErr i e

1136 ProgramLineComment -> return () -- fail elsewhere

1177 ProgramLineComment -> return () -- fail elsewhere

1137− _ -> do setErrLine 3 -- FIXME! Propagate it

1178+ _ -> do setErrSpan emptyFC -- FIXME! Propagate it

1138 iputStrLn (pshow i e))

1179 iputStrLn (pshow i e))

1139 where -- load all files, stop if any fail

1180 where -- load all files, stop if any fail

1140 tryLoad :: [IFileType] -> Idris ()

1181 tryLoad :: [IFileType] -> Idris ()

src/Idris/REPLParser.hs+2

@@ -98,6 +98,7 @@ pCmd = do P.whiteSpace; try (do cmd ["q", "quit"]; eof; return Quit)

98 <|> try (do cmd ["patt"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Pattelab t))

99 <|> try (do cmd ["errorhandlers"]; eof ; return ListErrorHandlers)

100 <|> try (do cmd ["consolewidth"]; w <- pConsoleWidth ; return (SetConsoleWidth w))

101+ <|> try (do cmd ["apropos"]; str <- many anyChar ; return (Apropos str))

101 <|> do P.whiteSpace; do eof; return NOP

102 <|> do P.whiteSpace; do eof; return NOP

102 <|> do t <- P.fullExpr defaultSyntax; return (Eval t)

103 <|> do t <- P.fullExpr defaultSyntax; return (Eval t)

103

104

@@ -107,6 +108,7 @@ pOption :: P.IdrisParser Opt

107pOption = do discard (P.symbol "errorcontext"); return ErrContext

108pOption = do discard (P.symbol "errorcontext"); return ErrContext

108 <|> do discard (P.symbol "showimplicits"); return ShowImpl

109 <|> do discard (P.symbol "showimplicits"); return ShowImpl

109 <|> do discard (P.symbol "originalerrors"); return ShowOrigErr

110 <|> do discard (P.symbol "originalerrors"); return ShowOrigErr

111+ <|> do discard (P.symbol "autosolve"); return AutoSolve

110

112

111pConsoleWidth :: P.IdrisParser ConsoleWidth

113pConsoleWidth :: P.IdrisParser ConsoleWidth

112pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth

114pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth

src/Idris/Unlit.hs+2−2

@@ -24,8 +24,8 @@ check f l [x] = return ()

24check f l [] = return ()

25

26chkAdj :: FilePath -> Int -> LineType -> LineType -> TC ()

27−chkAdj f l Prog Comm = tfail $ At (FC f l 0) ProgramLineComment --TODO: Include column?

27+chkAdj f l Prog Comm = tfail $ At (FC f (l, 0) (l, 0)) ProgramLineComment --TODO: Span correctly

28−chkAdj f l Comm Prog = tfail $ At (FC f l 0) ProgramLineComment --TODO: Include column?

28+chkAdj f l Comm Prog = tfail $ At (FC f (l, 0) (l, 0)) ProgramLineComment --TODO: Span correctly

29chkAdj f l _ _ = return ()

30

31

src/Pkg/Package.hs+2−2

@@ -52,7 +52,7 @@ buildPkg warnonly (install, fp)

52 Nothing -> exitWith (ExitFailure 1)

53 Just ist -> do

54 -- Quit with error code if there was a problem

55− case errLine ist of

55+ case errSpan ist of

56 Just _ -> exitWith (ExitFailure 1)

57 _ -> return ()

58 -- Also give up if there are metavariables to solve

@@ -85,7 +85,7 @@ checkPkg warnonly quit fpath

85 when quit $ case res of

86 Nothing -> exitWith (ExitFailure 1)

87 Just res' -> do

88− case errLine res' of

88+ case errSpan res' of

89 Just _ -> exitWith (ExitFailure 1)

90 _ -> return ()

91

test/Makefile+3−3

@@ -8,13 +8,13 @@ test: $(TESTS)

8 @perl ./runtest.pl $(patsubst %.test,%,$@)

9

10test_java:

11− perl ./runtest.pl without buffer001 --codegen Java

11+ perl ./runtest.pl without sugar004 buffer001 --codegen Java

12

13test_js:

14− @perl ./runtest.pl without reg029 io001 dsl002 io003 effects001 effects002 buffer001 bounded001 --codegen node

14+ @perl ./runtest.pl without sugar004 reg029 io001 dsl002 io003 effects001 effects002 buffer001 bounded001 folding002 --codegen node

15

16test_llvm:

17− @perl ./runtest.pl without io003 buffer001 --codegen llvm

17+ @perl ./runtest.pl without sugar004 io003 buffer001 --codegen llvm

18

19update:

20 /usr/bin/env perl ./runtest.pl all -u

test/README+1

@@ -12,5 +12,6 @@ primitives: Primitive types

12proof: Theorem proving, tactics

13sugar: Syntactic sugar, syntax extensions

14totality: Totality checking

15+tutorial: Examples from the tutorial

15

16

16reg: Regression tests, covering previous bug fixes

17reg: Regression tests, covering previous bug fixes

test/basic006/expected+7−6

@@ -1,13 +1,14 @@

1When elaborating right hand side of foo:

2−test020a.idr:14:18:Can't unify

2+test020a.idr:14:18:When elaborating an application of function Prelude.List.reverse:

3− Vect n a

4−with

5− List a

6−

7−Specifically:

8 Can't unify

3 Can't unify

9 Vect n a

4 Vect n a

10 with

5 with

11 List a

6 List a

7+

8+ Specifically:

9+ Can't unify

10+ Vect n a

11+ with

12+ List a

12[3, 2, 1]

13[3, 2, 1]

13"Number 42"

14"Number 42"

test/basic009/expected+2−1

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

1MAIN-PASS

2Faulty.idr:6:7:When elaborating type of Faulty.fault:

3+When elaborating an application of type constructor =:

3−Can't disambiguate name: A.num, B.C.num

4+ Can't disambiguate name: A.num, B.C.num

4Multiple.idr:3:1:import alias not unique: "X"

5Multiple.idr:3:1:import alias not unique: "X"

test/effects001/test021.idr+7−9

@@ -5,11 +5,11 @@ import Effect.State

5import Effect.StdIO

6import Control.IOExcept

7

8−data FName = Count | NotCount

8+data Count : Type where

9

10FileIO : Type -> Type -> Type

11FileIO st t

12− = Eff (IOExcept String) [FILE_IO st, STDIO, Count ::: STATE Int] t

12+ = { [FILE_IO st, STDIO, Count ::: STATE Int] } Eff IO t

13

14readFile : FileIO (OpenFile Read) (List String)

15readFile = readAcc [] where

@@ -22,14 +22,12 @@ readFile = readAcc [] where

22 else return (reverse acc)

23

24testFile : FileIO () ()

25−testFile = do open "testFile" Read

25+testFile = do True <- open "testFile" Read | False => putStrLn "Error!"

26− if_valid then do putStrLn (show !readFile)

26+ putStrLn (show !readFile)

27− close

27+ close

28− putStrLn (show !(Count :- get))

28+ putStrLn (show !(Count :- get))

29− else putStrLn ("Error!")

30

29

31main : IO ()

30main : IO ()

32−main = do ioe_run (run [(), (), Count := 0] testFile)

31+main = run testFile

33− (\err => print err) (\ok => return ())

34

32

35

33

test/effects001/test021a.idr+2−2

@@ -17,7 +17,7 @@ Env = List (String, Integer)

17-- Evaluator t

18-- = Eff m [EXCEPTION String, RND, STATE Env] t

19

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

20+eval : Expr -> { [EXCEPTION String, STDIO, RND, STATE Env] } Eff IO Integer

21eval (Var x) = do vs <- get

22 case lookup x vs of

23 Nothing => raise ("No such variable " ++ x)

@@ -32,7 +32,7 @@ testExpr : Expr

32testExpr = Add (Add (Var "foo") (Val 42)) (Random 100)

33

34runEval : List (String, Integer) -> Expr -> IO Integer

35−runEval args expr = run [(), (), 123456, args] (eval expr)

35+runEval args expr = runInit [(), (), 123456, args] (eval expr)

36

37main : IO ()

38main = do let x = 42

test/effects002/test025.idr+4−4

@@ -5,8 +5,8 @@ import Effect.Memory

5import Control.IOExcept

6

7MemoryIO : Type -> Type -> Type -> Type

8−MemoryIO td ts r = Eff (IOExcept String) [ Dst ::: RAW_MEMORY td

8+MemoryIO td ts r = { [ Dst ::: RAW_MEMORY td

9− , Src ::: RAW_MEMORY ts ] r

9+ , Src ::: RAW_MEMORY ts ] } Eff (IOExcept String) r

10

11inpVect : Vect 5 Bits8

12inpVect = map prim__truncInt_B8 [0, 1, 2, 3, 5]

@@ -28,7 +28,7 @@ testMemory = do Src :- allocate 5

28 return (map (prim__zextB8_Int) res)

29

30main : IO ()

31−main = do ioe_run (run [Dst := (), Src := ()] testMemory)

31+main = ioe_run (runInit [Dst := (), Src := ()] testMemory)

32− (\err => print err) (\ok => print ok)

32+ (\err => print err) (\ok => print ok)

33

34

test/error003/ErrorReflection.idr−11

@@ -59,17 +59,6 @@ dslerr (CantUnify _ tm1 tm2 _ _ _) = do tm1' <- getTmTy tm1

59 ty1 <- reifyTy tm1'

60 ty2 <- reifyTy tm2'

61 return [TextPart $ "DSL type error: " ++ (show ty1) ++ " doesn't match " ++(show ty2)]

62−dslerr (At (FileLoc f l c) err) = do err' <- dslerr err

63− return [ TextPart "In file"

64− , TextPart f

65− , TextPart "line", TextPart (cast l)

66− , TextPart "column", TextPart (cast c)

67− , SubReport err']

68−dslerr (Elaborating s n err) = do err' <- dslerr err

69− return ([ TextPart $ "When elaborating " ++ s

70− , NamePart n

71− , TextPart ":"

72− , SubReport err'])

73dslerr _ = Nothing

62dslerr _ = Nothing

74

63

75

64

test/error003/expected+2−3

@@ -1,3 +1,2 @@

1−In file ErrorReflection.idr line 78 column 5

2− When elaborating right hand side of Main.bad :

1+ErrorReflection.idr:67:5:When elaborating right hand side of bad:

3− DSL type error: (t'(504) => t'(504)) doesn't match ()

2+DSL type error: (t(503) => t'(504)) doesn't match ()

test/error004/FunErrTest.idr+2−2

@@ -6,6 +6,7 @@ import Language.Reflection.Utils

6

7%language ErrorReflection

8

9+

9total

10total

10cadr : (xs : List a)

11cadr : (xs : List a)

11 -> {auto cons1 : isCons xs = True}

12 -> {auto cons1 : isCons xs = True}

@@ -18,7 +19,6 @@ extractList : TT -> Maybe TT

18extractList (App (App reflCon (App isCons lst)) _) = Just lst

19extractList (App (App reflCon (App isCons lst)) _) = Just lst

19extractList _ = Nothing

20extractList _ = Nothing

20

21

21−

22total

23has2elts : Err -> Maybe (List ErrorReportPart)

24has2elts (CantSolveGoal tm _) = do lst <- extractList tm

@@ -38,4 +38,4 @@ badCadr2 : Int

38badCadr2 = cadr [1]

39

40goodCadr : Int

41−goodCadr = cadr [1, 2]

41+goodCadr = cadr [1, 2]

test/error004/expected+4−2

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

1FunErrTest.idr:35:10:When elaborating right hand side of badCadr1:

2+When elaborating argument cons1 to function FunErrTest.cadr:

2−Could not prove that [] has at least two elements.

3+ Could not prove that [] has at least two elements.

3FunErrTest.idr:38:10:When elaborating right hand side of badCadr2:

4FunErrTest.idr:38:10:When elaborating right hand side of badCadr2:

5+When elaborating argument cons2 to function FunErrTest.cadr:

4−Could not prove that tail [(fromInteger 1)] refl has at least two elements.

6+ Could not prove that tail [(fromInteger 1)] refl has at least two elements.

test/folding001/expectednew file+4

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

1+([], []) -> ([], [])

2+([1], [1]) -> ([1], [1])

3+([1, 2, 3], [1, 2, 3]) -> ([1, 2, 3], [1, 2, 3])

4+([3, 2, 1], [3, 2, 1]) -> ([3, 2, 1], [3, 2, 1])

test/folding001/folding001.idrnew file+23

@@ -0,0 +1,23 @@

1+module Main

2+

3+-- foldr (::) [] converts to lists

4+foldToList : (Foldable t) => t a -> List a

5+foldToList = foldr (::) []

6+

7+showTestLine : List Int -> Vect n Int -> IO ()

8+showTestLine xs ys =

9+ putStrLn $ "(" ++

10+ show xs ++ ", " ++

11+ show ys ++ ") " ++

12+ "-> (" ++

13+ show (foldToList xs) ++ ", " ++

14+ show (foldToList ys) ++ ")"

15+

16+main : IO ()

17+main = do

18+ showTestLine [] []

19+ showTestLine [1] [1]

20+ showTestLine [1, 2, 3] [1, 2, 3]

21+ showTestLine [3, 2, 1] [3, 2, 1]

22+

23+

test/folding001/runnew file+4

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

1+#!/usr/bin/env bash

2+idris $@ folding001.idr -o folding001

3+./folding001

4+rm -f folding001 *.ibc

test/folding002/expectednew file+2

@@ -0,0 +1,2 @@

1+500000500000

2+500000500000

test/folding002/folding002.idrnew file+23

@@ -0,0 +1,23 @@

1+-- perform a very large foldr to test tail recursion

2+addAll : (Foldable t, Num a) => t a -> a

3+addAll = foldr (+) 0

4+

5+n : Integer

6+n = 1000000

7+

8+numbersList : List Bits64

9+numbersList = numbersList' n []

10+ where

11+ numbersList' : Integer -> List Bits64 -> List Bits64

12+ numbersList' 0 xs = xs

13+ numbersList' k xs = numbersList' (k - 1) (fromInteger k :: xs)

14+

15+numbersVect : Vect (length numbersList) Bits64

16+numbersVect = fromList numbersList

17+

18+main : IO ()

19+main = do

20+ putStrLn . show . prim__zextB64_BigInt $ addAll numbersVect

21+ putStrLn . show . prim__zextB64_BigInt $ addAll numbersList

22+

23+

test/folding002/runnew file+4

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

1+#!/usr/bin/env bash

2+idris $@ folding002.idr -o folding002

3+./folding002

4+rm -f folding002 *.ibc

test/proof002/expected+10−9

@@ -1,11 +1,12 @@

1−test030a.idr:12:14:When elaborating right hand side of testReflect1:

1+Reflect.idr:207:38:When elaborating right hand side of testReflect1:

2−Can't unify

2+When elaborating an application of function Reflect.getJust:

3− IsJust (Just x)

4−with

5− IsJust (prove (getProof x))

6−

7−Specifically:

8 Can't unify

3 Can't unify

9− Just x

4+ IsJust (Just x)

10 with

5 with

6+ IsJust (prove (getProof x))

7+

8+ Specifically:

9+ Can't unify

10+ Just x

11+ with

11− Nothing

12+ Nothing

test/reg007/expected+1−1

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

1reg007.lidr:8:1:A.n is already defined

2−reg007.lidr:12:9:When elaborating right hand side of hurrah:

2+reg007.lidr:12:11:When elaborating right hand side of hurrah:

3Can't unify

4 n = lala

5with

test/reg018/expected+2−2

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

1−reg018a.idr:16:1:conat.minusCoNat is not productive

1+reg018a.idr:16:1:conat.minusCoNat is possibly not total due to recursive path conat.minusCoNat

2reg018b.idr:8:1:A.showB is possibly not total due to recursive path A.showB

3−reg018c.idr:19:1:CodataTest.inf is not productive

3+reg018c.idr:19:1:CodataTest.inf is possibly not total due to: {CodataTest.inf19}

4reg018d.idr:5:1:Main.pull is not total as there are missing cases

test/reg034/expected+18−16

@@ -1,22 +1,24 @@

1reg034.idr:6:5:When elaborating left hand side of bar:

2−Can't unify

2+When elaborating an application of main.bar:

3− [92mlength[0m [95mys[0m [94m=[0m [92mlength[0m [95mys[0m

4−with

5− [92mlength[0m [95mxs[0m [94m=[0m [92mlength[0m [95mys[0m

6−

7−Specifically:

8 Can't unify

3 Can't unify

9− [92mlength[0m [95mys[0m

4+ [95mx[0m [94m=[0m [95mx[0m

10 with

5 with

11− [92mlength[0m [95mxs[0m

6+ [92mlength[0m [95mxs[0m [94m=[0m [92mlength[0m [95mys[0m

7+

8+ Specifically:

9+ Can't unify

10+ [92mlength[0m [95mys[0m

11+ with

12+ [92mlength[0m [95mxs[0m

12reg034.idr:9:5:When elaborating left hand side of foo:

13reg034.idr:9:5:When elaborating left hand side of foo:

13−Can't unify

14+When elaborating an application of main.foo:

14− [95mf[0m [95my[0m [94m=[0m [95mf[0m [95my[0m

15−with

16− [95mf[0m [95mx[0m [94m=[0m [95mf[0m [95my[0m

17−

18−Specifically:

19 Can't unify

15 Can't unify

20− [95mf[0m [95my[0m

16+ [95mx[0m [94m=[0m [95mx[0m

21 with

17 with

22− [95mf[0m [95mx[0m

18+ [95mf[0m [95mx[0m [94m=[0m [95mf[0m [95my[0m

19+

20+ Specifically:

21+ Can't unify

22+ [95mf[0m [95my[0m

23+ with

24+ [95mf[0m [95mx[0m

test/sugar004/expectednew file+3

@@ -0,0 +1,3 @@

1+No arguments!

2+42

3+Too many arguments!

test/sugar004/runnew file+6

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

1+#!/usr/bin/env bash

2+idris $@ sugar004.idr -o sugar004

3+./sugar004

4+./sugar004 42

5+./sugar004 42 100

6+rm -f sugar004 *.ibc

test/sugar004/sugar004.idrnew file+36

@@ -0,0 +1,36 @@

1+module Main

2+

3+import System

4+

5+total

6+foo : Maybe Int -> Int

7+foo x = let Just x' = x | Nothing => 100 in x'

8+

9+main : IO ()

10+main = do [p, a] <- getArgs | [p] => putStrLn "No arguments!"

11+ | (x :: y :: _) => putStrLn "Too many arguments!"

12+ print (foo (Just (cast a)))

13+

14+{-

15+

16+let pat = val | <alternatives> in x'

17+

18+...becomes...

19+

20+case val of

21+ pat => x'

22+ <alternatives>

23+

24+do pat <- val | <alternatives>

25+ p

26+

27+...becomes...

28+

29+do x <- val

30+ case x of

31+ pat => p

32+ <alternatives>

33+

34+-}

35+

36+

test/totality004/expectednew file+2

@@ -0,0 +1,2 @@

1+[1, 2, 2, 4, 3, 6, 4, 8, 5, 10]

2+totality004a.idr:13:1:Main.process is possibly not total due to recursive path Main.process --> Main.process --> Main.process

test/totality004/runnew file+5

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

1+#!/usr/bin/env bash

2+idris $@ totality004.idr -o totality004

3+./totality004

4+idris $@ --check totality004a.idr

5+rm -f totality004 *.ibc

test/totality004/totality004.idrnew file+25

@@ -0,0 +1,25 @@

1+module Main

2+

3+%default total

4+

5+data SP : Type -> Type -> Type where

6+ get : (a -> SP a b) -> SP a b

7+ put : b -> Inf (SP a b) -> SP a b

8+

9+copy : SP a a

10+copy = get (\x => put x copy)

11+

12+process : SP a b -> Stream a -> Stream b

13+process (get f) (x :: xs) = process (f x) xs

14+process (put b sp) xs = b :: process sp xs

15+

16+doubleInt : SP Nat Int

17+doubleInt = get (\x => put (the Int (cast x))

18+ (put (the Int (cast x) * 2) doubleInt))

19+

20+countStream : Nat -> Stream Nat

21+countStream x = x :: countStream (x + 1)

22+

23+main : IO ()

24+main = print (take 10 (process doubleInt (countStream 1)))

25+

test/totality004/totality004a.idrnew file+25

@@ -0,0 +1,25 @@

1+module Main

2+

3+%default total

4+

5+data SP : Type -> Type -> Type where

6+ get : (a -> SP a b) -> SP a b

7+ put : b -> Inf (SP a b) -> SP a b

8+

9+copy : SP a a

10+copy = get (\x => put x copy)

11+

12+process : SP a b -> Stream a -> Stream b

13+process (get f) (x :: xs) = process (f x) xs

14+process (put b sp) xs = process sp xs

15+

16+doubleInt : SP Nat Int

17+doubleInt = get (\x => put (the Int (cast x))

18+ (put (the Int (cast x) * 2) doubleInt))

19+

20+countStream : Nat -> Stream Nat

21+countStream x = x :: countStream (x + 1)

22+

23+main : IO ()

24+main = print (take 10 (process doubleInt (countStream 1)))

25+

test/totality005/expectednew file+2

@@ -0,0 +1,2 @@

1+totality005.idr:6:1:Main.fib is possibly not total due to recursive path Main.fib

2+[0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377]

test/totality005/runnew file+5

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

1+#!/usr/bin/env bash

2+idris $@ totality005.idr --total --check

3+idris $@ totality005.idr -o totality005

4+./totality005

5+rm -f totality005 *.ibc

test/totality005/totality005.idrnew file+9

@@ -0,0 +1,9 @@

1+

2+zipWithS : (f : a -> b -> c) -> Stream a -> Stream b -> Stream c

3+zipWithS f (x :: xs) (y :: ys) = f x y :: zipWithS f xs ys

4+

5+fib : Stream Nat

6+fib = 0 :: zipWithS (+) fib (1 :: fib)

7+

8+main : IO ()

9+main = print (take 15 fib)

test/tutorial001/expectednew file

No changes to the content.

test/tutorial001/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris --check tutorial001.idr

3+rm -f *.ibc

test/tutorial001/tutorial001.idrnew file+9

@@ -0,0 +1,9 @@

1+foo : Int -> Int

2+foo x = case isLT of

3+ Yes => x*2

4+ No => x*4

5+ where

6+ data MyLT = Yes | No

7+ isLT : MyLT

8+ isLT = if x < 20 then Yes else No

9+

test/tutorial002/expectednew file

No changes to the content.

test/tutorial002/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ tutorial002.idr --check

3+rm -f *.ibc

test/tutorial002/tutorial002.idrnew file+61

@@ -0,0 +1,61 @@

1+module Main

2+

3+data Binary : Nat -> Type where

4+ bEnd : Binary Z

5+ bO : Binary n -> Binary (n + n)

6+ bI : Binary n -> Binary (S (n + n))

7+

8+instance Show (Binary n) where

9+ show (bO x) = show x ++ "0"

10+ show (bI x) = show x ++ "1"

11+ show bEnd = ""

12+

13+data Parity : Nat -> Type where

14+ even : Parity (n + n)

15+ odd : Parity (S (n + n))

16+

17+parity : (n:Nat) -> Parity n

18+parity Z = even {n=Z}

19+parity (S Z) = odd {n=Z}

20+parity (S (S k)) with (parity k)

21+ parity (S (S (j + j))) | even ?= even {n=S j}

22+ parity (S (S (S (j + j)))) | odd ?= odd {n=S j}

23+

24+natToBin : (n:Nat) -> Binary n

25+natToBin Z = bEnd

26+natToBin (S k) with (parity k)

27+ natToBin (S (j + j)) | even = bI (natToBin j)

28+ natToBin (S (S (j + j))) | odd ?= bO (natToBin (S j))

29+

30+intToNat : Int -> Nat

31+intToNat 0 = Z

32+intToNat x = if (x>0) then (S (intToNat (x-1))) else Z

33+

34+main : IO ()

35+main = do putStr "Enter a number: "

36+ x <- getLine

37+ print (natToBin (fromInteger (cast x)))

38+

39+---------- Proofs ----------

40+

41+Main.natToBin_lemma_1 = proof

42+ intros

43+ rewrite plusSuccRightSucc j j

44+ rewrite sym (plusSuccRightSucc j j)

45+ trivial

46+

47+

48+parity_lemma_1 = proof

49+ intros

50+ rewrite sym (plusSuccRightSucc j j)

51+ trivial

52+

53+

54+parity_lemma_2 = proof {

55+ intro;

56+ intro;

57+ rewrite sym (plusSuccRightSucc j j);

58+ trivial;

59+}

60+

61+

test/tutorial003/expectednew file

No changes to the content.

test/tutorial003/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ tutorial003.idr --check

3+rm -f *.ibc

test/tutorial003/tutorial003.idrnew file+38

@@ -0,0 +1,38 @@

1+module idiom

2+

3+data Expr = Var String

4+ | Val Int

5+ | Add Expr Expr

6+

7+data Eval : Type -> Type where

8+ MkEval : (List (String, Int) -> Maybe a) -> Eval a

9+

10+fetch : String -> Eval Int

11+fetch x = MkEval (\e => fetchVal e) where

12+ fetchVal : List (String, Int) -> Maybe Int

13+ fetchVal [] = Nothing

14+ fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs)

15+

16+instance Functor Eval where

17+ map f (MkEval g) = MkEval (\e => map f (g e))

18+

19+instance Applicative Eval where

20+ pure x = MkEval (\e => Just x)

21+

22+ (<$>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where

23+ app : Maybe (a -> b) -> Maybe a -> Maybe b

24+ app (Just fx) (Just gx) = Just (fx gx)

25+ app _ _ = Nothing

26+

27+eval : Expr -> Eval Int

28+eval (Var x) = fetch x

29+eval (Val x) = [| x |]

30+eval (Add x y) = [| eval x + eval y |]

31+

32+runEval : List (String, Int) -> Expr -> Maybe Int

33+runEval env e = case eval e of

34+ MkEval envFn => envFn env

35+

36+m_add' : Maybe Int -> Maybe Int -> Maybe Int

37+m_add' x y = [| x + y |]

38+

test/tutorial004/expectednew file

No changes to the content.

test/tutorial004/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ tutorial004.idr --check

3+rm -f *.ibc

test/tutorial004/tutorial004.idrnew file+57

@@ -0,0 +1,57 @@

1+

2+fiveIsFive : 5 = 5

3+fiveIsFive = refl

4+

5+twoPlusTwo : 2 + 2 = 4

6+twoPlusTwo = refl

7+

8+total disjoint : (n : Nat) -> Z = S n -> _|_

9+disjoint n p = replace {P = disjointTy} p ()

10+ where

11+ disjointTy : Nat -> Type

12+ disjointTy Z = ()

13+ disjointTy (S k) = _|_

14+

15+total acyclic : (n : Nat) -> n = S n -> _|_

16+acyclic Z p = disjoint _ p

17+acyclic (S k) p = acyclic k (succInjective _ _ p)

18+

19+empty1 : _|_

20+empty1 = hd [] where

21+ hd : List a -> a

22+ hd (x :: xs) = x

23+

24+empty2 : _|_

25+empty2 = empty2

26+

27+plusReduces : (n:Nat) -> plus Z n = n

28+plusReduces n = refl

29+

30+plusReducesZ : (n:Nat) -> n = plus n Z

31+plusReducesZ Z = refl

32+plusReducesZ (S k) = cong (plusReducesZ k)

33+

34+plusReducesS : (n:Nat) -> (m:Nat) -> S (plus n m) = plus n (S m)

35+plusReducesS Z m = refl

36+plusReducesS (S k) m = cong (plusReducesS k m)

37+

38+plusReducesZ' : (n:Nat) -> n = plus n Z

39+plusReducesZ' Z = ?plusredZ_Z

40+plusReducesZ' (S k) = let ih = plusReducesZ' k in

41+ ?plusredZ_S

42+

43+

44+---------- Proofs ----------

45+

46+plusredZ_S = proof {

47+ intro;

48+ intro;

49+ rewrite ih;

50+ trivial;

51+}

52+

53+plusredZ_Z = proof {

54+ compute;

55+ trivial;

56+}

57+

test/tutorial005/expectednew file

No changes to the content.

test/tutorial005/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris $@ tutorial005.idr --check

3+rm -f *.ibc

test/tutorial005/tutorial005.idrnew file+14

@@ -0,0 +1,14 @@

1+module wheres

2+

3+even : Nat -> Bool

4+even Z = True

5+even (S k) = odd k where

6+ odd Z = False

7+ odd (S k) = even k

8+

9+test : List Nat

10+test = [c (S 1), c Z, d (S Z)]

11+ where c x = 42 + x

12+ d y = c (y + 1 + z y)

13+ where z w = y + w

14+

test/tutorial006/expectednew file+23

@@ -0,0 +1,23 @@

1+tutorial006a.idr:3:23:When elaborating right hand side of vapp:

2+When elaborating argument [95mxs[0m to constructor [91mPrelude.Vect.::[0m:

3+ Can't unify

4+ [94mVect[0m ([95mn[0m [92m+[0m [95mm[0m) [95ma[0m

5+ with

6+ [94mVect[0m ([92mplus[0m [95mn[0m [95mm[0m) [95ma[0m

7+

8+ Specifically:

9+ Can't unify

10+ [92mplus[0m [95mn[0m [95mm[0m

11+ with

12+ [92mplus[0m [95mn[0m [95mm[0m

13+tutorial006b.idr:10:10:When elaborating right hand side of Main.parity:

14+Can't unify

15+ [94mParity[0m ([92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m))

16+with

17+ [94mParity[0m ([91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m)))

18+

19+Specifically:

20+ Can't unify

21+ [92mplus[0m ([91mS[0m [95mj[0m) ([91mS[0m [95mj[0m)

22+ with

23+ [91mS[0m ([91mS[0m ([92mplus[0m [95mj[0m [95mj[0m))

test/tutorial006/runnew file+4

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

1+#!/usr/bin/env bash

2+idris $@ tutorial006a.idr --check

3+idris $@ tutorial006b.idr --check

4+rm -f *.ibc

test/tutorial006/tutorial006a.idrnew file+5

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

1+vapp : Vect n a -> Vect m a -> Vect (n + m) a

2+vapp Nil ys = ys

3+vapp (x :: xs) ys = x :: vapp xs xs -- BROKEN

4+

5+

test/tutorial006/tutorial006b.idrnew file+12

@@ -0,0 +1,12 @@

1+

2+data Parity : Nat -> Type where

3+ even : Parity (n + n)

4+ odd : Parity (S (n + n))

5+

6+parity : (n:Nat) -> Parity n

7+parity Z = even {n=Z}

8+parity (S Z) = odd {n=Z}

9+parity (S (S k)) with (parity k)

10+ parity (S (S (j + j))) | even = even {n=S j}

11+ parity (S (S (S (j + j)))) | odd = odd {n=S j}

12+