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

.travis.yml−1

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

2121env:

2222 # TESTS=doc

2323 - TESTS=test_c

24− - TESTS=test_java

2524 - TESTS=test_llvm

2625 - TESTS=test_js

CHANGELOG+18−9

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

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

55 type inference.

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

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

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

9−* Lots of performance patches for generated JavaScript

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

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

9+* Lots of performance patches for generated JavaScript.

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

11− or show the type of expressions

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

11+ or show the type of expressions.

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

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

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

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

15−||| Add two natural numbers

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

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

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

16+ ||| Add two natural numbers

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

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

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

1928

2029New in 0.9.11:

2130--------------

Makefile+1−1

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

3939 $(CABAL) install $(CABALFLAGS)

4040

4141linecount:

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

4343

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

4545doc: dist/setup-config

contribs/idrislang.sty+7−80

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

2424\RequirePackage{ifthen}

2525\RequirePackage{listings}

2626\RequirePackage{xspace}

27+\RequirePackage{textcomp}

2728%% ----------------------------------------------------------------- [ Options ]

2829\newboolean{literate}

2930\setboolean{literate}{false}

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

4849\lstdefinelanguage{idris}{%

4950 sensitive,%

5051%% ----------------------------------------------------------- [ Default Style ]

51− xleftmargin=\parindent,

52+ xleftmargin=1.5em,

5253 tabsize=2,

54+ upquote=true,

5355 basicstyle=\ttfamily,

5456 flexiblecolumns=false,

5557 commentstyle=\footnotesize\sffamily,

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

6365 total, trivial, try, using, where, with

6466},

6567%% ------------------------------------------------------- [ Prelude Functions ]

66−%% Generated using

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

6868 morekeywords={%

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

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

7070 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

13871 },

13972%% ---------------------------------------------------------------- [ Comments ]

14073 morecomment=[l]--,%

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

16699%% -------------------------------------------------- [ Default Listings Style ]

167100

168101\lstdefinestyle{default}{%

169− xleftmargin=\parindent,

170− tabsize=2,

171102 basicstyle=\ttfamily

172103}

173104\lstdefinestyle{numbers}{%

174− xleftmargin=\parindent,

175− tabsize=2,

176105 numbers=left,

177106 numbersep=10pt,

178107 numberstyle=\footnotesize\sffamily,

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

186115 {\ifthenelse{\boolean{literate}}{%

187116 \lstset{language=literateidris}}{%

188117 \lstset{language=idris}}

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

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

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

192− }

193− {}

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

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

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

194121%% ---------------------------------------------------------- [ Input Listings ]

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

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

idris.cabal+33−4

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

9797 libs/effects/Effect/*.idr

9898 libs/effects/*.idr

9999

100− libs/neweffects/Makefile

101− libs/neweffects/neweffects.ipkg

102− libs/neweffects/Effect/*.idr

103− libs/neweffects/*.idr

100+ libs/oldeffects/Makefile

101+ libs/oldeffects/oldeffects.ipkg

102+ libs/oldeffects/Effect/*.idr

103+ libs/oldeffects/*.idr

104104

105105 libs/javascript/*.idr

106106 libs/javascript/JavaScript/*.idr

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

381381 test/totality003/run

382382 test/totality003/*.idr

383383 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

384409

385410source-repository head

386411 type: git

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

430455

431456 , Idris.AbsSyntax

432457 , Idris.AbsSyntaxTree

458+ , Idris.Apropos

433459 , Idris.CaseSplit

434460 , Idris.Chaser

435461 , Idris.Colours

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

440466 , Idris.DeepSeq

441467 , Idris.Delaborate

442468 , Idris.Docs

469+ , Idris.Docstrings

443470 , Idris.ElabDecls

444471 , Idris.ElabTerm

445472 , Idris.Error

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

506533 , ansi-wl-pprint

507534 , binary

508535 , bytestring

536+ , cheapskate

509537 , containers >= 0.5

510538 , directory

511539 , directory >= 1.2

512540 , filepath

513541 , haskeline >= 0.7

514542 , language-java >= 0.2.6

543+ , lens >= 4.1.1

515544 , mtl

516545 , parsers >= 0.9

517546 , pretty

libs/Makefile+3−3

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

22 $(MAKE) -C prelude build

33 $(MAKE) -C base build

44 $(MAKE) -C effects build

5− $(MAKE) -C neweffects build

5+ $(MAKE) -C oldeffects build

66 $(MAKE) -C javascript build

77

88

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

1010 $(MAKE) -C prelude install

1111 $(MAKE) -C base install

1212 $(MAKE) -C effects install

13− $(MAKE) -C neweffects install

13+ $(MAKE) -C oldeffects install

1414 $(MAKE) -C javascript install

1515

1616clean:

1717 $(MAKE) -C prelude clean

1818 $(MAKE) -C base clean

1919 $(MAKE) -C effects clean

20− $(MAKE) -C neweffects clean

20+ $(MAKE) -C oldeffects clean

2121 $(MAKE) -C javascript clean

2222

2323.PHONY: build install clean

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

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

44

55%default total

66

7−-- An isomorphism between two types

7+||| An isomorphism between two types

88data Iso : Type -> Type -> Type where

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

1010 (from : b -> a) ->

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

1414

1515-- Isomorphism properties

1616

17+||| Isomorphism is reflexive

1718isoRefl : Iso a a

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

1920

21+||| Isomorphism is transitive

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

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

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

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

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

2931 x QED)

3032

33+||| Isomorphism is symmetric

3134isoSym : Iso a b -> Iso b a

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

3336

3437-- Isomorphisms over sums

3538

39+||| Disjunction is commutative

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

3741eitherComm = MkIso swap swap swapSwap swapSwap

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

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

4246 swapSwap (Left x) = refl

4347 swapSwap (Right x) = refl

4448

49+||| Disjunction is associative

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

4651eitherAssoc = MkIso eitherAssoc1 eitherAssoc2 ok1 ok2

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

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

6469 ok2 (Left (Right x)) = refl

6570 ok2 (Right x) = refl

6671

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

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

6874eitherBotLeft = MkIso to from ok1 ok2

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

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

7783 ok2 (Left x) = FalseElim x

7884 ok2 (Right x) = refl

7985

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

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

8188eitherBotRight = isoTrans eitherComm eitherBotLeft

8289

83−

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

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

8592eitherCong {a = a} {a' = a'} {b = b} {b' = b'}

8693 (MkIso to from toFrom fromTo)

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

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

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

98105

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

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

100108eitherCongLeft i = eitherCong i isoRefl

101109

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

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

103112eitherCongRight i = eitherCong isoRefl i

104113

105114-- Isomorphisms over products

115+||| Conjunction is commutative

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

107117pairComm = MkIso swap swap swapSwap swapSwap

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

109119 swap (x, y) = (y, x)

110−

120+

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

112122 swapSwap (x, y) = refl

113123

124+||| Conjunction is associative

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

115126pairAssoc = MkIso to from ok1 ok2

116127 where

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

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

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

125136

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

126138pairUnitRight : Iso (a, ()) a

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

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

129141 ok (x, ()) = refl

130142

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

131144pairUnitLeft : Iso ((), a) a

132145pairUnitLeft = isoTrans pairComm pairUnitRight

133146

147+||| Conjunction preserves falsehood

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

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

136150

151+||| Conjunction preserves falsehood

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

138153pairBotRight = isoTrans pairComm pairBotLeft

139154

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

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

141157pairCong {a = a} {a' = a'} {b = b} {b' = b'}

142158 (MkIso to from toFrom fromTo)

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

155171 rewrite fromTo' y in

156172 refl

157173

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

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

159176pairCongLeft i = pairCong i isoRefl

160177

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

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

162180pairCongRight = pairCong isoRefl

163181

164182-- Distributivity of products over sums

183+||| Products distribute over sums

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

166185distribLeft = MkIso to from toFrom fromTo

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

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

177196 fromTo (Left x, y) = refl

178197 fromTo (Right x, y) = refl

179198

199+||| Products distribute over sums

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

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

182202

183203

184204-- Enable preorder reasoning syntax over isomorphisms

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

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

186207qed a = isoRefl

187208

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

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

189211step a iso1 iso2 = isoTrans iso1 iso2

190212

191213

192214

193215-- Isomorphisms over Maybe

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

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

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

196219 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

200223 ok2 Nothing = refl

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

202225

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

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

204228maybeEither = MkIso to from iso1 iso2

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

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

215239 iso2 Nothing = refl

216240 iso2 (Just x) = refl

217241

242+||| Maybe of void is just unit

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

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

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

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

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

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

2424-- would require exposing the offset argument of prim__appendBuffer

2525

26−-- A contiguous chunk of n bytes

26+||| A contiguous chunk of n bytes

2727abstract

2828record Buffer : Nat -> Type where

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

libs/base/Data/HVect.idr+4

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

66%default total

77

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

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

910 data HVect : Vect k Type -> Type where

1011 Nil : HVect []

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

1213

14+ ||| Extract an element from an HVect

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

1416 index fZ (x::xs) = x

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

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

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

5052 show xs = show (shows xs)

5153

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

55+ ||| @ t the goal type

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

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

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

libs/base/Data/Sign.idr+2

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

11module Data.Sign

22

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

34data Sign = Plus | Minus

45

6+||| Discover the sign of some type

57class Signed t where

68 total sign : t -> Sign

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

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

1010--------------------------------------------------------------------------------

1111

1212using (xs : Vect k a)

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

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

1415 Here : Elem x (x::xs)

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

1617

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

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

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

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

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

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

2023

libs/base/Language/Reflection.idr+2

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

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

181181 | Reflect TT

182182 -- ^ turn a value into its reflected representation

183+ | ByReflection TT

184+ -- ^ use a %reflection function

183185 | Fill Raw

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

185187 | Exact TT

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

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

33import Language.Reflection

44

55data SourceLocation : Type where

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

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

77

88%name SourceLocation loc

99

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

3535 | AlreadyDefined TTName

3636 | ProofSearchFail Err

3737 | NoRewriting TT

38− | At SourceLocation Err

39− | Elaborating String TTName Err

4038 | ProviderError String

4139 | LoadingFailed String Err

4240

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

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

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

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

254254 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 ++ ")"

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

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

259257

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

44import System

55import Control.IOExcept

66

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

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

7+data Exception : Type -> Effect where

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

99

1010instance Handler (Exception a) Maybe where

1111 handle _ (Raise e) k = Nothing

1212

13+instance Handler (Exception a) List where

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

15+

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

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

1518 believe_me (exit 1)

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

2326EXCEPTION : Type -> EFFECT

2427EXCEPTION t = MkEff () (Exception t)

2528

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

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

2730raise err = Raise err

2831

2932

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

3134

3235

3336

34−

3537-- TODO: Catching exceptions mid program?

3638-- probably need to invoke a new interpreter

3739

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

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

66data OpenFile : Mode -> Type where

77 FH : File -> OpenFile m

88

9−data FileIO : Effect where

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

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

9+openOK : Mode -> Bool -> Type

10+openOK m True = OpenFile m

11+openOK m False = ()

1212

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

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

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

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

1617

18+ ReadLine : {OpenFile Read} FileIO String

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

20+ EOF : {OpenFile Read} FileIO Bool

1721

1822instance Handler FileIO IO where

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

2024 valid <- validFile h

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

22− else k (Left ()) False

25+ if valid then k True (FH h)

26+ else k False ()

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

2428 k () ()

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

26− k (FH h) str

30+ k str (FH h)

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

28− k (FH h) ()

32+ k () (FH h)

2933 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

34+ k e (FH h)

4535

4636FILE_IO : Type -> EFFECT

4737FILE_IO t = MkEff t FileIO

4838

4939open : Handler FileIO e =>

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

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

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

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

5242open f m = Open f m

5343

5444close : Handler FileIO e =>

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

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

5646close = Close

5747

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

48+readLine : Handler FileIO e =>

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

5950readLine = ReadLine

6051

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

52+writeLine : Handler FileIO e =>

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

6254writeLine str = WriteLine str

6355

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

56+eof : Handler FileIO e =>

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

6558eof = EOF

6659

6760

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

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

1212abstract

1313data RawMemory : Effect where

1414 Allocate : (n : Nat) ->

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

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

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

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

1717 Initialize : Bits8 ->

1818 (size : Nat) ->

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

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

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

2121 Peek : (offset : Nat) ->

2222 (size : Nat) ->

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

2526 Poke : (offset : Nat) ->

2627 (Vect size Bits8) ->

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

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

3031 (dst_offset : Nat) ->

3132 (src_offset : Nat) ->

3233 (size : Nat) ->

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

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

35− RawMemory (MemoryChunk dst_size dst_init)

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

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

36+ RawMemory () (MemoryChunk dst_size dst_init)

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

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

3839

3940private

4041do_malloc : Nat -> IOExcept String Ptr

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

7980instance Handler RawMemory (IOExcept String) where

8081 handle () (Allocate n) k

8182 = do ptr <- do_malloc n

82− k (CH ptr) ()

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

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

83+ k () (CH ptr)

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

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

8586 handle (CH ptr) (Free) k

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

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

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

89− k (CH ptr) res

90+ k res (CH ptr)

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

9192 = do ioe_lift (do_poke ptr offset content)

92− k (CH ptr) ()

93+ k () (CH ptr)

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

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

95− k (CH dest_ptr) ()

96+ k () (CH dest_ptr)

9697 handle chunk (GetRawPtr) k

9798 = k chunk chunk

9899

99100RAW_MEMORY : Type -> EFFECT

100101RAW_MEMORY t = MkEff t RawMemory

101102

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

103+allocate : (n : Nat) ->

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

103105allocate size = Allocate size

104106

105107initialize : {i : Nat} ->

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

107109 Bits8 ->

108110 (size : Nat) ->

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

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

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

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

111114initialize c size prf = Initialize c size prf

112115

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

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

114117free = Free

115118

116119peek : {i : Nat} ->

117120 (offset : Nat) ->

118121 (size : Nat) ->

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

121124peek offset size prf = Peek offset size prf

122125

123126poke : {n : Nat} ->

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

125128 (offset : Nat) ->

126129 Vect size Bits8 ->

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

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

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

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

129133poke offset content prf = Poke offset content prf

130134

131135private

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

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

133137getRawPtr = GetRawPtr

134138

135139private

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

142146 (size : Nat) ->

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

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

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

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

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

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

147151move' src_ptr dst_offset src_offset size dst_bounds src_bounds

148152 = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

149153

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

158162 (size : Nat) ->

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

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

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

165+ Eff m ()

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

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

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

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

168+ (\v =>

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

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

165171move dst_offset src_offset size dst_bounds src_bounds

166172 = do src_ptr <- Src :- getRawPtr

167173 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

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

66

77using (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

99 map f prog = do t <- prog

1010 value (f t)

1111

12− instance Applicative (EffM m xs xs) where

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

1313 pure = value

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

1515 a' <- a

1616 value (f' a')

1717

18− instance Monad (EffM m xs xs) where

19− (>>=) = ebind

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

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

2020

2121

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

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

22

33import Effects

44

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

6− getRandom : Random Integer Integer Integer

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

5+data Random : Effect where

6+ getRandom : { Integer } Random Integer

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

88

99using (m : Type -> Type)

1010 instance Handler Random m where

1111 handle seed getRandom k

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

1313 k seed' seed'

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

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

1515

1616RND : EFFECT

1717RND = MkEff Integer Random

1818

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

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

2020rndInt lower upper = do v <- getRandom

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

2222

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

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

2432srand n = setSeed n

2533

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

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

33import Effects

44

55data Selection : Effect where

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

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

77

88instance Handler Selection Maybe where

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

1010 tryAll [] = Nothing

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

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

1212 Nothing => tryAll xs

1313 Just v => Just v

1414

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

1717

1818SELECT : EFFECT

1919SELECT = MkEff () Selection

2020

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

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

2222select xs = Select xs

2323

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

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

55%access public

66

77data State : Effect where

8− Get : State a a a

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

8+ Get : { a } State a

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

1010

1111using (m : Type -> Type)

1212 instance Handler State m where

1313 handle st Get k = k st st

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

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

1515

1616STATE : Type -> EFFECT

1717STATE t = MkEff t State

1818

19−get : Eff m [STATE x] x

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

2020get = Get

2121

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

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

2323put val = Put val

2424

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

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

2626putM val = Put val

2727

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

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

2929update f = put (f !get)

3030

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

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

3232updateM f = putM (f !get)

3333

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

3535locally newst prog = do st <- get

3636 putM newst

3737 val <- prog

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

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

44import Control.IOExcept

55

66data StdIO : Effect where

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

8− GetStr : StdIO () () String

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

8+ GetStr : { () } StdIO String

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

10+ GetCh : { () } StdIO Char

911

1012instance Handler StdIO IO where

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

1317

1418instance 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

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

3523

3624--- The Effect and associated functions

3725

3826STDIO : EFFECT

3927STDIO = MkEff () StdIO

4028

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

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

4230putStr s = PutStr s

4331

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

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

33+putChar c = PutCh c

34+

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

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

4637

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

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

4839getStr = GetStr

4940

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−

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

42+getChar = GetCh

6043

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

22

33import Language.Reflection

44import Control.Catchable

5+import Effect.Default

56

6−%access public

7−

8−---- Effects

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

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

99

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.

1018Effect : Type

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

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

1220

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

22+||| description into a concrete effect.

1323%error_reverse

1424data EFFECT : Type where

1525 MkEff : Type -> Effect -> EFFECT

1626

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

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

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

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

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.

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

1946

20−---- Properties and proof construction

47+-- No state transition

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

2149

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 ]

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

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

2460 SubNil : SubList {a} [] []

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

2965 subListId {xs = Nil} = SubNil

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

3167

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

68+namespace Env

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

70+ Nil : Env m Nil

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

72+

73+data EffElem : Effect -> Type ->

3774 List EFFECT -> Type where

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

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

4077

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

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

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

4380dropEnv [] SubNil = []

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

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

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

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

5491

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

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

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

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

5895rebuildEnv [] SubNil env = env

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

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

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

6299

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

64−

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

65101-- some proof automation

66102

67103%reflection

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

79115

80116%reflection

81117reflectSubList : List a -> Tactic

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

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

83119reflectSubList (x :: xs)

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

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

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

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

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

89125

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+

90140%reflection

91141reflectEff : (P : Type) -> Tactic

92142reflectEff (EffElem m a xs)

93143 = reflectListEffElem xs `Seq` Solve

94144reflectEff (SubList xs ys)

95145 = reflectSubList ys `Seq` Solve

146+reflectEff (Env m xs)

147+ = reflectDefaultList xs `Seq` Solve

96148

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

149+updateResTy : (val : t) ->

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

98151 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

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

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

106154

107155infix 5 :::, :-, :=

108156

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

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

111159

112160(:::) : 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

114166

115167private

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

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

118170

119171private

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

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

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

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

175+

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

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.

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

184+ -> (x : Type)

185+ -> (es : List EFFECT)

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

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'

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

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

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

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

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

195+

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

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

198+ newInit : Handler e m =>

199+ res ->

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

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

202+ catch : Catchable m err =>

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

204+ Eff m a xs xs'

205+

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

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

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

209+

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

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

212+(>>=) = ebind

213+

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

187215return x = value x

188216

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 ]

193218

194219infixl 2 <$>

195220

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

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

197222pure = value

198223

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)

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

201229 arg <- v

202230 return (fn arg)

203231

204−-- an interpreter

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

205233

206234private

207235execEff : 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

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

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

210238execEff (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))

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

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

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

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

237243

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

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

240246

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

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

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

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

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

246253eff env (lift prf effP) k

247254 = 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' effP (\p', envk => k p' (rebuildEnv envk prf env))

256+eff env (newInit r prog) k

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

255258eff env (catch prog handler) k

256259 = catch (eff env prog k)

257260 (\e => eff env (handler e) k)

@@ -261,48 +264,79 @@ eff env (catch prog handler) k

261264-- end so that everything is in scope when it needs to be.

262265eff {xs = [l ::: x]} env (l :- prog) k

263266 = 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] |)

265279

266280implicit

267−lift' : EffM m ys ys' t ->

281+lift' : Eff m t ys ys' ->

268282 {default tactics { byReflection reflectEff; }

269283 prf : SubList ys xs} ->

270− EffM m xs (updateWith ys' xs prf) t

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

271285lift' e {prf} = lift prf e

272286

273287implicit

274288effect' : {a, b: _} -> {e : Effect} ->

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

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

276290 {default tactics { byReflection reflectEff; }

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

279293effect' e {prf} = effect prf e

280294

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

281300

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)

301+-- --------------------------------------------------------- [ Running Effects ]

284302

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

303+||| Run an effectful program

304+run : Applicative m => {default MkDefaultEnv env : Env m xs} -> Eff m a xs xs' -> m a

305+run {env} prog = eff env prog (\r, env => pure r)

287306

288−runPure : Env id xs -> EffM id xs xs' a -> a

289−runPure env prog = eff env prog (\env, r => r)

307+runPure : {default MkDefaultEnv env : Env id xs} -> Eff id a xs xs' -> a

308+runPure {env} prog = eff env prog (\r, env => r)

290309

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

310+runInit : Applicative m => Env m xs -> Eff m a xs xs' -> m a

311+runInit env prog = eff env prog (\r, env => pure r)

293312

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)

313+runPureInit : Env id xs -> Eff id a xs xs' -> a

314+runPureInit env prog = eff env prog (\r, env => r)

296315

297−Eff : (Type -> Type) -> List EFFECT -> Type -> Type

298−Eff m xs t = EffM m xs xs t

316+runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a

317+runWith inj env prog = eff env prog (\r, env => inj r)

299318

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

301322

302−mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b)

323+-- ----------------------------------------------- [ some higher order things ]

324+

325+mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b)

303326mapE f [] = pure []

304327mapE f (x :: xs) = [| f x :: mapE f xs |]

305328

306−when : Applicative m => Bool -> Eff m xs () -> Eff m xs ()

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+

338+when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m ()

307339when True e = e

308340when False e = pure ()

341+

342+-- --------------------------------------------------------------------- [ EOF ]

libs/effects/effects.ipkg+3−2

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

11package effects

22

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

4−modules = Effects,

4+modules = Effects, Effect.Default,

5+

56 Effect.Exception, Effect.File, Effect.State,

67 Effect.Random, Effect.StdIO, Effect.Select,

7− Effect.Memory, Effect.Monad

8+ Effect.Memory, Effect.System

89

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

44import System

55import Control.IOExcept

66

7−data Exception : Type -> Effect where

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

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

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

99

1010instance Handler (Exception a) Maybe where

1111 handle _ (Raise e) k = Nothing

1212

13−instance Handler (Exception a) List where

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

15−

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

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

1815 believe_me (exit 1)

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

2623EXCEPTION : Type -> EFFECT

2724EXCEPTION t = MkEff () (Exception t)

2825

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

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

3027raise err = Raise err

3128

3229

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

3431

3532

3633

34+

3735-- TODO: Catching exceptions mid program?

3836-- probably need to invoke a new interpreter

3937

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

1212abstract

1313data RawMemory : Effect where

1414 Allocate : (n : Nat) ->

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

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

15+ RawMemory () (MemoryChunk n 0) ()

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

1717 Initialize : Bits8 ->

1818 (size : Nat) ->

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

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

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

2121 Peek : (offset : Nat) ->

2222 (size : Nat) ->

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

24− RawMemory (Vect size Bits8)

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

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

2625 Poke : (offset : Nat) ->

2726 (Vect size Bits8) ->

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

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

3130 (dst_offset : Nat) ->

3231 (src_offset : Nat) ->

3332 (size : Nat) ->

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

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

36− RawMemory () (MemoryChunk dst_size dst_init)

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

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

35+ RawMemory (MemoryChunk dst_size dst_init)

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

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

3938

4039private

4140do_malloc : Nat -> IOExcept String Ptr

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

8079instance Handler RawMemory (IOExcept String) where

8180 handle () (Allocate n) k

8281 = do ptr <- do_malloc n

83− k () (CH ptr)

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

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

82+ k (CH ptr) ()

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

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

8685 handle (CH ptr) (Free) k

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

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

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

90− k res (CH ptr)

89+ k (CH ptr) res

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

9291 = do ioe_lift (do_poke ptr offset content)

93− k () (CH ptr)

92+ k (CH ptr) ()

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

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

96− k () (CH dest_ptr)

95+ k (CH dest_ptr) ()

9796 handle chunk (GetRawPtr) k

9897 = k chunk chunk

9998

10099RAW_MEMORY : Type -> EFFECT

101100RAW_MEMORY t = MkEff t RawMemory

102101

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

105103allocate size = Allocate size

106104

107105initialize : {i : Nat} ->

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

109107 Bits8 ->

110108 (size : Nat) ->

111109 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))] ()

114111initialize c size prf = Initialize c size prf

115112

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

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

117114free = Free

118115

119116peek : {i : Nat} ->

120117 (offset : Nat) ->

121118 (size : Nat) ->

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

124121peek offset size prf = Peek offset size prf

125122

126123poke : {n : Nat} ->

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

128125 (offset : Nat) ->

129126 Vect size Bits8 ->

130127 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)))] ()

133129poke offset content prf = Poke offset content prf

134130

135131private

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

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

137133getRawPtr = GetRawPtr

138134

139135private

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

146142 (size : Nat) ->

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

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

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

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

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

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

151147move' src_ptr dst_offset src_offset size dst_bounds src_bounds

152148 = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

153149

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

162158 (size : Nat) ->

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

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

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

168− (\v =>

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

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

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

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

171165move dst_offset src_offset size dst_bounds src_bounds

172166 = do src_ptr <- Src :- getRawPtr

173167 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

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

66

77using (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

99 map f prog = do t <- prog

1010 value (f t)

1111

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

12+ instance Applicative (EffM m xs xs) where

1313 pure = value

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

1515 a' <- a

1616 value (f' a')

1717

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

19− (>>=) = Effects.(>>=)

18+ instance Monad (EffM m xs xs) where

19+ (>>=) = ebind

2020

2121

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

33import Effects

44

55data Selection : Effect where

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

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

77

88instance Handler Selection Maybe where

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

1010 tryAll [] = Nothing

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

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

1212 Nothing => tryAll xs

1313 Just v => Just v

1414

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

1717

1818SELECT : EFFECT

1919SELECT = MkEff () Selection

2020

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

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

2222select xs = Select xs

2323

libs/neweffects/Effect/State.idr → libs/oldeffects/Effect/State.idrrenamed+9−9

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

55%access public

66

77data State : Effect where

8− Get : { a } State a

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

8+ Get : State a a a

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

1010

1111using (m : Type -> Type)

1212 instance Handler State m where

1313 handle st Get k = k st st

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

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

1515

1616STATE : Type -> EFFECT

1717STATE t = MkEff t State

1818

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

19+get : Eff m [STATE x] x

2020get = Get

2121

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

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

2323put val = Put val

2424

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

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

2626putM val = Put val

2727

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

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

2929update f = put (f !get)

3030

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

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

3232updateM f = putM (f !get)

3333

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

3535locally newst prog = do st <- get

3636 putM newst

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

11IDRIS := idris

22

33build:

4− $(IDRIS) --build neweffects.ipkg

4+ $(IDRIS) --build oldeffects.ipkg

55

66clean:

7− $(IDRIS) --clean neweffects.ipkg

7+ $(IDRIS) --clean oldeffects.ipkg

88

99install:

10− $(IDRIS) --install neweffects.ipkg

10+ $(IDRIS) --install oldeffects.ipkg

1111

1212rebuild: clean build

1313

libs/neweffects/neweffects.ipkg → libs/oldeffects/oldeffects.ipkgrenamed+3−4

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

1−package neweffects

1+package oldeffects

22

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

4−modules = Effects, Effect.Default,

5−

4+modules = Effects,

65 Effect.Exception, Effect.File, Effect.State,

76 Effect.Random, Effect.StdIO, Effect.Select,

8− Effect.Memory, Effect.System

7+ Effect.Memory, Effect.Monad

98

libs/prelude/Builtins.idr+17−6

@@ -23,7 +23,9 @@ FalseElim : _|_ -> a

2323data Symbol_ : String -> Type where

2424

2525-- ------------------------------------------------------ [ For rewrite tactic ]

26−||| Perform substitution in a term. This is used by the `rewrite` tactic and term.

26+||| Perform substitution in a term according to some equality.

27+|||

28+||| This is used by the `rewrite` tactic and term.

2729replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y

2830replace refl prf = prf

2931

@@ -41,14 +43,23 @@ lazy x = x -- compiled specially

4143force : a -> a

4244force x = x -- compiled specially

4345

44−data Lazy : Type -> Type where

45− Delay : (val : a) -> Lazy a

46+data LazyType = LazyCodata | LazyEval

4647

47−Force : Lazy a -> a

48+data Lazy' : LazyType -> Type -> Type where

49+ Delay : {t, a : _} -> (val : a) -> Lazy' t a

50+

51+Force : {t, a : _} -> Lazy' t a -> a

4852Force (Delay x) = x

4953

50−par : Lazy a -> a

51−par (Delay x) = x -- compiled specially

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?

62+par (Delay x) = x

5263

5364malloc : Int -> a -> a

5465malloc size x = x -- compiled specially

libs/prelude/Decidable/Equality.idr+25−18

@@ -12,6 +12,7 @@ import Prelude.Maybe

1212-- Utility lemmas

1313--------------------------------------------------------------------------------

1414

15+||| The negation of equality is symmetric (follows from symmetry of equality)

1516total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_)

1617negEqSym p h = p (sym h)

1718

@@ -20,7 +21,9 @@ negEqSym p h = p (sym h)

2021-- Decidable equality

2122--------------------------------------------------------------------------------

2223

24+||| Decision procedures for propositional equality

2325class DecEq t where

26+ ||| Decide whether two elements of `t` are propositionally equal

2427 total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)

2528

2629--------------------------------------------------------------------------------

@@ -33,7 +36,6 @@ instance DecEq () where

3336--------------------------------------------------------------------------------

3437-- Booleans

3538--------------------------------------------------------------------------------

36−

3739total trueNotFalse : True = False -> _|_

3840trueNotFalse refl impossible

3941

@@ -122,13 +124,13 @@ lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} ->

122124lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl

123125

124126instance (DecEq a, DecEq b) => DecEq (a, b) where

125− decEq (a, b) (a', b') with (decEq a a')

126− decEq (a, b) (a, b') | (Yes refl) with (decEq b b')

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

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

131− decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq)

127+ decEq (a, b) (a', b') with (decEq a a')

128+ decEq (a, b) (a, b') | (Yes refl) with (decEq b b')

129+ decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl

130+ decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq)

131+ decEq (a, b) (a', b') | (No p) with (decEq b b')

132+ decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq)

133+ decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq)

132134

133135

134136--------------------------------------------------------------------------------

@@ -188,39 +190,44 @@ instance DecEq a => DecEq (Vect n a) where

188190--------------------------------------------------------------------------------

189191

190192instance DecEq Int where

191− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

192− else No (really_believe_me _|_)

193+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

194+ where postulate primitiveEq : x = y

195+ postulate primitiveNotEq : x = y -> _|_

193196

194197--------------------------------------------------------------------------------

195198-- Char

196199--------------------------------------------------------------------------------

197200

198201instance DecEq Char where

199− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

200− else No (really_believe_me _|_)

202+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

203+ where postulate primitiveEq : x = y

204+ postulate primitiveNotEq : x = y -> _|_

201205

202206--------------------------------------------------------------------------------

203207-- Integer

204208--------------------------------------------------------------------------------

205209

206210instance DecEq Integer where

207− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

208− else No (really_believe_me _|_)

211+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

212+ where postulate primitiveEq : x = y

213+ postulate primitiveNotEq : x = y -> _|_

209214

210215--------------------------------------------------------------------------------

211216-- Float

212217--------------------------------------------------------------------------------

213218

214219instance DecEq Float where

215− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

216− else No (really_believe_me _|_)

220+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

221+ where postulate primitiveEq : x = y

222+ postulate primitiveNotEq : x = y -> _|_

217223

218224--------------------------------------------------------------------------------

219225-- String

220226--------------------------------------------------------------------------------

221227

222228instance DecEq String where

223− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

224− else No (really_believe_me _|_)

229+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

230+ where postulate primitiveEq : x = y

231+ postulate primitiveNotEq : x = y -> _|_

225232

226233

libs/prelude/IO.idr+10−1

@@ -4,8 +4,10 @@ import Prelude.List

44

55%access public

66

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

78abstract data PrimIO a = prim__IO a

89

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

911abstract data World = TheWorld

1012

1113abstract WorldRes : Type -> Type

@@ -26,7 +28,10 @@ abstract

2628prim_io_return : a -> PrimIO a

2729prim_io_return x = prim__IO x

2830

31+||| Descriptions of the various sorts of Ints that Idris supports

2932data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2

33+

34+||| Types available for foreign function calls

3035data FTy = FIntT IntTy

3136 | FFunction FTy FTy

3237 | FFloat

@@ -75,6 +80,7 @@ FBits32x4 = FIntT IT32x4

7580FBits64x2 : FTy

7681FBits64x2 = FIntT IT64x2

7782

83+||| Interpret an FFI type as the type of the Idris function that it will become

7884interpFTy : FTy -> Type

7985interpFTy (FIntT ITNative) = Int

8086interpFTy (FIntT ITChar) = Char

@@ -95,7 +101,10 @@ interpFTy FUnit = ()

95101

96102interpFTy (FFunction a b) = interpFTy a -> interpFTy b

97103

98−ForeignTy : (xs:List FTy) -> (t:FTy) -> Type

104+||| Type signatures for foreign functions

105+||| @ xs the argument types

106+||| @ t the return type

107+ForeignTy : (xs : List FTy) -> (t : FTy) -> Type

99108ForeignTy Nil rt = World -> PrimIO (interpFTy rt)

100109ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt

101110

libs/prelude/Prelude.idr+20−2

@@ -439,26 +439,32 @@ uniformB64x2 x = prim__mkB64x2 x x

439439

440440---- some basic io

441441

442+||| Output a string to stdout without a trailing newline

442443partial

443444putStr : String -> IO ()

444445putStr x = mkForeign (FFun "putStr" [FString] FUnit) x

445446

447+||| Output a string to stdout with a trailing newline

446448partial

447449putStrLn : String -> IO ()

448450putStrLn x = putStr (x ++ "\n")

449451

452+||| Output something showable to stdout, with a trailing newline

450453partial

451454print : Show a => a -> IO ()

452455print x = putStrLn (show x)

453456

457+||| Read one line of input from stdin

454458partial

455459getLine : IO String

456460getLine = prim_fread prim__stdin

457461

462+||| Write a single character to stdout

458463partial

459464putChar : Char -> IO ()

460465putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)

461466

467+||| Read a single character from stdin

462468partial

463469getChar : IO Char

464470getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

@@ -468,21 +474,30 @@ getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

468474abstract

469475data File = FHandle Ptr

470476

477+||| Standard input

471478partial stdin : File

472479stdin = FHandle prim__stdin

473480

481+||| Call the RTS's file opening function

474482do_fopen : String -> String -> IO Ptr

475483do_fopen f m

476484 = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m

477485

478−fopen : String -> String -> IO File

486+||| Open a file

487+||| @ f the filename

488+||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

489+fopen : (f : String) -> (m : String) -> IO File

479490fopen f m = do h <- do_fopen f m

480491 return (FHandle h)

481492

493+||| Modes for opening files

482494data Mode = Read | Write | ReadWrite

483495

496+||| Open a file

497+||| @ f the filename

498+||| @ m the mode

484499partial

485−openFile : String -> Mode -> IO File

500+openFile : (f : String) -> (m : Mode) -> IO File

486501openFile f m = fopen f (modeStr m) where

487502 modeStr Read = "r"

488503 modeStr Write = "w"

@@ -567,15 +582,18 @@ nullPtr : Ptr -> IO Bool

567582nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

568583 return (ok /= 0)

569584

585+||| Check if a supposed string was actually a null pointer

570586partial

571587nullStr : String -> IO Bool

572588nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p

573589 return (ok /= 0)

574590

591+||| Pointer equality

575592eqPtr : Ptr -> Ptr -> IO Bool

576593eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y

577594 return (eq /= 0)

578595

596+||| Check whether a file handle is actually a null pointer

579597partial

580598validFile : File -> IO Bool

581599validFile (FHandle h) = do x <- nullPtr h

libs/prelude/Prelude/Bool.idr+3−1

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

11module Prelude.Bool

22

3+import Builtins

4+

35||| Boolean Data Type

46data Bool = False | True

57

@@ -14,7 +16,7 @@ boolElim False t e = e

1416||| Defines a predicate on Bool which guarantees that the value is true.

1517data so : Bool -> Type where oh : so True

1618

17−-- Syntaxtic sugar for boolean elimination.

19+-- Syntactic sugar for boolean elimination.

1820syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)

1921

2022-- Boolean Operator Precedence

libs/prelude/Prelude/Either.idr+11−1

@@ -16,10 +16,12 @@ data Either a b =

1616-- Syntactic tests

1717--------------------------------------------------------------------------------

1818

19+||| True if the argument is Left, False otherwise

1920isLeft : Either a b -> Bool

2021isLeft (Left l) = True

2122isLeft (Right r) = False

2223

24+||| True if the argument is Right, False otherwise

2325isRight : Either a b -> Bool

2426isRight (Left l) = False

2527isRight (Right r) = True

@@ -41,6 +43,7 @@ either : (f : a -> c) -> (g : b -> c) -> (e : Either a b) -> c

4143either l r (Left x) = l x

4244either l r (Right x) = r x

4345

46+||| Keep the payloads of all Left constructors in a list of Eithers

4447lefts : List (Either a b) -> List a

4548lefts [] = []

4649lefts (x::xs) =

@@ -48,6 +51,7 @@ lefts (x::xs) =

4851 Left l => l :: lefts xs

4952 Right r => lefts xs

5053

54+||| Keep the payloads of all Right constructors in a list of Eithers

5155rights : List (Either a b) -> List b

5256rights [] = []

5357rights (x::xs) =

@@ -55,9 +59,11 @@ rights (x::xs) =

5559 Left l => rights xs

5660 Right r => r :: rights xs

5761

62+||| Split a list of Eithers into a list of the left elements and a list of the right elements

5863partitionEithers : List (Either a b) -> (List a, List b)

5964partitionEithers l = (lefts l, rights l)

6065

66+||| Remove a "useless" Either by collapsing the case distinction

6167fromEither : Either a a -> a

6268fromEither (Left l) = l

6369fromEither (Right r) = r

@@ -66,7 +72,9 @@ fromEither (Right r) = r

6672-- Conversions

6773--------------------------------------------------------------------------------

6874

69−maybeToEither : e -> Maybe a -> Either e a

75+||| Convert a Maybe to an Either by using a default value in case of Nothing

76+||| @ e the default value

77+maybeToEither : (def : e) -> Maybe a -> Either e a

7078maybeToEither def (Just j) = Right j

7179maybeToEither def Nothing = Left def

7280

@@ -86,10 +94,12 @@ instance (Eq a, Eq b) => Eq (Either a b) where

8694-- Injectivity of constructors

8795--------------------------------------------------------------------------------

8896

97+||| Left is injective

8998total leftInjective : {b : Type} -> {x : a} -> {y : a}

9099 -> (Left {b = b} x = Left {b = b} y) -> (x = y)

91100leftInjective refl = refl

92101

102+||| Right is injective

93103total rightInjective : {a : Type} -> {x : b} -> {y : b}

94104 -> (Right {a = a} x = Right {a = a} y) -> (x = y)

95105rightInjective refl = refl

libs/prelude/Prelude/Fin.idr+16−3

@@ -88,6 +88,18 @@ instance MaxBound (Fin (S n)) where

8888 maxBound = last

8989

9090

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+

91103-- Construct a Fin from an integer literal which must fit in the given Fin

92104

93105natToFin : Nat -> (n : Nat) -> Maybe (Fin n)

@@ -101,11 +113,12 @@ integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)

101113integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing

102114

103115data IsJust : Maybe a -> Type where

104− ItIsJust : IsJust {a} (Just x)

116+ ItIsJust : IsJust {a} (Just x)

105117

106118fromInteger : (x : Integer) ->

107− {default ItIsJust

108− prf : (IsJust (integerToFin x n))} -> Fin n

119+ {default ItIsJust

120+ prf : (IsJust (integerToFin x n))} ->

121+ Fin n

109122fromInteger {n} x {prf} with (integerToFin x n)

110123 fromInteger {n} x {prf = ItIsJust} | Just y = y

111124

libs/prelude/Prelude/List.idr+5−2

@@ -236,9 +236,12 @@ mapMaybe f (x::xs) =

236236-- Folds

237237--------------------------------------------------------------------------------

238238

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+

239243instance Foldable List where

240− foldr f e [] = e

241− foldr f e (x::xs) = f x (foldr f e xs)

244+ foldr f e xs = foldrImpl f e id xs

242245

243246--------------------------------------------------------------------------------

244247-- Special folds

libs/prelude/Prelude/Monad.idr+4−1

@@ -13,8 +13,11 @@ infixl 5 >>=

1313class Applicative m => Monad (m : Type -> Type) where

1414 (>>=) : m a -> (a -> m b) -> m b

1515

16+||| Also called `join` or mu

1617flatten : Monad m => m (m a) -> m a

1718flatten a = a >>= id

1819

20+||| For compatibility with Haskell. Note that monads are **not** free to

21+||| define `return` and `pure` differently!

1922return : Monad m => a -> m a

20−return = pure

23+return = pure

libs/prelude/Prelude/Stream.idr+3

@@ -10,6 +10,9 @@ import Prelude.Vect

1010codata Stream : Type -> Type where

1111 (::) : a -> Stream a -> Stream a

1212

13+-- Hints for interactive editing

14+%name Stream xs,ys,zs,ws

15+

1316instance Functor Stream where

1417 map f (x::xs) = f x :: map f xs

1518

libs/prelude/Prelude/Vect.idr+122−37

@@ -20,39 +20,69 @@ infixr 7 ::

2020-- Hints for interactive editing

2121%name Vect xs,ys,zs,ws

2222

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+

2342--------------------------------------------------------------------------------

2443-- Indexing into vectors

2544--------------------------------------------------------------------------------

2645

46+||| All but the first element of the vector

2747tail : Vect (S n) a -> Vect n a

2848tail (x::xs) = xs

2949

50+||| Only the first element of the vector

3051head : Vect (S n) a -> a

3152head (x::xs) = x

3253

54+||| The last element of the vector

3355last : Vect (S n) a -> a

3456last (x::[]) = x

3557last (x::y::ys) = last $ y::ys

3658

59+||| All but the last element of the vector

3760init : Vect (S n) a -> Vect n a

3861init (x::[]) = []

3962init (x::y::ys) = x :: init (y::ys)

4063

64+||| Extract a particular element from a vector

4165index : Fin n -> Vect n a -> a

4266index fZ (x::xs) = x

4367index (fS k) (x::xs) = index k xs

4468index fZ [] impossible

4569

70+||| Construct a new vector consisting of all but the indicated element

4671deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a

4772deleteAt fZ (x::xs) = xs

4873deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs

4974deleteAt _ [] impossible

5075

76+||| Replace an element at a particlar index with another

5177replaceAt : Fin n -> t -> Vect n t -> Vect n t

5278replaceAt fZ y (x::xs) = y :: xs

5379replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs

5480

55−updateAt : Fin n -> (t -> t) -> Vect n t -> Vect n t

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

85+updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t

5686updateAt fZ f (x::xs) = f x :: xs

5787updateAt (fS k) f (x::xs) = x :: updateAt k f xs

5888

@@ -60,33 +90,82 @@ updateAt (fS k) f (x::xs) = x :: updateAt k f xs

6090-- Subvectors

6191--------------------------------------------------------------------------------

6292

93+||| Get the first m elements of a Vect

94+||| @ m the number of elements to take

6395take : {n : Nat} -> (m : Fin (S n)) -> Vect n a -> Vect (cast m) a

6496take (fS k) [] = FinZElim k

6597take fZ _ = []

6698take (fS k) (x::xs) = x :: take k xs

6799

100+||| Remove the first m elements of a Vect

101+||| @ m the number of elements to remove

68102drop : (m : Fin (S n)) -> Vect n a -> Vect (n - cast m) a

69103drop (fS k) [] = FinZElim k

70104drop fZ xs ?= xs

71105drop (fS k) (x::xs) = drop k xs

72106

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+

73136--------------------------------------------------------------------------------

74137-- Conversion from list (toList is provided by Foldable)

75138--------------------------------------------------------------------------------

76139

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.

77151fromList : (l : List a) -> Vect (length l) a

78−fromList [] = []

79−fromList (x::xs) = x :: fromList xs

152+fromList l =

153+ rewrite (sym $ plusZeroRightNeutral (length l)) in

154+ reverse $ fromList' [] l

80155

81156--------------------------------------------------------------------------------

82157-- Building (bigger) vectors

83158--------------------------------------------------------------------------------

84159

160+||| Append two vectors

85161(++) : Vect m a -> Vect n a -> Vect (m + n) a

86162(++) [] ys = ys

87163(++) (x::xs) ys = x :: xs ++ ys

88164

89−replicate : (n : Nat) -> a -> Vect n a

165+||| Repeate some value n times

166+||| @ n the number of times to repeat it

167+||| @ x the value to repeat

168+replicate : (n : Nat) -> (x : a) -> Vect n a

90169replicate Z x = []

91170replicate (S k) x = x :: replicate k x

92171

@@ -94,18 +173,21 @@ replicate (S k) x = x :: replicate k x

94173-- Zips and unzips

95174--------------------------------------------------------------------------------

96175

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

97177zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

98178zipWith f [] [] = []

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

100180

181+||| Combine two equal-length vectors pairwise

101182zip : Vect n a -> Vect n b -> Vect n (a, b)

102183zip = zipWith (\x => \y => (x,y))

103184

185+||| Convert a vector of pairs to a pair of vectors

104186unzip : Vect n (a, b) -> (Vect n a, Vect n b)

105187unzip [] = ([], [])

106188unzip ((l, r)::xs) with (unzip xs)

107189 | (lefts, rights) = (l::lefts, r::rights)

108−

190+

109191--------------------------------------------------------------------------------

110192-- Equality

111193--------------------------------------------------------------------------------

@@ -154,65 +236,66 @@ instance Functor (Vect n) where

154236-- Folds

155237--------------------------------------------------------------------------------

156238

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+

157243instance Foldable (Vect n) where

158− foldr f e [] = e

159− foldr f e (x::xs) = f x (foldr f e xs)

244+ foldr f e xs = foldrImpl f e id xs

160245

161246--------------------------------------------------------------------------------

162247-- Special folds

163248--------------------------------------------------------------------------------

164249

250+||| Flatten a vector of equal-length vectors

165251concat : Vect m (Vect n a) -> Vect (m * n) a

166252concat [] = []

167253concat (v::vs) = v ++ concat vs

168254

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−

188255--------------------------------------------------------------------------------

189256-- Membership tests

190257--------------------------------------------------------------------------------

191258

192−elemBy : (a -> a -> Bool) -> a -> Vect n a -> Bool

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

263+elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool

193264elemBy p e [] = False

194265elemBy p e (x::xs) with (p e x)

195266 | True = True

196267 | False = elemBy p e xs

197268

198−elem : Eq a => a -> Vect n a -> Bool

269+||| Use the default Boolean equality on elements to search for an item

270+||| @ x what to search for

271+||| @ xs where to search

272+elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool

199273elem = elemBy (==)

200274

201−lookupBy : (a -> a -> Bool) -> a -> Vect n (a, b) -> Maybe b

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

278+lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b

202279lookupBy p e [] = Nothing

203280lookupBy p e ((l, r)::xs) with (p e l)

204281 | True = Just r

205282 | False = lookupBy p e xs

206283

284+||| Find the assocation of some key using the default Boolean equality test

207285lookup : Eq a => a -> Vect n (a, b) -> Maybe b

208286lookup = lookupBy (==)

209287

210−hasAnyBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool

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

292+hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool

211293hasAnyBy p elems [] = False

212294hasAnyBy p elems (x::xs) with (elemBy p x elems)

213295 | True = True

214296 | False = hasAnyBy p elems xs

215297

298+||| Check if any element of xs is found in elems using the default Boolean equality test

216299hasAny : Eq a => Vect m a -> Vect n a -> Bool

217300hasAny = hasAnyBy (==)

218301

@@ -220,12 +303,15 @@ hasAny = hasAnyBy (==)

220303-- Searching with a predicate

221304--------------------------------------------------------------------------------

222305

223−find : (a -> Bool) -> Vect n a -> Maybe a

306+||| Find the first element of the vector that satisfies some test

307+||| @ p the test to satisfy

308+find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a

224309find p [] = Nothing

225310find p (x::xs) with (p x)

226311 | True = Just x

227312 | False = find p xs

228313

314+||| Find the index of the first element of the vector that satisfies some test

229315findIndex : (a -> Bool) -> Vect n a -> Maybe Nat

230316findIndex = findIndex' 0

231317 where

@@ -235,6 +321,7 @@ findIndex = findIndex' 0

235321 | True = Just cnt

236322 | False = findIndex' (S cnt) p xs

237323

324+||| Find the indices of all elements that satisfy some test

238325total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)

239326findIndices = findIndices' 0

240327 where

@@ -263,6 +350,7 @@ elemIndices = elemIndicesBy (==)

263350-- Filters

264351--------------------------------------------------------------------------------

265352

353+||| Find all elements of a vector that satisfy some test

266354total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)

267355filter p [] = ( _ ** [] )

268356filter p (x::xs) with (filter p xs)

@@ -272,6 +360,7 @@ filter p (x::xs) with (filter p xs)

272360 else

273361 (_ ** tail)

274362

363+||| Make the elements of some vector unique by some test

275364nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)

276365nubBy = nubBy' []

277366 where

@@ -282,6 +371,7 @@ nubBy = nubBy' []

282371 | False with (nubBy' (x::acc) p xs)

283372 | (_ ** tail) = (_ ** x::tail)

284373

374+||| Make the elements of some vector unique by the default Boolean equality

285375nub : Eq a => Vect n a -> (p ** Vect p a)

286376nub = nubBy (==)

287377

@@ -349,14 +439,9 @@ Prelude.Vect.drop_lemma_1 = proof {

349439 trivial;

350440}

351441

352−Prelude.Vect.reverse'_lemma_2 = proof {

353− intros;

354− rewrite (plusSuccRightSucc m n1);

355− exact value;

356−}

357−

358442Prelude.Vect.reverse'_lemma_1 = proof {

359443 intros;

444+ rewrite prf;

360445 rewrite sym (plusZeroRightNeutral m);

361446 exact value;

362447}

src/IRTS/CodegenC.hs+4−4

@@ -132,10 +132,10 @@ bcc i (ASSIGNCONST l c)

132132 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

133133 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

134134 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"

135− mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"

136− mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"

137− mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"

138− mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")"

135+ mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"

136+ mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"

137+ mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"

138+ mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"

139139 mkConst _ = "MKINT(42424242)"

140140bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

141141bcc i (MKCON l tag args)

src/IRTS/CodegenJavaScript.hs+7−4

@@ -100,18 +100,18 @@ data FFI = FFICode Char | FFIArg Int | FFIError String

100100ffi :: String -> [String] -> String

101101ffi code args = let parsed = ffiParse code in

102102 case ffiError parsed of

103− Just err -> compileJS $ jsError err

103+ Just err -> error err

104104 Nothing -> renderFFI parsed args

105105 where

106106 ffiParse :: String -> [FFI]

107107 ffiParse "" = []

108− ffiParse ['%'] = [FFIError "Invalid positional argument"]

108+ ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]

109109 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss

110110 ffiParse ('%':s:ss)

111111 | isDigit s =

112112 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)

113113 | otherwise =

114− [FFIError "Invalid positional argument"]

114+ [FFIError $ "FFI - Invalid positional argument"]

115115 ffiParse (s:ss) = FFICode s : ffiParse ss

116116

117117

@@ -126,7 +126,7 @@ ffi code args = let parsed = ffiParse code in

126126 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args

127127 renderFFI ((FFIArg i) : fs) args

128128 | 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"

130130

131131

132132compileJS :: JS -> String

@@ -1964,6 +1964,9 @@ translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =

19641964translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =

19651965 JSBinOp "==" (JSVar lhs) (JSVar rhs)

19661966

1967+translateExpression (SForeign _ _ "idris_time" []) =

1968+ JSRaw "(new Date()).getTime()"

1969+

19671970translateExpression (SForeign _ _ fun args) =

19681971 JSFFI fun (map generateWrapper args)

19691972 where

src/IRTS/Compiler.hs+2−2

@@ -163,7 +163,7 @@ mkLDecl n (CaseOp ci _ _ _ pats cd)

163163 return (declArgs [] (case_inlinable ci) n e)

164164mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a

165165mkLDecl 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

167167

168168instance ToIR (TT Name) where

169169 ir tm = ir' [] tm where

@@ -193,7 +193,7 @@ instance ToIR (TT Name) where

193193 l == txt "Delay"

194194 = do arg' <- ir' env arg

195195 return $ LLazyExp arg'

196− | (P _ (UN l) _, [_, arg]) <- unApply tm,

196+ | (P _ (UN l) _, [_, _, arg]) <- unApply tm,

197197 l == txt "Force"

198198 = do arg' <- ir' env arg

199199 return $ LForce arg'

src/Idris/AbsSyntax.hs+28−18

@@ -9,7 +9,8 @@ import Idris.Core.Elaborate hiding (Tactic(..))

99import Idris.Core.Typecheck

1010import Idris.AbsSyntaxTree

1111import Idris.Colours

12−import Idris.IdeSlave

12+import Idris.Docstrings

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

1314import IRTS.CodegenCommon

1415import Util.DynamicLinker

1516

@@ -262,7 +263,7 @@ addCoercion :: Name -> Idris ()

262263addCoercion n = do i <- getIState

263264 putIState $ i { idris_coercions = nub $ n : idris_coercions i }

264265

265−addDocStr :: Name -> String -> [(Name, String)] -> Idris ()

266+addDocStr :: Name -> Docstring -> [(Name, Docstring)] -> Idris ()

266267addDocStr n doc args

267268 = do i <- getIState

268269 putIState $ i { idris_docstrings = addDef n (doc, args) (idris_docstrings i) }

@@ -356,15 +357,15 @@ addNameIdx' i n

356357getHdrs :: Codegen -> Idris [String]

357358getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

358359

359−setErrLine :: Int -> Idris ()

360−setErrLine x = do i <- getIState;

361− case (errLine i) of

362− Nothing -> putIState $ i { errLine = Just x }

360+setErrSpan :: FC -> Idris ()

361+setErrSpan x = do i <- getIState;

362+ case (errSpan i) of

363+ Nothing -> putIState $ i { errSpan = Just x }

363364 Just _ -> return ()

364365

365366clearErr :: Idris ()

366367clearErr = do i <- getIState

367− putIState $ i { errLine = Nothing }

368+ putIState $ i { errSpan = Nothing }

368369

369370getSO :: Idris (Maybe String)

370371getSO = do i <- getIState

@@ -391,6 +392,8 @@ getName = do i <- getIState;

391392 putIState $ (i { idris_name = idx + 1 })

392393 return idx

393394

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

394397addInternalApp :: FilePath -> Int -> PTerm -> Idris ()

395398addInternalApp fp l t

396399 = do i <- getIState

@@ -564,7 +567,7 @@ ihPrintFunTypes h bnd n overloads = do imp <- impShow

564567 RawOutput -> consoleDisplayAnnotated h output

565568 IdeSlave n -> ideSlaveReturnAnnotated n h output

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

568571

569572ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris ()

570573ihRenderResult h d = do ist <- getIState

@@ -640,15 +643,16 @@ isetPrompt p = do i <- getIState

640643

641644ihWarn :: Handle -> FC -> Doc OutputAnnotation -> Idris ()

642645ihWarn h fc err = do i <- getIState

643− err' <- iRender . fmap (fancifyAnnots i) $ err

644646 case idris_outputmode i of

645647 RawOutput ->

646− runIO $

647− hPutStrLn h (show fc ++ ":" ++ displayDecorated (consoleDecorate i) err')

648+ do err' <- iRender . fmap (fancifyAnnots i) $

649+ text (show fc) <> colon <//> err

650+ runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'

648651 IdeSlave n ->

649− do let (str, spans) = displaySpans err'

652+ do err' <- iRender . fmap (fancifyAnnots i) $ err

653+ let (str, spans) = displaySpans err'

650654 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

652656

653657setLogLevel :: Int -> Idris ()

654658setLogLevel l = do i <- getIState

@@ -713,6 +717,12 @@ setShowOrigErr b = do i <- getIState

713717 let opt' = opts { opt_origerr = b }

714718 putIState $ i { idris_options = opt' }

715719

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+

716726setNoBanner :: Bool -> Idris ()

717727setNoBanner n = do i <- getIState

718728 let opts = idris_options i

@@ -899,7 +909,7 @@ iLOG = logLvl 1

899909

900910noErrors :: Idris Bool

901911noErrors = do i <- getIState

902− case errLine i of

912+ case errSpan i of

903913 Nothing -> return True

904914 _ -> return False

905915

@@ -1061,14 +1071,14 @@ expandParamsD rhs ist dec ps ns (PData doc argDocs syn fc co pd)

10611071 (map econ cons)

10621072 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

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

10651075expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty cdoc cn cty)

10661076 = if tn `elem` ns

10671077 then PRecord doc syn fc (dec tn) (piBind ps (expandParams dec ps ns [] tty))

10681078 cdoc (dec cn) conty

10691079 else PRecord doc syn fc (dec tn) (expandParams dec ps ns [] tty)

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

10721082expandParamsD rhs ist dec ps ns (PParams f params pds)

10731083 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

10741084 (map (expandParamsD True ist dec ps ns) pds)

@@ -1544,9 +1554,9 @@ stripLinear i tm = evalState (sl tm) [] where

15441554 return (PPatvar fc f)

15451555 sl t@(PAlternative _ (a : as)) = do sl a

15461556 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

15481558 args' <- mapM slA args

1549− return $ PApp fc fn' args'

1559+ return $ PApp fc fn args'

15501560 where slA (PImp p m l n t) = do t' <- sl t

15511561 return $ PImp p m l n t'

15521562 slA (PExp p l t) = do t' <- sl t

src/Idris/AbsSyntaxTree.hs+56−42

@@ -7,6 +7,7 @@ import Idris.Core.TT

77import Idris.Core.Evaluate

88import Idris.Core.Elaborate hiding (Tactic(..))

99import Idris.Core.Typecheck

10+import Idris.Docstrings

1011import IRTS.Lang

1112import IRTS.CodegenCommon

1213import Util.Pretty

@@ -53,7 +54,8 @@ data IOption = IOption { opt_logLevel :: Int,

5354 opt_cpu :: String,

5455 opt_optLevel :: Word,

5556 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

5759 }

5860 deriving (Show, Eq)

5961

@@ -76,6 +78,7 @@ defaultOpts = IOption { opt_logLevel = 0

7678 , opt_optLevel = 2

7779 , opt_cmdline = []

7880 , opt_origerr = False

81+ , opt_autoSolve = True

7982 }

8083

8184data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord)

@@ -111,7 +114,7 @@ data IState = IState {

111114 idris_flags :: Ctxt [FnOpt],

112115 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

113116 idris_calledgraph :: Ctxt [Name],

114− idris_docstrings :: Ctxt (String, [(Name, String)]),

117+ idris_docstrings :: Ctxt (Docstring, [(Name, Docstring)]),

115118 idris_tyinfodata :: Ctxt TIData,

116119 idris_totcheck :: [(FC, Name)], -- names to check totality on

117120 idris_defertotcheck :: [(FC, Name)], -- names to check at the end

@@ -132,11 +135,12 @@ data IState = IState {

132135 idris_cgflags :: [(Codegen, String)],

133136 idris_hdrs :: [(Codegen, String)],

134137 proof_list :: [(Name, [String])],

135− errLine :: Maybe Int,

138+ errSpan :: Maybe FC,

136139 parserWarnings :: [(FC, Err)],

137140 lastParse :: Maybe Name,

138141 indent_stack :: [Int],

139142 brace_stack :: [Maybe Int],

143+ lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

140144 hide_list :: [(Name, Maybe Accessibility)],

141145 default_access :: Accessibility,

142146 default_total :: Bool,

@@ -221,7 +225,7 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

221225 emptyContext emptyContext emptyContext emptyContext

222226 emptyContext emptyContext

223227 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

224− [] Nothing [] Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

228+ [] Nothing [] Nothing [] [] Nothing [] Hidden False [] Nothing [] [] RawOutput

225229 True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty

226230 AutomaticWidth

227231

@@ -288,6 +292,7 @@ data Command = Quit

288292 | ColourOff

289293 | ListErrorHandlers

290294 | SetConsoleWidth ConsoleWidth

295+ | Apropos String

291296

292297data Opt = Filename String

293298 | Ver

@@ -336,6 +341,7 @@ data Opt = Filename String

336341 | Client String

337342 | ShowOrigErr

338343 | AutoWidth -- ^ Automatically adjust terminal width

344+ | AutoSolve -- ^ Automatically issue "solve" tactic in interactive prover

339345 deriving (Show, Eq)

340346

341347-- Parsed declarations

@@ -407,7 +413,7 @@ constraint = Constraint [] Dynamic

407413tacimpl t = TacImp [] Dynamic t

408414

409415data FnOpt = Inlinable -- always evaluate when simplifying

410− | TotalFn | PartialFn

416+ | TotalFn | PartialFn | CoveringFn

411417 | Coinductive | AssertTotal

412418 | Dictionary -- type class dictionary, eval only when

413419 -- a function argument, and further evaluation resutls

@@ -450,15 +456,15 @@ data ProvideWhat = ProvTerm -- ^ only allow providing terms

450456-- datatypes and typeclasses.

451457data PDecl' t

452458 = PFix FC Fixity [String] -- ^ Fixity declaration

453− | PTy String [(Name, String)] SyntaxInfo FC FnOpts Name t -- ^ Type declaration

454− | PPostulate String SyntaxInfo FC FnOpts Name t -- ^ Postulate

459+ | PTy Docstring [(Name, Docstring)] SyntaxInfo FC FnOpts Name t -- ^ Type declaration

460+ | PPostulate Docstring SyntaxInfo FC FnOpts Name t -- ^ Postulate

455461 | PClauses FC FnOpts Name [PClause' t] -- ^ Pattern clause

456462 | 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.

458464 | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block

459465 | PNamespace String [PDecl' t] -- ^ New namespace

460− | PRecord String SyntaxInfo FC Name t String Name t -- ^ Record declaration

461− | PClass String SyntaxInfo FC

466+ | PRecord Docstring SyntaxInfo FC Name t Docstring Name t -- ^ Record declaration

467+ | PClass Docstring SyntaxInfo FC

462468 [t] -- constraints

463469 Name

464470 [(Name, t)] -- parameters

@@ -512,7 +518,7 @@ deriving instance NFData PClause'

512518-- | Data declaration

513519data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

514520 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

516522 }

517523 -- ^ Data declaration

518524 | PLaterdecl { d_name :: Name, d_tcon :: t }

@@ -737,7 +743,7 @@ type PTactic = PTactic' PTerm

737743

738744data PDo' t = DoExp FC t

739745 | DoBind FC Name t

740− | DoBindP FC t t

746+ | DoBindP FC t t [(t,t)]

741747 | DoLet FC Name t t

742748 | DoLetP FC t t

743749 deriving (Eq, Functor)

@@ -749,7 +755,7 @@ deriving instance NFData PDo'

749755instance Sized a => Sized (PDo' a) where

750756 size (DoExp fc t) = 1 + size fc + size t

751757 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

753759 size (DoLet fc nm l r) = 1 + size fc + size nm + size l + size r

754760 size (DoLetP fc l r) = 1 + size fc + size l + size r

755761

@@ -948,9 +954,9 @@ inferTy = sMN 0 "__Infer"

948954inferCon = sMN 0 "__infer"

949955inferDecl = PDatadecl inferTy

950956 PType

951− [("", [], inferCon, PPi impl (sMN 0 "iType") PType (

952− PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

953− (PRef bi inferTy)), bi, [])]

957+ [(emptyDocstring, [], inferCon, PPi impl (sMN 0 "iType") PType (

958+ PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

959+ (PRef bi inferTy)), bi, [])]

954960inferOpts = []

955961

956962infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t]

@@ -978,7 +984,7 @@ primNames = [unitTy, unitCon,

978984unitTy = sMN 0 "__Unit"

979985unitCon = sMN 0 "__II"

980986unitDecl = PDatadecl unitTy PType

981− [("", [], unitCon, PRef bi unitTy, bi, [])]

987+ [(emptyDocstring, [], unitCon, PRef bi unitTy, bi, [])]

982988unitOpts = [DefaultEliminator]

983989

984990falseTy = sMN 0 "__False"

@@ -988,12 +994,12 @@ falseOpts = []

988994pairTy = sMN 0 "__Pair"

989995pairCon = sMN 0 "__MkPair"

990996pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

991− [("", [], pairCon, PPi impl (n "A") PType (

992− PPi impl (n "B") PType (

993− PPi expl (n "a") (PRef bi (n "A")) (

994− PPi expl (n "b") (PRef bi (n "B"))

995− (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

996− pexp (PRef bi (n "B"))])))), bi, [])]

997+ [(emptyDocstring, [], pairCon, PPi impl (n "A") PType (

998+ PPi impl (n "B") PType (

999+ PPi expl (n "a") (PRef bi (n "A")) (

1000+ PPi expl (n "b") (PRef bi (n "B"))

1001+ (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

1002+ pexp (PRef bi (n "B"))])))), bi, [])]

9971003 where n a = sMN 0 a

9981004pairOpts = []

9991005

@@ -1002,21 +1008,21 @@ eqCon = sUN "refl"

10021008eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),

10031009 (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

10041010 PType)

1005− [("", [], eqCon, PPi impl (n "A") PType (

1006− PPi impl (n "x") (PRef bi (n "A"))

1007− (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1008− pimp (n "B") Placeholder False,

1009− pexp (PRef bi (n "x")),

1010− pexp (PRef bi (n "x"))])), bi, [])]

1011+ [(emptyDocstring, [], eqCon, PPi impl (n "A") PType (

1012+ PPi impl (n "x") (PRef bi (n "A"))

1013+ (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1014+ pimp (n "B") Placeholder False,

1015+ pexp (PRef bi (n "x")),

1016+ pexp (PRef bi (n "x"))])), bi, [])]

10111017 where n a = sMN 0 a

10121018eqOpts = []

10131019

10141020elimName = sUN "__Elim"

10151021elimMethElimTy = sUN "__elimTy"

10161022elimMethElim = sUN "elim"

1017−elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]

1018− [PTy "" [] defaultSyntax bi [TotalFn] elimMethElimTy PType,

1019− PTy "" [] defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

1023+elimDecl = PClass (parseDocstring . T.pack $ "Type class for eliminators") defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]

1024+ [PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElimTy PType,

1025+ PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

10201026

10211027-- Defined in builtins.idr

10221028sigmaTy = sUN "Exists"

@@ -1061,6 +1067,7 @@ consoleDecorate ist AnnConstType = let theme = idris_colourTheme ist

10611067 in colouriseType theme

10621068consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist)

10631069consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)

1070+consoleDecorate ist AnnKeyword = colouriseKeyword (idris_colourTheme ist)

10641071consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist

10651072 theme = idris_colourTheme ist

10661073 in case () of

@@ -1069,19 +1076,24 @@ consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist

10691076 _ | isTConName n ctxt -> colouriseType theme

10701077 _ | otherwise -> id -- don't colourise unknown names

10711078consoleDecorate 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

10721083

10731084-- | Pretty-print a high-level closed Idris term

10741085prettyImp :: Bool -- ^^ whether to show implicits

10751086 -> PTerm -- ^^ the term to pretty-print

10761087 -> Doc OutputAnnotation

1077−prettyImp impl = pprintPTerm impl []

1088+prettyImp impl = pprintPTerm impl [] []

10781089

10791090-- | Pretty-print a high-level Idris term in some bindings context

10801091pprintPTerm :: Bool -- ^^ whether to show implicits

10811092 -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit

1093+ -> [Name] -- ^^ names to always show in pi, even if not used

10821094 -> PTerm -- ^^ the term to pretty-print

10831095 -> Doc OutputAnnotation

1084−pprintPTerm impl bnd = prettySe 10 bnd

1096+pprintPTerm impl bnd docArgs = prettySe 10 bnd

10851097 where

10861098 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

10871099 prettySe p bnd (PQuote r) =

@@ -1097,11 +1109,11 @@ pprintPTerm impl bnd = prettySe 10 bnd

10971109 prettySe 10 ((n, False):bnd) sc

10981110 prettySe p bnd (PLet n ty v sc) =

10991111 bracket p 2 $

1100− text "let" <+> bindingOf n False <+> text "=" </>

1101− prettySe 10 bnd v <+> text "in" </>

1112+ kwd "let" <+> bindingOf n False <+> text "=" </>

1113+ prettySe 10 bnd v <+> kwd "in" </>

11021114 prettySe 10 ((n, False):bnd) sc

11031115 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 =

11051117 let open = if Lazy `elem` l then text "|" <> lparen else lparen in

11061118 bracket p 2 . group $

11071119 enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

@@ -1131,7 +1143,7 @@ pprintPTerm impl bnd = prettySe 10 bnd

11311143 prettySe 10 bnd ty <+> text "=>" </> prettySe 10 ((n, True):bnd) sc

11321144 prettySe p bnd (PPi (TacImp _ _ s) n ty sc) =

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

11351147 rbrace <+> text "->" </> prettySe 10 ((n, True):bnd) sc

11361148 prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args

11371149 | UN nm <- basename f

@@ -1171,7 +1183,7 @@ pprintPTerm impl bnd = prettySe 10 bnd

11711183 then fp

11721184 else fp <+> align (vsep (map (prettyArgSe bnd) args))

11731185 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

11751187 where

11761188 prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts

11771189

@@ -1238,8 +1250,8 @@ pprintPTerm impl bnd = prettySe 10 bnd

12381250 prettySe p bnd (PTactics ts) =

12391251 text "tactics" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

12401252 prettySe p bnd (PMetavar n) = text "?" <> pretty n

1241− prettySe p bnd (PReturn f) = text "return"

1242− prettySe p bnd PImpossible = text "impossible"

1253+ prettySe p bnd (PReturn f) = kwd "return"

1254+ prettySe p bnd PImpossible = kwd "impossible"

12431255 prettySe p bnd Placeholder = text "_"

12441256 prettySe p bnd (PDoBlock _) = text "do block pretty not implemented"

12451257 prettySe p bnd (PElabError s) = pretty s

@@ -1254,7 +1266,7 @@ pprintPTerm impl bnd = prettySe 10 bnd

12541266 prettyArgSe bnd arg = prettySe 0 bnd arg

12551267 prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

12561268 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

12581270

12591271 basename :: Name -> Name

12601272 basename (NS n _) = basename n

@@ -1307,6 +1319,8 @@ pprintPTerm impl bnd = prettySe 10 bnd

13071319 | inner > outer = lparen <> doc <> rparen

13081320 | otherwise = doc

13091321

1322+ kwd = annotate AnnKeyword . text

1323+

13101324-- | Pretty-printer helper for the binding site of a name

13111325bindingOf :: Name -- ^^ the bound name

13121326 -> 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.

5151split :: Name -> PTerm -> Idris [[(Name, PTerm)]]

5252split n t'

5353 = do ist <- getIState

54+ -- Make sure all the names in the term are accessible

55+ mapM_ (\n -> setAccessibility n Public) (allNamesIn t')

5456 (tm, ty, pats) <- elabValBind toplevel True (addImplPat ist t')

5557 logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats)

5658-- iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty))

src/Idris/Colours.hs+7−5

@@ -3,9 +3,8 @@ module Idris.Colours (

33 ColourTheme(..),

44 defaultTheme,

55 colouriseKwd, colouriseBound, colouriseImplicit,

6− colouriseType, colouriseFun, colouriseData,

7− colourisePrompt,

8− ColourType(..)) where

6+ colouriseType, colouriseFun, colouriseData, colouriseKeyword,

7+ colourisePrompt, colourise, ColourType(..)) where

98

109import System.Console.ANSI

1110

@@ -30,8 +29,9 @@ data ColourTheme = ColourTheme { keywordColour :: IdrisColour

3029 }

3130 deriving (Eq, Show)

3231

32+-- | Idris's default console colour theme

3333defaultTheme :: ColourTheme

34−defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True True True False

34+defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True False True False

3535 , boundVarColour = mkColour Magenta

3636 , implicitColour = IdrisColour (Just Magenta) True True False False

3737 , functionColour = mkColour Green

@@ -40,7 +40,7 @@ defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True True True

4040 , promptColour = IdrisColour Nothing True False True False

4141 }

4242

43−-- Set the colour of a string using POSIX escape codes

43+-- | Set the colour of a string using POSIX escape codes

4444colourise :: IdrisColour -> String -> String

4545colourise (IdrisColour c v u b i) str = setSGRCode sgr ++ str ++ setSGRCode [Reset]

4646 where sgr = fg c ++

@@ -71,6 +71,8 @@ colouriseData t = colourise (dataColour t)

7171colourisePrompt :: ColourTheme -> String -> String

7272colourisePrompt t = colourise (promptColour t)

7373

74+colouriseKeyword :: ColourTheme -> String -> String

75+colouriseKeyword t = colourise (keywordColour t)

7476

7577data ColourType = KeywordColour

7678 | BoundVarColour

src/Idris/Completion.hs+5−1

@@ -108,7 +108,11 @@ completeMetaVar = completeWord Nothing (" \t(){}:" ++ opChars) completeM

108108

109109completeOption :: CompletionFunc Idris

110110completeOption = 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+ ]

112116

113117completeConsoleWidth :: CompletionFunc Idris

114118completeConsoleWidth = completeWord Nothing " \t" completeW

src/Idris/Core/CaseTree.hs+2−2

@@ -159,7 +159,7 @@ directUse fn@(App f a)

159159 | (P Ref (UN pfk) _, [App e w]) <- unApply fn,

160160 pfk == txt "prim_fork"

161161 = 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,

163163 fce == txt "Force"

164164 = directUse a -- forcing a value counts as a use

165165 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

@@ -626,7 +626,7 @@ prune proj (Case n alts)

626626

627627 forceTm n arg t = subst arg (forceArg n) t

628628

629− forceArg n = App (App (P Ref (sUN "Force") Erased) Erased)

629+ forceArg n = App (App (App (P Ref (sUN "Force") Erased) Erased) Erased)

630630 (P Bound n Erased)

631631

632632 mkProj n i [] sc = prune proj sc

src/Idris/Core/Elaborate.hs+33−8

@@ -131,14 +131,17 @@ force_term :: Elab' aux ()

131131force_term = do ES (ps, a) l p <- get

132132 put (ES (ps { pterm = force (pterm ps) }, a) l p)

133133

134+-- | Modify the auxiliary state

134135updateAux :: (aux -> aux) -> Elab' aux ()

135136updateAux f = do ES (ps, a) l p <- get

136137 put (ES (ps, f a) l p)

137138

139+-- | Get the auxiliary state

138140getAux :: Elab' aux aux

139141getAux = do ES (ps, a) _ _ <- get

140142 return $! a

141143

144+-- | Set whether to show the unifier log

142145unifyLog :: Bool -> Elab' aux ()

143146unifyLog log = do ES (ps, a) l p <- get

144147 put (ES (ps { unifylog = log }, a) l p)

@@ -147,11 +150,28 @@ getUnifyLog :: Elab' aux Bool

147150getUnifyLog = do ES (ps, a) l p <- get

148151 return (unifylog ps)

149152

153+-- | Process a tactic within the current elaborator state

154+processTactic' :: Tactic -> Elab' aux ()

150155processTactic' t = do ES (p, a) logs prev <- get

151156 (p', log) <- lift $ processTactic t p

152157 put (ES (p', a) (logs ++ log) prev)

153158 return $! ()

154159

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+

155175-- Some handy gadgets for pulling out bits of state

156176

157177-- get the global context

@@ -595,10 +615,10 @@ simple_app fun arg appstr =

595615 hs <- get_holes

596616 env <- get_env

597617 -- 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.

599− -- If they haven't been solved, regret will fail

600− when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr)

601− when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr)

618+ -- just for checking f, so move them to the end. If they never end up

619+ -- getting solved, we'll get an 'Incomplete term' error.

620+ when (a `elem` hs) $ do movelast a

621+ when (b `elem` hs) $ do movelast b

602622 end_unify

603623 where regretWith err = try regret

604624 (lift $ tfail err)

@@ -625,9 +645,12 @@ no_errors tac err

625645 ps' <- get_probs

626646 if (length ps' > length ps) then

627647 case reverse ps' of

628− ((x,y,env,err,_) : _) ->

648+ ((x, y, env, inerr, while, _) : _) ->

629649 let env' = map (\(x, b) -> (x, binderTy b)) env in

630− lift $ tfail $ CantUnify False x y err env' 0

650+ lift $ tfail $

651+ case err of

652+ Nothing -> CantUnify False x y inerr env' 0

653+ Just e -> e

631654 else return $! ()

632655

633656-- Try a tactic, if it fails, try another

@@ -668,6 +691,8 @@ try' t1 t2 proofSearch

668691 r || proofSearch

669692 recoverableErr (CantSolveGoal _ _) = False

670693 recoverableErr (ProofSearchFail _) = False

694+ recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e

695+ recoverableErr (At _ e) = recoverableErr e

671696 recoverableErr _ = True

672697

673698tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a

@@ -716,12 +741,12 @@ prunStateT pmax zok ps x s

716741 newpmax = if newps < 0 then 0 else newps in

717742 if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))

718743 then case reverse (problems p) of

719− ((_,_,_,e,_):_) -> Error e

744+ ((_,_,_,e,_,_):_) -> Error e

720745 else OK ((v, newpmax, problems p), s')

721746 Error e -> Error e

722747

723748qshow :: Fails -> String

724−qshow fs = show (map (\ (x, y, _, _, _) -> (x, y)) fs)

749+qshow fs = show (map (\ (x, y, _, _, _, _) -> (x, y)) fs)

725750

726751dumpprobs [] = ""

727752dumpprobs ((_,_,_,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

262262 n' b' (\x -> ev ntimes stk False ((n', x):env) sc)

263263 where vbind env t

264264 = 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'

265278 -- Treat "assert_total" specially, as long as it's defined!

266279 ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)

267280 | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

@@ -876,12 +889,12 @@ isDConName n ctxt

876889

877890isFnName :: Name -> Context -> Bool

878891isFnName n ctxt

879− = or $ do def <- lookupCtxt n (definitions ctxt)

880− case tfst def of

881− (Function _ _) -> return True

882− (Operator _ _ _) -> return True

883− (CaseOp _ _ _ _ _ _) -> return True

884− _ -> return False

892+ = let def = lookupCtxtExact n (definitions ctxt) in

893+ case def of

894+ Just (Function _ _, _, _, _) -> True

895+ Just (Operator _ _ _, _, _, _) -> True

896+ Just (CaseOp _ _ _ _ _ _, _, _, _) -> True

897+ _ -> False

885898

886899lookupP :: Name -> Context -> [Term]

887900lookupP n ctxt

src/Idris/Core/ProofState.hs+55−25

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

55 evaluation/checking inside the proof system, etc. --}

66

77module Idris.Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,

8− Tactic(..), Goal(..), processTactic,

9− dropGiven, keepGiven) where

8+ Tactic(..), Goal(..), processTactic, nowElaboratingPS, doneElaboratingAppPS,

9+ doneElaboratingArgPS, dropGiven, keepGiven) where

1010

1111import Idris.Core.Typecheck

1212import Idris.Core.Evaluate

@@ -15,6 +15,7 @@ import Idris.Core.Unify

1515

1616import Control.Monad.State.Strict

1717import Control.Applicative hiding (empty)

18+import Control.Arrow (first)

1819import Data.List

1920import Debug.Trace

2021

@@ -38,7 +39,8 @@ data ProofState = PS { thname :: Name,

3839 context :: Context,

3940 plog :: String,

4041 unifylog :: Bool,

41− done :: Bool

42+ done :: Bool,

43+ while_elaborating :: [FailContext]

4244 }

4345

4446data Goal = GD { premises :: Env,

@@ -89,9 +91,9 @@ data Tactic = Attack

8991-- Some utilites on proof and tactic states

9092

9193instance Show ProofState where

92− show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _)

94+ show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)

9395 = show nm ++ ": no more goals"

94− show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _)

96+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _)

9597 = let OK g = goal (Just h) tm

9698 wkenv = premises g in

9799 "Other goals: " ++ show hs ++ "\n" ++

@@ -114,9 +116,9 @@ instance Show ProofState where

114116 showG ps b = showEnv ps (binderTy b)

115117

116118instance Pretty ProofState OutputAnnotation where

117− pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

119+ pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

118120 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 _ _ _ _) =

120122 let OK g = goal (Just h) tm in

121123 let wkEnv = premises g in

122124 text "Other goals" <+> colon <+> pretty hs <+>

@@ -147,12 +149,13 @@ hole _ = False

147149holeName i = sMN i "hole"

148150

149151qshow :: 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)

151153

152154match_unify' :: Context -> Env -> TT Name -> TT Name ->

153155 StateT TState TC [(Name, TT Name)]

154156match_unify' ctxt env topx topy =

155157 do ps <- get

158+ let while = while_elaborating ps

156159 let dont = dontunify ps

157160 let inj = injective ps

158161 traceWhen (unifylog ps)

@@ -162,11 +165,11 @@ match_unify' ctxt env topx topy =

162165 ++ "\n"

163166 ++ "\n" ++ show (pterm ps) ++ "\n\n"

164167 ) $

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

166169 OK u -> do let (h, ns) = unified ps

167170 put (ps { unified = (h, u ++ ns) })

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

170173 problems ps })

171174 return []

172175-- traceWhen (unifylog ps)

@@ -180,24 +183,25 @@ unify' :: Context -> Env -> TT Name -> TT Name ->

180183 StateT TState TC [(Name, TT Name)]

181184unify' ctxt env topx topy =

182185 do ps <- get

186+ let while = while_elaborating ps

183187 let dont = dontunify ps

184188 let inj = injective ps

185189 (u, fails) <- traceWhen (unifylog ps)

186190 ("Trying " ++ show (topx, topy) ++

187191 "\nNormalised " ++ show (normalise ctxt env topx,

188− normalise ctxt env topy) ++

192+ normalise ctxt env topy) ++

189193 " in " ++ show env ++

190194 "\nHoles: " ++ show (holes ps)

191− ++ "\nInjective: " ++ show (injective ps)

195+ ++ "\nInjective: " ++ show (injective ps)

192196 ++ "\n") $

193− lift $ unify ctxt env topx topy inj (holes ps)

197+ lift $ unify ctxt env topx topy inj (holes ps) while

194198 let notu = filter (\ (n, t) -> case t of

195199 P _ _ _ -> False

196200 _ -> n `elem` dont) u

197201 traceWhen (unifylog ps)

198202 ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

199203 "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

200− ++ "\nNot unified:\n" ++ show (notunified ps)

204+ ++ "\nNot unified:\n" ++ show (notunified ps)

201205 ++ "\nCurrent problems:\n" ++ qshow (problems ps)

202206-- ++ show (pterm ps)

203207 ++ "\n----------") $

@@ -220,6 +224,24 @@ unify' ctxt env topx topy =

220224 updateInj (_ : us) inj = updateInj us inj

221225 updateInj [] inj = inj

222226

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+

223245getName :: Monad m => String -> StateT TState m Name

224246getName tag = do ps <- get

225247 let n = nextname ps

@@ -230,6 +252,10 @@ action :: Monad m => (ProofState -> ProofState) -> StateT TState m ()

230252action a = do ps <- get

231253 put (a ps)

232254

255+query :: Monad m => (ProofState -> r) -> StateT TState m r

256+query q = do ps <- get

257+ return $ q ps

258+

233259addLog :: Monad m => String -> StateT TState m ()

234260addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

235261

@@ -240,7 +266,7 @@ newProof n ctxt ty = let h = holeName 0

240266 (P Bound h ty')) ty [] (h, []) []

241267 Nothing [] []

242268 [] []

243− Nothing ctxt "" False False

269+ Nothing ctxt "" False False []

244270

245271type TState = ProofState -- [TacticAction])

246272type RunTactic = Context -> Env -> Term -> StateT TState TC Term

@@ -491,7 +517,8 @@ solve ctxt env (Bind x (Guess ty val) sc)

491517 = do ps <- get

492518 let (uh, uns) = unified ps

493519 case lookup x (notunified ps) of

494− Just tm -> match_unify' ctxt env tm val

520+ Just tm -> -- trace ("NEED MATCH: " ++ show (tm, val)) $

521+ match_unify' ctxt env tm val

495522 _ -> return []

496523 action (\ps -> ps { holes = holes ps \\ [x],

497524 solved = Just (x, val),

@@ -637,10 +664,11 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

637664 let scr = last $ tail args'

638665 let indxnames = makeIndexNames indicies

639666 prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t

640− 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])))

667+ consargs' <- query (\ps -> map (first $ flip (uniqueNameCtxt (context ps)) (holes ps)) consargs)

668+ let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0)))

669+ (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))

642670 action (\ps -> ps {holes = holes ps \\ [x]})

643− mapM_ addConsHole (reverse consargs)

671+ mapM_ addConsHole (reverse consargs')

644672 let res' = forget $ res

645673 (scv, sct) <- lift $ check ctxt env res'

646674 let scv' = specialise ctxt env [] scv

@@ -788,36 +816,38 @@ updateNotunified ns nu = up nu where

788816 up ((n, t) : nus) = let t' = updateSolved ns t in

789817 ((n, t') : up nus)

790818

819+updateProblems :: Context -> [(Name, TT Name)] -> Fails -> [Name] -> [Name]

820+ -> ([(Name, TT Name)], Fails)

791821updateProblems ctxt [] ps inj holes = ([], ps)

792822updateProblems ctxt ns ps inj holes = up ns ps where

793823 up ns [] = (ns, [])

794− up ns ((x, y, env, err, um) : ps) =

824+ up ns ((x, y, env, err, while, um) : ps) =

795825 let x' = updateSolved ns x

796826 y' = updateSolved ns y

797827 err' = updateError ns err

798828 env' = updateEnv ns env in

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

801831 OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

802832 up (ns ++ v) ps

803833 e -> -- trace ("Failed " ++ show e) $

804834 let (ns', ps') = up ns ps in

805− (ns', (x',y',env',err', um) : ps')

835+ (ns', (x',y',env',err', while, um) : ps')

806836

807837-- attempt to solve remaining problems with match_unify

808838matchProblems all ns ctxt ps inj holes = up ns ps where

809839 up ns [] = (ns, [])

810− up ns ((x, y, env, err, um) : ps)

840+ up ns ((x, y, env, err, while, um) : ps)

811841 | all || um == Match =

812842 let x' = updateSolved ns x

813843 y' = updateSolved ns y

814844 err' = updateError ns err

815845 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

817847 OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

818848 up (ns ++ v) ps

819849 _ -> let (ns', ps') = up ns ps in

820− (ns', (x',y',env',err',um) : ps')

850+ (ns', (x', y', env', err', while, um) : ps')

821851 up ns (p : ps) = let (ns', ps') = up ns ps in

822852 (ns', p : ps')

823853

src/Idris/Core/TT.hs+19−6

@@ -44,8 +44,8 @@ data Option = TTypeInTType

4444

4545-- | Source location. These are typically produced by the parser 'Idris.Parser.getFC'

4646data FC = FC { fc_fname :: String, -- ^ Filename

47− fc_line :: Int, -- ^ Line number

48− fc_column :: Int -- ^ Column number

47+ fc_start :: (Int, Int), -- ^ Line and column numbers for the start of the location span

48+ fc_end :: (Int, Int) -- ^ Line and column numbers for the end of the location span

4949 }

5050

5151-- | Ignore source location equality (so deriving classes do not compare FCs)

@@ -57,7 +57,7 @@ newtype FC' = FC' { unwrapFC :: FC }

5757

5858instance Eq FC' where

5959 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'

6161

6262-- | Empty source location

6363emptyFC :: FC

@@ -65,7 +65,7 @@ emptyFC = fileFC ""

6565

6666-- | Source location with file only

6767fileFC :: String -> FC

68−fileFC s = FC s 0 0

68+fileFC s = FC s (0, 0) (0, 0)

6969

7070{-!

7171deriving instance Binary FC

@@ -73,20 +73,28 @@ deriving instance NFData FC

7373!-}

7474

7575instance Sized FC where

76− size (FC f l c) = 1 + length f

76+ size (FC f s e) = 4 + length f

7777

7878instance 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

8083

8184-- | Output annotation for pretty-printed name - decides colour

8285data NameOutput = TypeOutput | FunOutput | DataOutput

8386

87+-- | Text formatting output

88+data TextFormatting = BoldText | ItalicText | UnderlineText

89+

8490-- | Output annotations for pretty-printing

8591data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe Type)

8692 | AnnBoundName Name Bool

8793 | AnnConstData

8894 | AnnConstType

95+ | AnnKeyword

8996 | AnnFC FC

97+ | AnnTextFmt TextFormatting

9098

9199-- | Used for error reflection

92100data ErrorReportPart = TextPart String

@@ -132,6 +140,7 @@ data Err' t

132140 | NoRewriting t

133141 | At FC (Err' t)

134142 | Elaborating String Name (Err' t)

143+ | ElaboratingArg Name Name [(Name, Name)] (Err' t)

135144 | ProviderError String

136145 | LoadingFailed String (Err' t)

137146 | ReflectionError [[ErrorReportPart]] (Err' t)

@@ -162,6 +171,7 @@ instance Sized Err where

162171 size ProgramLineComment = 1

163172 size (At fc err) = size fc + size err

164173 size (Elaborating _ n err) = size err

174+ size (ElaboratingArg _ _ _ err) = size err

165175 size (ProviderError msg) = length msg

166176 size (LoadingFailed fn e) = 1 + length fn + size e

167177 size _ = 1

@@ -186,6 +196,9 @@ instance Show Err where

186196 show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e

187197 show ProgramLineComment = "Program line next to comment"

188198 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

189202 show _ = "Error"

190203

191204instance Pretty Err OutputAnnotation where

src/Idris/Core/Unify.hs+57−35

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

11{-# LANGUAGE PatternGuards #-}

22

3−module Idris.Core.Unify(match_unify, unify, Fails, FailAt(..)) where

3+module Idris.Core.Unify(match_unify, unify, Fails, FailContext(..), FailAt(..)) where

44

55import Idris.Core.TT

66import Idris.Core.Evaluate

@@ -21,8 +21,14 @@ import Debug.Trace

2121data FailAt = Match | Unify

2222 deriving (Show, Eq)

2323

24+data FailContext = FailContext { fail_sourceloc :: FC,

25+ fail_fn :: Name,

26+ fail_param :: Name

27+ }

28+ deriving (Eq, Show)

29+

2430type 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)]

2632

2733data UInfo = UI Int Fails

2834 deriving Show

@@ -31,13 +37,21 @@ data UResult a = UOK a

3137 | UPartOK a

3238 | UFail Err

3339

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+

3448-- Solve metavariables by matching terms against each other

3549-- Not really unification, of course!

3650

37−match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

51+match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->

3852 TC [(Name, TT Name)]

39−match_unify ctxt env topx topy inj holes =

40− case runStateT (un [] (renameBindersTm env topx)

53+match_unify ctxt env topx topy inj holes from =

54+ case runStateT (un [] (renameBindersTm env topx)

4155 (renameBindersTm env topy)) (UI 0 []) of

4256 OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v))

4357 res ->

@@ -82,11 +96,12 @@ match_unify ctxt env topx topy inj holes =

8296 un names x y

8397 | OK True <- convEq' ctxt holes x y = do sc 1; return []

8498 | otherwise = do UI s f <- get

85− let r = recoverable x y

86− let err = CantUnify r

99+ let r = recoverable (normalise ctxt env x)

100+ (normalise ctxt env y)

101+ let err = cantUnify from r

87102 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

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

90105 lift $ tfail err

91106

92107

@@ -96,11 +111,12 @@ match_unify ctxt env topx topy inj holes =

96111 uB bnames (Lam tx) (Lam ty) = un bnames tx ty

97112 uB bnames (Pi tx) (Pi ty) = un bnames tx ty

98113 uB bnames x y = do UI s f <- get

99− let r = recoverable (binderTy x) (binderTy y)

100− let err = CantUnify r topx topy

101− (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

102− (errEnv env) s

103− put (UI s ((binderTy x, binderTy y, env, err, Match) : f))

114+ let r = recoverable (normalise ctxt env (binderTy x))

115+ (normalise ctxt env (binderTy y))

116+ let err = cantUnify from r topx topy

117+ (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

118+ (errEnv env) s

119+ put (UI s ((binderTy x, binderTy y, env, err, from, Match) : f))

104120 return []

105121

106122 -- TODO: there's an annoying amount of repetition between this and the

@@ -110,10 +126,11 @@ match_unify ctxt env topx topy inj holes =

110126 put (UI (s+i) f)

111127

112128 unifyFail x y = do UI s f <- get

113− let r = recoverable x y

114− let err = CantUnify r

129+ let r = recoverable (normalise ctxt env x)

130+ (normalise ctxt env y)

131+ let err = cantUnify from r

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

117134 lift $ tfail err

118135 combine bnames as [] = return as

119136 combine bnames as ((n, t) : bs)

@@ -188,9 +205,9 @@ expandLets env (x, tm) = (x, doSubst (reverse env) tm)

188205 = doSubst env tm

189206

190207

191−unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

208+unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->

192209 TC ([(Name, TT Name)], Fails)

193−unify ctxt env topx topy inj holes =

210+unify ctxt env topx topy inj holes from =

194211-- trace ("Unifying " ++ show (topx, topy)) $

195212 -- don't bother if topx and topy are different at the head

196213 case runStateT (un False [] (renameBindersTm env topx)

@@ -363,17 +380,18 @@ unify ctxt env topx topy inj holes =

363380 un' fn bnames x y

364381 | OK True <- convEq' ctxt holes x y = do sc 1; return []

365382 | otherwise = do UI s f <- get

366− let r = recoverable x y

367− let err = CantUnify r

383+ let r = recoverable (normalise ctxt env x)

384+ (normalise ctxt env y)

385+ let err = cantUnify from r

368386 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

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

371389 return [] -- lift $ tfail err

372390

373391 unApp fn bnames appx@(App fx ax) appy@(App fy ay)

374392 | (injectiveApp fx && injectiveApp fy)

375− || (injectiveApp fx && rigid appx && metavarApp appy)

376− || (injectiveApp fy && rigid appy && metavarApp appx)

393+ || (injectiveApp fx && rigid appx && metavarApp appy && numArgs appx == numArgs appy)

394+ || (injectiveApp fy && rigid appy && metavarApp appx && numArgs appx == numArgs appy)

377395 || (injectiveApp fx && metavarApp fy && ax == ay)

378396 || (injectiveApp fy && metavarApp fx && ax == ay)

379397 = do let (headx, _) = unApply fx

@@ -418,6 +436,8 @@ unify ctxt env topx topy inj holes =

418436 vs <- combine bnames as as'

419437 unArgs vs xs ys

420438

439+ numArgs tm = let (f, args) = unApply tm in length args

440+

421441 metavarApp tm = let (f, args) = unApply tm in

422442 (metavar f &&

423443 all (\x -> metavarApp x) args

@@ -461,18 +481,18 @@ unify ctxt env topx topy inj holes =

461481 unifyTmpFail :: Term -> Term -> StateT UInfo TC [(Name, TT Name)]

462482 unifyTmpFail x y

463483 = do UI s f <- get

464− let r = recoverable x y

465− let err = CantUnify r

484+ let r = recoverable (normalise ctxt env x) (normalise ctxt env y)

485+ let err = cantUnify from r

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

468488 return []

469489

470490 -- shortcut failure, if we *know* nothing can fix it

471491 unifyFail x y = do UI s f <- get

472− let r = recoverable x y

473− let err = CantUnify r

492+ let r = recoverable (normalise ctxt env x) (normalise ctxt env y)

493+ let err = cantUnify from r

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

476496 lift $ tfail err

477497

478498

@@ -491,11 +511,12 @@ unify ctxt env topx topy inj holes =

491511 uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty

492512 uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty

493513 uB bnames x y = do UI s f <- get

494− let r = recoverable (binderTy x) (binderTy y)

495− let err = CantUnify r topx topy

496− (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

497− (errEnv env) s

498− put (UI s ((binderTy x, binderTy y, env, err, Unify) : f))

514+ let r = recoverable (normalise ctxt env (binderTy x))

515+ (normalise ctxt env (binderTy y))

516+ let err = cantUnify from r topx topy

517+ (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

518+ (errEnv env) s

519+ put (UI s ((binderTy x, binderTy y, env, err, from, Unify) : f))

499520 return [] -- lift $ tfail err

500521

501522 checkCycle ns p@(x, P _ _ _) = return [p]

@@ -561,6 +582,7 @@ envPos x i ((y, _) : ys) | x == y = i

561582-- more work may help.

562583-- FIXME: Depending on how overloading gets used, this may cause problems. Better

563584-- rethink overloading properly...

585+-- ASSUMPTION: inputs are in normal form

564586

565587recoverable t@(App _ _) _

566588 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False

@@ -581,7 +603,7 @@ recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False

581603recoverable p@(Constant _) (App f a) = recoverable p f

582604recoverable (App f a) p@(Constant _) = recoverable f p

583605recoverable 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

585607recoverable (App f a) (App f' a')

586608 = recoverable f f' -- && recoverable a a'

587609recoverable f (Bind _ (Pi _) sc)

src/Idris/Coverage.hs+63−128

@@ -218,6 +218,23 @@ genAll i args

218218

219219upd p' p = p { getTm = p' }

220220

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+

221238-- Check if, in a given type n, the constructor cn : ty is strictly positive,

222239-- and update the context accordingly

223240

@@ -256,7 +273,7 @@ calcProd i fc topn pats

256273

257274 prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

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

260277

261278 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

262279 prod n done ok ap@(App _ _)

@@ -292,9 +309,12 @@ calcProd i fc topn pats

292309 _ -> False

293310 cotype nt n ty = False

294311

295−calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]

296− -> Idris Totality

297−calcTotality path fc n pats

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+

316+calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality

317+calcTotality fc n pats

298318 = do i <- getIState

299319 let opts = case lookupCtxt n (idris_flags i) of

300320 [fs] -> fs

@@ -329,20 +349,10 @@ checkTotality path fc n

329349 [CaseOp _ _ _ _ pats _] ->

330350 do t' <- if AssertTotal `elem` opts

331351 then return $ Total []

332− else calcTotality path fc n pats

352+ else calcTotality fc n pats

333353 setTotality n t'

334354 addIBC (IBCTotal n t')

335355 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'

346356 _ -> return $ Total []

347357 x -> return x

348358 case t' of

@@ -411,41 +421,57 @@ buildSCG (_, n) = do

411421 [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

412422 x -> error $ "buildSCG: " ++ show (n, x)

413423

414−delazy t@(App f a)

415− | (P _ (UN l) _, [_, arg]) <- unApply t,

416− l == txt "Force" = delazy arg

417− | (P _ (UN l) _, [_, arg]) <- unApply t,

418− l == txt "Delay" = delazy arg

419− | (P _ (UN l) _, [arg]) <- unApply t,

420− l == txt "Lazy" = delazy arg

421−delazy (App f a) = App (delazy f) (delazy a)

422−delazy (Bind n b sc) = Bind n (fmap delazy b) (delazy sc)

423−delazy t = t

424+delazy = delazy' False -- not lazy codata

425+delazy' all t@(App f a)

426+ | (P _ (UN l) _, [_, _, arg]) <- unApply t,

427+ l == txt "Force" = delazy' all arg

428+ | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,

429+ l == txt "Delay" && (all || lty == txt "LazyEval") = delazy arg

430+ | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,

431+ l == txt "Lazy'" && (all || lty == txt "LazyEval") = delazy' all arg

432+delazy' all (App f a) = App (delazy' all f) (delazy' all a)

433+delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc)

434+delazy' all t = t

435+

436+data Guardedness = Toplevel | Unguarded | Guarded

424437

425438buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry]

426439buildSCG' ist pats args = nub $ concatMap scgPat pats where

427440 scgPat (lhs, rhs) = let lhs' = delazy lhs

428441 rhs' = delazy rhs

429442 (f, pargs) = unApply (dePat lhs') in

430− findCalls (dePat rhs') (patvars lhs') pargs

443+ findCalls Toplevel (dePat rhs') (patvars lhs') pargs

431444

432− findCalls ap@(App f a) pvs pargs

445+ findCalls guarded ap@(App f a) pvs pargs

433446 -- under a call to "assert_total", don't do any checking, just believe

434447 -- that it is total.

435448 | (P _ (UN at) _, [_, _]) <- unApply ap,

436449 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

437458 | (P _ n _, args) <- unApply ap

438− = mkChange n args pargs ++

439− concatMap (\x -> findCalls x pvs pargs) args

440− findCalls (App f a) pvs pargs

441− = findCalls f pvs pargs ++ findCalls a pvs pargs

442− findCalls (Bind n (Let t v) e) pvs pargs

443− = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs

444− findCalls (Bind n _ e) pvs pargs

445− = findCalls e (n : pvs) pargs

446− findCalls (P _ f _ ) pvs 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 ++

465+ concatMap (\x -> findCalls nguarded x pvs pargs) args

466+ findCalls guarded (App f a) pvs pargs

467+ = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs

468+ findCalls guarded (Bind n (Let t v) e) pvs pargs

469+ = findCalls Unguarded v pvs pargs ++ findCalls guarded e (n : pvs) pargs

470+ findCalls guarded (Bind n _ e) pvs pargs

471+ = findCalls guarded e (n : pvs) pargs

472+ findCalls guarded (P _ f _ ) pvs pargs

447473 | not (f `elem` pvs) = [(f, [])]

448− findCalls _ _ _ = []

474+ findCalls _ _ _ _ = []

449475

450476 expandToArity n args

451477 = case lookupTy n (tt_ctxt ist) of

@@ -498,103 +524,12 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

498524 nty == nty' && not co

499525 isInductive _ _ = False

500526

501−-- getTypeFam t | (P _ n _, _) <- unApply t

502−

503527 dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)

504528 dePat t = t

505529

506530 patvars (Bind x (PVar _) sc) = x : patvars sc

507531 patvars _ = []

508532

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−

598533checkSizeChange :: Name -> Idris Totality

599534checkSizeChange n = do

600535 ist <- getIState

src/Idris/DSL.hs+2−2

@@ -57,10 +57,10 @@ expandDo dsl (PDoBlock ds)

5757 block b [a] = PElabError (Msg "Last statement in do block must be an expression")

5858 block b (DoBind fc n tm : rest)

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

6161 = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder

6262 (PCase fc (PRef fc (sMN 0 "bpat"))

63− [(p, block b rest)]))]

63+ ((p, block b rest) : alts)))]

6464 block b (DoLet fc n ty tm : rest)

6565 = PLet n ty tm (block b rest)

6666 block b (DoLetP fc p tm : rest)

src/Idris/DeepSeq.hs+43−1

@@ -6,6 +6,48 @@ import Idris.AbsSyntaxTree

66

77import Control.DeepSeq

88

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+

951-- All generated by 'derive'

1052

1153instance NFData Forceability where

@@ -226,7 +268,7 @@ instance (NFData t) => NFData (PTactic' t) where

226268instance (NFData t) => NFData (PDo' t) where

227269 rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

228270 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` ()

230272 rnf (DoLet x1 x2 x3 x4)

231273 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

232274 rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

src/Idris/Delaborate.hs+29−6

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

11{-# LANGUAGE PatternGuards #-}

2−

32module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', pshow, pprintErr) where

43

54-- Convert core TT back into high level syntax, primarily for display

@@ -13,6 +12,7 @@ import Idris.Core.Evaluate

1312import Idris.ErrReverse

1413

1514import Data.List (intersperse)

15+import qualified Data.Text as T

1616

1717import Debug.Trace

1818

@@ -138,7 +138,7 @@ pprintTerm :: IState -> PTerm -> Doc OutputAnnotation

138138pprintTerm ist = pprintTerm' ist []

139139

140140pprintTerm' :: 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

142142

143143pshow :: IState -> Err -> String

144144pshow ist err = displayDecorated (consoleDecorate ist) .

@@ -200,7 +200,7 @@ pprintErr' i (NotInjective p x y) =

200200 pprintTerm i (delab i y)

201201pprintErr' i (CantResolve c) = text "Can't resolve type class" <+> pprintTerm i (delab i c)

202202pprintErr' 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)))

204204pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n

205205pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n

206206pprintErr' 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

217217pprintErr' i (Elaborating s n e) = text "When elaborating" <+> text s <>

218218 annName' n (showqual i n) <> colon <$>

219219 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

220237pprintErr' i (ProviderError msg) = text ("Type provider error: " ++ msg)

221238pprintErr' i (LoadingFailed fn e) = text "Loading" <+> text fn <+> text "failed:" <+> pprintErr' i e

222239pprintErr' i (ReflectionError parts orig) =

223− let parts' = map (hsep . map showPart) parts in

224− vsep parts' <>

240+ let parts' = map (fillSep . map showPart) parts in

241+ align (fillSep parts') <>

225242 if (opt_origerr (idris_options i))

226243 then line <> line <> text "Original error:" <$> indented (pprintErr' i orig)

227244 else empty

228245 where showPart :: ErrorReportPart -> Doc OutputAnnotation

229− showPart (TextPart str) = text str

246+ showPart (TextPart str) = fillSep . map text . words $ str

230247 showPart (NamePart n) = annName n

231248 showPart (TermPart tm) = pprintTerm i (delab i tm)

232249 showPart (SubReport rs) = indented . hsep . map showPart $ rs

@@ -235,6 +252,11 @@ pprintErr' i (ReflectionFailed msg err) =

235252 indented (pprintErr' i err) <>

236253 text ("This is probably a bug. Please consider reporting it at " ++ bugaddr)

237254

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+

238260annName :: Name -> Doc OutputAnnotation

239261annName n = annName' n (showbasic n)

240262

@@ -259,6 +281,7 @@ showqual i n = showName (Just i) [] False False (dens n)

259281 _ -> ns

260282 dens n = n

261283

284+showbasic :: Name -> String

262285showbasic n@(UN _) = show n

263286showbasic (MN _ s) = str s

264287showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

src/Idris/Docs.hs+23−18

@@ -1,3 +1,4 @@

1+{-# LANGUAGE PatternGuards #-}

12module Idris.Docs where

23

34import Idris.AbsSyntax

@@ -5,16 +6,18 @@ import Idris.AbsSyntaxTree

56import Idris.Delaborate

67import Idris.Core.TT

78import Idris.Core.Evaluate

9+import Idris.Docstrings

810

911import Util.Pretty

1012

1113import Data.Maybe

1214import Data.List

15+import qualified Data.Text as T

1316

1417-- TODO: Only include names with public/abstract accessibility

1518

16−data FunDoc = FD Name String

17− [(Name, PTerm, Plicity, Maybe String)] -- args: name, ty, implicit, docs

19+data FunDoc = FD Name Docstring

20+ [(Name, PTerm, Plicity, Maybe Docstring)] -- args: name, ty, implicit, docs

1821 PTerm -- function type

1922 (Maybe Fixity)

2023 deriving Show

@@ -22,39 +25,41 @@ data FunDoc = FD Name String

2225data Docs = FunDoc FunDoc

2326 | DataDoc FunDoc -- type constructor docs

2427 [FunDoc] -- data constructor docs

25− | ClassDoc Name String -- class docs

28+ | ClassDoc Name Docstring -- class docs

2629 [FunDoc] -- method docs

2730 deriving Show

2831

29−showDoc "" = empty

30−showDoc x = text " -- " <> text x

32+showDoc d | nullDocstring d = empty

33+ | otherwise = text " -- " <> renderDocstring d

3134

3235pprintFD :: Bool -> FunDoc -> Doc OutputAnnotation

3336pprintFD 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 <$>

3541 maybe empty (\f -> text (show f) <> line) f <>

3642 let argshow = showArgs args [] in

3743 if not (null argshow)

3844 then nest 4 $ text "Arguments:" <$> vsep argshow

3945 else empty)

4046

41− where showArgs ((n, ty, Exp {}, d):args) bnd

47+ where showArgs ((n, ty, Exp {}, Just d):args) bnd

4248 = bindingOf n False <+> colon <+>

43− pprintPTerm imp bnd ty <>

44− showDoc (maybe "" id d) <> line

49+ pprintPTerm imp bnd [] ty <>

50+ showDoc d <> line

4551 :

4652 showArgs args ((n, False):bnd)

47− showArgs ((n, ty, Constraint {}, d):args) bnd

53+ showArgs ((n, ty, Constraint {}, Just d):args) bnd

4854 = text "Class constraint" <+>

49− pprintPTerm imp bnd ty <> showDoc (maybe "" id d) <> line

55+ pprintPTerm imp bnd [] ty <> showDoc d <> line

5056 :

5157 showArgs args ((n, True):bnd)

52− showArgs ((n, ty, Imp {}, d):args) bnd

53− | not (null doc)

58+ showArgs ((n, ty, Imp {}, Just d):args) bnd

5459 = text "(implicit)" <+>

5560 bindingOf n True <+> colon <+>

56− pprintPTerm imp bnd ty <>

57− showDoc (maybe "" id d) <> line

61+ pprintPTerm imp bnd [] ty <>

62+ showDoc d <> line

5863 :

5964 showArgs args ((n, True):bnd)

6065 showArgs ((n, _, _, _):args) bnd = showArgs args ((n, True):bnd)

@@ -93,7 +98,7 @@ docClass n ci

9398 = do i <- getIState

9499 let docstr = case lookupCtxt n (idris_docstrings i) of

95100 [str] -> fst str

96− _ -> ""

101+ _ -> emptyDocstring

97102 mdocs <- mapM docFun (map fst (class_methods ci))

98103 return (ClassDoc n docstr mdocs)

99104

@@ -102,7 +107,7 @@ docFun n

102107 = do i <- getIState

103108 let (docstr, argDocs) = case lookupCtxt n (idris_docstrings i) of

104109 [d] -> d

105− _ -> ("", [])

110+ _ -> noDocs

106111 let ty = delabTy i n

107112 let args = getPArgNames ty argDocs

108113 let infixes = idris_infixes i

@@ -116,7 +121,7 @@ docFun n

116121 funName (UN n) = str n

117122 funName (NS n _) = funName n

118123

119−getPArgNames :: PTerm -> [(Name, String)] -> [(Name, PTerm, Plicity, Maybe String)]

124+getPArgNames :: PTerm -> [(Name, Docstring)] -> [(Name, PTerm, Plicity, Maybe Docstring)]

120125getPArgNames (PPi plicity name ty body) ds =

121126 (name, ty, plicity, lookup name ds) : getPArgNames body ds

122127getPArgNames _ _ = []

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

2626import Idris.Core.Typecheck

2727import Idris.Core.CaseTree

2828

29+import Idris.Docstrings

30+

2931import Control.DeepSeq

3032import Control.Monad

3133import Control.Monad.State.Strict as State

@@ -63,12 +65,12 @@ checkAddDef add toplvl fc ((n, (i, top, t)) : ns)

6365-- return (n, (i, top, t'))) ns

6466

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

6769 FC -> FnOpts -> Name -> PTerm -> Idris Type

6870elabType = elabType' False

6971

7072elabType' :: Bool -> -- normalise it

71− ElabInfo -> SyntaxInfo -> String -> [(Name, String)] ->

73+ ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->

7274 FC -> FnOpts -> Name -> PTerm -> Idris Type

7375elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in

7476 n = liftname info n_in in -}

@@ -89,8 +91,7 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

8991 -- if the type is not complete, note that we'll need to infer

9092 -- things later (for solving metavariables)

9193 when (not (null ds)) $ addTyInferred n

92−-- let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds

93−-- addDeferred ds'

94+

9495 mapM_ (elabCaseBlock info opts) is

9596 ctxt <- getContext

9697 logLvl 5 $ "Rechecking"

@@ -106,8 +107,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

106107 -- Add normalised type to internals

107108 rep <- useREPL

108109 when rep $ do

109− addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

110− addIBC (IBCLineApp (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?

111+ addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')))

111112

112113 let (t, _) = unApply (getRetTy nty')

113114 let corec = case t of

@@ -115,7 +116,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

115116 [TI _ True _ _] -> True

116117 _ -> False

117118 _ -> False

118− let opts' = if corec then (Coinductive : opts) else opts

119+ -- Productivity checking now via checking for guarded 'Delay'

120+ let opts' = opts -- if corec then (Coinductive : opts) else opts

119121 let usety = if norm then nty' else nty

120122 ds <- checkDef fc [(n, (-1, Nothing, usety))]

121123 addIBC (IBCDef n)

@@ -126,8 +128,8 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

126128 addDocStr n doc argDocs

127129 addIBC (IBCDoc n)

128130 addIBC (IBCFlags n opts')

129− when (Implicit `elem` opts) $ do addCoercion n

130− addIBC (IBCCoercion n)

131+ when (Implicit `elem` opts') $ do addCoercion n

132+ addIBC (IBCCoercion n)

131133 -- If the function is declared as an error handler and the language

132134 -- extension is enabled, then add it to the list of error handlers.

133135 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

142144 addIBC (IBCErrorHandler n)

143145 else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

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

147147 return usety

148148 where

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

171171 tyIsHandler _ = False

172172

173173

174−elabPostulate :: ElabInfo -> SyntaxInfo -> String ->

174+elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring ->

175175 FC -> FnOpts -> Name -> PTerm -> Idris ()

176176elabPostulate info syn doc fc opts n ty

177177 = do elabType info syn doc [] fc opts n ty

@@ -195,7 +195,7 @@ elabPostulate info syn doc fc opts n ty

195195 -- remove it from the deferred definitions list

196196 solveDeferred n

197197

198−elabData :: ElabInfo -> SyntaxInfo -> String -> [(Name, String)] -> FC -> DataOpts -> PData -> Idris ()

198+elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris ()

199199elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

200200 = do let codata = Codata `elem` opts

201201 iLOG (show (fc, doc))

@@ -253,12 +253,13 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

253253 let metainf = DataMI params

254254 addIBC (IBCMetaInformation n metainf)

255255 -- TMP HACK! Make this a data option

256− when (n /= sUN "Lazy") $ collapseCons n cons

256+ when (n /= sUN "Lazy'") $ collapseCons n cons

257257 updateContext (addDatatype (Data n ttag cty cons))

258258 updateContext (setMetaInformation n metainf)

259259 mapM_ (checkPositive n) cons

260− if DefaultEliminator `elem` opts then evalStateT (elabEliminator params n t dcons info) Map.empty

261− else return ()

260+ if DefaultEliminator `elem` opts

261+ then evalStateT (elabEliminator params n t dcons info) Map.empty

262+ else return ()

262263 where

263264 checkDefinedAs fc n t ctxt

264265 = case lookupDef n ctxt of

@@ -322,7 +323,7 @@ type EliminatorState = StateT (Map.Map String Int) Idris

322323

323324-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

324325elabEliminator :: [Int] -> Name -> PTerm ->

325− [(String, [(Name, String)], Name, PTerm, FC, [Name])] ->

326+ [(Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])] ->

326327 ElabInfo -> EliminatorState ()

327328elabEliminator paramPos n ty cons info = do

328329 elimLog $ "Elaborating eliminator"

@@ -339,7 +340,7 @@ elabEliminator paramPos n ty cons info = do

339340 let motiveConstr = [(motiveName, expl, motive)]

340341 let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))

341342 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

343344 let clauseConsElimArgs = map getPiName consTerms

344345 let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs

345346 let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'

@@ -488,7 +489,7 @@ elabEliminator paramPos n ty cons info = do

488489 splitArgPms _ = ([],[])

489490

490491

491− implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

492+ implicitIndexes :: (Docstring, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

492493 implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

493494 i <- State.lift getIState

494495 implargs' <- case lookupCtxt cnm (idris_implicits i) of

@@ -503,7 +504,7 @@ elabEliminator paramPos n ty cons info = do

503504 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

504505 _ -> return implargs

505506

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

507508 extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do

508509 let cons' = replaceParams paramPos generalParameters ty

509510 let (args, resTy) = splitPi cons'

@@ -539,7 +540,7 @@ elabEliminator paramPos n ty cons info = do

539540 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

540541 convertImplPi _ = Nothing

541542

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

543544 generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

544545 let cons' = replaceParams paramPos generalParameters ty

545546 let (args, resTy) = splitPi cons'

@@ -561,7 +562,7 @@ elabEliminator paramPos n ty cons info = do

561562

562563elabPrims :: Idris ()

563564elabPrims = 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)

565566 (zip

566567 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

567568 [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

@@ -665,7 +666,7 @@ elabProvider info syn fc what n ty tm

665666 Provide tm

666667 | what `elem` [ProvTerm, ProvAny] ->

667668 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

669670 elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc n) []) [] (delab i tm) []] -- ipapp

670671 logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

671672 | otherwise ->

@@ -673,7 +674,7 @@ elabProvider info syn fc what n ty tm

673674 Postulate

674675 | what `elem` [ProvPostulate, ProvAny] ->

675676 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

677678 logLvl 3 $ "Elaborated provided postulate " ++ show n

678679 | otherwise ->

679680 ierror . Msg $ "Attempted to provide a postulate where a term was expected."

@@ -690,7 +691,6 @@ elabProvider info syn fc what n ty tm

690691 , prov == txt "Provider" && provs == txt "Providers" = True

691692 isProviderOf _ _ = False

692693

693−-- | Elaborate a type provider

694694elabTransform :: ElabInfo -> FC -> Bool -> PTerm -> PTerm -> Idris ()

695695elabTransform info fc safe lhs_in rhs_in

696696 = do ctxt <- getContext

@@ -724,8 +724,8 @@ elabTransform info fc safe lhs_in rhs_in

724724 addIBC (IBCTrans (clhs_tm, crhs_tm))

725725

726726

727−elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

728− PTerm -> String -> Name -> PTerm -> Idris ()

727+elabRecord :: ElabInfo -> SyntaxInfo -> Docstring -> FC -> Name ->

728+ PTerm -> Docstring -> Name -> PTerm -> Idris ()

729729elabRecord info syn doc fc tyn ty cdoc cn cty

730730 = do elabData info syn doc [] fc [] (PDatadecl tyn ty [(cdoc, [], cn, cty, fc, [])])

731731 cty' <- implicit syn cn cty

@@ -797,7 +797,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

797797

798798 mkProj recty substs cimp ((pn_in, pty), pos)

799799 = do let pn = expandNS syn pn_in

800− let pfnTy = PTy "" [] defaultSyntax fc [] pn

800+ let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] pn

801801 (PPi expl rec recty

802802 (substMatches substs pty))

803803 let pls = repeat Placeholder

@@ -818,7 +818,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

818818 let valname = sMN 0 "updateval"

819819 let pt = k (PPi expl pn pty

820820 (PPi expl rec recty recty))

821− let pfnTy = PTy "" [] defaultSyntax fc [] setname pt

821+ let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] setname pt

822822 let pls = map (\x -> PRef fc (sMN x "field")) [0..num-1]

823823 let lhsArgs = pls

824824 let rhsArgs = take pos pls ++ (PRef fc valname) :

@@ -834,7 +834,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

834834 return (pn, pfnTy, PClauses fc [] setname [pclause])

835835

836836elabCon :: 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)

838838elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

839839 = do checkUndefined fc n

840840 ctxt <- getContext

@@ -873,12 +873,15 @@ elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

873873

874874 mkLazy (PPi pl n ty sc)

875875 = 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]

877879 else ty in

878880 PPi pl n ty' (mkLazy sc)

879881 mkLazy t = t

880882

881883 getTyName (PApp _ (PRef _ n) _) = n == nsroot tn

884+ getTyName (PRef _ n) = n == nsroot tn

882885 getTyName _ = False

883886

884887

@@ -988,7 +991,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

988991 simpleCase tcase False reflect CompileTime fc atys pdef

989992 cov <- coverage

990993 pmissing <-

991− if cov

994+ if cov && not (hasDefault cs)

992995 then do missing <- genClauses fc n (map getLHS pdef) cs

993996 -- missing <- genMissing n scargs sc

994997 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

10171020 let tot = if pcover || AssertTotal `elem` opts

10181021 then Unchecked -- finish checking later

10191022 else Partial NotCovering -- already know it's not total

1023+

10201024 -- case lookupCtxt (namespace info) n (idris_flags ist) of

10211025 -- [fs] -> if TotalFn `elem` fs

10221026 -- then case tot of

@@ -1072,7 +1076,10 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

10721076 return ()

10731077 -- addIBC (IBCTotal n tot)

10741078 [] -> 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

10761083 where

10771084 noMatch i cs tm = all (\x -> case matchClause i (delab' i x True True) tm of

10781085 Right _ -> False

@@ -1092,6 +1099,10 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

10921099 depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)

10931100 depat acc x = (acc, x)

10941101

1102+ hasDefault cs | (PClause _ _ last _ _ _ :_) <- reverse cs

1103+ , (PApp fn s args) <- last = all ((==Placeholder) . getTm) args

1104+ hasDefault _ = False

1105+

10951106 getLHS (_, l, _) = l

10961107

10971108 simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x,

@@ -1162,7 +1173,7 @@ elabPE info fc caller r =

11621173 (map (\ (lhs, rhs) ->

11631174 (showTmImpls lhs ++ " = " ++

11641175 showTmImpls rhs)) pats)

1165− elabType info defaultSyntax "" [] fc opts newnm specTy

1176+ elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy

11661177 let def = map (\ (lhs, rhs) -> PClause fc newnm lhs [] rhs []) pats

11671178 elabClauses info fc opts newnm def

11681179 logLvl 2 $ "Specialised " ++ show newnm)

@@ -1262,10 +1273,6 @@ checkPossible info fc tcgen fname lhs_in

12621273 case recheck ctxt [] (forget lhs_tm) lhs_tm of

12631274 OK _ -> return True

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

12691276 Error err -> if tcgen then return False

12701277 else return (impossibleError err)

12711278 where impossibleError (CantUnify _ topx topy e _ _)

@@ -1273,6 +1280,7 @@ checkPossible info fc tcgen fname lhs_in

12731280 impossibleError (CantConvert _ _ _) = False

12741281 impossibleError (At _ e) = impossibleError e

12751282 impossibleError (Elaborating _ _ e) = impossibleError e

1283+ impossibleError (ElaboratingArg _ _ _ e) = impossibleError e

12761284 impossibleError _ = True

12771285

12781286 sameFam topx topy

@@ -1382,7 +1390,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

13821390 inj <- get_inj

13831391 return (res, probs, inj))

13841392

1385− when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_) -> (x,y)) probs)

1393+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)

13861394

13871395 let lhs_tm = orderPats (getInferTerm lhs')

13881396 let lhs_ty = getInferType lhs'

@@ -1401,8 +1409,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

14011409

14021410 rep <- useREPL

14031411 when rep $ do

1404− addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1405− addIBC (IBCLineApp (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?

1413+ addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs))

14061414

14071415 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

14081416 -- Elaborate where block

@@ -1446,14 +1454,16 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

14461454 probs <- get_probs

14471455 return (tm, ds, is, probs))

14481456

1449− when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_) -> (x,y)) probs)

1457+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)

14501458

14511459 logLvl 5 "DONE CHECK"

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

14541463 def' <- checkDef fc defer

14551464 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

14561465 addDeferred def''

1466+ mapM_ (\(n, _) -> addIBC (IBCDef n)) def''

14571467

14581468 when (not (null def')) $ do

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

17211731

17221732data MArgTy = IA | EA | CA deriving Show

17231733

1724−elabClass :: ElabInfo -> SyntaxInfo -> String ->

1734+elabClass :: ElabInfo -> SyntaxInfo -> Docstring ->

17251735 FC -> [PTerm] ->

17261736 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

17271737elabClass info syn doc fc constraints tn ps ds

@@ -1748,7 +1758,7 @@ elabClass info syn doc fc constraints tn ps ds

17481758 let cty = impbind ps $ conbind constraints

17491759 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

17501760 constraint

1751− let cons = [("", [], cn, cty, fc, [])]

1761+ let cons = [(emptyDocstring, [], cn, cty, fc, [])]

17521762 let ddecl = PDatadecl tn tty cons

17531763 logLvl 5 $ "Class data " ++ show (showDImp True ddecl)

17541764 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

18031813 case lookup n mtys of

18041814 Just (syn, o, ty) -> do let ty' = insertConstraint c ty

18051815 let ds = map (decorateid defaultdec)

1806− [PTy "" [] syn fc [] n ty',

1816+ [PTy emptyDocstring [] syn fc [] n ty',

18071817 PClauses fc (o ++ opts) n cs]

18081818 iLOG (show ds)

18091819 return (n, ((defaultdec n, ds!!1), ds))

@@ -1841,7 +1851,7 @@ elabClass info syn doc fc constraints tn ps ds

18411851 addInstance False conn' cfn

18421852 addIBC (IBCInstance False conn' cfn)

18431853-- iputStrLn ("Added " ++ show (conn, cfn, ty))

1844− return [PTy "" [] syn fc [] cfn ty,

1854+ return [PTy emptyDocstring [] syn fc [] cfn ty,

18451855 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

18461856

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

19051915 let constraint = PApp fc (PRef fc n) (map pexp ps) -- ipapp

19061916 let iname = mkiname n ps expn

19071917 when (what /= EDefns) $ do

1908− nty <- elabType' True info syn "" [] fc [] iname t

1918+ nty <- elabType' True info syn emptyDocstring [] fc [] iname t

19091919 -- if the instance type matches any of the instances we have already,

19101920 -- and it's not a named instance, then it's overlapping, so report an error

19111921 case expn of

@@ -1970,10 +1980,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

19701980 iLOG (show idecls)

19711981 mapM_ (elabDecl EAll info) idecls

19721982 addIBC (IBCInstance intInst n iname)

1973−-- -- for each constraint, build a top level function to chase it

1974−-- logLvl 5 $ "Building functions"

1975−-- fns <- mapM (cfun (instanceName ci) constraint syn idecls) cs

1976−-- mapM_ (elabDecl EAll info) (concat fns)

1983+

19771984 where

19781985 intInst = case ps of

19791986 [PConstant (AType (ATInt ITNative))] -> True

@@ -2057,7 +2064,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

20572064 decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

20582065 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

20592066

2060− mkTyDecl (n, op, t, _) = PTy "" [] syn fc op n t

2067+ mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t

20612068

20622069 conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

20632070 conbind [] x = x

@@ -2304,7 +2311,7 @@ inferredDiff fc inf user =

23042311-- | Check a PTerm against documentation and ensure that every documented

23052312-- argument actually exists. This must be run _after_ implicits have been

23062313-- found, or it will give spurious errors.

2307−checkDocs :: FC -> [(Name, String)] -> PTerm -> Idris ()

2314+checkDocs :: FC -> [(Name, Docstring)] -> PTerm -> Idris ()

23082315checkDocs fc args tm = cd (Map.fromList args) tm

23092316 where cd as (PPi _ n _ sc) = cd (Map.delete n as) sc

23102317 cd as _ | Map.null as = return ()

src/Idris/ElabTerm.hs+137−119

@@ -13,13 +13,14 @@ import Idris.Core.TT

1313import Idris.Core.Evaluate

1414import Idris.Core.Unify

1515import Idris.Core.Typecheck (check)

16+import Idris.ErrReverse (errReverse)

1617

1718import Control.Applicative ((<$>))

1819import Control.Monad

1920import Control.Monad.State.Strict

2021import Data.List

2122import qualified Data.Map as M

22−import Data.Maybe (mapMaybe)

23+import Data.Maybe (mapMaybe, fromMaybe)

2324import qualified Data.Set as S

2425import qualified Data.Text as T

2526

@@ -72,13 +73,16 @@ build ist info pattern opts fn tm

7273 tm <- get_term

7374 ctxt <- get_context

7475 probs <- get_probs

76+ u <- getUnifyLog

7577

76− when (not pattern) $ do matchProblems True; unifyProblems

78+ when (not pattern) $

79+ traceWhen u ("Remaining problems:\n" ++ show probs) $

80+ do matchProblems True; unifyProblems

7781 probs <- get_probs

7882 case probs of

7983 [] -> return ()

80− ((_,_,_,e,_):es) -> if inf then return ()

81− else lift (Error e)

84+ ((_,_,_,e,_,_):es) -> if inf then return ()

85+ else lift (Error e)

8286 is <- getAux

8387 tt <- get_term

8488 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

@@ -105,8 +109,8 @@ buildTC ist info pattern opts fn tm

105109 tm <- get_term

106110 case probs of

107111 [] -> return ()

108− ((_,_,_,e,_):es) -> if inf then return ()

109− else lift (Error e)

112+ ((_,_,_,e,_,_):es) -> if inf then return ()

113+ else lift (Error e)

110114 is <- getAux

111115 tt <- get_term

112116 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

@@ -154,39 +158,42 @@ elab ist info pattern opts fn tm

154158

155159 elabE :: (Bool, Bool, Bool) -> PTerm -> ElabD ()

156160 elabE ina t =

157−-- do g <- goal

158−-- trace ("Elaborating " ++ show t ++ " : " ++ show g) $

161+ --do g <- goal

162+ --trace ("Elaborating " ++ show t ++ " : " ++ show g) $

159163 do ct <- insertCoerce ina t

160164 t' <- insertLazy ct

161165 g <- goal

162166 tm <- get_term

163167 ps <- get_probs

164168 hs <- get_holes

165−-- trace ("Elaborating " ++ show t' ++ " in " ++ show g

166−-- -- ++ "\n" ++ show tm

167−-- ++ "\nholes " ++ show hs

168−-- ++ "\nproblems " ++ show ps

169−-- ++ "\n-----------\n") $

170−-- trace ("ELAB " ++ show t') $

169+ --trace ("Elaborating " ++ show t' ++ " in " ++ show g

170+ -- ++ "\n" ++ show tm

171+ -- ++ "\nholes " ++ show hs

172+ -- ++ "\nproblems " ++ show ps

173+ -- ++ "\n-----------\n") $

174+ --trace ("ELAB " ++ show t') $

171175 let fc = fileFC "Force"

172− handleError forceErr

176+ env <- get_env

177+ handleError (forceErr env)

173178 (elab' ina t')

174179 (elab' ina (PApp fc (PRef fc (sUN "Force")) -- ipapp

175− [pimp (sUN "a") Placeholder True,

180+ [pimp (sUN "t") Placeholder True,

181+ pimp (sUN "a") Placeholder True,

176182 pexp ct])) True

177183

178− forceErr (CantUnify _ t t' _ _ _)

179− | (P _ (UN ht) _, _) <- unApply t,

180− ht == txt "Lazy" = True

181− forceErr (CantUnify _ t t' _ _ _)

182− | (P _ (UN ht) _, _) <- unApply t',

183− ht == txt "Lazy" = True

184− forceErr (InfiniteUnify _ t _)

185− | (P _ (UN ht) _, _) <- unApply t,

186− ht == txt "Lazy" = True

187− forceErr (Elaborating _ _ t) = forceErr t

188− forceErr (At _ t) = forceErr t

189− forceErr t = False

184+ forceErr env (CantUnify _ t t' _ _ _)

185+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

186+ ht == txt "Lazy'" = True

187+ forceErr env (CantUnify _ t t' _ _ _)

188+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t'),

189+ ht == txt "Lazy'" = True

190+ forceErr env (InfiniteUnify _ t _)

191+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

192+ ht == txt "Lazy'" = True

193+ forceErr env (Elaborating _ _ t) = forceErr env t

194+ forceErr env (ElaboratingArg _ _ _ t) = forceErr env t

195+ forceErr env (At _ t) = forceErr env t

196+ forceErr env t = False

190197

191198 local f = do e <- get_env

192199 return (f `elem` map fst e)

@@ -458,6 +465,8 @@ elab ist info pattern opts fn tm

458465-- trace ("ns is " ++ show ns) $ return ()

459466 -- mark any type class arguments as injective

460467 mapM_ checkIfInjective (map snd ns)

468+ unifyProblems -- try again with the new information,

469+ -- to help with disambiguation

461470 -- Sort so that the implicit tactics and alternatives go last

462471 let (ns', eargs) = unzip $

463472 sortBy cmpArg (zip ns args)

@@ -480,12 +489,21 @@ elab ist info pattern opts fn tm

480489 (movelast n)

481490 else movelast n)

482491 (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.

484499 cmpArg (_, x) (_, y)

485500 = compare (conDepth 0 (getTm x) + priority x + alt x)

486501 (conDepth 0 (getTm y) + priority y + alt y)

487502 where alt t = case getTm t of

488503 PAlternative False _ -> 5

504+ PAlternative True _ -> 1

505+ PLam _ _ _ -> 2

506+ PRewrite _ _ _ _ -> 3

489507 _ -> 0

490508

491509 -- Score a point for every level where there is a non-constructor

@@ -672,14 +690,14 @@ elab ist info pattern opts fn tm

672690 let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)

673691 let tries = if pattern then [t, mkDelay t] else [mkDelay t, t]

674692 case tyh of

675− P _ (UN l) _ | l == txt "Lazy"

693+ P _ (UN l) _ | l == txt "Lazy'"

676694 -> return (PAlternative False tries)

677695 _ -> return t

678696 where

679697 mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)

680698 mkDelay t = let fc = fileFC "Delay" in

681− addImpl ist (PApp fc (PRef fc (sUN "Delay")) [pexp t]) -- ipapp

682−

699+ addImpl ist (PApp fc (PRef fc (sUN "Delay")) -- ipapp

700+ [pexp t])

683701

684702 insertCoerce ina t =

685703 do ty <- goal

@@ -709,10 +727,7 @@ elab ist info pattern opts fn tm

709727 -> Bool -- ^ under a 'force'

710728 -> [(Bool, PTerm)] -- ^ (Laziness, argument)

711729 -> ElabD ()

712− elabArgs ist ina failed fc retry f [] force _

713−-- | retry = let (ns, ts) = unzip (reverse failed) in

714−-- elabArgs ina [] False ns ts

715− | otherwise = return ()

730+ elabArgs ist ina failed fc retry f [] force _ = return ()

716731 elabArgs ist ina failed fc r f (n:ns) force ((_, Placeholder) : args)

717732 = elabArgs ist ina failed fc r f ns force args

718733 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

722737 pexp t])

723738 | otherwise = elabArg argName holeName t

724739 where elabArg argName holeName t =

725− reflectFunctionErrors ist f argName $

726− do hs <- get_holes

727− tm <- get_term

728− -- No coercing under an explicit Force (or it can Force/Delay

729− -- recursively!)

730− let elab = if force then elab' else elabE

731− failed' <- -- trace (show (n, t, hs, tm)) $

732− -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

733− case holeName `elem` hs of

734− True -> do focus holeName; elab ina t; return failed

735− False -> return failed

736− elabArgs ist ina failed fc r f ns force args

737−

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

742− (result, newState) <- case runStateT action elabState of

743− OK (res, newState) -> return (res, newState)

744− Error e@(ReflectionError _ _) -> (lift . tfail) e

745− Error e@(ReflectionFailed _ _) -> (lift . tfail) e

746− Error e -> handle e >>= lift . tfail

747− put newState

748− return result

749− where handle :: Err -> ElabD Err

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

740+ do now_elaborating fc f argName

741+ wrapErr f argName $ do

742+ hs <- get_holes

743+ tm <- get_term

744+ -- No coercing under an explicit Force (or it can Force/Delay

745+ -- recursively!)

746+ let elab = if force then elab' else elabE

747+ failed' <- -- trace (show (n, t, hs, tm)) $

748+ -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

749+ case holeName `elem` hs of

750+ True -> do focus holeName; elab ina t; return failed

751+ False -> return failed

752+ done_elaborating_arg f argName

753+ elabArgs ist ina failed fc r f ns force args

754+ wrapErr f argName action =

755+ do elabState <- get

756+ while <- elaborating_app

757+ let while' = map (\(x, y, z)-> (y, z)) while

758+ (result, newState) <- case runStateT action elabState of

759+ OK (res, newState) -> return (res, newState)

760+ Error e -> do done_elaborating_arg f argName

761+ lift (tfail (elaboratingArgErr while' e))

762+ put newState

763+ return result

764+

773765

774766-- For every alternative, look at the function at the head. Automatically resolve

775767-- any nested alternatives where that function is also at the head

@@ -787,6 +779,7 @@ pruneAlt xs = map prune xs

787779 case fs of

788780 [a] -> a

789781 _ -> PAlternative a as'

782+

790783 choose f (PApp fc f' as) = PApp fc (choose f f') (fmap (fmap (choose f)) as) -- tpapp

791784 choose f t = t

792785

@@ -1098,9 +1091,9 @@ runTac autoSolve ist fn tac

10981091 runReflected tactic

10991092 where tacticTy = Var (reflm "Tactic")

11001093 listTy = Var (sNS (sUN "List") ["List", "Prelude"])

1101− scriptTy = (RBind (sUN "__pi_arg")

1094+ scriptTy = (RBind (sMN 0 "__pi_arg")

11021095 (Pi (RApp listTy envTupleType))

1103− (RBind (sUN "__pi_arg1")

1096+ (RBind (sMN 1 "__pi_arg")

11041097 (Pi (Var $ reflm "TT")) tacticTy))

11051098 runT (ByReflection tm) -- run the reflection function 'tm' on the

11061099 -- goal, then apply the resulting reflected Tactic

@@ -1205,6 +1198,8 @@ reifyApp ist t [t']

12051198 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

12061199reifyApp ist t [t']

12071200 | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

1201+reifyApp ist t [t']

1202+ | t == reflm "ByReflection" = liftM (ByReflection . delab ist) (reifyTT t')

12081203reifyApp _ t [t']

12091204 | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')

12101205reifyApp ist t [t']

@@ -1603,24 +1598,20 @@ reflectErr (NonCollapsiblePostulate n) = raw_apply (Var $ reflErrName "NonCollab

16031598reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n]

16041599reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]

16051600reflectErr (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− ]

16181601reflectErr (ProviderError str) =

16191602 raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

16201603reflectErr (LoadingFailed str err) =

16211604 raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

16221605reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

16231606

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+

16241615

16251616withErrorReflection :: Idris a -> Idris a

16261617withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

@@ -1629,30 +1620,57 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

16291620 return e -- Don't do meta-reflection of errors

16301621 handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"

16311622 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

16321637 handle e = do ist <- getIState

16331638 logLvl 2 "Starting error reflection"

16341639 let handlers = idris_errorhandlers ist

1635− logLvl 3 $ "Using reflection handlers " ++ concat (intersperse ", " (map show handlers))

1636− let reports = map (\n -> RApp (Var n) (reflectErr e)) handlers

1637−

1638− -- Typecheck error handlers - if this fails, then something else was wrong earlier!

1639− handlers <- case mapM (check (tt_ctxt ist) []) reports of

1640− Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e

1641− OK hs -> return hs

1642−

1643− -- Normalize error handler terms to produce the new messages

1644− ctxt <- getContext

1645− let results = map (normalise ctxt []) (map fst handlers)

1646− logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

1647−

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

1650− errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

1651− Left err -> ierror err

1652− Right ok -> return ok

1653− return $ case errorparts of

1654− [] -> e

1655− parts -> ReflectionError errorparts e

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

1653+ concat (intersperse ", " (map show handlers))

1654+ let reports = map (\n -> RApp (Var n) (reflectErr err)) handlers

1655+

1656+ -- Typecheck error handlers - if this fails, then something else was wrong earlier!

1657+ handlers <- case mapM (check (tt_ctxt ist) []) reports of

1658+ Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e

1659+ OK hs -> return hs

1660+

1661+ -- Normalize error handler terms to produce the new messages

1662+ ctxt <- getContext

1663+ let results = map (normalise ctxt []) (map fst handlers)

1664+ logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

1665+

1666+ -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

1667+ let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

1668+ errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

1669+ Left err -> ierror err

1670+ Right ok -> return ok

1671+ return $ case errorparts of

1672+ [] -> e

1673+ parts -> ReflectionError errorparts e

16561674

16571675fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

16581676fromTTMaybe (App (App (P (DCon _ _) (NS (UN just) _) _) ty) tm)

src/Idris/Error.hs+8−13

@@ -23,7 +23,7 @@ iucheck = do tit <- typeInType

2323 when (not tit) $

2424 do ist <- getIState

2525 (tclift $ ucheck (idris_constraints ist)) `idrisCatch`

26− (\e -> do setErrLine (getErrLine e)

26+ (\e -> do setErrSpan (getErrSpan e)

2727 iputStrLn (pshow ist e))

2828

2929showErr :: Err -> Idris String

@@ -43,9 +43,9 @@ setAndReport :: Err -> Idris ()

4343setAndReport e = do ist <- getIState

4444 let h = idris_outh ist

4545 case e of

46− At fc@(FC f l c) e -> do setErrLine l

47− ihWarn h fc $ pprintErr ist e

48− _ -> do setErrLine (getErrLine e)

46+ At fc e -> do setErrSpan fc

47+ ihWarn h fc $ pprintErr ist e

48+ _ -> do setErrSpan (getErrSpan e)

4949 ihputStrLn h $ pshow ist e

5050

5151ifail :: String -> Idris a

@@ -56,7 +56,7 @@ ierror = throwError

5656

5757tclift :: TC a -> Idris a

5858tclift (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

6060tclift (Error err) = throwError err

6161

6262tctry :: TC a -> TC a -> Idris a

@@ -65,11 +65,6 @@ tctry tc1 tc2

6565 OK v -> return v

6666 Error err -> tclift tc2

6767

68−getErrLine :: Err -> Int

69−getErrLine (At (FC _ l _) _) = l

70−getErrLine _ = 0

71−

72−getErrColumn :: Err -> Int

73−getErrColumn (At (FC _ _ c) _) = c

74−getErrColumn _ = 0

75−

68+getErrSpan :: Err -> FC

69+getErrSpan (At fc _) = fc

70+getErrSpan _ = emptyFC

src/Idris/Help.hs+1

@@ -29,6 +29,7 @@ help =

2929 ([":t"], ExprArg, "Check the type of an expression"),

3030 ([":miss", ":missing"], NameArg, "Show missing clauses"),

3131 ([":doc"], NameArg, "Show internal documentation"),

32+ ([":apropos"], NoArg, "Search names, types, and documentation"),

3233 ([":i", ":info"], NameArg, "Display information about a type class"),

3334 ([":total"], NameArg, "Check the totality of a name"),

3435 ([":r",":reload"], NoArg, "Reload current file"),

src/Idris/IBC.hs+122−19

@@ -9,6 +9,9 @@ import Idris.AbsSyntax

99import Idris.Imports

1010import Idris.Error

1111import Idris.Delaborate

12+import Idris.Docstrings

13+

14+import qualified Cheapskate.Types as CT

1215

1316import Data.Binary

1417import Data.Vector.Binary

@@ -25,8 +28,7 @@ import Codec.Compression.Zlib (compress)

2528import Util.Zlib (decompressEither)

2629

2730ibcVersion :: Word8

28−ibcVersion = 62

29−

31+ibcVersion = 65

3032

3133data IBCFile = IBCFile { ver :: Word8,

3234 sourcefile :: FilePath,

@@ -52,7 +54,7 @@ data IBCFile = IBCFile { ver :: Word8,

5254 ibc_flags :: [(Name, [FnOpt])],

5355 ibc_cg :: [(Name, CGInfo)],

5456 ibc_defs :: [(Name, Def)],

55− ibc_docstrings :: [(Name, (String, [(Name, String)]))],

57+ ibc_docstrings :: [(Name, (Docstring, [(Name, Docstring)]))],

5658 ibc_transforms :: [(Term, Term)],

5759 ibc_errRev :: [(Term, Term)],

5860 ibc_coercions :: [Name],

@@ -61,7 +63,8 @@ data IBCFile = IBCFile { ver :: Word8,

6163 ibc_metainformation :: [(Name, MetaInformation)],

6264 ibc_errorhandlers :: [Name],

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

6568 }

6669 deriving Show

6770{-!

@@ -69,7 +72,7 @@ deriving instance Binary IBCFile

6972!-}

7073

7174initIBC :: IBCFile

72−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

75+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

7376

7477loadIBC :: FilePath -> Idris ()

7578loadIBC 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 }

142145ibc i (IBCCGFlag tgt n) f = return f { ibc_cgflags = (tgt, n) : ibc_cgflags f }

143146ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

144147ibc i (IBCHeader tgt n) f = return f { ibc_hdrs = (tgt, n) : ibc_hdrs f }

145−ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of

146− [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))

147− return f' { ibc_defs = (n,v) : ibc_defs f' }

148− _ -> ifail "IBC write failed"

148+ibc i (IBCDef n) f

149+ = do f' <- case lookupDef n (tt_ctxt i) of

150+ [v] -> do (v', (f', _)) <- runStateT (updateDef v) (f, length (symbols f))

151+ return f' { ibc_defs = (n,v) : ibc_defs f' }

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

149156 where

150157 updateDef :: Def -> StateT (IBCFile, Int) Idris Def

151158 updateDef (CaseOp c t args o s cd)

@@ -253,6 +260,7 @@ process i fn

253260 pDyLibs (ibc_dynamic_libs i)

254261 pHdrs (ibc_hdrs i)

255262 pDefs (symbols i) (ibc_defs i)

263+ pPatdefs (ibc_patdefs i)

256264 pAccess (ibc_access i)

257265 pTotal (ibc_total i)

258266 pCG (ibc_cg i)

@@ -378,6 +386,13 @@ pDyLibs ls = do res <- mapM (addDyLib . return) ls

378386pHdrs :: [(Codegen, String)] -> Idris ()

379387pHdrs hs = mapM_ (uncurry addHdr) hs

380388

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+

381396pDefs :: [Name] -> [(Name, Def)] -> Idris ()

382397pDefs syms ds

383398 = mapM_ (\ (n, d) ->

@@ -405,7 +420,7 @@ pDefs syms ds

405420 update (Proj t i) = Proj (update t) i

406421 update t = t

407422

408−pDocs :: [(Name, (String, [(Name, String)]))] -> Idris ()

423+pDocs :: [(Name, (Docstring, [(Name, Docstring)]))] -> Idris ()

409424pDocs ds = mapM_ (\ (n, a) -> addDocStr n (fst a) (snd a)) ds

410425

411426pAccess :: [(Name, Accessibility)] -> Idris ()

@@ -461,6 +476,86 @@ pMetavars ns = do i <- getIState

461476 putIState $ i { idris_metavars = Data.List.reverse ns

462477 ++ idris_metavars i }

463478

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+

464559----- Generated by 'derive'

465560

466561instance Binary SizeChange where

@@ -494,13 +589,15 @@ instance Binary CGInfo where

494589 return (CGInfo x1 x2 [] x4 x5)

495590

496591instance Binary FC where

497− put (FC x1 x2 x3)

592+ put (FC x1 (x2, x3) (x4, x5))

498593 = do put x1

499594 put (x2 * 65536 + x3)

595+ put (x4 * 65536 + x5)

500596 get

501597 = do x1 <- get

502598 x2x3 <- get

503− return (FC x1 (x2x3 `div` 65536) (x2x3 `mod` 65536))

599+ x4x5 <- get

600+ return (FC x1 (x2x3 `div` 65536, x2x3 `mod` 65536) (x4x5 `div` 65536, x4x5 `mod` 65536))

504601

505602

506603instance Binary Name where

@@ -1052,7 +1149,7 @@ instance Binary MetaInformation where

10521149 return (DataMI x1)

10531150

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

10561153 = {-# SCC "putIBCFile" #-}

10571154 do put x1

10581155 put x2

@@ -1088,6 +1185,7 @@ instance Binary IBCFile where

10881185 put x32

10891186 put x33

10901187 put x34

1188+ put x35

10911189

10921190 get

10931191 = do x1 <- get

@@ -1125,7 +1223,8 @@ instance Binary IBCFile where

11251223 x32 <- get

11261224 x33 <- get

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

1226+ x35 <- get

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)

11291228 else return (initIBC { ver = x1 })

11301229

11311230instance Binary DataOpt where

@@ -1154,6 +1253,7 @@ instance Binary FnOpt where

11541253 Reflection -> putWord8 8

11551254 ErrorHandler -> putWord8 9

11561255 ErrorReverse -> putWord8 10

1256+ CoveringFn -> putWord8 11

11571257 get

11581258 = do i <- getWord8

11591259 case i of

@@ -1169,6 +1269,7 @@ instance Binary FnOpt where

11691269 8 -> return Reflection

11701270 9 -> return ErrorHandler

11711271 10 -> return ErrorReverse

1272+ 11 -> return CoveringFn

11721273 _ -> error "Corrupted binary data for FnOpt"

11731274

11741275instance Binary Fixity where

@@ -1878,10 +1979,11 @@ instance (Binary t) => Binary (PDo' t) where

18781979 put x1

18791980 put x2

18801981 put x3

1881− DoBindP x1 x2 x3 -> do putWord8 2

1882− put x1

1883− put x2

1884− put x3

1982+ DoBindP x1 x2 x3 x4 -> do putWord8 2

1983+ put x1

1984+ put x2

1985+ put x3

1986+ put x4

18851987 DoLet x1 x2 x3 x4 -> do putWord8 3

18861988 put x1

18871989 put x2

@@ -1904,7 +2006,8 @@ instance (Binary t) => Binary (PDo' t) where

19042006 2 -> do x1 <- get

19052007 x2 <- get

19062008 x3 <- get

1907− return (DoBindP x1 x2 x3)

2009+ x4 <- get

2010+ return (DoBindP x1 x2 x3 x4)

19082011 3 -> do x1 <- get

19092012 x2 <- get

19102013 x3 <- get

src/Idris/IdeSlave.hs+21−5

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

11{-# LANGUAGE FlexibleInstances, IncoherentInstances, PatternGuards #-}

22

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

44

55import Text.Printf

66import Numeric

@@ -89,10 +89,16 @@ instance SExpable OutputAnnotation where

8989 (SymbolAtom "implicit", BoolAtom imp)]

9090 toSExp AnnConstData = toSExp [(SymbolAtom "decor", SymbolAtom "data")]

9191 toSExp AnnConstType = toSExp [(SymbolAtom "decor", SymbolAtom "type")]

92− toSExp (AnnFC (FC f l c)) = toSExp [(SymbolAtom "source-loc",

93− ((SymbolAtom "filename", StringAtom f),

94− (SymbolAtom "line", IntegerAtom (toInteger l)),

95− (SymbolAtom "column", IntegerAtom (toInteger c))))]

92+ toSExp AnnKeyword = toSExp [(SymbolAtom "decor", SymbolAtom "keyword")]

93+ toSExp (AnnFC (FC f (sl, sc) (el, ec))) = toSExp [(SymbolAtom "source-loc",

94+ ((SymbolAtom "filename", StringAtom f),

95+ (SymbolAtom "start", IntegerAtom (toInteger sl), IntegerAtom (toInteger sc)),

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"

96102

97103escape :: String -> String

98104escape = concatMap escapeChar

@@ -124,6 +130,8 @@ quotedChar = try (string "\\\\" >> return '\\')

124130parseSExp :: String -> Result SExp

125131parseSExp = parseString pSExp (Directed (UTF8.fromString "(unknown)") 0 0 0 0)

126132

133+data Opt = ShowImpl | ErrContext deriving Show

134+

127135data IdeSlaveCommand = REPLCompletions String

128136 | Interpret String

129137 | TypeOf String

@@ -135,6 +143,9 @@ data IdeSlaveCommand = REPLCompletions String

135143 | ProofSearch Int String [String]

136144 | LoadFile String

137145 | DocsFor String

146+ | Apropos String

147+ | GetOpts

148+ | SetOpt Opt Bool

138149 deriving Show

139150

140151sexpToCommand :: SExp -> Maybe IdeSlaveCommand

@@ -153,6 +164,11 @@ sexpToCommand (SexpList [SymbolAtom "proof-search", IntegerAtom line, StringAtom

153164 StringAtom s -> Just s

154165 _ -> Nothing)

155166sexpToCommand (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

156172sexpToCommand _ = Nothing

157173

158174parseMessage :: String -> Either Err (SExp, Integer)

src/Idris/ParseData.hs+8−6

@@ -20,6 +20,8 @@ import Idris.DSL

2020import Idris.Core.TT

2121import Idris.Core.Evaluate

2222

23+import Idris.Docstrings

24+

2325import Control.Applicative

2426import Control.Monad

2527import Control.Monad.State.Strict

@@ -41,7 +43,7 @@ Record ::=

4143-}

4244record :: SyntaxInfo -> IdrisParser PDecl

4345record syn = do (doc, acc) <- try (do

44− doc <- option ("", []) docComment

46+ doc <- option noDocs docComment

4547 acc <- optional accessibility

4648 reserved "record"

4749 return (doc, acc))

@@ -103,7 +105,7 @@ SimpleConstructorList ::=

103105-}

104106data_ :: SyntaxInfo -> IdrisParser PDecl

105107data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

106− (doc, argDocs) <- option ("", []) docComment

108+ (doc, argDocs) <- option noDocs docComment

107109 pushIndent

108110 acc <- optional accessibility

109111 elim <- dataOpts []

@@ -160,9 +162,9 @@ data_ syn = do (doc, argDocs, acc, dataOpts) <- try (do

160162{- | Parses a type constructor declaration

161163 Constructor ::= DocComment? FnName TypeSig;

162164-}

163−constructor :: SyntaxInfo -> IdrisParser (String, [(Name, String)], Name, PTerm, FC, [Name])

165+constructor :: SyntaxInfo -> IdrisParser (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])

164166constructor syn

165− = do (doc, argDocs) <- option ("", []) docComment

167+ = do (doc, argDocs) <- option noDocs docComment

166168 cn_in <- fnName; fc <- getFC

167169 let cn = expandNS syn cn_in

168170 lchar ':'

@@ -177,9 +179,9 @@ constructor syn

177179{- | Parses a constructor for simple discriminative union data types

178180 SimpleConstructor ::= FnName SimpleExpr* DocComment?

179181-}

180−simpleConstructor :: SyntaxInfo -> IdrisParser (String, [(Name, String)], Name, [PTerm], FC, [Name])

182+simpleConstructor :: SyntaxInfo -> IdrisParser (Docstring, [(Name, Docstring)], Name, [PTerm], FC, [Name])

181183simpleConstructor syn

182− = do doc <- option ("", []) (try docComment)

184+ = do doc <- option noDocs (try docComment)

183185 cn_in <- fnName

184186 let cn = expandNS syn cn_in

185187 fc <- getFC

src/Idris/ParseExpr.hs+27−8

@@ -167,7 +167,9 @@ extension syn (Rule ssym ptm _)

167167 upd ns (DoBind fc n t : ds) = DoBind fc n (update ns t) : upd (dropn n ns) ds

168168 upd ns (DoLet fc n ty t : ds) = DoLet fc n (update ns ty) (update ns t)

169169 : upd (dropn n ns) ds

170− upd ns (DoBindP fc i t : ds) = DoBindP fc (update ns i) (update ns t)

170+ upd ns (DoBindP fc i t ts : ds)

171+ = DoBindP fc (update ns i) (update ns t)

172+ (map (\(l,r) -> (update ns l, update ns r)) ts)

171173 : upd ns ds

172174 upd ns (DoLetP fc i t : ds) = DoLetP fc (update ns i) (update ns t)

173175 : upd ns ds

@@ -245,7 +247,7 @@ ProofExpr ::=

245247-}

246248proofExpr :: SyntaxInfo -> IdrisParser PTerm

247249proofExpr syn = do reserved "proof"

248− ts <- indentedBlock (tactic syn)

250+ ts <- indentedBlock1 (tactic syn)

249251 return $ PProof ts

250252 <?> "proof block"

251253

@@ -258,7 +260,7 @@ TacticsExpr :=

258260-}

259261tacticsExpr :: SyntaxInfo -> IdrisParser PTerm

260262tacticsExpr syn = do reserved "tactics"

261− ts <- indentedBlock (tactic syn)

263+ ts <- indentedBlock1 (tactic syn)

262264 return $ PTactics ts

263265 <?> "tactics block"

264266

@@ -736,16 +738,22 @@ TypeSig' ::=

736738@

737739 -}

738740let_ :: SyntaxInfo -> IdrisParser PTerm

739−let_ syn = try (do reserved "let"; n <- name;

741+let_ syn = try (do reserved "let"; fc <- getFC; n <- name;

740742 ty <- option Placeholder (do lchar ':'; expr' syn)

741743 lchar '='

742744 v <- expr syn

745+ ts <- option [] (do lchar '|'

746+ sepBy1 (do_alt syn) (lchar '|'))

743747 reserved "in"; sc <- expr syn

744− return (PLet n ty v sc))

748+ case ts of

749+ [] -> return (PLet n ty v sc)

750+ alts -> return (PCase fc v ((PRef fc n, sc) : ts)))

745751 <|> (do reserved "let"; fc <- getFC; pat <- expr' (syn { inPattern = True } )

746752 symbol "="; v <- expr syn

753+ ts <- option [] (do lchar '|'

754+ sepBy1 (do_alt syn) (lchar '|'))

747755 reserved "in"; sc <- expr syn

748− return (PCase fc v [(pat, sc)]))

756+ return (PCase fc v ((pat, sc) : ts)))

749757 <?> "let binding"

750758

751759{- | Parses a quote goal

@@ -967,17 +975,28 @@ do_ syn

967975 symbol "<-"

968976 fc <- getFC

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

971982 <|> try (do i <- expr' syn

972983 symbol "<-"

973984 fc <- getFC

974985 e <- expr syn;

975− return (DoBindP fc i e))

986+ option (DoBindP fc i e [])

987+ (do lchar '|'

988+ ts <- sepBy1 (do_alt syn) (lchar '|')

989+ return (DoBindP fc i e ts)))

976990 <|> do e <- expr syn

977991 fc <- getFC

978992 return (DoExp fc e)

979993 <?> "do block expression"

980994

995+do_alt syn = do l <- expr' syn

996+ symbol "=>"

997+ r <- expr' syn

998+ return (l, r)

999+

9811000{- | Parses an expression in idiom brackets

9821001@

9831002Idiom ::= '[|' Expr '|]';

src/Idris/ParseHelpers.hs+23−13

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

1−{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

1+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards, OverlappingInstances, StandaloneDeriving #-}

22module Idris.ParseHelpers where

33

44import Prelude hiding (pi)

@@ -16,6 +16,7 @@ import Idris.AbsSyntax

1616import Idris.Core.TT

1717import Idris.Core.Evaluate

1818import Idris.Delaborate (pprintErr)

19+import Idris.Docstrings

1920

2021import qualified Util.Pretty as Pretty (text)

2122

@@ -41,11 +42,19 @@ import Debug.Trace

4142type IdrisParser = StateT IState IdrisInnerParser

4243

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

4546

46−instance TokenParsing IdrisInnerParser where

47− someSpace = many (simpleWhiteSpace <|> singleLineComment <|> multiLineComment) *> pure ()

47+deriving instance Parsing IdrisInnerParser

4848

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

4958-- | Generalized monadic parsing constraint type

5059type MonadicParsing m = (DeltaParsing m, LookAheadParsing m, TokenParsing m, Monad m)

5160

@@ -139,25 +148,26 @@ multiLineComment = try (string "{-" *> (string "-}") *> pure ())

139148{-| Parses a documentation comment (similar to haddoc) given a marker character

140149

141150@

142− DocComment_t ::= '--' DocCommentMarker_t ~EOL_t* EOL_t

143− | '{ -' DocCommentMarket_t ~'- }'* '- }'

151+ DocComment_t ::= '|||' ~EOL_t* EOL_t

144152 ;

145153@

146154 -}

147−docComment :: IdrisParser (String, [(Name, String)])

155+docComment :: IdrisParser (Docstring, [(Name, Docstring)])

148156docComment = do dc <- pushIndent *> docCommentLine

149157 rest <- many (indented docCommentLine)

150158 args <- many (indented argDocCommentLine)

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

153162

154163 where docCommentLine :: MonadicParsing m => m String

155164 docCommentLine = try (do string "|||"

156− many (satisfy isSpace)

157− first <- satisfy (\c -> not (isEol c || c == '@'))

158− res <- many (satisfy (not . isEol))

165+ many (satisfy (==' '))

166+ contents <- option "" (do first <- satisfy (\c -> not (isEol c || c == '@'))

167+ res <- many (satisfy (not . isEol))

168+ return $ first:res)

159169 eol ; someSpace

160− return (first:res))-- ++ concat rest))

170+ return contents)-- ++ concat rest))

161171 <?> ""

162172 argDocCommentLine = do string "|||"

163173 many (satisfy isSpace)

@@ -328,7 +338,7 @@ getFC :: MonadicParsing m => m FC

328338getFC = do s <- position

329339 let (dir, file) = splitFileName (fileName s)

330340 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

332342

333343{-* Syntax helpers-}

334344-- | Bind constraints to term

src/Idris/ParseOps.hs−1

@@ -59,7 +59,6 @@ binary name f = Infix (do fc <- getFC

5959 indentPropHolds gtProp

6060 reservedOp name

6161 indentPropHolds gtProp

62− doc <- option ("", []) docComment

6362 return (f fc))

6463

6564-- | Prefix operator

src/Idris/Parser.hs+13−9

@@ -35,6 +35,8 @@ import Idris.ParseOps

3535import Idris.ParseExpr

3636import Idris.ParseData

3737

38+import Idris.Docstrings

39+

3840import Paths_idris

3941

4042import Util.DynamicLinker

@@ -315,7 +317,7 @@ fnDecl' syn = checkFixity $

315317 do (doc, fc, opts', n, acc) <- try (do

316318 pushIndent

317319 ist <- get

318− doc <- option ("", []) docComment

320+ doc <- option noDocs docComment

319321 ist <- get

320322 let initOpts = if default_total ist

321323 then [TotalFn]

@@ -382,6 +384,7 @@ fnOpts :: [FnOpt] -> IdrisParser [FnOpt]

382384fnOpts opts

383385 = do reserved "total"; fnOpts (TotalFn : opts)

384386 <|> do reserved "partial"; fnOpts (PartialFn : (opts \\ [TotalFn]))

387+ <|> do reserved "covering"; fnOpts (CoveringFn : (opts \\ [TotalFn]))

385388 <|> do try (lchar '%' *> reserved "export"); c <- stringLiteral;

386389 fnOpts (CExport c : opts)

387390 <|> do try (lchar '%' *> reserved "assert_total");

@@ -413,7 +416,7 @@ Postulate ::=

413416@

414417-}

415418postulate :: SyntaxInfo -> IdrisParser PDecl

416−postulate syn = do doc <- try $ do doc <- option ("", []) docComment

419+postulate syn = do doc <- try $ do doc <- option noDocs docComment

417420 pushIndent

418421 reserved "postulate"

419422 return doc

@@ -561,7 +564,7 @@ Class ::=

561564-}

562565class_ :: SyntaxInfo -> IdrisParser [PDecl]

563566class_ syn = do (doc, acc) <- try (do

564− doc <- option ("", []) docComment

567+ doc <- option noDocs docComment

565568 acc <- optional accessibility

566569 return (doc, acc))

567570 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

10031006 mapM_ (addNameHint ty') ns

10041007 mapM_ (\n -> addIBC (IBCNameHint (ty', n))) ns)]

10051008 <|> do try (lchar '%' *> reserved "error_handlers")

1006− fn <- iName []

1007− arg <- iName []

1009+ fn <- fnName

1010+ arg <- fnName

10081011 ns <- sepBy1 name (lchar ',')

10091012 return [PDirective (do fn' <- disambiguate fn

10101013 ns' <- mapM disambiguate ns

@@ -1113,7 +1116,8 @@ findFC x = let s = show (plain x) in

11131116 case span (/= ':') s of

11141117 (failname, ':':rest) -> case span isDigit rest of

11151118 (line, ':':rest') -> case span isDigit rest' of

1116− (col, ':':msg) -> (FC failname (read line) (read col), msg)

1119+ (col, ':':msg) -> let pos = (read line, read col) in

1120+ (FC failname pos pos, msg)

11171121

11181122-- | A program is a list of declarations, possibly with associated

11191123-- documentation strings.

@@ -1129,7 +1133,7 @@ parseProg syn fname input mrk

11291133 case idris_outputmode i of

11301134 RawOutput -> ihputStrLn (idris_outh i) (show doc)

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

11331137 return []

11341138 Success (x, i) -> do putIState i

11351139 reportParserWarnings

@@ -1147,7 +1151,7 @@ parseProg syn fname input mrk

11471151loadModule :: Handle -> FilePath -> Idris String

11481152loadModule outh f

11491153 = idrisCatch (loadModule' outh f)

1150− (\e -> do setErrLine (getErrLine e)

1154+ (\e -> do setErrSpan (getErrSpan e)

11511155 ist <- getIState

11521156 msg <- showErr e

11531157 ihputStrLn outh msg

@@ -1195,7 +1199,7 @@ loadFromIFile h (LIDR fn) = loadSource' h True fn

11951199loadSource' :: Handle -> Bool -> FilePath -> Idris ()

11961200loadSource' h lidr r

11971201 = idrisCatch (loadSource h lidr r)

1198− (\e -> do setErrLine (getErrLine e)

1202+ (\e -> do setErrSpan (getErrSpan e)

11991203 ist <- getIState

12001204 ihRenderError h (pprintErr ist e))

12011205

src/Idris/Prover.hs+9−8

@@ -89,10 +89,10 @@ elabStep st e = do case runStateT e st of

8989 Error a -> ierror a

9090

9191dumpState :: IState -> ProofState -> Idris ()

92−dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

92+dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

9393 do rendered <- iRender $ prettyName False [] nm <> colon <+> text "No more goals."

9494 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

9696 let OK ty = goalAtFocus ps

9797 let OK env = envAtFocus ps

9898 let state = prettyOtherGoals hs <> line <>

@@ -104,7 +104,7 @@ dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = d

104104 where

105105 showImplicits = opt_showimp (idris_options ist)

106106

107− tPretty bnd t = pprintPTerm showImplicits bnd $ delab ist t

107+ tPretty bnd t = pprintPTerm showImplicits bnd [] $ delab ist t

108108

109109 assumptionNames :: Env -> [Name]

110110 assumptionNames = map fst

@@ -164,6 +164,7 @@ receiveInput e =

164164ploop :: Name -> Bool -> String -> [String] -> ElabState [PDecl] -> Maybe History -> Idris (Term, [String])

165165ploop fn d prompt prf e h

166166 = do i <- getIState

167+ let autoSolve = opt_autoSolve (idris_options i)

167168 when d $ dumpState i (proof e)

168169 (x, h') <-

169170 case idris_outputmode i of

@@ -235,8 +236,8 @@ ploop fn d prompt prf e h

235236 TType _ ->

236237 ihPrintTermWithType h (prettyImp imp PType) type1Doc

237238 _ -> let bnd = map (\x -> (fst x, False)) env in

238− ihPrintTermWithType h (pprintPTerm imp bnd (delab ist tm))

239− (pprintPTerm imp bnd (delab ist ty))

239+ ihPrintTermWithType h (pprintPTerm imp bnd [] (delab ist tm))

240+ (pprintPTerm imp bnd [] (delab ist ty))

240241 putIState ist

241242 return (False, e, False, prf))

242243 (\err -> do putIState ist { tt_ctxt = ctxt } ; ierror err)

@@ -253,14 +254,14 @@ ploop fn d prompt prf e h

253254 let tm' = force (normaliseAll ctxt' env tm)

254255 ty' = force (normaliseAll ctxt' env ty)

255256 imp = opt_showimp (idris_options ist')

256− tmDoc = pprintPTerm imp bnd (delab ist' tm')

257− tyDoc = pprintPTerm imp bnd (delab ist' ty')

257+ tmDoc = pprintPTerm imp bnd [] (delab ist' tm')

258+ tyDoc = pprintPTerm imp bnd [] (delab ist' ty')

258259 ihPrintTermWithType (idris_outh ist') tmDoc tyDoc

259260 putIState ist

260261 return (False, e, False, prf))

261262 (\err -> do putIState ist ; ierror err)

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

264265-- trace (show (problems (proof st))) $

265266 iPrintResult ""

266267 return (True, st, False, prf ++ [step]))

src/Idris/REPL.hs+51−10

@@ -4,12 +4,14 @@

44module Idris.REPL where

55

66import Idris.AbsSyntax

7+import Idris.Apropos (apropos)

78import Idris.REPLParser

89import Idris.ElabDecls

910import Idris.ElabTerm

1011import Idris.Error

1112import Idris.ErrReverse

1213import Idris.Delaborate

14+import Idris.Docstrings (Docstring, overview, renderDocstring)

1315import Idris.Prover

1416import Idris.Parser

1517import Idris.Primitives

@@ -21,7 +23,7 @@ import Idris.Completion

2123import qualified Idris.IdeSlave as IdeSlave

2224import Idris.Chaser

2325import Idris.Imports

24−import Idris.Colours

26+import Idris.Colours hiding (colourise)

2527import Idris.Inliner

2628import Idris.CaseSplit

2729import Idris.DeepSeq

@@ -42,6 +44,7 @@ import IRTS.Compiler

4244import IRTS.CodegenCommon

4345

4446import Data.List.Split (splitOn)

47+import qualified Data.Text as T

4548

4649import Text.Trifecta.Result(Result(..))

4750

@@ -238,7 +241,7 @@ ideslave orig mods

238241 isetPrompt (mkPrompt [filename])

239242 -- Report either success or failure

240243 i <- getIState

241− case (errLine i) of

244+ case (errSpan i) of

242245 Nothing -> iPrintResult $ "loaded " ++ filename

243246 Just x -> iPrintError $ "didn't load " ++ filename

244247 ideslave orig [filename]

@@ -246,7 +249,7 @@ ideslave orig mods

246249 case splitName name of

247250 Left err -> iPrintError err

248251 Right n -> process stdout "(ideslave)"

249− (Check (PRef (FC "(ideslave)" 0 0) n))

252+ (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))

250253 Just (IdeSlave.DocsFor name) ->

251254 case splitName name of

252255 Left err -> iPrintError err

@@ -263,6 +266,25 @@ ideslave orig mods

263266 process stdout fn (MakeWith False line (sUN name))

264267 Just (IdeSlave.ProofSearch line name hints) ->

265268 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

266288 Nothing -> do iPrintError "did not understand")

267289 (\e -> do iPrintError $ show e))

268290 (\e -> do iPrintError $ show e)

@@ -334,6 +356,8 @@ ideslaveProcess fn (MakeWith False pos str) = process stdout fn (MakeWith False

334356ideslaveProcess fn (DoProofSearch False pos str xs) = process stdout fn (DoProofSearch False pos str xs)

335357ideslaveProcess fn (SetConsoleWidth w) = do process stdout fn (SetConsoleWidth w)

336358 iPrintResult ""

359+ideslaveProcess fn (Apropos a) = do process stdout fn (Apropos a)

360+ iPrintResult ""

337361ideslaveProcess fn _ = iPrintError "command not recognized or not supported"

338362

339363

@@ -412,8 +436,8 @@ edit f orig

412436 = do i <- getIState

413437 env <- runIO $ getEnvironment

414438 let editor = getEditor env

415− let line = case errLine i of

416− Just l -> " +" ++ show l ++ " "

439+ let line = case errSpan i of

440+ Just l -> " +" ++ show (fst (fc_start l)) ++ " "

417441 Nothing -> " "

418442 let cmd = editor ++ line ++ fixName f

419443 runIO $ system cmd

@@ -511,7 +535,7 @@ process h fn (Check (PRef _ n))

511535 annotate (AnnName n Nothing Nothing) (text $ show n) <+> colon <+>

512536 align (tPretty bnd ist g)

513537

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

515539

516540

517541process h fn (Check t)

@@ -710,7 +734,7 @@ process h fn (MakeWith updatefile l n)

710734 runIO $ copyFile fb fn

711735 else ihPrintResult h with

712736 where getIndent s = length (takeWhile isSpace s)

713−

737+

714738process h fn (DoProofSearch updatefile l n hints)

715739 = do src <- runIO $ readFile fn

716740 let (before, tyline : later) = splitAt (l-1) (lines src)

@@ -932,6 +956,8 @@ process h fn (SetOpt ShowImpl) = setImpShow True

932956process h fn (UnsetOpt ShowImpl) = setImpShow False

933957process h fn (SetOpt ShowOrigErr) = setShowOrigErr True

934958process h fn (UnsetOpt ShowOrigErr) = setShowOrigErr False

959+process h fn (SetOpt AutoSolve) = setAutoSolve True

960+process h fn (UnsetOpt AutoSolve) = setAutoSolve False

935961

936962process h fn (SetOpt _) = iPrintError "Not a valid option"

937963process h fn (UnsetOpt _) = iPrintError "Not a valid option"

@@ -950,6 +976,21 @@ process h fn ListErrorHandlers =

950976 iPrintResult $ "Registered error handlers: " ++ (concat . intersperse ", " . map show) handlers

951977process h fn (SetConsoleWidth w) = setWidth w

952978

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

953994

954995classInfo :: ClassInfo -> Idris ()

955996classInfo ci = do iputStrLn "Methods:\n"

@@ -1123,7 +1164,7 @@ loadInputs h inputs

11231164 -- to check everything worked consistently (in particular, will catch

11241165 -- if the ibc version is out of date) if we weren't loading per

11251166 -- module

1126− case errLine inew of

1167+ case errSpan inew of

11271168 Nothing ->

11281169 do putIState ist

11291170 when (not loadCode) $ tryLoad $ nub (concat ifiles)

@@ -1131,10 +1172,10 @@ loadInputs h inputs

11311172 putIState inew)

11321173 (\e -> do i <- getIState

11331174 case e of

1134− At f _ -> do setErrLine (fc_line f)

1175+ At f _ -> do setErrSpan f

11351176 ihRenderError stdout $ pprintErr i e

11361177 ProgramLineComment -> return () -- fail elsewhere

1137− _ -> do setErrLine 3 -- FIXME! Propagate it

1178+ _ -> do setErrSpan emptyFC -- FIXME! Propagate it

11381179 iputStrLn (pshow i e))

11391180 where -- load all files, stop if any fail

11401181 tryLoad :: [IFileType] -> Idris ()

src/Idris/REPLParser.hs+2

@@ -98,6 +98,7 @@ pCmd = do P.whiteSpace; try (do cmd ["q", "quit"]; eof; return Quit)

9898 <|> try (do cmd ["patt"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Pattelab t))

9999 <|> try (do cmd ["errorhandlers"]; eof ; return ListErrorHandlers)

100100 <|> try (do cmd ["consolewidth"]; w <- pConsoleWidth ; return (SetConsoleWidth w))

101+ <|> try (do cmd ["apropos"]; str <- many anyChar ; return (Apropos str))

101102 <|> do P.whiteSpace; do eof; return NOP

102103 <|> do t <- P.fullExpr defaultSyntax; return (Eval t)

103104

@@ -107,6 +108,7 @@ pOption :: P.IdrisParser Opt

107108pOption = do discard (P.symbol "errorcontext"); return ErrContext

108109 <|> do discard (P.symbol "showimplicits"); return ShowImpl

109110 <|> do discard (P.symbol "originalerrors"); return ShowOrigErr

111+ <|> do discard (P.symbol "autosolve"); return AutoSolve

110112

111113pConsoleWidth :: P.IdrisParser ConsoleWidth

112114pConsoleWidth = do discard (P.symbol "auto"); return AutomaticWidth

src/Idris/Unlit.hs+2−2

@@ -24,8 +24,8 @@ check f l [x] = return ()

2424check f l [] = return ()

2525

2626chkAdj :: FilePath -> Int -> LineType -> LineType -> TC ()

27−chkAdj f l Prog Comm = tfail $ At (FC f l 0) ProgramLineComment --TODO: Include column?

28−chkAdj f l Comm Prog = 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) (l, 0)) ProgramLineComment --TODO: Span correctly

2929chkAdj f l _ _ = return ()

3030

3131

src/Pkg/Package.hs+2−2

@@ -52,7 +52,7 @@ buildPkg warnonly (install, fp)

5252 Nothing -> exitWith (ExitFailure 1)

5353 Just ist -> do

5454 -- Quit with error code if there was a problem

55− case errLine ist of

55+ case errSpan ist of

5656 Just _ -> exitWith (ExitFailure 1)

5757 _ -> return ()

5858 -- Also give up if there are metavariables to solve

@@ -85,7 +85,7 @@ checkPkg warnonly quit fpath

8585 when quit $ case res of

8686 Nothing -> exitWith (ExitFailure 1)

8787 Just res' -> do

88− case errLine res' of

88+ case errSpan res' of

8989 Just _ -> exitWith (ExitFailure 1)

9090 _ -> return ()

9191

test/Makefile+3−3

@@ -8,13 +8,13 @@ test: $(TESTS)

88 @perl ./runtest.pl $(patsubst %.test,%,$@)

99

1010test_java:

11− perl ./runtest.pl without buffer001 --codegen Java

11+ perl ./runtest.pl without sugar004 buffer001 --codegen Java

1212

1313test_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

1515

1616test_llvm:

17− @perl ./runtest.pl without io003 buffer001 --codegen llvm

17+ @perl ./runtest.pl without sugar004 io003 buffer001 --codegen llvm

1818

1919update:

2020 /usr/bin/env perl ./runtest.pl all -u

test/README+1

@@ -12,5 +12,6 @@ primitives: Primitive types

1212proof: Theorem proving, tactics

1313sugar: Syntactic sugar, syntax extensions

1414totality: Totality checking

15+tutorial: Examples from the tutorial

1516

1617reg: Regression tests, covering previous bug fixes

test/basic006/expected+7−6

@@ -1,13 +1,14 @@

11When elaborating right hand side of foo:

2−test020a.idr:14:18:Can't unify

3− Vect n a

4−with

5− List a

6−

7−Specifically:

2+test020a.idr:14:18:When elaborating an application of function Prelude.List.reverse:

83 Can't unify

94 Vect n a

105 with

116 List a

7+

8+ Specifically:

9+ Can't unify

10+ Vect n a

11+ with

12+ List a

1213[3, 2, 1]

1314"Number 42"

test/basic009/expected+2−1

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

11MAIN-PASS

22Faulty.idr:6:7:When elaborating type of Faulty.fault:

3−Can't disambiguate name: A.num, B.C.num

3+When elaborating an application of type constructor =:

4+ Can't disambiguate name: A.num, B.C.num

45Multiple.idr:3:1:import alias not unique: "X"

test/effects001/test021.idr+7−9

@@ -5,11 +5,11 @@ import Effect.State

55import Effect.StdIO

66import Control.IOExcept

77

8−data FName = Count | NotCount

8+data Count : Type where

99

1010FileIO : Type -> Type -> Type

1111FileIO 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

1313

1414readFile : FileIO (OpenFile Read) (List String)

1515readFile = readAcc [] where

@@ -22,14 +22,12 @@ readFile = readAcc [] where

2222 else return (reverse acc)

2323

2424testFile : FileIO () ()

25−testFile = do open "testFile" Read

26− if_valid then do putStrLn (show !readFile)

27− close

28− putStrLn (show !(Count :- get))

29− else putStrLn ("Error!")

25+testFile = do True <- open "testFile" Read | False => putStrLn "Error!"

26+ putStrLn (show !readFile)

27+ close

28+ putStrLn (show !(Count :- get))

3029

3130main : IO ()

32−main = do ioe_run (run [(), (), Count := 0] testFile)

33− (\err => print err) (\ok => return ())

31+main = run testFile

3432

3533

test/effects001/test021a.idr+2−2

@@ -17,7 +17,7 @@ Env = List (String, Integer)

1717-- Evaluator t

1818-- = Eff m [EXCEPTION String, RND, STATE Env] t

1919

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

20+eval : Expr -> { [EXCEPTION String, STDIO, RND, STATE Env] } Eff IO Integer

2121eval (Var x) = do vs <- get

2222 case lookup x vs of

2323 Nothing => raise ("No such variable " ++ x)

@@ -32,7 +32,7 @@ testExpr : Expr

3232testExpr = Add (Add (Var "foo") (Val 42)) (Random 100)

3333

3434runEval : List (String, Integer) -> Expr -> IO Integer

35−runEval args expr = run [(), (), 123456, args] (eval expr)

35+runEval args expr = runInit [(), (), 123456, args] (eval expr)

3636

3737main : IO ()

3838main = do let x = 42

test/effects002/test025.idr+4−4

@@ -5,8 +5,8 @@ import Effect.Memory

55import Control.IOExcept

66

77MemoryIO : Type -> Type -> Type -> Type

8−MemoryIO td ts r = Eff (IOExcept String) [ Dst ::: RAW_MEMORY td

9− , Src ::: RAW_MEMORY ts ] r

8+MemoryIO td ts r = { [ Dst ::: RAW_MEMORY td

9+ , Src ::: RAW_MEMORY ts ] } Eff (IOExcept String) r

1010

1111inpVect : Vect 5 Bits8

1212inpVect = map prim__truncInt_B8 [0, 1, 2, 3, 5]

@@ -28,7 +28,7 @@ testMemory = do Src :- allocate 5

2828 return (map (prim__zextB8_Int) res)

2929

3030main : IO ()

31−main = do ioe_run (run [Dst := (), Src := ()] testMemory)

32− (\err => print err) (\ok => print ok)

31+main = ioe_run (runInit [Dst := (), Src := ()] testMemory)

32+ (\err => print err) (\ok => print ok)

3333

3434

test/error003/ErrorReflection.idr−11

@@ -59,17 +59,6 @@ dslerr (CantUnify _ tm1 tm2 _ _ _) = do tm1' <- getTmTy tm1

5959 ty1 <- reifyTy tm1'

6060 ty2 <- reifyTy tm2'

6161 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'])

7362dslerr _ = Nothing

7463

7564

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 :

3− DSL type error: (t'(504) => t'(504)) doesn't match ()

1+ErrorReflection.idr:67:5:When elaborating right hand side of bad:

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

66

77%language ErrorReflection

88

9+

910total

1011cadr : (xs : List a)

1112 -> {auto cons1 : isCons xs = True}

@@ -18,7 +19,6 @@ extractList : TT -> Maybe TT

1819extractList (App (App reflCon (App isCons lst)) _) = Just lst

1920extractList _ = Nothing

2021

21−

2222total

2323has2elts : Err -> Maybe (List ErrorReportPart)

2424has2elts (CantSolveGoal tm _) = do lst <- extractList tm

@@ -38,4 +38,4 @@ badCadr2 : Int

3838badCadr2 = cadr [1]

3939

4040goodCadr : Int

41−goodCadr = cadr [1, 2]

41+goodCadr = cadr [1, 2]

test/error004/expected+4−2

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

11FunErrTest.idr:35:10:When elaborating right hand side of badCadr1:

2−Could not prove that [] has at least two elements.

2+When elaborating argument cons1 to function FunErrTest.cadr:

3+ Could not prove that [] has at least two elements.

34FunErrTest.idr:38:10:When elaborating right hand side of badCadr2:

4−Could not prove that tail [(fromInteger 1)] refl has at least two elements.

5+When elaborating argument cons2 to function FunErrTest.cadr:

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:

2−Can't unify

3− IsJust (Just x)

4−with

5− IsJust (prove (getProof x))

6−

7−Specifically:

1+Reflect.idr:207:38:When elaborating right hand side of testReflect1:

2+When elaborating an application of function Reflect.getJust:

83 Can't unify

9− Just x

4+ IsJust (Just x)

105 with

11− Nothing

6+ IsJust (prove (getProof x))

7+

8+ Specifically:

9+ Can't unify

10+ Just x

11+ with

12+ Nothing

test/reg007/expected+1−1

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

11reg007.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:

33Can't unify

44 n = lala

55with

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

22reg018b.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}

44reg018d.idr:5:1:Main.pull is not total as there are missing cases

test/reg034/expected+18−16

@@ -1,22 +1,24 @@

11reg034.idr:6:5:When elaborating left hand side of bar:

2−Can't unify

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:

2+When elaborating an application of main.bar:

83 Can't unify

9− [92mlength[0m [95mys[0m

4+ [95mx[0m [94m=[0m [95mx[0m

105 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

1213reg034.idr:9:5:When elaborating left hand side of foo:

13−Can't unify

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:

14+When elaborating an application of main.foo:

1915 Can't unify

20− [95mf[0m [95my[0m

16+ [95mx[0m [94m=[0m [95mx[0m

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