31b2346 · Idris-dev · git.iko.soy

.travis.yml+10−7

@@ -6,6 +6,10 @@ before_install:

6 - sudo apt-get install -qq libghc-unordered-containers-dev libghc-mtl-dev libghc-network-dev libghc-xml-dev libghc-transformers-dev libghc-text-dev libghc-utf8-string-dev libghc-vector-dev libghc-split-dev libghc-ansi-terminal-dev libghc-ansi-wl-pprint-dev

7 # trifecta dependencies

8 - sudo apt-get install -qq libghc-blaze-builder-dev libghc-blaze-html-dev libghc-data-lens-dev libghc-bifunctors-dev libghc-hashable-dev libghc-semigroups-dev libghc-semigroupoids-dev libghc-parallel-dev libghc-comonad-dev libghc-terminfo-dev libghc-keys-dev

9+ # Haddock dependencies

10+ - sudo apt-get install hscolour

11+ # test dependency

12+ - sudo apt-get install -qq expect

9install:

13install:

10 - cabal install -f FFI -f LLVM --only-dependencies --enable-tests

14 - cabal install -f FFI -f LLVM --only-dependencies --enable-tests

11before_script:

15before_script:

@@ -15,12 +19,11 @@ before_script:

15 - cd idris*

19 - cd idris*

16script:

20script:

17 - cabal configure -f FFI -f LLVM

21 - cabal configure -f FFI -f LLVM

18− - cabal build

22+ - if [[ "$TESTS" != "doc" ]]; then cabal build; fi

19− - cabal copy

23+ - if [[ "$TESTS" != "doc" ]]; then cabal copy; fi

20 - make -j2 $TESTS

24 - make -j2 $TESTS

21env:

25env:

22− # TESTS=doc

26+ - TESTS="doc"

23− - TESTS=test_c

27+ - TESTS="test_c"

24− - TESTS=test_java

25− - TESTS=test_llvm

28+ - TESTS="test_llvm"

26− - TESTS=test_js

29+ - TESTS="test_js"

CHANGELOG+59−5

@@ -1,15 +1,69 @@

1+New in 0.9.14:

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

3+* Support for running tests for a package with the tests section of .ipkg files and the

4+ --testpkg command-line option

5+* Clearly distinguish between type providers and postulate providers at the use site

6+

7+New in 0.9.13:

8+--------------

9+* IDE support for retrieving structured information about metavariables

10+* Experimental Bits support for JavaScript

11+* IdrisDoc: a Haddock- and JavaDoc-like HTML documentation generator

12+* Command line option -e (or --eval) to evaluate expressions without loading the

13+ REPL. This is useful for writing more portable tests.

14+* Many more of the basic functions and datatypes are documented.

15+* Primitive types such as Int and String are documented

16+* Removed javascript lib in favor of idris-hackers/iQuery

17+* Specify codegen for :compile REPL command (e.g. :compile javascript program.js)

18+* Remove :info REPL command, subsume and enhance its functionality in the :doc command

19+* New (first class) nested record update/access syntax:

20+ record { a->b->c = val } x -- sets field accessed by c (b (a x)) to val

21+ record { a->b->c } x -- accesses field, equivalent to c (b (a x))

22+* The banner at startup can be suppressed by adding :set nobanner to the initialisation script.

23+* :apropos now accepts space-delimited lists of query items, and searches for the conjunction

24+ of its inputs. It also accepts binder syntax as search strings - for instance, -> finds

25+ functions.

26+* Totality errors are now treated as warnings until code generation time, when they become

27+ errors again. This allows users to use the interactive editing features to fix totality

28+ issues, but no programs that violate the stated assumptions will actually run.

29+* Added :makelemma command, which adds a new top level definition to solve

30+ a metavariable.

31+* Extend :addclause to add instance bodies as well as definitions

32+* Reverse parameters to BoundedList -- now matches Vect, and is easier to instantiate classes.

33+* Move foldl into Foldable so it can be overridden.

34+* Experimental :search REPL command for finding functions by type

35+

36+Internal changes

37+

38+* New implementation of erasure

39+

1New in 0.9.12:

40New in 0.9.12:

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

41--------------

3

42

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

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

5 type inference.

44 type inference.

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

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

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

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

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

47+* Concept of 'null' is now understood in the JavaScript and Node codegen.

9−* Lots of performance patches for generated JavaScript

48+* Lots of performance patches for generated JavaScript.

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

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

11− or show the type of expressions

50+ or show the type of expressions.

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

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

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

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

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

55+ ||| Add two natural numbers

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

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

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

59+* Allow the auto-solve behaviour in the prover to be disabled, for easier

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

61+* Updated 'effects' library

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

63+* Unification errors are now slightly more informative

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

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

66+ descendants cover all possible inputs

13

67

14New in 0.9.11:

68New in 0.9.11:

15--------------

69--------------

CONTRIBUTORS+7−4

@@ -8,24 +8,27 @@ Edwin Brady

8David Raymond Christiansen

9Jason Dagit

10Simon Fowler

11+Google

11Cezar Ionescu

12Cezar Ionescu

12Irene Knapp

13Irene Knapp

14+Paul Koerbitz

15+Shea Levy

13Mathnerd314

16Mathnerd314

14Hannes Mehnert

17Hannes Mehnert

15Mekeor Melire

18Mekeor Melire

16Melissa Mozifian

19Melissa Mozifian

17Dominic Mulligan

20Dominic Mulligan

18Jan de Muijnck-Hughes

21Jan de Muijnck-Hughes

19−raichoo

20Tom Prince

22Tom Prince

23+raichoo

24+Philip Rasmussen

25+Reynir Reynisson

21Seo Sanghyeon

26Seo Sanghyeon

22Benjamin Saunders

27Benjamin Saunders

23startling

28startling

24Chetan T

29Chetan T

30+Matúš Tejiščák

25Dirk Ullrich

31Dirk Ullrich

26Leif Warner

32Leif Warner

27Daniel Waterworth

33Daniel Waterworth

28Jonas Westerlund

34Jonas Westerlund

29−Reynir Reynisson

30−Shea Levy

31−

Makefile+2−2

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

39 $(CABAL) install $(CABALFLAGS)

40

41linecount:

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

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

43

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

45doc: dist/setup-config

46− $(CABAL) haddock --executables --hyperlink-source --html --hoogle --html-location="http://hackage.haskell.org/packages/archive/\$$pkg/latest/doc/html" --haddock-options="--title Idris"

46+ $(CABAL) haddock --hyperlink-source --html --hoogle --html-location="http://hackage.haskell.org/packages/archive/\$$pkg/latest/doc/html" --haddock-options="--title Idris"

47

48

49dist/setup-config:

README+1−1

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

1−Idris (http://idris-lang.org/) is an experimental functional programming

1+Idris (http://idris-lang.org/) is a general-purpose functional programming

2language with dependent types.

3

4To configure, edit config.mk. The default values should work for most people.

benchmarks/ALL+1

@@ -1,2 +1,3 @@

1trivial/sortvec 2000

2quasigroups/qgsolve board

3+fasta/fasta 1

benchmarks/fasta/fasta.idrnew file+84

@@ -0,0 +1,84 @@

1+module Main

2+

3+import System

4+import Data.Floats

5+

6+alu : String

7+alu = "GGCCGGGCGCGGTGGCTCACGCCTGTAATCCCAGCACTTTGGGAGGCCGAGGCGGGCGGATCACCTGAGG\

8+ \TCAGGAGTTCGAGACCAGCCTGGCCAACATGGTGAAACCCCGTCTCTACTAAAAATACAAAAATTAGCCGGG\

9+ \CGTGGTGGCGCGCGCCTGTAATCCCAGCTACTCGGGAGGCTGAGGCAGGAGAATCGCTTGAACCCGGGAGGC\

10+ \GGAGGTTGCAGTGAGCCGAGATCGCGCCACTGCACTCCAGCCTGGGCGACAGAGCGAGACTCCGTCTCAAAAA"

11+

12+iub : List (Char, Float)

13+iub = [('a',0.27),('c',0.12),('g',0.12),('t',0.27),('B',0.02)

14+ ,('D',0.02),('H',0.02),('K',0.02),('M',0.02),('N',0.02)

15+ ,('R',0.02),('S',0.02),('V',0.02),('W',0.02),('Y',0.02)]

16+

17+homosapiens : List (Char, Float)

18+homosapiens = [('a',0.3029549426680),('c',0.1979883004921)

19+ ,('g',0.1975473066391),('t',0.3015094502008)]

20+

21+

22+takeRepeat : Int -> String -> String

23+takeRepeat n s = if n > m

24+ then s ++ takeRepeat (n-m) s

25+ else pack $ take (cast n) $ unpack s

26+ where

27+ m = cast $ length s

28+

29+splitAt' : Nat -> String -> (String, String)

30+splitAt' n s = let s' = unpack s in (pack $ take n s', pack $ drop n s')

31+

32+writeAlu : String -> String -> IO ()

33+writeAlu name s0 = putStrLn name $> go s0

34+ where

35+ go "" = return ()

36+ go s = let (h,t) = splitAt' 60 s in putStrLn h $> go t

37+

38+replicate : Int -> Char -> String

39+replicate 0 c = ""

40+replicate n c = singleton c <+> replicate (n-1) c

41+

42+scanl : (f : acc -> a -> acc) -> acc -> List a -> List acc

43+scanl f q ls = q :: (case ls of

44+ [] => []

45+ x::xs => scanl f (f q x) xs)

46+

47+accum : (Char,Float) -> (Char,Float) -> (Char,Float)

48+accum (_,p) (c,q) = (c,p+q)

49+

50+make : String -> Int -> List (Char, Float) -> Int -> IO Int

51+make name n0 tbl seed0 = do

52+ putStrLn name

53+ make' n0 0 seed0 ""

54+ where

55+ modulus : Int

56+ modulus = 139968

57+

58+ fill : List (Char,Float) -> Int -> List String

59+ fill ((c,p) :: cps) j =

60+ let k = min modulus (cast (cast modulus * p + 1))

61+ in replicate (k - j) c :: fill cps k

62+ fill _ _ = []

63+

64+ lookupTable : String

65+ lookupTable = Foldable.concat (fill (scanl accum ('a',0) tbl) 0)

66+

67+ make' : Int -> Int -> Int -> String -> IO Int

68+ make' 0 col seed buf = when (col > 0) (putStrLn buf) $> return seed

69+ make' n col seed buf = do

70+ let newseed = modInt (seed * 3877 + 29573) modulus

71+ let nextchar = strIndex lookupTable newseed

72+ let newbuf = buf <+> singleton nextchar

73+ if col+1 >= 60

74+ then putStrLn newbuf $> make' (n-1) 0 newseed ""

75+ else make' (n-1) (col+1) newseed newbuf

76+

77+

78+main : IO ()

79+main = do

80+ (_ :: n :: _) <- getArgs

81+ writeAlu ">ONE Homo sapiens alu" (takeRepeat (fromInteger (cast n)*2) alu)

82+ nseed <- make ">TWO IUB ambiguity codes" (fromInteger (cast n)*3) iub 42

83+ make ">THREE Homo sapiens frequency" (fromInteger (cast n)*5) homosapiens nseed

84+ return ()

benchmarks/fasta/fasta.ipkgnew file+6

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

1+package fasta

2+

3+modules = fasta

4+

5+executable = fasta

6+main = fasta

config.mk+1−1

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

1−CC :=cc

1+CC ?=cc

2CABAL :=cabal

3CFLAGS :=-O2 -Wall -DHAS_PTHREAD $(CFLAGS)

4#CABALFLAGS :=

contribs/idrislang.sty+7−80

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

24\RequirePackage{ifthen}

25\RequirePackage{listings}

26\RequirePackage{xspace}

27+\RequirePackage{textcomp}

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

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

28\newboolean{literate}

29\newboolean{literate}

29\setboolean{literate}{false}

30\setboolean{literate}{false}

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

48\lstdefinelanguage{idris}{%

49\lstdefinelanguage{idris}{%

49 sensitive,%

50 sensitive,%

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

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

51− xleftmargin=\parindent,

52+ xleftmargin=1.5em,

52 tabsize=2,

53 tabsize=2,

54+ upquote=true,

53 basicstyle=\ttfamily,

55 basicstyle=\ttfamily,

54 flexiblecolumns=false,

56 flexiblecolumns=false,

55 commentstyle=\footnotesize\sffamily,

57 commentstyle=\footnotesize\sffamily,

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

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

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

64},

66},

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

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

66−%% Generated using

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

68 morekeywords={%

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

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

70 lambda, variable, index_first, index_next

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

97− % posInjective, negSInjective, posNotNeg, plusZeroLeftNeutralZ,

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

125− % maybeToList, listToMaybe, catMaybes, appendNilRightNeutral,

126− % appendAssociative, lengthAppend, mapPreservesLength,

127− % mapDistributesOverAppend, mapFusion, hasAnyByNilFalse,

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

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

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

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

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

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

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

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

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

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

138 },

71 },

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

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

140 morecomment=[l]--,%

73 morecomment=[l]--,%

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

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

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

167

100

168\lstdefinestyle{default}{%

101\lstdefinestyle{default}{%

169− xleftmargin=\parindent,

170− tabsize=2,

171 basicstyle=\ttfamily

102 basicstyle=\ttfamily

172}

103}

173\lstdefinestyle{numbers}{%

104\lstdefinestyle{numbers}{%

174− xleftmargin=\parindent,

175− tabsize=2,

176 numbers=left,

105 numbers=left,

177 numbersep=10pt,

106 numbersep=10pt,

178 numberstyle=\footnotesize\sffamily,

107 numberstyle=\footnotesize\sffamily,

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

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

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

187 \lstset{language=literateidris}}{%

116 \lstset{language=literateidris}}{%

188 \lstset{language=idris}}

117 \lstset{language=idris}}

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

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

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

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

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

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

192− }

193− {}

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

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

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

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

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

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

examples/bmain.idrdeleted−8

@@ -1,8 +0,0 @@

1−module Main

2−

3−import btree

4−

5−main : IO ()

6−main = do let t = toTree [1,8,2,7,9,3]

7− print (btree.toList t)

8−

examples/btree.idrdeleted−18

@@ -1,18 +0,0 @@

1−module btree

2−

3−data BTree a = Leaf

4− | Node (BTree a) a (BTree a)

5−

6−insert : Ord a => a -> BTree a -> BTree a

7−insert x Leaf = Node Leaf x Leaf

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

9− else (Node l v (insert x r))

10−

11−toList : BTree a -> List a

12−toList Leaf = []

13−toList (Node l v r) = btree.toList l ++ (v :: btree.toList r)

14−

15−toTree : Ord a => List a -> BTree a

16−toTree [] = Leaf

17−toTree (x :: xs) = insert x (toTree xs)

18−

examples/classes.idrdeleted−10

@@ -1,10 +0,0 @@

1−m_add : Maybe Int -> Maybe Int -> Maybe Int

2−m_add x y = do x' <- x -- Extract value from x

3− y' <- y -- Extract value from y

4− return (x' + y') -- Add them

5−

6−m_add' : Maybe Int -> Maybe Int -> Maybe Int

7−m_add' x y = [ x' + y' | x' <- x, y' <- y ]

8−

9−sortAndShow : (Ord a, Show a) => List a -> String

10−sortAndShow xs = show (sort xs)

examples/foo.idrdeleted−10

@@ -1,10 +0,0 @@

1−module foo

2−

3−namespace x

4− test : Int -> Int

5− test x = x * 2

6−

7−namespace y

8− test : String -> String

9− test x = x ++ x

10−

examples/hello.idrdeleted−5

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

1−module Main

2−

3−main : IO ()

4−main = putStrLn "Hello world"

5−

examples/interp.idrdeleted−71

@@ -1,71 +0,0 @@

1−module Main

2−

3−data Ty = TyInt | TyBool| TyFun Ty Ty

4−

5−interpTy : Ty -> Type

6−interpTy TyInt = Int

7−interpTy TyBool = Bool

8−interpTy (TyFun s t) = interpTy s -> interpTy t

9−

10−using (G : Vect n Ty)

11−

12− data Env : Vect n Ty -> Type where

13− Nil : Env Nil

14− (::) : interpTy a -> Env G -> Env (a :: G)

15−

16− data HasType : (i : Fin n) -> Vect n Ty -> Ty -> Type where

17− stop : HasType fZ (t :: G) t

18− pop : HasType k G t -> HasType (fS k) (u :: G) t

19−

20− lookup : HasType i G t -> Env G -> interpTy t

21− lookup stop (x :: xs) = x

22− lookup (pop k) (x :: xs) = lookup k xs

23−

24− data Expr : Vect n Ty -> Ty -> Type where

25− Var : HasType i G t -> Expr G t

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

27− Lam : Expr (a :: G) t -> Expr G (TyFun a t)

28− App : Expr G (TyFun a t) -> Expr G a -> Expr G t

29− Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b ->

30− Expr G c

31− If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a

32−

33− interp : Env G -> {static} Expr G t -> interpTy t

34− interp env (Var i) = lookup i env

35− interp env (Val x) = x

36− interp env (Lam sc) = \x => interp (x :: env) sc

37− interp env (App f s) = interp env f (interp env s)

38− interp env (Op op x y) = op (interp env x) (interp env y)

39− interp env (If x t e) = if interp env x then interp env t

40− else interp env e

41−

42− eId : Expr G (TyFun TyInt TyInt)

43− eId = Lam (Var stop)

44−

45− eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt))

46− eAdd = Lam (Lam (Op (+) (Var stop) (Var (pop stop))))

47−

48− eEq : Expr G (TyFun TyInt (TyFun TyInt TyBool))

49− eEq = Lam (Lam (Op (==) (Var stop) (Var (pop stop))))

50−

51− eDouble : Expr G (TyFun TyInt TyInt)

52− eDouble = Lam (App (App eAdd (Var stop)) (Var stop))

53−

54− app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t

55− app = \f, a => App f a

56−

57− fact : Expr G (TyFun TyInt TyInt)

58− fact = Lam (If (Op (==) (Var stop) (Val 0))

59− (Val 1) (Op (*) (app fact (Op (-) (Var stop) (Val 1))) (Var stop)))

60−

61−testFac : Int

62−testFac = interp [] fact 4

63−

64−unitTestFac : so (interp [] fact 4 == 24)

65−unitTestFac = oh

66−

67−main : IO ()

68−main = do putStr "Enter a number: "

69− x <- getLine

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

71−

examples/letbind.idrdeleted−16

@@ -1,16 +0,0 @@

1−module letbind

2−

3−mirror : List a -> List a

4−mirror xs = let xs' = reverse xs in

5− xs ++ xs'

6−

7−data Person = MkPerson String Int

8−

9−showPerson : Person -> String

10−showPerson p = let MkPerson name age = p in

11− name ++ " is " ++ show age ++ " years old"

12−

13−splitAt : Char -> String -> (String, String)

14−splitAt c x = case break (== c) x of

15− (x, y) => (x, strTail y)

16−

examples/prims.idrdeleted−14

@@ -1,14 +0,0 @@

1−module prims

2−

3−x : Int

4−x = 42

5−

6−foo : String

7−foo = "Sausage machine"

8−

9−bar : Char

10−bar = 'Z'

11−

12−quux : Bool

13−quux = False

14−

examples/universe.idrdeleted−7

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

1−myid : (a : Type) -> a -> a

2−myid _ x = x

3−

4−idid : (a : Type) -> a -> a

5−idid = myid _ myid

6−

7−

examples/usefultypes.idrdeleted−20

@@ -1,20 +0,0 @@

1−

2−intVec : Vect 5 Int

3−intVec = [1, 2, 3, 4, 5]

4−

5−double : Int -> Int

6−double x = x * 2

7−

8−vec : (n ** Vect n Int)

9−vec = (_ ** [3, 4])

10−

11−list_lookup : Nat -> List a -> Maybe a

12−list_lookup _ Nil = Nothing

13−list_lookup Z (x :: xs) = Just x

14−list_lookup (S k) (x :: xs) = list_lookup k xs

15−

16−lookup_default : Nat -> List a -> a -> a

17−lookup_default i xs def = case list_lookup i xs of

18− Nothing => def

19− Just x => x

20−

examples/views.idrdeleted−37

@@ -1,37 +0,0 @@

1−module views

2−

3−data Parity : Nat -> Type where

4− even : Parity (n + n)

5− odd : Parity (S (n + n))

6−

7−parity : (n:Nat) -> Parity n

8−parity Z = even {n=Z}

9−parity (S Z) = odd {n=Z}

10−parity (S (S k)) with (parity k)

11− parity (S (S (j + j))) | even ?= even {n=S j}

12− parity (S (S (S (j + j)))) | odd ?= odd {n=S j}

13−

14−natToBin : Nat -> List Bool

15−natToBin Z = Nil

16−natToBin k with (parity k)

17− natToBin (j + j) | even = False :: natToBin j

18− natToBin (S (j + j)) | odd = True :: natToBin j

19−

20−

21−---------- Proofs ----------

22−

23−views.parity_lemma_2 = proof {

24− intro;

25− intro;

26− rewrite sym (plusSuccRightSucc j j);

27− trivial;

28−}

29−

30−views.parity_lemma_1 = proof {

31− intro;

32− intro;

33− rewrite sym (plusSuccRightSucc j j);

34− trivial;

35−}

36−

37−

idris.cabal+130−13

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

1Name: idris

2−Version: 0.9.11.2

2+Version: 0.9.13

3License: BSD3

4License-file: LICENSE

5Author: Edwin Brady

@@ -46,7 +46,8 @@ Cabal-Version: >= 1.8

46

47Build-type: Custom

48

49+Data-files: idrisdoc/styles.css

49−Data-files: jsrts/Runtime-browser.js

50+ jsrts/Runtime-browser.js

50 jsrts/Runtime-common.js

51 jsrts/Runtime-common.js

51 jsrts/Runtime-node.js

52 jsrts/Runtime-node.js

52 jsrts/jsbn/jsbn.js

53 jsrts/jsbn/jsbn.js

@@ -65,6 +66,7 @@ Extra-source-files:

65

66

66 rts/*.c

67 rts/*.c

67 rts/*.h

68 rts/*.h

69+ rts/windows/*.c

68 rts/Makefile

70 rts/Makefile

69

71

70 libs/Makefile

72 libs/Makefile

@@ -88,6 +90,7 @@ Extra-source-files:

88 libs/base/Language/Reflection/*.idr

90 libs/base/Language/Reflection/*.idr

89 libs/base/Makefile

91 libs/base/Makefile

90 libs/base/Network/*.idr

92 libs/base/Network/*.idr

93+ libs/base/System/*.idr

91 libs/base/System/Concurrency/*.idr

94 libs/base/System/Concurrency/*.idr

92 libs/base/Syntax/*.idr

95 libs/base/Syntax/*.idr

93

96

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

97 libs/effects/Effect/*.idr

100 libs/effects/Effect/*.idr

98 libs/effects/*.idr

101 libs/effects/*.idr

99

102

100− libs/neweffects/Makefile

103+ libs/oldeffects/Makefile

101− libs/neweffects/neweffects.ipkg

104+ libs/oldeffects/oldeffects.ipkg

102− libs/neweffects/Effect/*.idr

105+ libs/oldeffects/Effect/*.idr

103− libs/neweffects/*.idr

106+ libs/oldeffects/*.idr

104−

105− libs/javascript/*.idr

106− libs/javascript/JavaScript/*.idr

107− libs/javascript/Makefile

108− libs/javascript/javascript.ipkg

109

107

110 llvm/*.c

108 llvm/*.c

111 llvm/Makefile

109 llvm/Makefile

@@ -221,6 +219,29 @@ Extra-source-files:

221 test/reg036/run

219 test/reg036/run

222 test/reg036/*.idr

220 test/reg036/*.idr

223 test/reg036/expected

221 test/reg036/expected

222+ test/reg037/run

223+ test/reg037/*.idr

224+ test/reg037/expected

225+ test/reg038/run

226+ test/reg038/*.idr

227+ test/reg038/expected

228+ test/reg039/run

229+ test/reg039/*.idr

230+ test/reg039/expected

231+ test/reg040/run

232+ test/reg040/*.idr

233+ test/reg040/expected

234+ test/reg041/run

235+ test/reg041/*.idr

236+ test/reg041/expected

237+ test/reg042/run

238+ test/reg042/*.idr

239+ test/reg042/expected

240+ test/reg043/run

241+ test/reg043/expected

242+ test/reg044/run

243+ test/reg044/*.idr

244+ test/reg044/expected

224

245

225 test/basic001/run

246 test/basic001/run

226 test/basic001/*.idr

247 test/basic001/*.idr

@@ -250,6 +271,9 @@ Extra-source-files:

250 test/basic009/*.idr

271 test/basic009/*.idr

251 test/basic009/expected

272 test/basic009/expected

252 test/basic009/B/*.idr

273 test/basic009/B/*.idr

274+ test/basic010/run

275+ test/basic010/*.idr

276+ test/basic010/expected

253

277

254 test/buffer001-disabled/*.idr

278 test/buffer001-disabled/*.idr

255 test/buffer001-disabled/run

279 test/buffer001-disabled/run

@@ -303,6 +327,40 @@ Extra-source-files:

303 test/ffi005/run

327 test/ffi005/run

304 test/ffi005/expected

328 test/ffi005/expected

305

329

330+ test/idrisdoc001/run

331+ test/idrisdoc001/expected

332+ test/idrisdoc001/*.idr

333+ test/idrisdoc001/*.ipkg

334+ test/idrisdoc002/run

335+ test/idrisdoc002/expected

336+ test/idrisdoc002/*.idr

337+ test/idrisdoc002/*.ipkg

338+ test/idrisdoc003/run

339+ test/idrisdoc003/expected

340+ test/idrisdoc003/*.idr

341+ test/idrisdoc003/*.ipkg

342+ test/idrisdoc004/run

343+ test/idrisdoc004/expected

344+ test/idrisdoc004/*.idr

345+ test/idrisdoc004/*.ipkg

346+ test/idrisdoc005/run

347+ test/idrisdoc005/expected

348+ test/idrisdoc005/*.idr

349+ test/idrisdoc005/*.ipkg

350+ test/idrisdoc006/run

351+ test/idrisdoc006/expected

352+ test/idrisdoc006/A/fully/Qualified/NAME.idr

353+ test/idrisdoc006/*.idr

354+ test/idrisdoc006/*.ipkg

355+ test/idrisdoc007/run

356+ test/idrisdoc007/expected

357+ test/idrisdoc007/*.idr

358+ test/idrisdoc007/*.ipkg

359+ test/idrisdoc008/run

360+ test/idrisdoc008/expected

361+ test/idrisdoc008/*.idr

362+ test/idrisdoc008/*.ipkg

363+

306 test/interactive001/run

364 test/interactive001/run

307 test/interactive001/input

365 test/interactive001/input

308 test/interactive001/*.idr

366 test/interactive001/*.idr

@@ -315,6 +373,10 @@ Extra-source-files:

315 test/interactive003/input

373 test/interactive003/input

316 test/interactive003/*.idr

374 test/interactive003/*.idr

317 test/interactive003/expected

375 test/interactive003/expected

376+ test/interactive004/run

377+ test/interactive004/input

378+ test/interactive004/*.idr

379+ test/interactive004/expected

318

380

319 test/io001/run

381 test/io001/run

320 test/io001/*.idr

382 test/io001/*.idr

@@ -355,6 +417,12 @@ Extra-source-files:

355 test/records001/run

417 test/records001/run

356 test/records001/*.idr

418 test/records001/*.idr

357 test/records001/expected

419 test/records001/expected

420+ test/records002/run

421+ test/records002/*.idr

422+ test/records002/expected

423+ test/records003/run

424+ test/records003/*.idr

425+ test/records003/expected

358

426

359 test/sugar001/run

427 test/sugar001/run

360 test/sugar001/*.idr

428 test/sugar001/*.idr

@@ -375,6 +443,41 @@ Extra-source-files:

375 test/totality003/run

443 test/totality003/run

376 test/totality003/*.idr

444 test/totality003/*.idr

377 test/totality003/expected

445 test/totality003/expected

446+ test/totality004/run

447+ test/totality004/*.idr

448+ test/totality004/expected

449+ test/totality005/run

450+ test/totality005/*.idr

451+ test/totality005/expected

452+ test/totality006/run

453+ test/totality006/*.idr

454+ test/totality006/expected

455+ test/totality007/run

456+ test/totality007/*.ipkg

457+ test/totality007/src/*.idr

458+ test/totality007/expected

459+ test/totality008/run

460+ test/totality008/*.idr

461+ test/totality008/expected

462+

463+ test/tutorial001/run

464+ test/tutorial001/*.idr

465+ test/tutorial001/expected

466+ test/tutorial002/run

467+ test/tutorial002/*.idr

468+ test/tutorial002/expected

469+ test/tutorial003/run

470+ test/tutorial003/*.idr

471+ test/tutorial003/expected

472+ test/tutorial004/run

473+ test/tutorial004/*.idr

474+ test/tutorial004/expected

475+ test/tutorial005/run

476+ test/tutorial005/*.idr

477+ test/tutorial005/expected

478+ test/tutorial006/run

479+ test/tutorial006/*.idr

480+ test/tutorial006/expected

378

481

379source-repository head

482source-repository head

380 type: git

483 type: git

@@ -424,6 +527,8 @@ Library

424

527

425 , Idris.AbsSyntax

528 , Idris.AbsSyntax

426 , Idris.AbsSyntaxTree

529 , Idris.AbsSyntaxTree

530+ , Idris.Apropos

531+ , Idris.ASTUtils

427 , Idris.CaseSplit

532 , Idris.CaseSplit

428 , Idris.Chaser

533 , Idris.Chaser

429 , Idris.Colours

534 , Idris.Colours

@@ -434,15 +539,20 @@ Library

434 , Idris.DeepSeq

539 , Idris.DeepSeq

435 , Idris.Delaborate

540 , Idris.Delaborate

436 , Idris.Docs

541 , Idris.Docs

542+ , Idris.Docstrings

437 , Idris.ElabDecls

543 , Idris.ElabDecls

438 , Idris.ElabTerm

544 , Idris.ElabTerm

545+ , Idris.Erasure

439 , Idris.Error

546 , Idris.Error

440 , Idris.ErrReverse

547 , Idris.ErrReverse

441 , Idris.Help

548 , Idris.Help

442 , Idris.IBC

549 , Idris.IBC

443 , Idris.IdeSlave

550 , Idris.IdeSlave

551+ , Idris.IdrisDoc

444 , Idris.Imports

552 , Idris.Imports

445 , Idris.Inliner

553 , Idris.Inliner

554+ , Idris.Interactive

555+ , Idris.Output

446 , Idris.Parser

556 , Idris.Parser

447 , Idris.ParseHelpers

557 , Idris.ParseHelpers

448 , Idris.ParseOps

558 , Idris.ParseOps

@@ -456,8 +566,10 @@ Library

456 , Idris.REPL

566 , Idris.REPL

457 , Idris.REPLParser

567 , Idris.REPLParser

458 , Idris.Transforms

568 , Idris.Transforms

569+ , Idris.TypeSearch

459 , Idris.Unlit

570 , Idris.Unlit

460− , Idris.UnusedArgs

571+ , Idris.WhoCalls

572+ , Idris.CmdOptions

461

573

462 , IRTS.BCImp

574 , IRTS.BCImp

463 , IRTS.Bytecode

575 , IRTS.Bytecode

@@ -499,15 +611,19 @@ Library

499 , ansi-terminal

611 , ansi-terminal

500 , ansi-wl-pprint

612 , ansi-wl-pprint

501 , binary

613 , binary

614+ , blaze-html >= 0.6.1.3

615+ , blaze-markup >= 0.5.2.1 && < 0.7.0.0

502 , bytestring

616 , bytestring

617+ , cheapskate

503 , containers >= 0.5

618 , containers >= 0.5

504 , directory

619 , directory

505 , directory >= 1.2

620 , directory >= 1.2

506 , filepath

621 , filepath

507 , haskeline >= 0.7

622 , haskeline >= 0.7

508 , language-java >= 0.2.6

623 , language-java >= 0.2.6

624+ , lens >= 4.1.1

509 , mtl

625 , mtl

510− , parsers >= 0.9

626+ , parsers >= 0.9 && < 0.11.0.2

511 , pretty

627 , pretty

512 , process

628 , process

513 , split

629 , split

@@ -523,6 +639,7 @@ Library

523 , xml

639 , xml

524 , deepseq

640 , deepseq

525 , zlib

641 , zlib

642+ , optparse-applicative >= 0.8

526 Extensions: MultiParamTypeClasses

643 Extensions: MultiParamTypeClasses

527 , FunctionalDependencies

644 , FunctionalDependencies

528 , FlexibleContexts

645 , FlexibleContexts

idrisdoc/styles.cssnew file+320

@@ -0,0 +1,320 @@

1+html, body {

2+

3+ margin: 0;

4+ padding: 0;

5+ border: 0;

6+

7+ height: 100%;

8+

9+ font-family: "Trebuchet MS", Helvetica, sans-serif;

10+ font-size: 11pt;

11+

12+ background-color: #FFF;

13+}

14+

15+a, a:active, a:visited {

16+

17+ text-decoration: none;

18+ color: inherit;

19+}

20+

21+a:hover {

22+

23+ text-decoration: underline;

24+}

25+

26+header {

27+

28+ padding: 5px 11px;

29+

30+ border-bottom: 3px solid #659FDB;

31+ box-shadow: 0 -8px 22px 0px;

32+

33+ background-color: #252525;

34+ color: white;

35+

36+ font-size: 9pt;

37+}

38+

39+.wrapper {

40+

41+ min-height: 100%;

42+}

43+

44+header nav, header strong {

45+

46+ font-size: 11pt;

47+}

48+

49+header nav {

50+

51+ float: right;

52+}

53+

54+footer {

55+

56+ height: 30px;

57+ width: 100%;

58+ border-top: 1px solid #AAAAAA;

59+

60+ margin-top: -31px;

61+

62+ text-align: center;

63+ color: #666;

64+ line-height: 30px;

65+ font-size: 9pt;

66+

67+ background: none repeat scroll 0 0 #DDDDDD;

68+}

69+

70+.container {

71+

72+ padding: 10px 10px 41px 20px;

73+}

74+

75+body.index .container a:visited {

76+

77+ color: #666;

78+}

79+

80+body.index .container a:hover {

81+

82+ color: #04819E;

83+}

84+

85+h1 {

86+

87+ margin: 0;

88+ margin-bottom: 5px;

89+ font-size: 14pt;

90+

91+ font-family: "Trebuchet MS", Helvetica, sans-serif;

92+}

93+

94+body.namespace h1 {

95+

96+ border-bottom: 1px solid #BBB;

97+ padding-bottom: 2px;

98+}

99+

100+ul {

101+

102+ list-style-type: none;

103+

104+ margin: 0;

105+ padding: 0;

106+}

107+

108+hr {

109+

110+ margin: 0;

111+ padding: 0;

112+ border: 0;

113+

114+ border-bottom: 1px solid #BBB;

115+}

116+

117+p {

118+

119+ margin: 0;

120+ padding: 0;

121+}

122+

123+.code {

124+

125+ font-family: "Lucida Console", Monaco, monospace;

126+ font-size: 10pt;

127+}

128+

129+.decls {

130+

131+ margin-top: 15px;

132+}

133+

134+.decls > dt {

135+

136+ font-family: "Lucida Console", Monaco, monospace;

137+ font-size: 10pt;

138+ line-height: 20px;

139+

140+ padding: 2px 0;

141+

142+ border: 1px solid #CCC;

143+ background-color: #F0F0F0;

144+

145+ display: table;

146+ width: 100%;

147+}

148+

149+.decls > dt > :first-child {

150+

151+ padding-left: 6px;

152+}

153+

154+.decls > dt > :last-child {

155+

156+ padding-right: 6px;

157+}

158+

159+.decls > dd {

160+

161+ margin: 10px 0 10px 20px;

162+

163+ font-family: Arial, sans-serif;

164+ font-size: 10pt;

165+}

166+

167+.decls > dd > p {

168+

169+ margin-bottom: 8px;

170+}

171+

172+.decls > dd > dl:not(.decls):not(:first-child) {

173+

174+ padding-top: 5px;

175+ border-top: 1px solid #EEE;

176+}

177+

178+.decls > dd > dl:not(.decls) > dt {

179+

180+ display: block;

181+ min-width: 70px;

182+

183+ float: left;

184+

185+ font-weight: bold;

186+}

187+

188+.decls > dd > dl:not(.decls) > dd {

189+

190+ margin-bottom: 2px;

191+}

192+

193+.fixity {

194+

195+ font-style: italic;

196+ font-weight: normal !important;

197+}

198+

199+dd.fixity {

200+

201+ cursor: default;

202+}

203+

204+.word {

205+

206+ display: table-cell;

207+ white-space: nowrap;

208+ width: 0;

209+}

210+

211+.signature {

212+

213+ display: table-cell;

214+ width: 100%;

215+}

216+

217+.name {

218+

219+ display: table-cell;

220+ white-space: nowrap;

221+ width: 0;

222+}

223+

224+.documented, .name {

225+

226+ cursor: default;

227+}

228+

229+.documented {

230+

231+ font-weight: bold;

232+}

233+

234+a.function {

235+

236+ color: #00BA00;

237+}

238+

239+.function {

240+

241+ color: #007C21;

242+}

243+

244+a.constructor {

245+

246+ color: #FF0000;

247+}

248+

249+.constructor {

250+

251+ color: #BF3030;

252+}

253+

254+a.type {

255+

256+ color: #0000FF;

257+}

258+

259+.type {

260+

261+ color: #050599;

262+}

263+

264+.keyword {

265+

266+ color: inherit;

267+}

268+

269+.boundvar {

270+

271+ color: #BF30BF; /* Too much colour makes it hard to differ the rest of the colours */

272+ color: inherit;

273+}

274+

275+.boundvar.implicit {

276+

277+ text-decoration: underline;

278+}

279+

280+/******************* Old colours

281+

282+a {

283+

284+ color: #04819E;

285+}

286+

287+a:visited {

288+

289+ color: #26A3BF;

290+}

291+

292+********************/

293+

294+ul.names {

295+

296+ border: 1px solid #666;

297+}

298+

299+ul.names li:nth-child(odd) {

300+

301+ background-color: #EEEEEF;

302+}

303+

304+ul.names li:nth-child(even) {

305+

306+ background-color: white;

307+}

308+

309+ul.names li {

310+

311+ padding-left: 5px;

312+}

313+

314+ul.names li a {

315+

316+ display: inline-block;

317+ width: 100%;

318+

319+ padding: 2px 0;

320+}

jsrts/Runtime-browser.js+11

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

1var __IDRRT__print = function(s) {

2 console.log(s);

3};

4+

5+

6+var __IDRRT__systemInfo = function(index) {

7+ switch(index) {

8+ case 0:

9+ return "javascript";

10+ case 1:

11+ return navigator.platform;

12+ }

13+ return "";

14+}

jsrts/Runtime-common.js+16−3

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

1−var __IDRRT__ZERO = __IDRRT__bigInt("0");

2−var __IDRRT__ONE = __IDRRT__bigInt("1");

3−

4/** @constructor */

1/** @constructor */

5var __IDRRT__Type = function(type) {

2var __IDRRT__Type = function(type) {

6 this.type = type;

3 this.type = type;

@@ -37,3 +34,19 @@ var __IDRRT__tailcall = function(k) {

37

34

38 return ret;

35 return ret;

39};

36};

37+

38+var __IDRRT__charCode = function(str) {

39+ var type = typeof str;

40+ if (type == "string")

41+ return str.charCodeAt(0);

42+ else

43+ return str;

44+}

45+

46+var __IDRRT__fromCharCode = function(chr) {

47+ var type = typeof chr;

48+ if (type == "string")

49+ return chr;

50+ else

51+ return String.fromCharCode(chr);

52+}

jsrts/Runtime-node.js+11

@@ -4,3 +4,14 @@ var __IDRRT__print = (function() {

4 util.print(s);

5 };

6})();

7+

8+var __IDRRT__systemInfo = function(index) {

9+ var os = require('os')

10+ switch(index) {

11+ case 0:

12+ return "node";

13+ case 1:

14+ return os.platform();

15+ }

16+ return "";

17+}

jsrts/jsbn/jsbn.js+3

@@ -1233,3 +1233,6 @@ return function(val) {

1233 return new BigInteger(val);

1234}

1235})();

1236+

1237+var __IDRRT__ZERO = __IDRRT__bigInt("0");

1238+var __IDRRT__ONE = __IDRRT__bigInt("1");

libs/Makefile−6

@@ -2,22 +2,16 @@ build:

2 $(MAKE) -C prelude build

3 $(MAKE) -C base build

4 $(MAKE) -C effects build

5− $(MAKE) -C neweffects build

6− $(MAKE) -C javascript build

7

5

8

6

9install:

7install:

10 $(MAKE) -C prelude install

8 $(MAKE) -C prelude install

11 $(MAKE) -C base install

9 $(MAKE) -C base install

12 $(MAKE) -C effects install

10 $(MAKE) -C effects install

13− $(MAKE) -C neweffects install

14− $(MAKE) -C javascript install

15

11

16clean:

12clean:

17 $(MAKE) -C prelude clean

13 $(MAKE) -C prelude clean

18 $(MAKE) -C base clean

14 $(MAKE) -C base clean

19 $(MAKE) -C effects clean

15 $(MAKE) -C effects clean

20− $(MAKE) -C neweffects clean

21− $(MAKE) -C javascript clean

22

16

23.PHONY: build install clean

17.PHONY: build install clean

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

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

1−module Category.Arrow

1+module Control.Arrow

2

3import Data.Morphisms

4import Control.Category

@@ -37,4 +37,3 @@ instance Monad m => Arrow (Kleislimorphism m) where

37 (Kleisli f) &&& (Kleisli g) = Kleisli $ \a => do x <- f a

38 y <- g a

39 return (x, y)

40−

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

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

1−module Prelude.Catchable

1+module Control.Catchable

2

3import Control.IOExcept

4

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

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

4

5%default total

6

7−-- An isomorphism between two types

7+||| An isomorphism between two types

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

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

10 (from : b -> a) ->

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

14

15-- Isomorphism properties

16

17+||| Isomorphism is reflexive

17isoRefl : Iso a a

18isoRefl : Iso a a

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

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

19

20

21+||| Isomorphism is transitive

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

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

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

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

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

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

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

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

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

29 x QED)

31 x QED)

30

32

33+||| Isomorphism is symmetric

31isoSym : Iso a b -> Iso b a

34isoSym : Iso a b -> Iso b a

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

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

33

36

34-- Isomorphisms over sums

37-- Isomorphisms over sums

35

38

39+||| Disjunction is commutative

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

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

37eitherComm = MkIso swap swap swapSwap swapSwap

41eitherComm = MkIso swap swap swapSwap swapSwap

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

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

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

42 swapSwap (Left x) = refl

46 swapSwap (Left x) = refl

43 swapSwap (Right x) = refl

47 swapSwap (Right x) = refl

44

48

49+||| Disjunction is associative

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

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

46eitherAssoc = MkIso eitherAssoc1 eitherAssoc2 ok1 ok2

51eitherAssoc = MkIso eitherAssoc1 eitherAssoc2 ok1 ok2

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

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

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

64 ok2 (Left (Right x)) = refl

69 ok2 (Left (Right x)) = refl

65 ok2 (Right x) = refl

70 ok2 (Right x) = refl

66

71

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

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

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

68eitherBotLeft = MkIso to from ok1 ok2

74eitherBotLeft = MkIso to from ok1 ok2

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

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

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

77 ok2 (Left x) = FalseElim x

83 ok2 (Left x) = FalseElim x

78 ok2 (Right x) = refl

84 ok2 (Right x) = refl

79

85

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

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

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

81eitherBotRight = isoTrans eitherComm eitherBotLeft

88eitherBotRight = isoTrans eitherComm eitherBotLeft

82

89

83−

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

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

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

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

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

86 (MkIso to from toFrom fromTo)

93 (MkIso to from toFrom fromTo)

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

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

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

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

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

98

105

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

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

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

100eitherCongLeft i = eitherCong i isoRefl

108eitherCongLeft i = eitherCong i isoRefl

101

109

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

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

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

103eitherCongRight i = eitherCong isoRefl i

112eitherCongRight i = eitherCong isoRefl i

104

113

105-- Isomorphisms over products

114-- Isomorphisms over products

115+||| Conjunction is commutative

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

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

107pairComm = MkIso swap swap swapSwap swapSwap

117pairComm = MkIso swap swap swapSwap swapSwap

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

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

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

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

110−

120+

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

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

112 swapSwap (x, y) = refl

122 swapSwap (x, y) = refl

113

123

124+||| Conjunction is associative

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

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

115pairAssoc = MkIso to from ok1 ok2

126pairAssoc = MkIso to from ok1 ok2

116 where

127 where

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

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

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

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

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

125

136

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

126pairUnitRight : Iso (a, ()) a

138pairUnitRight : Iso (a, ()) a

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

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

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

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

129 ok (x, ()) = refl

141 ok (x, ()) = refl

130

142

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

131pairUnitLeft : Iso ((), a) a

144pairUnitLeft : Iso ((), a) a

132pairUnitLeft = isoTrans pairComm pairUnitRight

145pairUnitLeft = isoTrans pairComm pairUnitRight

133

146

147+||| Conjunction preserves falsehood

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

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

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

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

136

150

151+||| Conjunction preserves falsehood

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

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

138pairBotRight = isoTrans pairComm pairBotLeft

153pairBotRight = isoTrans pairComm pairBotLeft

139

154

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

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

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

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

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

142 (MkIso to from toFrom fromTo)

158 (MkIso to from toFrom fromTo)

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

155 rewrite fromTo' y in

171 rewrite fromTo' y in

156 refl

172 refl

157

173

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

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

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

159pairCongLeft i = pairCong i isoRefl

176pairCongLeft i = pairCong i isoRefl

160

177

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

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

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

162pairCongRight = pairCong isoRefl

180pairCongRight = pairCong isoRefl

163

181

164-- Distributivity of products over sums

182-- Distributivity of products over sums

183+||| Products distribute over sums

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

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

166distribLeft = MkIso to from toFrom fromTo

185distribLeft = MkIso to from toFrom fromTo

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

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

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

177 fromTo (Left x, y) = refl

196 fromTo (Left x, y) = refl

178 fromTo (Right x, y) = refl

197 fromTo (Right x, y) = refl

179

198

199+||| Products distribute over sums

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

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

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

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

182

202

183

203

184-- Enable preorder reasoning syntax over isomorphisms

204-- Enable preorder reasoning syntax over isomorphisms

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

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

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

186qed a = isoRefl

207qed a = isoRefl

187

208

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

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

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

189step a iso1 iso2 = isoTrans iso1 iso2

211step a iso1 iso2 = isoTrans iso1 iso2

190

212

191

213

192

214

193-- Isomorphisms over Maybe

215-- Isomorphisms over Maybe

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

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

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

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

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

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

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

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

200 ok2 Nothing = refl

223 ok2 Nothing = refl

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

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

202

225

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

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

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

204maybeEither = MkIso to from iso1 iso2

228maybeEither = MkIso to from iso1 iso2

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

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

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

215 iso2 Nothing = refl

239 iso2 Nothing = refl

216 iso2 (Just x) = refl

240 iso2 (Just x) = refl

217

241

242+||| Maybe of void is just unit

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

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

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

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

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

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

libs/base/Data/Bits.idr+7−7

@@ -356,8 +356,8 @@ bitsToInt : Bits n -> Integer

356bitsToInt (MkBits x) = bitsToInt' x

357

358-- Zero out the high bits of a truncated bitstring

359−--zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n)

359+zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n)

360−--zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0)

360+zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0)

361

362--instance Cast Nat (Bits n) where

363-- cast x = MkBits (zeroUnused (natToBits n))

@@ -399,8 +399,8 @@ sext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

399

400-- TODO: Prove

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

402−trunc' : machineTy (nextBytes (n+m)) -> machineTy (nextBytes n)

402+trunc' : machineTy (nextBytes (m+n)) -> machineTy (nextBytes n)

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

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

404 | (Z, Z) = believe_me x

405 | (Z, S Z) = believe_me (prim__truncB16_B8 (believe_me x))

406 | (Z, S (S Z)) = believe_me (prim__truncB32_B8 (believe_me x))

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

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

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

414

415−--public

415+public

416−--truncate : Bits (n+m) -> Bits n

416+truncate : Bits (m+n) -> Bits n

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

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

418

419public

420bitAt : Fin n -> Bits n

libs/base/Data/BoundedList.idr+25−23

@@ -3,11 +3,13 @@ module Data.BoundedList

3%access public

4%default total

5

6+||| A list with an upper bound on its length.

6−data BoundedList : Type -> Nat -> Type where

7+data BoundedList : Nat -> Type -> Type where

7− Nil : BoundedList a n

8+ Nil : BoundedList n a

8− (::) : a -> BoundedList a n -> BoundedList a (S n)

9+ (::) : a -> BoundedList n a -> BoundedList (S n) a

9

10

11+||| Compute the length of a list.

10−length : BoundedList a n -> Fin (S n)

12+length : BoundedList n a -> Fin (S n)

11length [] = fZ

13length [] = fZ

12length (x :: xs) = fS (length xs)

14length (x :: xs) = fS (length xs)

13

15

@@ -15,7 +17,7 @@ length (x :: xs) = fS (length xs)

15-- Indexing into bounded lists

17-- Indexing into bounded lists

16--------------------------------------------------------------------------------

18--------------------------------------------------------------------------------

17

19

18−index : Fin (S n) -> BoundedList a n -> Maybe a

20+index : Fin (S n) -> BoundedList n a -> Maybe a

19index _ [] = Nothing

21index _ [] = Nothing

20index fZ (x :: _) = Just x

22index fZ (x :: _) = Just x

21index (fS f) (_ :: xs) = index f xs

23index (fS f) (_ :: xs) = index f xs

@@ -24,7 +26,8 @@ index (fS f) (_ :: xs) = index f xs

24-- Adjusting bounds

26-- Adjusting bounds

25--------------------------------------------------------------------------------

27--------------------------------------------------------------------------------

26

28

29+||| Loosen the bounds on a list's length.

27−weaken : BoundedList a n -> BoundedList a (n + m)

30+weaken : BoundedList n a -> BoundedList (n + m) a

28weaken [] = []

31weaken [] = []

29weaken (x :: xs) = x :: weaken xs

32weaken (x :: xs) = x :: weaken xs

30

33

@@ -32,16 +35,16 @@ weaken (x :: xs) = x :: weaken xs

32-- Conversions to and from list

35-- Conversions to and from list

33--------------------------------------------------------------------------------

36--------------------------------------------------------------------------------

34

37

35−take : (n : Nat) -> List a -> BoundedList a n

38+take : (n : Nat) -> List a -> BoundedList n a

36take _ [] = []

39take _ [] = []

37take Z _ = []

40take Z _ = []

38take (S n') (x :: xs) = x :: take n' xs

41take (S n') (x :: xs) = x :: take n' xs

39

42

40−toList : BoundedList a n -> List a

43+toList : BoundedList n a -> List a

41toList [] = []

44toList [] = []

42−toList (x :: xs) = x :: toList xs

45+toList (x :: xs) = x :: Data.BoundedList.toList xs

43

46

44−fromList : (xs : List a) -> BoundedList a (length xs)

47+fromList : (xs : List a) -> BoundedList (length xs) a

45fromList [] = []

48fromList [] = []

46fromList (x :: xs) = x :: fromList xs

49fromList (x :: xs) = x :: fromList xs

47

50

@@ -49,7 +52,7 @@ fromList (x :: xs) = x :: fromList xs

49-- Building (bigger) bounded lists

52-- Building (bigger) bounded lists

50--------------------------------------------------------------------------------

53--------------------------------------------------------------------------------

51

54

52−replicate : (n : Nat) -> a -> BoundedList a n

55+replicate : (n : Nat) -> a -> BoundedList n a

53replicate Z _ = []

56replicate Z _ = []

54replicate (S n) x = x :: replicate n x

57replicate (S n) x = x :: replicate n x

55

58

@@ -57,27 +60,26 @@ replicate (S n) x = x :: replicate n x

57-- Folds

60-- Folds

58--------------------------------------------------------------------------------

61--------------------------------------------------------------------------------

59

62

60−foldl : (a -> b -> a) -> a -> BoundedList b n -> a

63+instance Foldable (BoundedList n) where

61−foldl f e [] = e

64+ foldr f e [] = e

62−foldl f e (x::xs) = foldl f (f e x) xs

65+ foldr f e (x::xs) = f x (foldr f e xs)

63−

66+ foldl f e [] = e

64−foldr : (a -> b -> b) -> b -> BoundedList a n -> b

67+ foldl f e (x::xs) = foldl f (f e x) xs

65−foldr f e [] = e

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

67

68

68--------------------------------------------------------------------------------

69--------------------------------------------------------------------------------

69-- Maps

70-- Maps

70--------------------------------------------------------------------------------

71--------------------------------------------------------------------------------

71

72

72−map : (a -> b) -> BoundedList a n -> BoundedList b n

73+instance Functor (BoundedList n) where

73−map f [] = []

74+ map f [] = []

74−map f (x :: xs) = f x :: map f xs

75+ map f (x :: xs) = f x :: map f xs

75

76

76--------------------------------------------------------------------------------

77--------------------------------------------------------------------------------

77-- Misc

78-- Misc

78--------------------------------------------------------------------------------

79--------------------------------------------------------------------------------

79

80

81+||| Extend a bounded list to the maximum size by padding on the left.

80−pad : (xs : BoundedList a n) -> (padding : a) -> BoundedList a n

82+pad : BoundedList n a -> a -> BoundedList n a

81pad {n=Z} [] _ = []

83pad {n=Z} [] _ = []

82pad {n=S n'} [] padding = padding :: (pad {n=n'} [] padding)

84pad {n=S n'} [] padding = padding :: (pad {n=n'} [] padding)

83pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding

85pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding

@@ -87,6 +89,6 @@ pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding

87-- Simple properties

89-- Simple properties

88--------------------------------------------------------------------------------

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

89

91

90−zeroBoundIsEmpty : (xs : BoundedList a 0) -> xs = the (BoundedList a 0) []

92+zeroBoundIsEmpty : (xs : BoundedList 0 a) -> xs = the (BoundedList 0 a) []

91zeroBoundIsEmpty [] = refl

93zeroBoundIsEmpty [] = refl

92zeroBoundIsEmpty (_ :: _) impossible

94zeroBoundIsEmpty (_ :: _) impossible

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

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

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

24-- would require exposing the offset argument of prim__appendBuffer

25

26−-- A contiguous chunk of n bytes

26+||| A contiguous chunk of n bytes

27abstract

28record Buffer : Nat -> Type where

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

@@ -36,15 +36,15 @@ bitsFromFin : Fin n -> Bits64

36bitsFromFin fZ = 0

37bitsFromFin (fS k) = 1 + bitsFromFin k

38

39−-- Allocate an empty Buffer. The size hint can be used to avoid

39+||| Allocate an empty Buffer. The size hint can be used to avoid

40−-- unnecessary reallocations and copies under the hood if the

40+||| unnecessary reallocations and copies under the hood if the

41−-- approximate ultimate size of the Buffer is known. Users can assume

41+||| approximate ultimate size of the Buffer is known. Users can assume

42−-- the new Buffer is word-aligned.

42+||| the new Buffer is word-aligned.

43public

44allocate : ( hint : Nat ) -> Buffer Z

45allocate = MkBuffer Z . prim__allocate . bitsFromNat

46

47−-- Append count repetitions of a Buffer to another Buffer

47+||| Append count repetitions of a Buffer to another Buffer

48%assert_total

49public

50appendBuffer : Buffer n ->

@@ -63,13 +63,13 @@ appendBuffer { n } { m } ( MkBuffer o1 r1 ) c ( MkBuffer o2 r2 ) =

63 off : Bits64

64 off = bitsFromNat o2

65

66−-- Copy a buffer, potentially allowing the (potentially large) space it

66+||| Copy a buffer, potentially allowing the (potentially large) space it

67−-- pointed to to be freed

67+||| pointed to to be freed

68public

69copy : Buffer n -> Buffer n

70copy { n } = replace ( plusZeroRightNeutral n ) . appendBuffer ( allocate n ) 1

71

72−-- Create a view over a buffer

72+||| Create a view over a buffer

73public

74peekBuffer : { n : Nat } -> { offset : Nat } -> Buffer ( n + offset ) -> ( offset : Nat ) -> Buffer n

75peekBuffer ( MkBuffer o r ) off = MkBuffer ( o + off ) r

@@ -93,7 +93,7 @@ appendBits { n } prim ( MkBuffer o r ) count =

93 MkBuffer o . prim r ( bitsFromNat $ n + o ) ( bitsFromNat count )

94

95

96−-- Read a Bits8 from a Buffer starting at offset

96+||| Read a Bits8 from a Buffer starting at offset

97%assert_total

98public

99peekBits8 : Buffer ( 1 + n ) ->

@@ -101,7 +101,7 @@ peekBits8 : Buffer ( 1 + n ) ->

101 Bits8

102peekBits8 = peekBits { m = 1 } prim__peekB8Native

103

104−-- Append count repetitions of a Bits8 to a Buffer

104+||| Append count repetitions of a Bits8 to a Buffer

105%assert_total

106public

107appendBits8 : Buffer n ->

@@ -110,7 +110,7 @@ appendBits8 : Buffer n ->

110 Buffer ( n + count * 1 )

111appendBits8 = appendBits prim__appendB8Native

112

113−-- Read a Bits16 in native byte order from a Buffer starting at offset

113+||| Read a Bits16 in native byte order from a Buffer starting at offset

114%assert_total

115public

116peekBits16Native : Buffer ( 2 + n ) ->

@@ -118,19 +118,19 @@ peekBits16Native : Buffer ( 2 + n ) ->

118 Bits16

119peekBits16Native = peekBits { m = 2 } prim__peekB16Native

120

121−-- Read a little-endian Bits16 from a Buffer starting at offset

121+||| Read a little-endian Bits16 from a Buffer starting at offset

122%assert_total

123public

124peekBits16LE : Buffer ( 2 + n ) -> ( offset : Fin ( S n ) ) -> Bits16

125peekBits16LE = peekBits { m = 2 } prim__peekB16LE

126

127−-- Read a big-endian Bits16 from a Buffer starting at offset

127+||| Read a big-endian Bits16 from a Buffer starting at offset

128%assert_total

129public

130peekBits16BE : Buffer ( 2 + n ) -> ( offset : Fin ( S n ) ) -> Bits16

131peekBits16BE = peekBits { m = 2 } prim__peekB16BE

132

133−-- Append count repetitions of a Bits16 in native byte order to a Buffer

133+||| Append count repetitions of a Bits16 in native byte order to a Buffer

134%assert_total

135public

136appendBits16Native : Buffer n ->

@@ -139,7 +139,7 @@ appendBits16Native : Buffer n ->

139 Buffer ( n + count * 2 )

140appendBits16Native = appendBits prim__appendB16Native

141

142−-- Append count repetitions of a little-endian Bits16 to a Buffer

142+||| Append count repetitions of a little-endian Bits16 to a Buffer

143%assert_total

144public

145appendBits16LE : Buffer n ->

@@ -148,7 +148,7 @@ appendBits16LE : Buffer n ->

148 Buffer ( n + count * 2 )

149appendBits16LE = appendBits prim__appendB16LE

150

151−-- Append count repetitions of a big-endian Bits16 to a Buffer

151+||| Append count repetitions of a big-endian Bits16 to a Buffer

152%assert_total

153public

154appendBits16BE : Buffer n ->

@@ -157,7 +157,7 @@ appendBits16BE : Buffer n ->

157 Buffer ( n + count * 2 )

158appendBits16BE = appendBits prim__appendB16BE

159

160−-- Read a Bits32 in native byte order from a Buffer starting at offset

160+||| Read a Bits32 in native byte order from a Buffer starting at offset

161%assert_total

162public

163peekBits32Native : Buffer ( 4 + n ) ->

@@ -165,19 +165,19 @@ peekBits32Native : Buffer ( 4 + n ) ->

165 Bits32

166peekBits32Native = peekBits { m = 4 } prim__peekB32Native

167

168−-- Read a little-endian Bits32 from a Buffer starting at offset

168+||| Read a little-endian Bits32 from a Buffer starting at offset

169%assert_total

170public

171peekBits32LE : Buffer ( 4 + n ) -> ( offset : Fin ( S n ) ) -> Bits32

172peekBits32LE = peekBits { m = 4 } prim__peekB32LE

173

174−-- Read a big-endian Bits32 from a Buffer starting at offset

174+||| Read a big-endian Bits32 from a Buffer starting at offset

175%assert_total

176public

177peekBits32BE : Buffer ( 4 + n ) -> ( offset : Fin ( S n ) ) -> Bits32

178peekBits32BE = peekBits { m = 4 } prim__peekB32BE

179

180−-- Append count repetitions of a Bits32 in native byte order to a Buffer

180+||| Append count repetitions of a Bits32 in native byte order to a Buffer

181%assert_total

182public

183appendBits32Native : Buffer n ->

@@ -186,7 +186,7 @@ appendBits32Native : Buffer n ->

186 Buffer ( n + count * 4 )

187appendBits32Native = appendBits prim__appendB32Native

188

189−-- Append count repetitions of a little-endian Bits32 to a Buffer

189+||| Append count repetitions of a little-endian Bits32 to a Buffer

190%assert_total

191public

192appendBits32LE : Buffer n ->

@@ -195,7 +195,7 @@ appendBits32LE : Buffer n ->

195 Buffer ( n + count * 4 )

196appendBits32LE = appendBits prim__appendB32LE

197

198−-- Append count repetitions of a big-endian Bits32 to a Buffer

198+||| Append count repetitions of a big-endian Bits32 to a Buffer

199%assert_total

200public

201appendBits32BE : Buffer n ->

@@ -204,7 +204,7 @@ appendBits32BE : Buffer n ->

204 Buffer ( n + count * 4 )

205appendBits32BE = appendBits prim__appendB32BE

206

207−-- Read a Bits64 in native byte order from a Buffer starting at offset

207+||| Read a Bits64 in native byte order from a Buffer starting at offset

208%assert_total

209public

210peekBits64Native : Buffer ( 8 + n ) ->

@@ -212,19 +212,19 @@ peekBits64Native : Buffer ( 8 + n ) ->

212 Bits64

213peekBits64Native = peekBits { m = 8 } prim__peekB64Native

214

215−-- Read a little-endian Bits64 from a Buffer starting at offset

215+||| Read a little-endian Bits64 from a Buffer starting at offset

216%assert_total

217public

218peekBits64LE : Buffer ( 8 + n ) -> ( offset : Fin ( S n ) ) -> Bits64

219peekBits64LE = peekBits { m = 8 } prim__peekB64LE

220

221−-- Read a big-endian Bits64 from a Buffer starting at offset

221+||| Read a big-endian Bits64 from a Buffer starting at offset

222%assert_total

223public

224peekBits64BE : Buffer ( 8 + n ) -> ( offset : Fin ( S n ) ) -> Bits64

225peekBits64BE = peekBits { m = 8 } prim__peekB64BE

226

227−-- Append count repetitions of a Bits64 in native byte order to a Buffer

227+||| Append count repetitions of a Bits64 in native byte order to a Buffer

228%assert_total

229public

230appendBits64Native : Buffer n ->

@@ -233,7 +233,7 @@ appendBits64Native : Buffer n ->

233 Buffer ( n + count * 8 )

234appendBits64Native = appendBits prim__appendB64Native

235

236−-- Append count repetitions of a little-endian Bits64 to a Buffer

236+||| Append count repetitions of a little-endian Bits64 to a Buffer

237%assert_total

238public

239appendBits64LE : Buffer n ->

@@ -242,7 +242,7 @@ appendBits64LE : Buffer n ->

242 Buffer ( n + count * 8 )

243appendBits64LE = appendBits prim__appendB64LE

244

245−-- Append count repetitions of a big-endian Bits64 to a Buffer

245+||| Append count repetitions of a big-endian Bits64 to a Buffer

246%assert_total

247public

248appendBits64BE : Buffer n ->

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

@@ -62,8 +62,8 @@ conjugate (r:+i) = (r :+ (0-i))

62-- We can't do "instance Num a => Num (Complex a)" because

63-- we need "abs" which needs "magnitude" which needs "sqrt" which needs Float

64instance Num (Complex Float) where

65− (+) (a:+b) (c:+d) = ((a+b):+(c+d))

65+ (+) (a:+b) (c:+d) = ((a+c):+(b+d))

66− (-) (a:+b) (c:+d) = ((a-b):+(c-d))

66+ (-) (a:+b) (c:+d) = ((a-c):+(b-d))

67 (*) (a:+b) (c:+d) = ((a*c-b*d):+(b*c+a*d))

68 fromInteger x = (fromInteger x:+0)

69 abs (a:+b) = (magnitude (a:+b):+0)

libs/base/Data/Erased.idrnew file+29

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

1+module Data.Erased

2+

3+%access public

4+%default total

5+

6+||| The erasure monad.

7+|||

8+||| Used when explicit modelling of erasure in the type system is needed.

9+data Erased : Type -> Type where

10+

11+ ||| Construct an erased value from any value.

12+ Erase : .(x : a) -> Erased a

13+

14+instance Functor Erased where

15+ map f (Erase x) = Erase (f x)

16+

17+instance Applicative Erased where

18+ pure = Erase

19+ (<$>) (Erase f) (Erase x) = Erase (f x)

20+

21+instance Monad Erased where

22+ (>>=) (Erase x) f = f x

23+

24+||| Project the erased value out of the monad.

25+|||

26+||| This is usable only in types and other erased contexts,

27+||| where it won't cause erasure violations.

28+unerase : Erased a -> a

29+unerase (Erase x) = x

libs/base/Data/Fun.idr+8−5

@@ -1,12 +1,15 @@

1module Data.Fun

2

3−--------------------------------------------------------------------------------

3+%default total

4+

4−-- Build an n-ary function type from a Vect of Types and a result type

5+||| Build an n-ary function type from a Vect of Types and a result type

5−--------------------------------------------------------------------------------

6Fun : Vect n Type -> Type -> Type

7Fun [] r = r

8Fun (t::ts) r = t -> Fun ts r

9

10−target : {ts : Vect n Type} -> Fun ts r -> Type

10+chain : {ts : Vect n Type} -> Fun [r] r' -> Fun ts r -> Fun ts r'

11−target {r} _ = r

11+chain {ts = []} g r = g r

12+chain {ts = (_::_)} g f = \ x => chain g (f x)

12

13

14+target : {ts : Vect n Type} -> Fun ts r -> Type

15+target {r} _ = r

libs/base/Data/HVect.idr+9

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

6%default total

7

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

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

10+ ||| the types of the contents.

9 data HVect : Vect k Type -> Type where

11 data HVect : Vect k Type -> Type where

10 Nil : HVect []

12 Nil : HVect []

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

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

12

14

15+ ||| Extract an element from an HVect

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

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

14 index fZ (x::xs) = x

17 index fZ (x::xs) = x

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

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

@@ -17,6 +20,7 @@ using (k : Nat, ts : Vect k Type)

17 deleteAt : {us : Vect (S l) Type} -> (i : Fin (S l)) -> HVect us -> HVect (deleteAt i us)

20 deleteAt : {us : Vect (S l) Type} -> (i : Fin (S l)) -> HVect us -> HVect (deleteAt i us)

18 deleteAt fZ (x::xs) = xs

21 deleteAt fZ (x::xs) = xs

19 deleteAt {l = S m} (fS j) (x::xs) = x :: deleteAt j xs

22 deleteAt {l = S m} (fS j) (x::xs) = x :: deleteAt j xs

23+ deleteAt {l = Z} (fS j) (x::xs) = absurd j

20 deleteAt _ [] impossible

24 deleteAt _ [] impossible

21

25

22 replaceAt : (i : Fin k) -> t -> HVect ts -> HVect (replaceAt i t ts)

26 replaceAt : (i : Fin k) -> t -> HVect ts -> HVect (replaceAt i t ts)

@@ -27,6 +31,7 @@ using (k : Nat, ts : Vect k Type)

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

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

28 updateAt (fS j) f (x::xs) = x :: updateAt j f xs

32 updateAt (fS j) f (x::xs) = x :: updateAt j f xs

29

33

34+ ||| Append two `HVect`s.

30 (++) : {us : Vect l Type} -> HVect ts -> HVect us -> HVect (ts ++ us)

35 (++) : {us : Vect l Type} -> HVect ts -> HVect us -> HVect (ts ++ us)

31 (++) [] ys = ys

36 (++) [] ys = ys

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

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

@@ -49,14 +54,18 @@ using (k : Nat, ts : Vect k Type)

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

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

50 show xs = show (shows xs)

55 show xs = show (shows xs)

51

56

57+ ||| Extract an arbitrary element of the correct type.

58+ ||| @ t the goal type

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

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

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

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

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

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

55

62

63+ ||| Replace an element with the correct type.

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

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

57 put {p = Here} y (x::xs) = y :: xs

65 put {p = Here} y (x::xs) = y :: xs

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

66 put {p = There p'} y (x::xs) = x :: put {p = p'} y xs

59

67

68+ ||| Replace an element with the correct type.

60 update : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> (t -> u) -> HVect ts -> HVect (replaceByElem ts p u)

69 update : {default tactics { applyTactic findElem 100; solve; } p : Elem t ts} -> (t -> u) -> HVect ts -> HVect (replaceByElem ts p u)

61 update {p = Here} f (x::xs) = f x :: xs

70 update {p = Here} f (x::xs) = f x :: xs

62 update {p = There p'} f (x::xs) = x :: update {p = p'} f xs

71 update {p = There p'} f (x::xs) = x :: update {p = p'} f xs

libs/base/Data/List.idrnew file+31

@@ -0,0 +1,31 @@

1+module Data.List

2+

3+%access public

4+

5+using (xs : List a)

6+ ||| A proof that some element is found in a list

7+ data Elem : a -> List a -> Type where

8+ Here : Elem x (x :: xs)

9+ There : Elem x xs -> Elem x (y :: xs)

10+

11+ instance Uninhabited (Elem {a} x []) where

12+ uninhabited Here impossible

13+ uninhabited (There p) impossible

14+

15+ ||| Is the given element a member of the given list.

16+ |||

17+ ||| @x The element to be tested.

18+ ||| @xs The list to be checked against

19+ isElem : DecEq a => (x : a) -> (xs : List a) -> Dec (Elem x xs)

20+ isElem x [] = No absurd

21+ isElem x (y :: xs) with (decEq x y)

22+ isElem x (x :: xs) | (Yes refl) = Yes Here

23+ isElem x (y :: xs) | (No contra) with (isElem x xs)

24+ isElem x (y :: xs) | (No contra) | (Yes prf) = Yes (There prf)

25+ isElem x (y :: xs) | (No contra) | (No f) = No (mkNo contra f)

26+ where

27+ mkNo : {xs' : List a} ->

28+ ((x' = y') -> _|_) -> (Elem x' xs' -> _|_) ->

29+ Elem x' (y' :: xs') -> _|_

30+ mkNo f g Here = f refl

31+ mkNo f g (There x) = g x

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

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

4

5%default total

6

7−-- Integers modulo 2^n

7+||| Integers modulo 2^n

8public

9data Mod2 : Nat -> Type where

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

libs/base/Data/Rel.idr+2−3

@@ -2,9 +2,8 @@ module Data.Rel

2

3import Data.Fun

4

5−--------------------------------------------------------------------------------

5+

6−-- Build an n-ary relation type from a Vect of Types

6+||| Build an n-ary relation type from a Vect of Types

7−--------------------------------------------------------------------------------

8Rel : Vect n Type -> Type

7Rel : Vect n Type -> Type

9Rel ts = Fun ts Type

8Rel ts = Fun ts Type

10

9

libs/base/Data/Sign.idr+2

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

1module Data.Sign

2

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

3data Sign = Plus | Minus

4data Sign = Plus | Minus

4

5

6+||| Discover the sign of some type

5class Signed t where

7class Signed t where

6 total sign : t -> Sign

8 total sign : t -> Sign

libs/base/Data/SortedMap.idr+3−3

@@ -183,10 +183,10 @@ treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =

183 Left t3' => Left (Branch3 t1 k1 t2 k2 t3')

184 Right t3' => Left (merge3 t1 k1 t2 k2 t3')

185

186−treeToList : Ord k => Tree n k v -> List (k, v)

186+treeToList : Tree n k v -> List (k, v)

187treeToList = treeToList' (:: [])

188 where

189− treeToList' : Ord k => ((k, v) -> List (k, v)) -> Tree n k v -> List (k, v)

189+ treeToList' : ((k, v) -> List (k, v)) -> Tree n k v -> List (k, v)

190 treeToList' cont (Leaf k v) = cont (k, v)

191 treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1

192 treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

@@ -223,7 +223,7 @@ delete k (M (S _) t) =

223fromList : Ord k => List (k, v) -> SortedMap k v

224fromList l = foldl (flip (uncurry insert)) empty l

225

226−toList : Ord k => SortedMap k v -> List (k, v)

226+toList : SortedMap k v -> List (k, v)

227toList Empty = []

228toList (M _ t) = treeToList t

229

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

@@ -21,5 +21,8 @@ contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)

21fromList : Ord k => List k -> SortedSet k

22fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))

23

24−toList : Ord k => SortedSet k -> List k

24+toList : SortedSet k -> List k

25toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)

26+

27+instance Foldable SortedSet where

28+ foldr f e xs = foldr f e (Data.SortedSet.toList xs)

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

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

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

11

12using (xs : Vect k a)

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

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

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

14 Here : Elem x (x::xs)

15 Here : Elem x (x::xs)

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

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

16

17

18+||| Nothing can be in an empty Vect

19+noEmptyElem : {x : a} -> Elem x [] -> _|_

20+noEmptyElem Here impossible

21+

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

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

24+neitherHereNorThere xneqy xninxs Here = xneqy refl

25+neitherHereNorThere xneqy xninxs (There xinxs) = xninxs xinxs

26+

27+||| A decision procedure for Elem

28+isElem : DecEq a => (x : a) -> (xs : Vect n a) -> Dec (Elem x xs)

29+isElem x [] = No noEmptyElem

30+isElem x (y :: xs) with (decEq x y)

31+ isElem x (x :: xs) | (Yes refl) = Yes Here

32+ isElem x (y :: xs) | (No xneqy) with (isElem x xs)

33+ isElem x (y :: xs) | (No xneqy) | (Yes xinxs) = Yes (There xinxs)

34+ isElem x (y :: xs) | (No xneqy) | (No xninxs) = No (neitherHereNorThere xneqy xninxs)

35+

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

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

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

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

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

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

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

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

20

41

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

@@ -7,8 +7,8 @@ import Data.Sign

7%access public

8

9

10−-- | An integer is either a positive nat or the negated successor of a nat.

10+||| An integer is either a positive nat or the negated successor of a nat.

11−-- Zero is chosen to be positive.

11+||| Zero is arbitrarily chosen to be positive.

12data ZZ = Pos Nat | NegS Nat

13

14instance Signed ZZ where

libs/base/Debug/Trace.idr+4−1

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

1module Debug.Trace

2

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

4+||| @ msg what to print

5+||| @ result the final result

3−trace : String -> a -> a

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

4trace x val = unsafePerformIO (do putStrLn x; return val)

7trace x val = unsafePerformIO (do putStrLn x; return val)

5

8

6

9

libs/base/Decidable/Order.idr+25−2

@@ -10,7 +10,7 @@ import Decidable.Equality

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

11

12--------------------------------------------------------------------------------

13−-- Preorders, Posets and total Orders

13+-- Preorders, Posets, total Orders, Equivalencies, Congruencies

14--------------------------------------------------------------------------------

15

16class Preorder t (po : t -> t -> Type) where

@@ -21,7 +21,16 @@ class (Preorder t po) => Poset t (po : t -> t -> Type) where

21 total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b

22

23class (Poset t to) => Ordered t (to : t -> t -> Type) where

24− total order : (a : t) -> (b : t) -> Either (to a b) (to b a)

24+ total order : (a : t) -> (b : t) -> Either (to a b) (to b a)

25+

26+class (Preorder t eq) => Equivalence t (eq : t -> t -> Type) where

27+ total symmetric : (a : t) -> (b : t) -> eq a b -> eq b a

28+

29+class (Equivalence t eq) => Congruence t (f : t -> t) (eq : t -> t -> Type) where

30+ total congruent : (a : t) ->

31+ (b : t) ->

32+ eq a b ->

33+ eq (f a) (f b)

25

34

26minimum : (Ordered t to) => t -> t -> t

35minimum : (Ordered t to) => t -> t -> t

27minimum x y with (order x y)

36minimum x y with (order x y)

@@ -33,6 +42,20 @@ maximum x y with (order x y)

33 | Left _ = y

42 | Left _ = y

34 | Right _ = x

43 | Right _ = x

35

44

45+--------------------------------------------------------------------------------

46+-- Syntactic equivalence (=)

47+--------------------------------------------------------------------------------

48+

49+instance Preorder t ((=) {A = t} {B = t}) where

50+ transitive a b c = trans {a = a} {b = b} {c = c}

51+ reflexive a = refl

52+

53+instance Equivalence t ((=) {A = t} {B = t}) where

54+ symmetric a b prf = sym prf

55+

56+instance Congruence t f ((=) {A = t} {B = t}) where

57+ congruent a b = cong {a = a} {b = b} {f = f}

58+

36--------------------------------------------------------------------------------

59--------------------------------------------------------------------------------

37-- Natural numbers

60-- Natural numbers

38--------------------------------------------------------------------------------

61--------------------------------------------------------------------------------

libs/base/Language/Reflection.idr+10−6

@@ -22,7 +22,7 @@ data TTUExp = UVar Int

22 -- ^ explicit universe variable

23%name TTUExp uexp

24

25−-- | Primitive constants

25+||| Primitive constants

26data Const = I Int | BI Integer | Fl Float | Ch Char | Str String

28 | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64

@@ -66,7 +66,7 @@ reflectConstant: (ReflConst a) => a -> Const

66reflectConstant = toConst

67

68

69−-- | Types of named references

69+||| Types of named references

70data NameType = Bound

71 -- ^ reference which is just bound, e.g. by intro

72 | Ref

@@ -77,8 +77,8 @@ data NameType = Bound

77 -- ^ type constructor with tag and number

78%name NameType nt, nt'

79

80−-- | Types annotations for bound variables in different

80+||| Types annotations for bound variables in different

81−-- binding contexts

81+||| binding contexts

82data Binder a = Lam a

83 | Pi a

84 | Let a a

@@ -124,7 +124,7 @@ instance Traversable Binder where

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

125

126

127−-- | Reflection of the well typed core language

127+||| Reflection of the well typed core language

128data TT = P NameType TTName TT

129 -- ^ named binders

130 | V Int

@@ -146,7 +146,7 @@ data TT = P NameType TTName TT

146

147%name TT tm, tm'

148

149−-- | Raw terms without types

149+||| Raw terms without types

150data Raw = Var TTName

151 | RBind TTName (Binder Raw) Raw

152 | RApp Raw Raw

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

167 -- ^ apply both tactics in sequence

168 | Trivial

169 -- ^ intelligently construct the proof target from the context

170+ | Search Int

171+ -- ^ build a proof by applying contructors up to a maximum depth

170 | Instance

172 | Instance

171 -- ^ resolve a type class

173 -- ^ resolve a type class

172 | Solve

174 | Solve

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

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

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

181 | Reflect TT

183 | Reflect TT

182 -- ^ turn a value into its reflected representation

184 -- ^ turn a value into its reflected representation

185+ | ByReflection TT

186+ -- ^ use a %reflection function

183 | Fill Raw

187 | Fill Raw

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

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

185 | Exact TT

189 | Exact TT

libs/base/Language/Reflection/Errors.idr+2−4

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

3import Language.Reflection

4

5data SourceLocation : Type where

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

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

7

8%name SourceLocation loc

9

@@ -35,14 +35,12 @@ data Err = Msg String

35 | AlreadyDefined TTName

36 | ProofSearchFail Err

37 | NoRewriting TT

38− | At SourceLocation Err

39− | Elaborating String TTName Err

40 | ProviderError String

38 | ProviderError String

41 | LoadingFailed String Err

39 | LoadingFailed String Err

42

40

43%name Err err, e

41%name Err err, e

44

42

45−-- | Error reports are a list of report parts

43+||| Error reports are a list of report parts

46data ErrorReportPart = TextPart String

44data ErrorReportPart = TextPart String

47 | NamePart TTName

45 | NamePart TTName

48 | TermPart TT

46 | TermPart TT

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

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

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

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

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

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

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

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

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

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

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

259

257

libs/base/Providers.idr+9−7

@@ -1,25 +1,27 @@

1module Providers

2

3+||| Type providers must build one of these in an IO computation.

3public

4public

4−data Provider a = Provide a | Error String | Postulate

5+data Provider : (a : Type) -> Type where

6+ ||| Return a term to be spliced in

7+ ||| @ x the term to be spliced (i.e. the proof)

8+ Provide : (x : a) -> Provider a

9+

10+ ||| Report an error to the user and stop compilation

11+ ||| @ msg the error message

12+ Error : (msg : String) -> Provider a

5

13

6-- instances

14-- instances

7instance Functor Provider where

15instance Functor Provider where

8 map f (Provide a) = Provide (f a)

16 map f (Provide a) = Provide (f a)

9 map f (Error err) = Error err

17 map f (Error err) = Error err

10− map f Postulate = Postulate

11

18

12instance Applicative Provider where

19instance Applicative Provider where

13 (Provide f) <$> (Provide x) = Provide (f x)

20 (Provide f) <$> (Provide x) = Provide (f x)

14 (Provide f) <$> (Error err) = Error err

21 (Provide f) <$> (Error err) = Error err

15− (Provide f) <$> Postulate = Postulate

16 (Error err) <$> _ = Error err

22 (Error err) <$> _ = Error err

17− Postulate <$> (Error err) = Error err

18− Postulate <$> _ = Postulate

19 pure = Provide

23 pure = Provide

20

24

21−-- is this correct for Postulate?

22instance Monad Provider where

25instance Monad Provider where

23 (Provide x) >>= f = f x

26 (Provide x) >>= f = f x

24 (Error err) >>= _ = Error err

27 (Error err) >>= _ = Error err

25− Postulate >>= f = Postulate

libs/base/System.idr+9−6

@@ -5,6 +5,7 @@ import Prelude

5%default partial

6%access public

7

8+||| Get the command-line arguments that the program was called with.

8getArgs : IO (List String)

9getArgs : IO (List String)

9getArgs = do n <- numArgs

10getArgs = do n <- numArgs

10 ga' [] 0 n

11 ga' [] 0 n

@@ -20,8 +21,8 @@ getArgs = do n <- numArgs

20 do arg <- getArg i

21 do arg <- getArg i

21 ga' (arg :: acc) (i+1) n

22 ga' (arg :: acc) (i+1) n

22

23

23−-- Retrieves an value from the environment, if the given key is present,

24+||| Retrieves an value from the environment, if the given key is present,

24−-- otherwise it returns Nothing.

25+||| otherwise it returns Nothing.

25getEnv : String -> IO (Maybe String)

26getEnv : String -> IO (Maybe String)

26getEnv key = do

27getEnv key = do

27 str_ptr <- getEnv'

28 str_ptr <- getEnv'

@@ -33,15 +34,15 @@ getEnv key = do

33 getEnv' : IO String

34 getEnv' : IO String

34 getEnv' = mkForeign (FFun "getenv" [FString] FString) key

35 getEnv' = mkForeign (FFun "getenv" [FString] FString) key

35

36

36−-- Sets an environment variable with a given value.

37+||| Sets an environment variable with a given value.

37−-- Returns true if the operation was successful.

38+||| Returns true if the operation was successful.

38setEnv : String -> String -> IO Bool

39setEnv : String -> String -> IO Bool

39setEnv key value = do

40setEnv key value = do

40 ok <- mkForeign (FFun "setenv" [FString, FString, FInt] FInt) key value 1

41 ok <- mkForeign (FFun "setenv" [FString, FString, FInt] FInt) key value 1

41 return (ok == 0)

42 return (ok == 0)

42

43

43−-- Unsets an environment variable.

44+||| Unsets an environment variable.

44−-- Returns true if the variable was able to be unset.

45+||| Returns true if the variable was able to be unset.

45unsetEnv : String -> IO Bool

46unsetEnv : String -> IO Bool

46unsetEnv key = do

47unsetEnv key = do

47 ok <- mkForeign (FFun "unsetenv" [FString] FInt) key

48 ok <- mkForeign (FFun "unsetenv" [FString] FInt) key

@@ -68,9 +69,11 @@ getEnvironment = getAllPairs 0 []

68 then return $ reverse $ map splitEq acc

69 then return $ reverse $ map splitEq acc

69 else getAllPairs (n + 1) (envPair :: acc)

70 else getAllPairs (n + 1) (envPair :: acc)

70

71

72+||| Quit with a particular exit code

71exit : Int -> IO ()

73exit : Int -> IO ()

72exit code = mkForeign (FFun "exit" [FInt] FUnit) code

74exit code = mkForeign (FFun "exit" [FInt] FUnit) code

73

75

76+||| Get the Unix time

74time : IO Int

77time : IO Int

75time = mkForeign (FFun "idris_time" [] FInt)

78time = mkForeign (FFun "idris_time" [] FInt)

76

79

libs/base/System/Concurrency/Process.idr+7−14

@@ -9,9 +9,8 @@ import System.Concurrency.Raw

9abstract

10data ProcID msg = MkPID Ptr

11

12−-- Type safe message passing programs. Parameterised over the type of

12+||| Type safe message passing programs. Parameterised over the type of

13−-- message which can be send, and the return type.

13+||| message which can be send, and the return type.

14−

15data Process : (msgType : Type) -> Type -> Type where

14data Process : (msgType : Type) -> Type -> Type where

16 lift : IO a -> Process msg a

15 lift : IO a -> Process msg a

17

16

@@ -30,31 +29,26 @@ instance Monad (Process msg) where

30run : Process msg x -> IO x

29run : Process msg x -> IO x

31run (lift prog) = prog

30run (lift prog) = prog

32

31

33−-- Get current process ID

32+||| Get current process ID

34−

35myID : Process msg (ProcID msg)

33myID : Process msg (ProcID msg)

36myID = lift (return (MkPID prim__vm))

34myID = lift (return (MkPID prim__vm))

37

35

38−-- Send a message to another process

36+||| Send a message to another process

39−

40send : ProcID msg -> msg -> Process msg ()

37send : ProcID msg -> msg -> Process msg ()

41send (MkPID p) m = lift (sendToThread p (prim__vm, m))

38send (MkPID p) m = lift (sendToThread p (prim__vm, m))

42

39

43−-- Return whether a message is waiting in the queue

40+||| Return whether a message is waiting in the queue

44−

45msgWaiting : Process msg Bool

41msgWaiting : Process msg Bool

46msgWaiting = lift checkMsgs

42msgWaiting = lift checkMsgs

47

43

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

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

49−

50recv : Process msg msg

45recv : Process msg msg

51recv {msg} = do (senderid, m) <- lift get

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

52 return m

47 return m

53 where get : IO (Ptr, msg)

48 where get : IO (Ptr, msg)

54 get = getMsg

49 get = getMsg

55

50

56−-- receive a message, and return with the sender's process ID.

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

57−

58recvWithSender : Process msg (ProcID msg, msg)

52recvWithSender : Process msg (ProcID msg, msg)

59recvWithSender {msg}

53recvWithSender {msg}

60 = do (senderid, m) <- lift get

54 = do (senderid, m) <- lift get

@@ -65,4 +59,3 @@ recvWithSender {msg}

65create : Process msg () -> Process msg (ProcID msg)

59create : Process msg () -> Process msg (ProcID msg)

66create (lift p) = do ptr <- lift (fork p)

60create (lift p) = do ptr <- lift (fork p)

67 return (MkPID ptr)

61 return (MkPID ptr)

68−

libs/base/System/Concurrency/Raw.idr+3−6

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

6

7import System

8

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

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

10−

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

10sendToThread : (thread_id : Ptr) -> a -> IO ()

12sendToThread {a} dest val

11sendToThread {a} dest val

13 = mkForeign (FFun "idris_sendMessage"

12 = mkForeign (FFun "idris_sendMessage"

@@ -18,10 +17,8 @@ checkMsgs = do msgs <- mkForeign (FFun "idris_checkMessages"

18 [FPtr] FInt) prim__vm

17 [FPtr] FInt) prim__vm

19 return (intToBool msgs)

18 return (intToBool msgs)

20

19

21−-- Check inbox for messages. If there are none, blocks until a message

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

22−-- arrives.

21+||| arrives.

23−

24getMsg : IO a

22getMsg : IO a

25getMsg {a} = mkForeign (FFun "idris_recvMessage"

23getMsg {a} = mkForeign (FFun "idris_recvMessage"

26 [FPtr] (FAny a)) prim__vm

24 [FPtr] (FAny a)) prim__vm

27−

libs/base/System/Info.idrnew file+13

@@ -0,0 +1,13 @@

1+module System.Info

2+

3+||| The Idris backend in use

4+backend : String

5+backend = prim__systemInfo 0

6+

7+||| The operating system in use.

8+os : String

9+os = prim__systemInfo 1

10+

11+||| The triple this program was targeted for

12+targetTriple : String

13+targetTriple = prim__systemInfo 2

libs/base/base.ipkg+3−1

@@ -6,6 +6,7 @@ modules = System,

6 Network.Cgi, Network.Socket,

7 Debug.Trace,

8

9+ System.Info,

9 System.Concurrency.Raw, System.Concurrency.Process,

10 System.Concurrency.Raw, System.Concurrency.Process,

10

11

11 Decidable.Decidable, Decidable.Order,

12 Decidable.Decidable, Decidable.Order,

@@ -22,7 +23,8 @@ modules = System,

22 Data.SortedMap, Data.SortedSet, Data.BoundedList,

23 Data.SortedMap, Data.SortedSet, Data.BoundedList,

23 Data.Vect, Data.HVect, Data.Vect.Quantifiers,

24 Data.Vect, Data.HVect, Data.Vect.Quantifiers,

24 Data.Floats, Data.Complex, Data.Heap, Data.Fun,

25 Data.Floats, Data.Complex, Data.Heap, Data.Fun,

25− Data.Rel, Data.Buffer,

26+ Data.Rel, Data.Buffer, Data.Erased,

27+ Data.List,

26

28

27 Control.Isomorphism, Control.Isomorphism.Primitives,

29 Control.Isomorphism, Control.Isomorphism.Primitives,

28 Control.Monad.Identity,

30 Control.Monad.Identity,

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

The content is the same.

libs/effects/Effect/Exception.idr+7−5

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

4import System

5import Control.IOExcept

6

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

7+data Exception : Type -> Effect where

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

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

9

10instance Handler (Exception a) Maybe where

11 handle _ (Raise e) k = Nothing

12

13+instance Handler (Exception a) List where

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

15+

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

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

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

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

15 believe_me (exit 1)

18 believe_me (exit 1)

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

23EXCEPTION : Type -> EFFECT

26EXCEPTION : Type -> EFFECT

24EXCEPTION t = MkEff () (Exception t)

27EXCEPTION t = MkEff () (Exception t)

25

28

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

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

27−raise err = Raise err

30+raise err = call $ Raise err

28−

29

31

30

32

31

33

libs/effects/Effect/File.idr+108−49

@@ -1,69 +1,128 @@

1+-- -------------------------------------------------------- [ Effectful FileIO ]

1module Effect.File

2module Effect.File

2

3

3import Effects

4import Effects

4import Control.IOExcept

5import Control.IOExcept

5

6

7+

8+||| A Dependent type to describe File Handles. File handles are

9+||| parameterised with the current state of the file: Closed; Open for

10+||| reading; and Open for writing.

11+|||

12+||| @ m The file mode.

6−data OpenFile : Mode -> Type where

13+data OpenFile : (m : Mode) -> Type where

7 FH : File -> OpenFile m

14 FH : File -> OpenFile m

8

15

16+openOK : Mode -> Bool -> Type

17+openOK m True = OpenFile m

18+openOK m False = ()

19+

20+-- ------------------------------------------------------------ [ The Protocol ]

21+

22+||| Here the protocol for resource access is defined as an effect.

23+||| The state transitions diagram for the protocol is as follows:

24+|||

25+||| digraph G {

26+|||

27+||| empty; read; write; // States

28+|||

29+||| empty -> read [label="Open R"];

30+||| read -> empty [label="Close"];

31+||| read -> read [label="ReadLine"];

32+||| read -> read [label="EOF"];

33+|||

34+||| empty -> write [label="Open W"];

35+||| write -> empty [label="Close"];

36+||| write -> write [label="WriteLine"];

37+|||

38+||| }

9data FileIO : Effect where

39data FileIO : Effect where

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

40+ ||| Open a file with the specified mode.

41+ |||

42+ ||| Opening a file successful moves the state from 'empty' to the

43+ ||| specified mode. If not successful the state is still 'empty'.

44+ |||

45+ ||| @ fname The file name to be opened.

46+ ||| @ m The file mode.

47+ Open : (fname: String)

48+ -> (m : Mode)

49+ -> {() ==> {res} if res

50+ then OpenFile m

51+ else ()} FileIO Bool

52+

53+ ||| Close a file.

54+ |||

55+ ||| Closing a file moves the state from Open to closed.

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

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

12−

57+

58+ ||| Read a line from the file.

59+ |||

60+ ||| Only files that are open for reading can be read.

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

61+ ReadLine : {OpenFile Read} FileIO String

62+

63+ ||| Write a line to a file.

64+ |||

65+ ||| Only file that are open for writing can be written to.

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

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

67+

68+ ||| End of file?

69+ |||

70+ ||| Only files open for reading can be tested for EOF

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

71+ EOF : {OpenFile Read} FileIO Bool

16−

72+

17−

73+-- ------------------------------------------------------------ [ The Handlers ]

74+

75+--- An implementation of the resource access protocol for the IO Context.

18instance Handler FileIO IO where

76instance Handler FileIO IO where

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

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

20 valid <- validFile h

78 valid <- validFile h

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

79+ if valid then k True (FH h)

22− else k (Left ()) False

80+ else k False ()

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

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

24 k () ()

82 k () ()

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

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

26− k (FH h) str

84+ k str (FH h)

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

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

28− k (FH h) ()

86+ k () (FH h)

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

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

30− k (FH h) e

88+ k e (FH h)

31−

32−instance Handler FileIO (IOExcept String) where

33− handle () (Open fname m) k

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

35− valid <- ioe_lift (validFile h)

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

37− else k (Left ()) False

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

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

40− k (FH h) str

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

42− k (FH h) ()

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

44− k (FH h) e

45

89

90+-- -------------------------------------------------------------- [ The Effect ]

46FILE_IO : Type -> EFFECT

91FILE_IO : Type -> EFFECT

47FILE_IO t = MkEff t FileIO

92FILE_IO t = MkEff t FileIO

48

93

49−open : Handler FileIO e =>

94+-- ------------------------------------------------------------ [ The Bindings ]

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

95+--

96+-- Bind the IO context handlers to functions. These functions will run

97+-- in the IO context.

98+--

99+

100+||| Open a file with the specified mode.

101+|||

102+||| @ fname The file name to be opened.

103+||| @ m The file mode.

104+open : (fname : String)

105+ -> (m : Mode)

106+ -> { [FILE_IO ()] ==> [FILE_IO (if result

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

107+ then OpenFile m

108+ else ())] } Eff e Bool

52−open f m = Open f m

109+open f m = call $ Open f m

53−

110+

54−close : Handler FileIO e =>

111+

112+||| Close a file.

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

113+close : { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e ()

56−close = Close

114+close = call $ Close

57−

115+

116+||| Read a line from the file.

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

117+readLine : { [FILE_IO (OpenFile Read)] } Eff e String

59−readLine = ReadLine

118+readLine = call $ ReadLine

60−

119+

120+||| Write a line to a file.

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

121+writeLine : String -> { [FILE_IO (OpenFile Write)] } Eff e ()

62−writeLine str = WriteLine str

122+writeLine str = call $ WriteLine str

63−

123+

124+||| End of file?

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

125+eof : { [FILE_IO (OpenFile Read)] } Eff e Bool

65−eof = EOF

126+eof = call $ EOF

66−

127+

67−

128+-- --------------------------------------------------------------------- [ EOF ]

68−

69−

libs/effects/Effect/Memory.idr+38−32

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

12abstract

13data RawMemory : Effect where

14 Allocate : (n : Nat) ->

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

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

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

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

17 Initialize : Bits8 ->

18 (size : Nat) ->

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

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

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

21 Peek : (offset : Nat) ->

22 (size : Nat) ->

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

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

24+ RawMemory (Vect size Bits8)

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

25 Poke : (offset : Nat) ->

26 Poke : (offset : Nat) ->

26 (Vect size Bits8) ->

27 (Vect size Bits8) ->

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

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

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

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

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

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

30 (dst_offset : Nat) ->

31 (dst_offset : Nat) ->

31 (src_offset : Nat) ->

32 (src_offset : Nat) ->

32 (size : Nat) ->

33 (size : Nat) ->

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

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

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

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

35− RawMemory (MemoryChunk dst_size dst_init)

36+ RawMemory () (MemoryChunk dst_size dst_init)

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

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

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

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

38

39

39private

40private

40do_malloc : Nat -> IOExcept String Ptr

41do_malloc : Nat -> IOExcept String Ptr

@@ -79,58 +80,61 @@ do_poke ptr offset (b::bs)

79instance Handler RawMemory (IOExcept String) where

80instance Handler RawMemory (IOExcept String) where

80 handle () (Allocate n) k

81 handle () (Allocate n) k

81 = do ptr <- do_malloc n

82 = do ptr <- do_malloc n

82− k (CH ptr) ()

83+ k () (CH ptr)

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

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

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

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

85 handle (CH ptr) (Free) k

86 handle (CH ptr) (Free) k

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

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

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

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

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

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

89− k (CH ptr) res

90+ k res (CH ptr)

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

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

91 = do ioe_lift (do_poke ptr offset content)

92 = do ioe_lift (do_poke ptr offset content)

92− k (CH ptr) ()

93+ k () (CH ptr)

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

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

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

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

95− k (CH dest_ptr) ()

96+ k () (CH dest_ptr)

96 handle chunk (GetRawPtr) k

97 handle chunk (GetRawPtr) k

97 = k chunk chunk

98 = k chunk chunk

98

99

99RAW_MEMORY : Type -> EFFECT

100RAW_MEMORY : Type -> EFFECT

100RAW_MEMORY t = MkEff t RawMemory

101RAW_MEMORY t = MkEff t RawMemory

101

102

103+allocate : (n : Nat) ->

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

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

103−allocate size = Allocate size

105+allocate size = call $ Allocate size

104

106

105initialize : {i : Nat} ->

107initialize : {i : Nat} ->

106 {n : Nat} ->

108 {n : Nat} ->

107 Bits8 ->

109 Bits8 ->

108 (size : Nat) ->

110 (size : Nat) ->

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

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

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

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

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

111−initialize c size prf = Initialize c size prf

114+initialize c size prf = call $ Initialize c size prf

112

115

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

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

114−free = Free

117+free = call Free

115

118

116peek : {i : Nat} ->

119peek : {i : Nat} ->

117 (offset : Nat) ->

120 (offset : Nat) ->

118 (size : Nat) ->

121 (size : Nat) ->

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

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

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

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

121−peek offset size prf = Peek offset size prf

124+peek offset size prf = call $ Peek offset size prf

122

125

123poke : {n : Nat} ->

126poke : {n : Nat} ->

124 {i : Nat} ->

127 {i : Nat} ->

125 (offset : Nat) ->

128 (offset : Nat) ->

126 Vect size Bits8 ->

129 Vect size Bits8 ->

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

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

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

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

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

129−poke offset content prf = Poke offset content prf

133+poke offset content prf = call $ Poke offset content prf

130

134

131private

135private

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

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

133−getRawPtr = GetRawPtr

137+getRawPtr = call $ GetRawPtr

134

138

135private

139private

136move' : {dst_size : Nat} ->

140move' : {dst_size : Nat} ->

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

142 (size : Nat) ->

146 (size : Nat) ->

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

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

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

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

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

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

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

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

147move' src_ptr dst_offset src_offset size dst_bounds src_bounds

151move' src_ptr dst_offset src_offset size dst_bounds src_bounds

148− = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

152+ = call $ Move src_ptr dst_offset src_offset size dst_bounds src_bounds

149

153

150data MoveDescriptor = Dst | Src

154data MoveDescriptor = Dst | Src

151

155

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

158 (size : Nat) ->

162 (size : Nat) ->

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

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

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

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

165+ Eff m ()

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

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

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

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

168+ (\v =>

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

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

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

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

165move dst_offset src_offset size dst_bounds src_bounds

171move dst_offset src_offset size dst_bounds src_bounds

166 = do src_ptr <- Src :- getRawPtr

172 = do src_ptr <- Src :- getRawPtr

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

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

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

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

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

6

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

8− instance Functor (EffM m xs xs) where

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

9 map f prog = do t <- prog

10 value (f t)

11

12− instance Applicative (EffM m xs xs) where

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

13 pure = value

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

15 a' <- a

16 value (f' a')

17

18− instance Monad (EffM m xs xs) where

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

19− (>>=) = ebind

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

20

21

libs/effects/Effect/Random.idr+31−9

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

2

3import Effects

4

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

5+data Random : Effect where

6− getRandom : Random Integer Integer Integer

6+ getRandom : { Integer } Random Integer

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

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

8

9using (m : Type -> Type)

10 instance Handler Random m where

11 handle seed getRandom k

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

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

13 k seed' seed'

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

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

15

16RND : EFFECT

17RND = MkEff Integer Random

18

19+||| Generates a random Integer in a given range

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

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

20−rndInt lower upper = do v <- getRandom

21+rndInt lower upper = do v <- call $ getRandom

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

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

22

23

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

24+||| Generate a random number in Fin (S `k`)

25+|||

26+||| Note that rndFin k takes values 0, 1, ..., k.

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

28+rndFin k = do let v = assert_total $ !(call getRandom) `prim__sremBigInt` (cast (S k))

29+ return (toFin v)

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

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

32+ Just v => v

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

34+

35+||| Select a random element from a vector

36+rndSelect' : Vect (S k) a -> { [RND] } Eff IO a

37+rndSelect' {k} xs = return (Vect.index !(rndFin k) xs)

38+

39+||| Select a random element from a list, or Nothing if the list is empty

40+rndSelect : List a -> { [RND] } Eff IO (Maybe a)

41+rndSelect [] = return Nothing

42+rndSelect (x::xs) = return (Just !(rndSelect' (x::(fromList xs))))

43+

44+||| Sets the random seed

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

24−srand n = setSeed n

46+srand n = call $ setSeed n

25

47

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

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

3import Effects

4

5data Selection : Effect where

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

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

7

8instance Handler Selection Maybe where

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

10 tryAll [] = Nothing

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

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

12 Nothing => tryAll xs

13 Just v => Just v

14

15instance Handler Selection List where

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

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

17

18SELECT : EFFECT

19SELECT = MkEff () Selection

20

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

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

22−select xs = Select xs

22+select xs = call $ Select xs

23

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

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

5%access public

6

7data State : Effect where

8− Get : State a a a

8+ Get : { a } State a

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

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

10

11using (m : Type -> Type)

12 instance Handler State m where

13 handle st Get k = k st st

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

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

15

16STATE : Type -> EFFECT

17STATE t = MkEff t State

18

19−get : Eff m [STATE x] x

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

20−get = Get

20+get = call $ Get

21

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

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

23−put val = Put val

23+put val = call $ Put val

24

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

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

26−putM val = Put val

26+putM val = call $ Put val

27

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

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

29update f = put (f !get)

30

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

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

32updateM f = putM (f !get)

33

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

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

35locally newst prog = do st <- get

36 putM newst

37 val <- prog

libs/effects/Effect/StdIO.idr+38−38

@@ -3,58 +3,58 @@ module Effect.StdIO

3import Effects

4import Control.IOExcept

5

6+-------------------------------------------------------------

7+-- IO effects internals

8+-------------------------------------------------------------

9+

10+||| The internal representation of StdIO effects

6data StdIO : Effect where

11data StdIO : Effect where

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

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

8− GetStr : StdIO () () String

13+ GetStr : { () } StdIO String

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

15+ GetCh : { () } StdIO Char

16+

17+

18+-------------------------------------------------------------

19+-- IO effects handlers

20+-------------------------------------------------------------

9

21

10instance Handler StdIO IO where

22instance Handler StdIO IO where

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

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

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

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

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

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

13

27

14instance Handler StdIO (IOExcept a) where

28instance Handler StdIO (IOExcept a) where

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

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

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

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

17−

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

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

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

19−

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

21−

22−instance Handler StdIO IOStream where

23− handle () (PutStr s) k

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

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

26− (res, s :: str))

27− handle {a} () GetStr k

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

29− [] => cont "" []

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

31− where

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

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

34− MkStream f => f ts

35

33

34+-------------------------------------------------------------

36--- The Effect and associated functions

35--- The Effect and associated functions

36+-------------------------------------------------------------

37

38STDIO : EFFECT

39STDIO = MkEff () StdIO

40

41+||| Write a string to standard output.

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

42+putStr : String -> { [STDIO] } Eff e ()

42−putStr s = PutStr s

43+putStr s = call $ PutStr s

43

44

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

45+||| Write a character to standard output.

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

46+putChar : Char -> { [STDIO] } Eff e ()

47+putChar c = call $ PutCh c

46

48

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

49+||| Write a string to standard output, terminating with a newline.

48−getStr = GetStr

50+putStrLn : String -> { [STDIO] } Eff e ()

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

49

52

50−mkStrFn : Env IOStream xs ->

53+||| Read a string from standard input.

51− Eff IOStream xs a ->

54+getStr : { [STDIO] } Eff e String

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

55+getStr = call $ GetStr

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

56

57+||| Read a character from standard input.

58+getChar : { [STDIO] } Eff e Char

59+getChar = call $ GetCh

60

libs/neweffects/Effect/System.idr → libs/effects/Effect/System.idrrenamed+3−3

@@ -28,11 +28,11 @@ SYSTEM : EFFECT

28SYSTEM = MkEff () System

29

30getArgs : Handler System e => { [SYSTEM] } Eff e (List String)

31−getArgs = Args

31+getArgs = call Args

32

33time : Handler System e => { [SYSTEM] } Eff e Int

34−time = Time

34+time = call Time

35

36getEnv : Handler System e => String -> { [SYSTEM] } Eff e (Maybe String)

37−getEnv s = GetEnv s

37+getEnv s = call $ GetEnv s

38

libs/effects/Effects.idr+205−201

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

2

3import Language.Reflection

4import Control.Catchable

5+import Effect.Default

5

6

6−%access public

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

7−

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

8−---- Effects

9

10+%access public

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

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

13+|||

14+||| This type is parameterised by:

15+||| + The input resource.

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

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

10Effect : Type

18Effect : Type

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

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

12

20

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

22+||| description into a concrete effect.

13%error_reverse

23%error_reverse

14data EFFECT : Type where

24data EFFECT : Type where

15 MkEff : Type -> Effect -> EFFECT

25 MkEff : Type -> Effect -> EFFECT

16

26

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

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

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

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

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+ ||| @ k The continuation to pass the result of the effect

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

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

37+

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

39+resourceType : EFFECT -> Type

40+resourceType (MkEff t e) = t

41+

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

43+

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

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

19

46

20−---- Properties and proof construction

47+-- No state transition

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

21

49

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

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

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

53+

54+--- A simple state transition

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

56+

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

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

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

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

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

24 SubNil : SubList {a} [] []

60 SubNil : SubList {a} [] []

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

29 subListId {xs = Nil} = SubNil

65 subListId {xs = Nil} = SubNil

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

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

31

67

68+namespace Env

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

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

33− Nil : Env m Nil

70+ Nil : Env m Nil

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

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

35−

72+

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

73+data EffElem : Effect -> Type ->

37 List EFFECT -> Type where

74 List EFFECT -> Type where

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

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

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

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

40

77

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

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

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

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

43dropEnv [] SubNil = []

80dropEnv [] SubNil = []

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

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

@@ -52,57 +89,23 @@ updateWith [] [] SubNil = []

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

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

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

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

54

91

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

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

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

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

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

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

58rebuildEnv [] SubNil env = env

95rebuildEnv [] SubNil env = env

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

97+rebuildEnv [] (Keep rest) (y :: env) = []

59rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

98rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

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

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

100

101+

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

103+

104+updateResTy : (val : t) ->

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

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

103− List EFFECT

106+ List EFFECT

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

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

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

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

106

109

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

110infix 5 :::, :-, :=

108

111

@@ -110,148 +113,117 @@ data LRes : lbl -> Type -> Type where

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

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

111

114

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

115(:::) : lbl -> EFFECT -> EFFECT

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

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

117+

118+using (lbl : Type)

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

120+ default = lbl := default

114

121

115private

122private

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

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

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

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

118

125

119private

126private

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

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

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

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

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

122−

130+

123−-- the language of Effects

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

124−

132+||| Definition of an Effect.

133+|||

134+||| @ m The computation context

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

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

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

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

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

139+ -> (x : Type)

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

140+ -> (es : List EFFECT)

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

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

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

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

144+ Eff m a xs xs'

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

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

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

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

147+ callP : (prf : EffElem e a xs) ->

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

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

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

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

150+

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

151+ liftP : (prf : SubList ys xs) ->

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

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

134− new : Handler e m =>

153+ newInit : Handler e m =>

154+ res ->

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

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

136− EffM m xs xs' a

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

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

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

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

140− EffM m xs xs' t

141− test_lbl : {x : lbl} ->

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

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

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

145− EffM m xs xs' t

146− catch : Catchable m err =>

157+ catch : Catchable m err =>

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

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

148− EffM m xs xs' a

159+ Eff m a xs xs'

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

160+

150−

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

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

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

152−

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

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

164+

154−

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

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

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

156−

167+(>>=) = ebind

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

168+

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

169+-- namespace SimpleBind

159−

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

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

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

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

172+-- (>>=) = ebind

162−

173+

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

174+||| Run a subprogram which results in an effect state the same as the input.

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

175+staticEff : Eff m a xs (\v => xs) -> Eff m a xs (\v => xs)

165−

176+staticEff = id

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

177+

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

178+||| Explicitly give the expected set of result effects for an effectful

168−

179+||| operation.

169−-- These may read better in some contexts

180+toEff : .(xs' : List EFFECT) -> Eff m a xs (\v => xs') -> Eff m a xs (\v => xs')

170−

181+toEff xs' = id

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

182+

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

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

187return x = value x

184return x = value x

188

185

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

190−(>>=) = ebind

191−

192−-- for idiom brackets

186+-- ------------------------------------------------------ [ for idiom brackets ]

193

187

194infixl 2 <$>

188infixl 2 <$>

195

189

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

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

197pure = value

191pure = value

198

192

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

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

194+

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

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

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

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

201 arg <- v

198 arg <- v

202 return (fn arg)

199 return (fn arg)

203

200

204−-- an interpreter

201+-- ---------------------------------------------------------- [ an interpreter ]

205

202

206private

203private

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

214−

215−private

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

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

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

219− m b

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

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

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

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

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

225−

226−private

227−testEffLbl : {x : lblTy} ->

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

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

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

231− m b

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

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

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

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

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

237

212

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

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

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

240

215

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

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

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

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

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

243eff env (prog `ebind` c) k

219eff env (prog `ebind` c) k

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

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

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

221+eff env (callP prf effP) k = execEff env prf effP k

246−eff env (lift prf effP) k

222+eff env (liftP prf effP) k

247 = let env' = dropEnv env prf in

223 = let env' = dropEnv env prf in

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

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

249−eff env (new r prog) k

225+eff env (newInit r prog) k

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

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

251−eff env (test prf l r) k

252− = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)

253−eff env (test_lbl prf l r) k

254− = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k)

255eff env (catch prog handler) k

227eff env (catch prog handler) k

256 = catch (eff env prog k)

228 = catch (eff env prog k)

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

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

@@ -261,48 +233,80 @@ eff env (catch prog handler) k

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

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

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

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

263 = let env' = unlabel env in

235 = let env' = unlabel env in

264− eff env' prog (\envk, p' => k (relabel l envk) p')

236+ eff env' prog (\p', envk => k p' (relabel l envk))

237+

238+-- yuck :) Haven't got type class instances working nicely in tactic

239+-- proofs yet, and 'search' can't be told about any hints yet,

240+-- so just brute force it.

241+syntax MkDefaultEnv = with Env

242+ (| [], [default], [default, default],

243+ [default, default, default],

244+ [default, default, default, default],

245+ [default, default, default, default, default],

246+ [default, default, default, default, default, default],

247+ [default, default, default, default, default, default, default],

248+ [default, default, default, default, default, default, default, default] |)

249+

250+call : {a, b: _} -> {e : Effect} ->

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

252+ {default tactics { search 100; }

253+ prf : EffElem e a xs} ->

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

255+call e {prf} = callP prf e

265

256

266implicit

257implicit

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

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

268− {default tactics { byReflection reflectEff; }

259+ {default tactics { search 100; }

269− prf : SubList ys xs} ->

260+ prf : SubList ys xs} ->

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

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

271−lift' e {prf} = lift prf e

262+lift e {prf} = liftP prf e

272

263

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

264

265+new : Handler e m =>

266+ {default default r : res} ->

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

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

269+new {r} e = newInit r e

281

270

282−run : Applicative m => Env m xs -> EffM m xs xs' a -> m a

271+-- --------------------------------------------------------- [ Running Effects ]

283−run env prog = eff env prog (\env, r => pure r)

284

272

273+||| Run an effectful program

285−runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a)

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

286−runEnv env prog = eff env prog (\env, r => pure (env, r))

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

287

276

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

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

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

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

290

279

291−-- runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a)

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

292−-- runPureEnv env prog = eff env prog (\env, r => (env, r))

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

293

282

294−runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a

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

295−runWith inj env prog = eff env prog (\env, r => inj r)

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

296

285

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

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

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

287+runWith inj env prog = eff env prog (\r, env => inj r)

299

288

300−-- some higher order things

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))

301

292

293+-- ----------------------------------------------- [ some higher order things ]

294+

302−mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b)

295+mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b)

303mapE f [] = pure []

296mapE f [] = pure []

304mapE f (x :: xs) = [| f x :: mapE f xs |]

297mapE f (x :: xs) = [| f x :: mapE f xs |]

305

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+

306−when : Applicative m => Bool -> Eff m xs () -> Eff m xs ()

308+when : Applicative m => Bool -> Lazy ({xs} Eff m ()) -> {xs} Eff m ()

307−when True e = e

309+when True e = Force e

308when False e = pure ()

310when False e = pure ()

311+

312+-- --------------------------------------------------------------------- [ EOF ]

libs/effects/effects.ipkg+3−2

@@ -1,8 +1,9 @@

1package effects

2

3opts = "--nobasepkgs -i ../prelude -i ../base"

4−modules = Effects,

4+modules = Effects, Effect.Default,

5+

5 Effect.Exception, Effect.File, Effect.State,

6 Effect.Exception, Effect.File, Effect.State,

6 Effect.Random, Effect.StdIO, Effect.Select,

7 Effect.Random, Effect.StdIO, Effect.Select,

7− Effect.Memory, Effect.Monad

8+ Effect.Memory, Effect.System

8

9

libs/javascript/JavaScript.idrdeleted−104

@@ -1,104 +0,0 @@

1−module JavaScript

2−

3−%access public

4−

5−private

6−isUndefined : Ptr -> IO Bool

7−isUndefined p = do

8− res <- mkForeign (

9− FFun "%0 === undefined" [FPtr] FString) p

10− if res == "false"

11− then (return False)

12− else (return True)

13−

14−--------------------------------------------------------------------------------

15−-- Events

16−--------------------------------------------------------------------------------

17−abstract

18−data Event : Type where

19− MkEvent : Ptr -> Event

20−

21−--------------------------------------------------------------------------------

22−-- Elements

23−--------------------------------------------------------------------------------

24−abstract

25−data Element : Type where

26− MkElem : Ptr -> Element

27−

28−setText : Element -> String -> IO ()

29−setText (MkElem p) s =

30− mkForeign (FFun "%0.textContent=%1" [FPtr, FString] FUnit) p s

31−

32−

33−setOnClick : Element -> (Event -> IO Bool) -> IO ()

34−setOnClick (MkElem e) f =

35− mkForeign (

36− FFun "%0['onclick']=%1" [ FPtr

37− , FFunction (FAny Event) (FAny (IO Bool))

38− ] FUnit) e f

39−--------------------------------------------------------------------------------

40−-- Nodelists

41−--------------------------------------------------------------------------------

42−abstract

43−data NodeList : Type where

44− MkNodeList : Ptr -> NodeList

45−

46−elemAt : NodeList -> Nat -> IO (Maybe Element)

47−elemAt (MkNodeList p) i = do

48− e <- mkForeign (FFun "%0.item(%1)" [FPtr, FInt] FPtr) p (

49− prim__truncBigInt_Int (cast i)

50− )

51− d <- isUndefined e

52− if d

53− then return $ Just (MkElem e)

54− else return Nothing

55−

56−--------------------------------------------------------------------------------

57−-- Intervals

58−--------------------------------------------------------------------------------

59−abstract

60−data Interval : Type where

61− MkInterval : Ptr -> Interval

62−

63−setInterval : (() -> IO ()) -> Float -> IO Interval

64−setInterval f t = do

65− e <- mkForeign (

66− FFun "setInterval(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr

67− ) f t

68− return (MkInterval e)

69−

70−clearInterval : Interval -> IO ()

71−clearInterval (MkInterval p) =

72− mkForeign (FFun "clearInterval(%0)" [FPtr] FUnit) p

73−

74−--------------------------------------------------------------------------------

75−-- Timeouts

76−--------------------------------------------------------------------------------

77−data Timeout : Type where

78− MkTimeout : Ptr -> Timeout

79−

80−setTimeout : (() -> IO ()) -> Float -> IO Timeout

81−setTimeout f t = do

82− e <- mkForeign (

83− FFun "setTimeout(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr

84− ) f t

85− return (MkTimeout e)

86−

87−clearTimeout : Timeout -> IO ()

88−clearTimeout (MkTimeout p) =

89− mkForeign (FFun "clearTimeout(%0)" [FPtr] FUnit) p

90−

91−--------------------------------------------------------------------------------

92−-- Basic IO

93−--------------------------------------------------------------------------------

94−alert : String -> IO ()

95−alert msg =

96− mkForeign (FFun "alert(%0)" [FString] FUnit) msg

97−

98−--------------------------------------------------------------------------------

99−-- DOM

100−--------------------------------------------------------------------------------

101−query : String -> IO NodeList

102−query q = do

103− e <- mkForeign (FFun "document.querySelectorAll(%0)" [FString] FPtr) q

104− return (MkNodeList e)

libs/javascript/JavaScript/JSON.idrdeleted−44

@@ -1,44 +0,0 @@

1−module JSON

2−

3−import Data.SortedMap

4−

5−data JSONType : Type where

6− JSONArray : (n : Nat) -> Vect n JSONType -> JSONType

7− JSONString : JSONType

8− JSONNumber : JSONType

9− JSONBool : JSONType

10− JSONObject : SortedMap String JSONType -> JSONType

11− JSONNull : JSONType

12−

13−mutual

14− using (ts : Vect n JSONType, fs : SortedMap String JSONType)

15− namespace JArray

16− data JArray : (n : Nat) -> Vect n JSONType -> Type where

17− Nil : JArray 0 []

18− (::) : JSON t -> JArray n ts -> JArray (S n) (t :: ts)

19−

20− namespace JObject

21− data JObject : SortedMap String JSONType -> Type where

22− Nil : JObject empty

23− (::) : (f : (String, JSON t)) ->

24− JObject fs ->

25− JObject (insert (fst f) t fs)

26−

27− data JSON : JSONType -> Type where

28− JSString : String -> JSON JSONString

29− JSNumber : Float -> JSON JSONNumber

30− JSBool : Bool -> JSON JSONBool

31− JSNull : JSON JSONNull

32− JSArray : JArray n ts -> JSON (JSONArray n ts)

33− JSObject : JObject fs -> JSON (JSONObject fs)

34−

35−index : (i : Fin n) -> JSON (JSONArray n ts) -> JSON (index i ts)

36−index fZ (JSArray (x :: xs)) = x

37−index (fS i) (JSArray (x :: xs)) = index i (JSArray xs)

38−

39−(++) : JSON (JSONArray m ts1) ->

40− JSON (JSONArray n ts2) ->

41− JSON (JSONArray (m + n) (ts1 ++ ts2))

42−(++) (JSArray []) ys = ys

43−(++) (JSArray (x :: xs)) ys with ((JSArray xs) ++ ys)

44− | (JSArray as) = JSArray (x :: as)

libs/javascript/Makefiledeleted−14

@@ -1,14 +0,0 @@

1−IDRIS := idris

2−

3−build:

4− $(IDRIS) --build javascript.ipkg

5−

6−install:

7− $(IDRIS) --install javascript.ipkg

8−

9−clean:

10− $(IDRIS) --clean javascript.ipkg

11−

12−rebuild: clean build

13−

14−.PHONY: build install clean rebuild

libs/javascript/javascript.ipkgdeleted−5

@@ -1,5 +0,0 @@

1−package javascript

2−

3−opts = "--nobasepkgs -i ../prelude -i ../base"

4−modules = JavaScript, JavaScript.JSON

5−

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−302

@@ -1,302 +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−-- A bit of syntactic sugar ('syntax' is not very flexible so we only go

23−-- up to a small number of parameters...)

24−

25−syntax "{" [inst] "}" [eff] = eff inst (\result => inst)

26−syntax "{" [inst] "==>" "{" {b} "}" [outst] "}" [eff]

27− = eff inst (\b => outst)

28−syntax "{" [inst] "==>" [outst] "}" [eff] = eff inst (\result => outst)

29−

30−---- Properties and proof construction

31−

32−using (xs : List a, ys : List a)

33− data SubList : List a -> List a -> Type where

34− SubNil : SubList {a} [] []

35− Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

36− Drop : SubList xs ys -> SubList xs (x :: ys)

37−

38− subListId : SubList xs xs

39− subListId {xs = Nil} = SubNil

40− subListId {xs = x :: xs} = Keep subListId

41−

42−namespace Env

43− data Env : (m : Type -> Type) -> List EFFECT -> Type where

44− Nil : Env m Nil

45− (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

46−

47−data EffElem : Effect -> Type ->

48− List EFFECT -> Type where

49− Here : EffElem x a (MkEff a x :: xs)

50− There : EffElem x a xs -> EffElem x a (y :: xs)

51−

52−-- make an environment corresponding to a sub-list

53−dropEnv : Env m ys -> SubList xs ys -> Env m xs

54−dropEnv [] SubNil = []

55−dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

56−dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

57−

58−updateWith : (ys' : List a) -> (xs : List a) ->

59− SubList ys xs -> List a

60−updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

61−updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest

62−updateWith [] [] SubNil = []

63−updateWith (y :: ys) [] SubNil = y :: ys

64−updateWith [] (x :: xs) (Keep rest) = []

65−

66−-- put things back, replacing old with new in the sub-environment

67−rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->

68− Env m xs -> Env m (updateWith ys' xs prf)

69−rebuildEnv [] SubNil env = env

70−rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

71−rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

72−rebuildEnv (x :: xs) SubNil [] = x :: xs

73−

74−---- The Effect EDSL itself ----

75−

76−-- some proof automation

77−

78−%reflection

79−reflectListEffElem : List a -> Tactic

80−reflectListEffElem [] = Refine "Here" `Seq` Solve

81−reflectListEffElem (x :: xs)

82− = Try (Refine "Here" `Seq` Solve)

83− (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))

84−-- TMP HACK! FIXME!

85−-- The evaluator needs a 'function case' to know its a reflection function

86−-- until we propagate that information! Without this, the _ case won't get

87−-- matched.

88−reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve

89−reflectListEffElem _ = Refine "Here" `Seq` Solve

90−

91−%reflection

92−reflectSubList : List a -> Tactic

93−reflectSubList [] = Refine "subListId" `Seq` Solve

94−reflectSubList (x :: xs)

95− = Try (Refine "subListId" `Seq` Solve)

96− (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))

97− (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))

98−reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve

99−reflectSubList _ = Refine "subListId" `Seq` Solve

100−

101−%reflection

102−reflectDefaultList : List a -> Tactic

103−reflectDefaultList [] = Refine "enil" `Seq` Solve

104−reflectDefaultList (x :: xs)

105− = Refine "econs" `Seq`

106− (Solve `Seq`

107− (Instance `Seq`

108− (Refine "default" `Seq`

109− (Solve `Seq`

110− (Instance `Seq`

111− (reflectDefaultList xs))))))

112−reflectDefaultList (x ++ y) = Refine "Nil" `Seq` Solve

113−reflectDefaultList _ = Refine "Nil" `Seq` Solve

114−

115−%reflection

116−reflectEff : (P : Type) -> Tactic

117−reflectEff (EffElem m a xs)

118− = reflectListEffElem xs `Seq` Solve

119−reflectEff (SubList xs ys)

120− = reflectSubList ys `Seq` Solve

121−reflectEff (Env m xs)

122− = reflectDefaultList xs `Seq` Solve

123−

124−updateResTy : (val : t) ->

125− (xs : List EFFECT) -> EffElem e a xs -> e t a b ->

126− List EFFECT

127−updateResTy {b} val (MkEff a e :: xs) Here n = (MkEff (b val) e) :: xs

128−updateResTy val (x :: xs) (There p) n = x :: updateResTy val xs p n

129−

130−-- updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->

131−-- List EFFECT

132−-- updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs

133−-- updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b

134−

135−infix 5 :::, :-, :=

136−

137−data LRes : lbl -> Type -> Type where

138− (:=) : (x : lbl) -> res -> LRes x res

139−

140−(:::) : lbl -> EFFECT -> EFFECT

141−(:::) {lbl} x (MkEff r e) = MkEff (LRes x r) e

142−

143−using (lbl : Type)

144− instance Default a => Default (LRes lbl a) where

145− default = lbl := default

146−

147−private

148−unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]

149−unlabel {m} {x = MkEff a eff} [l := v] = [v]

150−

151−private

152−relabel : (l : ty) -> Env m xs -> Env m (map (\x => l ::: x) xs)

153−relabel {xs = []} l [] = []

154−relabel {xs = (MkEff a e :: xs)} l (v :: vs) = (l := v) :: relabel l vs

155−

156−-- the language of Effects

157−

158−data Eff : (m : Type -> Type) ->

159− (x : Type) ->

160− List EFFECT -> (x -> List EFFECT) -> Type where

161− value : a -> Eff m a xs (\v => xs)

162− ebind : Eff m a xs xs' ->

163− ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''

164− effect : (prf : EffElem e a xs) ->

165− (eff : e t a b) ->

166− Eff m t xs (\v => updateResTy v xs prf eff)

167−

168− lift : (prf : SubList ys xs) ->

169− Eff m t ys ys' -> Eff m t xs (\v => updateWith (ys' v) xs prf)

170− new : Handler e m =>

171− res ->

172− Eff m a (MkEff res e :: xs) (\v => (MkEff res' e :: xs')) ->

173− Eff m a xs (\v => xs')

174− catch : Catchable m err =>

175− Eff m a xs xs' -> (err -> Eff m a xs xs') ->

176− Eff m a xs xs'

177−

178− (:-) : (l : ty) ->

179− Eff m t [x] xs' -> -- [x] (\v => xs) ->

180− Eff m t [l ::: x] (\v => map (l :::) (xs' v))

181−

182−(>>=) : Eff m a xs xs' ->

183− ((val : a) -> Eff m b (xs' val) xs'') -> Eff m b xs xs''

184−(>>=) = ebind

185−

186−return : a -> Eff m a xs (\v => xs)

187−return x = value x

188−

189−-- for idiom brackets

190−

191−infixl 2 <$>

192−

193−pure : a -> Eff m a xs (\v => xs)

194−pure = value

195−

196−(<$>) : Eff m (a -> b) xs (\v => xs) ->

197− Eff m a xs (\v => xs) -> Eff m b xs (\v => xs)

198−(<$>) prog v = do fn <- prog

199− arg <- v

200− return (fn arg)

201−

202−-- an interpreter

203−

204−private

205−execEff : Env m xs -> (p : EffElem e res xs) ->

206− (eff : e a res resk) ->

207− ((v : a) -> Env m (updateResTy v xs p eff) -> m t) -> m t

208−execEff (val :: env) Here eff' k

209− = handle val eff' (\v, res => k v (res :: env))

210−-- FIXME: Teach the elaborator to propagate parameters here

211−execEff {e} {a} {res} {resk} (val :: env) (There p) eff k

212− = execEff {e} {a} {res} {resk} env p eff (\v, env' => k v (val :: env'))

213−

214−-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

215−-- updates can be propagated even through failing computations?

216−

217−eff : Env m xs -> Eff m a xs xs' -> ((x : a) -> Env m (xs' x) -> m b) -> m b

218−eff env (value x) k = k x env

219−eff env (prog `ebind` c) k

220− = eff env prog (\p', env' => eff env' (c p') k)

221−eff env (effect prf effP) k = execEff env prf effP k

222−eff env (lift prf effP) k

223− = let env' = dropEnv env prf in

224− eff env' effP (\p', envk => k p' (rebuildEnv envk prf env))

225−eff env (new r prog) k

226− = eff (r :: env) prog (\p' => \ (v :: envk) => k p' envk)

227−eff env (catch prog handler) k

228− = catch (eff env prog k)

229− (\e => eff env (handler e) k)

230−-- FIXME:

231−-- xs is needed explicitly because otherwise the pattern binding for

232−-- 'l' appears too late. Solution seems to be to reorder patterns at the

233−-- end so that everything is in scope when it needs to be.

234−eff {xs = [l ::: x]} env (l :- prog) k

235− = let env' = unlabel env in

236− eff env' prog (\p', envk => k p' (relabel l envk))

237−

238−-- yuck :) Haven't got type class instances working nicely in tactic

239−-- proofs yet, so just brute force it.

240−syntax MkDefaultEnv = with Env

241− (| [], [default], [default, default],

242− [default, default, default],

243− [default, default, default, default],

244− [default, default, default, default, default],

245− [default, default, default, default, default, default],

246− [default, default, default, default, default, default, default],

247− [default, default, default, default, default, default, default, default] |)

248−

249−implicit

250−lift' : Eff m t ys ys' ->

251− {default tactics { byReflection reflectEff; }

252− prf : SubList ys xs} ->

253− Eff m t xs (\v => updateWith (ys' v) xs prf)

254−lift' e {prf} = lift prf e

255−

256−implicit

257−effect' : {a, b: _} -> {e : Effect} ->

258− (eff : e t a b) ->

259− {default tactics { byReflection reflectEff; }

260− prf : EffElem e a xs} ->

261− Eff m t xs (\v => updateResTy v xs prf eff)

262−effect' e {prf} = effect prf e

263−

264−

265−run : Applicative m => {default MkDefaultEnv env : Env m xs} -> Eff m a xs xs' -> m a

266−run {env} prog = eff env prog (\r, env => pure r)

267−

268−runPure : {default MkDefaultEnv env : Env id xs} -> Eff id a xs xs' -> a

269−runPure {env} prog = eff env prog (\r, env => r)

270−

271−runInit : Applicative m => Env m xs -> Eff m a xs xs' -> m a

272−runInit env prog = eff env prog (\r, env => pure r)

273−

274−runPureInit : Env id xs -> Eff id a xs xs' -> a

275−runPureInit env prog = eff env prog (\r, env => r)

276−

277−runWith : (a -> m a) -> Env m xs -> Eff m a xs xs' -> m a

278−runWith inj env prog = eff env prog (\r, env => inj r)

279−

280−runEnv : Applicative m => Env m xs -> Eff m a xs xs' ->

281− m (x : a ** Env m (xs' x))

282−runEnv env prog = eff env prog (\r, env => pure (r ** env))

283−

284−-- some higher order things

285−

286−mapE : Applicative m => (a -> {xs} Eff m b) -> List a -> {xs} Eff m (List b)

287−mapE f [] = pure []

288−mapE f (x :: xs) = [| f x :: mapE f xs |]

289−

290−

291−mapVE : Applicative m =>

292− (a -> {xs} Eff m b) ->

293− Vect n a ->

294− {xs} Eff m (Vect n b)

295−mapVE f [] = pure []

296−mapVE f (x :: xs) = [| f x :: mapVE f xs |]

297−

298−

299−when : Applicative m => Bool -> ({xs} Eff m ()) -> {xs} Eff m ()

300−when True e = e

301−when False e = pure ()

302−

libs/neweffects/Effect/Exception.idr → libs/oldeffects/Effect/Exception.idrrenamed+4−3

@@ -4,8 +4,8 @@ import Effects

4import System

5import Control.IOExcept

6

7−data Exception : Type -> Effect where

7+data Exception : Type -> Type -> Type -> Type -> Type where

8− Raise : a -> { () } Exception a b

8+ Raise : a -> Exception a () () b

9

10instance Handler (Exception a) Maybe where

11 handle _ (Raise e) k = Nothing

@@ -23,7 +23,7 @@ instance Handler (Exception a) (Either a) where

23EXCEPTION : Type -> EFFECT

24EXCEPTION t = MkEff () (Exception t)

25

26−raise : a -> { [EXCEPTION a ] } Eff m b

26+raise : a -> Eff m [EXCEPTION a] b

27raise err = Raise err

28

29

@@ -31,6 +31,7 @@ raise err = Raise err

31

32

33

34+

34-- TODO: Catching exceptions mid program?

35-- TODO: Catching exceptions mid program?

35-- probably need to invoke a new interpreter

36-- probably need to invoke a new interpreter

36

37

libs/oldeffects/Effect/File.idrnew file+69

@@ -0,0 +1,69 @@

1+module Effect.File

2+

3+import Effects

4+import Control.IOExcept

5+

6+data OpenFile : Mode -> Type where

7+ FH : File -> OpenFile m

8+

9+data FileIO : Effect where

10+ Open : String -> (m : Mode) -> FileIO () (Either () (OpenFile m)) Bool

11+ Close : FileIO (OpenFile m) () ()

12+

13+ ReadLine : FileIO (OpenFile Read) (OpenFile Read) String

14+ WriteLine : String -> FileIO (OpenFile Write) (OpenFile Write) ()

15+ EOF : FileIO (OpenFile Read) (OpenFile Read) Bool

16+

17+

18+instance Handler FileIO IO where

19+ handle () (Open fname m) k = do h <- openFile fname m

20+ valid <- validFile h

21+ if valid then k (Right (FH h)) True

22+ else k (Left ()) False

23+ handle (FH h) Close k = do closeFile h

24+ k () ()

25+ handle (FH h) ReadLine k = do str <- fread h

26+ k (FH h) str

27+ handle (FH h) (WriteLine str) k = do fwrite h str

28+ k (FH h) ()

29+ handle (FH h) EOF k = do e <- feof h

30+ k (FH h) e

31+

32+instance Handler FileIO (IOExcept String) where

33+ handle () (Open fname m) k

34+ = do h <- ioe_lift (openFile fname m)

35+ valid <- ioe_lift (validFile h)

36+ if valid then k (Right (FH h)) True

37+ else k (Left ()) False

38+ handle (FH h) Close k = do ioe_lift (closeFile h); k () ()

39+ handle (FH h) ReadLine k = do str <- ioe_lift (fread h)

40+ k (FH h) str

41+ handle (FH h) (WriteLine str) k = do ioe_lift (fwrite h str)

42+ k (FH h) ()

43+ handle (FH h) EOF k = do e <- ioe_lift (feof h)

44+ k (FH h) e

45+

46+FILE_IO : Type -> EFFECT

47+FILE_IO t = MkEff t FileIO

48+

49+open : Handler FileIO e =>

50+ String -> (m : Mode) -> EffM e [FILE_IO ()]

51+ [FILE_IO (Either () (OpenFile m))] Bool

52+open f m = Open f m

53+

54+close : Handler FileIO e =>

55+ EffM e [FILE_IO (OpenFile m)] [FILE_IO ()] ()

56+close = Close

57+

58+readLine : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] String

59+readLine = ReadLine

60+

61+writeLine : Handler FileIO e => String -> Eff e [FILE_IO (OpenFile Write)] ()

62+writeLine str = WriteLine str

63+

64+eof : Handler FileIO e => Eff e [FILE_IO (OpenFile Read)] Bool

65+eof = EOF

66+

67+

68+

69+

libs/neweffects/Effect/Memory.idr → libs/oldeffects/Effect/Memory.idrrenamed+25−31

@@ -12,30 +12,29 @@ data MemoryChunk : Nat -> Nat -> Type where

12abstract

13data RawMemory : Effect where

14 Allocate : (n : Nat) ->

15− RawMemory () () (\v => MemoryChunk n 0)

15+ RawMemory () (MemoryChunk n 0) ()

16− Free : RawMemory () (MemoryChunk n i) (\v => ())

16+ Free : RawMemory (MemoryChunk n i) () ()

17 Initialize : Bits8 ->

18 (size : Nat) ->

19 so (i + size <= n) ->

20− RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (i + size))

20+ RawMemory (MemoryChunk n i) (MemoryChunk n (i + size)) ()

21 Peek : (offset : Nat) ->

22 (size : Nat) ->

23 so (offset + size <= i) ->

24− RawMemory (Vect size Bits8)

24+ RawMemory (MemoryChunk n i) (MemoryChunk n i) (Vect size Bits8)

25− (MemoryChunk n i) (\v => MemoryChunk n i)

26 Poke : (offset : Nat) ->

25 Poke : (offset : Nat) ->

27 (Vect size Bits8) ->

26 (Vect size Bits8) ->

28 so (offset <= i && offset + size <= n) ->

27 so (offset <= i && offset + size <= n) ->

29− RawMemory () (MemoryChunk n i) (\v => MemoryChunk n (max i (offset + size)))

28+ RawMemory (MemoryChunk n i) (MemoryChunk n (max i (offset + size))) ()

30 Move : (src : MemoryChunk src_size src_init) ->

29 Move : (src : MemoryChunk src_size src_init) ->

31 (dst_offset : Nat) ->

30 (dst_offset : Nat) ->

32 (src_offset : Nat) ->

31 (src_offset : Nat) ->

33 (size : Nat) ->

32 (size : Nat) ->

34 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

33 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

35 so (src_offset + size <= src_init) ->

34 so (src_offset + size <= src_init) ->

36− RawMemory () (MemoryChunk dst_size dst_init)

35+ RawMemory (MemoryChunk dst_size dst_init)

37− (\v => MemoryChunk dst_size (max dst_init (dst_offset + size)))

36+ (MemoryChunk dst_size (max dst_init (dst_offset + size))) ()

38− GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (\v => MemoryChunk n i)

37+ GetRawPtr : RawMemory (MemoryChunk n i) (MemoryChunk n i) (MemoryChunk n i)

39

38

40private

39private

41do_malloc : Nat -> IOExcept String Ptr

40do_malloc : Nat -> IOExcept String Ptr

@@ -80,28 +79,27 @@ do_poke ptr offset (b::bs)

80instance Handler RawMemory (IOExcept String) where

79instance Handler RawMemory (IOExcept String) where

81 handle () (Allocate n) k

80 handle () (Allocate n) k

82 = do ptr <- do_malloc n

81 = do ptr <- do_malloc n

83− k () (CH ptr)

82+ k (CH ptr) ()

84− handle {-{res = MemoryChunk _ offset}-} (CH ptr) (Initialize {i} c size _) k

83+ handle (CH ptr) (Initialize {i} c size _) k

85− = ioe_lift (do_memset ptr i c size) $> k () (CH ptr)

84+ = ioe_lift (do_memset ptr i c size) $> k (CH ptr) ()

86 handle (CH ptr) (Free) k

85 handle (CH ptr) (Free) k

87 = ioe_lift (do_free ptr) $> k () ()

86 = ioe_lift (do_free ptr) $> k () ()

88 handle (CH ptr) (Peek offset size _) k

87 handle (CH ptr) (Peek offset size _) k

89 = do res <- ioe_lift (do_peek ptr offset size)

88 = do res <- ioe_lift (do_peek ptr offset size)

90− k res (CH ptr)

89+ k (CH ptr) res

91 handle (CH ptr) (Poke offset content _) k

90 handle (CH ptr) (Poke offset content _) k

92 = do ioe_lift (do_poke ptr offset content)

91 = do ioe_lift (do_poke ptr offset content)

93− k () (CH ptr)

92+ k (CH ptr) ()

94 handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k

93 handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k

95 = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)

94 = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)

96− k () (CH dest_ptr)

95+ k (CH dest_ptr) ()

97 handle chunk (GetRawPtr) k

96 handle chunk (GetRawPtr) k

98 = k chunk chunk

97 = k chunk chunk

99

98

100RAW_MEMORY : Type -> EFFECT

99RAW_MEMORY : Type -> EFFECT

101RAW_MEMORY t = MkEff t RawMemory

100RAW_MEMORY t = MkEff t RawMemory

102

101

103−allocate : (n : Nat) ->

104− Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

102+allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] ()

105allocate size = Allocate size

103allocate size = Allocate size

106

104

107initialize : {i : Nat} ->

105initialize : {i : Nat} ->

@@ -109,18 +107,17 @@ initialize : {i : Nat} ->

109 Bits8 ->

107 Bits8 ->

110 (size : Nat) ->

108 (size : Nat) ->

111 so (i + size <= n) ->

109 so (i + size <= n) ->

112− Eff m () [RAW_MEMORY (MemoryChunk n i)]

113− (\v => [RAW_MEMORY (MemoryChunk n (i + size))])

110+ EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] ()

114initialize c size prf = Initialize c size prf

111initialize c size prf = Initialize c size prf

115

112

116−free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

113+free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] ()

117free = Free

114free = Free

118

115

119peek : {i : Nat} ->

116peek : {i : Nat} ->

120 (offset : Nat) ->

117 (offset : Nat) ->

121 (size : Nat) ->

118 (size : Nat) ->

122 so (offset + size <= i) ->

119 so (offset + size <= i) ->

123− { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8)

120+ Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect size Bits8)

124peek offset size prf = Peek offset size prf

121peek offset size prf = Peek offset size prf

125

122

126poke : {n : Nat} ->

123poke : {n : Nat} ->

@@ -128,12 +125,11 @@ poke : {n : Nat} ->

128 (offset : Nat) ->

125 (offset : Nat) ->

129 Vect size Bits8 ->

126 Vect size Bits8 ->

130 so (offset <= i && offset + size <= n) ->

127 so (offset <= i && offset + size <= n) ->

131− Eff m () [RAW_MEMORY (MemoryChunk n i)]

132− (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))])

128+ EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] ()

133poke offset content prf = Poke offset content prf

129poke offset content prf = Poke offset content prf

134

130

135private

131private

136−getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i)

132+getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i)

137getRawPtr = GetRawPtr

133getRawPtr = GetRawPtr

138

134

139private

135private

@@ -146,8 +142,8 @@ move' : {dst_size : Nat} ->

146 (size : Nat) ->

142 (size : Nat) ->

147 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

143 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

148 so (src_offset + size <= src_init) ->

144 so (src_offset + size <= src_init) ->

149− Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]

145+ EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)]

150− (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))])

146+ [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] ()

151move' src_ptr dst_offset src_offset size dst_bounds src_bounds

147move' src_ptr dst_offset src_offset size dst_bounds src_bounds

152 = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

148 = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

153

149

@@ -162,12 +158,10 @@ move : {dst_size : Nat} ->

162 (size : Nat) ->

158 (size : Nat) ->

163 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

159 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

164 so (src_offset + size <= src_init) ->

160 so (src_offset + size <= src_init) ->

165− Eff m ()

166− [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)

161+ EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)

167 , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]

162 , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]

168− (\v =>

169− [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))

163+ [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))

170− , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)])

164+ , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] ()

171move dst_offset src_offset size dst_bounds src_bounds

165move dst_offset src_offset size dst_bounds src_bounds

172 = do src_ptr <- Src :- getRawPtr

166 = do src_ptr <- Src :- getRawPtr

173 Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds

167 Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds

libs/neweffects/Effect/Monad.idr → libs/oldeffects/Effect/Monad.idrrenamed+4−4

@@ -5,17 +5,17 @@ import Effects

5-- Eff is a monad too, so we can happily use it in a monad transformer.

6

7using (xs : List EFFECT, m : Type -> Type)

8− instance Functor (\a => EffM m a xs (\v => xs)) where

8+ instance Functor (EffM m xs xs) where

9 map f prog = do t <- prog

10 value (f t)

11

12− instance Applicative (\a => EffM m a xs (\v => xs)) where

12+ instance Applicative (EffM m xs xs) where

13 pure = value

14 (<$>) f a = do f' <- f

15 a' <- a

16 value (f' a')

17

18− instance Monad (\a => Eff m a xs (\v => xs)) where

18+ instance Monad (EffM m xs xs) where

19− (>>=) = Effects.(>>=)

19+ (>>=) = ebind

20

21

libs/oldeffects/Effect/Random.idrnew file+25

@@ -0,0 +1,25 @@

1+module Effect.Random

2+

3+import Effects

4+

5+data Random : Type -> Type -> Type -> Type where

6+ getRandom : Random Integer Integer Integer

7+ setSeed : Integer -> Random Integer Integer ()

8+

9+using (m : Type -> Type)

10+ instance Handler Random m where

11+ handle seed getRandom k

12+ = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in

13+ k seed' seed'

14+ handle seed (setSeed n) k = k n ()

15+

16+RND : EFFECT

17+RND = MkEff Integer Random

18+

19+rndInt : Integer -> Integer -> Eff m [RND] Integer

20+rndInt lower upper = do v <- getRandom

21+ return (v `prim__sremBigInt` (upper - lower) + lower)

22+

23+srand : Integer -> Eff m [RND] ()

24+srand n = setSeed n

25+

libs/neweffects/Effect/Select.idr → libs/oldeffects/Effect/Select.idrrenamed+4−4

@@ -3,21 +3,21 @@ module Effect.Select

3import Effects

4

5data Selection : Effect where

6− Select : List a -> { () } Selection a

6+ Select : List a -> Selection () () a

7

8instance Handler Selection Maybe where

9 handle _ (Select xs) k = tryAll xs where

10 tryAll [] = Nothing

11− tryAll (x :: xs) = case k x () of

11+ tryAll (x :: xs) = case k () x of

12 Nothing => tryAll xs

13 Just v => Just v

14

15instance Handler Selection List where

16− handle r (Select xs) k = concatMap (\x => k x r) xs

16+ handle r (Select xs) k = concatMap (k r) xs

17

18SELECT : EFFECT

19SELECT = MkEff () Selection

20

21−select : List a -> { [SELECT] } Eff m a

21+select : List a -> Eff m [SELECT] a

22select xs = Select xs

23

libs/neweffects/Effect/State.idr → libs/oldeffects/Effect/State.idrrenamed+9−9

@@ -5,33 +5,33 @@ import Effects

5%access public

6

7data State : Effect where

8− Get : { a } State a

8+ Get : State a a a

9− Put : b -> { a ==> b } State ()

9+ Put : b -> State a b ()

10

11using (m : Type -> Type)

12 instance Handler State m where

13 handle st Get k = k st st

14− handle st (Put n) k = k () n

14+ handle st (Put n) k = k n ()

15

16STATE : Type -> EFFECT

17STATE t = MkEff t State

18

19−get : { [STATE x] } Eff m x

19+get : Eff m [STATE x] x

20get = Get

21

22−put : x -> { [STATE x] } Eff m ()

22+put : x -> Eff m [STATE x] ()

23put val = Put val

24

25−putM : y -> { [STATE x] ==> [STATE y] } Eff m ()

25+putM : y -> EffM m [STATE x] [STATE y] ()

26putM val = Put val

27

28−update : (x -> x) -> { [STATE x] } Eff m ()

28+update : (x -> x) -> Eff m [STATE x] ()

29update f = put (f !get)

30

31−updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff m ()

31+updateM : (x -> y) -> EffM m [STATE x] [STATE y] ()

32updateM f = putM (f !get)

33

34−locally : x -> ({ [STATE x] } Eff m t) -> { [STATE y] } Eff m t

34+locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t

35locally newst prog = do st <- get

36 putM newst

37 val <- prog

libs/oldeffects/Effect/StdIO.idrnew file+60

@@ -0,0 +1,60 @@

1+module Effect.StdIO

2+

3+import Effects

4+import Control.IOExcept

5+

6+data StdIO : Effect where

7+ PutStr : String -> StdIO () () ()

8+ GetStr : StdIO () () String

9+

10+instance Handler StdIO IO where

11+ handle () (PutStr s) k = do putStr s; k () ()

12+ handle () GetStr k = do x <- getLine; k () x

13+

14+instance Handler StdIO (IOExcept a) where

15+ handle () (PutStr s) k = do ioe_lift (putStr s); k () ()

16+ handle () GetStr k = do x <- ioe_lift getLine; k () x

17+

18+-- Handle effects in a pure way, for simulating IO for unit testing/proof

19+

20+data IOStream a = MkStream (List String -> (a, List String))

21+

22+instance Handler StdIO IOStream where

23+ handle () (PutStr s) k

24+ = MkStream (\x => case k () () of

25+ MkStream f => let (res, str) = f x in

26+ (res, s :: str))

27+ handle {a} () GetStr k

28+ = MkStream (\x => case x of

29+ [] => cont "" []

30+ (t :: ts) => cont t ts)

31+ where

32+ cont : String -> List String -> (a, List String)

33+ cont t ts = case k () t of

34+ MkStream f => f ts

35+

36+--- The Effect and associated functions

37+

38+STDIO : EFFECT

39+STDIO = MkEff () StdIO

40+

41+putStr : Handler StdIO e => String -> Eff e [STDIO] ()

42+putStr s = PutStr s

43+

44+putStrLn : Handler StdIO e => String -> Eff e [STDIO] ()

45+putStrLn s = putStr (s ++ "\n")

46+

47+getStr : Handler StdIO e => Eff e [STDIO] String

48+getStr = GetStr

49+

50+mkStrFn : Env IOStream xs ->

51+ Eff IOStream xs a ->

52+ List String -> (a, List String)

53+mkStrFn {a} env p input = case mkStrFn' of

54+ MkStream f => f input

55+ where injStream : a -> IOStream a

56+ injStream v = MkStream (\x => (v, []))

57+ mkStrFn' : IOStream a

58+ mkStrFn' = runWith injStream env p

59+

60+

libs/oldeffects/Effects.idrnew file+308

@@ -0,0 +1,308 @@

1+module Effects

2+

3+import Language.Reflection

4+import Control.Catchable

5+

6+%access public

7+

8+---- Effects

9+

10+Effect : Type

11+Effect = Type -> Type -> Type -> Type

12+

13+%error_reverse

14+data EFFECT : Type where

15+ MkEff : Type -> Effect -> EFFECT

16+

17+class Handler (e : Effect) (m : Type -> Type) where

18+ handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a

19+

20+---- Properties and proof construction

21+

22+using (xs : List a, ys : List a)

23+ data SubList : List a -> List a -> Type where

24+ SubNil : SubList {a} [] []

25+ Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

26+ Drop : SubList xs ys -> SubList xs (x :: ys)

27+

28+ subListId : SubList xs xs

29+ subListId {xs = Nil} = SubNil

30+ subListId {xs = x :: xs} = Keep subListId

31+

32+data Env : (m : Type -> Type) -> List EFFECT -> Type where

33+ Nil : Env m Nil

34+ (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

35+

36+data EffElem : (Type -> Type -> Type -> Type) -> Type ->

37+ List EFFECT -> Type where

38+ Here : EffElem x a (MkEff a x :: xs)

39+ There : EffElem x a xs -> EffElem x a (y :: xs)

40+

41+-- make an environment corresponding to a sub-list

42+dropEnv : Env m ys -> SubList xs ys -> Env m xs

43+dropEnv [] SubNil = []

44+dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

45+dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

46+

47+updateWith : (ys' : List a) -> (xs : List a) ->

48+ SubList ys xs -> List a

49+updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

50+updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest

51+updateWith [] [] SubNil = []

52+updateWith (y :: ys) [] SubNil = y :: ys

53+updateWith [] (x :: xs) (Keep rest) = []

54+

55+-- put things back, replacing old with new in the sub-environment

56+rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->

57+ Env m xs -> Env m (updateWith ys' xs prf)

58+rebuildEnv [] SubNil env = env

59+rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

60+rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

61+rebuildEnv (x :: xs) SubNil [] = x :: xs

62+

63+---- The Effect EDSL itself ----

64+

65+-- some proof automation

66+

67+%reflection

68+reflectListEffElem : List a -> Tactic

69+reflectListEffElem [] = Refine "Here" `Seq` Solve

70+reflectListEffElem (x :: xs)

71+ = Try (Refine "Here" `Seq` Solve)

72+ (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))

73+-- TMP HACK! FIXME!

74+-- The evaluator needs a 'function case' to know its a reflection function

75+-- until we propagate that information! Without this, the _ case won't get

76+-- matched.

77+reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve

78+reflectListEffElem _ = Refine "Here" `Seq` Solve

79+

80+%reflection

81+reflectSubList : List a -> Tactic

82+reflectSubList [] = Refine "SubNil" `Seq` Solve

83+reflectSubList (x :: xs)

84+ = Try (Refine "subListId" `Seq` Solve)

85+ (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))

86+ (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))

87+reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve

88+reflectSubList _ = Refine "subListId" `Seq` Solve

89+

90+%reflection

91+reflectEff : (P : Type) -> Tactic

92+reflectEff (EffElem m a xs)

93+ = reflectListEffElem xs `Seq` Solve

94+reflectEff (SubList xs ys)

95+ = reflectSubList ys `Seq` Solve

96+

97+updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t ->

98+ List EFFECT

99+updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs

100+updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n

101+

102+updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->

103+ List EFFECT

104+updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs

105+updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b

106+

107+infix 5 :::, :-, :=

108+

109+data LRes : lbl -> Type -> Type where

110+ (:=) : (x : lbl) -> res -> LRes x res

111+

112+(:::) : lbl -> EFFECT -> EFFECT

113+(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff

114+

115+private

116+unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]

117+unlabel {m} {x = MkEff a eff} [l := v] = [v]

118+

119+private

120+relabel : (l : ty) -> Env m [x] -> Env m [l ::: x]

121+relabel {x = MkEff a eff} l [v] = [l := v]

122+

123+-- the language of Effects

124+

125+data EffM : (m : Type -> Type) ->

126+ List EFFECT -> List EFFECT -> Type -> Type where

127+ value : a -> EffM m xs xs a

128+ ebind : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b

129+ effect : (prf : EffElem e a xs) ->

130+ (eff : e a b t) ->

131+ EffM m xs (updateResTy xs prf eff) t

132+ lift : (prf : SubList ys xs) ->

133+ EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t

134+ new : Handler e m =>

135+ res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a ->

136+ EffM m xs xs' a

137+ test : (prf : EffElem e (Either l r) xs) ->

138+ EffM m (updateResTyImm xs prf l) xs' t ->

139+ EffM m (updateResTyImm xs prf r) xs' t ->

140+ EffM m xs xs' t

141+ test_lbl : {x : lbl} ->

142+ (prf : EffElem e (LRes x (Either l r)) xs) ->

143+ EffM m (updateResTyImm xs prf (LRes x l)) xs' t ->

144+ EffM m (updateResTyImm xs prf (LRes x r)) xs' t ->

145+ EffM m xs xs' t

146+ catch : Catchable m err =>

147+ EffM m xs xs' a -> (err -> EffM m xs xs' a) ->

148+ EffM m xs xs' a

149+ (:-) : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t

150+

151+syntax [tag] ":!" [val] = !(tag :- val)

152+

153+-- Eff : List (EFFECT m) -> Type -> Type

154+

155+-- For making proofs implicitly for 'test' and 'test_lbl'

156+

157+syntax if_valid then [e] else [t] =

158+ test (tactics { byReflection reflectEff; }) t e

159+

160+syntax if_valid [lbl] then [e] else [t] =

161+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

162+

163+syntax if_error then [t] else [e] =

164+ test (tactics { byReflection reflectEff; }) t e

165+

166+syntax if_error [lbl] then [t] else [e] =

167+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

168+

169+-- These may read better in some contexts

170+

171+syntax if_right then [e] else [t] =

172+ test (tactics { byReflection reflectEff; }) t e

173+

174+syntax if_right [lbl] then [e] else [t] =

175+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

176+

177+syntax if_left then [t] else [e] =

178+ test (tactics { byReflection reflectEff; }) t e

179+

180+syntax if_left [lbl] then [t] else [e] =

181+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

182+

183+

184+-- for 'do' notation

185+

186+return : a -> EffM m xs xs a

187+return x = value x

188+

189+(>>=) : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b

190+(>>=) = ebind

191+

192+-- for idiom brackets

193+

194+infixl 2 <$>

195+

196+pure : a -> EffM m xs xs a

197+pure = value

198+

199+(<$>) : EffM m xs xs (a -> b) -> EffM m xs xs a -> EffM m xs xs b

200+(<$>) prog v = do fn <- prog

201+ arg <- v

202+ return (fn arg)

203+

204+-- an interpreter

205+

206+private

207+execEff : Env m xs -> (p : EffElem e res xs) ->

208+ (eff : e res b a) ->

209+ (Env m (updateResTy xs p eff) -> a -> m t) -> m t

210+execEff (val :: env) Here eff' k

211+ = handle val eff' (\res, v => k (res :: env) v)

212+execEff {e} {res} {b} {a} (val :: env) (There p) eff k

213+ = execEff {e} {res} {b} {a} env p eff (\env', v => k (val :: env') v)

214+

215+private

216+testEff : Env m xs -> (p : EffElem e (Either l r) xs) ->

217+ (Env m (updateResTyImm xs p l) -> m b) ->

218+ (Env m (updateResTyImm xs p r) -> m b) ->

219+ m b

220+testEff (Left err :: env) Here lk rk = lk (err :: env)

221+testEff (Right ok :: env) Here lk rk = rk (ok :: env)

222+testEff (val :: env) (There p) lk rk

223+ = testEff env p (\envk => lk (val :: envk))

224+ (\envk => rk (val :: envk))

225+

226+private

227+testEffLbl : {x : lblTy} ->

228+ Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) ->

229+ (Env m (updateResTyImm xs p (LRes x l)) -> m b) ->

230+ (Env m (updateResTyImm xs p (LRes x r)) -> m b) ->

231+ m b

232+testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env)

233+testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env)

234+testEffLbl (val :: env) (There p) lk rk

235+ = testEffLbl env p (\envk => lk (val :: envk))

236+ (\envk => rk (val :: envk))

237+

238+-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

239+-- updates can be propagated even through failing computations?

240+

241+eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b

242+eff env (value x) k = k env x

243+eff env (prog `ebind` c) k

244+ = eff env prog (\env', p' => eff env' (c p') k)

245+eff env (effect prf effP) k = execEff env prf effP k

246+eff env (lift prf effP) k

247+ = let env' = dropEnv env prf in

248+ eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p')

249+eff env (new r prog) k

250+ = eff (r :: env) prog (\(v :: envk), p' => k envk p')

251+eff env (test prf l r) k

252+ = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)

253+eff env (test_lbl prf l r) k

254+ = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k)

255+eff env (catch prog handler) k

256+ = catch (eff env prog k)

257+ (\e => eff env (handler e) k)

258+-- FIXME:

259+-- xs is needed explicitly because otherwise the pattern binding for

260+-- 'l' appears too late. Solution seems to be to reorder patterns at the

261+-- end so that everything is in scope when it needs to be.

262+eff {xs = [l ::: x]} env (l :- prog) k

263+ = let env' = unlabel env in

264+ eff env' prog (\envk, p' => k (relabel l envk) p')

265+

266+implicit

267+lift' : EffM m ys ys' t ->

268+ {default tactics { byReflection reflectEff; }

269+ prf : SubList ys xs} ->

270+ EffM m xs (updateWith ys' xs prf) t

271+lift' e {prf} = lift prf e

272+

273+implicit

274+effect' : {a, b: _} -> {e : Effect} ->

275+ (eff : e a b t) ->

276+ {default tactics { byReflection reflectEff; }

277+ prf : EffElem e a xs} ->

278+ EffM m xs (updateResTy xs prf eff) t

279+effect' e {prf} = effect prf e

280+

281+

282+run : Applicative m => Env m xs -> EffM m xs xs' a -> m a

283+run env prog = eff env prog (\env, r => pure r)

284+

285+runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a)

286+runEnv env prog = eff env prog (\env, r => pure (env, r))

287+

288+runPure : Env id xs -> EffM id xs xs' a -> a

289+runPure env prog = eff env prog (\env, r => r)

290+

291+-- runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a)

292+-- runPureEnv env prog = eff env prog (\env, r => (env, r))

293+

294+runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a

295+runWith inj env prog = eff env prog (\env, r => inj r)

296+

297+Eff : (Type -> Type) -> List EFFECT -> Type -> Type

298+Eff m xs t = EffM m xs xs t

299+

300+-- some higher order things

301+

302+mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b)

303+mapE f [] = pure []

304+mapE f (x :: xs) = [| f x :: mapE f xs |]

305+

306+when : Applicative m => Bool -> Lazy (Eff m xs ()) -> Eff m xs ()

307+when True e = e

308+when False e = pure ()

libs/neweffects/Makefile → libs/oldeffects/Makefilerenamed+3−3

@@ -1,13 +1,13 @@

1IDRIS := idris

2

3build:

4− $(IDRIS) --build neweffects.ipkg

4+ $(IDRIS) --build oldeffects.ipkg

5

6clean:

7− $(IDRIS) --clean neweffects.ipkg

7+ $(IDRIS) --clean oldeffects.ipkg

8

9install:

10− $(IDRIS) --install neweffects.ipkg

10+ $(IDRIS) --install oldeffects.ipkg

11

12rebuild: clean build

13

libs/neweffects/neweffects.ipkg → libs/oldeffects/oldeffects.ipkgrenamed+3−4

@@ -1,9 +1,8 @@

1−package neweffects

1+package oldeffects

2

3opts = "--nobasepkgs -i ../prelude -i ../base"

4−modules = Effects, Effect.Default,

4+modules = Effects,

5−

6 Effect.Exception, Effect.File, Effect.State,

5 Effect.Exception, Effect.File, Effect.State,

7 Effect.Random, Effect.StdIO, Effect.Select,

6 Effect.Random, Effect.StdIO, Effect.Select,

8− Effect.Memory, Effect.System

7+ Effect.Memory, Effect.Monad

9

8

libs/prelude/Builtins.idr+59−28

@@ -3,44 +3,69 @@

3%access public

4%default total

5

6+||| Dependent pairs, in their internal representation

7+||| @ a the type of the witness

8+||| @ P the type of the proof

6−data Exists : (a : Type) -> (P : a -> Type) -> Type where

9+data Sigma : (a : Type) -> (P : a -> Type) -> Type where

7− Ex_intro : {P : a -> Type} -> (x : a) -> P x -> Exists a P

10+ Sg_intro : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P

8−

9−getWitness : {P : a -> Type} -> Exists a P -> a

10−getWitness (a ** v) = a

11−

12−getProof : {P : a -> Type} -> (s : Exists a P) -> P (getWitness s)

13−getProof (a ** v) = v

14

11

12+||| The eliminator for the empty type.

15FalseElim : _|_ -> a

13FalseElim : _|_ -> a

16

14

17−-- For 'symbol syntax. 'foo becomes Symbol_ "foo"

15+||| For 'symbol syntax. 'foo becomes Symbol_ "foo"

18data Symbol_ : String -> Type where

16data Symbol_ : String -> Type where

19

17

20-- ------------------------------------------------------ [ For rewrite tactic ]

18-- ------------------------------------------------------ [ For rewrite tactic ]

19+||| Perform substitution in a term according to some equality.

20+|||

21+||| This is used by the `rewrite` tactic and term.

21replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y

22replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y

22replace refl prf = prf

23replace refl prf = prf

23

24

25+||| Symmetry of propositional equality

24sym : {l:a} -> {r:a} -> l = r -> r = l

26sym : {l:a} -> {r:a} -> l = r -> r = l

25sym refl = refl

27sym refl = refl

26

28

29+||| Transitivity of propositional equality

27−trans : {a:x} -> {b:x} -> {c:x} -> a = b -> b = c -> a = c

30+trans : {a:x} -> {b:y} -> {c:z} -> a = b -> b = c -> a = c

28trans refl refl = refl

31trans refl refl = refl

29

32

30−lazy : a -> a

33+||| There are two types of laziness: that arising from lazy functions, and that

31−lazy x = x -- compiled specially

34+||| arising from codata. They differ in their totality condition.

32−

35+data LazyType = LazyCodata | LazyEval

33−force : a -> a

36+

34−force x = x -- compiled specially

37+||| The underlying implementation of Lazy and Inf.

38+%error_reverse

39+data Lazy' : LazyType -> Type -> Type where

40+ ||| A delayed computation.

41+ |||

42+ ||| Delay is inserted automatically by the elaborator where necessary.

43+ |||

44+ ||| Note that compiled code gives `Delay` special semantics.

45+ ||| @ t whether this is laziness from codata or normal lazy evaluation

46+ ||| @ a the type of the eventual value

47+ ||| @ val a computation that will produce a value

48+ Delay : {t, a : _} -> (val : a) -> Lazy' t a

49+

50+||| Compute a value from a delayed computation.

51+|||

52+||| Inserted by the elaborator where necessary.

53+Force : {t, a : _} -> Lazy' t a -> a

54+Force (Delay x) = x

35

55

56+||| Lazily evaluated values. This has special evaluation semantics.

36−data Lazy : Type -> Type where

57+Lazy : Type -> Type

37− Delay : (val : a) -> Lazy a

58+Lazy t = Lazy' LazyEval t

38

59

39−Force : Lazy a -> a

60+||| Recursive parameters to codata. Inserted automatically by the elaborator

40−Force (Delay x) = x

61+||| on a "codata" definition but is necessary by hand if mixing inductive and

62+||| coinductive parameters.

63+Inf : Type -> Type

64+Inf t = Lazy' LazyCodata t

41

65

42−par : Lazy a -> a

66+par : Lazy a -> a -- Doesn't actually do anything yet. Maybe a 'Par a' type

67+ -- is better in any case?

43−par (Delay x) = x -- compiled specially

68+par (Delay x) = x

44

69

45malloc : Int -> a -> a

70malloc : Int -> a -> a

46malloc size x = x -- compiled specially

71malloc size x = x -- compiled specially

@@ -48,21 +73,27 @@ malloc size x = x -- compiled specially

48trace_malloc : a -> a

73trace_malloc : a -> a

49trace_malloc x = x -- compiled specially

74trace_malloc x = x -- compiled specially

50

75

51−-- Assert to the totality checker than y is always structureally smaller than

76+||| Assert to the totality checker than y is always structurally smaller than

52−-- x (which is typically a pattern argument)

77+||| x (which is typically a pattern argument)

78+||| @ x the larger value (typically a pattern argument)

79+||| @ y the smaller value (typically an argument to a recursive call)

53−assert_smaller : a -> a -> a

80+assert_smaller : (x : a) -> (y : b) -> b

54assert_smaller x y = y

81assert_smaller x y = y

55

82

56−-- Assert to the totality checker than the given expression will always

83+||| Assert to the totality checker than the given expression will always

57−-- terminate.

84+||| terminate.

58assert_total : a -> a

85assert_total : a -> a

59assert_total x = x

86assert_total x = x

60

87

88+||| Subvert the type checker. This function is abstract, so it will not reduce in

89+||| the type checker. Use it with care - it can result in segfaults or worse!

61abstract %assert_total -- need to pretend

90abstract %assert_total -- need to pretend

62−believe_me : a -> b -- compiled specially as id, use with care!

91+believe_me : a -> b

63believe_me x = prim__believe_me _ _ x

92believe_me x = prim__believe_me _ _ x

64

93

65−public %assert_total -- reduces at compile time, use with extreme care!

94+||| Subvert the type checker. This function *will* reduce in the type checker.

95+||| Use it with extreme care - it can result in segfaults or worse!

96+public %assert_total

66really_believe_me : a -> b

97really_believe_me : a -> b

67really_believe_me x = prim__believe_me _ _ x

98really_believe_me x = prim__believe_me _ _ x

68

99

libs/prelude/Decidable/Equality.idr+36−19

@@ -12,6 +12,7 @@ import Prelude.Maybe

12-- Utility lemmas

13--------------------------------------------------------------------------------

14

15+||| The negation of equality is symmetric (follows from symmetry of equality)

15total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_)

16total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_)

16negEqSym p h = p (sym h)

17negEqSym p h = p (sym h)

17

18

@@ -20,7 +21,9 @@ negEqSym p h = p (sym h)

20-- Decidable equality

21-- Decidable equality

21--------------------------------------------------------------------------------

22--------------------------------------------------------------------------------

22

23

24+||| Decision procedures for propositional equality

23class DecEq t where

25class DecEq t where

26+ ||| Decide whether two elements of `t` are propositionally equal

24 total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)

27 total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)

25

28

26--------------------------------------------------------------------------------

29--------------------------------------------------------------------------------

@@ -33,7 +36,6 @@ instance DecEq () where

33--------------------------------------------------------------------------------

36--------------------------------------------------------------------------------

34-- Booleans

37-- Booleans

35--------------------------------------------------------------------------------

38--------------------------------------------------------------------------------

36−

37total trueNotFalse : True = False -> _|_

39total trueNotFalse : True = False -> _|_

38trueNotFalse refl impossible

40trueNotFalse refl impossible

39

41

@@ -122,13 +124,13 @@ lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} ->

122lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl

124lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl

123

125

124instance (DecEq a, DecEq b) => DecEq (a, b) where

126instance (DecEq a, DecEq b) => DecEq (a, b) where

125− decEq (a, b) (a', b') with (decEq a a')

127+ decEq (a, b) (a', b') with (decEq a a')

126− decEq (a, b) (a, b') | (Yes refl) with (decEq b b')

128+ decEq (a, b) (a, b') | (Yes refl) with (decEq b b')

127− decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl

129+ decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl

128− decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq)

130+ decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq)

129− decEq (a, b) (a', b') | (No p) with (decEq b b')

131+ decEq (a, b) (a', b') | (No p) with (decEq b b')

130− decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq)

132+ decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq)

131− decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq)

133+ decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq)

132

134

133

135

134--------------------------------------------------------------------------------

136--------------------------------------------------------------------------------

@@ -172,13 +174,23 @@ total

172vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys

174vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys

173vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl

175vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl

174

176

177+instance DecEq a => DecEq (Vect n a) where

178+ decEq [] [] = Yes refl

179+ decEq (x :: xs) (y :: ys) with (decEq x y)

180+ decEq (x :: xs) (x :: ys) | Yes refl with (decEq xs ys)

181+ decEq (x :: xs) (x :: xs) | Yes refl | Yes refl = Yes refl

182+ decEq (x :: xs) (x :: ys) | Yes refl | No neq = No (neq . vectInjective2)

183+ decEq (x :: xs) (y :: ys) | No neq = No (neq . vectInjective1)

184+

185+{- The following definition is elaborated in a wrong case-tree. Examination pending.

186+

175instance DecEq a => DecEq (Vect n a) where

187instance DecEq a => DecEq (Vect n a) where

176 decEq [] [] = Yes refl

188 decEq [] [] = Yes refl

177 decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)

189 decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)

178 decEq (x :: xs) (x :: xs) | (Yes refl, Yes refl) = Yes refl

190 decEq (x :: xs) (x :: xs) | (Yes refl, Yes refl) = Yes refl

179 decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))

191 decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))

180 decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))

192 decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))

181−

193+-}

182

194

183-- For the primitives, we have to cheat because we don't have access to their

195-- For the primitives, we have to cheat because we don't have access to their

184-- internal implementations.

196-- internal implementations.

@@ -188,39 +200,44 @@ instance DecEq a => DecEq (Vect n a) where

188--------------------------------------------------------------------------------

200--------------------------------------------------------------------------------

189

201

190instance DecEq Int where

202instance DecEq Int where

191− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

203+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

192− else No (really_believe_me _|_)

204+ where postulate primitiveEq : x = y

205+ postulate primitiveNotEq : x = y -> _|_

193

206

194--------------------------------------------------------------------------------

207--------------------------------------------------------------------------------

195-- Char

208-- Char

196--------------------------------------------------------------------------------

209--------------------------------------------------------------------------------

197

210

198instance DecEq Char where

211instance DecEq Char where

199− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

212+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

200− else No (really_believe_me _|_)

213+ where postulate primitiveEq : x = y

214+ postulate primitiveNotEq : x = y -> _|_

201

215

202--------------------------------------------------------------------------------

216--------------------------------------------------------------------------------

203-- Integer

217-- Integer

204--------------------------------------------------------------------------------

218--------------------------------------------------------------------------------

205

219

206instance DecEq Integer where

220instance DecEq Integer where

207− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

221+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

208− else No (really_believe_me _|_)

222+ where postulate primitiveEq : x = y

223+ postulate primitiveNotEq : x = y -> _|_

209

224

210--------------------------------------------------------------------------------

225--------------------------------------------------------------------------------

211-- Float

226-- Float

212--------------------------------------------------------------------------------

227--------------------------------------------------------------------------------

213

228

214instance DecEq Float where

229instance DecEq Float where

215− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

230+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

216− else No (really_believe_me _|_)

231+ where postulate primitiveEq : x = y

232+ postulate primitiveNotEq : x = y -> _|_

217

233

218--------------------------------------------------------------------------------

234--------------------------------------------------------------------------------

219-- String

235-- String

220--------------------------------------------------------------------------------

236--------------------------------------------------------------------------------

221

237

222instance DecEq String where

238instance DecEq String where

223− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

239+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

224− else No (really_believe_me _|_)

240+ where postulate primitiveEq : x = y

241+ postulate primitiveNotEq : x = y -> _|_

225

242

226

243

libs/prelude/IO.idr+13−7

@@ -4,8 +4,10 @@ import Prelude.List

4

5%access public

6

7+||| Idris's primitive IO, for building abstractions on top of

7abstract data PrimIO a = prim__IO a

8abstract data PrimIO a = prim__IO a

8

9

10+||| A token representing the world, for use in `IO`

9abstract data World = TheWorld

11abstract data World = TheWorld

10

12

11abstract WorldRes : Type -> Type

13abstract WorldRes : Type -> Type

@@ -26,7 +28,10 @@ abstract

26prim_io_return : a -> PrimIO a

28prim_io_return : a -> PrimIO a

27prim_io_return x = prim__IO x

29prim_io_return x = prim__IO x

28

30

31+||| Descriptions of the various sorts of Ints that Idris supports

29data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2

32data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2

33+

34+||| Types available for foreign function calls

30data FTy = FIntT IntTy

35data FTy = FIntT IntTy

31 | FFunction FTy FTy

36 | FFunction FTy FTy

32 | FFloat

37 | FFloat

@@ -75,6 +80,7 @@ FBits32x4 = FIntT IT32x4

75FBits64x2 : FTy

80FBits64x2 : FTy

76FBits64x2 = FIntT IT64x2

81FBits64x2 = FIntT IT64x2

77

82

83+||| Interpret an FFI type as the type of the Idris function that it will become

78interpFTy : FTy -> Type

84interpFTy : FTy -> Type

79interpFTy (FIntT ITNative) = Int

85interpFTy (FIntT ITNative) = Int

80interpFTy (FIntT ITChar) = Char

86interpFTy (FIntT ITChar) = Char

@@ -95,7 +101,10 @@ interpFTy FUnit = ()

95

101

96interpFTy (FFunction a b) = interpFTy a -> interpFTy b

102interpFTy (FFunction a b) = interpFTy a -> interpFTy b

97

103

104+||| Type signatures for foreign functions

105+||| @ xs the argument types

106+||| @ t the return type

98−ForeignTy : (xs:List FTy) -> (t:FTy) -> Type

107+ForeignTy : (xs : List FTy) -> (t : FTy) -> Type

99ForeignTy Nil rt = World -> PrimIO (interpFTy rt)

108ForeignTy Nil rt = World -> PrimIO (interpFTy rt)

100ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt

109ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt

101

110

@@ -123,16 +132,13 @@ io_return : a -> IO a

123io_return x = MkIO (\w => prim_io_return x)

132io_return x = MkIO (\w => prim_io_return x)

124

133

125liftPrimIO : (World -> PrimIO a) -> IO a

134liftPrimIO : (World -> PrimIO a) -> IO a

126−liftPrimIO f = MkIO (\w => prim_io_bind (f w)

135+liftPrimIO = MkIO

127− (\x => prim_io_return x))

128

136

129run__IO : IO () -> PrimIO ()

137run__IO : IO () -> PrimIO ()

130−run__IO (MkIO f) = prim_io_bind (f TheWorld)

138+run__IO (MkIO f) = f TheWorld

131− (\ b => prim_io_return b)

132

139

133run__provider : IO a -> PrimIO a

140run__provider : IO a -> PrimIO a

134−run__provider (MkIO f) = prim_io_bind (f TheWorld)

141+run__provider (MkIO f) = f TheWorld

135− (\ b => prim_io_return b)

136

142

137-- io_bind v (\v' => io_return v')

143-- io_bind v (\v' => io_return v')

138

144

libs/prelude/Prelude.idr+64−16

@@ -21,6 +21,7 @@ import Prelude.Traversable

21import Prelude.Bits

22import Prelude.Stream

23import Prelude.Uninhabited

24+import Prelude.Pairs

24

25

25import Decidable.Equality

26import Decidable.Equality

26

27

@@ -347,27 +348,38 @@ natRange n = List.reverse (go n)

347 where go Z = []

348 where go Z = []

348 go (S n) = n :: go n

349 go (S n) = n :: go n

349

350

351+-- predefine Nat versions of Enum, so we can use them in the default impls

352+total natEnumFromThen : Nat -> Nat -> Stream Nat

353+natEnumFromThen n inc = n :: natEnumFromThen (inc + n) inc

354+total natEnumFromTo : Nat -> Nat -> List Nat

355+natEnumFromTo n m = map (plus n) (natRange ((S m) - n))

356+total natEnumFromThenTo : Nat -> Nat -> Nat -> List Nat

357+natEnumFromThenTo _ Z _ = []

358+natEnumFromThenTo n inc m = map (plus n . (* inc)) (natRange (S ((m - n) `div` inc)))

359+

350class Enum a where

360class Enum a where

351 total pred : a -> a

361 total pred : a -> a

352 total succ : a -> a

362 total succ : a -> a

363+ succ e = fromNat (S (toNat e))

353 total toNat : a -> Nat

364 total toNat : a -> Nat

354 total fromNat : Nat -> a

365 total fromNat : Nat -> a

355 total enumFrom : a -> Stream a

366 total enumFrom : a -> Stream a

356 enumFrom n = n :: enumFrom (succ n)

367 enumFrom n = n :: enumFrom (succ n)

357 total enumFromThen : a -> a -> Stream a

368 total enumFromThen : a -> a -> Stream a

369+ enumFromThen x y = map fromNat (natEnumFromThen (toNat x) (toNat y))

358 total enumFromTo : a -> a -> List a

370 total enumFromTo : a -> a -> List a

371+ enumFromTo x y = map fromNat (natEnumFromTo (toNat x) (toNat y))

359 total enumFromThenTo : a -> a -> a -> List a

372 total enumFromThenTo : a -> a -> a -> List a

360−

373+ enumFromThenTo x1 x2 y = map fromNat (natEnumFromThenTo (toNat x1) (toNat x2) (toNat y))

361

374

362instance Enum Nat where

375instance Enum Nat where

363− pred = Nat.pred

376+ pred n = Nat.pred n

364− succ = S

377+ succ n = S n

365− toNat = id

378+ toNat x = id x

366− fromNat = id

379+ fromNat x = id x

367− enumFromThen n inc = n :: enumFromThen (fromNat (plus (toNat inc) (toNat n))) inc

380+ enumFromThen x y = natEnumFromThen x y

368− enumFromThenTo _ Z _ = []

381+ enumFromThenTo x y z = natEnumFromThenTo x y z

369− enumFromThenTo n inc m = map (plus n . (* inc)) (natRange (S ((m - n) `div` inc)))

382+ enumFromTo x y = natEnumFromTo x y

370− enumFromTo n m = map (plus n) (natRange ((S m) - n))

371

383

372instance Enum Integer where

384instance Enum Integer where

373 pred n = n - 1

385 pred n = n - 1

@@ -407,14 +419,25 @@ instance Enum Int where

407 go [] = []

419 go [] = []

408 go (x :: xs) = n + (cast x * inc) :: go xs

420 go (x :: xs) = n + (cast x * inc) :: go xs

409

421

422+instance Enum (Fin (S n)) where

423+ pred fZ = fZ

424+ pred (fS n) = weaken n

425+ succ n = case strengthen (fS n) of

426+ Left _ => last

427+ Right k => k

428+ toNat n = cast n

429+ fromNat {n=n} m = case natToFin m (S n) of

430+ Just k => k

431+ Nothing => last

432+

410syntax "[" [start] ".." [end] "]"

433syntax "[" [start] ".." [end] "]"

411 = enumFromTo start end

434 = enumFromTo start end

412syntax "[" [start] "," [next] ".." [end] "]"

435syntax "[" [start] "," [next] ".." [end] "]"

413 = enumFromThenTo start (next - start) end

436 = enumFromThenTo start (next - start) end

414

437

415−syntax "[" [start] "..]"

438+syntax "[" [start] ".." "]"

416 = enumFrom start

439 = enumFrom start

417−syntax "[" [start] "," [next] "..]"

440+syntax "[" [start] "," [next] ".." "]"

418 = enumFromThen start (next - start)

441 = enumFromThen start (next - start)

419

442

420---- More utilities

443---- More utilities

@@ -439,26 +462,32 @@ uniformB64x2 x = prim__mkB64x2 x x

439

462

440---- some basic io

463---- some basic io

441

464

465+||| Output a string to stdout without a trailing newline

442partial

466partial

443putStr : String -> IO ()

467putStr : String -> IO ()

444putStr x = mkForeign (FFun "putStr" [FString] FUnit) x

468putStr x = mkForeign (FFun "putStr" [FString] FUnit) x

445

469

470+||| Output a string to stdout with a trailing newline

446partial

471partial

447putStrLn : String -> IO ()

472putStrLn : String -> IO ()

448putStrLn x = putStr (x ++ "\n")

473putStrLn x = putStr (x ++ "\n")

449

474

475+||| Output something showable to stdout, with a trailing newline

450partial

476partial

451print : Show a => a -> IO ()

477print : Show a => a -> IO ()

452print x = putStrLn (show x)

478print x = putStrLn (show x)

453

479

480+||| Read one line of input from stdin

454partial

481partial

455getLine : IO String

482getLine : IO String

456getLine = prim_fread prim__stdin

483getLine = prim_fread prim__stdin

457

484

485+||| Write a single character to stdout

458partial

486partial

459putChar : Char -> IO ()

487putChar : Char -> IO ()

460putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)

488putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)

461

489

490+||| Read a single character from stdin

462partial

491partial

463getChar : IO Char

492getChar : IO Char

464getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

493getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

@@ -468,21 +497,38 @@ getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

468abstract

497abstract

469data File = FHandle Ptr

498data File = FHandle Ptr

470

499

500+||| Standard input

471partial stdin : File

501partial stdin : File

472stdin = FHandle prim__stdin

502stdin = FHandle prim__stdin

473

503

504+||| Standard output

505+partial stdout : File

506+stdout = FHandle prim__stdout

507+

508+||| Standard output

509+partial stderr : File

510+stderr = FHandle prim__stderr

511+

512+||| Call the RTS's file opening function

474do_fopen : String -> String -> IO Ptr

513do_fopen : String -> String -> IO Ptr

475do_fopen f m

514do_fopen f m

476 = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m

515 = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m

477

516

517+||| Open a file

518+||| @ f the filename

519+||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

478−fopen : String -> String -> IO File

520+fopen : (f : String) -> (m : String) -> IO File

479fopen f m = do h <- do_fopen f m

521fopen f m = do h <- do_fopen f m

480 return (FHandle h)

522 return (FHandle h)

481

523

524+||| Modes for opening files

482data Mode = Read | Write | ReadWrite

525data Mode = Read | Write | ReadWrite

483

526

527+||| Open a file

528+||| @ f the filename

529+||| @ m the mode

484partial

530partial

485−openFile : String -> Mode -> IO File

531+openFile : (f : String) -> (m : Mode) -> IO File

486openFile f m = fopen f (modeStr m) where

532openFile f m = fopen f (modeStr m) where

487 modeStr Read = "r"

533 modeStr Read = "r"

488 modeStr Write = "w"

534 modeStr Write = "w"

@@ -504,9 +550,9 @@ fgetc : File -> IO Char

504fgetc (FHandle h) = return (cast !(mkForeign (FFun "fgetc" [FPtr] FInt) h))

550fgetc (FHandle h) = return (cast !(mkForeign (FFun "fgetc" [FPtr] FInt) h))

505

551

506fgetc' : File -> IO (Maybe Char)

552fgetc' : File -> IO (Maybe Char)

507−fgetc' (FHandle h)

553+fgetc' (FHandle h)

508 = do x <- mkForeign (FFun "fgetc" [FPtr] FInt) h

554 = do x <- mkForeign (FFun "fgetc" [FPtr] FInt) h

509− if (x < 0) then return Nothing

555+ if (x < 0) then return Nothing

510 else return (Just (cast x))

556 else return (Just (cast x))

511

557

512fflush : File -> IO ()

558fflush : File -> IO ()

@@ -567,15 +613,18 @@ nullPtr : Ptr -> IO Bool

567nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

613nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

568 return (ok /= 0)

614 return (ok /= 0)

569

615

616+||| Check if a supposed string was actually a null pointer

570partial

617partial

571nullStr : String -> IO Bool

618nullStr : String -> IO Bool

572nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p

619nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p

573 return (ok /= 0)

620 return (ok /= 0)

574

621

622+||| Pointer equality

575eqPtr : Ptr -> Ptr -> IO Bool

623eqPtr : Ptr -> Ptr -> IO Bool

576eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y

624eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y

577 return (eq /= 0)

625 return (eq /= 0)

578

626

627+||| Check whether a file handle is actually a null pointer

579partial

628partial

580validFile : File -> IO Bool

629validFile : File -> IO Bool

581validFile (FHandle h) = do x <- nullPtr h

630validFile (FHandle h) = do x <- nullPtr h

@@ -602,4 +651,3 @@ readFile fn = do h <- openFile fn Read

602 if not x then do l <- fread h

651 if not x then do l <- fread h

603 readFile' h (contents ++ l)

652 readFile' h (contents ++ l)

604 else return contents

653 else return contents

605−

libs/prelude/Prelude/Algebra.idr+191−176

@@ -13,238 +13,253 @@ infixl 6 <*>

13-- A modest class hierarchy

14--------------------------------------------------------------------------------

15

16−-- Sets equipped with a single binary operation that is associative. Must

16+||| Sets equipped with a single binary operation that is associative. Must

17−-- satisfy the following laws:

17+||| satisfy the following laws:

18+|||

18−-- Associativity of <+>:

19+||| + Associativity of `<+>`:

19−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

20+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

20class Semigroup a where

21class Semigroup a where

21 (<+>) : a -> a -> a

22 (<+>) : a -> a -> a

22

23

23class Semigroup a => VerifiedSemigroup a where

24class Semigroup a => VerifiedSemigroup a where

24− semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r

25+ total semigroupOpIsAssociative : (l, c, r : a) -> l <+> (c <+> r) = (l <+> c) <+> r

25

26

26−-- Sets equipped with a single binary operation that is associative, along with

27+||| Sets equipped with a single binary operation that is associative, along with

27−-- a neutral element for that binary operation. Must satisfy the following

28+||| a neutral element for that binary operation. Must satisfy the following

28−-- laws:

29+||| laws:

30+|||

29−-- Associativity of <+>:

31+||| + Associativity of `<+>`:

30−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

32+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

31−-- Neutral for <+>:

33+||| + Neutral for `<+>`:

32−-- forall a, a <+> neutral == a

34+||| forall a, a <+> neutral == a

33−-- forall a, neutral <+> a == a

35+||| forall a, neutral <+> a == a

34class Semigroup a => Monoid a where

36class Semigroup a => Monoid a where

35 neutral : a

37 neutral : a

36

38

37class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where

39class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where

38− monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l

40+ total monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l

39− monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r

41+ total monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r

40

42

41−-- Sets equipped with a single binary operation that is associative, along with

43+||| Sets equipped with a single binary operation that is associative, along with

42−-- a neutral element for that binary operation and inverses for all elements.

44+||| a neutral element for that binary operation and inverses for all elements.

43−-- Must satisfy the following laws:

45+||| Must satisfy the following laws:

44−-- Associativity of <+>:

46+||| + Associativity of `<+>`:

45−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

47+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

46−-- Neutral for <+>:

48+||| + Neutral for `<+>`:

47−-- forall a, a <+> neutral == a

49+||| forall a, a <+> neutral == a

48−-- forall a, neutral <+> a == a

50+||| forall a, neutral <+> a == a

49−-- Inverse for <+>:

51+||| + Inverse for `<+>`:

50−-- forall a, a <+> inverse a == neutral

52+||| forall a, a <+> inverse a == neutral

51−-- forall a, inverse a <+> a == neutral

53+||| forall a, inverse a <+> a == neutral

52class Monoid a => Group a where

54class Monoid a => Group a where

53 inverse : a -> a

55 inverse : a -> a

54

56

55class (VerifiedMonoid a, Group a) => VerifiedGroup a where

57class (VerifiedMonoid a, Group a) => VerifiedGroup a where

56− groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral

58+ total groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral

57− groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral

59+ total groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral

58

60

59(<->) : Group a => a -> a -> a

61(<->) : Group a => a -> a -> a

60(<->) left right = left <+> (inverse right)

62(<->) left right = left <+> (inverse right)

61

63

62−-- Sets equipped with a single binary operation that is associative and

64+||| Sets equipped with a single binary operation that is associative and

63−-- commutative, along with a neutral element for that binary operation and

65+||| commutative, along with a neutral element for that binary operation and

64−-- inverses for all elements. Must satisfy the following laws:

66+||| inverses for all elements. Must satisfy the following laws:

67+|||

65−-- Associativity of <+>:

68+||| + Associativity of `<+>`:

66−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

69+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

67−-- Commutativity of <+>:

70+||| + Commutativity of `<+>`:

68−-- forall a b, a <+> b == b <+> a

71+||| forall a b, a <+> b == b <+> a

69−-- Neutral for <+>:

72+||| + Neutral for `<+>`:

70−-- forall a, a <+> neutral == a

73+||| forall a, a <+> neutral == a

71−-- forall a, neutral <+> a == a

74+||| forall a, neutral <+> a == a

72−-- Inverse for <+>:

75+||| + Inverse for `<+>`:

73−-- forall a, a <+> inverse a == neutral

76+||| forall a, a <+> inverse a == neutral

74−-- forall a, inverse a <+> a == neutral

77+||| forall a, inverse a <+> a == neutral

75class Group a => AbelianGroup a where { }

78class Group a => AbelianGroup a where { }

76

79

77class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where

80class (VerifiedGroup a, AbelianGroup a) => VerifiedAbelianGroup a where

78− abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l

81+ total abelianGroupOpIsCommutative : (l, r : a) -> l <+> r = r <+> l

79

82

80−-- Sets equipped with two binary operations, one associative and commutative

83+||| Sets equipped with two binary operations, one associative and commutative

81−-- supplied with a neutral element, and the other associative, with

84+||| supplied with a neutral element, and the other associative, with

82−-- distributivity laws relating the two operations. Must satisfy the following

85+||| distributivity laws relating the two operations. Must satisfy the following

83−-- laws:

86+||| laws:

87+|||

84−-- Associativity of <+>:

88+||| + Associativity of `<+>`:

85−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

89+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

86−-- Commutativity of <+>:

90+||| + Commutativity of `<+>`:

87−-- forall a b, a <+> b == b <+> a

91+||| forall a b, a <+> b == b <+> a

88−-- Neutral for <+>:

92+||| + Neutral for `<+>`:

89−-- forall a, a <+> neutral == a

93+||| forall a, a <+> neutral == a

90−-- forall a, neutral <+> a == a

94+||| forall a, neutral <+> a == a

91−-- Inverse for <+>:

95+||| + Inverse for `<+>`:

92−-- forall a, a <+> inverse a == neutral

96+||| forall a, a <+> inverse a == neutral

93−-- forall a, inverse a <+> a == neutral

97+||| forall a, inverse a <+> a == neutral

94−-- Associativity of <*>:

98+||| + Associativity of `<*>`:

95−-- forall a b c, a <*> (b <*> c) == (a <*> b) <*> c

99+||| forall a b c, a <*> (b <*> c) == (a <*> b) <*> c

96−-- Distributivity of <*> and <->:

100+||| + Distributivity of `<*>` and `<->`:

97−-- forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)

101+||| forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)

98−-- forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)

102+||| forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)

99class AbelianGroup a => Ring a where

103class AbelianGroup a => Ring a where

100 (<*>) : a -> a -> a

104 (<*>) : a -> a -> a

101

105

102class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where

106class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where

103− ringOpIsAssociative : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r

107+ total ringOpIsAssociative : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r

104− ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)

108+ total ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)

105− ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (l <*> c)

109+ total ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (c <*> r)

106

110

107−-- Sets equipped with two binary operations, one associative and commutative

111+||| Sets equipped with two binary operations, one associative and commutative

108−-- supplied with a neutral element, and the other associative supplied with a

112+||| supplied with a neutral element, and the other associative supplied with a

109−-- neutral element, with distributivity laws relating the two operations. Must

113+||| neutral element, with distributivity laws relating the two operations. Must

110−-- satisfy the following laws:

114+||| satisfy the following laws:

115+|||

111−-- Associativity of <+>:

116+||| + Associativity of `<+>`:

112−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

117+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

113−-- Commutativity of <+>:

118+||| + Commutativity of `<+>`:

114−-- forall a b, a <+> b == b <+> a

119+||| forall a b, a <+> b == b <+> a

115−-- Neutral for <+>:

120+||| + Neutral for `<+>`:

116−-- forall a, a <+> neutral == a

121+||| forall a, a <+> neutral == a

117−-- forall a, neutral <+> a == a

122+||| forall a, neutral <+> a == a

118−-- Inverse for <+>:

123+||| + Inverse for `<+>`:

119−-- forall a, a <+> inverse a == neutral

124+||| forall a, a <+> inverse a == neutral

120−-- forall a, inverse a <+> a == neutral

125+||| forall a, inverse a <+> a == neutral

121−-- Associativity of <*>:

126+||| + Associativity of `<*>a:

122−-- forall a b c, a <*> (b <*> c) == (a <*> b) <*> c

127+||| forall a b c, a <*> (b <*> c) == (a <*> b) <*> c

123−-- Neutral for <*>:

128+||| + Neutral for `<*>`:

124−-- forall a, a <*> unity == a

129+||| forall a, a <*> unity == a

125−-- forall a, unity <*> a == a

130+||| forall a, unity <*> a == a

126−-- Distributivity of <*> and <->:

131+||| + Distributivity of `<*>` and `<->`:

127−-- forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)

132+||| forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)

128−-- forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)

133+||| forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)

129class Ring a => RingWithUnity a where

134class Ring a => RingWithUnity a where

130 unity : a

135 unity : a

131

136

132class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where

137class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where

133− ringWithUnityIsUnityL : (l : a) -> l <*> unity = l

138+ total ringWithUnityIsUnityL : (l : a) -> l <*> unity = l

134− ringWithUnityIsUnityR : (r : a) -> unity <*> r = r

139+ total ringWithUnityIsUnityR : (r : a) -> unity <*> r = r

135

140

136−-- Sets equipped with a binary operation that is commutative, associative and

141+||| Sets equipped with a binary operation that is commutative, associative and

137−-- idempotent. Must satisfy the following laws:

142+||| idempotent. Must satisfy the following laws:

143+|||

138−-- Associativity of join:

144+||| + Associativity of join:

139−-- forall a b c, join a (join b c) == join (join a b) c

145+||| forall a b c, join a (join b c) == join (join a b) c

140−-- Commutativity of join:

146+||| + Commutativity of join:

141−-- forall a b, join a b == join b a

147+||| forall a b, join a b == join b a

142−-- Idempotency of join:

148+||| + Idempotency of join:

143−-- forall a, join a a == a

149+||| forall a, join a a == a

150+|||

144−-- Join semilattices capture the notion of sets with a "least upper bound".

151+||| Join semilattices capture the notion of sets with a "least upper bound".

145class JoinSemilattice a where

152class JoinSemilattice a where

146 join : a -> a -> a

153 join : a -> a -> a

147

154

148class JoinSemilattice a => VerifiedJoinSemilattice a where

155class JoinSemilattice a => VerifiedJoinSemilattice a where

149− joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r

156+ total joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r

150− joinSemilatticeJoinIsCommutative : (l, r : a) -> join l r = join r l

157+ total joinSemilatticeJoinIsCommutative : (l, r : a) -> join l r = join r l

151− joinSemilatticeJoinIsIdempotent : (e : a) -> join e e = e

158+ total joinSemilatticeJoinIsIdempotent : (e : a) -> join e e = e

152

159

153−-- Sets equipped with a binary operation that is commutative, associative and

160+||| Sets equipped with a binary operation that is commutative, associative and

154−-- idempotent. Must satisfy the following laws:

161+||| idempotent. Must satisfy the following laws:

162+|||

155−-- Associativity of meet:

163+||| + Associativity of meet:

156−-- forall a b c, meet a (meet b c) == meet (meet a b) c

164+||| forall a b c, meet a (meet b c) == meet (meet a b) c

157−-- Commutativity of meet:

165+||| + Commutativity of meet:

158−-- forall a b, meet a b == meet b a

166+||| forall a b, meet a b == meet b a

159−-- Idempotency of meet:

167+||| + Idempotency of meet:

160−-- forall a, meet a a == a

168+||| forall a, meet a a == a

169+|||

161−-- Meet semilattices capture the notion of sets with a "greatest lower bound".

170+||| Meet semilattices capture the notion of sets with a "greatest lower bound".

162class MeetSemilattice a where

171class MeetSemilattice a where

163 meet : a -> a -> a

172 meet : a -> a -> a

164

173

165class MeetSemilattice a => VerifiedMeetSemilattice a where

174class MeetSemilattice a => VerifiedMeetSemilattice a where

166− meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r

175+ total meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r

167− meetSemilatticeMeetIsCommutative : (l, r : a) -> meet l r = meet r l

176+ total meetSemilatticeMeetIsCommutative : (l, r : a) -> meet l r = meet r l

168− meetSemilatticeMeetIsIdempotent : (e : a) -> meet e e = e

177+ total meetSemilatticeMeetIsIdempotent : (e : a) -> meet e e = e

169

178

170−-- Sets equipped with a binary operation that is commutative, associative and

179+||| Sets equipped with a binary operation that is commutative, associative and

171−-- idempotent and supplied with a neutral element. Must satisfy the following

180+||| idempotent and supplied with a neutral element. Must satisfy the following

172−-- laws:

181+||| laws:

182+|||

173−-- Associativity of join:

183+||| + Associativity of join:

174−-- forall a b c, join a (join b c) == join (join a b) c

184+||| forall a b c, join a (join b c) == join (join a b) c

175−-- Commutativity of join:

185+||| + Commutativity of join:

176−-- forall a b, join a b == join b a

186+||| forall a b, join a b == join b a

177−-- Idempotency of join:

187+||| + Idempotency of join:

178−-- forall a, join a a == a

188+||| forall a, join a a == a

179−-- Bottom:

189+||| + Bottom:

180−-- forall a, join a bottom == bottom

190+||| forall a, join a bottom == bottom

191+|||

181−-- Join semilattices capture the notion of sets with a "least upper bound"

192+||| Join semilattices capture the notion of sets with a "least upper bound"

182−-- equipped with a "bottom" element.

193+||| equipped with a "bottom" element.

183class JoinSemilattice a => BoundedJoinSemilattice a where

194class JoinSemilattice a => BoundedJoinSemilattice a where

184 bottom : a

195 bottom : a

185

196

186class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where

197class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where

187− boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom

198+ total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom

188

199

189−-- Sets equipped with a binary operation that is commutative, associative and

200+||| Sets equipped with a binary operation that is commutative, associative and

190−-- idempotent and supplied with a neutral element. Must satisfy the following

201+||| idempotent and supplied with a neutral element. Must satisfy the following

191−-- laws:

202+||| laws:

203+|||

192−-- Associativity of meet:

204+||| + Associativity of meet:

193−-- forall a b c, meet a (meet b c) == meet (meet a b) c

205+||| forall a b c, meet a (meet b c) == meet (meet a b) c

194−-- Commutativity of meet:

206+||| + Commutativity of meet:

195−-- forall a b, meet a b == meet b a

207+||| forall a b, meet a b == meet b a

196−-- Idempotency of meet:

208+||| + Idempotency of meet:

197−-- forall a, meet a a == a

209+||| forall a, meet a a == a

198−-- Top:

210+||| + Top:

199−-- forall a, meet a top == top

211+||| forall a, meet a top == top

212+|||

200−-- Meet semilattices capture the notion of sets with a "greatest lower bound"

213+||| Meet semilattices capture the notion of sets with a "greatest lower bound"

201−-- equipped with a "top" element.

214+||| equipped with a "top" element.

202class MeetSemilattice a => BoundedMeetSemilattice a where

215class MeetSemilattice a => BoundedMeetSemilattice a where

203 top : a

216 top : a

204

217

205class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where

218class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where

206− boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top

219+ total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top

207

220

208−-- Sets equipped with two binary operations that are both commutative,

221+||| Sets equipped with two binary operations that are both commutative,

209−-- associative and idempotent, along with absorbtion laws for relating the two

222+||| associative and idempotent, along with absorbtion laws for relating the two

210−-- binary operations. Must satisfy the following:

223+||| binary operations. Must satisfy the following:

224+|||

211−-- Associativity of meet and join:

225+||| + Associativity of meet and join:

212−-- forall a b c, meet a (meet b c) == meet (meet a b) c

226+||| forall a b c, meet a (meet b c) == meet (meet a b) c

213−-- forall a b c, join a (join b c) == join (join a b) c

227+||| forall a b c, join a (join b c) == join (join a b) c

214−-- Commutativity of meet and join:

228+||| + Commutativity of meet and join:

215−-- forall a b, meet a b == meet b a

229+||| forall a b, meet a b == meet b a

216−-- forall a b, join a b == join b a

230+||| forall a b, join a b == join b a

217−-- Idempotency of meet and join:

231+||| + Idempotency of meet and join:

218−-- forall a, meet a a == a

232+||| forall a, meet a a == a

219−-- forall a, join a a == a

233+||| forall a, join a a == a

220−-- Absorbtion laws for meet and join:

234+||| + Absorbtion laws for meet and join:

221−-- forall a b, meet a (join a b) == a

235+||| forall a b, meet a (join a b) == a

222−-- forall a b, join a (meet a b) == a

236+||| forall a b, join a (meet a b) == a

223class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }

237class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }

224

238

225class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where

239class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where

226− latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l

240+ total latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l

227− latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l

241+ total latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l

228

242

229−-- Sets equipped with two binary operations that are both commutative,

243+||| Sets equipped with two binary operations that are both commutative,

230−-- associative and idempotent and supplied with neutral elements, along with

244+||| associative and idempotent and supplied with neutral elements, along with

231−-- absorbtion laws for relating the two binary operations. Must satisfy the

245+||| absorbtion laws for relating the two binary operations. Must satisfy the

232−-- following:

246+||| following:

247+|||

233−-- Associativity of meet and join:

248+||| + Associativity of meet and join:

234−-- forall a b c, meet a (meet b c) == meet (meet a b) c

249+||| forall a b c, meet a (meet b c) == meet (meet a b) c

235−-- forall a b c, join a (join b c) == join (join a b) c

250+||| forall a b c, join a (join b c) == join (join a b) c

236−-- Commutativity of meet and join:

251+||| + Commutativity of meet and join:

237−-- forall a b, meet a b == meet b a

252+||| forall a b, meet a b == meet b a

238−-- forall a b, join a b == join b a

253+||| forall a b, join a b == join b a

239−-- Idempotency of meet and join:

254+||| + Idempotency of meet and join:

240−-- forall a, meet a a == a

255+||| forall a, meet a a == a

241−-- forall a, join a a == a

256+||| forall a, join a a == a

242−-- Absorbtion laws for meet and join:

257+||| + Absorbtion laws for meet and join:

243−-- forall a b, meet a (join a b) == a

258+||| forall a b, meet a (join a b) == a

244−-- forall a b, join a (meet a b) == a

259+||| forall a b, join a (meet a b) == a

245−-- Neutral for meet and join:

260+||| + Neutral for meet and join:

246−-- forall a, meet a top == top

261+||| forall a, meet a top == top

247−-- forall a, join a bottom == bottom

262+||| forall a, join a bottom == bottom

248class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }

263class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }

249

264

250class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }

265class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }

libs/prelude/Prelude/Applicative.idr+10−2

@@ -1,6 +1,8 @@

1module Prelude.Applicative

2

3import Builtins

4+import Prelude.Basics

5+import Prelude.Classes

4import Prelude.Functor

6import Prelude.Functor

5

7

6---- Applicative functors/Idioms

8---- Applicative functors/Idioms

@@ -19,12 +21,15 @@ infixl 2 $>

19($>) : Applicative f => f a -> f b -> f b

21($>) : Applicative f => f a -> f b -> f b

20a $> b = map (const id) a <$> b

22a $> b = map (const id) a <$> b

21

23

24+||| Lift a function to an applicative

22liftA : Applicative f => (a -> b) -> f a -> f b

25liftA : Applicative f => (a -> b) -> f a -> f b

23liftA f a = pure f <$> a

26liftA f a = pure f <$> a

24

27

28+||| Lift a two-argument function to an applicative

25liftA2 : Applicative f => (a -> b -> c) -> f a -> f b -> f c

29liftA2 : Applicative f => (a -> b -> c) -> f a -> f b -> f c

26liftA2 f a b = (map f a) <$> b

30liftA2 f a b = (map f a) <$> b

27

31

32+||| Lift a three-argument function to an applicative

28liftA3 : Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d

33liftA3 : Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d

29liftA3 f a b c = (map f a) <$> b <$> c

34liftA3 f a b c = (map f a) <$> b <$> c

30

35

@@ -33,8 +38,11 @@ class Applicative f => Alternative (f : Type -> Type) where

33 empty : f a

38 empty : f a

34 (<|>) : f a -> f a -> f a

39 (<|>) : f a -> f a -> f a

35

40

41+||| `guard a` is `pure ()` if `a` is `True` and `empty` if `a` is `False`

36guard : Alternative f => Bool -> f ()

42guard : Alternative f => Bool -> f ()

37guard a = if a then pure () else empty

43guard a = if a then pure () else empty

38

44

45+||| Conditionally execute an applicative expression

39−when : Applicative f => Bool -> f () -> f ()

46+when : Applicative f => Bool -> Lazy (f ()) -> f ()

40−when a f = if a then f else pure ()

47+when True f = Force f

48+when False f = pure ()

libs/prelude/Prelude/Basics.idr+23−12

@@ -3,44 +3,55 @@ module Prelude.Basics

3Not : Type -> Type

4Not a = a -> _|_

5

6−-- | Identity function.

6+||| Identity function.

7id : a -> a

8id x = x

9

10−-- | Manually assign a type to an expression.

10+||| Manually assign a type to an expression.

11+||| @ a the type to assign

12+||| @ x the element to get the type

11−the : (a : Type) -> a -> a

13+the : (a : Type) -> (x : a) -> a

12the _ = id

14the _ = id

13

15

14−-- | Constant function.

16+||| Constant function. Ignores its second argument.

15const : a -> b -> a

17const : a -> b -> a

16const x = \v => x

18const x = \v => x

17

19

18−-- | Return the first element of a pair.

20+||| Return the first element of a pair.

19fst : (s, t) -> s

21fst : (s, t) -> s

20fst (x, y) = x

22fst (x, y) = x

21

23

22−-- | Return the second element of a pair.

24+||| Return the second element of a pair.

23snd : (a, b) -> b

25snd : (a, b) -> b

24snd (x, y) = y

26snd (x, y) = y

25

27

26infixl 9 .

28infixl 9 .

27

29

28−-- | Function composition

30+||| Function composition

29(.) : (b -> c) -> (a -> b) -> a -> c

31(.) : (b -> c) -> (a -> b) -> a -> c

30(.) f g x = f (g x)

32(.) f g x = f (g x)

31

33

32−-- | Takes in the first two arguments in reverse order.

34+||| Takes in the first two arguments in reverse order.

35+||| @ f the function to flip

33−flip : (a -> b -> c) -> b -> a -> c

36+flip : (f : a -> b -> c) -> b -> a -> c

34flip f x y = f y x

37flip f x y = f y x

35

38

36−-- | Function application.

39+||| Function application.

37apply : (a -> b) -> a -> b

40apply : (a -> b) -> a -> b

38apply f a = f a

41apply f a = f a

39

42

43+||| Equality is a congruence.

40cong : {f : t -> u} -> (a = b) -> f a = f b

44cong : {f : t -> u} -> (a = b) -> f a = f b

41cong refl = refl

45cong refl = refl

42

46

47+||| Decidability. A decidable property either holds or is a contradiction.

43data Dec : Type -> Type where

48data Dec : Type -> Type where

49+

50+ ||| The case where the property holds

51+ ||| @ prf the proof

44− Yes : {A : Type} -> A -> Dec A

52+ Yes : {A : Type} -> (prf : A) -> Dec A

53+

54+ ||| The case where the property holding would be a contradiction

55+ ||| @ contra a demonstration that A would be a contradiction

45− No : {A : Type} -> (A -> _|_) -> Dec A

56+ No : {A : Type} -> (contra : A -> _|_) -> Dec A

46

57

libs/prelude/Prelude/Bool.idr+28−10

@@ -1,33 +1,51 @@

1module Prelude.Bool

2

3+import Builtins

4+

5+import Prelude.Uninhabited

6+

3−-- | Boolean Data Type

7+||| Boolean Data Type

4data Bool = False | True

8data Bool = False | True

5

9

6−-- | Boolean elimination

10+||| The underlying implementation of the if ... then ... else ... syntax

11+||| @ b the condition on the if

12+||| @ t the value if b is true

13+||| @ e the falue if b is false

7−boolElim : Bool -> (t : Lazy a) -> (e : Lazy a) -> a

14+boolElim : (b : Bool) -> (t : Lazy a) -> (e : Lazy a) -> a

8boolElim True t e = t

15boolElim True t e = t

9boolElim False t e = e

16boolElim False t e = e

10

17

11−-- | Defines a predicate on Bool which guarantees that the value is true.

18+||| Ensure that some run-time Boolean test has been performed.

19+|||

20+||| This lifts a Boolean predicate to the type level. See the function `choose`

21+||| if you need to perform a Boolean test and convince the type checker of this

22+||| fact.

23+|||

24+||| If you find yourself using `so` for something other than primitive types,

25+||| it may be appropriate to define a type of evidence for the property that you

26+||| care about instead.

12data so : Bool -> Type where oh : so True

27data so : Bool -> Type where oh : so True

13

28

29+instance Uninhabited (so False) where

30+ uninhabited oh impossible

31+

14−-- Syntaxtic sugar for boolean elimination.

32+-- Syntactic sugar for boolean elimination.

15syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)

33syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)

16

34

17-- Boolean Operator Precedence

35-- Boolean Operator Precedence

18infixl 4 &&, ||

36infixl 4 &&, ||

19

37

20−-- | Boolean OR

38+||| Boolean OR only evaluates the second argument if the first is `False`.

21−(||) : Bool -> Bool -> Bool

39+(||) : Bool -> Lazy Bool -> Bool

22(||) False x = x

40(||) False x = x

23(||) True _ = True

41(||) True _ = True

24

42

25−-- | Boolean AND

43+||| Boolean AND only evaluates the second argument if the first is `True`.

26−(&&) : Bool -> Bool -> Bool

44+(&&) : Bool -> Lazy Bool -> Bool

27(&&) True x = x

45(&&) True x = x

28(&&) False _ = False

46(&&) False _ = False

29

47

30−-- | Boolean NOT

48+||| Boolean NOT

31not : Bool -> Bool

49not : Bool -> Bool

32not True = False

50not True = False

33not False = True

51not False = True

libs/prelude/Prelude/Cast.idr+5−3

@@ -1,7 +1,11 @@

1module Prelude.Cast

2

3+||| Type class for transforming a instance of a data type to another type.

3class Cast from to where

4class Cast from to where

5+ ||| Perform a cast operation.

6+ |||

7+ ||| @orig The original type.

4− cast : from -> to

8+ cast : (orig : from) -> to

5

9

6-- String casts

10-- String casts

7

11

@@ -45,5 +49,3 @@ instance Cast Integer String where

45

49

46instance Cast Char Int where

50instance Cast Char Int where

47 cast = prim__charToInt

51 cast = prim__charToInt

48−

49−

libs/prelude/Prelude/Chars.idr+19−16

@@ -1,69 +1,72 @@

1module Prelude.Char

2-- Functions operating over Chars

3

4+import Prelude.Bool

5+import Prelude.Classes

6+import Prelude.List

4import Builtins

7import Builtins

5

8

6−-- | Return the ASCII representation of the character.

9+||| Return the ASCII representation of the character.

7chr : Int -> Char

10chr : Int -> Char

8chr x = prim__intToChar x

11chr x = prim__intToChar x

9

12

10−-- | Convert the number to its ASCII equivalent.

13+||| Convert the number to its ASCII equivalent.

11ord : Char -> Int

14ord : Char -> Int

12ord x = prim__charToInt x

15ord x = prim__charToInt x

13

16

14−-- | Returns true if the character is in the range [A-Z].

17+||| Returns true if the character is in the range [A-Z].

15isUpper : Char -> Bool

18isUpper : Char -> Bool

16isUpper x = x >= 'A' && x <= 'Z'

19isUpper x = x >= 'A' && x <= 'Z'

17

20

18−-- | Returns true if the character is in the range [a-z]

21+||| Returns true if the character is in the range [a-z]

19isLower : Char -> Bool

22isLower : Char -> Bool

20isLower x = x >= 'a' && x <= 'z'

23isLower x = x >= 'a' && x <= 'z'

21

24

22−-- | Returns true if the character is in the ranges [A-Z][a-z].

25+||| Returns true if the character is in the ranges [A-Z][a-z].

23isAlpha : Char -> Bool

26isAlpha : Char -> Bool

24isAlpha x = isUpper x || isLower x

27isAlpha x = isUpper x || isLower x

25

28

26−-- | Returns true if the character is in the range [0-9]

29+||| Returns true if the character is in the range [0-9]

27isDigit : Char -> Bool

30isDigit : Char -> Bool

28isDigit x = (x >= '0' && x <= '9')

31isDigit x = (x >= '0' && x <= '9')

29

32

30−-- | Returns true if the character is in the ranges [A-Z][a-z][0-9]

33+||| Returns true if the character is in the ranges [A-Z][a-z][0-9]

31isAlphaNum : Char -> Bool

34isAlphaNum : Char -> Bool

32isAlphaNum x = isDigit x || isAlpha x

35isAlphaNum x = isDigit x || isAlpha x

33

36

34−-- | Returns true if the character is a whitespace character.

37+||| Returns true if the character is a whitespace character.

35isSpace : Char -> Bool

38isSpace : Char -> Bool

36isSpace x = x == ' ' || x == '\t' || x == '\r' ||

39isSpace x = x == ' ' || x == '\t' || x == '\r' ||

37 x == '\n' || x == '\f' || x == '\v' ||

40 x == '\n' || x == '\f' || x == '\v' ||

38 x == '\xa0'

41 x == '\xa0'

39

42

40−-- | Returns true if the character represents a new line.

43+||| Returns true if the character represents a new line.

41isNL : Char -> Bool

44isNL : Char -> Bool

42isNL x = x == '\r' || x == '\n'

45isNL x = x == '\r' || x == '\n'

43

46

44−-- | Convert a letter to the corresponding upper-case letter, if any.

47+||| Convert a letter to the corresponding upper-case letter, if any.

45−-- Non-letters are ignored.

48+||| Non-letters are ignored.

46toUpper : Char -> Char

49toUpper : Char -> Char

47toUpper x = if (isLower x)

50toUpper x = if (isLower x)

48 then (prim__intToChar (prim__charToInt x - 32))

51 then (prim__intToChar (prim__charToInt x - 32))

49 else x

52 else x

50

53

51−-- | Convert a letter to the corresponding lower-case letter, if any.

54+||| Convert a letter to the corresponding lower-case letter, if any.

52−-- Non-letters are ignored.

55+||| Non-letters are ignored.

53toLower : Char -> Char

56toLower : Char -> Char

54toLower x = if (isUpper x)

57toLower x = if (isUpper x)

55 then (prim__intToChar (prim__charToInt x + 32))

58 then (prim__intToChar (prim__charToInt x + 32))

56 else x

59 else x

57

60

58−-- | Returns true if the character is a hexadecimal digit i.e. in the range [0-9][a-f][A-F]

61+||| Returns true if the character is a hexadecimal digit i.e. in the range [0-9][a-f][A-F]

59isHexDigit : Char -> Bool

62isHexDigit : Char -> Bool

60isHexDigit x = elem (toUpper x) hexChars where

63isHexDigit x = elem (toUpper x) hexChars where

61 hexChars : List Char

64 hexChars : List Char

62 hexChars = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',

65 hexChars = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',

63 'A', 'B', 'C', 'D', 'E', 'F']

66 'A', 'B', 'C', 'D', 'E', 'F']

64

67

65−-- | Returns true if the character is an octal digit.

68+||| Returns true if the character is an octal digit.

66isOctDigit : Char -> Bool

69isOctDigit : Char -> Bool

67isOctDigit x = (x >= '0' && x <= '7')

70isOctDigit x = (x >= '0' && x <= '7')

68

71

69−-- --------------------------------------------------------------------- [ EOF ]

72+

libs/prelude/Prelude/Classes.idr+16−10

@@ -20,7 +20,7 @@ boolOp : (a -> a -> Int) -> a -> a -> Bool

20boolOp op x y = intToBool (op x y)

21

22-- ---------------------------------------------------------- [ Equality Class ]

23−-- | The Eq class defines inequality and equality.

23+||| The Eq class defines inequality and equality.

24class Eq a where

25 (==) : a -> a -> Bool

26 (/=) : a -> a -> Bool

@@ -65,7 +65,7 @@ instance Eq Ordering where

65 GT == GT = True

66 _ == _ = False

67

68−-- | The Ord class defines comparison operations on ordered data types.

68+||| The Ord class defines comparison operations on ordered data types.

69class Eq a => Ord a where

70 compare : a -> a -> Ordering

71

@@ -131,14 +131,14 @@ instance (Ord a, Ord b) => Ord (a, b) where

131 else compare xr yr

132

133-- --------------------------------------------------------- [ Numerical Class ]

134−-- | The Num class defines basic numerical arithmetic.

134+||| The Num class defines basic numerical arithmetic.

135class Num a where

136 (+) : a -> a -> a

137 (-) : a -> a -> a

138 (*) : a -> a -> a

139− -- | Absolute value

139+ ||| Absolute value

140 abs : a -> a

141− -- | Conversion from Integer.

141+ ||| Conversion from Integer.

142 fromInteger : Integer -> a

143

144instance Num Integer where

@@ -244,14 +244,20 @@ instance Ord Bits64 where

244

245-- ------------------------------------------------------------- [ Bounded ]

246

247−class MinBound b where

247+class Ord b => MinBound b where

248− -- | The lower bound for the type

248+ ||| The lower bound for the type

249 minBound : b

250

251−class MaxBound b where

251+class Ord b => MaxBound b where

252− -- | The upper bound for the type

252+ ||| The upper bound for the type

253 maxBound : b

254

255+instance MinBound Bits8 where

256+ minBound = 0x0

257+

258+instance MaxBound Bits8 where

259+ maxBound = 0xff

260+

255instance MinBound Bits16 where

261instance MinBound Bits16 where

256 minBound = 0x0

262 minBound = 0x0

257

263

@@ -273,7 +279,7 @@ instance MaxBound Bits64 where

273

279

274-- ------------------------------------------------------------- [ Fractionals ]

280-- ------------------------------------------------------------- [ Fractionals ]

275

281

276−-- | Fractional division of two Floats.

282+||| Fractional division of two Floats.

277(/) : Float -> Float -> Float

283(/) : Float -> Float -> Float

278(/) = prim__divFloat

284(/) = prim__divFloat

279

285

libs/prelude/Prelude/Either.idr+26−8

@@ -1,22 +1,27 @@

1−module Prelude.Either

1+ module Prelude.Either

2

3import Builtins

4

5import Prelude.Maybe

6import Prelude.List

7

8+||| A sum type

8−data Either a b

9+data Either a b =

10+ ||| One possibility of the sum, conventionally used to represent errors

9− = Left a

11+ Left a |

12+ ||| The other possibility, conventionally used to represent success

10− | Right b

13+ Right b

11

14

12--------------------------------------------------------------------------------

15--------------------------------------------------------------------------------

13-- Syntactic tests

16-- Syntactic tests

14--------------------------------------------------------------------------------

17--------------------------------------------------------------------------------

15

18

19+||| True if the argument is Left, False otherwise

16isLeft : Either a b -> Bool

20isLeft : Either a b -> Bool

17isLeft (Left l) = True

21isLeft (Left l) = True

18isLeft (Right r) = False

22isLeft (Right r) = False

19

23

24+||| True if the argument is Right, False otherwise

20isRight : Either a b -> Bool

25isRight : Either a b -> Bool

21isRight (Left l) = False

26isRight (Left l) = False

22isRight (Right r) = True

27isRight (Right r) = True

@@ -25,14 +30,20 @@ isRight (Right r) = True

25-- Misc.

30-- Misc.

26--------------------------------------------------------------------------------

31--------------------------------------------------------------------------------

27

32

33+||| Perform a case analysis on a Boolean, providing clients with a `so` proof

28choose : (b : Bool) -> Either (so b) (so (not b))

34choose : (b : Bool) -> Either (so b) (so (not b))

29choose True = Left oh

35choose True = Left oh

30choose False = Right oh

36choose False = Right oh

31

37

38+||| Simply-typed eliminator for Either

39+||| @ f the action to take on Left

40+||| @ g the action to take on Right

41+||| @ e the sum to analyze

32−either : (a -> c) -> (b -> c) -> Either a b -> c

42+either : (f : Lazy (a -> c)) -> (g : Lazy (b -> c)) -> (e : Either a b) -> c

33−either l r (Left x) = l x

43+either l r (Left x) = (Force l) x

34−either l r (Right x) = r x

44+either l r (Right x) = (Force r) x

35

45

46+||| Keep the payloads of all Left constructors in a list of Eithers

36lefts : List (Either a b) -> List a

47lefts : List (Either a b) -> List a

37lefts [] = []

48lefts [] = []

38lefts (x::xs) =

49lefts (x::xs) =

@@ -40,6 +51,7 @@ lefts (x::xs) =

40 Left l => l :: lefts xs

51 Left l => l :: lefts xs

41 Right r => lefts xs

52 Right r => lefts xs

42

53

54+||| Keep the payloads of all Right constructors in a list of Eithers

43rights : List (Either a b) -> List b

55rights : List (Either a b) -> List b

44rights [] = []

56rights [] = []

45rights (x::xs) =

57rights (x::xs) =

@@ -47,9 +59,11 @@ rights (x::xs) =

47 Left l => rights xs

59 Left l => rights xs

48 Right r => r :: rights xs

60 Right r => r :: rights xs

49

61

62+||| Split a list of Eithers into a list of the left elements and a list of the right elements

50partitionEithers : List (Either a b) -> (List a, List b)

63partitionEithers : List (Either a b) -> (List a, List b)

51partitionEithers l = (lefts l, rights l)

64partitionEithers l = (lefts l, rights l)

52

65

66+||| Remove a "useless" Either by collapsing the case distinction

53fromEither : Either a a -> a

67fromEither : Either a a -> a

54fromEither (Left l) = l

68fromEither (Left l) = l

55fromEither (Right r) = r

69fromEither (Right r) = r

@@ -58,7 +72,9 @@ fromEither (Right r) = r

58-- Conversions

72-- Conversions

59--------------------------------------------------------------------------------

73--------------------------------------------------------------------------------

60

74

75+||| Convert a Maybe to an Either by using a default value in case of Nothing

76+||| @ e the default value

61−maybeToEither : e -> Maybe a -> Either e a

77+maybeToEither : (def : Lazy e) -> Maybe a -> Either e a

62maybeToEither def (Just j) = Right j

78maybeToEither def (Just j) = Right j

63maybeToEither def Nothing = Left def

79maybeToEither def Nothing = Left def

64

80

@@ -78,10 +94,12 @@ instance (Eq a, Eq b) => Eq (Either a b) where

78-- Injectivity of constructors

94-- Injectivity of constructors

79--------------------------------------------------------------------------------

95--------------------------------------------------------------------------------

80

96

97+||| Left is injective

81total leftInjective : {b : Type} -> {x : a} -> {y : a}

98total leftInjective : {b : Type} -> {x : a} -> {y : a}

82 -> (Left {b = b} x = Left {b = b} y) -> (x = y)

99 -> (Left {b = b} x = Left {b = b} y) -> (x = y)

83leftInjective refl = refl

100leftInjective refl = refl

84

101

102+||| Right is injective

85total rightInjective : {a : Type} -> {x : b} -> {y : b}

103total rightInjective : {a : Type} -> {x : b} -> {y : b}

86 -> (Right {a = a} x = Right {a = a} y) -> (x = y)

104 -> (Right {a = a} x = Right {a = a} y) -> (x = y)

87rightInjective refl = refl

105rightInjective refl = refl

libs/prelude/Prelude/Fin.idr+55−5

@@ -2,13 +2,23 @@ module Prelude.Fin

2

3import Prelude.Nat

4import Prelude.Either

5+import Prelude.Uninhabited

5

6

6%default total

7%default total

7

8

9+||| Numbers strictly less than some bound. The name comes from "finite sets".

10+|||

11+||| It's probably not a good idea to use `Fin` for arithmetic, and they will be

12+||| exceedingly inefficient at run time.

13+||| @ n the upper bound

8−data Fin : Nat -> Type where

14+data Fin : (n : Nat) -> Type where

9 fZ : Fin (S k)

15 fZ : Fin (S k)

10 fS : Fin k -> Fin (S k)

16 fS : Fin k -> Fin (S k)

11

17

18+instance Uninhabited (Fin Z) where

19+ uninhabited fZ impossible

20+ uninhabited (fS f) impossible

21+

12fSInjective : (m : Fin k) -> (n : Fin k) -> fS m = fS n -> m = n

22fSInjective : (m : Fin k) -> (n : Fin k) -> fS m = fS n -> m = n

13fSInjective left _ refl = refl

23fSInjective left _ refl = refl

14

24

@@ -17,16 +27,19 @@ instance Eq (Fin n) where

17 (==) (fS k) (fS k') = k == k'

27 (==) (fS k) (fS k') = k == k'

18 (==) _ _ = False

28 (==) _ _ = False

19

29

30+||| There are no elements of `Fin Z`

20FinZAbsurd : Fin Z -> _|_

31FinZAbsurd : Fin Z -> _|_

21FinZAbsurd fZ impossible

32FinZAbsurd fZ impossible

22

33

23FinZElim : Fin Z -> a

34FinZElim : Fin Z -> a

24FinZElim x = FalseElim (FinZAbsurd x)

35FinZElim x = FalseElim (FinZAbsurd x)

25

36

37+||| Convert a Fin to a Nat

26finToNat : Fin n -> Nat

38finToNat : Fin n -> Nat

27finToNat fZ = Z

39finToNat fZ = Z

28finToNat (fS k) = S (finToNat k)

40finToNat (fS k) = S (finToNat k)

29

41

42+||| `finToNat` is injective

30finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn

43finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn

31finToNatInjective fZ fZ refl = refl

44finToNatInjective fZ fZ refl = refl

32finToNatInjective (fS m) fZ refl impossible

45finToNatInjective (fS m) fZ refl impossible

@@ -37,6 +50,7 @@ finToNatInjective (fS m) (fS n) prf =

37instance Cast (Fin n) Nat where

50instance Cast (Fin n) Nat where

38 cast x = finToNat x

51 cast x = finToNat x

39

52

53+||| Convert a Fin to an Integer

40finToInteger : Fin n -> Integer

54finToInteger : Fin n -> Integer

41finToInteger fZ = 0

55finToInteger fZ = 0

42finToInteger (fS k) = 1 + finToInteger k

56finToInteger (fS k) = 1 + finToInteger k

@@ -44,14 +58,18 @@ finToInteger (fS k) = 1 + finToInteger k

44instance Cast (Fin n) Integer where

58instance Cast (Fin n) Integer where

45 cast x = finToInteger x

59 cast x = finToInteger x

46

60

61+||| Weaken the bound on a Fin by 1

47weaken : Fin n -> Fin (S n)

62weaken : Fin n -> Fin (S n)

48weaken fZ = fZ

63weaken fZ = fZ

49weaken (fS k) = fS (weaken k)

64weaken (fS k) = fS (weaken k)

50

65

66+||| Weaken the bound on a Fin by some amount

51weakenN : (n : Nat) -> Fin m -> Fin (m + n)

67weakenN : (n : Nat) -> Fin m -> Fin (m + n)

52weakenN n fZ = fZ

68weakenN n fZ = fZ

53weakenN n (fS f) = fS (weakenN n f)

69weakenN n (fS f) = fS (weakenN n f)

54

70

71+||| Attempt to tighten the bound on a Fin.

72+||| Return `Left` if the bound could not be tightened, or `Right` if it could.

55strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n)

73strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n)

56strengthen {n = S k} fZ = Right fZ

74strengthen {n = S k} fZ = Right fZ

57strengthen {n = S k} (fS i) with (strengthen i)

75strengthen {n = S k} (fS i) with (strengthen i)

@@ -59,10 +77,14 @@ strengthen {n = S k} (fS i) with (strengthen i)

59 strengthen (fS k) | Right x = Right (fS x)

77 strengthen (fS k) | Right x = Right (fS x)

60strengthen f = Left f

78strengthen f = Left f

61

79

80+||| Add some natural number to a Fin, extending the bound accordingly

81+||| @ n the previous bound

82+||| @ m the number to increase the Fin by

62shift : (m : Nat) -> Fin n -> Fin (m + n)

83shift : (m : Nat) -> Fin n -> Fin (m + n)

63shift Z f = f

84shift Z f = f

64shift {n=n} (S m) f = fS {k = (m + n)} (shift m f)

85shift {n=n} (S m) f = fS {k = (m + n)} (shift m f)

65

86

87+||| The largest element of some Fin type

66last : Fin (S n)

88last : Fin (S n)

67last {n=Z} = fZ

89last {n=Z} = fZ

68last {n=S _} = fS last

90last {n=S _} = fS last

@@ -70,7 +92,12 @@ last {n=S _} = fS last

70total fSinjective : {f : Fin n} -> {f' : Fin n} -> (fS f = fS f') -> f = f'

92total fSinjective : {f : Fin n} -> {f' : Fin n} -> (fS f = fS f') -> f = f'

71fSinjective refl = refl

93fSinjective refl = refl

72

94

73−

95+instance Ord (Fin n) where

96+ compare fZ fZ = EQ

97+ compare fZ (fS _) = LT

98+ compare (fS _) fZ = GT

99+ compare (fS x) (fS y) = compare x y

100+

74instance MinBound (Fin (S n)) where

101instance MinBound (Fin (S n)) where

75 minBound = fZ

102 minBound = fZ

76

103

@@ -78,6 +105,24 @@ instance MaxBound (Fin (S n)) where

78 maxBound = last

105 maxBound = last

79

106

80

107

108+||| Add two Fins, extending the bound

109+(+) : Fin n -> Fin m -> Fin (n + m)

110+(+) {n=S n} {m=m} fZ f' = rewrite plusCommutative n m in weaken (weakenN n f')

111+(+) (fS f) f' = fS (f + f')

112+

113+||| Substract two Fins, keeping the bound of the minuend

114+(-) : Fin n -> Fin m -> Fin n

115+fZ - _ = fZ

116+f - fZ = f

117+(fS f) - (fS f') = weaken $ f - f'

118+

119+||| Multiply two Fins, extending the bound

120+(*) : Fin n -> Fin m -> Fin (n * m)

121+(*) {n=Z} f f' = FinZElim f

122+(*) {m=Z} f f' = FinZElim f'

123+(*) {n=S n} {m=S m} fZ f' = fZ

124+(*) {n=S n} {m=S m} (fS f) f' = f' + (f * f')

125+

81-- Construct a Fin from an integer literal which must fit in the given Fin

126-- Construct a Fin from an integer literal which must fit in the given Fin

82

127

83natToFin : Nat -> (n : Nat) -> Maybe (Fin n)

128natToFin : Nat -> (n : Nat) -> Maybe (Fin n)

@@ -90,12 +135,17 @@ natToFin _ _ = Nothing

90integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)

135integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)

91integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing

136integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing

92

137

138+||| Proof that some `Maybe` is actually `Just`

93data IsJust : Maybe a -> Type where

139data IsJust : Maybe a -> Type where

94− ItIsJust : IsJust {a} (Just x)

140+ ItIsJust : IsJust {a} (Just x)

95

141

142+||| Allow overloading of Integer literals for Fin.

143+||| @ x the Integer that the user typed

144+||| @ prf an automatically-constructed proof that `x` is in bounds

96fromInteger : (x : Integer) ->

145fromInteger : (x : Integer) ->

97− {default ItIsJust

146+ {default ItIsJust

98− prf : (IsJust (integerToFin x n))} -> Fin n

147+ prf : (IsJust (integerToFin x n))} ->

148+ Fin n

99fromInteger {n} x {prf} with (integerToFin x n)

149fromInteger {n} x {prf} with (integerToFin x n)

100 fromInteger {n} x {prf = ItIsJust} | Just y = y

150 fromInteger {n} x {prf = ItIsJust} | Just y = y

101

151

libs/prelude/Prelude/Foldable.idr+27−11

@@ -10,31 +10,47 @@ import Prelude.Algebra

10

11class Foldable (t : Type -> Type) where

12 foldr : (elt -> acc -> acc) -> acc -> t elt -> acc

13+ foldl : Foldable t => (acc -> elt -> acc) -> acc -> t elt -> acc

14+ foldl f z t = foldr (flip (.) . flip f) id t z

13

15

14−foldl : Foldable t => (acc -> elt -> acc) -> acc -> t elt -> acc

16+||| Combine each element of a structure into a monoid

15−foldl f z t = foldr (flip (.) . flip f) id t z

16−

17concat : (Foldable t, Monoid a) => t a -> a

18concat = foldr (<+>) neutral

19

20+||| Combine into a monoid the collective results of applying a function

21+||| to each element of a structure

20concatMap : (Foldable t, Monoid m) => (a -> m) -> t a -> m

22concatMap : (Foldable t, Monoid m) => (a -> m) -> t a -> m

21concatMap f = foldr ((<+>) . f) neutral

23concatMap f = foldr ((<+>) . f) neutral

22

24

25+||| The conjunction of all elements of a structure containing

26+||| lazy boolean values. `and` short-circuits from left to right,

27+||| evaluating until either an element is `False` or no elements remain.

23−and : Foldable t => t Bool -> Bool

28+and : Foldable t => t (Lazy Bool) -> Bool

24−and = foldr (&&) True

29+and = foldl (&&) True

25−

30+

31+||| The disjunction of all elements of a structure containing

32+||| lazy boolean values. `or` short-circuits from left to right, evaluating

33+||| either until an element is `True` or no elements remain.

26−or : Foldable t => t Bool -> Bool

34+or : Foldable t => t (Lazy Bool) -> Bool

27−or = foldr (||) False

35+or = foldl (||) False

28−

36+

37+||| The disjunction of the collective results of applying a

38+||| predicate to all elements of a structure. `any` short-circuits

39+||| from left to right.

29any : Foldable t => (a -> Bool) -> t a -> Bool

40any : Foldable t => (a -> Bool) -> t a -> Bool

30−any p = foldr ((||) . p) False

41+any p = foldl (\x => \y => x || p y) False

31

42

43+||| The disjunction of the collective results of applying a

44+||| predicate to all elements of a structure. `all` short-circuits

45+||| from left to right.

32all : Foldable t => (a -> Bool) -> t a -> Bool

46all : Foldable t => (a -> Bool) -> t a -> Bool

33−all p = foldr ((&&) . p) True

47+all p = foldl (\x => \y => x && p y) True

34

48

49+||| Add together all the elements of a structure

35sum : (Foldable t, Num a) => t a -> a

50sum : (Foldable t, Num a) => t a -> a

36sum = foldr (+) 0

51sum = foldr (+) 0

37

52

53+||| Multiply together all elements of a structure

38product : (Foldable t, Num a) => t a -> a

54product : (Foldable t, Num a) => t a -> a

39product = foldr (*) 1

55product = foldr (*) 1

40

56

libs/prelude/Prelude/Functor.idr+6−1

@@ -1,4 +1,9 @@

1module Prelude.Functor

2

3+||| Functors

4+||| @ f the action of the functor on objects

3class Functor (f : Type -> Type) where

5class Functor (f : Type -> Type) where

6+ ||| The action of the functor on morphisms

7+ ||| @ f the functor

8+ ||| @ m the morphism

4− map : (a -> b) -> f a -> f b

9+ map : (m : a -> b) -> f a -> f b

libs/prelude/Prelude/List.idr+178−42

@@ -12,11 +12,15 @@ import Prelude.Nat

12%access public

13%default total

14

15+infix 5 \\

15infixr 7 ::,++

16infixr 7 ::,++

16

17

18+||| Linked lists

17−%elim data List a

19+%elim data List a =

20+ ||| The empty list

18− = Nil

21+ Nil |

22+ ||| Cons cell

19− | (::) a (List a)

23+ (::) a (List a)

20

24

21-- Name hints for interactive editing

25-- Name hints for interactive editing

22%name List xs, ys, zs, ws

26%name List xs, ys, zs, ws

@@ -25,10 +29,12 @@ infixr 7 ::,++

25-- Syntactic tests

29-- Syntactic tests

26--------------------------------------------------------------------------------

30--------------------------------------------------------------------------------

27

31

32+||| Returns `True` iff the argument is empty

28isNil : List a -> Bool

33isNil : List a -> Bool

29isNil [] = True

34isNil [] = True

30isNil (x::xs) = False

35isNil (x::xs) = False

31

36

37+||| Returns `True` iff the argument is not empty

32isCons : List a -> Bool

38isCons : List a -> Bool

33isCons [] = False

39isCons [] = False

34isCons (x::xs) = True

40isCons (x::xs) = True

@@ -37,6 +43,9 @@ isCons (x::xs) = True

37-- Length

43-- Length

38--------------------------------------------------------------------------------

44--------------------------------------------------------------------------------

39

45

46+||| Compute the length of a list.

47+|||

48+||| Runs in linear time

40length : List a -> Nat

49length : List a -> Nat

41length [] = 0

50length [] = 0

42length (x::xs) = 1 + length xs

51length (x::xs) = 1 + length xs

@@ -45,49 +54,74 @@ length (x::xs) = 1 + length xs

45-- Indexing into lists

54-- Indexing into lists

46--------------------------------------------------------------------------------

55--------------------------------------------------------------------------------

47

56

57+||| Find a particular element of a list.

58+|||

59+||| @ ok a proof that the index is within bounds

48−index : (n : Nat) -> (l : List a) -> (lt n (length l) = True) -> a

60+index : (n : Nat) -> (l : List a) -> (ok : lt n (length l) = True) -> a

49index Z (x::xs) p = x

61index Z (x::xs) p = x

50index (S n) (x::xs) p = index n xs ?indexTailProof

62index (S n) (x::xs) p = index n xs ?indexTailProof

51index _ [] refl impossible

63index _ [] refl impossible

52

64

65+||| Attempt to find a particular element of a list.

66+|||

67+||| If the provided index is out of bounds, return Nothing.

53index' : (n : Nat) -> (l : List a) -> Maybe a

68index' : (n : Nat) -> (l : List a) -> Maybe a

54index' Z (x::xs) = Just x

69index' Z (x::xs) = Just x

55index' (S n) (x::xs) = index' n xs

70index' (S n) (x::xs) = index' n xs

56index' _ [] = Nothing

71index' _ [] = Nothing

57

72

73+||| Get the first element of a non-empty list

74+||| @ ok proof that the list is non-empty

58−head : (l : List a) -> (isCons l = True) -> a

75+head : (l : List a) -> (ok : isCons l = True) -> a

59head [] refl impossible

76head [] refl impossible

60head (x::xs) p = x

77head (x::xs) p = x

61

78

79+||| Attempt to get the first element of a list. If the list is empty, return

80+||| `Nothing`.

62head' : (l : List a) -> Maybe a

81head' : (l : List a) -> Maybe a

63head' [] = Nothing

82head' [] = Nothing

64head' (x::xs) = Just x

83head' (x::xs) = Just x

65

84

85+||| Get the tail of a non-empty list.

86+||| @ ok proof that the list is non-empty

66−tail : (l : List a) -> (isCons l = True) -> List a

87+tail : (l : List a) -> (ok : isCons l = True) -> List a

67tail [] refl impossible

88tail [] refl impossible

68tail (x::xs) p = xs

89tail (x::xs) p = xs

69

90

91+||| Attempt to get the tail of a list.

92+|||

93+||| If the list is empty, return `Nothing`.

70tail' : (l : List a) -> Maybe (List a)

94tail' : (l : List a) -> Maybe (List a)

71tail' [] = Nothing

95tail' [] = Nothing

72tail' (x::xs) = Just xs

96tail' (x::xs) = Just xs

73

97

98+||| Retrieve the last element of a non-empty list.

99+||| @ ok proof that the list is non-empty

74−last : (l : List a) -> (isCons l = True) -> a

100+last : (l : List a) -> (ok : isCons l = True) -> a

75last [] refl impossible

101last [] refl impossible

76last [x] p = x

102last [x] p = x

77last (x::y::ys) p = last (y::ys) refl

103last (x::y::ys) p = last (y::ys) refl

78

104

105+||| Attempt to retrieve the last element of a non-empty list.

106+|||

107+||| If the list is empty, return `Nothing`.

79last' : (l : List a) -> Maybe a

108last' : (l : List a) -> Maybe a

80last' [] = Nothing

109last' [] = Nothing

81−last' (x::xs) =

110+last' (x::xs) =

82 case xs of

111 case xs of

83 [] => Just x

112 [] => Just x

84 y :: ys => last' xs

113 y :: ys => last' xs

85

114

115+||| Return all but the last element of a non-empty list.

116+||| @ ok proof that the list is non-empty

86−init : (l : List a) -> (isCons l = True) -> List a

117+init : (l : List a) -> (ok : isCons l = True) -> List a

87init [] refl impossible

118init [] refl impossible

88init [x] p = []

119init [x] p = []

89init (x::y::ys) p = x :: init (y::ys) refl

120init (x::y::ys) p = x :: init (y::ys) refl

90

121

122+||| Attempt to Return all but the last element of a list.

123+|||

124+||| If the list is empty, return `Nothing`.

91init' : (l : List a) -> Maybe (List a)

125init' : (l : List a) -> Maybe (List a)

92init' [] = Nothing

126init' [] = Nothing

93init' (x::xs) =

127init' (x::xs) =

@@ -103,21 +137,39 @@ init' (x::xs) =

103-- Sublists

137-- Sublists

104--------------------------------------------------------------------------------

138--------------------------------------------------------------------------------

105

139

140+||| Take the first `n` elements of `xs`

141+|||

142+||| If there are not enough elements, return the whole list.

143+||| @ n how many elements to take

144+||| @ xs the list to take them from

106−take : Nat -> List a -> List a

145+take : (n : Nat) -> (xs : List a) -> List a

107take Z xs = []

146take Z xs = []

108take (S n) [] = []

147take (S n) [] = []

109take (S n) (x::xs) = x :: take n xs

148take (S n) (x::xs) = x :: take n xs

110

149

150+||| Drop the first `n` elements of `xs`

151+|||

152+||| If there are not enough elements, return the empty list.

153+||| @ n how many elements to drop

154+||| @ xs the list to drop them from

111−drop : Nat -> List a -> List a

155+drop : (n : Nat) -> (xs : List a) -> List a

112drop Z xs = xs

156drop Z xs = xs

113drop (S n) [] = []

157drop (S n) [] = []

114drop (S n) (x::xs) = drop n xs

158drop (S n) (x::xs) = drop n xs

115

159

160+||| Take the longest prefix of a list such that all elements satsify some

161+||| Boolean predicate.

162+|||

163+||| @ p the predicate

116−takeWhile : (a -> Bool) -> List a -> List a

164+takeWhile : (p : a -> Bool) -> List a -> List a

117takeWhile p [] = []

165takeWhile p [] = []

118takeWhile p (x::xs) = if p x then x :: takeWhile p xs else []

166takeWhile p (x::xs) = if p x then x :: takeWhile p xs else []

119

167

168+||| Remove the longest prefix of a list such that all removed elements satsify some

169+||| Boolean predicate.

170+|||

171+||| @ p the predicate

120−dropWhile : (a -> Bool) -> List a -> List a

172+dropWhile : (p : a -> Bool) -> List a -> List a

121dropWhile p [] = []

173dropWhile p [] = []

122dropWhile p (x::xs) = if p x then dropWhile p xs else x::xs

174dropWhile p (x::xs) = if p x then dropWhile p xs else x::xs

123

175

@@ -125,24 +177,29 @@ dropWhile p (x::xs) = if p x then dropWhile p xs else x::xs

125-- Misc.

177-- Misc.

126--------------------------------------------------------------------------------

178--------------------------------------------------------------------------------

127

179

180+||| Simply-typed recursion operator for lists.

181+|||

182+||| @ nil what to return at the end of the list

183+||| @ cons what to do at each step of recursion

184+||| @ xs the list to recurse over

128−list : a -> (a -> List a -> a) -> List a -> a

185+list : (nil : Lazy b) -> (cons : Lazy (a -> List a -> b)) -> (xs : List a) -> b

129list nil cons [] = nil

186list nil cons [] = nil

130−list nil cons (x::xs) = cons x xs

187+list nil cons (x::xs) = (Force cons) x xs

131

188

132--------------------------------------------------------------------------------

189--------------------------------------------------------------------------------

133-- Building (bigger) lists

190-- Building (bigger) lists

134--------------------------------------------------------------------------------

191--------------------------------------------------------------------------------

135

192

193+||| Append two lists

136(++) : List a -> List a -> List a

194(++) : List a -> List a -> List a

137−(++) [] right = right

195+(++) [] right = right

138(++) (x::xs) right = x :: (xs ++ right)

196(++) (x::xs) right = x :: (xs ++ right)

139

197

140−partial

198+||| Construct a list with `n` copies of `x`

141−repeat : a -> List a

199+||| @ n how many copies

142−repeat x = x :: lazy (repeat x)

200+||| @ x the element to replicate

143−

144−replicate : Nat -> a -> List a

201+replicate : (n : Nat) -> (x : a) -> List a

145−replicate Z x = []

202+replicate Z x = []

146replicate (S n) x = x :: replicate n x

203replicate (S n) x = x :: replicate n x

147

204

148--------------------------------------------------------------------------------

205--------------------------------------------------------------------------------

@@ -187,15 +244,27 @@ instance Functor List where

187-- Zips and unzips

244-- Zips and unzips

188--------------------------------------------------------------------------------

245--------------------------------------------------------------------------------

189

246

247+||| Combine two lists of the same length elementwise using some function.

248+||| @ f the function to combine elements with

249+||| @ l the first list

250+||| @ r the second list

251+||| @ ok a proof that the lengths of the inputs are equal

190zipWith : (f : a -> b -> c) -> (l : List a) -> (r : List b) ->

252zipWith : (f : a -> b -> c) -> (l : List a) -> (r : List b) ->

191− (length l = length r) -> List c

253+ (ok : length l = length r) -> List c

192zipWith f [] (y::ys) refl impossible

254zipWith f [] (y::ys) refl impossible

193zipWith f (x::xs) [] refl impossible

255zipWith f (x::xs) [] refl impossible

194zipWith f [] [] p = []

256zipWith f [] [] p = []

195zipWith f (x::xs) (y::ys) p = f x y :: (zipWith f xs ys ?zipWithTailProof)

257zipWith f (x::xs) (y::ys) p = f x y :: (zipWith f xs ys ?zipWithTailProof)

196

258

259+||| Combine three lists of the same length elementwise using some function.

260+||| @ f the function to combine elements with

261+||| @ x the first list

262+||| @ y the second list

263+||| @ z the third list

264+||| @ ok a proof that the lengths of the first two inputs are equal

265+||| @ ok' a proof that the lengths of the second and third inputs are equal

197zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) ->

266zipWith3 : (f : a -> b -> c -> d) -> (x : List a) -> (y : List b) ->

198− (z : List c) -> (length x = length y) -> (length y = length z) -> List d

267+ (z : List c) -> (ok : length x = length y) -> (ok' : length y = length z) -> List d

199zipWith3 f _ [] (z::zs) p refl impossible

268zipWith3 f _ [] (z::zs) p refl impossible

200zipWith3 f _ (y::ys) [] p refl impossible

269zipWith3 f _ (y::ys) [] p refl impossible

201zipWith3 f [] (y::ys) _ refl q impossible

270zipWith3 f [] (y::ys) _ refl q impossible

@@ -204,18 +273,22 @@ zipWith3 f [] [] [] p q = []

204zipWith3 f (x::xs) (y::ys) (z::zs) p q =

273zipWith3 f (x::xs) (y::ys) (z::zs) p q =

205 f x y z :: (zipWith3 f xs ys zs ?zipWith3TailProof ?zipWith3TailProof')

274 f x y z :: (zipWith3 f xs ys zs ?zipWith3TailProof ?zipWith3TailProof')

206

275

276+||| Combine two lists elementwise into pairs

207zip : (l : List a) -> (r : List b) -> (length l = length r) -> List (a, b)

277zip : (l : List a) -> (r : List b) -> (length l = length r) -> List (a, b)

208zip = zipWith (\x => \y => (x, y))

278zip = zipWith (\x => \y => (x, y))

209

279

280+||| Combine three lists elementwise into tuples

210zip3 : (x : List a) -> (y : List b) -> (z : List c) -> (length x = length y) ->

281zip3 : (x : List a) -> (y : List b) -> (z : List c) -> (length x = length y) ->

211 (length y = length z) -> List (a, b, c)

282 (length y = length z) -> List (a, b, c)

212zip3 = zipWith3 (\x => \y => \z => (x, y, z))

283zip3 = zipWith3 (\x => \y => \z => (x, y, z))

213

284

285+||| Split a list of pairs into two lists

214unzip : List (a, b) -> (List a, List b)

286unzip : List (a, b) -> (List a, List b)

215unzip [] = ([], [])

287unzip [] = ([], [])

216unzip ((l, r)::xs) with (unzip xs)

288unzip ((l, r)::xs) with (unzip xs)

217 | (lefts, rights) = (l::lefts, r::rights)

289 | (lefts, rights) = (l::lefts, r::rights)

218

290

291+||| Split a list of triples into three lists

219unzip3 : List (a, b, c) -> (List a, List b, List c)

292unzip3 : List (a, b, c) -> (List a, List b, List c)

220unzip3 [] = ([], [], [])

293unzip3 [] = ([], [], [])

221unzip3 ((l, c, r)::xs) with (unzip3 xs)

294unzip3 ((l, c, r)::xs) with (unzip3 xs)

@@ -225,6 +298,8 @@ unzip3 ((l, c, r)::xs) with (unzip3 xs)

225-- Maps

298-- Maps

226--------------------------------------------------------------------------------

299--------------------------------------------------------------------------------

227

300

301+||| Apply a partial function to the elements of a list, keeping the ones at which

302+||| it is defined.

228mapMaybe : (a -> Maybe b) -> List a -> List b

303mapMaybe : (a -> Maybe b) -> List a -> List b

229mapMaybe f [] = []

304mapMaybe f [] = []

230mapMaybe f (x::xs) =

305mapMaybe f (x::xs) =

@@ -236,14 +311,19 @@ mapMaybe f (x::xs) =

236-- Folds

311-- Folds

237--------------------------------------------------------------------------------

312--------------------------------------------------------------------------------

238

313

314+||| A tail recursive right fold on Lists.

315+total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> List t -> acc

316+foldrImpl f e go [] = go e

317+foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs

318+

239instance Foldable List where

319instance Foldable List where

240− foldr f e [] = e

320+ foldr f e xs = foldrImpl f e id xs

241− foldr f e (x::xs) = f x (foldr f e xs)

242

321

243--------------------------------------------------------------------------------

322--------------------------------------------------------------------------------

244-- Special folds

323-- Special folds

245--------------------------------------------------------------------------------

324--------------------------------------------------------------------------------

246

325

326+||| Convert any Foldable structure to a list.

247toList : Foldable t => t a -> List a

327toList : Foldable t => t a -> List a

248toList = foldr (::) []

328toList = foldr (::) []

249

329

@@ -251,6 +331,7 @@ toList = foldr (::) []

251-- Transformations

331-- Transformations

252--------------------------------------------------------------------------------

332--------------------------------------------------------------------------------

253

333

334+||| Return the elements of a list in reverse order.

254reverse : List a -> List a

335reverse : List a -> List a

255reverse = reverse' []

336reverse = reverse' []

256 where

337 where

@@ -258,6 +339,7 @@ reverse = reverse' []

258 reverse' acc [] = acc

339 reverse' acc [] = acc

259 reverse' acc (x::xs) = reverse' (x::acc) xs

340 reverse' acc (x::xs) = reverse' (x::acc) xs

260

341

342+||| Insert some separator between the elements of a list.

261intersperse : a -> List a -> List a

343intersperse : a -> List a -> List a

262intersperse sep [] = []

344intersperse sep [] = []

263intersperse sep (x::xs) = x :: intersperse' sep xs

345intersperse sep (x::xs) = x :: intersperse' sep xs

@@ -269,17 +351,17 @@ intersperse sep (x::xs) = x :: intersperse' sep xs

269intercalate : List a -> List (List a) -> List a

351intercalate : List a -> List (List a) -> List a

270intercalate sep l = concat $ intersperse sep l

352intercalate sep l = concat $ intersperse sep l

271

353

272−-- | Transposes rows and columns of a list of lists.

354+||| Transposes rows and columns of a list of lists.

273−--

355+|||

274−-- > transpose [[1, 2], [3, 4]] = [[1, 3], [2, 4]]

356+||| > transpose [[1, 2], [3, 4]] = [[1, 3], [2, 4]]

275−--

357+|||

276−-- This also works for non square scenarios, thus

358+||| This also works for non square scenarios, thus

277−-- involution does not always hold:

359+||| involution does not always hold:

278−--

360+|||

279−-- > transpose [[], [1, 2]] = [[1], [2]]

361+||| > transpose [[], [1, 2]] = [[1], [2]]

280−-- > transpose (transpose [[], [1, 2]]) = [[1, 2]]

362+||| > transpose (transpose [[], [1, 2]]) = [[1, 2]]

281−--

363+|||

282−-- TODO: Solution which satisfies the totality checker?

364+||| TODO: Solution which satisfies the totality checker?

283%assert_total

365%assert_total

284transpose : List (List a) -> List (List a)

366transpose : List (List a) -> List (List a)

285transpose [] = []

367transpose [] = []

@@ -290,6 +372,7 @@ transpose ((x::xs) :: xss) = (x :: (mapMaybe head' xss)) :: (transpose (xs :: (m

290-- Membership tests

372-- Membership tests

291--------------------------------------------------------------------------------

373--------------------------------------------------------------------------------

292

374

375+||| Check if something is a member of a list using a custom comparison.

293elemBy : (a -> a -> Bool) -> a -> List a -> Bool

376elemBy : (a -> a -> Bool) -> a -> List a -> Bool

294elemBy p e [] = False

377elemBy p e [] = False

295elemBy p e (x::xs) =

378elemBy p e (x::xs) =

@@ -298,9 +381,11 @@ elemBy p e (x::xs) =

298 else

381 else

299 elemBy p e xs

382 elemBy p e xs

300

383

384+||| Check if something is a member of a list using the default Boolean equality.

301elem : Eq a => a -> List a -> Bool

385elem : Eq a => a -> List a -> Bool

302elem = elemBy (==)

386elem = elemBy (==)

303

387

388+||| Find associated information in a list using a custom comparison.

304lookupBy : (a -> a -> Bool) -> a -> List (a, b) -> Maybe b

389lookupBy : (a -> a -> Bool) -> a -> List (a, b) -> Maybe b

305lookupBy p e [] = Nothing

390lookupBy p e [] = Nothing

306lookupBy p e (x::xs) =

391lookupBy p e (x::xs) =

@@ -310,9 +395,12 @@ lookupBy p e (x::xs) =

310 else

395 else

311 lookupBy p e xs

396 lookupBy p e xs

312

397

398+||| Find associated information in a list using Boolean equality.

313lookup : Eq a => a -> List (a, b) -> Maybe b

399lookup : Eq a => a -> List (a, b) -> Maybe b

314lookup = lookupBy (==)

400lookup = lookupBy (==)

315

401

402+||| Check if any elements of the first list are found in the second, using

403+||| a custom comparison.

316hasAnyBy : (a -> a -> Bool) -> List a -> List a -> Bool

404hasAnyBy : (a -> a -> Bool) -> List a -> List a -> Bool

317hasAnyBy p elems [] = False

405hasAnyBy p elems [] = False

318hasAnyBy p elems (x::xs) =

406hasAnyBy p elems (x::xs) =

@@ -321,6 +409,8 @@ hasAnyBy p elems (x::xs) =

321 else

409 else

322 hasAnyBy p elems xs

410 hasAnyBy p elems xs

323

411

412+||| Check if any elements of the first list are found in the second, using

413+||| Boolean equality.

324hasAny : Eq a => List a -> List a -> Bool

414hasAny : Eq a => List a -> List a -> Bool

325hasAny = hasAnyBy (==)

415hasAny = hasAnyBy (==)

326

416

@@ -328,6 +418,7 @@ hasAny = hasAnyBy (==)

328-- Searching with a predicate

418-- Searching with a predicate

329--------------------------------------------------------------------------------

419--------------------------------------------------------------------------------

330

420

421+||| Find the first element of a list that satisfies a predicate, or `Nothing` if none do.

331find : (a -> Bool) -> List a -> Maybe a

422find : (a -> Bool) -> List a -> Maybe a

332find p [] = Nothing

423find p [] = Nothing

333find p (x::xs) =

424find p (x::xs) =

@@ -336,6 +427,8 @@ find p (x::xs) =

336 else

427 else

337 find p xs

428 find p xs

338

429

430+||| Find the index of the first element of a list that satisfies a predicate, or

431+||| `Nothing` if none do.

339findIndex : (a -> Bool) -> List a -> Maybe Nat

432findIndex : (a -> Bool) -> List a -> Maybe Nat

340findIndex = findIndex' Z

433findIndex = findIndex' Z

341 where

434 where

@@ -347,6 +440,7 @@ findIndex = findIndex' Z

347 else

440 else

348 findIndex' (S cnt) p xs

441 findIndex' (S cnt) p xs

349

442

443+||| Find the indices of all elements that satisfy some predicate.

350findIndices : (a -> Bool) -> List a -> List Nat

444findIndices : (a -> Bool) -> List a -> List Nat

351findIndices = findIndices' Z

445findIndices = findIndices' Z

352 where

446 where

@@ -396,10 +490,28 @@ nubBy = nubBy' []

396nub : Eq a => List a -> List a

490nub : Eq a => List a -> List a

397nub = nubBy (==)

491nub = nubBy (==)

398

492

493+deleteBy : (a -> a -> Bool) -> a -> List a -> List a

494+deleteBy _ _ [] = []

495+deleteBy eq x (y::ys) = if x `eq` y then ys else y :: deleteBy eq x ys

496+

497+delete : (Eq a) => a -> List a -> List a

498+delete = deleteBy (==)

499+

500+(\\) : (Eq a) => List a -> List a -> List a

501+(\\) = foldl (flip delete)

502+

503+unionBy : (a -> a -> Bool) -> List a -> List a -> List a

504+unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs

505+

506+union : (Eq a) => List a -> List a -> List a

507+union = unionBy (==)

508+

399--------------------------------------------------------------------------------

509--------------------------------------------------------------------------------

400-- Splitting and breaking lists

510-- Splitting and breaking lists

401--------------------------------------------------------------------------------

511--------------------------------------------------------------------------------

402

512

513+||| Given a list and a predicate, returns a pair consisting of the longest

514+||| prefix of the list that satisfies a predicate and the rest of the list.

403span : (a -> Bool) -> List a -> (List a, List a)

515span : (a -> Bool) -> List a -> (List a, List a)

404span p [] = ([], [])

516span p [] = ([], [])

405span p (x::xs) =

517span p (x::xs) =

@@ -413,12 +525,19 @@ break : (a -> Bool) -> List a -> (List a, List a)

413break p = span (not . p)

525break p = span (not . p)

414

526

415split : (a -> Bool) -> List a -> List (List a)

527split : (a -> Bool) -> List a -> List (List a)

416−split p [] = []

417split p xs =

528split p xs =

418 case break p xs of

529 case break p xs of

419 (chunk, []) => [chunk]

530 (chunk, []) => [chunk]

420 (chunk, (c :: rest)) => chunk :: split p (assert_smaller xs rest)

531 (chunk, (c :: rest)) => chunk :: split p (assert_smaller xs rest)

421

532

533+||| A tuple where the first element is a List of the n first elements and

534+||| the second element is a List of the remaining elements of the list

535+||| It is equivalent to (take n xs, drop n xs)

536+||| @ n the index to split at

537+||| @ xs the list to split in two

538+splitAt : (n : Nat) -> (xs : List a) -> (List a, List a)

539+splitAt n xs = (take n xs, drop n xs)

540+

422partition : (a -> Bool) -> List a -> (List a, List a)

541partition : (a -> Bool) -> List a -> (List a, List a)

423partition p [] = ([], [])

542partition p [] = ([], [])

424partition p (x::xs) =

543partition p (x::xs) =

@@ -428,6 +547,16 @@ partition p (x::xs) =

428 else

547 else

429 (lefts, x::rights)

548 (lefts, x::rights)

430

549

550+inits : List a -> List (List a)

551+inits xs = [] :: case xs of

552+ [] => []

553+ x :: xs' => map (x ::) (inits xs')

554+

555+tails : List a -> List (List a)

556+tails xs = xs :: case xs of

557+ [] => []

558+ _ :: xs' => tails xs'

559+

431--------------------------------------------------------------------------------

560--------------------------------------------------------------------------------

432-- Predicates

561-- Predicates

433--------------------------------------------------------------------------------

562--------------------------------------------------------------------------------

@@ -490,6 +619,7 @@ sort xs = let (x, y) = split xs in

490-- Conversions

619-- Conversions

491--------------------------------------------------------------------------------

620--------------------------------------------------------------------------------

492

621

622+||| Either return the head of a list, or `Nothing` if it is empty.

493listToMaybe : List a -> Maybe a

623listToMaybe : List a -> Maybe a

494listToMaybe [] = Nothing

624listToMaybe [] = Nothing

495listToMaybe (x::xs) = Just x

625listToMaybe (x::xs) = Just x

@@ -509,7 +639,7 @@ catMaybes (x::xs) =

509-- Properties

639-- Properties

510--------------------------------------------------------------------------------

640--------------------------------------------------------------------------------

511

641

512−-- append

642+||| The empty list is a right identity for append.

513appendNilRightNeutral : (l : List a) ->

643appendNilRightNeutral : (l : List a) ->

514 l ++ [] = l

644 l ++ [] = l

515appendNilRightNeutral [] = refl

645appendNilRightNeutral [] = refl

@@ -517,6 +647,7 @@ appendNilRightNeutral (x::xs) =

517 let inductiveHypothesis = appendNilRightNeutral xs in

647 let inductiveHypothesis = appendNilRightNeutral xs in

518 ?appendNilRightNeutralStepCase

648 ?appendNilRightNeutralStepCase

519

649

650+||| Appending lists is associative.

520appendAssociative : (l : List a) -> (c : List a) -> (r : List a) ->

651appendAssociative : (l : List a) -> (c : List a) -> (r : List a) ->

521 l ++ (c ++ r) = (l ++ c) ++ r

652 l ++ (c ++ r) = (l ++ c) ++ r

522appendAssociative [] c r = refl

653appendAssociative [] c r = refl

@@ -524,7 +655,8 @@ appendAssociative (x::xs) c r =

524 let inductiveHypothesis = appendAssociative xs c r in

655 let inductiveHypothesis = appendAssociative xs c r in

525 ?appendAssociativeStepCase

656 ?appendAssociativeStepCase

526

657

527−-- length

658+||| The length of two lists that are appended is the sum of the lengths

659+||| of the input lists.

528lengthAppend : (left : List a) -> (right : List a) ->

660lengthAppend : (left : List a) -> (right : List a) ->

529 length (left ++ right) = length left + length right

661 length (left ++ right) = length left + length right

530lengthAppend [] right = refl

662lengthAppend [] right = refl

@@ -532,7 +664,7 @@ lengthAppend (x::xs) right =

532 let inductiveHypothesis = lengthAppend xs right in

664 let inductiveHypothesis = lengthAppend xs right in

533 ?lengthAppendStepCase

665 ?lengthAppendStepCase

534

666

535−-- map

667+||| Mapping a function over a list doesn't change its length.

536mapPreservesLength : (f : a -> b) -> (l : List a) ->

668mapPreservesLength : (f : a -> b) -> (l : List a) ->

537 length (map f l) = length l

669 length (map f l) = length l

538mapPreservesLength f [] = refl

670mapPreservesLength f [] = refl

@@ -540,6 +672,8 @@ mapPreservesLength f (x::xs) =

540 let inductiveHypothesis = mapPreservesLength f xs in

672 let inductiveHypothesis = mapPreservesLength f xs in

541 ?mapPreservesLengthStepCase

673 ?mapPreservesLengthStepCase

542

674

675+||| Mapping a function over two lists and appending them is equivalent

676+||| to appending them and then mapping the function.

543mapDistributesOverAppend : (f : a -> b) -> (l : List a) -> (r : List a) ->

677mapDistributesOverAppend : (f : a -> b) -> (l : List a) -> (r : List a) ->

544 map f (l ++ r) = map f l ++ map f r

678 map f (l ++ r) = map f l ++ map f r

545mapDistributesOverAppend f [] r = refl

679mapDistributesOverAppend f [] r = refl

@@ -547,6 +681,7 @@ mapDistributesOverAppend f (x::xs) r =

547 let inductiveHypothesis = mapDistributesOverAppend f xs r in

681 let inductiveHypothesis = mapDistributesOverAppend f xs r in

548 ?mapDistributesOverAppendStepCase

682 ?mapDistributesOverAppendStepCase

549

683

684+||| Mapping two functions is the same as mapping their composition.

550mapFusion : (f : b -> c) -> (g : a -> b) -> (l : List a) ->

685mapFusion : (f : b -> c) -> (g : a -> b) -> (l : List a) ->

551 map f (map g l) = map (f . g) l

686 map f (map g l) = map (f . g) l

552mapFusion f g [] = refl

687mapFusion f g [] = refl

@@ -554,7 +689,7 @@ mapFusion f g (x::xs) =

554 let inductiveHypothesis = mapFusion f g xs in

689 let inductiveHypothesis = mapFusion f g xs in

555 ?mapFusionStepCase

690 ?mapFusionStepCase

556

691

557−-- hasAny

692+||| No list contains an element of the empty list by any predicate.

558hasAnyByNilFalse : (p : a -> a -> Bool) -> (l : List a) ->

693hasAnyByNilFalse : (p : a -> a -> Bool) -> (l : List a) ->

559 hasAnyBy p [] l = False

694 hasAnyBy p [] l = False

560hasAnyByNilFalse p [] = refl

695hasAnyByNilFalse p [] = refl

@@ -562,6 +697,7 @@ hasAnyByNilFalse p (x::xs) =

562 let inductiveHypothesis = hasAnyByNilFalse p xs in

697 let inductiveHypothesis = hasAnyByNilFalse p xs in

563 ?hasAnyByNilFalseStepCase

698 ?hasAnyByNilFalseStepCase

564

699

700+||| No list contains an element of the empty list.

565hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False

701hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False

566hasAnyNilFalse l = ?hasAnyNilFalseBody

702hasAnyNilFalse l = ?hasAnyNilFalseBody

567

703

libs/prelude/Prelude/Maybe.idr+10−3

@@ -28,25 +28,32 @@ isJust (Just j) = True

28-- Misc

29--------------------------------------------------------------------------------

30

31−maybe : Lazy b -> (a -> b) -> Maybe a -> b

31+maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b

32maybe n j Nothing = n

33−maybe n j (Just x) = j x

33+maybe n j (Just x) = (Force j) x

34

35+||| Convert a `Maybe a` value to an `a` value by providing a default `a` value

36+||| in the case that the `Maybe` value is `Nothing`.

35fromMaybe : (Lazy a) -> Maybe a -> a

37fromMaybe : (Lazy a) -> Maybe a -> a

36fromMaybe def Nothing = def

38fromMaybe def Nothing = def

37fromMaybe def (Just j) = j

39fromMaybe def (Just j) = j

38

40

41+||| Returns `Just` the given value if the conditional is `True`

42+||| and `Nothing` if the conditional is `False`.

39−toMaybe : Bool -> a -> Maybe a

43+toMaybe : Bool -> Lazy a -> Maybe a

40toMaybe True j = Just j

44toMaybe True j = Just j

41toMaybe False j = Nothing

45toMaybe False j = Nothing

42

46

43justInjective : {x : t} -> {y : t} -> (Just x = Just y) -> x = y

47justInjective : {x : t} -> {y : t} -> (Just x = Just y) -> x = y

44justInjective refl = refl

48justInjective refl = refl

45

49

50+||| Convert a `Maybe a` value to an `a` value, using `neutral` in the case

51+||| that the `Maybe` value is `Nothing`.

46lowerMaybe : Monoid a => Maybe a -> a

52lowerMaybe : Monoid a => Maybe a -> a

47lowerMaybe Nothing = neutral

53lowerMaybe Nothing = neutral

48lowerMaybe (Just x) = x

54lowerMaybe (Just x) = x

49

55

56+||| Returns `Nothing` when applied to `neutral`, and `Just` the value otherwise.

50raiseToMaybe : (Monoid a, Eq a) => a -> Maybe a

57raiseToMaybe : (Monoid a, Eq a) => a -> Maybe a

51raiseToMaybe x = if x == neutral then Nothing else Just x

58raiseToMaybe x = if x == neutral then Nothing else Just x

52

59

libs/prelude/Prelude/Monad.idr+4−1

@@ -13,8 +13,11 @@ infixl 5 >>=

13class Applicative m => Monad (m : Type -> Type) where

14 (>>=) : m a -> (a -> m b) -> m b

15

16+||| Also called `join` or mu

16flatten : Monad m => m (m a) -> m a

17flatten : Monad m => m (m a) -> m a

17flatten a = a >>= id

18flatten a = a >>= id

18

19

20+||| For compatibility with Haskell. Note that monads are **not** free to

21+||| define `return` and `pure` differently!

19return : Monad m => a -> m a

22return : Monad m => a -> m a

20−return = pure

23+return = pure

libs/prelude/Prelude/Nat.idr+42−5

@@ -6,17 +6,24 @@ import Prelude.Algebra

6import Prelude.Bool

7import Prelude.Cast

8import Prelude.Classes

9+import Prelude.Uninhabited

9

10

10%access public

11%access public

11%default total

12%default total

12

13

14+||| Unary natural numbers

13−%elim data Nat

15+%elim data Nat =

16+ ||| Zero

14− = Z

17+ Z |

18+ ||| Successor

15− | S Nat

19+ S Nat

16

20

17-- name hints for interactive editing

21-- name hints for interactive editing

18%name Nat k,j,i,n,m

22%name Nat k,j,i,n,m

19

23

24+instance Uninhabited (Z = S n) where

25+ uninhabited refl impossible

26+

20--------------------------------------------------------------------------------

27--------------------------------------------------------------------------------

21-- Syntactic tests

28-- Syntactic tests

22--------------------------------------------------------------------------------

29--------------------------------------------------------------------------------

@@ -33,14 +40,19 @@ isSucc (S n) = True

33-- Basic arithmetic functions

40-- Basic arithmetic functions

34--------------------------------------------------------------------------------

41--------------------------------------------------------------------------------

35

42

43+||| Add two natural numbers.

44+||| @ n the number to case-split on

45+||| @ m the other number

36−total plus : Nat -> Nat -> Nat

46+total plus : (n, m : Nat) -> Nat

37plus Z right = right

47plus Z right = right

38plus (S left) right = S (plus left right)

48plus (S left) right = S (plus left right)

39

49

50+||| Multiply natural numbers

40total mult : Nat -> Nat -> Nat

51total mult : Nat -> Nat -> Nat

41mult Z right = Z

52mult Z right = Z

42mult (S left) right = plus right $ mult left right

53mult (S left) right = plus right $ mult left right

43

54

55+||| Convert an Integer to a Nat, mapping negative numbers to 0

44fromIntegerNat : Integer -> Nat

56fromIntegerNat : Integer -> Nat

45fromIntegerNat 0 = Z

57fromIntegerNat 0 = Z

46fromIntegerNat n =

58fromIntegerNat n =

@@ -49,15 +61,18 @@ fromIntegerNat n =

49 else

61 else

50 Z

62 Z

51

63

64+||| Convert a Nat to an Integer

52toIntegerNat : Nat -> Integer

65toIntegerNat : Nat -> Integer

53toIntegerNat Z = 0

66toIntegerNat Z = 0

54toIntegerNat (S k) = 1 + toIntegerNat k

67toIntegerNat (S k) = 1 + toIntegerNat k

55

68

69+||| Subtract natural numbers. If the second number is larger than the first, return 0.

56total minus : Nat -> Nat -> Nat

70total minus : Nat -> Nat -> Nat

57minus Z right = Z

71minus Z right = Z

58minus left Z = left

72minus left Z = left

59minus (S left) (S right) = minus left right

73minus (S left) (S right) = minus left right

60

74

75+||| Exponentiation of natural numbers

61total power : Nat -> Nat -> Nat

76total power : Nat -> Nat -> Nat

62power base Z = S Z

77power base Z = S Z

63power base (S exp) = mult base $ power base exp

78power base (S exp) = mult base $ power base exp

@@ -74,33 +89,46 @@ hyper (S pn) a (S pb) = hyper pn a (hyper (S pn) a pb)

74-- Comparisons

89-- Comparisons

75--------------------------------------------------------------------------------

90--------------------------------------------------------------------------------

76

91

92+||| Proofs that `n` is less than or equal to `m`

93+||| @ n the smaller number

94+||| @ m the larger number

77−data LTE : Nat -> Nat -> Type where

95+data LTE : (n, m : Nat) -> Type where

96+ ||| Zero is the smallest Nat

78 lteZero : LTE Z right

97 lteZero : LTE Z right

98+ ||| If n <= m, then n + 1 <= m + 1

79 lteSucc : LTE left right -> LTE (S left) (S right)

99 lteSucc : LTE left right -> LTE (S left) (S right)

80

100

101+||| Greater than or equal to

81total GTE : Nat -> Nat -> Type

102total GTE : Nat -> Nat -> Type

82GTE left right = LTE right left

103GTE left right = LTE right left

83

104

105+||| Strict less than

84total LT : Nat -> Nat -> Type

106total LT : Nat -> Nat -> Type

85LT left right = LTE (S left) right

107LT left right = LTE (S left) right

86

108

109+||| Strict greater than

87total GT : Nat -> Nat -> Type

110total GT : Nat -> Nat -> Type

88GT left right = LT right left

111GT left right = LT right left

89

112

113+||| Boolean test than one Nat is less than or equal to another

90total lte : Nat -> Nat -> Bool

114total lte : Nat -> Nat -> Bool

91lte Z right = True

115lte Z right = True

92lte left Z = False

116lte left Z = False

93lte (S left) (S right) = lte left right

117lte (S left) (S right) = lte left right

94

118

119+||| Boolean test than one Nat is greater than or equal to another

95total gte : Nat -> Nat -> Bool

120total gte : Nat -> Nat -> Bool

96gte left right = lte right left

121gte left right = lte right left

97

122

123+||| Boolean test than one Nat is strictly less than another

98total lt : Nat -> Nat -> Bool

124total lt : Nat -> Nat -> Bool

99lt left right = lte (S left) right

125lt left right = lte (S left) right

100

126

127+||| Boolean test than one Nat is strictly greater than another

101total gt : Nat -> Nat -> Bool

128total gt : Nat -> Nat -> Bool

102gt left right = lt right left

129gt left right = lt right left

103

130

131+||| Find the least of two natural numbers

104total minimum : Nat -> Nat -> Nat

132total minimum : Nat -> Nat -> Nat

105minimum left right =

133minimum left right =

106 if lte left right then

134 if lte left right then

@@ -108,6 +136,7 @@ minimum left right =

108 else

136 else

109 right

137 right

110

138

139+||| Find the greatest of two natural numbers

111total maximum : Nat -> Nat -> Nat

140total maximum : Nat -> Nat -> Nat

112maximum left right =

141maximum left right =

113 if lte left right then

142 if lte left right then

@@ -148,9 +177,11 @@ instance MinBound Nat where

148instance Cast Integer Nat where

177instance Cast Integer Nat where

149 cast = fromInteger

178 cast = fromInteger

150

179

180+||| A wrapper for Nat that specifies the semigroup and monad instances that use (+)

151record Multiplicative : Type where

181record Multiplicative : Type where

152 getMultiplicative : Nat -> Multiplicative

182 getMultiplicative : Nat -> Multiplicative

153

183

184+||| A wrapper for Nat that specifies the semigroup and monad instances that use (*)

154record Additive : Type where

185record Additive : Type where

155 getAdditive : Nat -> Additive

186 getAdditive : Nat -> Additive

156

187

@@ -210,6 +241,7 @@ instance Cast Nat Int where

210-- Auxilliary notions

241-- Auxilliary notions

211--------------------------------------------------------------------------------

242--------------------------------------------------------------------------------

212

243

244+||| The predecessor of a natural number. `pred Z` is `Z`.

213total pred : Nat -> Nat

245total pred : Nat -> Nat

214pred Z = Z

246pred Z = Z

215pred (S n) = n

247pred (S n) = n

@@ -218,11 +250,13 @@ pred (S n) = n

218-- Fibonacci and factorial

250-- Fibonacci and factorial

219--------------------------------------------------------------------------------

251--------------------------------------------------------------------------------

220

252

253+||| Fibonacci numbers

221total fib : Nat -> Nat

254total fib : Nat -> Nat

222fib Z = Z

255fib Z = Z

223fib (S Z) = S Z

256fib (S Z) = S Z

224fib (S (S n)) = fib (S n) + fib n

257fib (S (S n)) = fib (S n) + fib n

225

258

259+||| Factorial function

226total fact : Nat -> Nat

260total fact : Nat -> Nat

227fact Z = S Z

261fact Z = S Z

228fact (S n) = (S n) * fact n

262fact (S n) = (S n) * fact n

@@ -283,10 +317,13 @@ lcm x y = divNat (x * y) (gcd x y)

283--------------------------------------------------------------------------------

317--------------------------------------------------------------------------------

284

318

285-- Succ

319-- Succ

320+

321+||| S preserves equality

286total eqSucc : (left : Nat) -> (right : Nat) -> (p : left = right) ->

322total eqSucc : (left : Nat) -> (right : Nat) -> (p : left = right) ->

287 S left = S right

323 S left = S right

288eqSucc left _ refl = refl

324eqSucc left _ refl = refl

289

325

326+||| S is injective

290total succInjective : (left : Nat) -> (right : Nat) -> (p : S left = S right) ->

327total succInjective : (left : Nat) -> (right : Nat) -> (p : S left = S right) ->

291 left = right

328 left = right

292succInjective left _ refl = refl

329succInjective left _ refl = refl

libs/prelude/Prelude/Pairs.idrnew file+42

@@ -0,0 +1,42 @@

1+module Prelude.Pairs

2+

3+import Builtins

4+

5+%access public

6+%default total

7+

8+using (a : Type, P : a -> Type)

9+

10+ ||| Dependent pair where the first field is erased.

11+ data Exists : (P : a -> Type) -> Type where

12+ evidence : .(x : a) -> (pf : P x) -> Exists P

13+

14+ ||| Dependent pair where the second field is erased.

15+ data Subset : (a : Type) -> (P : a -> Type) -> Type where

16+ element : (x : a) -> .(pf : P x) -> Subset a P

17+

18+ -- Monomorphic projections

19+

20+ namespace Exists

21+ getWitness : Exists {a} P -> a

22+ getWitness (evidence x pf) = x

23+

24+ getProof : (x : Exists {a} P) -> P (getWitness x)

25+ getProof (evidence x pf) = pf

26+

27+ namespace Subset

28+ getWitness : Subset a P -> a

29+ getWitness (element x pf) = x

30+

31+ getProof : (x : Subset a P) -> P (getWitness x)

32+ getProof (element x pf) = pf

33+

34+ namespace Sigma

35+ getWitness : Sigma a P -> a

36+ getWitness (x ** pf) = x

37+

38+ getProof : (x : Sigma a P) -> P (getWitness x)

39+ getProof (x ** pf) = pf

40+

41+ -- Polymorphic (class-based) projections have been removed

42+ -- because type-directed name disambiguation works better.

libs/prelude/Prelude/Stream.idr+52−5

@@ -6,47 +6,94 @@ import Prelude.Vect

6%access public

7%default total

8

9+||| An infinite stream

9codata Stream : Type -> Type where

10codata Stream : Type -> Type where

10 (::) : a -> Stream a -> Stream a

11 (::) : a -> Stream a -> Stream a

11

12

13+-- Hints for interactive editing

14+%name Stream xs,ys,zs,ws

15+

12instance Functor Stream where

16instance Functor Stream where

13 map f (x::xs) = f x :: map f xs

17 map f (x::xs) = f x :: map f xs

14

18

19+||| The first element of an infinite stream

15head : Stream a -> a

20head : Stream a -> a

16head (x::xs) = x

21head (x::xs) = x

17

22

23+||| All but the first element

18tail : Stream a -> Stream a

24tail : Stream a -> Stream a

19tail (x::xs) = xs

25tail (x::xs) = xs

20

26

27+||| Take precisely n elements from the stream

28+||| @ n how many elements to take

29+||| @ xs the stream

21−take : (n : Nat) -> Stream a -> Vect n a

30+take : (n : Nat) -> (xs : Stream a) -> Vect n a

22take Z _ = []

31take Z _ = []

23take (S n) (x :: xs) = x :: (take n xs)

32take (S n) (x :: xs) = x :: (take n xs)

24

33

34+||| Drop the first n elements from the stream

35+||| @ n how many elements to drop

25%assert_total

36%assert_total

26−drop : Nat -> Stream a -> Stream a

37+drop : (n : Nat) -> Stream a -> Stream a

27−drop Z xs = xs

38+drop Z xs = xs

28drop (S k) (x::xs) = drop k xs

39drop (S k) (x::xs) = drop k xs

29

40

41+||| An infinite stream of repetitions of the same thing

30repeat : a -> Stream a

42repeat : a -> Stream a

31repeat x = x :: repeat x

43repeat x = x :: repeat x

32

44

45+||| Generate an infinite stream by repeatedly applying a function

46+||| @ f the function to iterate

47+||| @ x the initial value that will be the head of the stream

33−iterate : (a -> a) -> a -> Stream a

48+iterate : (f : a -> a) -> (x : a) -> Stream a

34iterate f x = x :: iterate f (f x)

49iterate f x = x :: iterate f (f x)

35

50

51+||| Get the nth element of a stream

36index : Nat -> Stream a -> a

52index : Nat -> Stream a -> a

37−index Z (x::xs) = x

53+index Z (x::xs) = x

38index (S k) (x::xs) = index k xs

54index (S k) (x::xs) = index k xs

39

55

56+||| Combine two streams element-wise using a function

40zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c

57zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c

41zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

58zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

42

59

60+||| Create a stream of pairs from two streams

43zip : Stream a -> Stream b -> Stream (a, b)

61zip : Stream a -> Stream b -> Stream (a, b)

44zip = zipWith (\x,y => (x,y))

62zip = zipWith (\x,y => (x,y))

45

63

64+||| Create a pair of streams from a stream of pairs

46unzip : Stream (a, b) -> (Stream a, Stream b)

65unzip : Stream (a, b) -> (Stream a, Stream b)

47unzip xs = (map fst xs, map snd xs)

66unzip xs = (map fst xs, map snd xs)

48

67

68+||| Return the diagonal elements of a stream of streams

49diag : Stream (Stream a) -> Stream a

69diag : Stream (Stream a) -> Stream a

50diag ((x::xs)::xss) = x :: diag (map tail xss)

70diag ((x::xs)::xss) = x :: diag (map tail xss)

51

71

72+||| Fold a Stream corecursively. Since there is no Nil, no initial value is used.

73+||| @ f the combining function

74+||| @ xs the Stream to fold up

75+foldr : (f : a -> Inf b -> b) -> (xs : Stream a) -> b

76+foldr f (x :: xs) = f x (foldr f xs)

77+

78+||| Produce a Stream of left folds of prefixes of the given Stream

79+||| @ f the combining function

80+||| @ acc the initial value

81+||| @ xs the Stream to process

82+scanl : (f : a -> b -> a) -> (acc : a) -> (xs : Stream b) -> Stream a

83+scanl f acc (x :: xs) = acc :: scanl f (f acc x) xs

84+

85+||| Produce a Stream of (corecursive) right folds of tails of the given Stream

86+||| @ f the combining function

87+||| @ xs the Stream to fold up

88+-- Reusing the head of the corecursion in the obvious way doesn’t productivity check

89+scanr : (f : a -> Inf b -> b) -> (xs : Stream a) -> Stream b

90+scanr f (x :: Delay xs) = f x (foldr f xs) :: scanr f xs

91+

92+||| Produce a Stream repeating a sequence

93+||| @ xs the sequence to repeat

94+cycle : (xs : Vect (S n) a) -> Stream a

95+cycle xs = cycle_ xs xs

96+ where cycle_ : Vect (S n) a -> Vect m a -> Stream a

97+ cycle_ (x :: xs) [] = x :: cycle_ (x :: xs) xs

98+ cycle_ xs (x :: ys) = x :: cycle_ xs ys

52

99

libs/prelude/Prelude/Strings.idr+121−7

@@ -7,30 +7,60 @@ import Prelude.Cast

7import Prelude.Either

8import Prelude.Foldable

9

10−-- | Appends two strings together.

10+||| Appends two strings together.

11+|||

12+||| Idris> "AB" ++ "C"

13+||| "ABC" : String

11(++) : String -> String -> String

14(++) : String -> String -> String

12(++) = prim__concat

15(++) = prim__concat

13

16

14−-- | Returns the first character in the specified string.

17+||| Returns the first character in the specified string.

18+|||

19+||| Doesn't work for empty strings.

20+|||

21+||| Idris> strHead "A"

22+||| 'A' : Char

15partial

23partial

16strHead : String -> Char

24strHead : String -> Char

17strHead = prim__strHead

25strHead = prim__strHead

18

26

19−-- | Returns the characters specified after the head of the string.

27+||| Returns the characters specified after the head of the string.

28+|||

29+||| Doesn't work for empty strings.

30+|||

31+||| Idris> strTail "AB"

32+||| "B" : String

33+||| Idris> strTail "A"

34+||| "" : String

20partial

35partial

21strTail : String -> String

36strTail : String -> String

22strTail = prim__strTail

37strTail = prim__strTail

23

38

24−-- | Adds a character to the from of the specified string.

39+||| Adds a character to the front of the specified string.

40+|||

41+||| Idris> strCons 'A' "B"

42+||| "AB" : String

43+||| Idris> strCons 'A' ""

44+||| "A" : String

25strCons : Char -> String -> String

45strCons : Char -> String -> String

26strCons = prim__strCons

46strCons = prim__strCons

27

47

28−-- | Returns the nth character (starting from 0) of the specified string.

48+||| Returns the nth character (starting from 0) of the specified string.

49+|||

50+||| Precondition: '0 < i < length s' for 'strIndex s i'.

51+|||

52+||| Idris> strIndex "AB" 1

53+||| 'B' : Char

29partial

54partial

30strIndex : String -> Int -> Char

55strIndex : String -> Int -> Char

31strIndex = prim__strIndex

56strIndex = prim__strIndex

32

57

33−-- | Reverses the elements within a String.

58+||| Reverses the elements within a String.

59+|||

60+||| Idris> reverse "ABC"

61+||| "CBA" : String

62+||| Idris> reverse ""

63+||| "" : String

34reverse : String -> String

64reverse : String -> String

35reverse = prim__strRev

65reverse = prim__strRev

36

66

@@ -43,9 +73,11 @@ data StrM : String -> Type where

43 StrNil : StrM ""

73 StrNil : StrM ""

44 StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs)

74 StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs)

45

75

76+||| Version of 'strHead' that statically verifies that the string is not empty.

46strHead' : (x : String) -> so (not (x == "")) -> Char

77strHead' : (x : String) -> so (not (x == "")) -> Char

47strHead' x p = assert_total $ prim__strHead x

78strHead' x p = assert_total $ prim__strHead x

48

79

80+||| Version of 'strTail' that statically verifies that the string is not empty.

49strTail' : (x : String) -> so (not (x == "")) -> String

81strTail' : (x : String) -> so (not (x == "")) -> String

50strTail' x p = assert_total $ prim__strTail x

82strTail' x p = assert_total $ prim__strTail x

51

83

@@ -61,14 +93,23 @@ strM x with (choose (not (x == "")))

61-- a recursive argument, therefore the termination checker doesn't believe

93-- a recursive argument, therefore the termination checker doesn't believe

62-- the string is guaranteed smaller. It makes a good point.

94-- the string is guaranteed smaller. It makes a good point.

63

95

96+||| Turns a string into a list of characters.

97+|||

98+||| Idris> unpack "ABC"

99+||| ['A', 'B', 'C'] : List Char

64unpack : String -> List Char

100unpack : String -> List Char

65unpack s with (strM s)

101unpack s with (strM s)

66 unpack "" | StrNil = []

102 unpack "" | StrNil = []

67 unpack (strCons x xs) | (StrCons x xs) = x :: assert_total (unpack xs)

103 unpack (strCons x xs) | (StrCons x xs) = x :: assert_total (unpack xs)

68

104

105+||| Turns a Foldable of characters into a string.

69pack : (Foldable t) => t Char -> String

106pack : (Foldable t) => t Char -> String

70pack = foldr strCons ""

107pack = foldr strCons ""

71

108

109+||| Creates a string of a single character.

110+|||

111+||| Idris> singleton 'A'

112+||| "A" : String

72singleton : Char -> String

113singleton : Char -> String

73singleton c = strCons c ""

114singleton c = strCons c ""

74

115

@@ -87,6 +128,13 @@ instance Semigroup String where

87instance Monoid String where

128instance Monoid String where

88 neutral = ""

129 neutral = ""

89

130

131+||| Splits the string into a part before the predicate

132+||| returns False and the rest of the string.

133+|||

134+||| Idris> span (/= 'C') "ABCD"

135+||| ("AB", "CD") : (String, String)

136+||| Idris> span (/= 'C') "EFGH"

137+||| ("EFGH", "") : (String, String)

90span : (Char -> Bool) -> String -> (String, String)

138span : (Char -> Bool) -> String -> (String, String)

91span p xs with (strM xs)

139span p xs with (strM xs)

92 span p "" | StrNil = ("", "")

140 span p "" | StrNil = ("", "")

@@ -95,44 +143,92 @@ span p xs with (strM xs)

95 | (ys, zs) = (strCons x ys, zs)

143 | (ys, zs) = (strCons x ys, zs)

96 | False = ("", strCons x xs)

144 | False = ("", strCons x xs)

97

145

146+||| Splits the string into a part before the predicate

147+||| returns True and the rest of the string.

148+|||

149+||| Idris> break (== 'C') "ABCD"

150+||| ("AB", "CD") : (String, String)

151+||| Idris> break (== 'C') "EFGH"

152+||| ("EFGH", "") : (String, String)

98break : (Char -> Bool) -> String -> (String, String)

153break : (Char -> Bool) -> String -> (String, String)

99break p = span (not . p)

154break p = span (not . p)

100

155

156+||| Splits the string into parts with the predicate

157+||| indicating separator characters.

158+|||

159+||| Idris> split (== '.') ".AB.C..D"

160+||| ["", "AB", "C", "", "D"] : List String

101split : (Char -> Bool) -> String -> List String

161split : (Char -> Bool) -> String -> List String

102split p xs = map pack (split p (unpack xs))

162split p xs = map pack (split p (unpack xs))

103

163

164+||| Removes whitespace (determined with 'isSpace') from

165+||| the start of the string.

166+|||

167+||| Idris> ltrim " A\nB"

168+||| "A\nB" : String

169+||| Idris> ltrim " \nAB"

170+||| "AB" : String

104ltrim : String -> String

171ltrim : String -> String

105ltrim xs with (strM xs)

172ltrim xs with (strM xs)

106 ltrim "" | StrNil = ""

173 ltrim "" | StrNil = ""

107 ltrim (strCons x xs) | StrCons _ _

174 ltrim (strCons x xs) | StrCons _ _

108 = if (isSpace x) then assert_total (ltrim xs) else (strCons x xs)

175 = if (isSpace x) then assert_total (ltrim xs) else (strCons x xs)

109

176

177+||| Removes whitespace (determined with 'isSpace') from

178+||| the start and end of the string.

179+|||

180+||| Idris> trim " A\nB C "

181+||| "A\nB C" : String

110trim : String -> String

182trim : String -> String

111trim xs = ltrim (reverse (ltrim (reverse xs)))

183trim xs = ltrim (reverse (ltrim (reverse xs)))

112

184

185+||| Splits a character list into a list of whitespace separated character lists.

186+|||

187+||| Idris> words' (unpack " A B C D E ")

188+||| [['A'], ['B'], ['C'], ['D'], ['E']] : List (List Char)

113words' : List Char -> List (List Char)

189words' : List Char -> List (List Char)

114words' s = case dropWhile isSpace s of

190words' s = case dropWhile isSpace s of

115 [] => []

191 [] => []

116 s' => let (w, s'') = break isSpace s'

192 s' => let (w, s'') = break isSpace s'

117 in w :: words' (assert_smaller s s'')

193 in w :: words' (assert_smaller s s'')

118

194

195+||| Splits a string into a list of whitespace separated strings.

196+|||

197+||| Idris> words " A B C D E "

198+||| ["A", "B", "C", "D", "E"] : List String

119words : String -> List String

199words : String -> List String

120words s = map pack $ words' $ unpack s

200words s = map pack $ words' $ unpack s

121

201

202+||| Splits a character list into a list of newline separated character lists.

203+|||

204+||| Idris> lines' (unpack "\rA BC\nD\r\nE\n")

205+||| [['A', ' ', 'B', 'C'], ['D'], ['E']] : List (List Char)

122lines' : List Char -> List (List Char)

206lines' : List Char -> List (List Char)

123lines' s = case dropWhile isNL s of

207lines' s = case dropWhile isNL s of

124 [] => []

208 [] => []

125 s' => let (w, s'') = break isNL s'

209 s' => let (w, s'') = break isNL s'

126 in w :: lines' (assert_smaller s s'')

210 in w :: lines' (assert_smaller s s'')

127

211

212+||| Splits a string into a list of newline separated strings.

213+|||

214+||| Idris> lines "\rA BC\nD\r\nE\n"

215+||| ["A BC", "D", "E"] : List String

128lines : String -> List String

216lines : String -> List String

129lines s = map pack $ lines' $ unpack s

217lines s = map pack $ lines' $ unpack s

130

218

131partial

219partial

132foldr1 : (a -> a -> a) -> List a -> a

220foldr1 : (a -> a -> a) -> List a -> a

133−foldr1 f [x] = x

221+foldr1 _ [x] = x

134foldr1 f (x::xs) = f x (foldr1 f xs)

222foldr1 f (x::xs) = f x (foldr1 f xs)

135

223

224+partial

225+foldl1 : (a -> a -> a) -> List a -> a

226+foldl1 f (x::xs) = foldl f x xs

227+

228+||| Joins the character lists by spaces into a single character list.

229+|||

230+||| Idris> unwords' [['A'], ['B', 'C'], ['D'], ['E']]

231+||| ['A', ' ', 'B', 'C', ' ', 'D', ' ', 'E'] : List Char

136unwords' : List (List Char) -> List Char

232unwords' : List (List Char) -> List Char

137unwords' [] = []

233unwords' [] = []

138unwords' ws = assert_total (foldr1 addSpace ws)

234unwords' ws = assert_total (foldr1 addSpace ws)

@@ -140,18 +236,36 @@ unwords' ws = assert_total (foldr1 addSpace ws)

140 addSpace : List Char -> List Char -> List Char

236 addSpace : List Char -> List Char -> List Char

141 addSpace w s = w ++ (' ' :: s)

237 addSpace w s = w ++ (' ' :: s)

142

238

239+||| Joins the strings by spaces into a single string.

240+|||

241+||| Idris> unwords ["A", "BC", "D", "E"]

242+||| "A BC D E" : String

143unwords : List String -> String

243unwords : List String -> String

144unwords = pack . unwords' . map unpack

244unwords = pack . unwords' . map unpack

145

245

246+||| Returns the length of the string.

247+|||

248+||| Idris> length ""

249+||| 0 : Nat

250+||| Idris> length "ABC"

251+||| 3 : Nat

146length : String -> Nat

252length : String -> Nat

147length = fromInteger . prim__zextInt_BigInt . prim_lenString

253length = fromInteger . prim__zextInt_BigInt . prim_lenString

148

254

255+||| Lowercases all characters in the string.

256+|||

257+||| Idris> toLower "aBc12!"

258+||| "abc12!" : String

149toLower : String -> String

259toLower : String -> String

150toLower x with (strM x)

260toLower x with (strM x)

151 strToLower "" | StrNil = ""

261 strToLower "" | StrNil = ""

152 strToLower (strCons c cs) | (StrCons c cs) =

262 strToLower (strCons c cs) | (StrCons c cs) =

153 strCons (toLower c) (toLower (assert_smaller (strCons c cs) cs))

263 strCons (toLower c) (toLower (assert_smaller (strCons c cs) cs))

154

264

265+||| Uppercases all characters in the string.

266+|||

267+||| Idris> toLower "aBc12!"

268+||| "ABC12!" : String

155toUpper : String -> String

269toUpper : String -> String

156toUpper x with (strM x)

270toUpper x with (strM x)

157 strToLower "" | StrNil = ""

271 strToLower "" | StrNil = ""

libs/prelude/Prelude/Uninhabited.idr+13−9

@@ -1,15 +1,19 @@

1module Prelude.Uninhabited

2

3+import Builtins

4+

5+||| A canonical proof that some type is empty

3class Uninhabited t where

6class Uninhabited t where

7+ ||| If I have a t, I've had a contradiction

8+ ||| @ t the uninhabited type

4 total uninhabited : t -> _|_

9 total uninhabited : t -> _|_

5

10

6−instance Uninhabited (Fin Z) where

11+instance Uninhabited _|_ where

7− uninhabited fZ impossible

12+ uninhabited a = a

8− uninhabited (fS f) impossible

9−

10−instance Uninhabited (Z = S n) where

11− uninhabited refl impossible

12

13

13−-- | Use an absurd assumption to discharge a proof obligation

14+||| Use an absurd assumption to discharge a proof obligation

15+||| @ t some empty type

16+||| @ a the goal type

17+||| @ h the contradictory hypothesis

14−absurd : Uninhabited t => t -> a

18+absurd : Uninhabited t => (h : t) -> a

15−absurd t = FalseElim (uninhabited t)

19+absurd h = FalseElim (uninhabited h)

libs/prelude/Prelude/Vect.idr+174−33

@@ -7,6 +7,7 @@ import Prelude.List

7import Prelude.Classes

8import Prelude.Nat

9import Prelude.Bool

10+import Prelude.Uninhabited

10

11

11%access public

12%access public

12%default total

13%default total

@@ -20,39 +21,76 @@ infixr 7 ::

20-- Hints for interactive editing

21-- Hints for interactive editing

21%name Vect xs,ys,zs,ws

22%name Vect xs,ys,zs,ws

22

23

24+--------------------------------------------------------------------------------

25+-- Length

26+--------------------------------------------------------------------------------

27+

28+||| Calculate the length of a `Vect`.

29+|||

30+||| **Note**: this is only useful if you don't already statically know the length

31+||| and you want to avoid matching the implicit argument for erasure reasons.

32+||| @ n the length (provably equal to the return value)

33+||| @ xs the vector

34+length : (xs : Vect n a) -> Nat

35+length [] = 0

36+length (x::xs) = 1 + length xs

37+

38+||| Show that the length function on vectors in fact calculates the length

39+private lengthCorrect : (n : Nat) -> (xs : Vect n a) -> length xs = n

40+lengthCorrect Z [] = refl

41+lengthCorrect (S n) (x :: xs) = rewrite lengthCorrect n xs in refl

42+

23--------------------------------------------------------------------------------

43--------------------------------------------------------------------------------

24-- Indexing into vectors

44-- Indexing into vectors

25--------------------------------------------------------------------------------

45--------------------------------------------------------------------------------

26

46

47+||| All but the first element of the vector

27tail : Vect (S n) a -> Vect n a

48tail : Vect (S n) a -> Vect n a

28tail (x::xs) = xs

49tail (x::xs) = xs

29

50

51+||| Only the first element of the vector

30head : Vect (S n) a -> a

52head : Vect (S n) a -> a

31head (x::xs) = x

53head (x::xs) = x

32

54

55+||| The last element of the vector

33last : Vect (S n) a -> a

56last : Vect (S n) a -> a

34last (x::[]) = x

57last (x::[]) = x

35last (x::y::ys) = last $ y::ys

58last (x::y::ys) = last $ y::ys

36

59

60+||| All but the last element of the vector

37init : Vect (S n) a -> Vect n a

61init : Vect (S n) a -> Vect n a

38init (x::[]) = []

62init (x::[]) = []

39init (x::y::ys) = x :: init (y::ys)

63init (x::y::ys) = x :: init (y::ys)

40

64

65+||| Extract a particular element from a vector

41index : Fin n -> Vect n a -> a

66index : Fin n -> Vect n a -> a

42index fZ (x::xs) = x

67index fZ (x::xs) = x

43index (fS k) (x::xs) = index k xs

68index (fS k) (x::xs) = index k xs

44index fZ [] impossible

69index fZ [] impossible

45

70

71+||| Insert an element at a particular index

72+insertAt : Fin (S n) -> a -> Vect n a -> Vect (S n) a

73+insertAt fZ y xs = y :: xs

74+insertAt (fS k) y (x::xs) = x :: insertAt k y xs

75+insertAt (fS k) y [] = absurd k

76+

77+||| Construct a new vector consisting of all but the indicated element

46deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a

78deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a

47deleteAt fZ (x::xs) = xs

79deleteAt fZ (x::xs) = xs

48deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs

80deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs

81+deleteAt {n = Z} (fS k) (x::xs) = absurd k

49deleteAt _ [] impossible

82deleteAt _ [] impossible

50

83

84+||| Replace an element at a particlar index with another

51replaceAt : Fin n -> t -> Vect n t -> Vect n t

85replaceAt : Fin n -> t -> Vect n t -> Vect n t

52replaceAt fZ y (x::xs) = y :: xs

86replaceAt fZ y (x::xs) = y :: xs

53replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs

87replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs

54

88

89+||| Replace the element at a particular index with the result of applying a function to it

90+||| @ i the index to replace at

91+||| @ f the update function

92+||| @ xs the vector to replace in

55−updateAt : Fin n -> (t -> t) -> Vect n t -> Vect n t

93+updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t

56updateAt fZ f (x::xs) = f x :: xs

94updateAt fZ f (x::xs) = f x :: xs

57updateAt (fS k) f (x::xs) = x :: updateAt k f xs

95updateAt (fS k) f (x::xs) = x :: updateAt k f xs

58

96

@@ -60,33 +98,82 @@ updateAt (fS k) f (x::xs) = x :: updateAt k f xs

60-- Subvectors

98-- Subvectors

61--------------------------------------------------------------------------------

99--------------------------------------------------------------------------------

62

100

101+||| Get the first m elements of a Vect

102+||| @ m the number of elements to take

63take : {n : Nat} -> (m : Fin (S n)) -> Vect n a -> Vect (cast m) a

103take : {n : Nat} -> (m : Fin (S n)) -> Vect n a -> Vect (cast m) a

64take (fS k) [] = FinZElim k

104take (fS k) [] = FinZElim k

65take fZ _ = []

105take fZ _ = []

66take (fS k) (x::xs) = x :: take k xs

106take (fS k) (x::xs) = x :: take k xs

67

107

108+||| Remove the first m elements of a Vect

109+||| @ m the number of elements to remove

68drop : (m : Fin (S n)) -> Vect n a -> Vect (n - cast m) a

110drop : (m : Fin (S n)) -> Vect n a -> Vect (n - cast m) a

69drop (fS k) [] = FinZElim k

111drop (fS k) [] = FinZElim k

70drop fZ xs ?= xs

112drop fZ xs ?= xs

71drop (fS k) (x::xs) = drop k xs

113drop (fS k) (x::xs) = drop k xs

72

114

115+--------------------------------------------------------------------------------

116+-- Transformations

117+--------------------------------------------------------------------------------

118+

119+||| Reverse the order of the elements of a vector

120+total reverse : {n : Nat} -> Vect n a -> Vect n a

121+reverse {n} xs = reverse' [] (plusZeroRightNeutral n) xs

122+ where

123+ total reverse' : {m, j, l : Nat} ->

124+ Vect m a -> (j + m = l) -> Vect j a -> Vect l a

125+ reverse' {m} {j = Z } {l} acc prf [] ?= acc

126+ reverse' {m} {j = S k} {l} acc prf (x::xs) =

127+ let prf1 : (m + (S k) = l) = rewrite plusCommutative m (S k) in prf in

128+ let prf2 : (S (m + k) = l) = rewrite plusSuccRightSucc m k in prf1 in

129+ let prf3 : (S (k + m) = l) = rewrite plusCommutative k m in prf2 in

130+ let prf4 : (k + (S m) = l) = rewrite sym $ plusSuccRightSucc k m in prf3 in

131+ reverse' (x::acc) prf4 xs

132+

133+||| Alternate an element between the other elements of a vector

134+||| @ sep the element to intersperse

135+||| @ xs the vector to separate with `sep`

136+intersperse : (sep : a) -> (xs : Vect n a) -> Vect (n + pred n) a

137+intersperse sep [] = []

138+intersperse sep (x::xs) = x :: intersperse' sep xs

139+ where

140+ intersperse' : a -> Vect n a -> Vect (n + n) a

141+ intersperse' sep [] = []

142+ intersperse' sep (x::xs) ?= sep :: x :: intersperse' sep xs

143+

73--------------------------------------------------------------------------------

144--------------------------------------------------------------------------------

74-- Conversion from list (toList is provided by Foldable)

145-- Conversion from list (toList is provided by Foldable)

75--------------------------------------------------------------------------------

146--------------------------------------------------------------------------------

76

147

148+

149+fromList' : Vect n a -> (l : List a) -> Vect (length l + n) a

150+fromList' ys [] = ys

151+fromList' {n} ys (x::xs) =

152+ rewrite (plusSuccRightSucc (length xs) n) ==>

153+ Vect (plus (length xs) (S n)) a in

154+ fromList' (x::ys) xs

155+

156+||| Convert a list to a vector.

157+|||

158+||| The length of the list should be statically known.

77fromList : (l : List a) -> Vect (length l) a

159fromList : (l : List a) -> Vect (length l) a

78−fromList [] = []

160+fromList l =

79−fromList (x::xs) = x :: fromList xs

161+ rewrite (sym $ plusZeroRightNeutral (length l)) in

162+ reverse $ fromList' [] l

80

163

81--------------------------------------------------------------------------------

164--------------------------------------------------------------------------------

82-- Building (bigger) vectors

165-- Building (bigger) vectors

83--------------------------------------------------------------------------------

166--------------------------------------------------------------------------------

84

167

168+||| Append two vectors

85(++) : Vect m a -> Vect n a -> Vect (m + n) a

169(++) : Vect m a -> Vect n a -> Vect (m + n) a

86(++) [] ys = ys

170(++) [] ys = ys

87(++) (x::xs) ys = x :: xs ++ ys

171(++) (x::xs) ys = x :: xs ++ ys

88

172

173+||| Repeate some value n times

174+||| @ n the number of times to repeat it

175+||| @ x the value to repeat

89−replicate : (n : Nat) -> a -> Vect n a

176+replicate : (n : Nat) -> (x : a) -> Vect n a

90replicate Z x = []

177replicate Z x = []

91replicate (S k) x = x :: replicate k x

178replicate (S k) x = x :: replicate k x

92

179

@@ -94,18 +181,21 @@ replicate (S k) x = x :: replicate k x

94-- Zips and unzips

181-- Zips and unzips

95--------------------------------------------------------------------------------

182--------------------------------------------------------------------------------

96

183

184+||| Combine two equal-length vectors pairwise with some function

97zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

185zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

98zipWith f [] [] = []

186zipWith f [] [] = []

99zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

187zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

100

188

189+||| Combine two equal-length vectors pairwise

101zip : Vect n a -> Vect n b -> Vect n (a, b)

190zip : Vect n a -> Vect n b -> Vect n (a, b)

102zip = zipWith (\x => \y => (x,y))

191zip = zipWith (\x => \y => (x,y))

103

192

193+||| Convert a vector of pairs to a pair of vectors

104unzip : Vect n (a, b) -> (Vect n a, Vect n b)

194unzip : Vect n (a, b) -> (Vect n a, Vect n b)

105unzip [] = ([], [])

195unzip [] = ([], [])

106unzip ((l, r)::xs) with (unzip xs)

196unzip ((l, r)::xs) with (unzip xs)

107 | (lefts, rights) = (l::lefts, r::rights)

197 | (lefts, rights) = (l::lefts, r::rights)

108−

198+

109--------------------------------------------------------------------------------

199--------------------------------------------------------------------------------

110-- Equality

200-- Equality

111--------------------------------------------------------------------------------

201--------------------------------------------------------------------------------

@@ -154,65 +244,81 @@ instance Functor (Vect n) where

154-- Folds

244-- Folds

155--------------------------------------------------------------------------------

245--------------------------------------------------------------------------------

156

246

247+total foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc

248+foldrImpl f e go [] = go e

249+foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs

250+

157instance Foldable (Vect n) where

251instance Foldable (Vect n) where

158− foldr f e [] = e

252+ foldr f e xs = foldrImpl f e id xs

159− foldr f e (x::xs) = f x (foldr f e xs)

160

253

161--------------------------------------------------------------------------------

254--------------------------------------------------------------------------------

162-- Special folds

255-- Special folds

163--------------------------------------------------------------------------------

256--------------------------------------------------------------------------------

164

257

258+||| Flatten a vector of equal-length vectors

165concat : Vect m (Vect n a) -> Vect (m * n) a

259concat : Vect m (Vect n a) -> Vect (m * n) a

166concat [] = []

260concat [] = []

167concat (v::vs) = v ++ concat vs

261concat (v::vs) = v ++ concat vs

168

262

263+||| Foldr without seeding the accumulator

264+foldr1 : (t -> t -> t) -> Vect (S n) t -> t

265+foldr1 f (x::xs) = foldr f x xs

266+

267+||| Foldl without seeding the accumulator

268+foldl1 : (t -> t -> t) -> Vect (S n) t -> t

269+foldl1 f (x::xs) = foldl f x xs

169--------------------------------------------------------------------------------

270--------------------------------------------------------------------------------

170−-- Transformations

271+-- Scans

171--------------------------------------------------------------------------------

272--------------------------------------------------------------------------------

172

273

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

274+scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b

181−intersperse sep [] = []

275+scanl f q [] = [q]

182−intersperse sep (x::xs) = x :: intersperse' sep xs

276+scanl f q (x::xs) = q :: scanl f (f q x) 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

277

188--------------------------------------------------------------------------------

278--------------------------------------------------------------------------------

189-- Membership tests

279-- Membership tests

190--------------------------------------------------------------------------------

280--------------------------------------------------------------------------------

191

281

282+||| Search for an item using a user-provided test

283+||| @ p the equality test

284+||| @ e the item to search for

285+||| @ xs the vector to search in

192−elemBy : (a -> a -> Bool) -> a -> Vect n a -> Bool

286+elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool

193elemBy p e [] = False

287elemBy p e [] = False

194elemBy p e (x::xs) with (p e x)

288elemBy p e (x::xs) with (p e x)

195 | True = True

289 | True = True

196 | False = elemBy p e xs

290 | False = elemBy p e xs

197

291

292+||| Use the default Boolean equality on elements to search for an item

293+||| @ x what to search for

294+||| @ xs where to search

198−elem : Eq a => a -> Vect n a -> Bool

295+elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool

199elem = elemBy (==)

296elem = elemBy (==)

200

297

298+||| Find the association of some key with a user-provided comparison

299+||| @ p the comparison operator for keys (True if they match)

300+||| @ e the key to look for

201−lookupBy : (a -> a -> Bool) -> a -> Vect n (a, b) -> Maybe b

301+lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b

202lookupBy p e [] = Nothing

302lookupBy p e [] = Nothing

203lookupBy p e ((l, r)::xs) with (p e l)

303lookupBy p e ((l, r)::xs) with (p e l)

204 | True = Just r

304 | True = Just r

205 | False = lookupBy p e xs

305 | False = lookupBy p e xs

206

306

307+||| Find the assocation of some key using the default Boolean equality test

207lookup : Eq a => a -> Vect n (a, b) -> Maybe b

308lookup : Eq a => a -> Vect n (a, b) -> Maybe b

208lookup = lookupBy (==)

309lookup = lookupBy (==)

209

310

311+||| Check if any element of xs is found in elems by a user-provided comparison

312+||| @ p the comparison operator

313+||| @ elems the vector to search

314+||| @ xs what to search for

210−hasAnyBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool

315+hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool

211hasAnyBy p elems [] = False

316hasAnyBy p elems [] = False

212hasAnyBy p elems (x::xs) with (elemBy p x elems)

317hasAnyBy p elems (x::xs) with (elemBy p x elems)

213 | True = True

318 | True = True

214 | False = hasAnyBy p elems xs

319 | False = hasAnyBy p elems xs

215

320

321+||| Check if any element of xs is found in elems using the default Boolean equality test

216hasAny : Eq a => Vect m a -> Vect n a -> Bool

322hasAny : Eq a => Vect m a -> Vect n a -> Bool

217hasAny = hasAnyBy (==)

323hasAny = hasAnyBy (==)

218

324

@@ -220,12 +326,15 @@ hasAny = hasAnyBy (==)

220-- Searching with a predicate

326-- Searching with a predicate

221--------------------------------------------------------------------------------

327--------------------------------------------------------------------------------

222

328

329+||| Find the first element of the vector that satisfies some test

330+||| @ p the test to satisfy

223−find : (a -> Bool) -> Vect n a -> Maybe a

331+find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a

224find p [] = Nothing

332find p [] = Nothing

225find p (x::xs) with (p x)

333find p (x::xs) with (p x)

226 | True = Just x

334 | True = Just x

227 | False = find p xs

335 | False = find p xs

228

336

337+||| Find the index of the first element of the vector that satisfies some test

229findIndex : (a -> Bool) -> Vect n a -> Maybe Nat

338findIndex : (a -> Bool) -> Vect n a -> Maybe Nat

230findIndex = findIndex' 0

339findIndex = findIndex' 0

231 where

340 where

@@ -235,6 +344,7 @@ findIndex = findIndex' 0

235 | True = Just cnt

344 | True = Just cnt

236 | False = findIndex' (S cnt) p xs

345 | False = findIndex' (S cnt) p xs

237

346

347+||| Find the indices of all elements that satisfy some test

238total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)

348total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)

239findIndices = findIndices' 0

349findIndices = findIndices' 0

240 where

350 where

@@ -263,6 +373,7 @@ elemIndices = elemIndicesBy (==)

263-- Filters

373-- Filters

264--------------------------------------------------------------------------------

374--------------------------------------------------------------------------------

265

375

376+||| Find all elements of a vector that satisfy some test

266total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)

377total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)

267filter p [] = ( _ ** [] )

378filter p [] = ( _ ** [] )

268filter p (x::xs) with (filter p xs)

379filter p (x::xs) with (filter p xs)

@@ -272,6 +383,7 @@ filter p (x::xs) with (filter p xs)

272 else

383 else

273 (_ ** tail)

384 (_ ** tail)

274

385

386+||| Make the elements of some vector unique by some test

275nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)

387nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)

276nubBy = nubBy' []

388nubBy = nubBy' []

277 where

389 where

@@ -282,6 +394,7 @@ nubBy = nubBy' []

282 | False with (nubBy' (x::acc) p xs)

394 | False with (nubBy' (x::acc) p xs)

283 | (_ ** tail) = (_ ** x::tail)

395 | (_ ** tail) = (_ ** x::tail)

284

396

397+||| Make the elements of some vector unique by the default Boolean equality

285nub : Eq a => Vect n a -> (p ** Vect p a)

398nub : Eq a => Vect n a -> (p ** Vect p a)

286nub = nubBy (==)

399nub = nubBy (==)

287

400

@@ -289,6 +402,14 @@ nub = nubBy (==)

289-- Splitting and breaking lists

402-- Splitting and breaking lists

290--------------------------------------------------------------------------------

403--------------------------------------------------------------------------------

291

404

405+||| A tuple where the first element is a Vect of the n first elements and

406+||| the second element is a Vect of the remaining elements of the original Vect

407+||| It is equivalent to (take n xs, drop n xs)

408+||| @ m the index to split at

409+||| @ xs the Vect to split in two

410+splitAt : {n : Nat} -> (m : Fin (S n)) -> (xs : Vect n a) -> (Vect (cast m) a, Vect (n - cast m) a)

411+splitAt n xs = (take n xs, drop n xs)

412+

292--------------------------------------------------------------------------------

413--------------------------------------------------------------------------------

293-- Predicates

414-- Predicates

294--------------------------------------------------------------------------------

415--------------------------------------------------------------------------------

@@ -339,6 +460,31 @@ range : Vect n (Fin n)

339range {n=Z} = []

460range {n=Z} = []

340range {n=S _} = fZ :: map fS range

461range {n=S _} = fZ :: map fS range

341

462

463+||| Transpose a Vect of Vects, turning rows into columns and vice versa.

464+|||

465+||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`.

466+transpose : Vect m (Vect n a) -> Vect n (Vect m a)

467+transpose [] = replicate _ []

468+transpose (x :: xs) = zipWith (::) x (transpose xs)

469+

470+--------------------------------------------------------------------------------

471+-- Properties

472+--------------------------------------------------------------------------------

473+

474+vectConsCong : (x : a) -> (xs : Vect n a) -> (ys : Vect m a) -> (xs = ys) -> (x :: xs = x :: ys)

475+vectConsCong x xs xs refl = refl

476+

477+vectNilRightNeutral : (xs : Vect n a) -> xs ++ [] = xs

478+vectNilRightNeutral [] = refl

479+vectNilRightNeutral (x :: xs) =

480+ vectConsCong _ _ _ (vectNilRightNeutral xs)

481+

482+vectAppendAssociative : (x : Vect xLen a) -> (y : Vect yLen a) -> (z : Vect zLen a) -> x ++ (y ++ z) = (x ++ y) ++ z

483+vectAppendAssociative [] y z = refl

484+vectAppendAssociative (x :: xs) ys zs =

485+ vectConsCong _ _ _ (vectAppendAssociative xs ys zs)

486+

487+

342--------------------------------------------------------------------------------

488--------------------------------------------------------------------------------

343-- Proofs

489-- Proofs

344--------------------------------------------------------------------------------

490--------------------------------------------------------------------------------

@@ -349,14 +495,9 @@ Prelude.Vect.drop_lemma_1 = proof {

349 trivial;

495 trivial;

350}

496}

351

497

352−Prelude.Vect.reverse'_lemma_2 = proof {

353− intros;

354− rewrite (plusSuccRightSucc m n1);

355− exact value;

356−}

357−

358Prelude.Vect.reverse'_lemma_1 = proof {

498Prelude.Vect.reverse'_lemma_1 = proof {

359 intros;

499 intros;

500+ rewrite prf;

360 rewrite sym (plusZeroRightNeutral m);

501 rewrite sym (plusZeroRightNeutral m);

361 exact value;

502 exact value;

362}

503}

libs/prelude/prelude.ipkg+1−1

@@ -8,7 +8,7 @@ modules = Builtins, Prelude, IO,

8 Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either,

9 Prelude.Vect, Prelude.Strings, Prelude.Chars, Prelude.Functor,

10 Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,

11− Prelude.Uninhabited,

11+ Prelude.Uninhabited, Prelude.Pairs,

12

13 Decidable.Equality

14

main/Main.hs+10−60

@@ -24,6 +24,7 @@ import Idris.ElabDecls

24import Idris.Primitives

25import Idris.Imports

26import Idris.Error

27+import Idris.CmdOptions

27

28

28import IRTS.System ( getLibFlags, getIdrisLibDir, getIncFlags )

29import IRTS.System ( getLibFlags, getIdrisLibDir, getIncFlags )

29

30

@@ -36,8 +37,7 @@ import Paths_idris

36-- Main program reads command line options, parses the main program, and gets

37-- Main program reads command line options, parses the main program, and gets

37-- on with the REPL.

38-- on with the REPL.

38

39

39−main = do xs <- getArgs

40+main = do opts <- runArgParser

40− let opts = parseArgs xs

41 result <- runErrorT $ execStateT (runIdris opts) idrisInit

42 case result of

43 Left err -> putStrLn $ "Uncaught error: " ++ show err

@@ -48,8 +48,6 @@ runIdris [Client c] = do setVerbose False

48 setQuiet True

49 runIO $ runClient c

50runIdris opts = do

51− when (Ver `elem` opts) $ runIO showver

52− when (Usage `elem` opts) $ runIO usage

53 when (ShowIncs `elem` opts) $ runIO showIncs

51 when (ShowIncs `elem` opts) $ runIO showIncs

54 when (ShowLibs `elem` opts) $ runIO showLibs

52 when (ShowLibs `elem` opts) $ runIO showLibs

55 when (ShowLibdir `elem` opts) $ runIO showLibdir

53 when (ShowLibdir `elem` opts) $ runIO showLibdir

@@ -61,6 +59,14 @@ runIdris opts = do

61 [] -> return ()

59 [] -> return ()

62 fs -> do runIO $ mapM_ cleanPkg fs

60 fs -> do runIO $ mapM_ cleanPkg fs

63 runIO $ exitWith ExitSuccess

61 runIO $ exitWith ExitSuccess

62+ case opt getPkgMkDoc opts of -- IdrisDoc

63+ [] -> return ()

64+ fs -> do runIO $ mapM_ documentPkg fs

65+ runIO $ exitWith ExitSuccess

66+ case opt getPkgTest opts of

67+ [] -> return ()

68+ fs -> do runIO $ mapM_ testPkg fs

69+ runIO $ exitWith ExitSuccess

64 case opt getPkg opts of

70 case opt getPkg opts of

65 [] -> case opt getPkgREPL opts of

71 [] -> case opt getPkgREPL opts of

66 [] -> idrisMain opts

72 [] -> idrisMain opts

@@ -68,9 +74,6 @@ runIdris opts = do

68 _ -> ifail "Too many packages"

74 _ -> ifail "Too many packages"

69 fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs

75 fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs

70

76

71−usage = do putStrLn usagemsg

72− exitWith ExitSuccess

73−

74showver = do putStrLn $ "Idris version " ++ ver

77showver = do putStrLn $ "Idris version " ++ ver

75 exitWith ExitSuccess

78 exitWith ExitSuccess

76

79

@@ -85,56 +88,3 @@ showLibdir = do dir <- getIdrisLibDir

85showIncs = do incFlags <- getIncFlags

88showIncs = do incFlags <- getIncFlags

86 putStrLn incFlags

89 putStrLn incFlags

87 exitWith ExitSuccess

90 exitWith ExitSuccess

88−

89−usagemsghdr = "Idris version " ++ ver ++ ", (C) The Idris Community 2014"

90−

91−usagemsg = usagemsghdr ++ "\n" ++

92− map (\x -> '-') usagemsghdr ++ "\n" ++

93− "idris [OPTIONS] [FILE]\n\n" ++

94− "Common flags:\n" ++

95− "\t --install IPKG Install package\n" ++

96− "\t --clean IPKG Clean package\n" ++

97− "\t --build IPKG Build package\n" ++

98− "\t --exec EXPR Execute as idris\n" ++

99− "\t --libdir Display library directory\n" ++

100− "\t --link Display link directory\n" ++

101− "\t --include Display the includes directory\n" ++

102− "\t --nobanner Suppress the banner\n" ++

103− "\t --color, --colour Force coloured output\n" ++

104− "\t --nocolor, --nocolour Disable coloured output\n" ++

105− "\t --errorcontent Undocumented\n" ++

106− "\t --nocoverage Undocumented\n" ++

107− "\t -o --output FILE Specify output file\n" ++

108− "\t --check Undocumented\n" ++

109− "\t --total Require functions to be total by default\n" ++

110− "\t --partial Undocumented\n" ++

111− "\t --warnpartial Warn about undeclared partial functions.\n" ++

112− "\t --warn Undocumented\n" ++

113− "\t --typecase Undocumented\n" ++

114− "\t --typeintype Undocumented\n" ++

115− "\t --nobasepkgs Undocumented\n" ++

116− "\t --noprelude Undocumented\n" ++

117− "\t --nobuiltins Undocumented\n" ++

118− "\t -O --level LEVEL Undocumented\n" ++

119− "\t -i --idrispath DIR Add directory to the list of import paths\n" ++

120− "\t --package ITEM Undocumented\n" ++

121− "\t --ibcsubdir FILE Write IBC files into sub directory\n" ++

122− "\t --codegen TARGET Select code generator: C, Java, bytecode,\n" ++

123− "\t javascript, node, or llvm\n" ++

124− "\t --mvn Create a maven project (for Java codegen)\n" ++

125− "\t --cpu=CPU Select target CPU e.g. corei7 or cortex-m3\n" ++

126− "\t (for LLVM codegen)\n" ++

127− "\t --target=TRIPLE Select target triple (for llvm codegen)\n" ++

128− "\t -S --codegenonly Do no further compilation of code generator output\n" ++

129− "\t -c --compileonly Compile to object files rather than an executable\n" ++

130− "\t -X --extension EXT Turn on langage extension (TypeProviders or ErrorReflection)\n" ++

131− "\t --dumpdefuns Undocumented\n" ++

132− "\t --dumpcases Undocumented\n" ++

133− "\t --log LEVEL --loglevel Debugging log level\n" ++

134− "\t --ideslave Undocumented\n" ++

135− "\t --client Undocumented\n" ++

136− "\t -h --help Display help message\n" ++

137− "\t -v --version Print version information\n" ++

138− "\t -V --verbose Loud verbosity\n" ++

139− "\t -q --quiet Quiet verbosity\n"

140−

rts/Makefile+3−4

@@ -3,16 +3,15 @@ include ../config.mk

3OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_bitstring.o \

4 idris_opts.o idris_stats.o mini-gmp.o

5HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_bitstring.h \

6− idris_opts.h idris_stats.h mini-gmp.h

6+ idris_opts.h idris_stats.h mini-gmp.h idris_stdfgn.h idris_net.h

7CFLAGS:=-fPIC $(CFLAGS)

8−CFLAGS += $(GMP_INCLUDE_DIR) $(GMP)

8+CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) -DIDRIS_TARGET_OS="\"$(OS)\""

9+CFLAGS += -DIDRIS_TARGET_TRIPLE="\"$(MACHINE)\""

9

10

10ifeq ($(OS), windows)

11ifeq ($(OS), windows)

11 OBJS += windows/idris_stdfgn.o windows/idris_net.o

12 OBJS += windows/idris_stdfgn.o windows/idris_net.o

12− HDRS += windows/idris_stdfgn.h windows/idris_net.h

13else

14 OBJS += idris_stdfgn.o idris_net.o

15− HDRS += idris_stdfgn.h idris_net.h

16endif

15endif

17

16

18LIBTARGET = libidris_rts.a

17LIBTARGET = libidris_rts.a

rts/idris_net.c+11−1

@@ -1,9 +1,19 @@

1// C-Side of the Idris network library

2// (C) Simon Fowler, 2014

3// MIT Licensed. Have fun!

4−#include "idris_net.h"

4+#include <errno.h>

5+#include <netdb.h>

6+#include <stdbool.h>

7+#include <stdlib.h>

8+#include <stdio.h>

9+#include <string.h>

10+#include <sys/types.h>

11+#include <sys/socket.h>

12+#include <netinet/in.h>

5#include <arpa/inet.h>

13#include <arpa/inet.h>

6

14

15+#include "idris_net.h"

16+

7void* idrnet_malloc(int size) {

17void* idrnet_malloc(int size) {

8 return malloc(size);

18 return malloc(size);

9}

19}

rts/idris_net.h−10

@@ -1,16 +1,6 @@

1#ifndef IDRISNET_H

2#define IDRISNET_H

3

4−#include <errno.h>

5−#include <netdb.h>

6−#include <stdbool.h>

7−#include <stdlib.h>

8−#include <stdio.h>

9−#include <string.h>

10−#include <sys/types.h>

11−#include <sys/socket.h>

12−#include <netinet/in.h>

13−

14typedef struct idrnet_recv_result {

4typedef struct idrnet_recv_result {

15 int result;

5 int result;

16 void* payload;

6 void* payload;

rts/idris_rts.c+25−3

@@ -38,9 +38,18 @@ VM* init_vm(int stack_size, size_t heap_size,

38 vm->inbox_ptr = vm->inbox;

39 vm->inbox_write = vm->inbox;

40

41+ // The allocation lock must be reentrant. The lock exists to ensure that

42+ // no memory is allocated during the message sending process, but we also

43+ // check the lock in calls to allocate.

44+ // The problem comes when we use requireAlloc to guarantee a chunk of memory

45+ // first: this sets the lock, and since it is not reentrant, we get a deadlock.

46+ pthread_mutexattr_t rec_attr;

47+ pthread_mutexattr_init(&rec_attr);

48+ pthread_mutexattr_settype(&rec_attr, PTHREAD_MUTEX_RECURSIVE);

49+

41 pthread_mutex_init(&(vm->inbox_lock), NULL);

50 pthread_mutex_init(&(vm->inbox_lock), NULL);

42 pthread_mutex_init(&(vm->inbox_block), NULL);

51 pthread_mutex_init(&(vm->inbox_block), NULL);

43− pthread_mutex_init(&(vm->alloc_lock), NULL);

52+ pthread_mutex_init(&(vm->alloc_lock), &rec_attr);

44 pthread_cond_init(&(vm->inbox_waiting), NULL);

53 pthread_cond_init(&(vm->inbox_waiting), NULL);

45

54

46 vm->max_threads = max_threads;

55 vm->max_threads = max_threads;

@@ -75,7 +84,7 @@ void idris_requireAlloc(VM* vm, size_t size) {

75 }

84 }

76#ifdef HAS_PTHREAD

85#ifdef HAS_PTHREAD

77 int lock = vm->processes > 0;

86 int lock = vm->processes > 0;

78− if (lock) { // not message passing

87+ if (lock) { // We only need to lock if we're in concurrent mode

79 pthread_mutex_lock(&vm->alloc_lock);

88 pthread_mutex_lock(&vm->alloc_lock);

80 }

89 }

81#endif

90#endif

@@ -84,7 +93,7 @@ void idris_requireAlloc(VM* vm, size_t size) {

84void idris_doneAlloc(VM* vm) {

93void idris_doneAlloc(VM* vm) {

85#ifdef HAS_PTHREAD

94#ifdef HAS_PTHREAD

86 int lock = vm->processes > 0;

95 int lock = vm->processes > 0;

87− if (lock) { // not message passing

96+ if (lock) { // We only need to lock if we're in concurrent mode

88 pthread_mutex_unlock(&vm->alloc_lock);

97 pthread_mutex_unlock(&vm->alloc_lock);

89 }

98 }

90#endif

99#endif

@@ -508,6 +517,19 @@ VAL idris_strRev(VM* vm, VAL str) {

508 return cl;

517 return cl;

509}

518}

510

519

520+VAL idris_systemInfo(VM* vm, VAL index) {

521+ int i = GETINT(index);

522+ switch(i) {

523+ case 0: // backend

524+ return MKSTR(vm, "c");

525+ case 1:

526+ return MKSTR(vm, IDRIS_TARGET_OS);

527+ case 2:

528+ return MKSTR(vm, IDRIS_TARGET_TRIPLE);

529+ }

530+ return MKSTR(vm, "");

531+}

532+

511VAL MKBUFFERc(VM* vm, Buffer* buf) {

533VAL MKBUFFERc(VM* vm, Buffer* buf) {

512 Closure* cl = allocate(vm, sizeof(Closure) + sizeof *buf + buf->cap, 1);

534 Closure* cl = allocate(vm, sizeof(Closure) + sizeof *buf + buf->cap, 1);

513 SETTY(cl, BUFFER);

535 SETTY(cl, BUFFER);

rts/idris_rts.h+6

@@ -283,6 +283,12 @@ VAL idris_peekB64Native(VM* vm, VAL buf, VAL off);

283VAL idris_peekB64LE(VM* vm, VAL buf, VAL off);

284VAL idris_peekB64BE(VM* vm, VAL buf, VAL off);

285

286+// system infox

287+// used indices:

288+// 0 returns backend

289+// 1 returns OS

290+VAL idris_systemInfo(VM* vm, VAL index);

291+

286// Command line args

292// Command line args

287

293

288extern int __idris_argc;

294extern int __idris_argc;

rts/windows/idris_net.c+15−4

@@ -1,7 +1,7 @@

1// C-Side of the Idris network library

2// (C) Simon Fowler, 2014

3// MIT Licensed. Have fun!

4−#include "idris_net.h"

4+#include "../idris_net.h"

5

6#include <errno.h>

7#include <stdbool.h>

@@ -11,6 +11,12 @@

11#include <Winsock2.h>

12#include <Ws2tcpip.h>

13

14+

15+// inet_ntop isn't defined in the old mingw delivered with GHC,

16+// so put the prototype here, cribbed from a newer version of it

17+WINSOCK_API_LINKAGE LPCSTR WSAAPI InetNtopA(INT Family, PVOID pAddr,

18+ LPSTR pStringBuf, size_t StringBufSize);

19+

14static int socket_inited = 0;

20static int socket_inited = 0;

15static WSADATA wsa_data;

21static WSADATA wsa_data;

16

22

@@ -22,12 +28,17 @@ void idrnet_free(void* ptr) {

22 free(ptr);

28 free(ptr);

23}

29}

24

30

31+static void clean_sockets(void) {

32+ WSACleanup();

33+}

34+

25−static int check_init()

35+static int check_init(void)

26{

36{

27 if (!socket_inited) {

37 if (!socket_inited) {

28 int result = WSAStartup(MAKEWORD(2, 2), &wsa_data);

38 int result = WSAStartup(MAKEWORD(2, 2), &wsa_data);

29 if (result == NO_ERROR) {

39 if (result == NO_ERROR) {

30 socket_inited = 1;

40 socket_inited = 1;

41+ atexit(clean_sockets);

31 }

42 }

32 }

43 }

33 return socket_inited;

44 return socket_inited;

@@ -104,7 +115,7 @@ int idrnet_sockaddr_family(void* sockaddr) {

104char* idrnet_sockaddr_ipv4(void* sockaddr) {

115char* idrnet_sockaddr_ipv4(void* sockaddr) {

105 struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;

116 struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;

106 char* ip_addr = (char*) malloc(sizeof(char) * INET_ADDRSTRLEN);

117 char* ip_addr = (char*) malloc(sizeof(char) * INET_ADDRSTRLEN);

107− inet_ntop(AF_INET, &(addr->sin_addr), ip_addr, INET_ADDRSTRLEN);

118+ InetNtopA(AF_INET, &(addr->sin_addr), ip_addr, INET_ADDRSTRLEN);

108 return ip_addr;

119 return ip_addr;

109}

120}

110

121

@@ -139,7 +150,7 @@ int idrnet_send_buf(int sockfd, void* data, int len) {

139

150

140void* idrnet_recv(int sockfd, int len) {

151void* idrnet_recv(int sockfd, int len) {

141 if (!check_init()) {

152 if (!check_init()) {

142− return -1;

153+ return NULL;

143 }

154 }

144 idrnet_recv_result* res_struct =

155 idrnet_recv_result* res_struct =

145 (idrnet_recv_result*) malloc(sizeof(idrnet_recv_result));

156 (idrnet_recv_result*) malloc(sizeof(idrnet_recv_result));

rts/windows/idris_net.hdeleted−45

@@ -1,45 +0,0 @@

1−#ifndef IDRISNET_H

2−#define IDRISNET_H

3−

4−

5−typedef struct idrnet_recv_result {

6− int result;

7− void* payload;

8−} idrnet_recv_result;

9−

10−// Memory management functions

11−void* idrnet_malloc(int size);

12−void idrnet_free(void* ptr);

13−

14−// Gets value of errno

15−int idrnet_errno();

16−

17−// Bind

18−int idrnet_bind(int sockfd, int family, int socket_type, char* host, int port);

19−

20−// Connect

21−int idrnet_connect(int sockfd, int family, int socket_type, char* host, int port);

22−

23−// Accessor functions for struct_sockaddr

24−int idrnet_sockaddr_family(void* sockaddr);

25−char* idrnet_sockaddr_ipv4(void* sockaddr);

26−void* idrnet_create_sockaddr();

27−

28−// Accept

29−int idrnet_accept(int sockfd, void* sockaddr);

30−

31−// Send

32−int idrnet_send(int sockfd, char* data);

33−int idrnet_send_buf(int sockfd, void* data, int len);

34−

35−// Receive

36−// Creates a result structure containing result and payload

37−void* idrnet_recv(int sockfd, int len);

38−// Receives directly into a buffer

39−int idrnet_recv_buf(int sockfd, void* buf, int len);

40−

41−// Receive structure accessors

42−int idrnet_get_recv_res(void* res_struct);

43−void* idrnet_get_recv_payload(void* res_struct);

44−void idrnet_free_recv_struct(void* res_struct);

45−#endif

rts/windows/idris_stdfgn.c+13−1

@@ -1,7 +1,10 @@

1−#include "idris_stdfgn.h"

1+#include "../idris_stdfgn.h"

2#include "../idris_rts.h"

3+#include "../idris_gc.h"

4+

3#include <fcntl.h>

5#include <fcntl.h>

4#include <stdio.h>

6#include <stdio.h>

7+#include <time.h>

5

8

6extern char** environ;

9extern char** environ;

7

10

@@ -61,3 +64,12 @@ void* idris_stdin() {

61char* getEnvPair(int i) {

64char* getEnvPair(int i) {

62 return *(environ + i);

65 return *(environ + i);

63}

66}

67+

68+int idris_time() {

69+ time_t t = time(NULL);

70+ return (int)t;

71+}

72+

73+void idris_forceGC(void* vm) {

74+ idris_gc((VM*)vm);

75+}

rts/windows/idris_stdfgn.hdeleted−24

@@ -1,24 +0,0 @@

1−#ifndef _IDRISSTDFGN_H

2−#define _IDRISSTDFGN_H

3−

4−// A collection of useful standard functions to be used by the prelude.

5−

6−void putStr(char* str);

7−//char* readStr();

8−

9−void* fileOpen(char* f, char* mode);

10−void fileClose(void* h);

11−int fileEOF(void* h);

12−int fileError(void* h);

13−void fputStr(void*h, char* str);

14−

15−void* do_popen(const char* cmd, const char* mode);

16−int fpoll(void* h);

17−

18−int idris_eqPtr(void* x, void* y);

19−int isNull(void* ptr);

20−void* idris_stdin();

21−

22−char* getEnvPair(int i);

23−

24−#endif

samples/reflection.idr+25−25

@@ -2,93 +2,93 @@ module ReflectionExamples

2

3import Language.Reflection

4

5−-- | The reflected term for (\ x => reverse "bba")

5+||| The reflected term for (\ x => reverse "bba")

6reflectVal : TT

7reflectVal = ?valPrf

8

9−-- | intEq for the integers 3 and 3

9+||| intEq for the integers 3 and 3

10applyTac1 : Int

11applyTac1 = ?tacPrf1

12

13−-- | intEq for the integers 3 and 42

13+||| intEq for the integers 3 and 42

14applyTac0 : Int

15applyTac0 = ?tacPrf0

16

17−-- | intEq for the two arguments

17+||| intEq for the two arguments

18applyTacDyn : Int -> Int -> Int

19applyTacDyn x y = ?tacPrfDyn

20

21−-- | Restored version for RConstant (I 42)

21+||| Restored version for RConstant (I 42)

22fill : Int

23fill = ?fillPrf

24

25−-- | The type (TTName, TT) computed from its reflected raw rep.

25+||| The type (TTName, TT) computed from its reflected raw rep.

26envTuple : Type

27envTuple = ?envTuplePrf

28

29−-- | The type List (TTName, TT) computed from its reflected raw rep.

29+||| The type List (TTName, TT) computed from its reflected raw rep.

30envList : List (TTName, TT)

31envList = ?envListPrf

32

33−-- | Reflected raw rep. for the type (TTName, TT)

33+||| Reflected raw rep. for the type (TTName, TT)

34tupleType : Raw

35tupleType = RApp (RApp (Var (MN 0 "__Pair"))

36 (Var (NS (UN "TTName") ["Reflection", "Language"])))

37 (Var (NS (UN "TT") ["Reflection", "Language"]))

38

39−-- | Reflected raw rep for the type List (TTName, TT)

39+||| Reflected raw rep for the type List (TTName, TT)

40mkTuple : Raw

41mkTuple = RApp (RApp (Var (MN 0 "__MkPair"))

42 (Var (NS (UN "TTName") ["Reflection", "Language"])))

43 (Var (NS (UN "TT") ["Reflection", "Language"]))

44

45−-- | Reflected raw rep for Prelude.List.Nil

45+||| Reflected raw rep for Prelude.List.Nil

46nil : Raw

47nil = (Var (NS (UN "Nil") ["List", "Prelude"]))

48

49−-- | Reflected raw rep for Prelude.List.::

49+||| Reflected raw rep for Prelude.List.::

50cons : Raw

51cons = (Var (NS (UN "::") ["List", "Prelude"]))

52

53−-- | 1 if the two arguments are equal, 0 otherwise

53+||| 1 if the two arguments are equal, 0 otherwise

54−-- This function is chosen as simple as possible for

54+||| This function is chosen as simple as possible for

55−-- demo purposes.

55+||| demo purposes.

56intEq : Int -> Int -> Int

57intEq x y = case x == y of

58 True => 1

59 False => 0

60

61−-- | A tactic script to run intEq on two let-bound or introduced

61+||| A tactic script to run intEq on two let-bound or introduced

62−-- arguments of the current (otherwise empty) proof context

62+||| arguments of the current (otherwise empty) proof context

63firstEq : List (TTName, Binder TT) -> TT -> Tactic

64firstEq ((_, (Let _ y))::(_, (Let _ x))::(_, Let _ f)::Nil) _ = Exact (App (App f x) y)

65firstEq ((y, Lam yt)::(x, Lam xt)::(_, Let _ f)::Nil) _ = Exact (App (App f (P (Bound) x xt)) (P Bound y yt))

66firstEq xs _ = Exact (TConst (I 0))

67

68−-- | Skip 1 argument of the proof context and return the second one which

68+||| Skip 1 argument of the proof context and return the second one which

69−-- has to be introduced. Used for the tactical dispatch example, which

69+||| has to be introduced. Used for the tactical dispatch example, which

70−-- will push dispatch, as first env agrument.

70+||| will push dispatch, as first env agrument.

71innerTac : List (TTName, Binder TT) -> TT -> Tactic

72innerTac (_::(x, Lam xt)::_) _ = Exact (P Bound x xt)

73

74−-- | Returns the reflected representation of innerTac

74+||| Returns the reflected representation of innerTac

75innerTacTT : TT

76innerTacTT = ?innerTacTTPrf

77

78−-- | Dispatch to the reflected rep. of innerTac

78+||| Dispatch to the reflected rep. of innerTac

79dispatch : List (TTName, Binder TT) -> TT -> Tactic

80dispatch xs _ = ApplyTactic (innerTacTT)

81

82−-- | Call dispatch which will then dispatch to innerTac.

82+||| Call dispatch which will then dispatch to innerTac.

83tacticalDispatch : Int -> Int

84tacticalDispatch = ?tacticalDispatchPrf

85

86−-- | A tactic to get the representation of its goal

86+||| A tactic to get the representation of its goal

87studyGoalTac : List (TTName, Binder TT) -> TT -> Tactic

88studyGoalTac _ goal = Reflect goal

89

90−-- | Returns the representation of its goal, TT

90+||| Returns the representation of its goal, TT

91−-- (so this is reflect on the type TT)

91+||| (so this is reflect on the type TT)

92studyGoal : TT

93studyGoal = ?studyGoalPrf

94

src/IRTS/CodegenC.hs+35−18

@@ -20,16 +20,32 @@ import System.Directory

20import System.FilePath ((</>), (<.>))

21import Control.Monad

22

23+codegenC :: CodeGenerator

24+codegenC ci = codegenC' (simpleDecls ci)

25+ (outputFile ci)

26+ (outputType ci)

27+ (includes ci)

28+ (concatMap mkObj (compileObjs ci))

29+ (concatMap mkLib (compileLibs ci) ++

30+ concatMap incdir (importDirs ci))

31+ (concatMap mkFlag (compilerFlags ci))

32+ (debugLevel ci)

33+

34+ where mkObj f = f ++ " "

35+ mkLib l = "-l" ++ l ++ " "

36+ mkFlag l = l ++ " "

37+ incdir i = "-I" ++ i ++ " "

38+

23−codegenC :: [(Name, SDecl)] ->

39+codegenC' :: [(Name, SDecl)] ->

24− String -> -- output file name

40+ String -> -- output file name

25− OutputType -> -- generate executable if True, only .o if False

41+ OutputType -> -- generate executable if True, only .o if False

26− [FilePath] -> -- include files

42+ [FilePath] -> -- include files

27− String -> -- extra object files

43+ String -> -- extra object files

28− String -> -- extra compiler flags (libraries)

44+ String -> -- extra compiler flags (libraries)

29− String -> -- extra compiler flags (anything)

45+ String -> -- extra compiler flags (anything)

30− DbgLevel ->

46+ DbgLevel ->

31− IO ()

47+ IO ()

32−codegenC defs out exec incs objs libs flags dbg

48+codegenC' defs out exec incs objs libs flags dbg

33 = do -- print defs

49 = do -- print defs

34 let bc = map toBC defs

50 let bc = map toBC defs

35 let h = concatMap toDecl (map fst bc)

51 let h = concatMap toDecl (map fst bc)

@@ -46,7 +62,6 @@ codegenC defs out exec incs objs libs flags dbg

46 hPutStr tmph cout

62 hPutStr tmph cout

47 hFlush tmph

63 hFlush tmph

48 hClose tmph

64 hClose tmph

49− let useclang = False

50 comp <- getCC

65 comp <- getCC

51 libFlags <- getLibFlags

66 libFlags <- getLibFlags

52 incFlags <- getIncFlags

67 incFlags <- getIncFlags

@@ -132,10 +147,10 @@ bcc i (ASSIGNCONST l c)

132 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

147 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

133 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

148 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

134 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"

149 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"

135− mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"

150+ mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"

136− mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"

151+ mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"

137− mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"

152+ mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"

138− mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")"

153+ mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"

139 mkConst _ = "MKINT(42424242)"

154 mkConst _ = "MKINT(42424242)"

140bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

155bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

141bcc i (MKCON l tag args)

156bcc i (MKCON l tag args)

@@ -159,15 +174,15 @@ bcc i (CASE True r code def)

159 | length code < 4 = showCase i def code

174 | length code < 4 = showCase i def code

160 where

175 where

161 showCode :: Int -> [BC] -> String

176 showCode :: Int -> [BC] -> String

162− showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc ++

177+ showCode i bc = "{\n" ++ concatMap (bcc (i + 1)) bc ++

163 indent i ++ "}\n"

178 indent i ++ "}\n"

164

179

165 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String

180 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String

166 showCase i Nothing [(t, c)] = showCode i c

181 showCase i Nothing [(t, c)] = showCode i c

167 showCase i (Just def) [] = showCode i def

182 showCase i (Just def) [] = showCode i def

168 showCase i def ((t, c) : cs)

183 showCase i def ((t, c) : cs)

169− = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c

184+ = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c

170− ++ "else " ++ showCase i def cs

185+ ++ indent i ++ "else " ++ showCase i def cs

171

186

172bcc i (CASE safe r code def)

187bcc i (CASE safe r code def)

173 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++

188 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++

@@ -478,6 +493,8 @@ doOp v (LChInt ITNative) args = v ++ creg (last args)

478doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args

493doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args

479doOp v (LIntCh ITNative) args = v ++ creg (last args)

494doOp v (LIntCh ITNative) args = v ++ creg (last args)

480doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args

495doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args

496+

497+doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"

481doOp v LNoOp args = v ++ creg (last args)

498doOp v LNoOp args = v ++ creg (last args)

482doOp _ op _ = "FAIL /* " ++ show op ++ " */"

499doOp _ op _ = "FAIL /* " ++ show op ++ " */"

483

500

src/IRTS/CodegenCommon.hs+25

@@ -2,8 +2,11 @@ module IRTS.CodegenCommon where

2

3import Idris.Core.TT

4import IRTS.Simplified

5+import IRTS.Defunctionalise

6+import IRTS.Lang

5

7

6import Control.Exception

8import Control.Exception

9+import Data.Word

7import System.Environment

10import System.Environment

8

11

9data DbgLevel = NONE | DEBUG | TRACE deriving Eq

12data DbgLevel = NONE | DEBUG | TRACE deriving Eq

@@ -13,3 +16,25 @@ environment :: String -> IO (Maybe String)

13environment x = Control.Exception.catch (do e <- getEnv x

16environment x = Control.Exception.catch (do e <- getEnv x

14 return (Just e))

17 return (Just e))

15 (\y-> do return (y::SomeException); return Nothing)

18 (\y-> do return (y::SomeException); return Nothing)

19+

20+-- Everything which might be needed in a code generator - a CG can choose which

21+-- level of Decls to generate code from (simplified, defunctionalised or merely

22+-- lambda lifted) and has access to the list of object files, libraries, etc.

23+

24+data CodegenInfo = CodegenInfo { outputFile :: String,

25+ outputType :: OutputType,

26+ targetTriple :: String,

27+ targetCPU :: String,

28+ optimisation :: Word,

29+ includes :: [FilePath],

30+ importDirs :: [FilePath],

31+ compileObjs :: [String],

32+ compileLibs :: [String],

33+ compilerFlags :: [String],

34+ debugLevel :: DbgLevel,

35+ simpleDecls :: [(Name, SDecl)],

36+ defunDecls :: [(Name, DDecl)],

37+ liftDecls :: [(Name, LDecl)]

38+ }

39+

40+type CodeGenerator = CodegenInfo -> IO ()

src/IRTS/CodegenJava.hs+13−8

@@ -34,14 +34,19 @@ import System.Process

34

35-----------------------------------------------------------------------

36-- Main function

37+codegenJava :: CodeGenerator

38+codegenJava cg = codegenJava' [] (simpleDecls cg) (outputFile cg)

39+ (includes cg) (compileLibs cg)

40+ (outputType cg)

41+

37−codegenJava :: [(Name, SExp)] -> -- initialization of globals

42+codegenJava' :: [(Name, SExp)] -> -- initialization of globals

38− [(Name, SDecl)] -> -- decls

43+ [(Name, SDecl)] -> -- decls

39− FilePath -> -- output file name

44+ FilePath -> -- output file name

40− [String] -> -- headers

45+ [String] -> -- headers

41− [String] -> -- libs

46+ [String] -> -- libs

42− OutputType ->

47+ OutputType ->

43− IO ()

48+ IO ()

44−codegenJava globalInit defs out hdrs libs exec =

49+codegenJava' globalInit defs out hdrs libs exec =

45 withTgtDir exec out (codegenJava' exec)

50 withTgtDir exec out (codegenJava' exec)

46 where

51 where

47 codegenJava' :: OutputType -> FilePath -> IO ()

52 codegenJava' :: OutputType -> FilePath -> IO ()

src/IRTS/CodegenJavaScript.hs+731−112

@@ -1,6 +1,6 @@

1{-# LANGUAGE PatternGuards #-}

2

3−module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where

3+module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where

4

5import Idris.AbsSyntax hiding (TypeCase)

6import IRTS.Bytecode

@@ -17,9 +17,11 @@ import Data.Char

17import Numeric

18import Data.List

19import Data.Maybe

20+import Data.Word

20import System.IO

21import System.IO

21import System.Directory

22import System.Directory

22

23

24+

23idrNamespace :: String

25idrNamespace :: String

24idrNamespace = "__IDR__"

26idrNamespace = "__IDR__"

25idrRTNamespace = "__IDRRT__"

27idrRTNamespace = "__IDRRT__"

@@ -52,6 +54,20 @@ data JSNum = JSInt Int

52 deriving Eq

54 deriving Eq

53

55

54

56

57+data JSWord = JSWord8 Word8

58+ | JSWord16 Word16

59+ | JSWord32 Word32

60+ | JSWord64 Word64

61+ deriving Eq

62+

63+

64+data JSAnnotation = JSConstructor deriving Eq

65+

66+

67+instance Show JSAnnotation where

68+ show JSConstructor = "constructor"

69+

70+

55data JS = JSRaw String

71data JS = JSRaw String

56 | JSIdent String

72 | JSIdent String

57 | JSFunction [String] JS

73 | JSFunction [String] JS

@@ -73,6 +89,7 @@ data JS = JSRaw String

73 | JSArray [JS]

89 | JSArray [JS]

74 | JSString String

90 | JSString String

75 | JSNum JSNum

91 | JSNum JSNum

92+ | JSWord JSWord

76 | JSAssign JS JS

93 | JSAssign JS JS

77 | JSAlloc String (Maybe JS)

94 | JSAlloc String (Maybe JS)

78 | JSIndex JS JS

95 | JSIndex JS JS

@@ -80,13 +97,56 @@ data JS = JSRaw String

80 | JSTernary JS JS JS

97 | JSTernary JS JS JS

81 | JSParens JS

98 | JSParens JS

82 | JSWhile JS JS

99 | JSWhile JS JS

100+ | JSFFI String [JS]

101+ | JSAnnotation JSAnnotation JS

83 | JSNoop

102 | JSNoop

84 deriving Eq

103 deriving Eq

85

104

86

105

106+data FFI = FFICode Char | FFIArg Int | FFIError String

107+

108+

109+ffi :: String -> [String] -> String

110+ffi code args = let parsed = ffiParse code in

111+ case ffiError parsed of

112+ Just err -> error err

113+ Nothing -> renderFFI parsed args

114+ where

115+ ffiParse :: String -> [FFI]

116+ ffiParse "" = []

117+ ffiParse ['%'] = [FFIError $ "FFI - Invalid positional argument"]

118+ ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss

119+ ffiParse ('%':s:ss)

120+ | isDigit s =

121+ FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)

122+ | otherwise =

123+ [FFIError $ "FFI - Invalid positional argument"]

124+ ffiParse (s:ss) = FFICode s : ffiParse ss

125+

126+

127+ ffiError :: [FFI] -> Maybe String

128+ ffiError [] = Nothing

129+ ffiError ((FFIError s):xs) = Just s

130+ ffiError (x:xs) = ffiError xs

131+

132+

133+ renderFFI :: [FFI] -> [String] -> String

134+ renderFFI [] _ = ""

135+ renderFFI ((FFICode c) : fs) args = c : renderFFI fs args

136+ renderFFI ((FFIArg i) : fs) args

137+ | i < length args && i >= 0 = args !! i ++ renderFFI fs args

138+ | otherwise = error "FFI - Argument index out of bounds"

139+

140+

87compileJS :: JS -> String

141compileJS :: JS -> String

88compileJS JSNoop = ""

142compileJS JSNoop = ""

89

143

144+compileJS (JSAnnotation annotation js) =

145+ "/** @" ++ show annotation ++ " */\n" ++ compileJS js

146+

147+compileJS (JSFFI raw args) =

148+ ffi raw (map compileJS args)

149+

90compileJS (JSRaw code) =

150compileJS (JSRaw code) =

91 code

151 code

92

152

@@ -206,6 +266,13 @@ compileJS (JSWhile cond body) =

206 ++ compileJS body

266 ++ compileJS body

207 ++ "\n}"

267 ++ "\n}"

208

268

269+compileJS (JSWord word)

270+ | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"

271+ | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"

272+ | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"

273+ | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"

274+

275+

209jsTailcall :: JS -> JS

276jsTailcall :: JS -> JS

210jsTailcall call =

277jsTailcall call =

211 jsCall (idrRTNamespace ++ "tailcall") [

278 jsCall (idrRTNamespace ++ "tailcall") [

@@ -229,6 +296,8 @@ jsInstanceOf = JSBinOp "instanceof"

229jsEq :: JS -> JS -> JS

296jsEq :: JS -> JS -> JS

230jsEq = JSBinOp "=="

297jsEq = JSBinOp "=="

231

298

299+jsNotEq :: JS -> JS -> JS

300+jsNotEq = JSBinOp "!="

232

301

233jsAnd :: JS -> JS -> JS

302jsAnd :: JS -> JS -> JS

234jsAnd = JSBinOp "&&"

303jsAnd = JSBinOp "&&"

@@ -276,6 +345,28 @@ jsLet name value body =

276jsError :: String -> JS

345jsError :: String -> JS

277jsError err = JSApp (JSFunction [] (JSError err)) []

346jsError err = JSApp (JSFunction [] (JSError err)) []

278

347

348+jsUnPackBits :: JS -> JS

349+jsUnPackBits js = JSIndex js $ JSNum (JSInt 0)

350+

351+

352+jsPackUBits8 :: JS -> JS

353+jsPackUBits8 js = JSNew "Uint8Array" [JSArray [js]]

354+

355+jsPackUBits16 :: JS -> JS

356+jsPackUBits16 js = JSNew "Uint16Array" [JSArray [js]]

357+

358+jsPackUBits32 :: JS -> JS

359+jsPackUBits32 js = JSNew "Uint32Array" [JSArray [js]]

360+

361+jsPackSBits8 :: JS -> JS

362+jsPackSBits8 js = JSNew "Int8Array" [JSArray [js]]

363+

364+jsPackSBits16 :: JS -> JS

365+jsPackSBits16 js = JSNew "Int16Array" [JSArray [js]]

366+

367+jsPackSBits32 :: JS -> JS

368+jsPackSBits32 js = JSNew "Int32Array" [JSArray [js]]

369+

279

370

280foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a

371foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a

281foldJS tr add acc js =

372foldJS tr add acc js =

@@ -316,6 +407,10 @@ foldJS tr add acc js =

316 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds

407 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds

317 | JSWhile cond body <- js =

408 | JSWhile cond body <- js =

318 add (tr js) $ add (fold cond) (fold body)

409 add (tr js) $ add (fold cond) (fold body)

410+ | JSFFI raw args <- js =

411+ add (tr js) $ foldl' add acc $ map fold args

412+ | JSAnnotation a js <- js =

413+ add (tr js) $ fold js

319 | otherwise =

414 | otherwise =

320 tr js

415 tr js

321

416

@@ -342,7 +437,9 @@ transformJS tr js =

342 | JSCond conds <- js = JSCond $ map (tr *** tr) conds

437 | JSCond conds <- js = JSCond $ map (tr *** tr) conds

343 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)

438 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)

344 | JSParens val <- js = JSParens $ tr val

439 | JSParens val <- js = JSParens $ tr val

345− | JSWhile cond body <- js = JSWhile(tr cond) (tr body)

440+ | JSWhile cond body <- js = JSWhile (tr cond) (tr body)

441+ | JSFFI raw args <- js = JSFFI raw (map tr args)

442+ | JSAnnotation a js <- js = JSAnnotation a (tr js)

346 | otherwise = js

443 | otherwise = js

347

444

348

445

@@ -350,6 +447,9 @@ moveJSDeclToTop :: String -> [JS] -> [JS]

350moveJSDeclToTop decl js = move ([], js)

447moveJSDeclToTop decl js = move ([], js)

351 where

448 where

352 move :: ([JS], [JS]) -> [JS]

449 move :: ([JS], [JS]) -> [JS]

450+ move (front, js@(JSAnnotation _ (JSAlloc name _)):back)

451+ | name == decl = js : front ++ back

452+

353 move (front, js@(JSAlloc name _):back)

453 move (front, js@(JSAlloc name _):back)

354 | name == decl = js : front ++ back

454 | name == decl = js : front ++ back

355

455

@@ -519,8 +619,6 @@ removeEval js =

519 match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val

619 match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val

520 match js = transformJS match js

620 match js = transformJS match js

521

621

522− removeEvalApp js = js

523−

524 checkEval :: [JS] -> ([JS], Bool)

622 checkEval :: [JS] -> ([JS], Bool)

525 checkEval js = foldr f ([], False) $ map checkEval' js

623 checkEval js = foldr f ([], False) $ map checkEval' js

526 where

624 where

@@ -644,33 +742,56 @@ removeIDs js =

644 JSReturn (JSApp (JSIdent fun) args)

742 JSReturn (JSApp (JSIdent fun) args)

645 )])

743 )])

646 | Just pos <- lookup fun ids

744 | Just pos <- lookup fun ids

647− , pos < length args = args !! pos

745+ , pos < length args = removeIDCall ids (args !! pos)

648

746

649 removeIDCall ids (JSNew _ [JSFunction [] (

747 removeIDCall ids (JSNew _ [JSFunction [] (

650 JSReturn (JSApp (JSIdent fun) args)

748 JSReturn (JSApp (JSIdent fun) args)

651 )])

749 )])

652 | Just pos <- lookup fun ids

750 | Just pos <- lookup fun ids

653− , pos < length args = args !! pos

751+ , pos < length args = removeIDCall ids (args !! pos)

654

752

655 removeIDCall ids js@(JSApp id@(JSIdent fun) args)

753 removeIDCall ids js@(JSApp id@(JSIdent fun) args)

656 | Just pos <- lookup fun ids

754 | Just pos <- lookup fun ids

657− , pos < length args = args !! pos

755+ , pos < length args = removeIDCall ids (args !! pos)

658

756

659 removeIDCall ids js = transformJS (removeIDCall ids) js

757 removeIDCall ids js = transformJS (removeIDCall ids) js

660

758

661

759

760+inlineFunction :: String -> [String] -> JS -> JS -> JS

761+inlineFunction fun args body js = inline' js

762+ where

763+ inline' :: JS -> JS

764+ inline' (JSApp (JSIdent name) vals)

765+ | name == fun =

766+ let (js, phs) = insertPlaceHolders args body in

767+ inline' $ foldr (uncurry jsSubst) js (zip phs vals)

768+

769+ inline' js = transformJS inline' js

770+

771+ insertPlaceHolders :: [String] -> JS -> (JS, [JS])

772+ insertPlaceHolders args body = insertPlaceHolders' args body []

773+ where

774+ insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])

775+ insertPlaceHolders' (a:as) body ph

776+ | (body', ph') <- insertPlaceHolders' as body ph =

777+ let phvar = JSIdent $ "__PH_" ++ show (length ph') in

778+ (jsSubst (JSIdent a) phvar body', phvar : ph')

779+

780+ insertPlaceHolders' [] body ph = (body, ph)

781+

782+

662inlineFunctions :: [JS] -> [JS]

783inlineFunctions :: [JS] -> [JS]

663inlineFunctions js =

784inlineFunctions js =

664 inlineHelper ([], js)

785 inlineHelper ([], js)

665 where

786 where

666 inlineHelper :: ([JS], [JS]) -> [JS]

787 inlineHelper :: ([JS], [JS]) -> [JS]

667− inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)

788+ inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)

668 | countAll fun front + countAll fun back == 0 =

789 | countAll fun front + countAll fun back == 0 =

669 inlineHelper (front, back)

790 inlineHelper (front, back)

670 | Just new <- inlineAble (

791 | Just new <- inlineAble (

671 countAll fun front + countAll fun back

792 countAll fun front + countAll fun back

672 ) fun args body =

793 ) fun args body =

673− let f = map (inline fun args new) in

794+ let f = map (inlineFunction fun args new) in

674 inlineHelper (f front, f back)

795 inlineHelper (f front, f back)

675

796

676 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)

797 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)

@@ -687,29 +808,6 @@ inlineFunctions js =

687 inlineAble _ _ _ _ = Nothing

808 inlineAble _ _ _ _ = Nothing

688

809

689

810

690− inline :: String -> [String] -> JS -> JS -> JS

691− inline fun args body js = inline' js

692− where

693− inline' :: JS -> JS

694− inline' (JSApp (JSIdent name) vals)

695− | name == fun =

696− let (js, phs) = insertPlaceHolders args body in

697− inline' $ foldr (uncurry jsSubst) js (zip phs vals)

698−

699− inline' js = transformJS inline' js

700−

701− insertPlaceHolders :: [String] -> JS -> (JS, [JS])

702− insertPlaceHolders args body = insertPlaceHolders' args body []

703− where

704− insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])

705− insertPlaceHolders' (a:as) body ph

706− | (body', ph') <- insertPlaceHolders' as body ph =

707− let phvar = JSIdent $ "__PH_" ++ show (length ph') in

708− (jsSubst (JSIdent a) phvar body', phvar : ph')

709−

710− insertPlaceHolders' [] body ph = (body, ph)

711−

712−

713 nonRecur :: String -> JS -> Bool

811 nonRecur :: String -> JS -> Bool

714 nonRecur name body = countInvokations name body == 0

812 nonRecur name body = countInvokations name body == 0

715

813

@@ -1012,7 +1110,7 @@ unfoldLookupTable input =

1012 adaptCon js =

1110 adaptCon js =

1013 adaptCon' [] js

1111 adaptCon' [] js

1014 where

1112 where

1015− adaptCon' front ((JSAlloc "__IDRRT__Con" (Just _)):back) =

1113+ adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =

1016 front ++ (new:back)

1114 front ++ (new:back)

1017

1115

1018 adaptCon' front (next:back) =

1116 adaptCon' front (next:back) =

@@ -1022,11 +1120,12 @@ unfoldLookupTable input =

1022

1120

1023

1121

1024 new =

1122 new =

1123+ JSAnnotation JSConstructor $

1025− JSAlloc "__IDRRT__Con" (Just $

1124+ JSAlloc "__IDRRT__Con" (Just $

1026− JSFunction newArgs (

1125+ JSFunction newArgs (

1027− JSSeq (map newVar newArgs)

1126+ JSSeq (map newVar newArgs)

1127+ )

1028 )

1128 )

1029− )

1030 where

1129 where

1031 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)

1130 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)

1032 newArgs = ["tag", "eval", "app", "vars"]

1131 newArgs = ["tag", "eval", "app", "vars"]

@@ -1095,7 +1194,7 @@ unfoldLookupTable input =

1095

1194

1096removeInstanceChecks :: JS -> JS

1195removeInstanceChecks :: JS -> JS

1097removeInstanceChecks (JSCond conds) =

1196removeInstanceChecks (JSCond conds) =

1098− JSCond $ eliminateDeadBranches $ map (

1197+ removeNoopConds $ JSCond $ eliminateDeadBranches $ map (

1099 removeHelper *** removeInstanceChecks

1198 removeHelper *** removeInstanceChecks

1100 ) conds

1199 ) conds

1101 where

1200 where

@@ -1110,6 +1209,11 @@ removeInstanceChecks (JSCond conds) =

1110 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs

1209 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs

1111 eliminateDeadBranches [] = []

1210 eliminateDeadBranches [] = []

1112

1211

1212+

1213+ removeNoopConds :: JS -> JS

1214+ removeNoopConds (JSCond [(JSNoop, js)]) = js

1215+ removeNoopConds js = js

1216+

1113removeInstanceChecks js = transformJS removeInstanceChecks js

1217removeInstanceChecks js = transformJS removeInstanceChecks js

1114

1218

1115

1219

@@ -1314,6 +1418,67 @@ evalCons js =

1314 match js = transformJS match js

1418 match js = transformJS match js

1315

1419

1316

1420

1421+elimConds :: [JS] -> [JS]

1422+elimConds js =

1423+ let (conds, rest) = partition isCond js in

1424+ foldl' eraseCond rest conds

1425+ where

1426+ isCond :: JS -> Bool

1427+ isCond (JSAlloc

1428+ fun (Just (JSFunction args (JSCond

1429+ [ (JSBinOp "==" (JSNum (JSInt tag)) (JSProj (JSIdent _) "tag"), JSReturn t)

1430+ , (JSNoop, JSReturn f)

1431+ ])))

1432+ )

1433+ | isJSConstant t && isJSConstant f =

1434+ True

1435+

1436+ | JSIdent _ <- t

1437+ , JSIdent _ <- f =

1438+ True

1439+

1440+ isCond (JSAlloc

1441+ fun (Just (JSFunction args (JSCond

1442+ [ (JSBinOp "==" (JSIdent _) c, JSReturn t)

1443+ , (JSNoop, JSReturn f)

1444+ ])))

1445+ )

1446+ | isJSConstant t && isJSConstant f && isJSConstant c =

1447+ True

1448+

1449+ | JSIdent _ <- t

1450+ , JSIdent _ <- f

1451+ , isJSConstant c =

1452+ True

1453+

1454+ isCond _ = False

1455+

1456+

1457+ eraseCond :: [JS] -> JS -> [JS]

1458+ eraseCond js (JSAlloc

1459+ fun (Just (JSFunction args (JSCond

1460+ [ (c, JSReturn t)

1461+ , (_, JSReturn f)

1462+ ])

1463+ )

1464+ )) = map (inlineFunction fun args (JSTernary c t f)) js

1465+

1466+

1467+removeUselessCons :: [JS] -> [JS]

1468+removeUselessCons js =

1469+ let (cons, rest) = partition isUseless js in

1470+ foldl' eraseCon rest cons

1471+ where

1472+ isUseless :: JS -> Bool

1473+ isUseless (JSAlloc fun (Just JSNull)) = True

1474+ isUseless (JSAlloc fun (Just (JSIdent _))) = True

1475+ isUseless _ = False

1476+

1477+

1478+ eraseCon :: [JS] -> JS -> [JS]

1479+ eraseCon js (JSAlloc fun (Just val)) = map (jsSubst (JSIdent fun) val) js

1480+

1481+

1317getGlobalCons :: JS -> [(String, JS)]

1482getGlobalCons :: JS -> [(String, JS)]

1318getGlobalCons js = foldJS match (++) [] js

1483getGlobalCons js = foldJS match (++) [] js

1319 where

1484 where

@@ -1330,15 +1495,23 @@ getGlobalCons js = foldJS match (++) [] js

1330getIncludes :: [FilePath] -> IO [String]

1495getIncludes :: [FilePath] -> IO [String]

1331getIncludes = mapM readFile

1496getIncludes = mapM readFile

1332

1497

1333−codegenJavaScript

1498+codegenJavaScript :: CodeGenerator

1499+codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)

1500+ (includes ci) (outputFile ci) (outputType ci)

1501+

1502+codegenNode :: CodeGenerator

1503+codegenNode ci = codegenJS_all Node (simpleDecls ci)

1504+ (includes ci) (outputFile ci) (outputType ci)

1505+

1506+codegenJS_all

1334 :: JSTarget

1507 :: JSTarget

1335 -> [(Name, SDecl)]

1508 -> [(Name, SDecl)]

1336 -> [FilePath]

1509 -> [FilePath]

1337 -> FilePath

1510 -> FilePath

1338 -> OutputType

1511 -> OutputType

1339 -> IO ()

1512 -> IO ()

1340−codegenJavaScript target definitions includes filename outputType = do

1513+codegenJS_all target definitions includes filename outputType = do

1341− let (header, runtime) = case target of

1514+ let (header, rt) = case target of

1342 Node ->

1515 Node ->

1343 ("#!/usr/bin/env node\n", "-node")

1516 ("#!/usr/bin/env node\n", "-node")

1344 JavaScript ->

1517 JavaScript ->

@@ -1346,13 +1519,10 @@ codegenJavaScript target definitions includes filename outputType = do

1346 included <- getIncludes includes

1519 included <- getIncludes includes

1347 path <- (++) <$> getDataDir <*> (pure "/jsrts/")

1520 path <- (++) <$> getDataDir <*> (pure "/jsrts/")

1348 idrRuntime <- readFile $ path ++ "Runtime-common.js"

1521 idrRuntime <- readFile $ path ++ "Runtime-common.js"

1349− tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]

1522+ tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]

1350 jsbn <- readFile $ path ++ "jsbn/jsbn.js"

1523 jsbn <- readFile $ path ++ "jsbn/jsbn.js"

1351 writeFile filename $ header ++ (

1524 writeFile filename $ header ++ (

1352− intercalate "\n" $ included ++ [ jsbn

1525+ intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions

1353− , idrRuntime

1354− , tgtRuntime

1355− ] ++ functions

1356 )

1526 )

1357

1527

1358 setPermissions filename (emptyPermissions { readable = True

1528 setPermissions filename (emptyPermissions { readable = True

@@ -1364,15 +1534,33 @@ codegenJavaScript target definitions includes filename outputType = do

1364 def = map (first translateNamespace) definitions

1534 def = map (first translateNamespace) definitions

1365

1535

1366

1536

1367− functions :: [String]

1537+ checkForBigInt :: [JS] -> Bool

1538+ checkForBigInt js = occur

1539+ where

1540+ occur :: Bool

1541+ occur = or $ map (foldJS match (||) False) js

1542+

1543+ match :: JS -> Bool

1544+ match (JSIdent "__IDRRT__bigInt") = True

1545+ match (JSWord (JSWord64 _)) = True

1546+ match (JSNum (JSInteger _)) = True

1547+ match js = False

1548+

1549+

1550+ runtime :: String -> String -> String -> [String]

1551+ runtime jsbn idrRuntime tgtRuntime =

1552+ if checkForBigInt optimized

1553+ then [jsbn, idrRuntime, tgtRuntime]

1554+ else [idrRuntime, tgtRuntime]

1555+

1556+

1557+ optimized :: [JS]

1368− functions = translate >>> optimize >>> compile $ def

1558+ optimized = translate >>> optimize $ def

1369 where

1559 where

1370 translate p =

1560 translate p =

1371 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]

1561 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]

1372 optimize p =

1562 optimize p =

1373 foldl' (flip ($)) p opt

1563 foldl' (flip ($)) p opt

1374− compile =

1375− map compileJS

1376

1564

1377 opt =

1565 opt =

1378 [ removeEval

1566 [ removeEval

@@ -1392,39 +1580,59 @@ codegenJavaScript target definitions includes filename outputType = do

1392 , extractLocalConstructors

1580 , extractLocalConstructors

1393 , unfoldLookupTable

1581 , unfoldLookupTable

1394 , evalCons

1582 , evalCons

1583+ , elimConds

1584+ , removeUselessCons

1395 ]

1585 ]

1396

1586

1587+ functions :: [String]

1588+ functions = map compileJS optimized

1589+

1397 prelude :: [JS]

1590 prelude :: [JS]

1398 prelude =

1591 prelude =

1592+ [ JSAnnotation JSConstructor $

1399− [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (

1593+ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (

1400− JSAssign (JSProj JSThis "k") (JSIdent "k")

1594+ JSAssign (JSProj JSThis "k") (JSIdent "k")

1401− ))

1595+ ))

1596+ , JSAnnotation JSConstructor $

1402− , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (

1597+ JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (

1403− JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")

1598+ JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")

1404− , JSAssign (JSProj JSThis "vars") (JSIdent "vars")

1599+ , JSAssign (JSProj JSThis "vars") (JSIdent "vars")

1405− ]

1600+ ]

1406− ))

1601+ ))

1407 ]

1602 ]

1408

1603

1409 mainLoop :: JS

1604 mainLoop :: JS

1410 mainLoop =

1605 mainLoop =

1411− JSAlloc "main" $ Just $ JSFunction [] (

1606+ JSAlloc "main" $ Just $ JSFunction [] (

1412− case target of

1607+ case target of

1413− Node -> mainFun

1608+ Node -> mainFun

1414− JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [

1609+ JavaScript -> JSCond [ (exists document `jsAnd` isReady, mainFun)

1415− JSString "DOMContentLoaded", JSFunction [] (

1610+ , (exists window, windowMainFun)

1416− mainFun

1611+ , (JSTrue, mainFun)

1417− ), JSFalse

1418− ])]

1612+ ]

1419 )

1613 )

1420 where

1614 where

1615+ exists :: JS -> JS

1616+ exists js = (JSPreOp "typeof " js) `jsNotEq` JSString "undefined"

1617+

1421 mainFun :: JS

1618 mainFun :: JS

1422 mainFun = jsTailcall $ jsCall runMain []

1619 mainFun = jsTailcall $ jsCall runMain []

1423

1620

1621+ window :: JS

1622+ window = JSIdent "window"

1424

1623

1425− isReady :: JS

1624+ document :: JS

1426− isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"

1625+ document = JSIdent "document"

1427

1626

1627+ windowMainFun :: JS

1628+ windowMainFun = jsMeth window "addEventListener" [

1629+ JSString "DOMContentLoaded"

1630+ , JSFunction [] ( mainFun )

1631+ , JSFalse

1632+ ]

1633+

1634+ isReady :: JS

1635+ isReady = JSParens $ readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"

1428

1636

1429 readyState :: JS

1637 readyState :: JS

1430 readyState = JSProj (JSIdent "document") "readyState"

1638 readyState = JSProj (JSIdent "document") "readyState"

@@ -1542,6 +1750,10 @@ translateConstant (AType (ATInt ITChar)) = JSType JSCharTy

1542translateConstant PtrType = JSType JSPtrTy

1750translateConstant PtrType = JSType JSPtrTy

1543translateConstant Forgot = JSType JSForgotTy

1751translateConstant Forgot = JSType JSForgotTy

1544translateConstant (BI i) = jsBigInt $ JSString (show i)

1752translateConstant (BI i) = jsBigInt $ JSString (show i)

1753+translateConstant (B8 b) = JSWord (JSWord8 b)

1754+translateConstant (B16 b) = JSWord (JSWord16 b)

1755+translateConstant (B32 b) = JSWord (JSWord32 b)

1756+translateConstant (B64 b) = JSWord (JSWord64 b)

1545translateConstant c =

1757translateConstant c =

1546 jsError $ "Unimplemented Constant: " ++ show c

1758 jsError $ "Unimplemented Constant: " ++ show c

1547

1759

@@ -1718,6 +1930,10 @@ translateExpression (SApp tc name vars)

1718translateExpression (SOp op vars)

1930translateExpression (SOp op vars)

1719 | LNoOp <- op = JSVar (last vars)

1931 | LNoOp <- op = JSVar (last vars)

1720

1932

1933+ | (LZExt (ITFixed IT8) ITNative) <- op = jsUnPackBits $ JSVar (last vars)

1934+ | (LZExt (ITFixed IT16) ITNative) <- op = jsUnPackBits $ JSVar (last vars)

1935+ | (LZExt (ITFixed IT32) ITNative) <- op = jsUnPackBits $ JSVar (last vars)

1936+

1721 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]

1937 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]

1722 | (LPlus (ATInt ITBig)) <- op

1938 | (LPlus (ATInt ITBig)) <- op

1723 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]

1939 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]

@@ -1759,6 +1975,435 @@ translateExpression (SOp op vars)

1759 | (LSGe ATFloat) <- op

1975 | (LSGe ATFloat) <- op

1760 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs

1976 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs

1761

1977

1978+ | (LPlus (ATInt ITChar)) <- op

1979+ , (lhs:rhs:_) <- vars =

1980+ jsCall "__IDRRT__fromCharCode" [

1981+ JSBinOp "+" (

1982+ jsCall "__IDRRT__charCode" [JSVar lhs]

1983+ ) (

1984+ jsCall "__IDRRT__charCode" [JSVar rhs]

1985+ )

1986+ ]

1987+

1988+ | (LTrunc (ITFixed IT16) (ITFixed IT8)) <- op

1989+ , (arg:_) <- vars =

1990+ jsPackUBits8 (

1991+ JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFF))

1992+ )

1993+

1994+ | (LTrunc (ITFixed IT32) (ITFixed IT16)) <- op

1995+ , (arg:_) <- vars =

1996+ jsPackUBits16 (

1997+ JSBinOp "&" (jsUnPackBits $ JSVar arg) (JSNum (JSInt 0xFFFF))

1998+ )

1999+

2000+ | (LTrunc (ITFixed IT64) (ITFixed IT32)) <- op

2001+ , (arg:_) <- vars =

2002+ jsPackUBits32 (

2003+ jsMeth (jsMeth (JSVar arg) "and" [

2004+ jsBigInt (JSString $ show 0xFFFFFFFF)

2005+ ]) "intValue" []

2006+ )

2007+

2008+ | (LTrunc ITBig (ITFixed IT64)) <- op

2009+ , (arg:_) <- vars =

2010+ jsMeth (JSVar arg) "and" [

2011+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)

2012+ ]

2013+

2014+ | (LLSHR (ITFixed IT8)) <- op

2015+ , (lhs:rhs:_) <- vars =

2016+ jsPackUBits8 (

2017+ JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)

2018+ )

2019+

2020+ | (LLSHR (ITFixed IT16)) <- op

2021+ , (lhs:rhs:_) <- vars =

2022+ jsPackUBits16 (

2023+ JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)

2024+ )

2025+

2026+ | (LLSHR (ITFixed IT32)) <- op

2027+ , (lhs:rhs:_) <- vars =

2028+ jsPackUBits32 (

2029+ JSBinOp ">>" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)

2030+ )

2031+

2032+ | (LLSHR (ITFixed IT64)) <- op

2033+ , (lhs:rhs:_) <- vars =

2034+ jsMeth (JSVar lhs) "shiftRight" [JSVar rhs]

2035+

2036+ | (LSHL (ITFixed IT8)) <- op

2037+ , (lhs:rhs:_) <- vars =

2038+ jsPackUBits8 (

2039+ JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)

2040+ )

2041+

2042+ | (LSHL (ITFixed IT16)) <- op

2043+ , (lhs:rhs:_) <- vars =

2044+ jsPackUBits16 (

2045+ JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)

2046+ )

2047+

2048+ | (LSHL (ITFixed IT32)) <- op

2049+ , (lhs:rhs:_) <- vars =

2050+ jsPackUBits32 (

2051+ JSBinOp "<<" (jsUnPackBits $ JSVar lhs) (jsUnPackBits $ JSVar rhs)

2052+ )

2053+

2054+ | (LSHL (ITFixed IT64)) <- op

2055+ , (lhs:rhs:_) <- vars =

2056+ jsMeth (jsMeth (JSVar lhs) "shiftLeft" [JSVar rhs]) "and" [

2057+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)

2058+ ]

2059+

2060+ | (LAnd (ITFixed IT8)) <- op

2061+ , (lhs:rhs:_) <- vars =

2062+ jsPackUBits8 (

2063+ JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2064+ )

2065+

2066+ | (LAnd (ITFixed IT16)) <- op

2067+ , (lhs:rhs:_) <- vars =

2068+ jsPackUBits16 (

2069+ JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2070+ )

2071+

2072+ | (LAnd (ITFixed IT32)) <- op

2073+ , (lhs:rhs:_) <- vars =

2074+ jsPackUBits32 (

2075+ JSBinOp "&" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2076+ )

2077+

2078+ | (LAnd (ITFixed IT64)) <- op

2079+ , (lhs:rhs:_) <- vars =

2080+ jsMeth (JSVar lhs) "and" [JSVar rhs]

2081+

2082+ | (LOr (ITFixed IT8)) <- op

2083+ , (lhs:rhs:_) <- vars =

2084+ jsPackUBits8 (

2085+ JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2086+ )

2087+

2088+ | (LOr (ITFixed IT16)) <- op

2089+ , (lhs:rhs:_) <- vars =

2090+ jsPackUBits16 (

2091+ JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2092+ )

2093+

2094+ | (LOr (ITFixed IT32)) <- op

2095+ , (lhs:rhs:_) <- vars =

2096+ jsPackUBits32 (

2097+ JSBinOp "|" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2098+ )

2099+

2100+ | (LOr (ITFixed IT64)) <- op

2101+ , (lhs:rhs:_) <- vars =

2102+ jsMeth (JSVar lhs) "or" [JSVar rhs]

2103+

2104+ | (LXOr (ITFixed IT8)) <- op

2105+ , (lhs:rhs:_) <- vars =

2106+ jsPackUBits8 (

2107+ JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2108+ )

2109+

2110+ | (LXOr (ITFixed IT16)) <- op

2111+ , (lhs:rhs:_) <- vars =

2112+ jsPackUBits16 (

2113+ JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2114+ )

2115+

2116+ | (LXOr (ITFixed IT32)) <- op

2117+ , (lhs:rhs:_) <- vars =

2118+ jsPackUBits32 (

2119+ JSBinOp "^" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2120+ )

2121+

2122+ | (LXOr (ITFixed IT64)) <- op

2123+ , (lhs:rhs:_) <- vars =

2124+ jsMeth (JSVar lhs) "xor" [JSVar rhs]

2125+

2126+ | (LPlus (ATInt (ITFixed IT8))) <- op

2127+ , (lhs:rhs:_) <- vars =

2128+ jsPackUBits8 (

2129+ JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2130+ )

2131+

2132+ | (LPlus (ATInt (ITFixed IT16))) <- op

2133+ , (lhs:rhs:_) <- vars =

2134+ jsPackUBits16 (

2135+ JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2136+ )

2137+

2138+ | (LPlus (ATInt (ITFixed IT32))) <- op

2139+ , (lhs:rhs:_) <- vars =

2140+ jsPackUBits32 (

2141+ JSBinOp "+" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2142+ )

2143+

2144+ | (LPlus (ATInt (ITFixed IT64))) <- op

2145+ , (lhs:rhs:_) <- vars =

2146+ jsMeth (jsMeth (JSVar lhs) "add" [JSVar rhs]) "and" [

2147+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)

2148+ ]

2149+

2150+ | (LMinus (ATInt (ITFixed IT8))) <- op

2151+ , (lhs:rhs:_) <- vars =

2152+ jsPackUBits8 (

2153+ JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2154+ )

2155+

2156+ | (LMinus (ATInt (ITFixed IT16))) <- op

2157+ , (lhs:rhs:_) <- vars =

2158+ jsPackUBits16 (

2159+ JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2160+ )

2161+

2162+ | (LMinus (ATInt (ITFixed IT32))) <- op

2163+ , (lhs:rhs:_) <- vars =

2164+ jsPackUBits32 (

2165+ JSBinOp "-" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2166+ )

2167+

2168+ | (LMinus (ATInt (ITFixed IT64))) <- op

2169+ , (lhs:rhs:_) <- vars =

2170+ jsMeth (jsMeth (JSVar lhs) "subtract" [JSVar rhs]) "and" [

2171+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)

2172+ ]

2173+

2174+ | (LTimes (ATInt (ITFixed IT8))) <- op

2175+ , (lhs:rhs:_) <- vars =

2176+ jsPackUBits8 (

2177+ JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2178+ )

2179+

2180+ | (LTimes (ATInt (ITFixed IT16))) <- op

2181+ , (lhs:rhs:_) <- vars =

2182+ jsPackUBits16 (

2183+ JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2184+ )

2185+

2186+ | (LTimes (ATInt (ITFixed IT32))) <- op

2187+ , (lhs:rhs:_) <- vars =

2188+ jsPackUBits32 (

2189+ JSBinOp "*" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2190+ )

2191+

2192+ | (LTimes (ATInt (ITFixed IT64))) <- op

2193+ , (lhs:rhs:_) <- vars =

2194+ jsMeth (jsMeth (JSVar lhs) "multiply" [JSVar rhs]) "and" [

2195+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)

2196+ ]

2197+

2198+ | (LEq (ATInt (ITFixed IT8))) <- op

2199+ , (lhs:rhs:_) <- vars =

2200+ jsPackUBits8 (

2201+ JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2202+ )

2203+

2204+ | (LEq (ATInt (ITFixed IT16))) <- op

2205+ , (lhs:rhs:_) <- vars =

2206+ jsPackUBits16 (

2207+ JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2208+ )

2209+

2210+ | (LEq (ATInt (ITFixed IT32))) <- op

2211+ , (lhs:rhs:_) <- vars =

2212+ jsPackUBits32 (

2213+ JSBinOp "==" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2214+ )

2215+

2216+ | (LEq (ATInt (ITFixed IT64))) <- op

2217+ , (lhs:rhs:_) <- vars =

2218+ jsMeth (jsMeth (JSVar lhs) "equals" [JSVar rhs]) "and" [

2219+ jsBigInt (JSString $ show 0xFFFFFFFFFFFFFFFF)

2220+ ]

2221+

2222+ | (LLt (ITFixed IT8)) <- op

2223+ , (lhs:rhs:_) <- vars =

2224+ jsPackUBits8 (

2225+ JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2226+ )

2227+

2228+ | (LLt (ITFixed IT16)) <- op

2229+ , (lhs:rhs:_) <- vars =

2230+ jsPackUBits16 (

2231+ JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2232+ )

2233+

2234+ | (LLt (ITFixed IT32)) <- op

2235+ , (lhs:rhs:_) <- vars =

2236+ jsPackUBits32 (

2237+ JSBinOp "<" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2238+ )

2239+

2240+ | (LLt (ITFixed IT64)) <- op

2241+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]

2242+

2243+ | (LLe (ITFixed IT8)) <- op

2244+ , (lhs:rhs:_) <- vars =

2245+ jsPackUBits8 (

2246+ JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2247+ )

2248+

2249+ | (LLe (ITFixed IT16)) <- op

2250+ , (lhs:rhs:_) <- vars =

2251+ jsPackUBits16 (

2252+ JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2253+ )

2254+

2255+ | (LLe (ITFixed IT32)) <- op

2256+ , (lhs:rhs:_) <- vars =

2257+ jsPackUBits32 (

2258+ JSBinOp "<=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2259+ )

2260+

2261+ | (LLe (ITFixed IT64)) <- op

2262+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]

2263+

2264+ | (LGt (ITFixed IT8)) <- op

2265+ , (lhs:rhs:_) <- vars =

2266+ jsPackUBits8 (

2267+ JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2268+ )

2269+

2270+ | (LGt (ITFixed IT16)) <- op

2271+ , (lhs:rhs:_) <- vars =

2272+ jsPackUBits16 (

2273+ JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2274+ )

2275+ | (LGt (ITFixed IT32)) <- op

2276+ , (lhs:rhs:_) <- vars =

2277+ jsPackUBits32 (

2278+ JSBinOp ">" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2279+ )

2280+

2281+ | (LGt (ITFixed IT64)) <- op

2282+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]

2283+

2284+ | (LGe (ITFixed IT8)) <- op

2285+ , (lhs:rhs:_) <- vars =

2286+ jsPackUBits8 (

2287+ JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2288+ )

2289+

2290+ | (LGe (ITFixed IT16)) <- op

2291+ , (lhs:rhs:_) <- vars =

2292+ jsPackUBits16 (

2293+ JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2294+ )

2295+ | (LGe (ITFixed IT32)) <- op

2296+ , (lhs:rhs:_) <- vars =

2297+ jsPackUBits32 (

2298+ JSBinOp ">=" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2299+ )

2300+

2301+ | (LGe (ITFixed IT64)) <- op

2302+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]

2303+

2304+ | (LUDiv (ITFixed IT8)) <- op

2305+ , (lhs:rhs:_) <- vars =

2306+ jsPackUBits8 (

2307+ JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2308+ )

2309+

2310+ | (LUDiv (ITFixed IT16)) <- op

2311+ , (lhs:rhs:_) <- vars =

2312+ jsPackUBits16 (

2313+ JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2314+ )

2315+

2316+ | (LUDiv (ITFixed IT32)) <- op

2317+ , (lhs:rhs:_) <- vars =

2318+ jsPackUBits32 (

2319+ JSBinOp "/" (jsUnPackBits (JSVar lhs)) (jsUnPackBits (JSVar rhs))

2320+ )

2321+

2322+ | (LUDiv (ITFixed IT64)) <- op

2323+ , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]

2324+

2325+ | (LSDiv (ATInt (ITFixed IT8))) <- op

2326+ , (lhs:rhs:_) <- vars =

2327+ jsPackSBits8 (

2328+ JSBinOp "/" (

2329+ jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)

2330+ ) (

2331+ jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)

2332+ )

2333+ )

2334+

2335+ | (LSDiv (ATInt (ITFixed IT16))) <- op

2336+ , (lhs:rhs:_) <- vars =

2337+ jsPackSBits16 (

2338+ JSBinOp "/" (

2339+ jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)

2340+ ) (

2341+ jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)

2342+ )

2343+ )

2344+

2345+ | (LSDiv (ATInt (ITFixed IT32))) <- op

2346+ , (lhs:rhs:_) <- vars =

2347+ jsPackSBits32 (

2348+ JSBinOp "/" (

2349+ jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)

2350+ ) (

2351+ jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)

2352+ )

2353+ )

2354+

2355+ | (LSDiv (ATInt (ITFixed IT64))) <- op

2356+ , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]

2357+

2358+ | (LSRem (ATInt (ITFixed IT8))) <- op

2359+ , (lhs:rhs:_) <- vars =

2360+ jsPackSBits8 (

2361+ JSBinOp "%" (

2362+ jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar lhs)

2363+ ) (

2364+ jsUnPackBits $ jsPackSBits8 $ jsUnPackBits (JSVar rhs)

2365+ )

2366+ )

2367+

2368+ | (LSRem (ATInt (ITFixed IT16))) <- op

2369+ , (lhs:rhs:_) <- vars =

2370+ jsPackSBits16 (

2371+ JSBinOp "%" (

2372+ jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar lhs)

2373+ ) (

2374+ jsUnPackBits $ jsPackSBits16 $ jsUnPackBits (JSVar rhs)

2375+ )

2376+ )

2377+

2378+ | (LSRem (ATInt (ITFixed IT32))) <- op

2379+ , (lhs:rhs:_) <- vars =

2380+ jsPackSBits32 (

2381+ JSBinOp "%" (

2382+ jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar lhs)

2383+ ) (

2384+ jsUnPackBits $ jsPackSBits32 $ jsUnPackBits (JSVar rhs)

2385+ )

2386+ )

2387+

2388+ | (LSRem (ATInt (ITFixed IT64))) <- op

2389+ , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]

2390+

2391+ | (LCompl (ITFixed IT8)) <- op

2392+ , (arg:_) <- vars =

2393+ jsPackSBits8 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)

2394+

2395+ | (LCompl (ITFixed IT16)) <- op

2396+ , (arg:_) <- vars =

2397+ jsPackSBits16 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)

2398+

2399+ | (LCompl (ITFixed IT32)) <- op

2400+ , (arg:_) <- vars =

2401+ jsPackSBits32 $ JSPreOp "~" $ jsUnPackBits (JSVar arg)

2402+

2403+ | (LCompl (ITFixed IT64)) <- op

2404+ , (arg:_) <- vars =

2405+ invokeMeth arg "not" []

2406+

1762 | (LPlus _) <- op

2407 | (LPlus _) <- op

1763 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

2408 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

1764 | (LMinus _) <- op

2409 | (LMinus _) <- op

@@ -1793,7 +2438,7 @@ translateExpression (SOp op vars)

1793 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)

2438 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)

1794

2439

1795 | LStrConcat <- op

2440 | LStrConcat <- op

1796− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

2441+ , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]

1797 | LStrEq <- op

2442 | LStrEq <- op

1798 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs

2443 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs

1799 | LStrLt <- op

2444 | LStrLt <- op

@@ -1822,9 +2467,9 @@ translateExpression (SOp op vars)

1822 | (LFloatInt ITNative) <- op

2467 | (LFloatInt ITNative) <- op

1823 , (arg:_) <- vars = JSVar arg

2468 , (arg:_) <- vars = JSVar arg

1824 | (LChInt ITNative) <- op

2469 | (LChInt ITNative) <- op

1825− , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"

2470+ , (arg:_) <- vars = jsCall "__IDRRT__charCode" [JSVar arg]

1826 | (LIntCh ITNative) <- op

2471 | (LIntCh ITNative) <- op

1827− , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]

2472+ , (arg:_) <- vars = jsCall "__IDRRT__fromCharCode" [JSVar arg]

1828

2473

1829 | LFExp <- op

2474 | LFExp <- op

1830 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]

2475 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]

@@ -1850,7 +2495,7 @@ translateExpression (SOp op vars)

1850 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]

2495 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]

1851

2496

1852 | LStrCons <- op

2497 | LStrCons <- op

1853− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

2498+ , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]

1854 | LStrHead <- op

2499 | LStrHead <- op

1855 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))

2500 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))

1856 | LStrRev <- op

2501 | LStrRev <- op

@@ -1863,12 +2508,14 @@ translateExpression (SOp op vars)

1863 JSNum (JSInt 1),

2508 JSNum (JSInt 1),

1864 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))

2509 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))

1865 ]

2510 ]

2511+ | LSystemInfo <- op

2512+ , (arg:_) <- vars = jsCall "__IDRRT__systemInfo" [JSVar arg]

1866 | LNullPtr <- op

2513 | LNullPtr <- op

1867 , (_) <- vars = JSNull

2514 , (_) <- vars = JSNull

1868

2515

1869 where

2516 where

1870 translateBinaryOp :: String -> LVar -> LVar -> JS

2517 translateBinaryOp :: String -> LVar -> LVar -> JS

1871− translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs)

2518+ translateBinaryOp f lhs rhs = JSParens $ JSBinOp f (JSVar lhs) (JSVar rhs)

1872

2519

1873

2520

1874 invokeMeth :: LVar -> String -> [LVar] -> JS

2521 invokeMeth :: LVar -> String -> [LVar] -> JS

@@ -1886,17 +2533,24 @@ translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =

1886translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =

2533translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =

1887 JSBinOp "==" (JSVar lhs) (JSVar rhs)

2534 JSBinOp "==" (JSVar lhs) (JSVar rhs)

1888

2535

2536+translateExpression (SForeign _ _ "idris_time" []) =

2537+ JSRaw "(new Date()).getTime()"

2538+

1889translateExpression (SForeign _ _ fun args) =

2539translateExpression (SForeign _ _ fun args) =

1890− ffi fun (map generateWrapper args)

2540+ JSFFI fun (map generateWrapper args)

1891 where

2541 where

1892 generateWrapper (ffunc, name)

2542 generateWrapper (ffunc, name)

1893 | FFunction <- ffunc =

2543 | FFunction <- ffunc =

2544+ JSApp (

2545+ JSIdent $ idrRTNamespace ++ "ffiWrap"

1894− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"

2546+ ) [JSIdent $ translateVariableName name]

1895 | FFunctionIO <- ffunc =

2547 | FFunctionIO <- ffunc =

2548+ JSApp (

2549+ JSIdent $ idrRTNamespace ++ "ffiWrap"

1896− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"

2550+ ) [JSIdent $ translateVariableName name]

1897

2551

1898 generateWrapper (_, name) =

2552 generateWrapper (_, name) =

1899− translateVariableName name

2553+ JSIdent $ translateVariableName name

1900

2554

1901translateExpression patterncase

2555translateExpression patterncase

1902 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"

2556 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"

@@ -1939,41 +2593,6 @@ translateExpression e =

1939 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)

2593 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)

1940

2594

1941

2595

1942−data FFI = FFICode Char | FFIArg Int | FFIError String

1943−

1944−

1945−ffi :: String -> [String] -> JS

1946−ffi code args = let parsed = ffiParse code in

1947− case ffiError parsed of

1948− Just err -> jsError err

1949− Nothing -> JSRaw $ renderFFI parsed args

1950− where

1951− ffiParse :: String -> [FFI]

1952− ffiParse "" = []

1953− ffiParse ['%'] = [FFIError "Invalid positional argument"]

1954− ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss

1955− ffiParse ('%':s:ss)

1956− | isDigit s =

1957− FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)

1958− | otherwise =

1959− [FFIError "Invalid positional argument"]

1960− ffiParse (s:ss) = FFICode s : ffiParse ss

1961−

1962−

1963− ffiError :: [FFI] -> Maybe String

1964− ffiError [] = Nothing

1965− ffiError ((FFIError s):xs) = Just s

1966− ffiError (x:xs) = ffiError xs

1967−

1968−

1969− renderFFI :: [FFI] -> [String] -> String

1970− renderFFI [] _ = ""

1971− renderFFI ((FFICode c) : fs) args = c : renderFFI fs args

1972− renderFFI ((FFIArg i) : fs) args

1973− | i < length args && i >= 0 = args !! i ++ renderFFI fs args

1974− | otherwise = "Argument index out of bounds"

1975−

1976−

1977data CaseType = ConCase Int

2596data CaseType = ConCase Int

1978 | TypeCase JSType

2597 | TypeCase JSType

1979 | DefaultCase

2598 | DefaultCase

src/IRTS/CodegenLLVM.hs+13−8

@@ -58,14 +58,19 @@ import Debug.Trace

58

59data Target = Target { triple :: String, dataLayout :: DataLayout }

60

61+codegenLLVM :: CodeGenerator

62+codegenLLVM ci = codegenLLVM' (simpleDecls ci) (targetTriple ci)

63+ (targetCPU ci) (optimisation ci)

64+ (outputFile ci) (outputType ci)

65+

61−codegenLLVM :: [(TT.Name, SDecl)] ->

66+codegenLLVM' :: [(TT.Name, SDecl)] ->

62− String -> -- target triple

67+ String -> -- target triple

63− String -> -- target CPU

68+ String -> -- target CPU

64− Word -> -- Optimization degree

69+ Word -> -- Optimization degree

65− FilePath -> -- output file name

70+ FilePath -> -- output file name

66− OutputType ->

71+ OutputType ->

67− IO ()

72+ IO ()

68−codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do

73+codegenLLVM' defs triple cpu optimize file outty = withContext $ \context -> do

69 initializeAllTargets

74 initializeAllTargets

70 (target, _) <- failInIO $ lookupTarget Nothing triple

75 (target, _) <- failInIO $ lookupTarget Nothing triple

71 withTargetOptions $ \options ->

76 withTargetOptions $ \options ->

src/IRTS/Compiler.hs+522−324

@@ -18,15 +18,29 @@ import Util.LLVMStubs

18import IRTS.Inliner

19

20import Idris.AbsSyntax

21−import Idris.UnusedArgs

21+import Idris.AbsSyntaxTree

22+import Idris.ASTUtils

23+import Idris.Erasure

22import Idris.Error

24import Idris.Error

23

25

26+import Debug.Trace

27+

24import Idris.Core.TT

28import Idris.Core.TT

25import Idris.Core.Evaluate

29import Idris.Core.Evaluate

26import Idris.Core.CaseTree

30import Idris.Core.CaseTree

27

31

32+import Control.Category

33+import Prelude hiding (id, (.))

34+

35+import Control.Applicative

28import Control.Monad.State

36import Control.Monad.State

37+import Data.Maybe

29import Data.List

38import Data.List

39+import Data.Ord

40+import Data.IntSet (IntSet)

41+import qualified Data.IntSet as IS

42+import qualified Data.Map as M

43+import qualified Data.Set as S

30import System.Process

44import System.Process

31import System.IO

45import System.IO

32import System.Directory

46import System.Directory

@@ -37,18 +51,17 @@ import Paths_idris

37

51

38compile :: Codegen -> FilePath -> Term -> Idris ()

52compile :: Codegen -> FilePath -> Term -> Idris ()

39compile codegen f tm

53compile codegen f tm

40− = do checkMVs

54+ = do checkMVs -- check for undefined metavariables

41− let tmnames = namesUsed (STerm tm)

55+ checkTotality -- refuse to compile if there are totality problems

42− usedIn <- mapM (allNames []) tmnames

56+ reachableNames <- performUsageAnalysis

43− let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn

44− defsIn <- mkDecls tm (concat used)

45− findUnusedArgs (concat used)

46 maindef <- irMain tm

57 maindef <- irMain tm

58+ iLOG $ "MAIN: " ++ show maindef

47 objs <- getObjectFiles codegen

59 objs <- getObjectFiles codegen

48 libs <- getLibs codegen

60 libs <- getLibs codegen

49 flags <- getFlags codegen

61 flags <- getFlags codegen

50 hdrs <- getHdrs codegen

62 hdrs <- getHdrs codegen

51 impdirs <- allImportDirs

63 impdirs <- allImportDirs

64+ defsIn <- mkDecls tm reachableNames

52 let defs = defsIn ++ [(sMN 0 "runMain", maindef)]

65 let defs = defsIn ++ [(sMN 0 "runMain", maindef)]

53 -- iputStrLn $ showSep "\n" (map show defs)

66 -- iputStrLn $ showSep "\n" (map show defs)

54 let (nexttag, tagged) = addTags 65536 (liftAll defs)

67 let (nexttag, tagged) = addTags 65536 (liftAll defs)

@@ -71,67 +84,79 @@ compile codegen f tm

71 case dumpDefun of

84 case dumpDefun of

72 Nothing -> return ()

85 Nothing -> return ()

73 Just f -> runIO $ writeFile f (dumpDefuns defuns)

86 Just f -> runIO $ writeFile f (dumpDefuns defuns)

74− triple <- targetTriple

87+ triple <- Idris.AbsSyntax.targetTriple

75− cpu <- targetCPU

88+ cpu <- Idris.AbsSyntax.targetCPU

76− optimize <- optLevel

89+ optimise <- optLevel

77 iLOG "Building output"

90 iLOG "Building output"

91+

78 case checked of

92 case checked of

93+ OK c -> do let cginfo = CodegenInfo f outty triple cpu optimise

94+ hdrs impdirs objs libs flags

95+ NONE c (toAlist defuns)

96+ tagged

79− OK c -> runIO $ case codegen of

97+ runIO $ case codegen of

80− ViaC ->

81− codegenC c f outty hdrs

98+ ViaC -> codegenC cginfo

82− (concatMap mkObj objs)

83− (concatMap mkLib libs)

84− (concatMap mkFlag flags ++

85− concatMap incdir impdirs) NONE

86− ViaJava ->

99+ ViaJava -> codegenJava cginfo

87− codegenJava [] c f hdrs libs outty

88− ViaJavaScript ->

100+ ViaJavaScript -> codegenJavaScript cginfo

89− codegenJavaScript JavaScript c hdrs f outty

90− ViaNode ->

101+ ViaNode -> codegenNode cginfo

91− codegenJavaScript Node c hdrs f outty

92− ViaLLVM -> codegenLLVM c triple cpu optimize f outty

102+ ViaLLVM -> codegenLLVM cginfo

93 Bytecode -> dumpBC c f

103 Bytecode -> dumpBC c f

94 Error e -> ierror e

104 Error e -> ierror e

95 where checkMVs = do i <- getIState

105 where checkMVs = do i <- getIState

96 case map fst (idris_metavars i) \\ primDefs of

106 case map fst (idris_metavars i) \\ primDefs of

97 [] -> return ()

107 [] -> return ()

98 ms -> ifail $ "There are undefined metavariables: " ++ show ms

108 ms -> ifail $ "There are undefined metavariables: " ++ show ms

109+ checkTotality = do i <- getIState

110+ case idris_totcheckfail i of

111+ [] -> return ()

112+ ((fc, msg):fs) -> ierror . At fc . Msg $ "Cannot compile:\n " ++ msg

99 inDir d h = do let f = d </> h

113 inDir d h = do let f = d </> h

100 ex <- doesFileExist f

114 ex <- doesFileExist f

101 if ex then return f else return h

115 if ex then return f else return h

102− mkObj f = f ++ " "

103− mkLib l = "-l" ++ l ++ " "

104− mkFlag l = l ++ " "

105−

106− incdir i = "-I" ++ i ++ " "

107−

108

116

109irMain :: TT Name -> Idris LDecl

117irMain :: TT Name -> Idris LDecl

110−irMain tm = do i <- ir tm

118+irMain tm = do

119+ i <- irTerm M.empty [] tm

111− return $ LFun [] (sMN 0 "runMain") [] (LForce i)

120+ return $ LFun [] (sMN 0 "runMain") [] (LForce i)

112

121

113mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]

122mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]

114mkDecls t used

123mkDecls t used

115 = do i <- getIState

124 = do i <- getIState

116− let ds = filter (\ (n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)

125+ let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)

117− mapM traceUnused used

118 decls <- mapM build ds

126 decls <- mapM build ds

119 return decls

127 return decls

120

128

121showCaseTrees :: [(Name, LDecl)] -> String

129showCaseTrees :: [(Name, LDecl)] -> String

122−showCaseTrees ds = showSep "\n\n" (map showCT ds)

130+showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)

123 where

131 where

124 showCT (n, LFun _ f args lexp)

132 showCT (n, LFun _ f args lexp)

125− = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t "

133+ = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t"

126 ++ show lexp

134 ++ show lexp

127 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a

135 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a

128

136

137+ defnRank :: (Name, LDecl) -> String

138+ defnRank (n, LFun _ _ _ _) = "1" ++ nameRank n

139+ defnRank (n, LConstructor _ _ _) = "2" ++ nameRank n

140+

141+ nameRank :: Name -> String

142+ nameRank (UN s) = "1" ++ show s

143+ nameRank (MN i s) = "2" ++ show s ++ show i

144+ nameRank (NS n ns) = "3" ++ concatMap show (reverse ns) ++ nameRank n

145+ nameRank (SN sn) = "4" ++ snRank sn

146+ nameRank n = "5" ++ show n

147+

148+ snRank :: SpecialName -> String

149+ snRank (WhereN i n n') = "1" ++ nameRank n' ++ nameRank n ++ show i

150+ snRank (InstanceN n args) = "2" ++ nameRank n ++ concatMap show args

151+ snRank (ParentN n s) = "3" ++ nameRank n ++ show s

152+ snRank (MethodN n) = "4" ++ nameRank n

153+ snRank (CaseN n) = "5" ++ nameRank n

154+ snRank (ElimN n) = "6" ++ nameRank n

155+ snRank (InstanceCtorN n) = "7" ++ nameRank n

156+

129isCon (TyDecl _ _) = True

157isCon (TyDecl _ _) = True

130isCon _ = False

158isCon _ = False

131

159

132−class ToIR a where

133− ir :: a -> Idris LExp

134−

135build :: (Name, Def) -> Idris (Name, LDecl)

160build :: (Name, Def) -> Idris (Name, LDecl)

136build (n, d)

161build (n, d)

137 = do i <- getIState

162 = do i <- getIState

@@ -144,295 +169,468 @@ build (n, d)

144 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def

169 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def

145 return (n, def)

170 return (n, def)

146

171

147−getPrim :: IState -> Name -> [LExp] -> Maybe LExp

148−getPrim i n args = case lookup n (idris_scprims i) of

149− Just (ar, op) ->

150− if (ar == length args)

151− then return (LOp op args)

152− else Nothing

153− _ -> Nothing

154−

155declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x

172declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x

156declArgs args inl n x = LFun (if inl then [Inline] else []) n args x

173declArgs args inl n x = LFun (if inl then [Inline] else []) n args x

157

174

158−mkLDecl n (Function tm _) = do e <- ir tm

175+mkLDecl n (Function tm _)

159− return (declArgs [] True n e)

176+ = declArgs [] True n <$> irTerm M.empty [] tm

177+

160mkLDecl n (CaseOp ci _ _ _ pats cd)

178mkLDecl n (CaseOp ci _ _ _ pats cd)

161− = let (args, sc) = cases_runtime cd in

162− do e <- ir (args, sc)

163− return (declArgs [] (case_inlinable ci) n e)

179+ = declArgs [] (case_inlinable ci) n <$> irTree args sc

180+ where

181+ (args, sc) = cases_runtime cd

182+

164−mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a

183+mkLDecl n (TyDecl (DCon tag arity) _) =

184+ LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)

185+

165mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a

186mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a

166−mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n)))

187+mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run

167−

188+

168−instance ToIR (TT Name) where

189+data VarInfo = VI

169− ir tm = ir' [] tm where

190+ { viMethod :: Maybe Name

191+ }

192+ deriving Show

193+

194+type Vars = M.Map Name VarInfo

195+

196+irTerm :: Vars -> [Name] -> Term -> Idris LExp

170− ir' env tm@(App f a)

197+irTerm vs env tm@(App f a) = case unApply tm of

171− | (P _ (UN m) _, args) <- unApply tm,

198+ (P _ (UN m) _, args)

172− m == txt "mkForeignPrim"

199+ | m == txt "mkForeignPrim"

173− = doForeign env args

200+ -> doForeign vs env args

201+

174− | (P _ (UN u) _, [_, arg]) <- unApply tm,

202+ (P _ (UN u) _, [_, arg])

175− u == txt "unsafePerformPrimIO"

203+ | u == txt "unsafePerformPrimIO"

176− = ir' env arg

204+ -> irTerm vs env arg

205+

177− -- TMP HACK - until we get inlining.

206+ -- TMP HACK - until we get inlining.

178− | (P _ (UN r) _, [_, _, _, _, _, arg]) <- unApply tm,

207+ (P _ (UN r) _, [_, _, _, _, _, arg])

179− r == txt "replace"

208+ | r == txt "replace"

180− = ir' env arg

209+ -> irTerm vs env arg

210+

181− -- Laziness, the old way

211+ -- Laziness, the old way

182− | (P _ (UN l) _, [_, arg]) <- unApply tm,

212+ (P _ (UN l) _, [_, arg])

183− l == txt "lazy"

213+ | l == txt "lazy"

184− = do arg' <- ir' env arg

185− error "lazy has crept in somehow"

214+ -> error "lazy has crept in somehow"

186−-- return $ LLazyExp arg'

215+

187− | (P _ (UN l) _, [_, arg]) <- unApply tm,

216+ (P _ (UN l) _, [_, arg])

188− l == txt "force"

217+ | l == txt "force"

189− = do arg' <- ir' env arg

218+ -> LForce <$> irTerm vs env arg

190− return $ LForce arg'

219+

191− -- Laziness, the new way

220+ -- Laziness, the new way

192− | (P _ (UN l) _, [arg]) <- unApply tm,

221+ (P _ (UN l) _, [_, _, arg])

193− l == txt "Delay"

222+ | l == txt "Delay"

194− = do arg' <- ir' env arg

223+ -> LLazyExp <$> irTerm vs env arg

195− return $ LLazyExp arg'

224+

196− | (P _ (UN l) _, [_, arg]) <- unApply tm,

225+ (P _ (UN l) _, [_, _, arg])

197− l == txt "Force"

226+ | l == txt "Force"

198− = do arg' <- ir' env arg

227+ -> LForce <$> irTerm vs env arg

199− return $ LForce arg'

228+

200− | (P _ (UN a) _, [_, _, arg]) <- unApply tm,

229+ (P _ (UN a) _, [_, _, _, arg])

201− a == txt "assert_smaller"

230+ | a == txt "assert_smaller"

202− = ir' env arg

231+ -> irTerm vs env arg

232+

203− | (P _ (UN a) _, [_, arg]) <- unApply tm,

233+ (P _ (UN a) _, [_, arg])

204− a == txt "assert_total"

234+ | a == txt "assert_total"

205− = ir' env arg

235+ -> irTerm vs env arg

236+

206− | (P _ (UN p) _, [_, arg]) <- unApply tm,

237+ (P _ (UN p) _, [_, arg])

207− p == txt "par"

238+ | p == txt "par"

208− = do arg' <- ir' env arg

239+ -> do arg' <- irTerm vs env arg

209− return $ LOp LPar [LLazyExp arg']

240+ return $ LOp LPar [LLazyExp arg']

241+

210− | (P _ (UN pf) _, [arg]) <- unApply tm,

242+ (P _ (UN pf) _, [arg])

211− pf == txt "prim_fork"

243+ | pf == txt "prim_fork"

212− = do arg' <- ir' env arg

244+ -> do arg' <- irTerm vs env arg

213− return $ LOp LFork [LLazyExp arg']

245+ return $ LOp LFork [LLazyExp arg']

246+

214− | (P _ (UN m) _, [_,size,t]) <- unApply tm,

247+ (P _ (UN m) _, [_,size,t])

215− m == txt "malloc"

248+ | m == txt "malloc"

216− = do size' <- ir' env size

217− t' <- ir' env t

249+ -> irTerm vs env t

218− return t' -- TODO $ malloc_ size' t'

250+

219− | (P _ (UN tm) _, [_,t]) <- unApply tm,

251+ (P _ (UN tm) _, [_,t])

220− tm == txt "trace_malloc"

252+ | tm == txt "trace_malloc"

221− = do t' <- ir' env t

253+ -> irTerm vs env t -- TODO

222− return t' -- TODO

254+

223− -- This case is here until we get more general inlining. It's just

255+ -- This case is here until we get more general inlining. It's just

224− -- a really common case, and the laziness hurts...

256+ -- a really common case, and the laziness hurts...

225− | (P _ (NS (UN be) [b,p]) _, [_,x,(App (P _ (UN d) _) t),

257+ (P _ (NS (UN be) [b,p]) _, [_,x,(App (App (App (P _ (UN d) _) _) _) t),

226− (App (P _ (UN d') _) e)]) <- unApply tm,

258+ (App (App (App (P _ (UN d') _) _) _) e)])

227− be == txt "boolElim" && d == txt "Delay" && d' == txt "Delay"

259+ | be == txt "boolElim"

260+ , d == txt "Delay"

261+ , d' == txt "Delay"

262+ -> do

228− = do x' <- ir' env x

263+ x' <- irTerm vs env x

229− t' <- ir' env t

264+ t' <- irTerm vs env t

230− e' <- ir' env e

265+ e' <- irTerm vs env e

231− return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e',

266+ return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'

232− LConCase 1 (sNS (sUN "True") ["Bool","Prelude"]) [] t'])

267+ ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'

268+ ])

269+

270+ -- data constructor

233− | (P (DCon t a) n _, args) <- unApply tm

271+ (P (DCon t arity) n _, args) -> do

234− = irCon env t a n args

272+ detag <- fgetState (opt_detaggable . ist_optimisation n)

273+ used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)

274+

275+ let isNewtype = length used == 1 && detag

276+ let argsPruned = [a | (i,a) <- zip [0..] args, i `elem` used]

277+

278+ -- The following code removes fields from data constructors

279+ -- and performs the newtype optimisation.

280+ --

281+ -- The general rule here is:

282+ -- Everything we get as input is not touched by erasure,

283+ -- so it conforms to the official arities and types

284+ -- and we can reason about it like it's plain TT.

285+ --

286+ -- It's only the data that leaves this point that's erased

287+ -- and possibly no longer typed as the original TT version.

288+ --

289+ -- Especially, underapplied constructors must yield functions

290+ -- even if all the remaining arguments are erased

291+ -- (the resulting function *will* be applied, to NULLs).

292+ --

293+ -- This will probably need rethinking when we get erasure from functions.

294+

295+ -- "padLams" will wrap our term in LLam-bdas and give us

296+ -- the "list of future unerased args" coming from these lambdas.

297+ --

298+ -- We can do whatever we like with the list of unerased args,

299+ -- hence it takes a lambda: \unerased_argname_list -> resulting_LExp.

300+ let padLams = padLambdas used (length args) arity

301+

302+ case compare arity (length args) of

303+

304+ -- overapplied

305+ GT -> ifail ("overapplied data constructor: " ++ show tm)

306+

307+ -- exactly saturated

308+ EQ | isNewtype

309+ -> irTerm vs env (head argsPruned)

310+

311+ | otherwise -- not newtype, plain data ctor

312+ -> buildApp (LV $ Glob n) argsPruned

313+

314+ -- not saturated, underapplied

315+ LT | isNewtype -- newtype

316+ , length argsPruned == 1 -- and we already have the value

317+ -> padLams . (\tm [] -> tm) -- the [] asserts there are no unerased args

318+ <$> irTerm vs env (head argsPruned)

319+

320+ | isNewtype -- newtype but the value is not among args yet

321+ -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]

322+

323+ -- not a newtype, just apply to a constructor

324+ | otherwise

325+ -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned

326+

327+ -- type constructor

235− | (P (TCon t a) n _, args) <- unApply tm

328+ (P (TCon t a) n _, args) -> return LNothing

236− = return LNothing

329+

330+ -- a name applied to arguments

237− | (P _ n _, args) <- unApply tm

331+ (P _ n _, args) -> do

238− = do i <- getIState

332+ ist <- getIState

239− args' <- mapM (ir' env) args

333+ case lookup n (idris_scprims ist) of

240− case getPrim i n args' of

334+ -- if it's a primitive that is already saturated,

241− Just tm -> return tm

335+ -- compile to the corresponding op here already to save work

242− _ -> do

336+ Just (arity, op) | length args == arity

243− let collapse

337+ -> LOp op <$> mapM (irTerm vs env) args

244− = case lookupCtxtExact n

338+

245− (idris_optimisation i) of

339+ -- otherwise, just apply the name

246− Just oi -> collapsible oi

340+ _ -> applyName n ist args

247− _ -> False

341+

248− let unused

342+ -- turn de bruijn vars into regular named references and try again

249− = case lookupCtxtExact n

343+ (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args

250− (idris_callgraph i) of

344+

251− Just (CGInfo _ _ _ _ unusedpos) ->

345+ (f, args)

252− unusedpos

346+ -> LApp False

253− _ -> []

347+ <$> irTerm vs env f

254− if collapse

348+ <*> mapM (irTerm vs env) args

255− then return LNothing

349+

256− else return (LApp False (LV (Glob n))

350+ where

257− (mkUnused unused 0 args'))

351+ buildApp :: LExp -> [Term] -> Idris LExp

258− | (f, args) <- unApply tm

352+ buildApp e [] = return e

259− = do f' <- ir' env f

353+ buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs

260− args' <- mapM (ir' env) args

354+

261− return (LApp False f' args')

355+ applyToNames :: LExp -> [Name] -> LExp

262− where mkUnused u i [] = []

356+ applyToNames tm [] = tm

263− mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs

357+ applyToNames tm ns = LApp False tm $ map (LV . Glob) ns

264− | otherwise = x : mkUnused u (i + 1) xs

358+

265−-- ir' env (P _ (NS (UN "Z") ["Nat", "Prelude"]) _)

359+ padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp

266−-- = return $ LConst (BI 0)

360+ padLambdas used startIdx endSIdx mkTerm

361+ = LLam allNames $ mkTerm nonerasedNames

362+ where

363+ allNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1]]

364+ nonerasedNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1], i `elem` used]

365+

366+ applyName :: Name -> IState -> [Term] -> Idris LExp

367+ applyName n ist args =

368+ LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)

369+ where

370+ erase (i, x)

371+ | i >= arity || i `elem` used = x

372+ | otherwise = Erased

373+

374+ arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of

375+ Just (CaseOp ci ty tys def tot cdefs) -> length tys

376+ Just (TyDecl (DCon tag ar) _) -> ar

377+ Just (TyDecl Ref ty) -> length $ getArgTys ty

378+ Just (Operator ty ar op) -> ar

379+ Just def -> error $ "unknown arity: " ++ show (n, def)

380+ Nothing -> 0 -- no definition, probably local name => can't erase anything

381+

382+ -- name for purposes of usage info lookup

383+ uName

384+ | Just n' <- viMethod =<< M.lookup n vs = n'

385+ | otherwise = n

386+

387+ used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)

388+ fst4 (x,_,_,_) = x

389+

267− ir' env (P _ n _) = return $ LV (Glob n)

390+irTerm vs env (P _ n _) = return $ LV (Glob n)

391+irTerm vs env (V i)

268− ir' env (V i) | i >= 0 && i < length env = return $ LV (Glob (env!!i))

392+ | i >= 0 && i < length env = return $ LV (Glob (env!!i))

269− | otherwise = ifail $ "IR fail " ++ show i ++ " " ++ show tm

393+ | otherwise = ifail $ "bad de bruijn index: " ++ show i

394+

270− ir' env (Bind n (Lam _) sc)

395+irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc

396+ where

271− = do let n' = uniqueName n env

397+ n' = uniqueName n env

272− sc' <- ir' (n' : env) sc

398+

273− return $ LLam [n'] sc'

274− ir' env (Bind n (Let _ v) sc)

399+irTerm vs env (Bind n (Let _ v) sc)

275− = do sc' <- ir' (n : env) sc

400+ = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc

276− v' <- ir' env v

401+

277− return $ LLet n v' sc'

278− ir' env (Bind _ _ _) = return $ LNothing

402+irTerm vs env (Bind _ _ _) = return $ LNothing

403+

279− ir' env (Proj t i) | i == -1

404+irTerm vs env (Proj t (-1)) = do

280− = do t' <- ir' env t

405+ t' <- irTerm vs env t

281− return $ LOp (LMinus (ATInt ITBig))

406+ return $ LOp (LMinus (ATInt ITBig))

282− [t', LConst (BI 1)]

407+ [t', LConst (BI 1)]

283− ir' env (Proj t i) = do t' <- ir' env t

408+

284− return $ LProj t' i

409+irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i

285− ir' env (Constant c) = return $ LConst c

410+irTerm vs env (Constant c) = return $ LConst c

286− ir' env (TType _) = return $ LNothing

411+irTerm vs env (TType _) = return $ LNothing

287− ir' env Erased = return $ LNothing

412+irTerm vs env Erased = return $ LNothing

288− ir' env Impossible = return $ LNothing

289−-- ir' env _ = return $ LError "Impossible"

413+irTerm vs env Impossible = return $ LNothing

290−

414+

291− irCon env t arity n args

292− | length args == arity = buildApp env (LV (Glob n)) args

293− | otherwise = let extra = satArgs (arity - length args) in

294− do sc' <- irCon env t arity n

295− (args ++ map (\n -> P Bound n undefined) extra)

296− return $ LLam extra sc'

297−

298− satArgs n = map (\i -> sMN i "sat") [1..n]

299−

300− buildApp env e [] = return e

301− buildApp env e xs = do xs' <- mapM (ir' env) xs

302− return $ LApp False e xs'

303−

304− doForeign :: [Name] -> [TT Name] -> Idris LExp

415+doForeign :: Vars -> [Name] -> [TT Name] -> Idris LExp

305− doForeign env (_ : fgn : args)

416+doForeign vs env (_ : fgn : args)

306− | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn

417+ | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn

307− = let maybeTys = getFTypes fgnArgTys

418+ = case getFTypes fgnArgTys of

308− rty = mkIty' ret in

309− case maybeTys of

310− Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)

419+ Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)

311− Just tys -> do

420+ Just tys -> do

312− args' <- mapM (ir' env) (init args)

421+ args' <- mapM (irTerm vs env) (init args)

313− -- wrap it in a prim__IO

314− -- return $ con_ 0 @@ impossible @@

315− return $ -- LLazyExp $

316− LForeign LANG_C rty fgnName (zip tys args')

422+ return $ LForeign LANG_C (mkIty' ret) fgnName (zip tys args')

423+

317− | otherwise = ifail "Badly formed foreign function call"

424+ | otherwise = ifail "Badly formed foreign function call"

318−

425+ where

319−getFTypes :: TT Name -> Maybe [FType]

426+ getFTypes :: TT Name -> Maybe [FType]

320−getFTypes tm = case unApply tm of

427+ getFTypes tm = case unApply tm of

428+ -- nil : {a : Type} -> List a

321− (nil, []) -> Just []

429+ (nil, [_]) -> Just []

322− (cons, [ty, xs]) ->

430+ -- cons : {a : Type} -> a -> List a -> List a

323− fmap (mkIty' ty :) (getFTypes xs)

431+ (cons, [_, ty, xs]) -> (mkIty' ty :) <$> getFTypes xs

324− _ -> Nothing

432+ _ -> Nothing

325−

433+

326−mkIty' (P _ (UN ty) _) = mkIty (str ty)

434+ mkIty' (P _ (UN ty) _) = mkIty (str ty)

327−mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))

435+ mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))

436+ | fi == txt "FIntT"

328− | fi == txt "FIntT" = mkIntIty (str intTy)

437+ = mkIntIty (str intTy)

438+

329−mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))

439+ mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))

330− | ff == txt "FFunction" && fa == txt "FAny" &&

440+ | ff == txt "FFunction"

441+ , fa == txt "FAny"

331− io == txt "IO"

442+ , io == txt "IO"

332 = FFunctionIO

443 = FFunctionIO

333−mkIty' (App (App (P _ (UN ff) _) _) _)

334− | ff == txt "FFunction" = FFunction

335−mkIty' _ = FAny

336−

337−-- would be better if these FInt types were evaluated at compile time

338−-- TODO: add %eval directive for such things

339−

340−mkIty "FFloat" = FArith ATFloat

341−mkIty "FInt" = mkIntIty "ITNative"

342−mkIty "FChar" = mkIntIty "ITChar"

343−mkIty "FByte" = mkIntIty "IT8"

344−mkIty "FShort" = mkIntIty "IT16"

345−mkIty "FLong" = mkIntIty "IT64"

346−mkIty "FBits8" = mkIntIty "IT8"

347−mkIty "FBits16" = mkIntIty "IT16"

348−mkIty "FBits32" = mkIntIty "IT32"

349−mkIty "FBits64" = mkIntIty "IT64"

350−mkIty "FString" = FString

351−mkIty "FPtr" = FPtr

352−mkIty "FManagedPtr" = FManagedPtr

353−mkIty "FUnit" = FUnit

354−mkIty "FFunction" = FFunction

355−mkIty "FFunctionIO" = FFunctionIO

356−mkIty "FBits8x16" = FArith (ATInt (ITVec IT8 16))

357−mkIty "FBits16x8" = FArith (ATInt (ITVec IT16 8))

358−mkIty "FBits32x4" = FArith (ATInt (ITVec IT32 4))

359−mkIty "FBits64x2" = FArith (ATInt (ITVec IT64 2))

360−mkIty x = error $ "Unknown type " ++ x

361−

362−mkIntIty "ITNative" = FArith (ATInt ITNative)

363−mkIntIty "ITChar" = FArith (ATInt ITChar)

364−mkIntIty "IT8" = FArith (ATInt (ITFixed IT8))

365−mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))

366−mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

367−mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

368−

369−zname = sNS (sUN "Z") ["Nat","Prelude"]

370−sname = sNS (sUN "S") ["Nat","Prelude"]

371−

372−instance ToIR ([Name], SC) where

373− ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

374− tree' <- ir tree

375− return $ LLam args tree'

376−

377−instance ToIR SC where

378− ir t = ir' t where

379−

380− ir' (STerm t) = ir t

381− ir' (UnmatchedCase str) = return $ LError str

382− ir' (ProjCase tm alts) = do tm' <- ir tm

383− alts' <- mapM (mkIRAlt tm') alts

384− return $ LCase tm' alts'

385− ir' (Case n alts) = do alts' <- mapM (mkIRAlt (LV (Glob n))) alts

386− return $ LCase (LV (Glob n)) alts'

387− ir' ImpossibleCase = return LNothing

388−

389− -- special cases for Z and S

390− -- Needs rethink: projections make this fail

391−-- mkIRAlt n (ConCase z _ [] rhs) | z == zname

392−-- = mkIRAlt n (ConstCase (BI 0) rhs)

393−-- mkIRAlt n (ConCase s _ [arg] rhs) | s == sname

394−-- = do n' <- ir n

395−-- rhs' <- ir rhs

396−-- return $ LDefaultCase

397−-- (LLet arg (LOp LBMinus [n', LConst (BI 1)])

398−-- rhs')

399− mkIRAlt _ (ConCase n t args rhs)

400− = do rhs' <- ir rhs

401− return $ LConCase (-1) n args rhs'

402− mkIRAlt _ (ConstCase x rhs)

403− | matchable x

404− = do rhs' <- ir rhs

405− return $ LConstCase x rhs'

406− | matchableTy x

407− = do rhs' <- ir rhs

408− return $ LDefaultCase rhs'

409− mkIRAlt tm (SucCase n rhs)

410− = do rhs' <- ir rhs

411− return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))

412− [tm,

413− LConst (BI 1)]) rhs')

414−-- return $ LSucCase n rhs'

415− mkIRAlt _ (ConstCase c rhs)

416− = ifail $ "Can't match on (" ++ show c ++ ")"

417− mkIRAlt _ (DefaultCase rhs)

418− = do rhs' <- ir rhs

419− return $ LDefaultCase rhs'

420−

421− matchable (I _) = True

422− matchable (BI _) = True

423− matchable (Ch _) = True

424− matchable (Str _) = True

425− matchable _ = False

426−

427− matchableTy (AType (ATInt ITNative)) = True

428− matchableTy (AType (ATInt ITBig)) = True

429− matchableTy (AType (ATInt ITChar)) = True

430− matchableTy StrType = True

431−

432− matchableTy (AType (ATInt (ITFixed IT8))) = True

433− matchableTy (AType (ATInt (ITFixed IT16))) = True

434− matchableTy (AType (ATInt (ITFixed IT32))) = True

435− matchableTy (AType (ATInt (ITFixed IT64))) = True

436−

437− matchableTy _ = False

438

444

445+ mkIty' (App (App (P _ (UN ff) _) _) _)

446+ | ff == txt "FFunction"

447+ = FFunction

448+

449+ mkIty' _ = FAny

450+

451+ -- would be better if these FInt types were evaluated at compile time

452+ -- TODO: add %eval directive for such things

453+

454+ mkIty "FFloat" = FArith ATFloat

455+ mkIty "FInt" = mkIntIty "ITNative"

456+ mkIty "FChar" = mkIntIty "ITChar"

457+ mkIty "FByte" = mkIntIty "IT8"

458+ mkIty "FShort" = mkIntIty "IT16"

459+ mkIty "FLong" = mkIntIty "IT64"

460+ mkIty "FBits8" = mkIntIty "IT8"

461+ mkIty "FBits16" = mkIntIty "IT16"

462+ mkIty "FBits32" = mkIntIty "IT32"

463+ mkIty "FBits64" = mkIntIty "IT64"

464+ mkIty "FString" = FString

465+ mkIty "FPtr" = FPtr

466+ mkIty "FManagedPtr" = FManagedPtr

467+ mkIty "FUnit" = FUnit

468+ mkIty "FFunction" = FFunction

469+ mkIty "FFunctionIO" = FFunctionIO

470+ mkIty "FBits8x16" = FArith (ATInt (ITVec IT8 16))

471+ mkIty "FBits16x8" = FArith (ATInt (ITVec IT16 8))

472+ mkIty "FBits32x4" = FArith (ATInt (ITVec IT32 4))

473+ mkIty "FBits64x2" = FArith (ATInt (ITVec IT64 2))

474+ mkIty x = error $ "Unknown type " ++ x

475+

476+ mkIntIty "ITNative" = FArith (ATInt ITNative)

477+ mkIntIty "ITChar" = FArith (ATInt ITChar)

478+ mkIntIty "IT8" = FArith (ATInt (ITFixed IT8))

479+ mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))

480+ mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

481+ mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

482+

483+irTree :: [Name] -> SC -> Idris LExp

484+irTree args tree = do

485+ logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

486+ LLam args <$> irSC M.empty tree

487+

488+irSC :: Vars -> SC -> Idris LExp

489+irSC vs (STerm t) = irTerm vs [] t

490+irSC vs (UnmatchedCase str) = return $ LError str

491+irSC vs (ProjCase tm alts) = do

492+ tm' <- irTerm vs [] tm

493+ alts' <- mapM (irAlt vs tm') alts

494+ return $ LCase tm' alts'

495+

496+-- Transform matching on Delay to applications of Force.

497+irSC vs (Case n [ConCase (UN delay) i [_, _, n'] sc])

498+ | delay == txt "Delay"

499+ = irSC vs $ mkForce n n' sc

500+

501+-- There are two transformations in this case:

502+--

503+-- 1. Newtype-case elimination:

504+-- case {e0} of

505+-- wrap({e1}) -> P({e1}) ==> P({e0})

506+--

507+-- This is important because newtyped constructors are compiled away entirely

508+-- and we need to do that everywhere.

509+--

510+-- 2. Unused-case elimination (only valid for singleton branches):

511+-- case {e0} of ==> P

512+-- C(x,y) -> P[... x,y not used ...]

513+--

514+-- This is important for runtime because sometimes we case on irrelevant data:

515+--

516+-- In the example above, {e0} will most probably have been erased

517+-- so this vain projection would make the resulting program segfault

518+-- because the code generator still emits a PROJECT(...) G-machine instruction.

519+--

520+-- Hence, we check whether the variables are used at all

521+-- and erase the casesplit if they are not.

522+--

523+irSC vs (Case n [alt]) = do

524+ replacement <- case alt of

525+ ConCase cn a ns sc -> do

526+ detag <- fgetState (opt_detaggable . ist_optimisation cn)

527+ used <- map fst <$> fgetState (cg_usedpos . ist_callgraph cn)

528+ if detag && length used == 1

529+ then return . Just $ substSC (ns !! head used) n sc

530+ else return Nothing

531+ _ -> return Nothing

532+

533+ case replacement of

534+ Just sc -> irSC vs sc

535+ _ -> do

536+ alt' <- irAlt vs (LV (Glob n)) alt

537+ return $ case namesBoundIn alt' `usedIn` subexpr alt' of

538+ [] -> subexpr alt' -- strip the unused top-most case

539+ _ -> LCase (LV (Glob n)) [alt']

540+ where

541+ namesBoundIn :: LAlt -> [Name]

542+ namesBoundIn (LConCase cn i ns sc) = ns

543+ namesBoundIn (LConstCase c sc) = []

544+ namesBoundIn (LDefaultCase sc) = []

545+

546+ subexpr :: LAlt -> LExp

547+ subexpr (LConCase _ _ _ e) = e

548+ subexpr (LConstCase _ e) = e

549+ subexpr (LDefaultCase e) = e

550+

551+-- FIXME: When we have a non-singleton case-tree of the form

552+--

553+-- case {e0} of

554+-- C(x) => ...

555+-- ... => ...

556+--

557+-- and C is detaggable (the only constructor of the family), we can be sure

558+-- that the first branch will be always taken -- so we add special handling

559+-- to remove the dead default branch.

560+--

561+-- If we don't do so and C is newtype-optimisable, we will miss this newtype

562+-- transformation and the resulting code will probably segfault.

563+--

564+-- This work-around is not entirely optimal; the best approach would be

565+-- to ensure that such case trees don't arise in the first place.

566+--

567+irSC vs (Case n alts@[ConCase cn a ns sc, DefaultCase sc']) = do

568+ detag <- fgetState (opt_detaggable . ist_optimisation cn)

569+ if detag

570+ then irSC vs (Case n [ConCase cn a ns sc])

571+ else LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts

572+

573+irSC vs sc@(Case n alts) = do

574+ -- check that neither alternative needs the newtype optimisation,

575+ -- see comment above

576+ goneWrong <- or <$> mapM isDetaggable alts

577+ when goneWrong

578+ $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)

579+

580+ -- everything okay

581+ LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts

582+ where

583+ isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn

584+ isDetaggable _ = return False

585+

586+irSC vs ImpossibleCase = return LNothing

587+

588+irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt

589+

590+-- this leaves out all unused arguments of the constructor

591+irAlt vs _ (ConCase n t args sc) = do

592+ used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)

593+ let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]

594+ LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc

595+ where

596+ methodVars = case n of

597+ SN (InstanceCtorN className)

598+ -> M.fromList [(v, VI

599+ { viMethod = Just $ mkFieldName n i

600+ }) | (v,i) <- zip args [0..]]

601+ _

602+ -> M.empty -- not an instance constructor

603+

604+irAlt vs _ (ConstCase x rhs)

605+ | matchable x = LConstCase x <$> irSC vs rhs

606+ | matchableTy x = LDefaultCase <$> irSC vs rhs

607+ where

608+ matchable (I _) = True

609+ matchable (BI _) = True

610+ matchable (Ch _) = True

611+ matchable (Str _) = True

612+ matchable _ = False

613+

614+ matchableTy (AType (ATInt ITNative)) = True

615+ matchableTy (AType (ATInt ITBig)) = True

616+ matchableTy (AType (ATInt ITChar)) = True

617+ matchableTy StrType = True

618+

619+ matchableTy (AType (ATInt (ITFixed IT8))) = True

620+ matchableTy (AType (ATInt (ITFixed IT16))) = True

621+ matchableTy (AType (ATInt (ITFixed IT32))) = True

622+ matchableTy (AType (ATInt (ITFixed IT64))) = True

623+

624+ matchableTy _ = False

625+

626+irAlt vs tm (SucCase n rhs) = do

627+ rhs' <- irSC vs rhs

628+ return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))

629+ [tm,

630+ LConst (BI 1)]) rhs')

631+

632+irAlt vs _ (ConstCase c rhs)

633+ = ifail $ "Can't match on (" ++ show c ++ ")"

634+

635+irAlt vs _ (DefaultCase rhs)

636+ = LDefaultCase <$> irSC vs rhs

src/IRTS/Defunctionalise.hs+1−1

@@ -195,7 +195,7 @@ toCons ns (n, i)

195 (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))

196 : [] -- mkApplyCase n 0 i

197 | otherwise = []

198− where dupdate tlarg x = x

198+ where dupdate tlarg x = DUpdate tlarg x

199

200toConsA :: [(Name, Int)] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]

201toConsA ns (n, i)

src/IRTS/Lang.hs+58−31

@@ -55,6 +55,8 @@ data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy

55 -- Buffers

56 | LAllocate

57 | LAppendBuffer

58+ -- system info

59+ | LSystemInfo

58 -- Note that for Bits8 only Native endianness is actually used

60 -- Note that for Bits8 only Native endianness is actually used

59 -- and the user-exposed interface for Bits8 doesn't mention

61 -- and the user-exposed interface for Bits8 doesn't mention

60 -- endianness

62 -- endianness

@@ -213,36 +215,61 @@ usedIn env (LOp f args) = concatMap (usedIn env) args

213usedIn env _ = []

215usedIn env _ = []

214

216

215instance Show LExp where

217instance Show LExp where

216− show e = show' [] e where

218+ show e = show' [] "" e where

217− show' env (LV (Loc i)) = env!!i

219+ show' env ind (LV (Loc i)) = env!!i

218− show' env (LV (Glob n)) = show n

220+ show' env ind (LV (Glob n)) = show n

221+

219− show' env (LLazyApp e args) = show e ++ "|(" ++

222+ show' env ind (LLazyApp e args)

220− showSep ", " (map (show' env) args) ++")"

223+ = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")"

224+

221− show' env (LApp _ e args) = show' env e ++ "(" ++

225+ show' env ind (LApp _ e args)

222− showSep ", " (map (show' env) args) ++")"

226+ = show' env ind e ++ "(" ++ showSep ", " (map (show' env ind) args) ++")"

227+

223− show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"

228+ show' env ind (LLazyExp e) = "lazy{ " ++ show' env ind e ++ " }"

224− show' env (LForce e) = "%force(" ++ show' env e ++ ")"

229+ show' env ind (LForce e) = "force{ " ++ show' env ind e ++ " }"

230+ show' env ind (LLet n v e)

225− show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++

231+ = "let " ++ show n ++ " = " ++ show' env ind v

226− show' (env ++ [show n]) e

232+ ++ " in " ++ show' (env ++ [show n]) ind e

233+

234+ show' env ind (LLam args e)

227− show' env (LLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++

235+ = "\\ " ++ showSep "," (map show args)

228− show' (env ++ (map show args)) e

236+ ++ " => " ++ show' (env ++ (map show args)) ind e

237+

229− show' env (LProj t i) = show t ++ "!" ++ show i

238+ show' env ind (LProj t i) = show t ++ "!" ++ show i

239+

240+ show' env ind (LCon i n args)

230− show' env (LCon i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"

241+ = show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

242+

231− show' env (LCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++

243+ show' env ind (LCase e alts)

244+ = "case " ++ show' env ind e ++ " of \n" ++ fmt alts

245+ where

246+ fmt [] = ""

247+ fmt [alt]

248+ = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt

249+ fmt (alt:as)

232− showSep "\n\t| " (map (showAlt env) alts)

250+ = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ". ") alt

251+ ++ "\n" ++ fmt as

252+

233− show' env (LConst c) = show c

253+ show' env ind (LConst c) = show c

254+

234− show' env (LForeign lang ty n args)

255+ show' env ind (LForeign lang ty n args) = concat

256+ [ "foreign{ "

257+ , n ++ "("

235− = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"

258+ , showSep ", " (map (\(ty,x) -> show' env ind x ++ " : " ++ show ty) args)

259+ , ") : "

260+ , show ty

261+ , " }"

262+ ]

263+

264+ show' env ind (LOp f args)

236− show' env (LOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"

265+ = show f ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

266+

237− show' env (LError str) = "error " ++ show str

267+ show' env ind (LError str) = "error " ++ show str

238− show' env LNothing = "____"

268+ show' env ind LNothing = "____"

239−

269+

240− showAlt env (LConCase _ n args e)

270+ showAlt env ind (LConCase _ n args e)

241 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "

271 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "

242− ++ show' env e

272+ ++ show' env ind e

243− showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e

244− showAlt env (LDefaultCase e) = "_ => " ++ show' env e

245−

246−

247−

248

273

274+ showAlt env ind (LConstCase c e) = show c ++ " => " ++ show' env ind e

275+ showAlt env ind (LDefaultCase e) = "_ => " ++ show' env ind e

src/IRTS/Simplified.hs+16−14

@@ -125,15 +125,17 @@ checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)

125 return xs'

126checkDefs ctxt ((n, DFun n' args exp) : xs)

127 = do let sexp = evalState (simplify True exp) (ctxt, 0)

128− (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args)

128+ (exp', locs) <- runStateT (scopecheck n ctxt (zip args [0..]) sexp) (length args)

129 xs' <- checkDefs ctxt xs

130 return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')

131

132lvar v = do i <- get

133 put (max i v)

134

135−scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp

135+scopecheck :: Name -> DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp

136−scopecheck ctxt envTop tm = sc envTop tm where

136+scopecheck fn ctxt envTop tm = sc envTop tm where

137+ failsc err = fail $ "Codegen error in " ++ show fn ++ ":" ++ err

138+

137 sc env (SV (Glob n)) =

139 sc env (SV (Glob n)) =

138 case lookup n (reverse env) of -- most recent first

140 case lookup n (reverse env) of -- most recent first

139 Just i -> do lvar i; return (SV (Loc i))

141 Just i -> do lvar i; return (SV (Loc i))

@@ -141,20 +143,20 @@ scopecheck ctxt envTop tm = sc envTop tm where

141 Just (DConstructor _ i ar) ->

143 Just (DConstructor _ i ar) ->

142 if True -- ar == 0

144 if True -- ar == 0

143 then return (SCon i n [])

145 then return (SCon i n [])

144− else fail $ "Codegen error: Constructor " ++ show n ++

146+ else failsc $ "Constructor " ++ show n ++

145 " has arity " ++ show ar

147 " has arity " ++ show ar

146 Just _ -> return (SV (Glob n))

148 Just _ -> return (SV (Glob n))

147− Nothing -> fail $ "Codegen error: No such variable " ++ show n

149+ Nothing -> failsc $ "No such variable " ++ show n

148 sc env (SApp tc f args)

150 sc env (SApp tc f args)

149 = do args' <- mapM (scVar env) args

151 = do args' <- mapM (scVar env) args

150 case lookupCtxtExact f ctxt of

152 case lookupCtxtExact f ctxt of

151 Just (DConstructor n tag ar) ->

153 Just (DConstructor n tag ar) ->

152 if True -- (ar == length args)

154 if True -- (ar == length args)

153 then return $ SCon tag n args'

155 then return $ SCon tag n args'

154− else fail $ "Codegen error: Constructor " ++ show f ++

156+ else failsc $ "Constructor " ++ show f ++

155 " has arity " ++ show ar

157 " has arity " ++ show ar

156 Just _ -> return $ SApp tc f args'

158 Just _ -> return $ SApp tc f args'

157− Nothing -> fail $ "Codegen error: No such variable " ++ show f

159+ Nothing -> failsc $ "No such variable " ++ show f

158 sc env (SForeign l ty f args)

160 sc env (SForeign l ty f args)

159 = do args' <- mapM (\ (t, a) -> do a' <- scVar env a

161 = do args' <- mapM (\ (t, a) -> do a' <- scVar env a

160 return (t, a')) args

162 return (t, a')) args

@@ -165,9 +167,9 @@ scopecheck ctxt envTop tm = sc envTop tm where

165 Just (DConstructor n tag ar) ->

167 Just (DConstructor n tag ar) ->

166 if True -- (ar == length args)

168 if True -- (ar == length args)

167 then return $ SCon tag n args'

169 then return $ SCon tag n args'

168− else fail $ "Codegen error: Constructor " ++ show f ++

170+ else failsc $ "Constructor " ++ show f ++

169− " has arity " ++ show ar

171+ " has arity " ++ show ar

170− _ -> fail $ "Codegen error: No such constructor " ++ show f

172+ _ -> failsc $ "No such constructor " ++ show f

171 sc env (SProj e i)

173 sc env (SProj e i)

172 = do e' <- scVar env e

174 = do e' <- scVar env e

173 return (SProj e' i)

175 return (SProj e' i)

@@ -200,9 +202,9 @@ scopecheck ctxt envTop tm = sc envTop tm where

200 Just i -> do lvar i; return (Loc i)

202 Just i -> do lvar i; return (Loc i)

201 Nothing -> case lookupCtxtExact n ctxt of

203 Nothing -> case lookupCtxtExact n ctxt of

202 Just (DConstructor _ i ar) ->

204 Just (DConstructor _ i ar) ->

203− fail $ "Codegen error : can't pass constructor here"

205+ failsc $ "can't pass constructor here"

204 Just _ -> return (Glob n)

206 Just _ -> return (Glob n)

205− Nothing -> fail $ "Codegen error: No such variable " ++ show n ++

207+ Nothing -> failsc $ "No such variable " ++ show n ++

206 " in " ++ show tm ++ " " ++ show envTop

208 " in " ++ show tm ++ " " ++ show envTop

207 scVar _ x = return x

209 scVar _ x = return x

208

210

@@ -212,9 +214,9 @@ scopecheck ctxt envTop tm = sc envTop tm where

212 Just (DConstructor _ i ar) ->

214 Just (DConstructor _ i ar) ->

213 if True -- (length args == ar)

215 if True -- (length args == ar)

214 then return i

216 then return i

215− else fail $ "Codegen error: Constructor " ++ show n ++

217+ else failsc $ "Constructor " ++ show n ++

216 " has arity " ++ show ar

218 " has arity " ++ show ar

217− _ -> fail $ "Codegen error: No constructor " ++ show n

219+ _ -> failsc $ "No constructor " ++ show n

218 e' <- sc env' e

220 e' <- sc env' e

219 return (SConCase (length env) tag n args e')

221 return (SConCase (length env) tag n args e')

220 scalt env (SConstCase c e) = do e' <- sc env e

222 scalt env (SConstCase c e) = do e' <- sc env e

src/Idris/ASTUtils.hsnew file+134

@@ -0,0 +1,134 @@

1+module Idris.ASTUtils where

2+

3+-- This implements just a few basic lens-like concepts to ease state updates.

4+-- Similar to fclabels in approach, just without the extra dependency.

5+--

6+-- We don't include an explicit export list

7+-- because everything here is meant to be exported.

8+--

9+-- Short synopsis:

10+-- ---------------

11+--

12+-- f :: Idris ()

13+-- f = do

14+-- -- these two steps:

15+-- detaggable <- fgetState (opt_detaggable . ist_optimisation typeName)

16+-- fputState (opt_detaggable . ist_optimisation typeName) (not detaggable)

17+--

18+-- -- are equivalent to:

19+-- fmodifyState (opt_detaggable . ist_optimisation typeName) not

20+--

21+-- -- of course, the long accessor can be put in a variable;

22+-- -- everything is first-class

23+-- let detag n = opt_detaggable . ist_optimisation n

24+-- fputState (detag n1) True

25+-- fputState (detag n2) False

26+--

27+-- -- Note that all these operations handle missing items consistently

28+-- -- and transparently, as prescribed by the default values included

29+-- -- in the definitions of the ist_* functions.

30+-- --

31+-- -- Especially, it's no longer necessary to have initial values of

32+-- -- data structures copied (possibly inconsistently) all over the compiler.

33+

34+import Control.Category

35+import Control.Applicative

36+import Control.Monad.State.Class

37+import Data.Maybe

38+import Prelude hiding (id, (.))

39+

40+import Idris.Core.TT

41+import Idris.AbsSyntaxTree

42+

43+data Field rec fld = Field

44+ { fget :: rec -> fld

45+ , fset :: fld -> rec -> rec

46+ }

47+

48+fmodify :: Field rec fld -> (fld -> fld) -> rec -> rec

49+fmodify field f x = fset field (f $ fget field x) x

50+

51+instance Category Field where

52+ id = Field id const

53+ Field g2 s2 . Field g1 s1 = Field (g2 . g1) (\v2 x1 -> s1 (s2 v2 $ g1 x1) x1)

54+

55+fgetState :: MonadState s m => Field s a -> m a

56+fgetState field = gets $ fget field

57+

58+fputState :: MonadState s m => Field s a -> a -> m ()

59+fputState field x = fmodifyState field (const x)

60+

61+fmodifyState :: MonadState s m => Field s a -> (a -> a) -> m ()

62+fmodifyState field f = modify $ fmodify field f

63+

64+-- Exact-name context lookup; uses Nothing for deleted values (read+write!).

65+--

66+-- Reading a non-existing value yields Nothing,

67+-- writing Nothing deletes the value (if it existed).

68+ctxt_lookup :: Name -> Field (Ctxt a) (Maybe a)

69+ctxt_lookup n = Field

70+ { fget = lookupCtxtExact n

71+ , fset = \newVal -> case newVal of

72+ Just x -> addDef n x

73+ Nothing -> deleteDefExact n

74+ }

75+

76+-- Maybe-lens with a default value.

77+maybe_default :: a -> Field (Maybe a) a

78+maybe_default dflt = Field (fromMaybe dflt) (const . Just)

79+

80+

81+-----------------------------------

82+-- Individual records and fields --

83+-----------------------------------

84+--

85+-- These could probably be generated; let's use lazy addition for now.

86+--

87+

88+

89+-- OptInfo

90+----------

91+

92+-- the optimisation record for the given (exact) name

93+ist_optimisation :: Name -> Field IState OptInfo

94+ist_optimisation n =

95+ maybe_default Optimise

96+ { inaccessible = []

97+ , detaggable = False

98+ }

99+ . ctxt_lookup n

100+ . Field idris_optimisation (\v ist -> ist{ idris_optimisation = v })

101+

102+-- two fields of the optimisation record

103+opt_inaccessible :: Field OptInfo [(Int, Name)]

104+opt_inaccessible = Field inaccessible (\v opt -> opt{ inaccessible = v })

105+

106+opt_detaggable :: Field OptInfo Bool

107+opt_detaggable = Field detaggable (\v opt -> opt{ detaggable = v })

108+

109+

110+-- CGInfo

111+---------

112+

113+-- callgraph record for the given (exact) name

114+ist_callgraph :: Name -> Field IState CGInfo

115+ist_callgraph n =

116+ maybe_default CGInfo

117+ { argsdef = [], calls = [], scg = []

118+ , argsused = [], usedpos = []

119+ }

120+ . ctxt_lookup n

121+ . Field idris_callgraph (\v ist -> ist{ idris_callgraph = v })

122+

123+-- some fields of the CGInfo record

124+cg_usedpos :: Field CGInfo [(Int, [UsageReason])]

125+cg_usedpos = Field usedpos (\v cg -> cg{ usedpos = v })

126+

127+

128+-- Commandline flags

129+--------------------

130+

131+opts_idrisCmdline :: Field IState [Opt]

132+opts_idrisCmdline =

133+ Field opt_cmdline (\v opts -> opts{ opt_cmdline = v })

134+ . Field idris_options (\v ist -> ist{ idris_options = v })

src/Idris/AbsSyntax.hs+200−237

@@ -9,7 +9,8 @@ import Idris.Core.Elaborate hiding (Tactic(..))

9import Idris.Core.Typecheck

10import Idris.AbsSyntaxTree

11import Idris.Colours

12−import Idris.IdeSlave

12+import Idris.Docstrings

13+import Idris.IdeSlave hiding (Opt(..))

13import IRTS.CodegenCommon

14import IRTS.CodegenCommon

14import Util.DynamicLinker

15import Util.DynamicLinker

15

16

@@ -87,6 +88,10 @@ addDyLib libs = do i <- getIState

87addHdr :: Codegen -> String -> Idris ()

88addHdr :: Codegen -> String -> Idris ()

88addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i }

89addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i }

89

90

91+addImported :: FilePath -> Idris ()

92+addImported f = do i <- getIState

93+ putIState $ i { idris_imported = nub $ f : idris_imported i }

94+

90addLangExt :: LanguageExt -> Idris ()

95addLangExt :: LanguageExt -> Idris ()

91addLangExt TypeProviders = do i <- getIState

96addLangExt TypeProviders = do i <- getIState

92 putIState $ i {

97 putIState $ i {

@@ -262,10 +267,10 @@ addCoercion :: Name -> Idris ()

262addCoercion n = do i <- getIState

267addCoercion n = do i <- getIState

263 putIState $ i { idris_coercions = nub $ n : idris_coercions i }

268 putIState $ i { idris_coercions = nub $ n : idris_coercions i }

264

269

265−addDocStr :: Name -> String -> Idris ()

270+addDocStr :: Name -> Docstring -> [(Name, Docstring)] -> Idris ()

266−addDocStr n doc

271+addDocStr n doc args

267 = do i <- getIState

272 = do i <- getIState

268− putIState $ i { idris_docstrings = addDef n doc (idris_docstrings i) }

273+ putIState $ i { idris_docstrings = addDef n (doc, args) (idris_docstrings i) }

269

274

270addNameHint :: Name -> Name -> Idris ()

275addNameHint :: Name -> Name -> Idris ()

271addNameHint ty n

276addNameHint ty n

@@ -273,7 +278,7 @@ addNameHint ty n

273 ty' <- case lookupCtxtName ty (idris_implicits i) of

278 ty' <- case lookupCtxtName ty (idris_implicits i) of

274 [(tyn, _)] -> return tyn

279 [(tyn, _)] -> return tyn

275 [] -> throwError (NoSuchVariable ty)

280 [] -> throwError (NoSuchVariable ty)

276− tyns -> throwError (CantResolveAlts (map show (map fst tyns)))

281+ tyns -> throwError (CantResolveAlts (map fst tyns))

277 let ns' = case lookupCtxt ty' (idris_namehints i) of

282 let ns' = case lookupCtxt ty' (idris_namehints i) of

278 [ns] -> ns ++ [n]

283 [ns] -> ns ++ [n]

279 _ -> [n]

284 _ -> [n]

@@ -356,15 +361,18 @@ addNameIdx' i n

356getHdrs :: Codegen -> Idris [String]

361getHdrs :: Codegen -> Idris [String]

357getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

362getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

358

363

359−setErrLine :: Int -> Idris ()

364+getImported :: Idris [FilePath]

365+getImported = do i <- getIState; return (idris_imported i)

366+

367+setErrSpan :: FC -> Idris ()

360−setErrLine x = do i <- getIState;

368+setErrSpan x = do i <- getIState;

361− case (errLine i) of

369+ case (errSpan i) of

362− Nothing -> putIState $ i { errLine = Just x }

370+ Nothing -> putIState $ i { errSpan = Just x }

363 Just _ -> return ()

371 Just _ -> return ()

364

372

365clearErr :: Idris ()

373clearErr :: Idris ()

366clearErr = do i <- getIState

374clearErr = do i <- getIState

367− putIState $ i { errLine = Nothing }

375+ putIState $ i { errSpan = Nothing }

368

376

369getSO :: Idris (Maybe String)

377getSO :: Idris (Maybe String)

370getSO = do i <- getIState

378getSO = do i <- getIState

@@ -380,6 +388,16 @@ getIState = get

380putIState :: IState -> Idris ()

388putIState :: IState -> Idris ()

381putIState = put

389putIState = put

382

390

391+withContext :: (IState -> Ctxt a) -> Name -> b -> (a -> Idris b) -> Idris b

392+withContext ctx name dflt action = do

393+ ist <- getIState

394+ case lookupCtxt name (ctx ist) of

395+ [x] -> action x

396+ _ -> return dflt

397+

398+withContext_ :: (IState -> Ctxt a) -> Name -> (a -> Idris ()) -> Idris ()

399+withContext_ ctx name action = withContext ctx name () action

400+

383-- | A version of liftIO that puts errors into the exception type of the Idris monad

401-- | A version of liftIO that puts errors into the exception type of the Idris monad

384runIO :: IO a -> Idris a

402runIO :: IO a -> Idris a

385runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return

403runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return

@@ -391,6 +409,8 @@ getName = do i <- getIState;

391 putIState $ (i { idris_name = idx + 1 })

409 putIState $ (i { idris_name = idx + 1 })

392 return idx

410 return idx

393

411

412+-- InternalApp keeps track of the real function application for making case splits from, not the application the

413+-- programmer wrote, which doesn't have the whole context in any case other than top level definitions

394addInternalApp :: FilePath -> Int -> PTerm -> Idris ()

414addInternalApp :: FilePath -> Int -> PTerm -> Idris ()

395addInternalApp fp l t

415addInternalApp fp l t

396 = do i <- getIState

416 = do i <- getIState

@@ -487,6 +507,12 @@ getUndefined :: Idris [Name]

487getUndefined = do i <- getIState

507getUndefined = do i <- getIState

488 return (map fst (idris_metavars i) \\ primDefs)

508 return (map fst (idris_metavars i) \\ primDefs)

489

509

510+isMetavarName :: Name -> IState -> Bool

511+isMetavarName n ist

512+ = case lookupNames n (tt_ctxt ist) of

513+ (t:_) -> isJust $ lookup t (idris_metavars ist)

514+ _ -> False

515+

490getWidth :: Idris ConsoleWidth

516getWidth :: Idris ConsoleWidth

491getWidth = fmap idris_consolewidth getIState

517getWidth = fmap idris_consolewidth getIState

492

518

@@ -502,153 +528,27 @@ renderWidth = do iw <- getWidth

502 AutomaticWidth -> runIO getScreenWidth

528 AutomaticWidth -> runIO getScreenWidth

503

529

504

530

505−iRender :: Doc a -> Idris (SimpleDoc a)

506−iRender d = do w <- getWidth

507− ist <- getIState

508− let ideSlave = case idris_outputmode ist of

509− IdeSlave _ -> True

510− _ -> False

511− case w of

512− InfinitelyWide -> return $ renderPretty 1.0 1000000000 d

513− ColsWide n -> return $

514− if n < 1

515− then renderPretty 1.0 1000000000 d

516− else renderPretty 0.8 n d

517− AutomaticWidth | ideSlave -> return $ renderPretty 1.0 1000000000 d

518− | otherwise -> do width <- runIO getScreenWidth

519− return $ renderPretty 0.8 width d

520−

521−ihPrintResult :: Handle -> String -> Idris ()

522−ihPrintResult h s = do i <- getIState

523− case idris_outputmode i of

524− RawOutput -> case s of

525− "" -> return ()

526− s -> runIO $ hPutStrLn h s

527− IdeSlave n ->

528− let good = SexpList [SymbolAtom "ok", toSExp s] in

529− runIO $ hPutStrLn h $ convSExp "return" good n

530−

531−-- | Write a pretty-printed term to the console with semantic coloring

532−consoleDisplayAnnotated :: Handle -> Doc OutputAnnotation -> Idris ()

533−consoleDisplayAnnotated h output = do ist <- getIState

534− rendered <- iRender $ output

535− runIO . hPutStrLn h .

536− displayDecorated (consoleDecorate ist) $

537− rendered

538−

539−

540−-- | Write pretty-printed output to IDESlave with semantic annotations

541−ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()

542−ideSlaveReturnAnnotated n h out = do ist <- getIState

543− (str, spans) <- fmap displaySpans .

544− iRender .

545− fmap (fancifyAnnots ist) $

546− out

547− let good = [SymbolAtom "ok", toSExp str, toSExp spans]

548− runIO . hPutStrLn h $ convSExp "return" good n

549−

550−ihPrintTermWithType :: Handle -> Doc OutputAnnotation -> Doc OutputAnnotation -> Idris ()

551−ihPrintTermWithType h tm ty = do ist <- getIState

552− let output = tm <+> colon <+> ty

553− case idris_outputmode ist of

554− RawOutput -> consoleDisplayAnnotated h output

555− IdeSlave n -> ideSlaveReturnAnnotated n h output

556−

557−-- | Pretty-print a collection of overloadings to REPL or IDESlave - corresponds to :t name

558−ihPrintFunTypes :: Handle -> [(Name, Bool)] -> Name -> [(Name, PTerm)] -> Idris ()

559−ihPrintFunTypes h bnd n [] = ihPrintError h $ "No such variable " ++ show n

560−ihPrintFunTypes h bnd n overloads = do imp <- impShow

561− ist <- getIState

562− let output = vsep (map (uncurry (ppOverload imp)) overloads)

563− case idris_outputmode ist of

564− RawOutput -> consoleDisplayAnnotated h output

565− IdeSlave n -> ideSlaveReturnAnnotated n h output

566− where fullName n = prettyName True bnd n

567− ppOverload imp n tm = fullName n <+> colon <+> align (pprintPTerm imp bnd tm)

568−

569−ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris ()

570−ihRenderResult h d = do ist <- getIState

571− case idris_outputmode ist of

572− RawOutput -> consoleDisplayAnnotated h d

573− IdeSlave n -> ideSlaveReturnAnnotated n h d

574−

575−fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation

576−fancifyAnnots ist annot@(AnnName n _ _) =

577− do let ctxt = tt_ctxt ist

578− case () of

579− _ | isDConName n ctxt -> AnnName n (Just DataOutput) Nothing

580− _ | isFnName n ctxt -> AnnName n (Just FunOutput) Nothing

581− _ | isTConName n ctxt -> AnnName n (Just TypeOutput) Nothing

582− _ | otherwise -> annot

583−fancifyAnnots _ annot = annot

584

531

585type1Doc :: Doc OutputAnnotation

532type1Doc :: Doc OutputAnnotation

586−type1Doc = (annotate AnnConstType $ text "Type 1")

533+type1Doc = (annotate (AnnType "Type" "The type of types, one level up") $ text "Type 1")

587−

534+

588−-- | Show an error with semantic highlighting

589−ihRenderError :: Handle -> Doc OutputAnnotation -> Idris ()

590−ihRenderError h e = do ist <- getIState

591− case idris_outputmode ist of

592− RawOutput -> consoleDisplayAnnotated h e

593− IdeSlave n -> do

594− (str, spans) <- fmap displaySpans .

595− iRender .

596− fmap (fancifyAnnots ist) $

597− e

598− let good = [SymbolAtom "error", toSExp str, toSExp spans]

599− runIO . hPutStrLn h $ convSExp "return" good n

600−

601−ihPrintError :: Handle -> String -> Idris ()

602−ihPrintError h s = do i <- getIState

603− case idris_outputmode i of

604− RawOutput -> case s of

605− "" -> return ()

606− s -> runIO $ hPutStrLn h s

607− IdeSlave n ->

608− let good = SexpList [SymbolAtom "error", toSExp s] in

609− runIO . hPutStrLn h $ convSExp "return" good n

610−

611−ihputStrLn :: Handle -> String -> Idris ()

612−ihputStrLn h s = do i <- getIState

613− case idris_outputmode i of

614− RawOutput -> runIO $ hPutStrLn h s

615− IdeSlave n -> runIO . hPutStrLn h $ convSExp "write-string" s n

616−

617−iputStrLn = ihputStrLn stdout

618−iPrintError = ihPrintError stdout

619−iPrintResult = ihPrintResult stdout

620−iWarn = ihWarn stdout

621−

622−ideslavePutSExp :: SExpable a => String -> a -> Idris ()

623−ideslavePutSExp cmd info = do i <- getIState

624− case idris_outputmode i of

625− IdeSlave n -> runIO . putStrLn $ convSExp cmd info n

626− _ -> return ()

627−

628−-- this needs some typing magic and more structured output towards emacs

629−iputGoal :: SimpleDoc OutputAnnotation -> Idris ()

630−iputGoal g = do i <- getIState

631− case idris_outputmode i of

632− RawOutput -> runIO $ putStrLn (displayDecorated (consoleDecorate i) g)

633− IdeSlave n -> runIO . putStrLn $

634− convSExp "write-goal" (displayS (fmap (fancifyAnnots i) g) "") n

635

535

636isetPrompt :: String -> Idris ()

536isetPrompt :: String -> Idris ()

637isetPrompt p = do i <- getIState

537isetPrompt p = do i <- getIState

638 case idris_outputmode i of

538 case idris_outputmode i of

639 IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n

539 IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n

640

540

641−ihWarn :: Handle -> FC -> Doc OutputAnnotation -> Idris ()

541+-- | Tell clients how much was parsed and loaded

542+isetLoadedRegion :: Idris ()

642−ihWarn h fc err = do i <- getIState

543+isetLoadedRegion = do i <- getIState

643− err' <- iRender . fmap (fancifyAnnots i) $ err

544+ let span = idris_parsedSpan i

545+ case span of

546+ Just fc ->

644− case idris_outputmode i of

547+ case idris_outputmode i of

645− RawOutput ->

646− runIO $

647− hPutStrLn h (show fc ++ ":" ++ displayDecorated (consoleDecorate i) err')

648− IdeSlave n ->

548+ IdeSlave n ->

649− do let (str, spans) = displaySpans err'

549+ runIO . putStrLn $

650− runIO . hPutStrLn h $

550+ convSExp "set-loaded-region" fc n

651− convSExp "warning" (fc_fname fc, fc_line fc, fc_column fc, str, spans) n

551+ Nothing -> return ()

652

552

653setLogLevel :: Int -> Idris ()

553setLogLevel :: Int -> Idris ()

654setLogLevel l = do i <- getIState

554setLogLevel l = do i <- getIState

@@ -713,6 +613,12 @@ setShowOrigErr b = do i <- getIState

713 let opt' = opts { opt_origerr = b }

613 let opt' = opts { opt_origerr = b }

714 putIState $ i { idris_options = opt' }

614 putIState $ i { idris_options = opt' }

715

615

616+setAutoSolve :: Bool -> Idris ()

617+setAutoSolve b = do i <- getIState

618+ let opts = idris_options i

619+ let opt' = opts { opt_autoSolve = b }

620+ putIState $ i { idris_options = opt' }

621+

716setNoBanner :: Bool -> Idris ()

622setNoBanner :: Bool -> Idris ()

717setNoBanner n = do i <- getIState

623setNoBanner n = do i <- getIState

718 let opts = idris_options i

624 let opts = idris_options i

@@ -872,13 +778,14 @@ setColour :: ColourType -> IdrisColour -> Idris ()

872setColour ct c = do i <- getIState

778setColour ct c = do i <- getIState

873 let newTheme = setColour' ct c (idris_colourTheme i)

779 let newTheme = setColour' ct c (idris_colourTheme i)

874 putIState $ i { idris_colourTheme = newTheme }

780 putIState $ i { idris_colourTheme = newTheme }

875− where setColour' KeywordColour c t = t { keywordColour = c }

781+ where setColour' KeywordColour c t = t { keywordColour = c }

876− setColour' BoundVarColour c t = t { boundVarColour = c }

782+ setColour' BoundVarColour c t = t { boundVarColour = c }

877− setColour' ImplicitColour c t = t { implicitColour = c }

783+ setColour' ImplicitColour c t = t { implicitColour = c }

878− setColour' FunctionColour c t = t { functionColour = c }

784+ setColour' FunctionColour c t = t { functionColour = c }

879− setColour' TypeColour c t = t { typeColour = c }

785+ setColour' TypeColour c t = t { typeColour = c }

880− setColour' DataColour c t = t { dataColour = c }

786+ setColour' DataColour c t = t { dataColour = c }

881− setColour' PromptColour c t = t { promptColour = c }

787+ setColour' PromptColour c t = t { promptColour = c }

788+ setColour' PostulateColour c t = t { postulateColour = c }

882

789

883logLvl :: Int -> String -> Idris ()

790logLvl :: Int -> String -> Idris ()

884logLvl l str = do i <- getIState

791logLvl l str = do i <- getIState

@@ -899,7 +806,7 @@ iLOG = logLvl 1

899

806

900noErrors :: Idris Bool

807noErrors :: Idris Bool

901noErrors = do i <- getIState

808noErrors = do i <- getIState

902− case errLine i of

809+ case errSpan i of

903 Nothing -> return True

810 Nothing -> return True

904 _ -> return False

811 _ -> return False

905

812

@@ -935,9 +842,9 @@ expandParams dec ps ns infs tm = en tm

935 | otherwise = PLam n (en t) (en s)

842 | otherwise = PLam n (en t) (en s)

936 en (PPi p n t s)

843 en (PPi p n t s)

937 | n `elem` (map fst ps ++ ns)

844 | n `elem` (map fst ps ++ ns)

938− = let n' = mkShadow n in

845+ = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp?

939− PPi p n' (en t) (en (shadow n n' s))

846+ PPi (enTacImp p) n' (en t) (en (shadow n n' s))

940− | otherwise = PPi p n (en t) (en s)

847+ | otherwise = PPi (enTacImp p) n (en t) (en s)

941 en (PLet n ty v s)

848 en (PLet n ty v s)

942 | n `elem` (map fst ps ++ ns)

849 | n `elem` (map fst ps ++ ns)

943 = let n' = mkShadow n in

850 = let n' = mkShadow n in

@@ -996,15 +903,18 @@ expandParams dec ps ns infs tm = en tm

996

903

997 nseq x y = nsroot x == nsroot y

904 nseq x y = nsroot x == nsroot y

998

905

906+ enTacImp (TacImp aos st scr) = TacImp aos st (en scr)

907+ enTacImp other = other

908+

999expandParamsD :: Bool -> -- True = RHS only

909expandParamsD :: Bool -> -- True = RHS only

1000 IState ->

910 IState ->

1001 (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl

911 (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl

1002−expandParamsD rhsonly ist dec ps ns (PTy doc syn fc o n ty)

912+expandParamsD rhsonly ist dec ps ns (PTy doc argdocs syn fc o n ty)

1003 = if n `elem` ns && (not rhsonly)

913 = if n `elem` ns && (not rhsonly)

1004 then -- trace (show (n, expandParams dec ps ns ty)) $

914 then -- trace (show (n, expandParams dec ps ns ty)) $

1005− PTy doc syn fc o (dec n) (piBindp expl_param ps (expandParams dec ps ns [] ty))

915+ PTy doc argdocs syn fc o (dec n) (piBindp expl_param ps (expandParams dec ps ns [] ty))

1006 else --trace (show (n, expandParams dec ps ns ty)) $

916 else --trace (show (n, expandParams dec ps ns ty)) $

1007− PTy doc syn fc o n (expandParams dec ps ns [] ty)

917+ PTy doc argdocs syn fc o n (expandParams dec ps ns [] ty)

1008expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty)

918expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty)

1009 = if n `elem` ns && (not rhsonly)

919 = if n `elem` ns && (not rhsonly)

1010 then -- trace (show (n, expandParams dec ps ns ty)) $

920 then -- trace (show (n, expandParams dec ps ns ty)) $

@@ -1040,7 +950,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

1040 updateps yn nm [] = []

950 updateps yn nm [] = []

1041 updateps yn nm (((a, t), i):as)

951 updateps yn nm (((a, t), i):as)

1042 | (a `elem` nm) == yn = (a, t) : updateps yn nm as

952 | (a `elem` nm) == yn = (a, t) : updateps yn nm as

1043− | otherwise = (sMN i (show n ++ "_u"), t) : updateps yn nm as

953+ | otherwise = (sMN i ('_' : show n ++ "_u"), t) : updateps yn nm as

1044

954

1045 removeBound lhs ns = ns \\ nub (bnames lhs)

955 removeBound lhs ns = ns \\ nub (bnames lhs)

1046

956

@@ -1050,8 +960,9 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

1050 bnames (PDPair _ _ l Placeholder r) = bnames l ++ bnames r

960 bnames (PDPair _ _ l Placeholder r) = bnames l ++ bnames r

1051 bnames _ = []

961 bnames _ = []

1052

962

963+-- | Expands parameters defined in parameter and where blocks inside of declarations

1053−expandParamsD rhs ist dec ps ns (PData doc syn fc co pd)

964+expandParamsD rhs ist dec ps ns (PData doc argDocs syn fc co pd)

1054− = PData doc syn fc co (expandPData pd)

965+ = PData doc argDocs syn fc co (expandPData pd)

1055 where

966 where

1056 -- just do the type decl, leave constructors alone (parameters will be

967 -- just do the type decl, leave constructors alone (parameters will be

1057 -- added implicitly)

968 -- added implicitly)

@@ -1060,26 +971,27 @@ expandParamsD rhs ist dec ps ns (PData doc syn fc co pd)

1060 then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))

971 then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))

1061 (map econ cons)

972 (map econ cons)

1062 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

973 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

1063− econ (doc, n, t, fc, fs)

974+ econ (doc, argDocs, n, t, fc, fs)

1064− = (doc, dec n, piBindp impl ps (expandParams dec ps ns [] t), fc, fs)

975+ = (doc, argDocs, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)

1065−expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty cdoc cn cty)

976+expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty opts cdoc cn cty)

1066− = if tn `elem` ns

977+ = if tn `elem` ns

1067 then PRecord doc syn fc (dec tn) (piBind ps (expandParams dec ps ns [] tty))

978 then PRecord doc syn fc (dec tn) (piBind ps (expandParams dec ps ns [] tty))

1068− cdoc (dec cn) conty

979+ opts cdoc (dec cn) conty

1069 else PRecord doc syn fc (dec tn) (expandParams dec ps ns [] tty)

980 else PRecord doc syn fc (dec tn) (expandParams dec ps ns [] tty)

1070− cdoc (dec cn) conty

981+ opts cdoc (dec cn) conty

1071− where conty = piBindp impl ps (expandParams dec ps ns [] cty)

982+ where conty = piBindp expl ps (expandParams dec ps ns [] cty)

1072expandParamsD rhs ist dec ps ns (PParams f params pds)

983expandParamsD rhs ist dec ps ns (PParams f params pds)

1073 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

984 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

1074 (map (expandParamsD True ist dec ps ns) pds)

985 (map (expandParamsD True ist dec ps ns) pds)

1075-- (map (expandParamsD ist dec ps ns) pds)

986-- (map (expandParamsD ist dec ps ns) pds)

1076expandParamsD rhs ist dec ps ns (PMutual f pds)

987expandParamsD rhs ist dec ps ns (PMutual f pds)

1077 = PMutual f (map (expandParamsD rhs ist dec ps ns) pds)

988 = PMutual f (map (expandParamsD rhs ist dec ps ns) pds)

1078−expandParamsD rhs ist dec ps ns (PClass doc info f cs n params decls)

989+expandParamsD rhs ist dec ps ns (PClass doc info f cs n params pDocs decls)

1079 = PClass doc info f

990 = PClass doc info f

1080 (map (expandParams dec ps ns []) cs)

991 (map (expandParams dec ps ns []) cs)

1081 n

992 n

1082 (map (mapsnd (expandParams dec ps ns [])) params)

993 (map (mapsnd (expandParams dec ps ns [])) params)

994+ pDocs

1083 (map (expandParamsD rhs ist dec ps ns) decls)

995 (map (expandParamsD rhs ist dec ps ns) decls)

1084expandParamsD rhs ist dec ps ns (PInstance info f cs n params ty cn decls)

996expandParamsD rhs ist dec ps ns (PInstance info f cs n params ty cn decls)

1085 = PInstance info f

997 = PInstance info f

@@ -1125,6 +1037,7 @@ getPriority i tm = 1 -- pri tm

1125 pri Placeholder = 1

1037 pri Placeholder = 1

1126 pri _ = 3

1038 pri _ = 3

1127

1039

1040+

1128addStatics :: Name -> Term -> PTerm -> Idris ()

1041addStatics :: Name -> Term -> PTerm -> Idris ()

1129addStatics n tm ptm =

1042addStatics n tm ptm =

1130 do let (statics, dynamics) = initStatics tm ptm

1043 do let (statics, dynamics) = initStatics tm ptm

@@ -1158,8 +1071,8 @@ addStatics n tm ptm =

1158 -- if a name appears in a type class or tactic implicit index, it doesn't

1071 -- if a name appears in a type class or tactic implicit index, it doesn't

1159 -- affect its 'uniquely inferrable' from a static status since these are

1072 -- affect its 'uniquely inferrable' from a static status since these are

1160 -- resolved by searching.

1073 -- resolved by searching.

1161− searchArg (Constraint _ _ _) = True

1074+ searchArg (Constraint _ _) = True

1162− searchArg (TacImp _ _ _ _) = True

1075+ searchArg (TacImp _ _ _) = True

1163 searchArg _ = False

1076 searchArg _ = False

1164

1077

1165 staticList sts (Bind n (Pi _) sc) = (n `elem` sts) : staticList sts sc

1078 staticList sts (Bind n (Pi _) sc) = (n `elem` sts) : staticList sts sc

@@ -1186,14 +1099,14 @@ addUsingConstraints syn fc t

1186 -- if all of args in ns, then add it

1099 -- if all of args in ns, then add it

1187 doAdd (UConstraint c args : cs) ns t

1100 doAdd (UConstraint c args : cs) ns t

1188 | all (\n -> elem n ns) args

1101 | all (\n -> elem n ns) args

1189− = PPi (Constraint [] Dynamic "") (sMN 0 "cu")

1102+ = PPi (Constraint [] Dynamic) (sMN 0 "cu")

1190 (mkConst c args) (doAdd cs ns t)

1103 (mkConst c args) (doAdd cs ns t)

1191 | otherwise = doAdd cs ns t

1104 | otherwise = doAdd cs ns t

1192

1105

1193 mkConst c args = PApp fc (PRef fc c)

1106 mkConst c args = PApp fc (PRef fc c)

1194− (map (\n -> PExp 0 [] (PRef fc n) "") args)

1107+ (map (\n -> PExp 0 [] (sMN 0 "carg") (PRef fc n)) args)

1195

1108

1196− getConstraints (PPi (Constraint _ _ _) _ c sc)

1109+ getConstraints (PPi (Constraint _ _) _ c sc)

1197 = getcapp c ++ getConstraints sc

1110 = getcapp c ++ getConstraints sc

1198 getConstraints (PPi _ _ c sc) = getConstraints sc

1111 getConstraints (PPi _ _ c sc) = getConstraints sc

1199 getConstraints _ = []

1112 getConstraints _ = []

@@ -1203,7 +1116,7 @@ addUsingConstraints syn fc t

1203 return (UConstraint c ns)

1116 return (UConstraint c ns)

1204 getcapp _ = []

1117 getcapp _ = []

1205

1118

1206− getName (PExp _ _ (PRef _ n) _) = return n

1119+ getName (PExp _ _ _ (PRef _ n)) = return n

1207 getName _ = []

1120 getName _ = []

1208

1121

1209-- Add implicit Pi bindings for any names in the term which appear in an

1122-- Add implicit Pi bindings for any names in the term which appear in an

@@ -1211,13 +1124,14 @@ addUsingConstraints syn fc t

1211

1124

1212-- This has become a right mess already. Better redo it some time...

1125-- This has become a right mess already. Better redo it some time...

1213

1126

1214−implicit :: SyntaxInfo -> Name -> PTerm -> Idris PTerm

1127+implicit :: ElabInfo -> SyntaxInfo -> Name -> PTerm -> Idris PTerm

1215−implicit syn n ptm = implicit' syn [] n ptm

1128+implicit info syn n ptm = implicit' info syn [] n ptm

1216

1129

1217−implicit' :: SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1130+implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1218−implicit' syn ignore n ptm

1131+implicit' info syn ignore n ptm

1219 = do i <- getIState

1132 = do i <- getIState

1220 let (tm', impdata) = implicitise syn ignore i ptm

1133 let (tm', impdata) = implicitise syn ignore i ptm

1134+ defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

1221-- let (tm'', spos) = findStatics i tm'

1135-- let (tm'', spos) = findStatics i tm'

1222 putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1136 putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1223 addIBC (IBCImp n)

1137 addIBC (IBCImp n)

@@ -1225,6 +1139,23 @@ implicit' syn ignore n ptm

1225-- i <- get

1139-- i <- get

1226-- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1140-- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1227 return tm'

1141 return tm'

1142+ where

1143+ -- Detect unknown names in default arguments and throw error if found.

1144+ defaultArgCheck :: [Name] -> [PArg] -> Idris ()

1145+ defaultArgCheck knowns params = foldM_ notFoundInDefault knowns params

1146+

1147+ notFoundInDefault :: [Name] -> PArg -> Idris [Name]

1148+ notFoundInDefault kns (PTacImplicit _ _ n script _)

1149+ = do i <- getIState

1150+ case notFound kns (namesIn [] i script) of

1151+ Nothing -> return (n:kns)

1152+ Just name -> throwError (NoSuchVariable name)

1153+ notFoundInDefault kns p = return ((pname p):kns)

1154+

1155+ notFound :: [Name] -> [Name] -> Maybe Name

1156+ notFound kns [] = Nothing

1157+ notFound kns (SN (WhereN _ _ _) : ns) = notFound kns ns -- Known already

1158+ notFound kns (n:ns) = if elem n kns then notFound kns ns else Just n

1228

1159

1229implicitise :: SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg])

1160implicitise :: SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg])

1230implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1161implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

@@ -1249,38 +1180,44 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1249 | otherwise = x : dropAll xs ys

1180 | otherwise = x : dropAll xs ys

1250 dropAll [] ys = []

1181 dropAll [] ys = []

1251

1182

1183+ -- Find names in argument position in a type, suitable for implicit

1184+ -- binding

1185+ -- Not the function position, but do everything else...

1186+ implNamesIn uv (PApp fc f args) = concatMap (implNamesIn uv) (map getTm args)

1187+ implNamesIn uv t = namesIn uv ist t

1188+

1252 imps top env (PApp _ f as)

1189 imps top env (PApp _ f as)

1253 = do (decls, ns) <- get

1190 = do (decls, ns) <- get

1254 let isn = concatMap (namesIn uvars ist) (map getTm as)

1191 let isn = concatMap (namesIn uvars ist) (map getTm as)

1255 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1192 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1256− imps top env (PPi (Imp l _ doc _) n ty sc)

1193+ imps top env (PPi (Imp l _ _) n ty sc)

1257− = do let isn = nub (namesIn uvars ist ty) `dropAll` [n]

1194+ = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

1258 (decls , ns) <- get

1195 (decls , ns) <- get

1259− put (PImp (getPriority ist ty) True l n Placeholder doc : decls,

1196+ put (PImp (getPriority ist ty) True l n Placeholder : decls,

1260 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1197 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1261 imps True (n:env) sc

1198 imps True (n:env) sc

1262− imps top env (PPi (Exp l _ doc _) n ty sc)

1199+ imps top env (PPi (Exp l _ _) n ty sc)

1263− = do let isn = nub (namesIn uvars ist ty ++ case sc of

1200+ = do let isn = nub (implNamesIn uvars ty ++ case sc of

1264 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1201 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1265 _ -> [])

1202 _ -> [])

1266 (decls, ns) <- get -- ignore decls in HO types

1203 (decls, ns) <- get -- ignore decls in HO types

1267− put (PExp (getPriority ist ty) l Placeholder doc : decls,

1204+ put (PExp (getPriority ist ty) l n Placeholder : decls,

1268 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1205 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1269 imps True (n:env) sc

1206 imps True (n:env) sc

1270− imps top env (PPi (Constraint l _ doc) n ty sc)

1207+ imps top env (PPi (Constraint l _) n ty sc)

1271− = do let isn = nub (namesIn uvars ist ty ++ case sc of

1208+ = do let isn = nub (implNamesIn uvars ty ++ case sc of

1272 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1209 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1273 _ -> [])

1210 _ -> [])

1274 (decls, ns) <- get -- ignore decls in HO types

1211 (decls, ns) <- get -- ignore decls in HO types

1275− put (PConstraint 10 l Placeholder doc : decls,

1212+ put (PConstraint 10 l n Placeholder : decls,

1276 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1213 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1277 imps True (n:env) sc

1214 imps True (n:env) sc

1278− imps top env (PPi (TacImp l _ scr doc) n ty sc)

1215+ imps top env (PPi (TacImp l _ scr) n ty sc)

1279− = do let isn = nub (namesIn uvars ist ty ++ case sc of

1216+ = do let isn = nub (implNamesIn uvars ty ++ case sc of

1280 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1217 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1281 _ -> [])

1218 _ -> [])

1282 (decls, ns) <- get -- ignore decls in HO types

1219 (decls, ns) <- get -- ignore decls in HO types

1283− put (PTacImplicit 10 l n scr Placeholder doc : decls,

1220+ put (PTacImplicit 10 l n scr Placeholder : decls,

1284 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1221 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1285 imps True (n:env) sc

1222 imps True (n:env) sc

1286 imps top env (PEq _ l r)

1223 imps top env (PEq _ l r)

@@ -1321,8 +1258,8 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1321 pibind using [] sc = sc

1258 pibind using [] sc = sc

1322 pibind using (n:ns) sc

1259 pibind using (n:ns) sc

1323 = case lookup n using of

1260 = case lookup n using of

1324− Just ty -> PPi (Imp [] Dynamic "" False) n ty (pibind using ns sc)

1261+ Just ty -> PPi (Imp [] Dynamic False) n ty (pibind using ns sc)

1325− Nothing -> PPi (Imp [] Dynamic "" False) n Placeholder

1262+ Nothing -> PPi (Imp [] Dynamic False) n Placeholder

1326 (pibind using ns sc)

1263 (pibind using ns sc)

1327

1264

1328-- Add implicit arguments in function calls

1265-- Add implicit arguments in function calls

@@ -1393,9 +1330,11 @@ addImpl' inpat env infns ist ptm

1393 as' = map (fmap (ai env ds)) as in

1330 as' = map (fmap (ai env ds)) as in

1394 mkPApp fc 1 f' as'

1331 mkPApp fc 1 f' as'

1395 ai env ds (PCase fc c os)

1332 ai env ds (PCase fc c os)

1396− = let c' = ai env ds c

1333+ = let c' = ai env ds c in

1397− os' = map (pmap (ai env ds)) os in

1334+ -- leave os alone, because they get lifted into a new pattern match

1335+ -- definition which is passed through addImpl again with more scope

1336+ -- information

1398− PCase fc c' os'

1337+ PCase fc c' os

1399 ai env ds (PLam n ty sc)

1338 ai env ds (PLam n ty sc)

1400 = let ty' = ai env ds ty

1339 = let ty' = ai env ds ty

1401 sc' = ai ((n, Just ty):env) ds sc in

1340 sc' = ai ((n, Just ty):env) ds sc in

@@ -1485,32 +1424,46 @@ aiFn inpat expat ist fc f ds as

1485 [(n,t)] -> t

1424 [(n,t)] -> t

1486 _ -> Public

1425 _ -> Public

1487

1426

1488−

1489 insertImpl :: [PArg] -> [PArg] -> [PArg]

1427 insertImpl :: [PArg] -> [PArg] -> [PArg]

1428+ insertImpl ps as = insImpAcc M.empty ps as

1429+

1430+ insImpAcc :: M.Map Name PTerm -- accumulated param names & arg terms

1431+ -> [PArg] -- parameters

1432+ -> [PArg] -- arguments

1433+ -> [PArg]

1490− insertImpl (PExp p l ty _ : ps) (PExp _ _ tm d : given) =

1434+ insImpAcc pnas (PExp p l n ty : ps) (PExp _ _ _ tm : given) =

1491− PExp p l tm d : insertImpl ps given

1435+ PExp p l n tm : insImpAcc (M.insert n tm pnas) ps given

1492− insertImpl (PConstraint p l ty _ : ps) (PConstraint _ _ tm d : given) =

1436+ insImpAcc pnas (PConstraint p l n ty : ps) (PConstraint _ _ _ tm : given) =

1493− PConstraint p l tm d : insertImpl ps given

1437+ PConstraint p l n tm : insImpAcc (M.insert n tm pnas) ps given

1494− insertImpl (PConstraint p l ty d : ps) given =

1438+ insImpAcc pnas (PConstraint p l n ty : ps) given =

1495− PConstraint p l (PResolveTC fc) d : insertImpl ps given

1439+ let rtc = PResolveTC fc in

1440+ PConstraint p l n rtc : insImpAcc (M.insert n rtc pnas) ps given

1496− insertImpl (PImp p _ l n ty d : ps) given =

1441+ insImpAcc pnas (PImp p _ l n ty : ps) given =

1497 case find n given [] of

1442 case find n given [] of

1443+ Just (tm, given') ->

1498− Just (tm, given') -> PImp p False l n tm "" : insertImpl ps given'

1444+ PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given'

1445+ Nothing ->

1499− Nothing -> PImp p True l n Placeholder "" : insertImpl ps given

1446+ PImp p True l n Placeholder :

1447+ insImpAcc (M.insert n Placeholder pnas) ps given

1500− insertImpl (PTacImplicit p l n sc' ty d : ps) given =

1448+ insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given =

1501− let sc = addImpl ist sc' in

1449+ let sc = addImpl ist (substMatches (M.toList pnas) sc') in

1502 case find n given [] of

1450 case find n given [] of

1451+ Just (tm, given') ->

1503− Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given'

1452+ PTacImplicit p l n sc tm :

1453+ insImpAcc (M.insert n tm pnas) ps given'

1504− Nothing -> if inpat

1454+ Nothing ->

1455+ if inpat

1505− then PTacImplicit p l n sc Placeholder "" : insertImpl ps given

1456+ then PTacImplicit p l n sc Placeholder :

1457+ insImpAcc (M.insert n Placeholder pnas) ps given

1506− else PTacImplicit p l n sc sc "" : insertImpl ps given

1458+ else PTacImplicit p l n sc sc :

1459+ insImpAcc (M.insert n sc pnas) ps given

1507− insertImpl expected [] = []

1460+ insImpAcc _ expected [] = []

1508− insertImpl _ given = given

1461+ insImpAcc _ _ given = given

1509

1462

1510 find n [] acc = Nothing

1463 find n [] acc = Nothing

1511− find n (PImp _ _ _ n' t _ : gs) acc

1464+ find n (PImp _ _ _ n' t : gs) acc

1512 | n == n' = Just (t, reverse acc ++ gs)

1465 | n == n' = Just (t, reverse acc ++ gs)

1513− find n (PTacImplicit _ _ n' _ t _ : gs) acc

1466+ find n (PTacImplicit _ _ n' _ t : gs) acc

1514 | n == n' = Just (t, reverse acc ++ gs)

1467 | n == n' = Just (t, reverse acc ++ gs)

1515 find n (g : gs) acc = find n gs (g : acc)

1468 find n (g : gs) acc = find n gs (g : acc)

1516

1469

@@ -1537,19 +1490,19 @@ stripLinear i tm = evalState (sl tm) [] where

1537 return (PPatvar fc f)

1490 return (PPatvar fc f)

1538 sl t@(PAlternative _ (a : as)) = do sl a

1491 sl t@(PAlternative _ (a : as)) = do sl a

1539 return t

1492 return t

1540− sl (PApp fc fn args) = do fn' <- sl fn

1493+ sl (PApp fc fn args) = do -- Just the args, fn isn't matchable as a var

1541 args' <- mapM slA args

1494 args' <- mapM slA args

1542− return $ PApp fc fn' args'

1495+ return $ PApp fc fn args'

1543− where slA (PImp p m l n t d) = do t' <- sl t

1496+ where slA (PImp p m l n t) = do t' <- sl t

1544− return $ PImp p m l n t' d

1497+ return $ PImp p m l n t'

1545− slA (PExp p l t d) = do t' <- sl t

1498+ slA (PExp p l n t) = do t' <- sl t

1546− return $ PExp p l t' d

1499+ return $ PExp p l n t'

1547− slA (PConstraint p l t d)

1500+ slA (PConstraint p l n t)

1548 = do t' <- sl t

1501 = do t' <- sl t

1549− return $ PConstraint p l t' d

1502+ return $ PConstraint p l n t'

1550− slA (PTacImplicit p l n sc t d)

1503+ slA (PTacImplicit p l n sc t)

1551 = do t' <- sl t

1504 = do t' <- sl t

1552− return $ PTacImplicit p l n sc t' d

1505+ return $ PTacImplicit p l n sc t'

1553 sl x = return x

1506 sl x = return x

1554

1507

1555-- Remove functions which aren't applied to anything, which must then

1508-- Remove functions which aren't applied to anything, which must then

@@ -1649,8 +1602,6 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

1649 = do mf <- match' f f'

1602 = do mf <- match' f f'

1650 ms <- zipWithM matchArg args args'

1603 ms <- zipWithM matchArg args args'

1651 return (mf ++ concat ms)

1604 return (mf ++ concat ms)

1652−-- match (PRef _ n) (PRef _ n') | n == n' = return []

1653−-- | otherwise = Nothing

1654 match (PRef f n) (PApp _ x []) = match (PRef f n) x

1605 match (PRef f n) (PApp _ x []) = match (PRef f n) x

1655 match (PPatvar f n) xr = match (PRef f n) xr

1606 match (PPatvar f n) xr = match (PRef f n) xr

1656 match xr (PPatvar f n) = match xr (PRef f n)

1607 match xr (PPatvar f n) = match xr (PRef f n)

@@ -1660,7 +1611,10 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

1660 (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i))

1611 (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i))

1661 || tm == Placeholder)

1612 || tm == Placeholder)

1662 = return [(n, tm)]

1613 = return [(n, tm)]

1614+ -- if one namespace is missing, drop the other

1663− | n == n' = return []

1615+ | n == n' || n == dropNS n' || dropNS n == n' = return []

1616+ where dropNS (NS n _) = n

1617+ dropNS n = n

1664 match (PRef _ n) tm

1618 match (PRef _ n) tm

1665 | not names && (not (isConName n (tt_ctxt i) ||

1619 | not names && (not (isConName n (tt_ctxt i) ||

1666 isFnName n (tt_ctxt i)) || tm == Placeholder)

1620 isFnName n (tt_ctxt i)) || tm == Placeholder)

@@ -1803,6 +1757,12 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

1803 mkUniqA arg = do t' <- mkUniq (getTm arg)

1757 mkUniqA arg = do t' <- mkUniq (getTm arg)

1804 return (arg { getTm = t' })

1758 return (arg { getTm = t' })

1805

1759

1760+ -- Initialise the unique name with the environment length (so we're not

1761+ -- looking for too long...)

1762+ initN (UN n) l = UN $ txt (str n ++ show l)

1763+ initN (MN i s) l = MN (i+l) s

1764+ initN n l = n

1765+

1806 -- FIXME: Probably ought to do this for completeness! It's fine as

1766 -- FIXME: Probably ought to do this for completeness! It's fine as

1807 -- long as there are no bindings inside tactics though.

1767 -- long as there are no bindings inside tactics though.

1808 mkUniqT tac = return tac

1768 mkUniqT tac = return tac

@@ -1812,7 +1772,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

1812 = do env <- get

1772 = do env <- get

1813 (n', sc') <-

1773 (n', sc') <-

1814 if n `elem` env

1774 if n `elem` env

1815− then do let n' = uniqueName n (env ++ inScope)

1775+ then do let n' = uniqueName (initN n (length env))

1776+ (env ++ inScope)

1816 return (n', shadow n n' sc)

1777 return (n', shadow n n' sc)

1817 else return (n, sc)

1778 else return (n, sc)

1818 put (n' : env)

1779 put (n' : env)

@@ -1823,7 +1784,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

1823 = do env <- get

1784 = do env <- get

1824 (n', sc') <-

1785 (n', sc') <-

1825 if n `elem` env

1786 if n `elem` env

1826− then do let n' = uniqueName n (env ++ inScope)

1787+ then do let n' = uniqueName (initN n (length env))

1788+ (env ++ inScope)

1827 return (n', shadow n n' sc)

1789 return (n', shadow n n' sc)

1828 else return (n, sc)

1790 else return (n, sc)

1829 put (n' : env)

1791 put (n' : env)

@@ -1834,7 +1796,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

1834 = do env <- get

1796 = do env <- get

1835 (n', sc') <-

1797 (n', sc') <-

1836 if n `elem` env

1798 if n `elem` env

1837− then do let n' = uniqueName n (env ++ inScope)

1799+ then do let n' = uniqueName (initN n (length env))

1800+ (env ++ inScope)

1838 return (n', shadow n n' sc)

1801 return (n', shadow n n' sc)

1839 else return (n, sc)

1802 else return (n, sc)

1840 put (n' : env)

1803 put (n' : env)

src/Idris/AbsSyntaxTree.hs+403−271

@@ -7,6 +7,7 @@ import Idris.Core.TT

7import Idris.Core.Evaluate

8import Idris.Core.Elaborate hiding (Tactic(..))

9import Idris.Core.Typecheck

10+import Idris.Docstrings

10import IRTS.Lang

11import IRTS.Lang

11import IRTS.CodegenCommon

12import IRTS.CodegenCommon

12import Util.Pretty

13import Util.Pretty

@@ -30,11 +31,25 @@ import qualified Data.Map as M

30import Data.Either

31import Data.Either

31import qualified Data.Set as S

32import qualified Data.Set as S

32import Data.Word (Word)

33import Data.Word (Word)

34+import Data.Maybe (fromMaybe)

33

35

34import Debug.Trace

36import Debug.Trace

35

37

36import Text.PrettyPrint.Annotated.Leijen

38import Text.PrettyPrint.Annotated.Leijen

37

39

40+-- Data to pass to recursively called elaborators; e.g. for where blocks,

41+-- paramaterised declarations, etc.

42+

43+data ElabInfo = EInfo { params :: [(Name, PTerm)],

44+ inblock :: Ctxt [Name], -- names in the block, and their params

45+ liftname :: Name -> Name,

46+ namespace :: Maybe [String] }

47+

48+toplevel = EInfo [] emptyContext id Nothing

49+

50+eInfoNames :: ElabInfo -> [Name]

51+eInfoNames info = map fst (params info) ++ M.keys (inblock info)

52+

38data IOption = IOption { opt_logLevel :: Int,

53data IOption = IOption { opt_logLevel :: Int,

39 opt_typecase :: Bool,

54 opt_typecase :: Bool,

40 opt_typeintype :: Bool,

55 opt_typeintype :: Bool,

@@ -53,7 +68,8 @@ data IOption = IOption { opt_logLevel :: Int,

53 opt_cpu :: String,

68 opt_cpu :: String,

54 opt_optLevel :: Word,

69 opt_optLevel :: Word,

55 opt_cmdline :: [Opt], -- remember whole command line

70 opt_cmdline :: [Opt], -- remember whole command line

56− opt_origerr :: Bool

71+ opt_origerr :: Bool,

72+ opt_autoSolve :: Bool -- ^ automatically apply "solve" tactic in prover

57 }

73 }

58 deriving (Show, Eq)

74 deriving (Show, Eq)

59

75

@@ -76,8 +92,31 @@ defaultOpts = IOption { opt_logLevel = 0

76 , opt_optLevel = 2

92 , opt_optLevel = 2

77 , opt_cmdline = []

93 , opt_cmdline = []

78 , opt_origerr = False

94 , opt_origerr = False

95+ , opt_autoSolve = True

79 }

96 }

80

97

98+data PPOption = PPOption {

99+ ppopt_impl :: Bool -- ^^ whether to show implicits

100+} deriving (Show)

101+

102+-- | Pretty printing options with default verbosity.

103+defaultPPOption :: PPOption

104+defaultPPOption = PPOption { ppopt_impl = False }

105+

106+-- | Pretty printing options with the most verbosity.

107+verbosePPOption :: PPOption

108+verbosePPOption = PPOption { ppopt_impl = True }

109+

110+-- | Get pretty printing options from the big options record.

111+ppOption :: IOption -> PPOption

112+ppOption opt = PPOption {

113+ ppopt_impl = opt_showimp opt

114+}

115+

116+-- | Get pretty printing options from an idris state record.

117+ppOptionIst :: IState -> PPOption

118+ppOptionIst = ppOption . idris_options

119+

81data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord)

120data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord)

82

121

83-- | The output mode in use

122-- | The output mode in use

@@ -88,11 +127,6 @@ data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines sh

88 | ColsWide Int -- ^ Manually specified - must be positive

127 | ColsWide Int -- ^ Manually specified - must be positive

89 | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise

128 | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise

90

129

91−-- TODO: Add 'module data' to IState, which can be saved out and reloaded quickly (i.e

92−-- without typechecking).

93−-- This will include all the functions and data declarations, plus fixity declarations

94−-- and syntax macros.

95−

96-- | The global state used in the Idris monad

130-- | The global state used in the Idris monad

97data IState = IState {

131data IState = IState {

98 tt_ctxt :: Context, -- ^ All the currently defined names and their terms

132 tt_ctxt :: Context, -- ^ All the currently defined names and their terms

@@ -111,10 +145,11 @@ data IState = IState {

111 idris_flags :: Ctxt [FnOpt],

145 idris_flags :: Ctxt [FnOpt],

112 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

146 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

113 idris_calledgraph :: Ctxt [Name],

147 idris_calledgraph :: Ctxt [Name],

114− idris_docstrings :: Ctxt String,

148+ idris_docstrings :: Ctxt (Docstring, [(Name, Docstring)]),

115 idris_tyinfodata :: Ctxt TIData,

149 idris_tyinfodata :: Ctxt TIData,

116− idris_totcheck :: [(FC, Name)], -- names to check totality on

150+ idris_totcheck :: [(FC, Name)], -- names to check totality on

117 idris_defertotcheck :: [(FC, Name)], -- names to check at the end

151 idris_defertotcheck :: [(FC, Name)], -- names to check at the end

152+ idris_totcheckfail :: [(FC, String)],

118 idris_options :: IOption,

153 idris_options :: IOption,

119 idris_name :: Int,

154 idris_name :: Int,

120 idris_lineapps :: [((FilePath, Int), PTerm)],

155 idris_lineapps :: [((FilePath, Int), PTerm)],

@@ -131,12 +166,15 @@ data IState = IState {

131 idris_libs :: [(Codegen, String)],

166 idris_libs :: [(Codegen, String)],

132 idris_cgflags :: [(Codegen, String)],

167 idris_cgflags :: [(Codegen, String)],

133 idris_hdrs :: [(Codegen, String)],

168 idris_hdrs :: [(Codegen, String)],

169+ idris_imported :: [FilePath], -- ^ Imported ibc file names

134 proof_list :: [(Name, [String])],

170 proof_list :: [(Name, [String])],

135− errLine :: Maybe Int,

171+ errSpan :: Maybe FC,

136 parserWarnings :: [(FC, Err)],

172 parserWarnings :: [(FC, Err)],

137 lastParse :: Maybe Name,

173 lastParse :: Maybe Name,

138 indent_stack :: [Int],

174 indent_stack :: [Int],

139 brace_stack :: [Maybe Int],

175 brace_stack :: [Maybe Int],

176+ lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

177+ idris_parsedSpan :: Maybe FC,

140 hide_list :: [(Name, Maybe Accessibility)],

178 hide_list :: [(Name, Maybe Accessibility)],

141 default_access :: Accessibility,

179 default_access :: Accessibility,

142 default_total :: Bool,

180 default_total :: Bool,

@@ -152,7 +190,10 @@ data IState = IState {

152 idris_nameIdx :: (Int, Ctxt (Int, Name)),

190 idris_nameIdx :: (Int, Ctxt (Int, Name)),

153 idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers

191 idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers

154 module_aliases :: M.Map [T.Text] [T.Text],

192 module_aliases :: M.Map [T.Text] [T.Text],

155− idris_consolewidth :: ConsoleWidth -- ^ How many chars wide is the console?

193+ idris_consolewidth :: ConsoleWidth, -- ^ How many chars wide is the console?

194+ idris_postulates :: S.Set Name,

195+ idris_whocalls :: Maybe (M.Map Name [Name]),

196+ idris_callswho :: Maybe (M.Map Name [Name])

156 }

197 }

157

198

158data SizeChange = Smaller | Same | Bigger | Unknown

199data SizeChange = Smaller | Same | Bigger | Unknown

@@ -163,12 +204,13 @@ deriving instance NFData SizeChange

163!-}

204!-}

164

205

165type SCGEntry = (Name, [Maybe (Int, SizeChange)])

206type SCGEntry = (Name, [Maybe (Int, SizeChange)])

207+type UsageReason = (Name, Int) -- fn_name, its_arg_number

166

208

167data CGInfo = CGInfo { argsdef :: [Name],

209data CGInfo = CGInfo { argsdef :: [Name],

168 calls :: [(Name, [[Name]])],

210 calls :: [(Name, [[Name]])],

169 scg :: [SCGEntry],

211 scg :: [SCGEntry],

170 argsused :: [Name],

212 argsused :: [Name],

171− unusedpos :: [Int] }

213+ usedpos :: [(Int, [UsageReason])] }

172 deriving Show

214 deriving Show

173{-!

215{-!

174deriving instance Binary CGInfo

216deriving instance Binary CGInfo

@@ -212,6 +254,9 @@ data IBCWrite = IBCFix FixDecl

212 | IBCLineApp FilePath Int PTerm

254 | IBCLineApp FilePath Int PTerm

213 | IBCErrorHandler Name

255 | IBCErrorHandler Name

214 | IBCFunctionErrorHandler Name Name Name

256 | IBCFunctionErrorHandler Name Name Name

257+ | IBCPostulate Name

258+ | IBCTotCheckErr FC String

259+ | IBCParsedRegion FC

215 deriving Show

260 deriving Show

216

261

217-- | The initial state for the compiler

262-- | The initial state for the compiler

@@ -220,10 +265,10 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

220 emptyContext emptyContext emptyContext emptyContext

265 emptyContext emptyContext emptyContext emptyContext

221 emptyContext emptyContext emptyContext emptyContext

266 emptyContext emptyContext emptyContext emptyContext

222 emptyContext emptyContext

267 emptyContext emptyContext

223− [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

268+ [] [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

224− [] Nothing [] Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

269+ [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] [] RawOutput

225 True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty

270 True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty

226− AutomaticWidth

271+ AutomaticWidth S.empty Nothing Nothing

227

272

228-- | The monad for the main REPL - reading and processing files and updating

273-- | The monad for the main REPL - reading and processing files and updating

229-- global state (hence the IO inner monad).

274-- global state (hence the IO inner monad).

@@ -245,10 +290,10 @@ data Command = Quit

245 | Help

290 | Help

246 | Eval PTerm

291 | Eval PTerm

247 | Check PTerm

292 | Check PTerm

248− | DocStr Name

293+ | DocStr (Either Name Const)

249 | TotCheck Name

294 | TotCheck Name

250 | Reload

295 | Reload

251− | Load FilePath

296+ | Load FilePath (Maybe Int) -- up to maximum line number

252 | ChangeDirectory FilePath

297 | ChangeDirectory FilePath

253 | ModImport String

298 | ModImport String

254 | Edit

299 | Edit

@@ -267,7 +312,6 @@ data Command = Quit

267 | HNF PTerm

312 | HNF PTerm

268 | TestInline PTerm

313 | TestInline PTerm

269 | Defn Name

314 | Defn Name

270− | Info Name

271 | Missing Name

315 | Missing Name

272 | DynamicLink FilePath

316 | DynamicLink FilePath

273 | ListDynamic

317 | ListDynamic

@@ -279,7 +323,10 @@ data Command = Quit

279 | AddProofClauseFrom Bool Int Name

323 | AddProofClauseFrom Bool Int Name

280 | AddMissing Bool Int Name

324 | AddMissing Bool Int Name

281 | MakeWith Bool Int Name

325 | MakeWith Bool Int Name

326+ | MakeLemma Bool Int Name

282− | DoProofSearch Bool Int Name [Name]

327+ | DoProofSearch Bool Bool Int Name [Name]

328+ -- ^ the first bool is whether to update,

329+ -- the second is whether to search recursively (i.e. for the arguments)

283 | SetOpt Opt

330 | SetOpt Opt

284 | UnsetOpt Opt

331 | UnsetOpt Opt

285 | NOP

332 | NOP

@@ -288,10 +335,13 @@ data Command = Quit

288 | ColourOff

335 | ColourOff

289 | ListErrorHandlers

336 | ListErrorHandlers

290 | SetConsoleWidth ConsoleWidth

337 | SetConsoleWidth ConsoleWidth

338+ | Apropos String

339+ | WhoCalls Name

340+ | CallsWho Name

341+ | MakeDoc String -- IdrisDoc

342+ | Warranty

291

343

292data Opt = Filename String

344data Opt = Filename String

293− | Ver

294− | Usage

295 | Quiet

345 | Quiet

296 | NoBanner

346 | NoBanner

297 | ColourREPL Bool

347 | ColourREPL Bool

@@ -310,6 +360,7 @@ data Opt = Filename String

310 | DefaultTotal

360 | DefaultTotal

311 | DefaultPartial

361 | DefaultPartial

312 | WarnPartial

362 | WarnPartial

363+ | WarnReach

313 | NoCoverage

364 | NoCoverage

314 | ErrContext

365 | ErrContext

315 | ShowImpl

366 | ShowImpl

@@ -321,6 +372,8 @@ data Opt = Filename String

321 | PkgClean String

372 | PkgClean String

322 | PkgCheck String

373 | PkgCheck String

323 | PkgREPL String

374 | PkgREPL String

375+ | PkgMkDoc String -- IdrisDoc

376+ | PkgTest String

324 | WarnOnly

377 | WarnOnly

325 | Pkg String

378 | Pkg String

326 | BCAsm String

379 | BCAsm String

@@ -330,12 +383,14 @@ data Opt = Filename String

330 | OutputTy OutputType

383 | OutputTy OutputType

331 | Extension LanguageExt

384 | Extension LanguageExt

332 | InterpretScript String

385 | InterpretScript String

386+ | EvalExpr String

333 | TargetTriple String

387 | TargetTriple String

334 | TargetCPU String

388 | TargetCPU String

335 | OptLevel Word

389 | OptLevel Word

336 | Client String

390 | Client String

337 | ShowOrigErr

391 | ShowOrigErr

338 | AutoWidth -- ^ Automatically adjust terminal width

392 | AutoWidth -- ^ Automatically adjust terminal width

393+ | AutoSolve -- ^ Automatically issue "solve" tactic in interactive prover

339 deriving (Show, Eq)

394 deriving (Show, Eq)

340

395

341-- Parsed declarations

396-- Parsed declarations

@@ -381,44 +436,37 @@ deriving instance NFData Static

381-- Mark bindings with their explicitness, and laziness

436-- Mark bindings with their explicitness, and laziness

382data Plicity = Imp { pargopts :: [ArgOpt],

437data Plicity = Imp { pargopts :: [ArgOpt],

383 pstatic :: Static,

438 pstatic :: Static,

384− pdocstr :: String,

385 pparam :: Bool }

439 pparam :: Bool }

386 | Exp { pargopts :: [ArgOpt],

440 | Exp { pargopts :: [ArgOpt],

387 pstatic :: Static,

441 pstatic :: Static,

388− pdocstr :: String,

389− pparam :: Bool }

442+ pparam :: Bool } -- this is a param (rather than index)

390 | Constraint { pargopts :: [ArgOpt],

443 | Constraint { pargopts :: [ArgOpt],

391− pstatic :: Static,

444+ pstatic :: Static }

392− pdocstr :: String }

393 | TacImp { pargopts :: [ArgOpt],

445 | TacImp { pargopts :: [ArgOpt],

394 pstatic :: Static,

446 pstatic :: Static,

395− pscript :: PTerm,

447+ pscript :: PTerm }

396− pdocstr :: String }

397 deriving (Show, Eq)

448 deriving (Show, Eq)

398

449

399−plazy :: Plicity -> Bool

400−plazy tm = Lazy `elem` pargopts tm

401−

402{-!

450{-!

403deriving instance Binary Plicity

451deriving instance Binary Plicity

404deriving instance NFData Plicity

452deriving instance NFData Plicity

405!-}

453!-}

406

454

407−impl = Imp [Lazy] Dynamic "" False

455+impl = Imp [] Dynamic False

408−expl = Exp [] Dynamic "" False

456+expl = Exp [] Dynamic False

409−expl_param = Exp [] Dynamic "" True

457+expl_param = Exp [] Dynamic True

410−constraint = Constraint [] Dynamic ""

458+constraint = Constraint [] Dynamic

411−tacimpl t = TacImp [] Dynamic t ""

459+tacimpl t = TacImp [] Dynamic t

412

460

413data FnOpt = Inlinable -- always evaluate when simplifying

461data FnOpt = Inlinable -- always evaluate when simplifying

414− | TotalFn | PartialFn

462+ | TotalFn | PartialFn | CoveringFn

415 | Coinductive | AssertTotal

463 | Coinductive | AssertTotal

416 | Dictionary -- type class dictionary, eval only when

464 | Dictionary -- type class dictionary, eval only when

417 -- a function argument, and further evaluation resutls

465 -- a function argument, and further evaluation resutls

418 | Implicit -- implicit coercion

466 | Implicit -- implicit coercion

419 | CExport String -- export, with a C name

467 | CExport String -- export, with a C name

420 | ErrorHandler -- ^^ an error handler for use with the ErrorReflection extension

468 | ErrorHandler -- ^^ an error handler for use with the ErrorReflection extension

421− | ErrorReverse -- ^^ attempt to reverse normalise before showing in error

469+ | ErrorReverse -- ^^ attempt to reverse normalise before showing in error

422 | Reflection -- a reflecting function, compile-time only

470 | Reflection -- a reflecting function, compile-time only

423 | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names

471 | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names

424 deriving (Show, Eq)

472 deriving (Show, Eq)

@@ -445,27 +493,29 @@ data DataOpt = Codata -- Set if the the data-type is coinductive

445type DataOpts = [DataOpt]

493type DataOpts = [DataOpt]

446

494

447-- | Type provider - what to provide

495-- | Type provider - what to provide

448−data ProvideWhat = ProvTerm -- ^ only allow providing terms

496+data ProvideWhat' t = ProvTerm t t -- ^ the first is the goal type, the second is the term

449− | ProvPostulate -- ^ only allow postulates

497+ | ProvPostulate t -- ^ goal type must be Type, so only term

450− | ProvAny -- ^ either is ok

451− deriving (Show, Eq)

498+ deriving (Show, Eq, Functor)

499+

500+type ProvideWhat = ProvideWhat' PTerm

452

501

453-- | Top-level declarations such as compiler directives, definitions,

502-- | Top-level declarations such as compiler directives, definitions,

454-- datatypes and typeclasses.

503-- datatypes and typeclasses.

455data PDecl' t

504data PDecl' t

456 = PFix FC Fixity [String] -- ^ Fixity declaration

505 = PFix FC Fixity [String] -- ^ Fixity declaration

457− | PTy String SyntaxInfo FC FnOpts Name t -- ^ Type declaration

506+ | PTy Docstring [(Name, Docstring)] SyntaxInfo FC FnOpts Name t -- ^ Type declaration

458− | PPostulate String SyntaxInfo FC FnOpts Name t -- ^ Postulate

507+ | PPostulate Docstring SyntaxInfo FC FnOpts Name t -- ^ Postulate

459 | PClauses FC FnOpts Name [PClause' t] -- ^ Pattern clause

508 | PClauses FC FnOpts Name [PClause' t] -- ^ Pattern clause

460 | PCAF FC Name t -- ^ Top level constant

509 | PCAF FC Name t -- ^ Top level constant

461− | PData String SyntaxInfo FC DataOpts (PData' t) -- ^ Data declaration.

510+ | PData Docstring [(Name, Docstring)] SyntaxInfo FC DataOpts (PData' t) -- ^ Data declaration.

462 | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block

511 | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block

463 | PNamespace String [PDecl' t] -- ^ New namespace

512 | PNamespace String [PDecl' t] -- ^ New namespace

464− | PRecord String SyntaxInfo FC Name t String Name t -- ^ Record declaration

513+ | PRecord Docstring SyntaxInfo FC Name t DataOpts Docstring Name t -- ^ Record declaration

465− | PClass String SyntaxInfo FC

514+ | PClass Docstring SyntaxInfo FC

466 [t] -- constraints

515 [t] -- constraints

467 Name

516 Name

468 [(Name, t)] -- parameters

517 [(Name, t)] -- parameters

518+ [(Name, Docstring)] -- parameter docstrings

469 [PDecl' t] -- declarations

519 [PDecl' t] -- declarations

470 -- ^ Type class: arguments are documentation, syntax info, source location, constraints,

520 -- ^ Type class: arguments are documentation, syntax info, source location, constraints,

471 -- class name, parameters, method declarations

521 -- class name, parameters, method declarations

@@ -481,7 +531,7 @@ data PDecl' t

481 | PSyntax FC Syntax -- ^ Syntax definition

531 | PSyntax FC Syntax -- ^ Syntax definition

482 | PMutual FC [PDecl' t] -- ^ Mutual block

532 | PMutual FC [PDecl' t] -- ^ Mutual block

483 | PDirective (Idris ()) -- ^ Compiler directive. The parser inserts the corresponding action in the Idris monad.

533 | PDirective (Idris ()) -- ^ Compiler directive. The parser inserts the corresponding action in the Idris monad.

484− | PProvider SyntaxInfo FC ProvideWhat Name t t -- ^ Type provider. The first t is the type, the second is the term

534+ | PProvider SyntaxInfo FC (ProvideWhat' t) Name -- ^ Type provider. The first t is the type, the second is the term

485 | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If

535 | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If

486 -- bool is True, lhs and rhs must be convertible

536 -- bool is True, lhs and rhs must be convertible

487 deriving Functor

537 deriving Functor

@@ -516,7 +566,7 @@ deriving instance NFData PClause'

516-- | Data declaration

566-- | Data declaration

517data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

567data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

518 d_tcon :: t, -- ^ Type constructor

568 d_tcon :: t, -- ^ Type constructor

519− d_cons :: [(String, Name, t, FC, [Name])] -- ^ Constructors

569+ d_cons :: [(Docstring, [(Name, Docstring)], Name, t, FC, [Name])] -- ^ Constructors

520 }

570 }

521 -- ^ Data declaration

571 -- ^ Data declaration

522 | PLaterdecl { d_name :: Name, d_tcon :: t }

572 | PLaterdecl { d_name :: Name, d_tcon :: t }

@@ -538,17 +588,17 @@ type PClause = PClause' PTerm

538

588

539declared :: PDecl -> [Name]

589declared :: PDecl -> [Name]

540declared (PFix _ _ _) = []

590declared (PFix _ _ _) = []

541−declared (PTy _ _ _ _ n t) = [n]

591+declared (PTy _ _ _ _ _ n t) = [n]

542declared (PPostulate _ _ _ _ n t) = [n]

592declared (PPostulate _ _ _ _ n t) = [n]

543declared (PClauses _ _ n _) = [] -- not a declaration

593declared (PClauses _ _ n _) = [] -- not a declaration

544declared (PCAF _ n _) = [n]

594declared (PCAF _ n _) = [n]

545−declared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

595+declared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

546− where fstt (_, a, _, _, _) = a

596+ where fstt (_, _, a, _, _, _) = a

547−declared (PData _ _ _ _ (PLaterdecl n _)) = [n]

597+declared (PData _ _ _ _ _ (PLaterdecl n _)) = [n]

548declared (PParams _ _ ds) = concatMap declared ds

598declared (PParams _ _ ds) = concatMap declared ds

549declared (PNamespace _ ds) = concatMap declared ds

599declared (PNamespace _ ds) = concatMap declared ds

550−declared (PRecord _ _ _ n _ _ c _) = [n, c]

600+declared (PRecord _ _ _ n _ _ _ c _) = [n, c]

551−declared (PClass _ _ _ _ n _ ms) = n : concatMap declared ms

601+declared (PClass _ _ _ _ n _ _ ms) = n : concatMap declared ms

552declared (PInstance _ _ _ _ _ _ _ _) = []

602declared (PInstance _ _ _ _ _ _ _ _) = []

553declared (PDSL n _) = [n]

603declared (PDSL n _) = [n]

554declared (PSyntax _ _) = []

604declared (PSyntax _ _) = []

@@ -558,32 +608,32 @@ declared (PDirective _) = []

558-- get the names declared, not counting nested parameter blocks

608-- get the names declared, not counting nested parameter blocks

559tldeclared :: PDecl -> [Name]

609tldeclared :: PDecl -> [Name]

560tldeclared (PFix _ _ _) = []

610tldeclared (PFix _ _ _) = []

561−tldeclared (PTy _ _ _ _ n t) = [n]

611+tldeclared (PTy _ _ _ _ _ n t) = [n]

562tldeclared (PPostulate _ _ _ _ n t) = [n]

612tldeclared (PPostulate _ _ _ _ n t) = [n]

563tldeclared (PClauses _ _ n _) = [] -- not a declaration

613tldeclared (PClauses _ _ n _) = [] -- not a declaration

564−tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]

614+tldeclared (PRecord _ _ _ n _ _ _ c _) = [n, c]

565−tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

615+tldeclared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

566− where fstt (_, a, _, _, _) = a

616+ where fstt (_, _, a, _, _, _) = a

567tldeclared (PParams _ _ ds) = []

617tldeclared (PParams _ _ ds) = []

568tldeclared (PMutual _ ds) = concatMap tldeclared ds

618tldeclared (PMutual _ ds) = concatMap tldeclared ds

569tldeclared (PNamespace _ ds) = concatMap tldeclared ds

619tldeclared (PNamespace _ ds) = concatMap tldeclared ds

570−tldeclared (PClass _ _ _ _ n _ ms) = concatMap tldeclared ms

620+tldeclared (PClass _ _ _ _ n _ _ ms) = concatMap tldeclared ms

571tldeclared (PInstance _ _ _ _ _ _ _ _) = []

621tldeclared (PInstance _ _ _ _ _ _ _ _) = []

572tldeclared _ = []

622tldeclared _ = []

573

623

574defined :: PDecl -> [Name]

624defined :: PDecl -> [Name]

575defined (PFix _ _ _) = []

625defined (PFix _ _ _) = []

576−defined (PTy _ _ _ _ n t) = []

626+defined (PTy _ _ _ _ _ n t) = []

577defined (PPostulate _ _ _ _ n t) = []

627defined (PPostulate _ _ _ _ n t) = []

578defined (PClauses _ _ n _) = [n] -- not a declaration

628defined (PClauses _ _ n _) = [n] -- not a declaration

579defined (PCAF _ n _) = [n]

629defined (PCAF _ n _) = [n]

580−defined (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

630+defined (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

581− where fstt (_, a, _, _, _) = a

631+ where fstt (_, _, a, _, _, _) = a

582−defined (PData _ _ _ _ (PLaterdecl n _)) = []

632+defined (PData _ _ _ _ _ (PLaterdecl n _)) = []

583defined (PParams _ _ ds) = concatMap defined ds

633defined (PParams _ _ ds) = concatMap defined ds

584defined (PNamespace _ ds) = concatMap defined ds

634defined (PNamespace _ ds) = concatMap defined ds

585−defined (PRecord _ _ _ n _ _ c _) = [n, c]

635+defined (PRecord _ _ _ n _ _ _ c _) = [n, c]

586−defined (PClass _ _ _ _ n _ ms) = n : concatMap defined ms

636+defined (PClass _ _ _ _ n _ _ ms) = n : concatMap defined ms

587defined (PInstance _ _ _ _ _ _ _ _) = []

637defined (PInstance _ _ _ _ _ _ _ _) = []

588defined (PDSL n _) = [n]

638defined (PDSL n _) = [n]

589defined (PSyntax _ _) = []

639defined (PSyntax _ _) = []

@@ -620,26 +670,26 @@ data PTerm = PQuote Raw

620 | PInferRef FC Name -- ^ A name to be defined later

670 | PInferRef FC Name -- ^ A name to be defined later

621 | PPatvar FC Name

671 | PPatvar FC Name

622 | PLam Name PTerm PTerm

672 | PLam Name PTerm PTerm

623− | PPi Plicity Name PTerm PTerm

673+ | PPi Plicity Name PTerm PTerm -- ^ (n : t1) -> t2

624 | PLet Name PTerm PTerm PTerm

674 | PLet Name PTerm PTerm PTerm

625 | PTyped PTerm PTerm -- ^ Term with explicit type

675 | PTyped PTerm PTerm -- ^ Term with explicit type

626− | PApp FC PTerm [PArg]

676+ | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x

627 | PAppBind FC PTerm [PArg] -- ^ implicitly bound application

677 | PAppBind FC PTerm [PArg] -- ^ implicitly bound application

628 | PMatchApp FC Name -- ^ Make an application by type matching

678 | PMatchApp FC Name -- ^ Make an application by type matching

629 | PCase FC PTerm [(PTerm, PTerm)]

679 | PCase FC PTerm [(PTerm, PTerm)]

630− | PTrue FC PunInfo

680+ | PTrue FC PunInfo -- ^ Unit type..?

631− | PFalse FC

681+ | PFalse FC -- ^ _|_

632 | PRefl FC PTerm

682 | PRefl FC PTerm

633 | PResolveTC FC

683 | PResolveTC FC

634− | PEq FC PTerm PTerm

684+ | PEq FC PTerm PTerm -- ^ Equality type: A = B

635 | PRewrite FC PTerm PTerm (Maybe PTerm)

685 | PRewrite FC PTerm PTerm (Maybe PTerm)

636 | PPair FC PunInfo PTerm PTerm

686 | PPair FC PunInfo PTerm PTerm

637 | PDPair FC PunInfo PTerm PTerm PTerm

687 | PDPair FC PunInfo PTerm PTerm PTerm

638 | PAlternative Bool [PTerm] -- True if only one may work

688 | PAlternative Bool [PTerm] -- True if only one may work

639 | PHidden PTerm -- ^ Irrelevant or hidden pattern

689 | PHidden PTerm -- ^ Irrelevant or hidden pattern

640− | PType

690+ | PType -- ^ 'Type' type

641 | PGoal FC PTerm Name PTerm

691 | PGoal FC PTerm Name PTerm

642− | PConstant Const

692+ | PConstant Const -- ^ Builtin types

643 | Placeholder

693 | Placeholder

644 | PDoBlock [PDo]

694 | PDoBlock [PDo]

645 | PIdiom FC PTerm

695 | PIdiom FC PTerm

@@ -688,13 +738,14 @@ mapPT f t = f (mpt t) where

688

738

689

739

690data PTactic' t = Intro [Name] | Intros | Focus Name

740data PTactic' t = Intro [Name] | Intros | Focus Name

691− | Refine Name [Bool] | Rewrite t

741+ | Refine Name [Bool] | Rewrite t | DoUnify

692 | Induction Name

742 | Induction Name

693 | Equiv t

743 | Equiv t

694 | MatchRefine Name

744 | MatchRefine Name

695 | LetTac Name t | LetTacTy Name t t

745 | LetTac Name t | LetTacTy Name t t

696 | Exact t | Compute | Trivial | TCInstance

746 | Exact t | Compute | Trivial | TCInstance

697− | ProofSearch (Maybe Name) [Name]

747+ | ProofSearch Bool Bool Int (Maybe Name) [Name]

748+ -- ^ the bool is whether to search recursively

698 | Solve

749 | Solve

699 | Attack

750 | Attack

700 | ProofState | ProofTerm | Undo

751 | ProofState | ProofTerm | Undo

@@ -741,7 +792,7 @@ type PTactic = PTactic' PTerm

741

792

742data PDo' t = DoExp FC t

793data PDo' t = DoExp FC t

743 | DoBind FC Name t

794 | DoBind FC Name t

744− | DoBindP FC t t

795+ | DoBindP FC t t [(t,t)]

745 | DoLet FC Name t t

796 | DoLet FC Name t t

746 | DoLetP FC t t

797 | DoLetP FC t t

747 deriving (Eq, Functor)

798 deriving (Eq, Functor)

@@ -753,7 +804,7 @@ deriving instance NFData PDo'

753instance Sized a => Sized (PDo' a) where

804instance Sized a => Sized (PDo' a) where

754 size (DoExp fc t) = 1 + size fc + size t

805 size (DoExp fc t) = 1 + size fc + size t

755 size (DoBind fc nm t) = 1 + size fc + size nm + size t

806 size (DoBind fc nm t) = 1 + size fc + size nm + size t

756− size (DoBindP fc l r) = 1 + size fc + size l + size r

807+ size (DoBindP fc l r alts) = 1 + size fc + size l + size r + size alts

757 size (DoLet fc nm l r) = 1 + size fc + size nm + size l + size r

808 size (DoLet fc nm l r) = 1 + size fc + size nm + size l + size r

758 size (DoLetP fc l r) = 1 + size fc + size l + size r

809 size (DoLetP fc l r) = 1 + size fc + size l + size r

759

810

@@ -766,45 +817,40 @@ type PDo = PDo' PTerm

766data PArg' t = PImp { priority :: Int,

817data PArg' t = PImp { priority :: Int,

767 machine_inf :: Bool, -- true if the machine inferred it

818 machine_inf :: Bool, -- true if the machine inferred it

768 argopts :: [ArgOpt],

819 argopts :: [ArgOpt],

769− pname :: Name, getTm :: t,

820+ pname :: Name, getTm :: t }

770− pargdoc :: String }

771 | PExp { priority :: Int,

821 | PExp { priority :: Int,

772 argopts :: [ArgOpt],

822 argopts :: [ArgOpt],

823+ pname :: Name,

773− getTm :: t,

824+ getTm :: t }

774− pargdoc :: String }

775 | PConstraint { priority :: Int,

825 | PConstraint { priority :: Int,

776 argopts :: [ArgOpt],

826 argopts :: [ArgOpt],

827+ pname :: Name,

777− getTm :: t,

828+ getTm :: t }

778− pargdoc :: String }

779 | PTacImplicit { priority :: Int,

829 | PTacImplicit { priority :: Int,

780 argopts :: [ArgOpt],

830 argopts :: [ArgOpt],

781 pname :: Name,

831 pname :: Name,

782 getScript :: t,

832 getScript :: t,

783− getTm :: t,

833+ getTm :: t }

784− pargdoc :: String }

785 deriving (Show, Eq, Functor)

834 deriving (Show, Eq, Functor)

786

835

787−data ArgOpt = Lazy | HideDisplay

836+data ArgOpt = HideDisplay | InaccessibleArg

788 deriving (Show, Eq)

837 deriving (Show, Eq)

789

838

790−lazyarg :: PArg' t -> Bool

791−lazyarg tm = Lazy `elem` argopts tm

792−

793instance Sized a => Sized (PArg' a) where

839instance Sized a => Sized (PArg' a) where

794− size (PImp p _ l nm trm _) = 1 + size nm + size trm

840+ size (PImp p _ l nm trm) = 1 + size nm + size trm

795− size (PExp p l trm _) = 1 + size trm

841+ size (PExp p l nm trm) = 1 + size nm + size trm

796− size (PConstraint p l trm _) = 1 + size trm

842+ size (PConstraint p l nm trm) = 1 + size nm +size nm + size trm

797− size (PTacImplicit p l nm scr trm _) = 1 + size nm + size scr + size trm

843+ size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

798

844

799{-!

845{-!

800deriving instance Binary PArg'

846deriving instance Binary PArg'

801deriving instance NFData PArg'

847deriving instance NFData PArg'

802!-}

848!-}

803

849

804−pimp n t mach = PImp 1 mach [Lazy] n t ""

850+pimp n t mach = PImp 1 mach [] n t

805−pexp t = PExp 1 [] t ""

851+pexp t = PExp 1 [] (sMN 0 "arg") t

806−pconst t = PConstraint 1 [] t ""

852+pconst t = PConstraint 1 [] (sMN 0 "carg") t

807−ptacimp n s t = PTacImplicit 2 [Lazy] n s t ""

853+ptacimp n s t = PTacImplicit 2 [] n s t

808

854

809type PArg = PArg' PTerm

855type PArg = PArg' PTerm

810

856

@@ -825,25 +871,11 @@ deriving instance NFData ClassInfo

825-- Type inference data

871-- Type inference data

826

872

827data TIData = TIPartial -- ^ a function with a partially defined type

873data TIData = TIPartial -- ^ a function with a partially defined type

828− | TISolution [Term] -- ^ possible solutions to a metavariable in a type

874+ | TISolution [Term] -- ^ possible solutions to a metavariable in a type

829 deriving Show

875 deriving Show

830

876

831−-- An argument is conditionally forceable iff its forceability

877+data OptInfo = Optimise { inaccessible :: [(Int,Name)], -- includes names for error reporting

832−-- depends on the collapsibility of the whole type.

878+ detaggable :: Bool }

833−data Forceability = Conditional | Unconditional deriving (Show, Enum, Bounded, Eq, Ord)

834−

835−{-!

836−deriving instance Binary Forceability

837−deriving instance NFData Forceability

838−!-}

839−

840−data OptInfo = Optimise { collapsible :: Bool,

841− isnewtype :: Bool,

842− -- The following should actually be (IntMap Forceability)

843− -- but the corresponding Binary instance seems to be broken.

844− -- Let's store a list and convert it to IntMap whenever needed.

845− forceable :: [(Int, Forceability)],

846− recursive :: [Int] }

847 deriving Show

879 deriving Show

848{-!

880{-!

849deriving instance Binary OptInfo

881deriving instance Binary OptInfo

@@ -854,7 +886,8 @@ deriving instance NFData OptInfo

854data TypeInfo = TI { con_names :: [Name],

886data TypeInfo = TI { con_names :: [Name],

855 codata :: Bool,

887 codata :: Bool,

856 data_opts :: DataOpts,

888 data_opts :: DataOpts,

857− param_pos :: [Int] }

889+ param_pos :: [Int],

890+ mutual_types :: [Name] }

858 deriving Show

891 deriving Show

859{-!

892{-!

860deriving instance Binary TypeInfo

893deriving instance Binary TypeInfo

@@ -932,6 +965,8 @@ data SyntaxInfo = Syn { using :: [Using],

932 decoration :: Name -> Name,

965 decoration :: Name -> Name,

933 inPattern :: Bool,

966 inPattern :: Bool,

934 implicitAllowed :: Bool,

967 implicitAllowed :: Bool,

968+ maxline :: Maybe Int,

969+ mut_nesting :: Int,

935 dsl_info :: DSL }

970 dsl_info :: DSL }

936 deriving Show

971 deriving Show

937{-!

972{-!

@@ -939,7 +974,7 @@ deriving instance NFData SyntaxInfo

939deriving instance Binary SyntaxInfo

974deriving instance Binary SyntaxInfo

940!-}

975!-}

941

976

942−defaultSyntax = Syn [] [] [] [] id False False initDSL

977+defaultSyntax = Syn [] [] [] [] id False False Nothing 0 initDSL

943

978

944expandNS :: SyntaxInfo -> Name -> Name

979expandNS :: SyntaxInfo -> Name -> Name

945expandNS syn n@(NS _ _) = n

980expandNS syn n@(NS _ _) = n

@@ -956,9 +991,9 @@ inferTy = sMN 0 "__Infer"

956inferCon = sMN 0 "__infer"

991inferCon = sMN 0 "__infer"

957inferDecl = PDatadecl inferTy

992inferDecl = PDatadecl inferTy

958 PType

993 PType

959− [("", inferCon, PPi impl (sMN 0 "iType") PType (

994+ [(emptyDocstring, [], inferCon, PPi impl (sMN 0 "iType") PType (

960− PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

995+ PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

961− (PRef bi inferTy)), bi, [])]

996+ (PRef bi inferTy)), bi, [])]

962inferOpts = []

997inferOpts = []

963

998

964infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t]

999infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t]

@@ -983,52 +1018,92 @@ primNames = [unitTy, unitCon,

983 falseTy, pairTy, pairCon,

1018 falseTy, pairTy, pairCon,

984 eqTy, eqCon, inferTy, inferCon]

1019 eqTy, eqCon, inferTy, inferCon]

985

1020

1021+unitDoc = parseDocstring . T.pack $ "The canonical single-element type, also known as the trivially true proposition."

986unitTy = sMN 0 "__Unit"

1022unitTy = sMN 0 "__Unit"

987unitCon = sMN 0 "__II"

1023unitCon = sMN 0 "__II"

988unitDecl = PDatadecl unitTy PType

1024unitDecl = PDatadecl unitTy PType

989− [("", unitCon, PRef bi unitTy, bi, [])]

1025+ [(parseDocstring . T.pack $ "The trivial constructor for `()`. ", [], unitCon, PRef bi unitTy, bi, [])]

990unitOpts = [DefaultEliminator]

1026unitOpts = [DefaultEliminator]

991

1027

1028+falseDoc = parseDocstring . T.pack $

1029+ "The empty type, also known as the trivially false proposition." ++

1030+ "\n\n" ++

1031+ "Use `FalseElim` or `absurd` to prove anything if you have a variable " ++

1032+ "of type `_|_` in scope."

992falseTy = sMN 0 "__False"

1033falseTy = sMN 0 "__False"

993falseDecl = PDatadecl falseTy PType []

1034falseDecl = PDatadecl falseTy PType []

994falseOpts = []

1035falseOpts = []

995

1036

1037+pairDoc = parseDocstring . T.pack $ "The non-dependent pair type, also known as conjunction."

996pairTy = sMN 0 "__Pair"

1038pairTy = sMN 0 "__Pair"

997pairCon = sMN 0 "__MkPair"

1039pairCon = sMN 0 "__MkPair"

998pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

1040pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

1041+ [(pairConDoc, pairConParamDoc,

999− [("", pairCon, PPi impl (n "A") PType (

1042+ pairCon, PPi impl (n "A") PType (

1000− PPi impl (n "B") PType (

1043+ PPi impl (n "B") PType (

1001− PPi expl (n "a") (PRef bi (n "A")) (

1044+ PPi expl (n "a") (PRef bi (n "A")) (

1002− PPi expl (n "b") (PRef bi (n "B"))

1045+ PPi expl (n "b") (PRef bi (n "B"))

1003− (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

1046+ (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

1004− pexp (PRef bi (n "B"))])))), bi, [])]

1047+ pexp (PRef bi (n "B"))])))), bi, [])]

1005 where n a = sMN 0 a

1048 where n a = sMN 0 a

1049+ pairConDoc = parseDocstring . T.pack $ "A pair of elements"

1050+ pairConParamDoc = [(n "a", parseDocstring . T.pack $ "the left element of the pair"),

1051+ (n "b", parseDocstring . T.pack $ "the right element of the pair")]

1006pairOpts = []

1052pairOpts = []

1053+pairParamDoc = [(n "A", parseDocstring . T.pack $ "the type of the left elements in the pair"),

1054+ (n "B", parseDocstring . T.pack $ "the type of the left elements in the pair")]

1055+ where n a = sMN 0 a

1007

1056

1008eqTy = sUN "="

1057eqTy = sUN "="

1009eqCon = sUN "refl"

1058eqCon = sUN "refl"

1059+eqDoc = parseDocstring . T.pack $

1060+ "The propositional equality type. A proof that `x` = `y`." ++

1061+ "\n\n" ++

1062+ "To use such a proof, pattern-match on it, and the two equal things will " ++

1063+ "then need to be the _same_ pattern." ++

1064+ "\n\n" ++

1065+ "**Note**: Idris's equality type is _heterogeneous_, which means that it " ++

1066+ "is possible to state equalities between values of potentially different " ++

1067+ "types. This is sometimes referred to in the literature as \"John Major\" " ++

1068+ "equality." ++

1069+ "\n\n" ++

1070+ "Thus, if Idris can't infer the type of one side of the equality, then " ++

1071+ "you may need to annotate it. See the function `the`."

1072+

1010eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),

1073eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),

1011 (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

1074 (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

1012 PType)

1075 PType)

1076+ [(reflDoc, reflParamDoc,

1013− [("", eqCon, PPi impl (n "A") PType (

1077+ eqCon, PPi impl (n "A") PType (

1014− PPi impl (n "x") (PRef bi (n "A"))

1078+ PPi impl (n "x") (PRef bi (n "A"))

1015− (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1079+ (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1016− pimp (n "B") Placeholder False,

1080+ pimp (n "B") Placeholder False,

1017− pexp (PRef bi (n "x")),

1081+ pexp (PRef bi (n "x")),

1018− pexp (PRef bi (n "x"))])), bi, [])]

1082+ pexp (PRef bi (n "x"))])), bi, [])]

1083+ where n a = sMN 0 a

1084+ reflDoc = parseDocstring . T.pack $

1085+ "A proof that `x` in fact equals `x`. To construct this, you must have already " ++

1086+ "shown that both sides are in fact equal."

1087+ reflParamDoc = [(n "A", parseDocstring . T.pack $ "the type at which the equality is proven"),

1088+ (n "x", parseDocstring . T.pack $ "the element shown to be equal to itself.")]

1089+

1090+eqParamDoc = [(n "A", parseDocstring . T.pack $ "the type of the left side of the equality"),

1091+ (n "B", parseDocstring . T.pack $ "the type of the right side of the equality")

1092+ ]

1019 where n a = sMN 0 a

1093 where n a = sMN 0 a

1094+

1020eqOpts = []

1095eqOpts = []

1021

1096

1022elimName = sUN "__Elim"

1097elimName = sUN "__Elim"

1023elimMethElimTy = sUN "__elimTy"

1098elimMethElimTy = sUN "__elimTy"

1024elimMethElim = sUN "elim"

1099elimMethElim = sUN "elim"

1025−elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]

1100+elimDecl = PClass (parseDocstring . T.pack $ "Type class for eliminators") defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)] []

1026− [PTy "" defaultSyntax bi [TotalFn] elimMethElimTy PType,

1101+ [PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElimTy PType,

1027− PTy "" defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

1102+ PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

1028

1103

1029-- Defined in builtins.idr

1104-- Defined in builtins.idr

1030−sigmaTy = sUN "Exists"

1105+sigmaTy = sUN "Sigma"

1031−existsCon = sUN "Ex_intro"

1106+existsCon = sUN "Sg_intro"

1032

1107

1033piBind :: [(Name, PTerm)] -> PTerm -> PTerm

1108piBind :: [(Name, PTerm)] -> PTerm -> PTerm

1034piBind = piBindp expl

1109piBind = piBindp expl

@@ -1044,52 +1119,69 @@ piBindp p ((n, ty):ns) t = PPi p n ty (piBindp p ns t)

1044-- could interfere with interactive editing, which calls "show".

1119-- could interfere with interactive editing, which calls "show".

1045

1120

1046instance Show PTerm where

1121instance Show PTerm where

1047− showsPrec _ tm = (displayS . renderPretty 1.0 10000000 . prettyImp False) tm

1122+ showsPrec _ tm = (displayS . renderPretty 1.0 10000000 . prettyImp defaultPPOption) tm

1048

1123

1049instance Show PDecl where

1124instance Show PDecl where

1050− showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDeclImp False) d

1125+ showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDeclImp defaultPPOption) d

1051

1126

1052instance Show PClause where

1127instance Show PClause where

1053− showsPrec _ c = (displayS . renderPretty 1.0 10000000 . showCImp True) c

1128+ showsPrec _ c = (displayS . renderPretty 1.0 10000000 . showCImp verbosePPOption) c

1054

1129

1055instance Show PData where

1130instance Show PData where

1056− showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDImp False) d

1131+ showsPrec _ d = (displayS . renderPretty 1.0 10000000 . showDImp defaultPPOption) d

1057

1132

1058instance Pretty PTerm OutputAnnotation where

1133instance Pretty PTerm OutputAnnotation where

1059− pretty = prettyImp False

1134+ pretty = prettyImp defaultPPOption

1060

1135

1061-- | Colourise annotations according to an Idris state. It ignores the names

1136-- | Colourise annotations according to an Idris state. It ignores the names

1062-- in the annotation, as there's no good way to show extended information on a

1137-- in the annotation, as there's no good way to show extended information on a

1063-- terminal.

1138-- terminal.

1064consoleDecorate :: IState -> OutputAnnotation -> String -> String

1139consoleDecorate :: IState -> OutputAnnotation -> String -> String

1065consoleDecorate ist _ | not (idris_colourRepl ist) = id

1140consoleDecorate ist _ | not (idris_colourRepl ist) = id

1066−consoleDecorate ist AnnConstData = let theme = idris_colourTheme ist

1141+consoleDecorate ist (AnnConst c) = let theme = idris_colourTheme ist

1142+ in if constIsType c

1143+ then colouriseType theme

1067− in colouriseData theme

1144+ else colouriseData theme

1068−consoleDecorate ist AnnConstType = let theme = idris_colourTheme ist

1145+consoleDecorate ist (AnnData _ _) = colouriseData (idris_colourTheme ist)

1069− in colouriseType theme

1146+consoleDecorate ist (AnnType _ _) = colouriseType (idris_colourTheme ist)

1070consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist)

1147consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist)

1071consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)

1148consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)

1149+consoleDecorate ist AnnKeyword = colouriseKeyword (idris_colourTheme ist)

1072−consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist

1150+consoleDecorate ist (AnnName n _ _ _) = let ctxt = tt_ctxt ist

1073− theme = idris_colourTheme ist

1151+ theme = idris_colourTheme ist

1074− in case () of

1152+ in case () of

1075− _ | isDConName n ctxt -> colouriseData theme

1153+ _ | isDConName n ctxt -> colouriseData theme

1076− _ | isFnName n ctxt -> colouriseFun theme

1154+ _ | isFnName n ctxt -> colouriseFun theme

1077− _ | isTConName n ctxt -> colouriseType theme

1155+ _ | isTConName n ctxt -> colouriseType theme

1156+ _ | isPostulateName n ist -> colourisePostulate theme

1078− _ | otherwise -> id -- don't colourise unknown names

1157+ _ | otherwise -> id -- don't colourise unknown names

1079consoleDecorate ist (AnnFC _) = id

1158consoleDecorate ist (AnnFC _) = id

1159+consoleDecorate ist (AnnTextFmt fmt) = Idris.Colours.colourise (colour fmt)

1160+ where colour BoldText = IdrisColour Nothing True False True False

1161+ colour UnderlineText = IdrisColour Nothing True True False False

1162+ colour ItalicText = IdrisColour Nothing True False False True

1080

1163

1164+isPostulateName :: Name -> IState -> Bool

1165+isPostulateName n ist = S.member n (idris_postulates ist)

1166+

1081−-- | Pretty-print a high-level closed Idris term

1167+-- | Pretty-print a high-level closed Idris term with no information about precedence/associativity

1082−prettyImp :: Bool -- ^^ whether to show implicits

1168+prettyImp :: PPOption -- ^^ pretty printing options

1083 -> PTerm -- ^^ the term to pretty-print

1169 -> PTerm -- ^^ the term to pretty-print

1084 -> Doc OutputAnnotation

1170 -> Doc OutputAnnotation

1085−prettyImp impl = pprintPTerm impl []

1171+prettyImp impl = pprintPTerm impl [] [] []

1172+

1173+-- | Do the right thing for rendering a term in an IState

1174+prettyIst :: IState -> PTerm -> Doc OutputAnnotation

1175+prettyIst ist = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist)

1086

1176

1087−-- | Pretty-print a high-level Idris term in some bindings context

1177+-- | Pretty-print a high-level Idris term in some bindings context with infix info

1088−pprintPTerm :: Bool -- ^^ whether to show implicits

1178+pprintPTerm :: PPOption -- ^^ pretty printing options

1089 -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit

1179 -> [(Name, Bool)] -- ^^ the currently-bound names and whether they are implicit

1180+ -> [Name] -- ^^ names to always show in pi, even if not used

1181+ -> [FixDecl] -- ^^ Fixity declarations

1090 -> PTerm -- ^^ the term to pretty-print

1182 -> PTerm -- ^^ the term to pretty-print

1091 -> Doc OutputAnnotation

1183 -> Doc OutputAnnotation

1092−pprintPTerm impl bnd = prettySe 10 bnd

1184+pprintPTerm ppo bnd docArgs infixes = prettySe 10 bnd

1093 where

1185 where

1094 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

1186 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

1095 prettySe p bnd (PQuote r) =

1187 prettySe p bnd (PQuote r) =

@@ -1097,81 +1189,90 @@ pprintPTerm impl bnd = prettySe 10 bnd

1097 prettySe p bnd (PPatvar fc n) = pretty n

1189 prettySe p bnd (PPatvar fc n) = pretty n

1098 prettySe p bnd e

1190 prettySe p bnd e

1099 | Just str <- slist p bnd e = str

1191 | Just str <- slist p bnd e = str

1100− | Just n <- snat p e = annotate AnnConstData (text (show n))

1192+ | Just n <- snat p e = annotate (AnnData "Nat" "") (text (show n))

1101− prettySe p bnd (PRef fc n) = prettyName impl bnd n

1193+ prettySe p bnd (PRef fc n) = prettyName (ppopt_impl ppo) bnd n

1102 prettySe p bnd (PLam n ty sc) =

1194 prettySe p bnd (PLam n ty sc) =

1103 bracket p 2 . group . align . hang 2 $

1195 bracket p 2 . group . align . hang 2 $

1104 text "\\" <> bindingOf n False <+> text "=>" <$>

1196 text "\\" <> bindingOf n False <+> text "=>" <$>

1105 prettySe 10 ((n, False):bnd) sc

1197 prettySe 10 ((n, False):bnd) sc

1106 prettySe p bnd (PLet n ty v sc) =

1198 prettySe p bnd (PLet n ty v sc) =

1107 bracket p 2 $

1199 bracket p 2 $

1108− text "let" <+> bindingOf n False <+> text "=" </>

1200+ kwd "let" <+> bindingOf n False <+> text "=" </>

1109− prettySe 10 bnd v <+> text "in" </>

1201+ prettySe 10 bnd v <+> kwd "in" </>

1110 prettySe 10 ((n, False):bnd) sc

1202 prettySe 10 ((n, False):bnd) sc

1111− prettySe p bnd (PPi (Exp l s _ _) n ty sc)

1203+ prettySe p bnd (PPi (Exp l s _) n ty sc)

1112− | n `elem` allNamesIn sc || impl =

1204+ | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =

1113− let open = if Lazy `elem` l then text "|" <> lparen else lparen in

1114− bracket p 2 . group $

1205+ bracket p 2 . group $

1115− enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

1206+ enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

1116− st <> text "->" <$> prettySe 10 ((n, False):bnd) sc

1207+ st <> text "->" <$> prettySe 10 ((n, False):bnd) sc

1117 | otherwise =

1208 | otherwise =

1118 bracket p 2 . group $

1209 bracket p 2 . group $

1119− group (prettySe 0 bnd ty <+> st) <> text "->" <$> group (prettySe 10 ((n, False):bnd) sc)

1210+ group (prettySe 1 bnd ty <+> st) <> text "->" <$> group (prettySe 10 ((n, False):bnd) sc)

1120 where

1211 where

1121 st =

1212 st =

1122 case s of

1213 case s of

1123 Static -> text "[static]" <> space

1214 Static -> text "[static]" <> space

1124 _ -> empty

1215 _ -> empty

1125− prettySe p bnd (PPi (Imp l s _ _) n ty sc)

1216+ prettySe p bnd (PPi (Imp l s _) n ty sc)

1126− | impl =

1217+ | ppopt_impl ppo =

1127− let open = if Lazy `elem` l then text "|" <> lbrace else lbrace in

1128− bracket p 2 $

1218+ bracket p 2 $

1129− open <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>

1219+ lbrace <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>

1130− st <> text "->" </> prettySe 10 ((n, True):bnd) sc

1220+ st <> text "->" </> prettySe 10 ((n, True):bnd) sc

1131 | otherwise = prettySe 10 ((n, True):bnd) sc

1221 | otherwise = prettySe 10 ((n, True):bnd) sc

1132 where

1222 where

1133 st =

1223 st =

1134 case s of

1224 case s of

1135 Static -> text "[static]" <> space

1225 Static -> text "[static]" <> space

1136 _ -> empty

1226 _ -> empty

1137− prettySe p bnd (PPi (Constraint _ _ _) n ty sc) =

1227+ prettySe p bnd (PPi (Constraint _ _) n ty sc) =

1138 bracket p 2 $

1228 bracket p 2 $

1139 prettySe 10 bnd ty <+> text "=>" </> prettySe 10 ((n, True):bnd) sc

1229 prettySe 10 bnd ty <+> text "=>" </> prettySe 10 ((n, True):bnd) sc

1140− prettySe p bnd (PPi (TacImp _ _ s _) n ty sc) =

1230+ prettySe p bnd (PPi (TacImp _ _ s) n ty sc) =

1141 bracket p 2 $

1231 bracket p 2 $

1142− lbrace <> text "tacimp" <+> pretty n <+> colon <+> prettySe 10 bnd ty <>

1232+ lbrace <> kwd "tacimp" <+> pretty n <+> colon <+> prettySe 10 bnd ty <>

1143 rbrace <+> text "->" </> prettySe 10 ((n, True):bnd) sc

1233 rbrace <+> text "->" </> prettySe 10 ((n, True):bnd) sc

1144 prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args

1234 prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args

1145 | UN nm <- basename f

1235 | UN nm <- basename f

1236+ , not (ppopt_impl ppo) && null (getExps args) =

1146− , not impl && null (getExps args) = if isAlpha (thead nm)

1237+ if isAlpha (thead nm)

1147− then prettyName impl bnd f

1238+ then prettyName (ppopt_impl ppo) bnd f

1148− else enclose lparen rparen $

1239+ else enclose lparen rparen $ prettyName (ppopt_impl ppo) bnd f

1149− prettyName impl bnd f

1150 prettySe p bnd (PAppBind _ (PRef _ f) [])

1240 prettySe p bnd (PAppBind _ (PRef _ f) [])

1151− | not impl = text "!" <> prettyName impl bnd f

1241+ | not (ppopt_impl ppo) = text "!" <> prettyName (ppopt_impl ppo) bnd f

1152− prettySe p bnd (PApp _ (PRef _ op) args)

1242+ prettySe p bnd (PApp _ (PRef _ op) args) -- infix operators

1153 | UN nm <- basename op

1243 | UN nm <- basename op

1154 , not (tnull nm) &&

1244 , not (tnull nm) &&

1155− (not impl) && (not $ isAlpha (thead nm)) =

1245+ (not (ppopt_impl ppo)) && (not $ isAlpha (thead nm)) =

1156 case getExps args of

1246 case getExps args of

1157 [] -> enclose lparen rparen opName

1247 [] -> enclose lparen rparen opName

1158 [x] -> group (enclose lparen rparen opName <$> group (prettySe 0 bnd x))

1248 [x] -> group (enclose lparen rparen opName <$> group (prettySe 0 bnd x))

1249+ [l,r] -> let precedence = fromMaybe 20 (fmap prec f)

1159− [l,r] -> bracket p 1 $ inFix l r

1250+ in bracket p precedence $ inFix l r

1160 (l:r:rest) -> bracket p 1 $

1251 (l:r:rest) -> bracket p 1 $

1161 enclose lparen rparen (inFix l r) <+>

1252 enclose lparen rparen (inFix l r) <+>

1162 align (group (vsep (map (prettyArgSe bnd) rest)))

1253 align (group (vsep (map (prettyArgSe bnd) rest)))

1163− where opName = prettyName impl bnd op

1254+ where opName = prettyName (ppopt_impl ppo) bnd op

1255+ f = getFixity (opStr op)

1256+ left l = case f of

1257+ Nothing -> prettySe (-1) bnd l

1258+ Just (Infixl p') -> prettySe p' bnd l

1259+ Just f' -> prettySe (prec f'-1) bnd l

1260+ right r = case f of

1261+ Nothing -> prettySe (-1) bnd r

1262+ Just (Infixr p') -> prettySe p' bnd r

1263+ Just f' -> prettySe (prec f'-1) bnd r

1164 inFix l r = align . group $

1264 inFix l r = align . group $

1165− (prettySe 1 bnd l <+> opName) <$> group (prettySe 0 bnd r)

1265+ (left l <+> opName) <$> group (right r)

1166− prettySe p bnd (PApp _ hd@(PRef fc f) [tm])

1266+ prettySe p bnd (PApp _ hd@(PRef fc f) [tm]) -- symbols, like 'foo

1167 | PConstant (Idris.Core.TT.Str str) <- getTm tm,

1267 | PConstant (Idris.Core.TT.Str str) <- getTm tm,

1268+ f == sUN "Symbol_" = annotate (AnnType ("'" ++ str) ("The symbol " ++ str)) $

1168− f == sUN "Symbol_" = char '\'' <> prettySe 10 bnd (PRef fc (sUN str))

1269+ char '\'' <> prettySe 10 bnd (PRef fc (sUN str))

1169− prettySe p bnd (PApp _ f as) =

1270+ prettySe p bnd (PApp _ f as) = -- Normal prefix applications

1170 let args = getExps as

1271 let args = getExps as

1171 fp = prettySe 1 bnd f

1272 fp = prettySe 1 bnd f

1172 in

1273 in

1173 bracket p 1 . group $

1274 bracket p 1 . group $

1174− if impl

1275+ if ppopt_impl ppo

1175 then if null as

1276 then if null as

1176 then fp

1277 then fp

1177 else fp <+> align (vsep (map (prettyArgS bnd) as))

1278 else fp <+> align (vsep (map (prettyArgS bnd) as))

@@ -1179,22 +1280,22 @@ pprintPTerm impl bnd = prettySe 10 bnd

1179 then fp

1280 then fp

1180 else fp <+> align (vsep (map (prettyArgSe bnd) args))

1281 else fp <+> align (vsep (map (prettyArgSe bnd) args))

1181 prettySe p bnd (PCase _ scr opts) =

1282 prettySe p bnd (PCase _ scr opts) =

1182− text "case" <+> prettySe 10 bnd scr <+> text "of" <> prettyBody

1283+ kwd "case" <+> prettySe 10 bnd scr <+> kwd "of" <> prettyBody

1183 where

1284 where

1184 prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts

1285 prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts

1185

1286

1186 sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r

1287 sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r

1187 prettySe p bnd (PHidden tm) = text "." <> prettySe 0 bnd tm

1288 prettySe p bnd (PHidden tm) = text "." <> prettySe 0 bnd tm

1188− prettySe p bnd (PRefl _ _) = annotate (AnnName eqCon Nothing Nothing) $ text "refl"

1289+ prettySe p bnd (PRefl _ _) = annName eqCon $ text "refl"

1189 prettySe p bnd (PResolveTC _) = text "resolvetc"

1290 prettySe p bnd (PResolveTC _) = text "resolvetc"

1190− prettySe p bnd (PTrue _ IsType) = annotate (AnnName unitTy Nothing Nothing) $ text "()"

1291+ prettySe p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1191− prettySe p bnd (PTrue _ IsTerm) = annotate (AnnName unitCon Nothing Nothing) $ text "()"

1292+ prettySe p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

1192 prettySe p bnd (PTrue _ TypeOrTerm) = text "()"

1293 prettySe p bnd (PTrue _ TypeOrTerm) = text "()"

1193− prettySe p bnd (PFalse _) = annotate (AnnName falseTy Nothing Nothing) $ text "_|_"

1294+ prettySe p bnd (PFalse _) = annName falseTy $ text "_|_"

1194 prettySe p bnd (PEq _ l r) =

1295 prettySe p bnd (PEq _ l r) =

1195 bracket p 2 . align . group $

1296 bracket p 2 . align . group $

1196 prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r)

1297 prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r)

1197− where eq = annotate (AnnName eqTy Nothing Nothing) (text "=")

1298+ where eq = annName eqTy (text "=")

1198 prettySe p bnd (PRewrite _ l r _) =

1299 prettySe p bnd (PRewrite _ l r _) =

1199 bracket p 2 $

1300 bracket p 2 $

1200 text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r

1301 text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r

@@ -1206,72 +1307,75 @@ pprintPTerm impl bnd = prettySe 10 bnd

1206 map (prettySe 10 bnd) elts

1307 map (prettySe 10 bnd) elts

1207 where ann = case pun of

1308 where ann = case pun of

1208 TypeOrTerm -> id

1309 TypeOrTerm -> id

1209− IsType -> annotate (AnnName pairTy Nothing Nothing)

1310+ IsType -> annName pairTy

1210− IsTerm -> annotate (AnnName pairCon Nothing Nothing)

1311+ IsTerm -> annName pairCon

1211 prettySe p bnd (PDPair _ TypeOrTerm l t r) =

1312 prettySe p bnd (PDPair _ TypeOrTerm l t r) =

1212 lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen

1313 lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen

1213 prettySe p bnd (PDPair _ IsType (PRef _ n) t r) =

1314 prettySe p bnd (PDPair _ IsType (PRef _ n) t r) =

1214− annotate (AnnName sigmaTy Nothing Nothing) lparen <>

1315+ annName sigmaTy lparen <>

1215 bindingOf n False <+>

1316 bindingOf n False <+>

1216− annotate (AnnName sigmaTy Nothing Nothing) (text "**") <+>

1317+ annName sigmaTy (text "**") <+>

1217 prettySe 10 ((n, False):bnd) r <>

1318 prettySe 10 ((n, False):bnd) r <>

1218− annotate (AnnName sigmaTy Nothing Nothing) rparen

1319+ annName sigmaTy rparen

1219 prettySe p bnd (PDPair _ IsType l t r) =

1320 prettySe p bnd (PDPair _ IsType l t r) =

1220− annotate (AnnName sigmaTy Nothing Nothing) lparen <>

1321+ annName sigmaTy lparen <>

1221 prettySe 10 bnd l <+>

1322 prettySe 10 bnd l <+>

1222− annotate (AnnName sigmaTy Nothing Nothing) (text "**") <+>

1323+ annName sigmaTy (text "**") <+>

1223 prettySe 10 bnd r <>

1324 prettySe 10 bnd r <>

1224− annotate (AnnName sigmaTy Nothing Nothing) rparen

1325+ annName sigmaTy rparen

1225 prettySe p bnd (PDPair _ IsTerm l t r) =

1326 prettySe p bnd (PDPair _ IsTerm l t r) =

1226− annotate (AnnName existsCon Nothing Nothing) lparen <>

1327+ annName existsCon lparen <>

1227 prettySe 10 bnd l <+>

1328 prettySe 10 bnd l <+>

1228− annotate (AnnName existsCon Nothing Nothing) (text "**") <+>

1329+ annName existsCon (text "**") <+>

1229 prettySe 10 bnd r <>

1330 prettySe 10 bnd r <>

1230− annotate (AnnName existsCon Nothing Nothing) rparen

1331+ annName existsCon rparen

1231 prettySe p bnd (PAlternative a as) =

1332 prettySe p bnd (PAlternative a as) =

1232 lparen <> text "|" <> prettyAs <> text "|" <> rparen

1333 lparen <> text "|" <> prettyAs <> text "|" <> rparen

1233 where

1334 where

1234 prettyAs =

1335 prettyAs =

1235 foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10 bnd) as

1336 foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10 bnd) as

1236− prettySe p bnd PType = annotate AnnConstType $ text "Type"

1337+ prettySe p bnd PType = annotate (AnnType "Type" "The type of types") $ text "Type"

1237− prettySe p bnd (PConstant c) = annotate (annot c) (text (show c))

1338+ prettySe p bnd (PConstant c) = annotate (AnnConst c) (text (show c))

1238− where annot (AType _) = AnnConstType

1239− annot StrType = AnnConstType

1240− annot PtrType = AnnConstType

1241− annot VoidType = AnnConstType

1242− annot _ = AnnConstData

1243 -- XXX: add pretty for tactics

1339 -- XXX: add pretty for tactics

1244 prettySe p bnd (PProof ts) =

1340 prettySe p bnd (PProof ts) =

1245 text "proof" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

1341 text "proof" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

1246 prettySe p bnd (PTactics ts) =

1342 prettySe p bnd (PTactics ts) =

1247 text "tactics" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

1343 text "tactics" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

1248 prettySe p bnd (PMetavar n) = text "?" <> pretty n

1344 prettySe p bnd (PMetavar n) = text "?" <> pretty n

1249− prettySe p bnd (PReturn f) = text "return"

1345+ prettySe p bnd (PReturn f) = kwd "return"

1250− prettySe p bnd PImpossible = text "impossible"

1346+ prettySe p bnd PImpossible = kwd "impossible"

1251 prettySe p bnd Placeholder = text "_"

1347 prettySe p bnd Placeholder = text "_"

1252 prettySe p bnd (PDoBlock _) = text "do block pretty not implemented"

1348 prettySe p bnd (PDoBlock _) = text "do block pretty not implemented"

1349+ prettySe p bnd (PCoerced t) = prettySe p bnd t

1253 prettySe p bnd (PElabError s) = pretty s

1350 prettySe p bnd (PElabError s) = pretty s

1254

1351

1255 prettySe p bnd _ = text "test"

1352 prettySe p bnd _ = text "test"

1256

1353

1257− prettyArgS bnd (PImp _ _ _ n tm _) = prettyArgSi bnd (n, tm)

1354+ prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)

1258− prettyArgS bnd (PExp _ _ tm _) = prettyArgSe bnd tm

1355+ prettyArgS bnd (PExp _ _ _ tm) = prettyArgSe bnd tm

1259− prettyArgS bnd (PConstraint _ _ tm _) = prettyArgSc bnd tm

1356+ prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm

1260− prettyArgS bnd (PTacImplicit _ _ n _ tm _) = prettyArgSti bnd (n, tm)

1357+ prettyArgS bnd (PTacImplicit _ _ n _ tm) = prettyArgSti bnd (n, tm)

1261

1358

1262 prettyArgSe bnd arg = prettySe 0 bnd arg

1359 prettyArgSe bnd arg = prettySe 0 bnd arg

1263 prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1360 prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1264 prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace

1361 prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace

1265− prettyArgSti bnd (n, val) = lbrace <> text "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1362+ prettyArgSti bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1363+

1364+ annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

1365+ annName n = annotate (AnnName n Nothing Nothing Nothing)

1366+

1367+ opStr :: Name -> String

1368+ opStr (NS n _) = opStr n

1369+ opStr (UN n) = T.unpack n

1266

1370

1267 basename :: Name -> Name

1371 basename :: Name -> Name

1268 basename (NS n _) = basename n

1372 basename (NS n _) = basename n

1269 basename n = n

1373 basename n = n

1270

1374

1271 slist' p bnd (PApp _ (PRef _ nil) _)

1375 slist' p bnd (PApp _ (PRef _ nil) _)

1272− | not impl && nsroot nil == sUN "Nil" = Just []

1376+ | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []

1273 slist' p bnd (PRef _ nil)

1377 slist' p bnd (PRef _ nil)

1274− | not impl && nsroot nil == sUN "Nil" = Just []

1378+ | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []

1275 slist' p bnd (PApp _ (PRef _ cons) args)

1379 slist' p bnd (PApp _ (PRef _ cons) args)

1276 | nsroot cons == sUN "::",

1380 | nsroot cons == sUN "::",

1277 (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,

1381 (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,

@@ -1284,16 +1388,16 @@ pprintPTerm impl bnd = prettySe 10 bnd

1284 slist' _ _ tm = Nothing

1388 slist' _ _ tm = Nothing

1285

1389

1286 slist p bnd e | Just es <- slist' p bnd e = Just $

1390 slist p bnd e | Just es <- slist' p bnd e = Just $

1287− case es of [] -> annotate AnnConstData $ text "[]"

1391+ case es of [] -> annotate (AnnData "" "") $ text "[]"

1288 [x] -> enclose left right . group $

1392 [x] -> enclose left right . group $

1289 prettySe p bnd x

1393 prettySe p bnd x

1290 xs -> (enclose left right .

1394 xs -> (enclose left right .

1291 align . group . vsep .

1395 align . group . vsep .

1292 punctuate comma .

1396 punctuate comma .

1293 map (prettySe p bnd)) xs

1397 map (prettySe p bnd)) xs

1294− where left = (annotate AnnConstData (text "["))

1398+ where left = (annotate (AnnData "" "") (text "["))

1295− right = (annotate AnnConstData (text "]"))

1399+ right = (annotate (AnnData "" "") (text "]"))

1296− comma = (annotate AnnConstData (text ","))

1400+ comma = (annotate (AnnData "" "") (text ","))

1297 slist _ _ _ = Nothing

1401 slist _ _ _ = Nothing

1298

1402

1299 pairElts :: PTerm -> Maybe [PTerm]

1403 pairElts :: PTerm -> Maybe [PTerm]

@@ -1315,6 +1419,19 @@ pprintPTerm impl bnd = prettySe 10 bnd

1315 | inner > outer = lparen <> doc <> rparen

1419 | inner > outer = lparen <> doc <> rparen

1316 | otherwise = doc

1420 | otherwise = doc

1317

1421

1422+ kwd = annotate AnnKeyword . text

1423+

1424+ fixities :: M.Map String Fixity

1425+ fixities = M.fromList [(s, f) | (Fix f s) <- infixes]

1426+

1427+ getFixity :: String -> Maybe Fixity

1428+ getFixity = flip M.lookup fixities

1429+

1430+prettyDocumentedIst :: IState -> (Name, PTerm, Maybe Docstring) -> Doc OutputAnnotation

1431+prettyDocumentedIst ist (name, ty, docs) =

1432+ prettyName True [] name <+> colon <+> align (prettyIst ist ty) <$>

1433+ fromMaybe empty (fmap (\d -> renderDocstring d <> line) docs)

1434+

1318-- | Pretty-printer helper for the binding site of a name

1435-- | Pretty-printer helper for the binding site of a name

1319bindingOf :: Name -- ^^ the bound name

1436bindingOf :: Name -- ^^ the bound name

1320 -> Bool -- ^^ whether the name is implicit

1437 -> Bool -- ^^ whether the name is implicit

@@ -1327,68 +1444,69 @@ prettyName :: Bool -- ^^ whether to show namespaces

1327 -> Name -- ^^ the name to pprint

1444 -> Name -- ^^ the name to pprint

1328 -> Doc OutputAnnotation

1445 -> Doc OutputAnnotation

1329prettyName showNS bnd n | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) (text (strName n))

1446prettyName showNS bnd n | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) (text (strName n))

1330− | otherwise = annotate (AnnName n Nothing Nothing) (text (strName n))

1447+ | otherwise = annotate (AnnName n Nothing Nothing Nothing) (text (strName n))

1331 where strName (UN n) = T.unpack n

1448 where strName (UN n) = T.unpack n

1332 strName (NS n ns) | showNS = (concatMap (++ ".") . map T.unpack . reverse) ns ++ strName n

1449 strName (NS n ns) | showNS = (concatMap (++ ".") . map T.unpack . reverse) ns ++ strName n

1333 | otherwise = strName n

1450 | otherwise = strName n

1451+ strName n | n == falseTy = "_|_"

1334 strName (MN i s) = T.unpack s

1452 strName (MN i s) = T.unpack s

1335 strName other = show other

1453 strName other = show other

1336

1454

1337

1455

1338−showCImp :: Bool -> PClause -> Doc OutputAnnotation

1456+showCImp :: PPOption -> PClause -> Doc OutputAnnotation

1339−showCImp impl (PClause _ n l ws r w)

1457+showCImp ppo (PClause _ n l ws r w)

1340− = prettyImp impl l <+> showWs ws <+> text "=" <+> prettyImp impl r

1458+ = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r

1341 <+> text "where" <+> text (show w)

1459 <+> text "where" <+> text (show w)

1342 where

1460 where

1343 showWs [] = empty

1461 showWs [] = empty

1344− showWs (x : xs) = text "|" <+> prettyImp impl x <+> showWs xs

1462+ showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

1345−showCImp impl (PWith _ n l ws r w)

1463+showCImp ppo (PWith _ n l ws r w)

1346− = prettyImp impl l <+> showWs ws <+> text "with" <+> prettyImp impl r

1464+ = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

1347 <+> braces (text (show w))

1465 <+> braces (text (show w))

1348 where

1466 where

1349 showWs [] = empty

1467 showWs [] = empty

1350− showWs (x : xs) = text "|" <+> prettyImp impl x <+> showWs xs

1468+ showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

1351

1469

1352

1470

1353−showDImp :: Bool -> PData -> Doc OutputAnnotation

1471+showDImp :: PPOption -> PData -> Doc OutputAnnotation

1354−showDImp impl (PDatadecl n ty cons)

1472+showDImp ppo (PDatadecl n ty cons)

1355− = text "data" <+> text (show n) <+> colon <+> prettyImp impl ty <+> text "where" <$>

1473+ = text "data" <+> text (show n) <+> colon <+> prettyImp ppo ty <+> text "where" <$>

1356− (indent 2 $ vsep (map (\ (_, n, t, _, _) -> pipe <+> prettyName False [] n <+> colon <+> prettyImp impl t) cons))

1474+ (indent 2 $ vsep (map (\ (_, _, n, t, _, _) -> pipe <+> prettyName False [] n <+> colon <+> prettyImp ppo t) cons))

1357

1475

1358−showDecls :: Bool -> [PDecl] -> Doc OutputAnnotation

1476+showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

1359−showDecls i ds = vsep (map (showDeclImp i) ds)

1477+showDecls o ds = vsep (map (showDeclImp o) ds)

1360

1478

1361showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))

1479showDeclImp _ (PFix _ f ops) = text (show f) <+> cat (punctuate (text ",") (map text ops))

1362−showDeclImp i (PTy _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp i t

1480+showDeclImp o (PTy _ _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t

1363−showDeclImp i (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>

1481+showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>

1364− indent 2 (vsep (map (showCImp i) cs))

1482+ indent 2 (vsep (map (showCImp o) cs))

1365−showDeclImp _ (PData _ _ _ _ d) = showDImp True d

1483+showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d

1366−showDeclImp i (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls i ps <> line)

1484+showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)

1367−showDeclImp i (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls i ps <> line)

1485+showDeclImp o (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

1368showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

1486showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

1369−showDeclImp i (PClass _ _ _ cs n ps ds)

1487+showDeclImp o (PClass _ _ _ cs n ps _ ds)

1370− = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls i ds

1488+ = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds

1371−showDeclImp i (PInstance _ _ cs n _ t _ ds)

1489+showDeclImp o (PInstance _ _ cs n _ t _ ds)

1372− = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp i t <> line <> showDecls i ds

1490+ = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

1373showDeclImp _ _ = text "..."

1491showDeclImp _ _ = text "..."

1374−-- showDeclImp (PImport i) = "import " ++ i

1492+-- showDeclImp (PImport o) = "import " ++ o

1375

1493

1376instance Show (Doc OutputAnnotation) where

1494instance Show (Doc OutputAnnotation) where

1377 show = flip (displayS . renderCompact) ""

1495 show = flip (displayS . renderCompact) ""

1378

1496

1379getImps :: [PArg] -> [(Name, PTerm)]

1497getImps :: [PArg] -> [(Name, PTerm)]

1380getImps [] = []

1498getImps [] = []

1381−getImps (PImp _ _ _ n tm _ : xs) = (n, tm) : getImps xs

1499+getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

1382getImps (_ : xs) = getImps xs

1500getImps (_ : xs) = getImps xs

1383

1501

1384getExps :: [PArg] -> [PTerm]

1502getExps :: [PArg] -> [PTerm]

1385getExps [] = []

1503getExps [] = []

1386−getExps (PExp _ _ tm _ : xs) = tm : getExps xs

1504+getExps (PExp _ _ _ tm : xs) = tm : getExps xs

1387getExps (_ : xs) = getExps xs

1505getExps (_ : xs) = getExps xs

1388

1506

1389getConsts :: [PArg] -> [PTerm]

1507getConsts :: [PArg] -> [PTerm]

1390getConsts [] = []

1508getConsts [] = []

1391−getConsts (PConstraint _ _ tm _ : xs) = tm : getConsts xs

1509+getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

1392getConsts (_ : xs) = getConsts xs

1510getConsts (_ : xs) = getConsts xs

1393

1511

1394getAll :: [PArg] -> [PTerm]

1512getAll :: [PArg] -> [PTerm]

@@ -1398,14 +1516,14 @@ getAll = map getTm

1398-- | Show Idris name

1516-- | Show Idris name

1399showName :: Maybe IState -- ^^ the Idris state, for information about names and colours

1517showName :: Maybe IState -- ^^ the Idris state, for information about names and colours

1400 -> [(Name, Bool)] -- ^^ the bound variables and whether they're implicit

1518 -> [(Name, Bool)] -- ^^ the bound variables and whether they're implicit

1401− -> Bool -- ^^ whether to show implicits

1519+ -> PPOption -- ^^ pretty printing options

1402 -> Bool -- ^^ whether to colourise

1520 -> Bool -- ^^ whether to colourise

1403 -> Name -- ^^ the term to show

1521 -> Name -- ^^ the term to show

1404 -> String

1522 -> String

1405−showName ist bnd impl colour n = case ist of

1523+showName ist bnd ppo colour n = case ist of

1406 Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

1524 Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

1407 Nothing -> showbasic n

1525 Nothing -> showbasic n

1408− where name = if impl then show n else showbasic n

1526+ where name = if ppopt_impl ppo then show n else showbasic n

1409 showbasic n@(UN _) = showCG n

1527 showbasic n@(UN _) = showCG n

1410 showbasic (MN _ s) = str s

1528 showbasic (MN _ s) = str s

1411 showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

1529 showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

@@ -1427,11 +1545,14 @@ showName ist bnd impl colour n = case ist of

1427showTm :: IState -- ^^ the Idris state, for information about identifiers and colours

1545showTm :: IState -- ^^ the Idris state, for information about identifiers and colours

1428 -> PTerm -- ^^ the term to show

1546 -> PTerm -- ^^ the term to show

1429 -> String

1547 -> String

1430−showTm ist = displayDecorated (consoleDecorate ist) . renderCompact . prettyImp (opt_showimp (idris_options ist))

1548+showTm ist = displayDecorated (consoleDecorate ist) .

1549+ renderPretty 0.8 100000 .

1550+ prettyImp (ppOptionIst ist)

1431

1551

1432-- | Show a term with implicits, no colours

1552-- | Show a term with implicits, no colours

1433showTmImpls :: PTerm -> String

1553showTmImpls :: PTerm -> String

1434−showTmImpls = flip (displayS . renderCompact . prettyImp True) ""

1554+showTmImpls = flip (displayS . renderCompact . prettyImp verbosePPOption) ""

1555+

1435

1556

1436

1557

1437instance Sized PTerm where

1558instance Sized PTerm where

@@ -1476,7 +1597,7 @@ getPArity _ = 0

1476

1597

1477allNamesIn :: PTerm -> [Name]

1598allNamesIn :: PTerm -> [Name]

1478allNamesIn tm = nub $ ni [] tm

1599allNamesIn tm = nub $ ni [] tm

1479− where

1600+ where -- TODO THINK added niTacImp, but is it right?

1480 ni env (PRef _ n)

1601 ni env (PRef _ n)

1481 | not (n `elem` env) = [n]

1602 | not (n `elem` env) = [n]

1482 ni env (PPatvar _ n) = [n]

1603 ni env (PPatvar _ n) = [n]

@@ -1484,7 +1605,7 @@ allNamesIn tm = nub $ ni [] tm

1484 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1605 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1485 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1606 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1486 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1607 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1487− ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc

1608+ ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

1488 ni env (PHidden tm) = ni env tm

1609 ni env (PHidden tm) = ni env tm

1489 ni env (PEq _ l r) = ni env l ++ ni env r

1610 ni env (PEq _ l r) = ni env l ++ ni env r

1490 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1611 ni env (PRewrite _ l r _) = ni env l ++ ni env r

@@ -1498,16 +1619,19 @@ allNamesIn tm = nub $ ni [] tm

1498 ni env (PNoImplicits tm) = ni env tm

1619 ni env (PNoImplicits tm) = ni env tm

1499 ni env _ = []

1620 ni env _ = []

1500

1621

1622+ niTacImp env (TacImp _ _ scr) = ni env scr

1623+ niTacImp _ _ = []

1624+

1501-- Return all names defined in binders in the given term

1625-- Return all names defined in binders in the given term

1502boundNamesIn :: PTerm -> [Name]

1626boundNamesIn :: PTerm -> [Name]

1503boundNamesIn tm = nub $ ni tm

1627boundNamesIn tm = nub $ ni tm

1504− where

1628+ where -- TODO THINK Added niTacImp, but is it right?

1505 ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as)

1629 ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as)

1506 ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as)

1630 ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as)

1507 ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os)

1631 ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os)

1508 ni (PLam n ty sc) = n : (ni ty ++ ni sc)

1632 ni (PLam n ty sc) = n : (ni ty ++ ni sc)

1509 ni (PLet n ty val sc) = n : (ni ty ++ ni val ++ ni sc)

1633 ni (PLet n ty val sc) = n : (ni ty ++ ni val ++ ni sc)

1510− ni (PPi _ n ty sc) = n : (ni ty ++ ni sc)

1634+ ni (PPi p n ty sc) = niTacImp p ++ (n : (ni ty ++ ni sc))

1511 ni (PEq _ l r) = ni l ++ ni r

1635 ni (PEq _ l r) = ni l ++ ni r

1512 ni (PRewrite _ l r _) = ni l ++ ni r

1636 ni (PRewrite _ l r _) = ni l ++ ni r

1513 ni (PTyped l r) = ni l ++ ni r

1637 ni (PTyped l r) = ni l ++ ni r

@@ -1521,6 +1645,9 @@ boundNamesIn tm = nub $ ni tm

1521 ni (PNoImplicits tm) = ni tm

1645 ni (PNoImplicits tm) = ni tm

1522 ni _ = []

1646 ni _ = []

1523

1647

1648+ niTacImp (TacImp _ _ scr) = ni scr

1649+ niTacImp _ = []

1650+

1524-- Return names which are free in the given term.

1651-- Return names which are free in the given term.

1525namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

1652namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

1526namesIn uvars ist tm = nub $ ni [] tm

1653namesIn uvars ist tm = nub $ ni [] tm

@@ -1534,7 +1661,7 @@ namesIn uvars ist tm = nub $ ni [] tm

1534 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1661 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1535 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1662 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1536 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1663 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1537− ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc

1664+ ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

1538 ni env (PEq _ l r) = ni env l ++ ni env r

1665 ni env (PEq _ l r) = ni env l ++ ni env r

1539 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1666 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1540 ni env (PTyped l r) = ni env l ++ ni env r

1667 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1548,21 +1675,24 @@ namesIn uvars ist tm = nub $ ni [] tm

1548 ni env (PNoImplicits tm) = ni env tm

1675 ni env (PNoImplicits tm) = ni env tm

1549 ni env _ = []

1676 ni env _ = []

1550

1677

1678+ niTacImp env (TacImp _ _ scr) = ni env scr

1679+ niTacImp _ _ = []

1680+

1551-- Return which of the given names are used in the given term.

1681-- Return which of the given names are used in the given term.

1552

1682

1553usedNamesIn :: [Name] -> IState -> PTerm -> [Name]

1683usedNamesIn :: [Name] -> IState -> PTerm -> [Name]

1554usedNamesIn vars ist tm = nub $ ni [] tm

1684usedNamesIn vars ist tm = nub $ ni [] tm

1555− where

1685+ where -- TODO THINK added niTacImp, but is it right?

1556 ni env (PRef _ n)

1686 ni env (PRef _ n)

1557 | n `elem` vars && not (n `elem` env)

1687 | n `elem` vars && not (n `elem` env)

1558− = case lookupTy n (tt_ctxt ist) of

1688+ = case lookupDefExact n (tt_ctxt ist) of

1559− [] -> [n]

1689+ Nothing -> [n]

1560 _ -> []

1690 _ -> []

1561 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1691 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1562 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1692 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1563 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1693 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1564 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1694 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1565− ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc

1695+ ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

1566 ni env (PEq _ l r) = ni env l ++ ni env r

1696 ni env (PEq _ l r) = ni env l ++ ni env r

1567 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1697 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1568 ni env (PTyped l r) = ni env l ++ ni env r

1698 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1576,3 +1706,5 @@ usedNamesIn vars ist tm = nub $ ni [] tm

1576 ni env (PNoImplicits tm) = ni env tm

1706 ni env (PNoImplicits tm) = ni env tm

1577 ni env _ = []

1707 ni env _ = []

1578

1708

1709+ niTacImp env (TacImp _ _ scr) = ni env scr

1710+ niTacImp _ _ = []

src/Idris/Apropos.hsnew file+91

@@ -0,0 +1,91 @@

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 all space-delimited components of

13+-- some string. Relevance is one or 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 (isAproposAll parts defs) ++

24+ map fst (isAproposAll parts docs))

25+ where isAproposAll [] xs = xs

26+ isAproposAll (what:more) xs = filter (isApropos what)

27+ (isAproposAll more xs)

28+ parts = filter ((> 0) . T.length) . T.splitOn (T.pack " ") $ what

29+

30+textIn :: T.Text -> T.Text -> Bool

31+textIn a b = T.isInfixOf (T.toLower a) (T.toLower b)

32+

33+class Apropos a where

34+ isApropos :: T.Text -> a -> Bool

35+

36+instance Apropos Name where

37+ isApropos str (UN n) = textIn str n

38+ isApropos str (NS n' ns) = isApropos str n' || any (textIn str) ns

39+ -- Handle special names from stdlib

40+ isApropos str n | (n == unitTy || n == unitCon) && str == T.pack "()" = True

41+ | n == falseTy && str == T.pack "_|_" = True

42+ | (n == pairTy || n == pairCon) && str == T.pack "," = True

43+ | n == eqTy && str == T.pack "=" = True

44+ | n == eqCon && (T.toLower str) == T.pack "refl" = True

45+ | (n == sigmaTy || n == existsCon) && str == T.pack "**" = True

46+ isApropos _ _ = False -- we don't care about case blocks, MNs, etc

47+

48+instance Apropos Def where

49+ isApropos str (Function ty tm) = isApropos str ty

50+ isApropos str (TyDecl _ ty) = isApropos str ty

51+ isApropos str (Operator ty _ _) = isApropos str ty

52+ isApropos str (CaseOp _ ty ty' _ _ _) = isApropos str ty

53+

54+instance Apropos (Binder (TT Name)) where

55+ isApropos str (Lam ty) = str == T.pack "\\" || isApropos str ty

56+ isApropos str (Pi ty) = str == T.pack "->" || isApropos str ty

57+ isApropos str (Let ty val) = str == T.pack "let" || isApropos str ty || isApropos str val

58+ isApropos str (NLet ty val) = str == T.pack "let" || isApropos str ty || isApropos str val

59+ isApropos str _ = False -- these shouldn't occur in defined libraries

60+

61+instance Apropos (TT Name) where

62+ isApropos str (P Ref n ty) = isApropos str n || isApropos str ty

63+ isApropos str (P (TCon _ _) n ty) = isApropos str n || isApropos str ty

64+ isApropos str (P (DCon _ _) n ty) = isApropos str n || isApropos str ty

65+ isApropos str (P Bound _ ty) = isApropos str ty

66+ isApropos str (Bind n b tm) = isApropos str b || isApropos str tm

67+ isApropos str (App t1 t2) = isApropos str t1 || isApropos str t2

68+ isApropos str (Constant const) = isApropos str const

69+ isApropos str _ = False

70+

71+instance Apropos Const where

72+ isApropos str c = textIn str (T.pack (show c))

73+

74+instance Apropos Docstring where

75+ isApropos str d = containsText str d

76+

77+instance (Apropos a, Apropos b) => Apropos (a, b) where

78+ isApropos str (x, y) = isApropos str x || isApropos str y

79+

80+instance (Apropos a) => Apropos (Maybe a) where

81+ isApropos str (Just x) = isApropos str x

82+ isApropos _ Nothing = False

83+

84+instance (Apropos a) => Apropos [a] where

85+ isApropos str xs = any (isApropos str) xs

86+

87+defType :: Def -> Type

88+defType (Function t _) = t

89+defType (TyDecl _ t) = t

90+defType (Operator t _ _) = t

91+defType (CaseOp _ t _ _ _ _) = t

src/Idris/CaseSplit.hs+48−16

@@ -14,6 +14,7 @@ import Idris.ElabTerm

14import Idris.Delaborate

15import Idris.Parser

16import Idris.Error

17+import Idris.Output

17

18

18import Idris.Core.TT

19import Idris.Core.TT

19import Idris.Core.Typecheck

20import Idris.Core.Typecheck

@@ -21,6 +22,7 @@ import Idris.Core.Evaluate

21

22

22import Data.Maybe

23import Data.Maybe

23import Data.Char

24import Data.Char

25+import Data.List (isPrefixOf, isSuffixOf)

24import Control.Monad

26import Control.Monad

25import Control.Monad.State.Strict

27import Control.Monad.State.Strict

26

28

@@ -51,7 +53,12 @@ names over '_', patterns over names, etc.

51split :: Name -> PTerm -> Idris [[(Name, PTerm)]]

53split :: Name -> PTerm -> Idris [[(Name, PTerm)]]

52split n t'

54split n t'

53 = do ist <- getIState

55 = do ist <- getIState

56+ -- Make sure all the names in the term are accessible

57+ mapM_ (\n -> setAccessibility n Public) (allNamesIn t')

54− (tm, ty, pats) <- elabValBind toplevel True (addImplPat ist t')

58+ (tm, ty, pats) <- elabValBind toplevel True True (addImplPat ist t')

59+ -- ASSUMPTION: tm is in normal form after elabValBind, so we don't

60+ -- need to do anything special to find out what family each argument

61+ -- is in

55 logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats)

62 logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats)

56-- iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty))

63-- iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty))

57-- iputStrLn (show pats)

64-- iputStrLn (show pats)

@@ -150,7 +157,7 @@ mergePat ist (PApp _ _ args) (PApp fc f args') t

150 where mergeArg x (y, t)

157 where mergeArg x (y, t)

151 = do tm' <- mergePat ist (getTm x) (getTm y) t

158 = do tm' <- mergePat ist (getTm x) (getTm y) t

152 case x of

159 case x of

153− (PImp _ _ _ _ _ _) ->

160+ (PImp _ _ _ _ _) ->

154 return (y { machine_inf = machine_inf x,

161 return (y { machine_inf = machine_inf x,

155 getTm = tm' })

162 getTm = tm' })

156 _ -> return (y { getTm = tm' })

163 _ -> return (y { getTm = tm' })

@@ -273,6 +280,8 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

273 nshow t = show t

280 nshow t = show t

274

281

275 -- if there's any {n} replace with {n=n}

282 -- if there's any {n} replace with {n=n}

283+ -- but don't replace it in comments

284+ expandBraces ('{' : '-' : xs) = '{' : '-' : xs

276 expandBraces ('{' : xs)

285 expandBraces ('{' : xs)

277 = let (brace, (_:rest)) = span (/= '}') xs in

286 = let (brace, (_:rest)) = span (/= '}') xs in

278 if (not ('=' `elem` brace))

287 if (not ('=' `elem` brace))

@@ -291,9 +300,11 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

291 if (before == n && not (isAlphaNum next))

300 if (before == n && not (isAlphaNum next))

292 then addBrackets tm ++ updatePat False n tm after

301 then addBrackets tm ++ updatePat False n tm after

293 else c : updatePat (not (isAlphaNum c)) n tm rest

302 else c : updatePat (not (isAlphaNum c)) n tm rest

294− updatePat start n tm (c:rest) = c : updatePat (not (isAlpha c)) n tm rest

303+ updatePat start n tm (c:rest) = c : updatePat (not ((isAlphaNum c) || c == '_')) n tm rest

295

304

296− addBrackets tm | ' ' `elem` tm = "(" ++ tm ++ ")"

305+ addBrackets tm | ' ' `elem` tm

306+ , not (isPrefixOf "(" tm)

307+ , not (isSuffixOf ")" tm) = "(" ++ tm ++ ")"

297 | otherwise = tm

308 | otherwise = tm

298

309

299getUniq nm i

310getUniq nm i

@@ -313,19 +324,24 @@ getClause :: Int -- ^ line number that the type is declared on

313 -> Name -- ^ Function name

324 -> Name -- ^ Function name

314 -> FilePath -- ^ Source file name

325 -> FilePath -- ^ Source file name

315 -> Idris String

326 -> Idris String

327+getClause l fn fp

328+ = do i <- getIState

329+ case lookupCtxt fn (idris_classes i) of

330+ [c] -> return (mkClassBodies i (class_methods c))

316−getClause l fn fp = do ty <- getInternalApp fp l

331+ _ -> do ty <- getInternalApp fp l

317− ist <- get

332+ ist <- get

318− let ap = mkApp ist ty []

333+ let ap = mkApp ist ty []

319− return (show fn ++ " " ++ ap ++

334+ return (show fn ++ " " ++ ap ++ "= ?"

320− "= ?" ++ show fn ++ "_rhs")

335+ ++ show fn ++ "_rhs")

336+ where mkApp :: IState -> PTerm -> [Name] -> String

321− where mkApp i (PPi (Exp _ _ _ False) (MN _ _) ty sc) used

337+ mkApp i (PPi (Exp _ _ False) (MN _ _) ty sc) used

322 = let n = getNameFrom i used ty in

338 = let n = getNameFrom i used ty in

323 show n ++ " " ++ mkApp i sc (n : used)

339 show n ++ " " ++ mkApp i sc (n : used)

324− mkApp i (PPi (Exp _ _ _ False) (UN n) ty sc) used

340+ mkApp i (PPi (Exp _ _ False) (UN n) ty sc) used

325 | thead n == '_'

341 | thead n == '_'

326 = let n = getNameFrom i used ty in

342 = let n = getNameFrom i used ty in

327 show n ++ " " ++ mkApp i sc (n : used)

343 show n ++ " " ++ mkApp i sc (n : used)

328− mkApp i (PPi (Exp _ _ _ False) n _ sc) used

344+ mkApp i (PPi (Exp _ _ False) n _ sc) used

329 = show n ++ " " ++ mkApp i sc (n : used)

345 = show n ++ " " ++ mkApp i sc (n : used)

330 mkApp i (PPi _ _ _ sc) used = mkApp i sc used

346 mkApp i (PPi _ _ _ sc) used = mkApp i sc used

331 mkApp i _ _ = ""

347 mkApp i _ _ = ""

@@ -340,6 +356,19 @@ getClause l fn fp = do ty <- getInternalApp fp l

340 ns -> uniqueNameFrom (mkSupply ns) used

356 ns -> uniqueNameFrom (mkSupply ns) used

341 getNameFrom i used _ = uniqueName (sUN "x") used

357 getNameFrom i used _ = uniqueName (sUN "x") used

342

358

359+ -- write method declarations, indent with 4 spaces

360+ mkClassBodies :: IState -> [(Name, (FnOpts, PTerm))] -> String

361+ mkClassBodies i ns

362+ = showSep "\n"

363+ (zipWith (\(n, (_, ty)) m -> " " ++

364+ def (show (nsroot n)) ++ " "

365+ ++ mkApp i ty []

366+ ++ "= ?"

367+ ++ show fn ++ "_rhs_" ++ show m) ns [1..])

368+

369+ def n@(x:xs) | not (isAlphaNum x) = "(" ++ n ++ ")"

370+ def n = n

371+

343getProofClause :: Int -- ^ line number that the type is declared

372getProofClause :: Int -- ^ line number that the type is declared

344 -> Name -- ^ Function name

373 -> Name -- ^ Function name

345 -> FilePath -- ^ Source file name

374 -> FilePath -- ^ Source file name

@@ -355,16 +384,19 @@ getProofClause l fn fp

355

384

356mkWith :: String -> Name -> String

385mkWith :: String -> Name -> String

357mkWith str n = let str' = replaceRHS str "with (_)"

386mkWith str n = let str' = replaceRHS str "with (_)"

358− newpat = " " ++

359− replaceRHS str "| with_pat = ?" ++ show n ++ "_rhs" in

360− str' ++ "\n" ++ newpat

387+ in str' ++ "\n" ++ newpat str

361

388

362 where replaceRHS [] str = str

389 where replaceRHS [] str = str

363 replaceRHS ('?':'=': rest) str = str

390 replaceRHS ('?':'=': rest) str = str

364− replaceRHS ('=': rest) str

391+ replaceRHS ('=': rest) str

365 | not ('=' `elem` rest) = str

392 | not ('=' `elem` rest) = str

366 replaceRHS (x : rest) str = x : replaceRHS rest str

393 replaceRHS (x : rest) str = x : replaceRHS rest str

367

394

395+ newpat ('>':patstr) = '>':newpat patstr

396+ newpat patstr =

397+ " " ++

398+ replaceRHS patstr "| with_pat = ?" ++ show n ++ "_rhs"

399+

368-- Replace _ with names in missing clauses

400-- Replace _ with names in missing clauses

369

401

370nameMissing :: [PTerm] -> Idris [PTerm]

402nameMissing :: [PTerm] -> Idris [PTerm]

src/Idris/Chaser.hs+1−1

@@ -82,7 +82,7 @@ buildTree built fp = btree [] fp

82 iLOG $ "CHASING " ++ show file

83 ibcsd <- valIBCSubDir i

84 ids <- allImportDirs

85− fp <- runIO $ findImport ids ibcsd file

85+ fp <- findImport ids ibcsd file

86 iLOG $ "Found " ++ show fp

87 mt <- runIO $ getIModTime fp

88 if (file `elem` built)

src/Idris/CmdOptions.hsnew file+149

@@ -0,0 +1,149 @@

1+{-# LANGUAGE Arrows #-}

2+module Idris.CmdOptions where

3+

4+import Idris.AbsSyntaxTree

5+import Idris.REPL

6+

7+import IRTS.CodegenCommon

8+

9+import Options.Applicative

10+import Options.Applicative.Arrows

11+import Data.Maybe

12+

13+import qualified Text.PrettyPrint.ANSI.Leijen as PP

14+

15+runArgParser :: IO [Opt]

16+runArgParser = do opts <- execParser $ info parser

17+ (fullDesc

18+ <> headerDoc (Just idrisHeader)

19+ <> progDescDoc (Just idrisProgDesc)

20+ <> footerDoc (Just idrisFooter)

21+ )

22+ return $ preProcOpts opts []

23+ where

24+ idrisHeader = PP.hsep [PP.text "Idris version", PP.text ver, PP.text ", (C) The Idris Community 2014"]

25+ idrisProgDesc = PP.vsep [PP.text "Idris is a general purpose pure functional programming language with dependent",

26+ PP.text "types. Dependent types allow types to be predicated on values, meaning that",

27+ PP.text "some aspects of a program’s behaviour can be specified precisely in the type.",

28+ PP.text "It is compiled, with eager evaluation. Its features are influenced by Haskell",

29+ PP.text "and ML.",

30+ PP.empty,

31+ PP.vsep $ map (\x -> PP.indent 4 (PP.text x)) [

32+ "+ Full dependent types with dependent pattern matching",

33+ "+ where clauses, with rule, simple case expressions",

34+ "+ pattern matching let and lambda bindings",

35+ "+ Type classes, monad comprehensions",

36+ "+ do notation, idiom brackets",

37+ "+ syntactic conveniences for lists, tuples, dependent pairs",

38+ "+ Totality checking",

39+ "+ Coinductive types",

40+ "+ Indentation significant syntax, extensible syntax",

41+ "+ Tactic based theorem proving (influenced by Coq)",

42+ "+ Cumulative universes",

43+ "+ Simple foreign function interface (to C)",

44+ "+ Hugs style interactive environment"

45+ ],

46+ PP.empty]

47+ idrisFooter = PP.vsep [PP.text "It is important to note that Idris is first and foremost a research tool",

48+ PP.text "and project. Thus the tooling provided and resulting programs created",

49+ PP.text "should not necessarily be seen as production ready nor for industrial use.",

50+ PP.empty,

51+ PP.text "More details over Idris can be found online here:",

52+ PP.empty,

53+ PP.indent 4 (PP.text "http://www.idris-lang.org/")]

54+

55+

56+

57+

58+pureArgParser :: [String] -> [Opt]

59+pureArgParser args = case execParserMaybe (info parser idm) args of

60+ Just opts -> preProcOpts opts []

61+ Nothing -> []

62+

63+parser :: Parser [Opt]

64+parser = runA $ proc () -> do

65+ flags <- asA parseFlags -< ()

66+ files <- asA (many $ argument ((fmap . fmap) Filename str) (metavar "FILES")) -< ()

67+ A parseVersion >>> A helper -< (flags ++ files)

68+

69+parseFlags :: Parser [Opt]

70+parseFlags = many $

71+ flag' NoBanner (long "nobanner" <> help "Suppress the banner")

72+ <|> flag' Quiet (short 'q' <> long "quiet" <> help "Quiet verbosity")

73+ <|> flag' Ideslave (long "ideslave")

74+ <|> (Client <$> strOption (long "client"))

75+ <|> (OLogging <$> option (long "log" <> metavar "LEVEL" <> help "Debugging log level"))

76+ <|> flag' NoBasePkgs (long "nobasepkgs")

77+ <|> flag' NoPrelude (long "noprelude")

78+ <|> flag' NoBuiltins (long "nobuiltins")

79+ <|> flag' NoREPL (long "check")

80+ <|> (Output <$> strOption (short 'o' <> long "output" <> metavar "FILE" <> help "Specify output file"))

81+ <|> flag' TypeCase (long "typecase")

82+ <|> flag' TypeInType (long "typeintype")

83+ <|> flag' DefaultTotal (long "total" <> help "Require functions to be total by default")

84+ <|> flag' DefaultPartial (long "partial")

85+ <|> flag' WarnPartial (long "warnpartial" <> help "Warn about undeclared partial functions")

86+ <|> flag' WarnReach (long "warnreach" <> help "Warn about reachable but inaccessible arguments")

87+ <|> flag' NoCoverage (long "nocoverage")

88+ <|> flag' ErrContext (long "errorcontext")

89+ <|> flag' ShowLibs (long "link" <> help "Display link flags")

90+ <|> flag' ShowLibdir (long "libdir" <> help "Display library directory")

91+ <|> flag' ShowIncs (long "include" <> help "Display the includes flags")

92+ <|> flag' Verbose (short 'V' <> long "verbose" <> help "Loud verbosity")

93+ <|> (IBCSubDir <$> strOption (long "ibcsubdir" <> metavar "FILE" <> help "Write IBC files into sub directory"))

94+ <|> (ImportDir <$> strOption (short 'i' <> long "idrispath" <> help "Add directory to the list of import paths"))

95+ <|> flag' WarnOnly (long "warn")

96+ <|> (Pkg <$> strOption (short 'p' <> long "package"))

97+ -- Package commands

98+ <|> (PkgBuild <$> strOption (long "build" <> metavar "IPKG" <> help "Build package"))

99+ <|> (PkgInstall <$> strOption (long "install" <> metavar "IPKG" <> help "Install package"))

100+ <|> (PkgREPL <$> strOption (long "repl"))

101+ <|> (PkgClean <$> strOption (long "clean" <> metavar "IPKG" <> help "Clean package"))

102+ <|> (PkgMkDoc <$> strOption (long "mkdoc" <> metavar "IPKG" <> help "Generate IdrisDoc for package"))

103+ <|> (PkgCheck <$> strOption (long "checkpkg" <> metavar "IPKG" <> help "Check package only"))

104+ <|> (PkgTest <$> strOption (long "testpkg" <> metavar "IPKG" <> help "Run tests for package"))

105+ -- Misc options

106+ <|> (BCAsm <$> strOption (long "bytecode"))

107+ <|> flag' (OutputTy Raw) (short 'S' <> long "codegenonly" <> help "Do no further compilation of code generator output")

108+ <|> flag' (OutputTy Object) (short 'c' <> long "compileonly" <> help "Compile to object files rather than an executable")

109+ <|> flag' (OutputTy MavenProject) (long "mvn" <> help "Create a maven project (for Java codegen)")

110+ <|> (DumpDefun <$> strOption (long "dumpdefuns"))

111+ <|> (DumpCases <$> strOption (long "dumpcases"))

112+ <|> ((\s -> UseCodegen $ parseCodegen s) <$> strOption (long "codegen" <> metavar "TARGET" <> help "Select code generator: C, Java, bytecode"))

113+ <|> (EvalExpr <$> strOption (long "eval" <> short 'e' <> metavar "EXPR" <> help "Evaluate an expression without loading the REPL"))

114+ <|> flag' (InterpretScript "Main.main") (long "execute" <> help "Execute as idris")

115+ <|> (InterpretScript <$> strOption (long "exec" <> metavar "EXPR" <> help "Execute as idris"))

116+ <|> ((\s -> Extension $ getExt s) <$> strOption (long "extension" <> short 'X' <> metavar "EXT" <> help "Turn on langage extension (TypeProviders or ErrorReflection)"))

117+ <|> flag' (OptLevel 3) (long "O3")

118+ <|> flag' (OptLevel 2) (long "O2")

119+ <|> flag' (OptLevel 1) (long "O1")

120+ <|> flag' (OptLevel 0) (long "O0")

121+ <|> (OptLevel <$> option (short 'O' <> long "level"))

122+ <|> (TargetTriple <$> strOption (long "target" <> metavar "TRIPLE" <> help "Select target triple (for llvm codegen)"))

123+ <|> (TargetCPU <$> strOption (long "cpu" <> metavar "CPU" <> help "Select target CPU e.g. corei7 or cortex-m3 (for LLVM codegen)"))

124+ <|> flag' (ColourREPL True) (long "colour" <> long "color" <> help "Force coloured output")

125+ <|> flag' (ColourREPL False) (long "nocolour" <> long "nocolor" <> help "Disable coloured output")

126+ where

127+ getExt s = case maybeRead s of

128+ Just ext -> ext

129+ Nothing -> error ("Unknown extension " ++ s)

130+ maybeRead = fmap fst . listToMaybe . reads

131+

132+parseVersion :: Parser (a -> a)

133+parseVersion = infoOption ver (short 'v' <> long "version" <> help "Print version information")

134+

135+preProcOpts :: [Opt] -> [Opt] -> [Opt]

136+preProcOpts [] ys = ys

137+preProcOpts (NoBuiltins:xs) ys = NoBuiltins : NoPrelude : preProcOpts xs ys

138+preProcOpts (Output s:xs) ys = Output s : NoREPL : preProcOpts xs ys

139+preProcOpts (BCAsm s:xs) ys = BCAsm s : NoREPL : preProcOpts xs ys

140+preProcOpts (x:xs) ys = preProcOpts xs (x:ys)

141+

142+parseCodegen :: String -> Codegen

143+parseCodegen "C" = ViaC

144+parseCodegen "Java" = ViaJava

145+parseCodegen "bytecode" = Bytecode

146+parseCodegen "javascript" = ViaJavaScript

147+parseCodegen "node" = ViaNode

148+parseCodegen "llvm" = ViaLLVM

149+parseCodegen _ = error "unknown codegen" -- FIXME: partial function

src/Idris/Colours.hs+22−13

@@ -2,10 +2,9 @@ module Idris.Colours (

2 IdrisColour(..),

3 ColourTheme(..),

4 defaultTheme,

5− colouriseKwd, colouriseBound, colouriseImplicit,

5+ colouriseKwd, colouriseBound, colouriseImplicit, colourisePostulate,

6− colouriseType, colouriseFun, colouriseData,

6+ colouriseType, colouriseFun, colouriseData, colouriseKeyword,

7− colourisePrompt,

7+ colourisePrompt, colourise, ColourType(..)) where

8− ColourType(..)) where

9

8

10import System.Console.ANSI

9import System.Console.ANSI

11

10

@@ -20,27 +19,30 @@ data IdrisColour = IdrisColour { colour :: Maybe Color

20mkColour :: Color -> IdrisColour

19mkColour :: Color -> IdrisColour

21mkColour c = IdrisColour (Just c) True False False False

20mkColour c = IdrisColour (Just c) True False False False

22

21

23−data ColourTheme = ColourTheme { keywordColour :: IdrisColour

22+data ColourTheme = ColourTheme { keywordColour :: IdrisColour

24− , boundVarColour :: IdrisColour

23+ , boundVarColour :: IdrisColour

25− , implicitColour :: IdrisColour

24+ , implicitColour :: IdrisColour

26− , functionColour :: IdrisColour

25+ , functionColour :: IdrisColour

27− , typeColour :: IdrisColour

26+ , typeColour :: IdrisColour

28− , dataColour :: IdrisColour

27+ , dataColour :: IdrisColour

29− , promptColour :: IdrisColour

28+ , promptColour :: IdrisColour

29+ , postulateColour :: IdrisColour

30 }

31 deriving (Eq, Show)

32

33+-- | Idris's default console colour theme

33defaultTheme :: ColourTheme

34defaultTheme :: ColourTheme

34−defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True True True False

35+defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True False True False

35 , boundVarColour = mkColour Magenta

36 , boundVarColour = mkColour Magenta

36 , implicitColour = IdrisColour (Just Magenta) True True False False

37 , implicitColour = IdrisColour (Just Magenta) True True False False

37 , functionColour = mkColour Green

38 , functionColour = mkColour Green

38 , typeColour = mkColour Blue

39 , typeColour = mkColour Blue

39 , dataColour = mkColour Red

40 , dataColour = mkColour Red

40 , promptColour = IdrisColour Nothing True False True False

41 , promptColour = IdrisColour Nothing True False True False

42+ , postulateColour = IdrisColour (Just Green) True False True False

41 }

43 }

42

44

43−-- Set the colour of a string using POSIX escape codes

45+-- | Set the colour of a string using POSIX escape codes

44colourise :: IdrisColour -> String -> String

46colourise :: IdrisColour -> String -> String

45colourise (IdrisColour c v u b i) str = setSGRCode sgr ++ str ++ setSGRCode [Reset]

47colourise (IdrisColour c v u b i) str = setSGRCode sgr ++ str ++ setSGRCode [Reset]

46 where sgr = fg c ++

48 where sgr = fg c ++

@@ -71,6 +73,12 @@ colouriseData t = colourise (dataColour t)

71colourisePrompt :: ColourTheme -> String -> String

73colourisePrompt :: ColourTheme -> String -> String

72colourisePrompt t = colourise (promptColour t)

74colourisePrompt t = colourise (promptColour t)

73

75

76+colouriseKeyword :: ColourTheme -> String -> String

77+colouriseKeyword t = colourise (keywordColour t)

78+

79+colourisePostulate :: ColourTheme -> String -> String

80+colourisePostulate t = colourise (postulateColour t)

81+

74

82

75data ColourType = KeywordColour

83data ColourType = KeywordColour

76 | BoundVarColour

84 | BoundVarColour

@@ -79,4 +87,5 @@ data ColourType = KeywordColour

79 | TypeColour

87 | TypeColour

80 | DataColour

88 | DataColour

81 | PromptColour

89 | PromptColour

90+ | PostulateColour

82 deriving (Eq, Show, Bounded, Enum)

91 deriving (Eq, Show, Bounded, Enum)

src/Idris/Completion.hs+8−2

@@ -51,7 +51,7 @@ tacticArgs = [ ("intro", Nothing) -- FIXME syntax for intro (fresh name)

51 , (":eval", Just ExprTArg)

52 ] ++ map (\x -> (x, Nothing)) [

53 "intros", "compute", "trivial", "search", "solve", "attack",

54− "state", "term", "undo", "qed", "abandon", ":q"

54+ "unify", "state", "term", "undo", "qed", "abandon", ":q"

55 ]

56tactics = map fst tacticArgs

57

@@ -108,7 +108,12 @@ completeMetaVar = completeWord Nothing (" \t(){}:" ++ opChars) completeM

108

109completeOption :: CompletionFunc Idris

110completeOption = completeWord Nothing " \t" completeOpt

111− where completeOpt = return . completeWith ["errorcontext", "showimplicits", "originalerrors"]

111+ where completeOpt = return . completeWith [ "errorcontext"

112+ , "showimplicits"

113+ , "originalerrors"

114+ , "autosolve"

115+ , "nobanner"

116+ ]

112

117

113completeConsoleWidth :: CompletionFunc Idris

118completeConsoleWidth :: CompletionFunc Idris

114completeConsoleWidth = completeWord Nothing " \t" completeW

119completeConsoleWidth = completeWord Nothing " \t" completeW

@@ -156,6 +161,7 @@ completeCmd cmd (prev, next) = fromMaybe completeCmdName $ fmap completeArg $ lo

156 completeArg NameArg = completeExpr [] (prev, next) -- FIXME only complete one name

161 completeArg NameArg = completeExpr [] (prev, next) -- FIXME only complete one name

157 completeArg OptionArg = completeOption (prev, next)

162 completeArg OptionArg = completeOption (prev, next)

158 completeArg ModuleArg = noCompletion (prev, next) -- FIXME do later

163 completeArg ModuleArg = noCompletion (prev, next) -- FIXME do later

164+ completeArg NamespaceArg = noCompletion (prev, next) -- FIXME do later

159 completeArg ExprArg = completeExpr [] (prev, next)

165 completeArg ExprArg = completeExpr [] (prev, next)

160 completeArg MetaVarArg = completeMetaVar (prev, next) -- FIXME only complete one name

166 completeArg MetaVarArg = completeMetaVar (prev, next) -- FIXME only complete one name

161 completeArg ColourArg = completeColour (prev, next)

167 completeArg ColourArg = completeColour (prev, next)

src/Idris/Core/CaseTree.hs+189−106

@@ -2,20 +2,34 @@

2

3module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..),

4 Phase(..), CaseTree,

5− simpleCase, small, namesUsed, findCalls, findUsedArgs) where

5+ simpleCase, small, namesUsed, findCalls, findUsedArgs,

6+ substSC, substAlt, mkForce) where

6

7

7import Idris.Core.TT

8import Idris.Core.TT

8

9

9import Control.Monad.State

10import Control.Monad.State

10import Data.Maybe

11import Data.Maybe

11import Data.List hiding (partition)

12import Data.List hiding (partition)

13+import qualified Data.List(partition)

12import Debug.Trace

14import Debug.Trace

13

15

14data CaseDef = CaseDef [Name] !SC [Term]

16data CaseDef = CaseDef [Name] !SC [Term]

15 deriving Show

17 deriving Show

16

18

19+-- Note: The case-tree elaborator only produces (Case n alts)-cases;

20+-- in other words, it never inspects anything else than variables.

21+--

22+-- ProjCase is a special powerful case construct that allows inspection

23+-- of compound terms. Occurrences of ProjCase arise no earlier than

24+-- in the function `prune` as a means of optimisation

25+-- of already built case trees.

26+--

27+-- While the intermediate representation (follows in the pipeline)

28+-- allows casing on arbitrary terms, here we choose to maintain the distinction

29+-- in order to allow for better optimisation opportunities.

30+--

17−data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

31+data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

18− | ProjCase t [CaseAlt' t] -- ^ special case for projections

32+ | ProjCase t [CaseAlt' t] -- ^ special case for projections/thunk-forcing before inspection

19 | STerm !t

33 | STerm !t

20 | UnmatchedCase String -- ^ error message

34 | UnmatchedCase String -- ^ error message

21 | ImpossibleCase -- ^ already checked to be impossible

35 | ImpossibleCase -- ^ already checked to be impossible

@@ -96,8 +110,7 @@ small n args t = let as = findAllUsedArgs t args in

96namesUsed :: SC -> [Name]

110namesUsed :: SC -> [Name]

97namesUsed sc = nub $ nu' [] sc where

111namesUsed sc = nub $ nu' [] sc where

98 nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n]

112 nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n]

99− nu' ps (ProjCase t alts) = nub $ (nut ps t ++

113+ nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts

100− (concatMap (nua ps) alts))

101 nu' ps (STerm t) = nub $ nut ps t

114 nu' ps (STerm t) = nub $ nut ps t

102 nu' ps _ = []

115 nu' ps _ = []

103

116

@@ -122,7 +135,7 @@ namesUsed sc = nub $ nu' [] sc where

122findCalls :: SC -> [Name] -> [(Name, [[Name]])]

135findCalls :: SC -> [Name] -> [(Name, [[Name]])]

123findCalls sc topargs = nub $ nu' topargs sc where

136findCalls sc topargs = nub $ nu' topargs sc where

124 nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts)

137 nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts)

125− nu' ps (ProjCase t alts) = nub (nut ps t ++ concatMap (nua ps) alts)

138+ nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts

126 nu' ps (STerm t) = nub $ nut ps t

139 nu' ps (STerm t) = nub $ nut ps t

127 nu' ps _ = []

140 nu' ps _ = []

128

141

@@ -159,7 +172,7 @@ directUse fn@(App f a)

159 | (P Ref (UN pfk) _, [App e w]) <- unApply fn,

172 | (P Ref (UN pfk) _, [App e w]) <- unApply fn,

160 pfk == txt "prim_fork"

173 pfk == txt "prim_fork"

161 = directUse e ++ directUse w -- HACK so that fork works

174 = directUse e ++ directUse w -- HACK so that fork works

162− | (P Ref (UN fce) _, [_, a]) <- unApply fn,

175+ | (P Ref (UN fce) _, [_, _, a]) <- unApply fn,

163 fce == txt "Force"

176 fce == txt "Force"

164 = directUse a -- forcing a value counts as a use

177 = directUse a -- forcing a value counts as a use

165 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

178 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

@@ -185,6 +198,22 @@ findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where

185 nua (SucCase _ sc) = nu' sc

198 nua (SucCase _ sc) = nu' sc

186 nua (DefaultCase sc) = nu' sc

199 nua (DefaultCase sc) = nu' sc

187

200

201+-- Return whether name is used anywhere in a case tree

202+isUsed :: SC -> Name -> Bool

203+isUsed sc n = used sc where

204+

205+ used (Case n' alts) = n == n' || or (map usedA alts)

206+ used (ProjCase t alts) = n `elem` freeNames t || or (map usedA alts)

207+ used (STerm t) = n `elem` freeNames t

208+ used _ = False

209+

210+ usedA (ConCase _ _ args sc) = used sc

211+ usedA (FnCase _ args sc) = used sc

212+ usedA (ConstCase _ sc) = used sc

213+ usedA (SucCase _ sc) = used sc

214+ usedA (DefaultCase sc) = used sc

215+

216+

188data Phase = CompileTime | RunTime

217data Phase = CompileTime | RunTime

189 deriving (Show, Eq)

218 deriving (Show, Eq)

190

219

@@ -192,10 +221,10 @@ data Phase = CompileTime | RunTime

192-- Work Right to Left

221-- Work Right to Left

193

222

194simpleCase :: Bool -> Bool -> Bool ->

223simpleCase :: Bool -> Bool -> Bool ->

195− Phase -> FC -> [Type] ->

224+ Phase -> FC -> [Int] -> [Type] ->

196 [([Name], Term, Term)] ->

225 [([Name], Term, Term)] ->

197 TC CaseDef

226 TC CaseDef

198−simpleCase tc cover reflect phase fc argtys cs

227+simpleCase tc cover reflect phase fc inacc argtys cs

199 = sc' tc cover phase fc (filter (\(_, _, r) ->

228 = sc' tc cover phase fc (filter (\(_, _, r) ->

200 case r of

229 case r of

201 Impossible -> False

230 Impossible -> False

@@ -213,7 +242,7 @@ simpleCase tc cover reflect phase fc argtys cs

213 OK pats ->

242 OK pats ->

214 let numargs = length (fst (head pats))

243 let numargs = length (fst (head pats))

215 ns = take numargs args

244 ns = take numargs args

216− (ns', ps') = order ns pats

245+ (ns', ps') = order [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats

217 (tree, st) = runState

246 (tree, st) = runState

218 (match ns' ps' (defaultCase cover))

247 (match ns' ps' (defaultCase cover))

219 ([], numargs, [])

248 ([], numargs, [])

@@ -382,21 +411,42 @@ partition xs = error $ "Partition " ++ show xs

382-- reorder the patterns so that the one with most distinct names

411-- reorder the patterns so that the one with most distinct names

383-- comes next. Take rightmost first, otherwise (i.e. pick value rather

412-- comes next. Take rightmost first, otherwise (i.e. pick value rather

384-- than dependency)

413-- than dependency)

385−

414+--

415+-- The first argument means [(Name, IsInaccessible)].

416+

386−order :: [Name] -> [Clause] -> ([Name], [Clause])

417+order :: [(Name, Bool)] -> [Clause] -> ([Name], [Clause])

387−order [] cs = ([], cs)

418+order [] cs = ([], cs)

388−order ns [] = (ns, [])

419+order ns' [] = (map fst ns', [])

389−order ns cs = let patnames = transpose (map (zip ns) (map fst cs))

420+order ns' cs = let patnames = transpose (map (zip ns') (map fst cs))

421+ -- only sort the arguments where there is no clash in

422+ -- constructor tags between families, and no constructor/constant

423+ -- clash, because otherwise we can't reliable make the

424+ -- case distinction on evaluation

425+ (patnames_ord, patnames_rest)

426+ = Data.List.partition (noClash . map snd) patnames

427+ -- note: sortBy . reverse is not nonsense because sortBy is stable

390− pats' = transpose (sortBy moreDistinct (reverse patnames)) in

428+ pats' = transpose (sortBy moreDistinct (reverse patnames_ord)

429+ ++ patnames_rest) in

391− (getNOrder pats', zipWith rebuild pats' cs)

430+ (getNOrder pats', zipWith rebuild pats' cs)

392 where

431 where

393− getNOrder [] = error $ "Failed order on " ++ show (ns, cs)

432+ getNOrder [] = error $ "Failed order on " ++ show (map fst ns', cs)

394− getNOrder (c : _) = map fst c

433+ getNOrder (c : _) = map (fst . fst) c

395

434

396 rebuild patnames clause = (map snd patnames, snd clause)

435 rebuild patnames clause = (map snd patnames, snd clause)

397

436

437+ noClash [] = True

438+ noClash (p : ps) = not (any (clashPat p) ps) && noClash ps

439+

440+ clashPat (PCon _ _ _) (PConst _) = True

441+ clashPat (PConst _) (PCon _ _ _) = True

442+ clashPat (PCon _ _ _) (PSuc _) = True

443+ clashPat (PSuc _) (PCon _ _ _) = True

444+ clashPat (PCon n i _) (PCon n' i' _) | i == i' = n /= n'

445+ clashPat _ _ = False

446+

447+ -- this compares (+isInaccessible, -numberOfCases)

398− moreDistinct xs ys = compare (numNames [] (map snd ys))

448+ moreDistinct xs ys = compare (snd . fst . head $ xs, numNames [] (map snd ys))

399− (numNames [] (map snd xs))

449+ (snd . fst . head $ ys, numNames [] (map snd xs))

400

450

401 numNames xs (PCon n _ _ : ps)

451 numNames xs (PCon n _ _ : ps)

402 | not (Left n `elem` xs) = numNames (Left n : xs) ps

452 | not (Left n `elem` xs) = numNames (Left n : xs) ps

@@ -576,91 +626,79 @@ depatt ns tm = dp [] tm

576-- FIXME: Do this for SucCase too

626-- FIXME: Do this for SucCase too

577prune :: Bool -- ^ Convert single branches to projections (only useful at runtime)

627prune :: Bool -- ^ Convert single branches to projections (only useful at runtime)

578 -> SC -> SC

628 -> SC -> SC

579−prune proj (Case n alts)

629+prune proj (Case n alts) = case alts' of

580− = let alts' = filter notErased (map pruneAlt alts) in

630+ [] -> ImpossibleCase

581− case alts' of

631+

582− [] -> ImpossibleCase

632+ -- Projection transformations prevent us from seeing some uses of ctor fields

583− as@(ConCase (UN delay) i [arg] sc : _)

633+ -- because they delete information about which ctor is being used.

584− | delay == txt "Delay"

634+ -- Consider:

585− -> if proj then mkForce n arg sc

635+ -- f (X x) = ... x ...

586− else Case n as

636+ -- vs.

637+ -- f x = ... x!0 ...

638+ --

639+ -- Hence, we disable this step.

640+ -- TODO: re-enable this in toIR

641+ --

642+ -- as@[ConCase cn i args sc]

643+ -- | proj -> mkProj n 0 args (prune proj sc)

644+ -- mkProj n i xs sc = foldr (\x -> projRep x n i) sc xs

645+

646+ -- If none of the args are used in the sc, however, we can just replace it

647+ -- with sc

648+ as@[ConCase cn i args sc]

649+ | proj -> let sc' = prune proj sc in

650+ if any (isUsed sc') args

587− as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc

651+ then Case n [ConCase cn i args sc']

588− else Case n as

652+ else sc'

653+

589− as@[SucCase cn sc] -> if proj then mkProj n (-1) [cn] sc

654+ [SucCase cn sc]

590− else Case n as

655+ | proj

656+ -> projRep cn n (-1) $ prune proj sc

657+

591− as@[ConstCase _ sc] -> prune proj sc

658+ [ConstCase _ sc]

659+ -> prune proj sc

660+

592− -- Bit of a hack here! The default case will always be 0, make sure

661+ -- Bit of a hack here! The default case will always be 0, make sure

593− -- it gets caught first.

662+ -- it gets caught first.

594− [s@(SucCase _ _), DefaultCase dc]

663+ [s@(SucCase _ _), DefaultCase dc]

595− -> Case n [ConstCase (BI 0) dc, s]

664+ -> Case n [ConstCase (BI 0) dc, s]

665+

596− as -> Case n as

666+ as -> Case n as

667+ where

668+ alts' = filter (not . erased) $ map pruneAlt alts

669+

597− where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)

670+ pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)

598− pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)

671+ pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)

599− pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

672+ pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

600− pruneAlt (SucCase n sc) = SucCase n (prune proj sc)

673+ pruneAlt (SucCase n sc) = SucCase n (prune proj sc)

601− pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

674+ pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

602−

675+

603− notErased (DefaultCase (STerm Erased)) = False

676+ erased (DefaultCase (STerm Erased)) = True

604− notErased (DefaultCase ImpossibleCase) = False

677+ erased (DefaultCase ImpossibleCase) = True

605− notErased _ = True

678+ erased _ = False

606−

679+

607− mkForce n arg (Case x alts)

608− | x == arg = ProjCase (forceArg n)

609− (map (mkForceAlt n arg) alts)

610− | otherwise = Case x (map (mkForceAlt n arg) alts)

611− mkForce n arg (ProjCase t alts)

612− = ProjCase (forceTm n arg t) (map (mkForceAlt n arg) alts)

613− mkForce n arg (STerm t) = STerm (forceTm n arg t)

614− mkForce n arg c = c

615−

616− mkForceAlt n arg (ConCase cn t args rhs)

617− = ConCase cn t args (mkForce n arg rhs)

618− mkForceAlt n arg (FnCase cn args rhs)

619− = FnCase cn args (mkForce n arg rhs)

620− mkForceAlt n arg (ConstCase t rhs)

621− = ConstCase t (mkForce n arg rhs)

622− mkForceAlt n arg (SucCase sn rhs)

623− = SucCase sn (mkForce n arg rhs)

624− mkForceAlt n arg (DefaultCase rhs)

625− = DefaultCase (mkForce n arg rhs)

626−

627− forceTm n arg t = subst arg (forceArg n) t

628−

629− forceArg n = App (App (P Ref (sUN "Force") Erased) Erased)

630− (P Bound n Erased)

631−

632− mkProj n i [] sc = prune proj sc

633− mkProj n i (x : xs) sc = mkProj n (i + 1) xs (projRep x n i sc)

634−

635− -- Change every 'n' in sc to 'n-1'

636−-- mkProjS n cn sc = prune proj (fmap projn sc) where

637−-- projn pn@(P _ n' _)

638−-- | cn == n' = App (App (P Ref (UN "prim__subBigInt") Erased)

639−-- (P Bound n Erased)) (Constant (BI 1))

640−-- projn t = t

641−

642− projRep :: Name -> Name -> Int -> SC -> SC

680+ projRep :: Name -> Name -> Int -> SC -> SC

643− projRep arg n i (Case x alts)

681+ projRep arg n i (Case x alts) | x == arg

644− | x == arg = ProjCase (Proj (P Bound n Erased) i)

682+ = ProjCase (Proj (P Bound n Erased) i) $ map (projRepAlt arg n i) alts

645− (map (projRepAlt arg n i) alts)

683+ projRep arg n i (Case x alts)

646− | otherwise = Case x (map (projRepAlt arg n i) alts)

684+ = Case x (map (projRepAlt arg n i) alts)

647− projRep arg n i (ProjCase t alts)

685+ projRep arg n i (ProjCase t alts)

648− = ProjCase (projRepTm arg n i t) (map (projRepAlt arg n i) alts)

686+ = ProjCase (projRepTm arg n i t) $ map (projRepAlt arg n i) alts

649− projRep arg n i (STerm t) = STerm (projRepTm arg n i t)

687+ projRep arg n i (STerm t) = STerm (projRepTm arg n i t)

650− projRep arg n i c = c -- unmatched

688+ projRep arg n i c = c

651−

689+

652− projRepAlt arg n i (ConCase cn t args rhs)

690+ projRepAlt arg n i (ConCase cn t args rhs)

653− = ConCase cn t args (projRep arg n i rhs)

691+ = ConCase cn t args (projRep arg n i rhs)

654− projRepAlt arg n i (FnCase cn args rhs)

692+ projRepAlt arg n i (FnCase cn args rhs)

655− = FnCase cn args (projRep arg n i rhs)

693+ = FnCase cn args (projRep arg n i rhs)

656− projRepAlt arg n i (ConstCase t rhs)

694+ projRepAlt arg n i (ConstCase t rhs)

657− = ConstCase t (projRep arg n i rhs)

695+ = ConstCase t (projRep arg n i rhs)

658− projRepAlt arg n i (SucCase sn rhs)

696+ projRepAlt arg n i (SucCase sn rhs)

659− = SucCase sn (projRep arg n i rhs)

697+ = SucCase sn (projRep arg n i rhs)

660− projRepAlt arg n i (DefaultCase rhs)

698+ projRepAlt arg n i (DefaultCase rhs)

661− = DefaultCase (projRep arg n i rhs)

699+ = DefaultCase (projRep arg n i rhs)

662−

700+

663− projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

701+ projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

664

702

665prune _ t = t

703prune _ t = t

666

704

@@ -669,6 +707,51 @@ stripLambdas (CaseDef ns (STerm (Bind x (Lam _) sc)) tm)

669 = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm)

707 = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm)

670stripLambdas x = x

708stripLambdas x = x

671

709

710+substSC :: Name -> Name -> SC -> SC

711+substSC n repl (Case n' alts)

712+ | n == n' = Case repl (map (substAlt n repl) alts)

713+ | otherwise = Case n' (map (substAlt n repl) alts)

714+substSC n repl (STerm t) = STerm $ subst n (P Bound repl Erased) t

715+substSC n repl (UnmatchedCase errmsg) = UnmatchedCase errmsg

716+substSC n repl ImpossibleCase = ImpossibleCase

717+substSC n repl sc = error $ "unsupported in substSC: " ++ show sc

718+

719+substAlt :: Name -> Name -> CaseAlt -> CaseAlt

720+substAlt n repl (ConCase cn a ns sc) = ConCase cn a ns (substSC n repl sc)

721+substAlt n repl (FnCase fn ns sc) = FnCase fn ns (substSC n repl sc)

722+substAlt n repl (ConstCase c sc) = ConstCase c (substSC n repl sc)

723+substAlt n repl (SucCase n' sc)

724+ | n == n' = SucCase n (substSC n repl sc)

725+ | otherwise = SucCase n' (substSC n repl sc)

726+substAlt n repl (DefaultCase sc) = DefaultCase (substSC n repl sc)

727+

728+mkForce :: Name -> Name -> SC -> SC

729+mkForce = mkForceSC

730+ where

731+ mkForceSC n arg (Case x alts) | x == arg

732+ = ProjCase (forceArg n) $ map (mkForceAlt n arg) alts

733+

734+ mkForceSC n arg (Case x alts)

735+ = Case x (map (mkForceAlt n arg) alts)

736+

737+ mkForceSC n arg (ProjCase t alts)

738+ = ProjCase (forceTm n arg t) $ map (mkForceAlt n arg) alts

739+

740+ mkForceSC n arg (STerm t) = STerm (forceTm n arg t)

741+ mkForceSC n arg c = c

672

742

743+ mkForceAlt n arg (ConCase cn t args rhs)

744+ = ConCase cn t args (mkForceSC n arg rhs)

745+ mkForceAlt n arg (FnCase cn args rhs)

746+ = FnCase cn args (mkForceSC n arg rhs)

747+ mkForceAlt n arg (ConstCase t rhs)

748+ = ConstCase t (mkForceSC n arg rhs)

749+ mkForceAlt n arg (SucCase sn rhs)

750+ = SucCase sn (mkForceSC n arg rhs)

751+ mkForceAlt n arg (DefaultCase rhs)

752+ = DefaultCase (mkForceSC n arg rhs)

673

753

754+ forceTm n arg t = subst arg (forceArg n) t

674

755

756+ forceArg n = App (App (App (P Ref (sUN "Force") Erased) Erased) Erased)

757+ (P Bound n Erased)

src/Idris/Core/Elaborate.hs+47−14

@@ -64,7 +64,7 @@ loadState :: Elab' aux ()

64loadState = do (ES p s e) <- get

65 case e of

66 Just st -> put st

67− _ -> fail "Nothing to undo"

67+ _ -> lift $ Error . Msg $ "Nothing to undo"

68

69getNameFrom :: Name -> Elab' aux Name

70getNameFrom n = do (ES (p, a) s e) <- get

@@ -131,14 +131,17 @@ force_term :: Elab' aux ()

131force_term = do ES (ps, a) l p <- get

132 put (ES (ps { pterm = force (pterm ps) }, a) l p)

133

134+-- | Modify the auxiliary state

134updateAux :: (aux -> aux) -> Elab' aux ()

135updateAux :: (aux -> aux) -> Elab' aux ()

135updateAux f = do ES (ps, a) l p <- get

136updateAux f = do ES (ps, a) l p <- get

136 put (ES (ps, f a) l p)

137 put (ES (ps, f a) l p)

137

138

139+-- | Get the auxiliary state

138getAux :: Elab' aux aux

140getAux :: Elab' aux aux

139getAux = do ES (ps, a) _ _ <- get

141getAux = do ES (ps, a) _ _ <- get

140 return $! a

142 return $! a

141

143

144+-- | Set whether to show the unifier log

142unifyLog :: Bool -> Elab' aux ()

145unifyLog :: Bool -> Elab' aux ()

143unifyLog log = do ES (ps, a) l p <- get

146unifyLog log = do ES (ps, a) l p <- get

144 put (ES (ps { unifylog = log }, a) l p)

147 put (ES (ps { unifylog = log }, a) l p)

@@ -147,11 +150,28 @@ getUnifyLog :: Elab' aux Bool

147getUnifyLog = do ES (ps, a) l p <- get

150getUnifyLog = do ES (ps, a) l p <- get

148 return (unifylog ps)

151 return (unifylog ps)

149

152

153+-- | Process a tactic within the current elaborator state

154+processTactic' :: Tactic -> Elab' aux ()

150processTactic' t = do ES (p, a) logs prev <- get

155processTactic' t = do ES (p, a) logs prev <- get

151 (p', log) <- lift $ processTactic t p

156 (p', log) <- lift $ processTactic t p

152 put (ES (p', a) (logs ++ log) prev)

157 put (ES (p', a) (logs ++ log) prev)

153 return $! ()

158 return $! ()

154

159

160+updatePS :: (ProofState -> ProofState) -> Elab' aux ()

161+updatePS f = do ES (ps, a) logs prev <- get

162+ put $ ES (f ps, a) logs prev

163+

164+now_elaborating :: FC -> Name -> Name -> Elab' aux ()

165+now_elaborating fc f a = updatePS (nowElaboratingPS fc f a)

166+done_elaborating_app :: Name -> Elab' aux ()

167+done_elaborating_app f = updatePS (doneElaboratingAppPS f)

168+done_elaborating_arg :: Name -> Name -> Elab' aux ()

169+done_elaborating_arg f a = updatePS (doneElaboratingArgPS f a)

170+elaborating_app :: Elab' aux [(FC, Name, Name)]

171+elaborating_app = do ES (ps, _) _ _ <- get

172+ return $ map (\ (FailContext x y z) -> (x, y, z))

173+ (while_elaborating ps)

174+

155-- Some handy gadgets for pulling out bits of state

175-- Some handy gadgets for pulling out bits of state

156

176

157-- get the global context

177-- get the global context

@@ -308,6 +328,10 @@ start_unify n = processTactic' (StartUnify n)

308end_unify :: Elab' aux ()

328end_unify :: Elab' aux ()

309end_unify = processTactic' EndUnify

329end_unify = processTactic' EndUnify

310

330

331+-- Clear the list of variables not to unify, and try to solve them

332+unify_all :: Elab' aux ()

333+unify_all = processTactic' UnifyAll

334+

311regret :: Elab' aux ()

335regret :: Elab' aux ()

312regret = processTactic' Regret

336regret = processTactic' Regret

313

337

@@ -595,10 +619,10 @@ simple_app fun arg appstr =

595 hs <- get_holes

619 hs <- get_holes

596 env <- get_env

620 env <- get_env

597 -- We don't need a and b in the hole queue any more since they were

621 -- 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.

622+ -- just for checking f, so move them to the end. If they never end up

599− -- If they haven't been solved, regret will fail

623+ -- getting solved, we'll get an 'Incomplete term' error.

600− when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr)

624+ when (a `elem` hs) $ do movelast a

601− when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr)

625+ when (b `elem` hs) $ do movelast b

602 end_unify

626 end_unify

603 where regretWith err = try regret

627 where regretWith err = try regret

604 (lift $ tfail err)

628 (lift $ tfail err)

@@ -622,12 +646,16 @@ no_errors tac err

622 Error _ -> lift $ Error e

646 Error _ -> lift $ Error e

623 OK (a, s') -> do put s'

647 OK (a, s') -> do put s'

624 return a

648 return a

649+ unifyProblems

625 ps' <- get_probs

650 ps' <- get_probs

626 if (length ps' > length ps) then

651 if (length ps' > length ps) then

627 case reverse ps' of

652 case reverse ps' of

628− ((x,y,env,err,_) : _) ->

653+ ((x, y, env, inerr, while, _) : _) ->

629 let env' = map (\(x, b) -> (x, binderTy b)) env in

654 let env' = map (\(x, b) -> (x, binderTy b)) env in

655+ lift $ tfail $

656+ case err of

630− lift $ tfail $ CantUnify False x y err env' 0

657+ Nothing -> CantUnify False x y inerr env' 0

658+ Just e -> e

631 else return $! ()

659 else return $! ()

632

660

633-- Try a tactic, if it fails, try another

661-- Try a tactic, if it fails, try another

@@ -653,11 +681,13 @@ try' :: Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a

653try' t1 t2 proofSearch

681try' t1 t2 proofSearch

654 = do s <- get

682 = do s <- get

655 ps <- get_probs

683 ps <- get_probs

684+ ulog <- getUnifyLog

656 case prunStateT 999999 False ps t1 s of

685 case prunStateT 999999 False ps t1 s of

657 OK ((v, _, _), s') -> do put s'

686 OK ((v, _, _), s') -> do put s'

658 return $! v

687 return $! v

688+ Error e1 -> traceWhen ulog ("try failed " ++ show e1) $

659− Error e1 -> if recoverableErr e1 then

689+ if recoverableErr e1 then

660− do case runStateT t2 s of

690+ do case runStateT t2 s of

661 OK (v, s') -> do put s'; return $! v

691 OK (v, s') -> do put s'; return $! v

662 Error e2 -> if score e1 >= score e2

692 Error e2 -> if score e1 >= score e2

663 then lift (tfail e1)

693 then lift (tfail e1)

@@ -667,7 +697,10 @@ try' t1 t2 proofSearch

667 = -- traceWhen r (show err) $

697 = -- traceWhen r (show err) $

668 r || proofSearch

698 r || proofSearch

669 recoverableErr (CantSolveGoal _ _) = False

699 recoverableErr (CantSolveGoal _ _) = False

700+ recoverableErr (ProofSearchFail (Msg _)) = True

670 recoverableErr (ProofSearchFail _) = False

701 recoverableErr (ProofSearchFail _) = False

702+ recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e

703+ recoverableErr (At _ e) = recoverableErr e

671 recoverableErr _ = True

704 recoverableErr _ = True

672

705

673tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a

706tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a

@@ -676,7 +709,7 @@ tryWhen False a b = a

676

709

677

710

678-- Try a selection of tactics. Exactly one must work, all others must fail

711-- Try a selection of tactics. Exactly one must work, all others must fail

679−tryAll :: [(Elab' aux a, String)] -> Elab' aux a

712+tryAll :: [(Elab' aux a, Name)] -> Elab' aux a

680tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs

713tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs

681 where

714 where

682 cantResolve :: Elab' aux a

715 cantResolve :: Elab' aux a

@@ -685,7 +718,7 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs

685 tryAll' :: [Elab' aux a] -> -- successes

718 tryAll' :: [Elab' aux a] -> -- successes

686 Int -> -- most problems

719 Int -> -- most problems

687 (Elab' aux a, Int) -> -- smallest failure

720 (Elab' aux a, Int) -> -- smallest failure

688− [(Elab' aux a, String)] -> -- still to try

721+ [(Elab' aux a, Name)] -> -- still to try

689 Elab' aux a

722 Elab' aux a

690 tryAll' [res] pmax _ [] = res

723 tryAll' [res] pmax _ [] = res

691 tryAll' (_:_) pmax _ [] = cantResolve

724 tryAll' (_:_) pmax _ [] = cantResolve

@@ -694,7 +727,7 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs

694 = do s <- get

727 = do s <- get

695 ps <- get_probs

728 ps <- get_probs

696 case prunStateT pmax True ps x s of

729 case prunStateT pmax True ps x s of

697− OK ((v, newps, probs), s') ->

730+ OK ((v, newps, probs), s') ->

698 do let cs' = if (newps < pmax)

731 do let cs' = if (newps < pmax)

699 then [do put s'; return $! v]

732 then [do put s'; return $! v]

700 else (do put s'; return $! v) : cs

733 else (do put s'; return $! v) : cs

@@ -716,12 +749,12 @@ prunStateT pmax zok ps x s

716 newpmax = if newps < 0 then 0 else newps in

749 newpmax = if newps < 0 then 0 else newps in

717 if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))

750 if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))

718 then case reverse (problems p) of

751 then case reverse (problems p) of

719− ((_,_,_,e,_):_) -> Error e

752+ ((_,_,_,e,_,_):_) -> Error e

720 else OK ((v, newpmax, problems p), s')

753 else OK ((v, newpmax, problems p), s')

721 Error e -> Error e

754 Error e -> Error e

722

755

723qshow :: Fails -> String

756qshow :: Fails -> String

724−qshow fs = show (map (\ (x, y, _, _, _) -> (x, y)) fs)

757+qshow fs = show (map (\ (x, y, _, _, _, _) -> (x, y)) fs)

725

758

726dumpprobs [] = ""

759dumpprobs [] = ""

727dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es

760dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es

src/Idris/Core/Evaluate.hs+68−26

@@ -8,12 +8,13 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,

8 Context, initContext, ctxtAlist, uconstraints, next_tvar,

9 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,

10 addDatatype, addCasedef, simplifyCasedef, addOperator,

11− lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal,

11+ lookupNames, lookupTyName, lookupTy, lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupVal,

12 mapDefCtxt,

13 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

14− Value(..), Quote(..), initEval, uniqueNameCtxt) where

14+ Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions) where

15

16import Debug.Trace

17+import Control.Applicative hiding (Const)

17import Control.Monad.State -- not Strict!

18import Control.Monad.State -- not Strict!

18import qualified Data.Binary as B

19import qualified Data.Binary as B

19import Data.Binary hiding (get, put)

20import Data.Binary hiding (get, put)

@@ -257,11 +258,24 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

257 return $ VBind True n (Let t' v') (\x -> return sc')

258 return $ VBind True n (Let t' v') (\x -> return sc')

258 ev ntimes stk top env (Bind n b sc)

259 ev ntimes stk top env (Bind n b sc)

259 = do b' <- vbind env b

260 = do b' <- vbind env b

260− let n' = uniqueName n (map fst env)

261+ let n' = uniqueName n (map fst genv ++ map fst env)

261 return $ VBind True -- (vinstances 0 sc < 2)

262 return $ VBind True -- (vinstances 0 sc < 2)

262− n' b' (\x -> ev ntimes stk False ((n, x):env) sc)

263+ n' b' (\x -> ev ntimes stk False ((n', x):env) sc)

263 where vbind env t

264 where vbind env t

264 = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t

265 = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t

266+ -- block reduction immediately under codata (and not forced)

267+ ev ntimes stk top env

268+ (App (App (App d@(P _ (UN dly) _) l@(P _ (UN lco) _)) t) arg)

269+ | dly == txt "Delay" && lco == txt "LazyCodata" && not simpl

270+ = do let (f, _) = unApply arg

271+ let ntimes' = case f of

272+ P _ fn _ -> (fn, 0) : ntimes

273+ _ -> ntimes

274+ d' <- ev ntimes' stk False env d

275+ l' <- ev ntimes' stk False env l

276+ t' <- ev ntimes' stk False env t

277+ arg' <- ev ntimes' stk False env arg

278+ evApply ntimes' stk top env [l',t',arg'] d'

265 -- Treat "assert_total" specially, as long as it's defined!

279 -- Treat "assert_total" specially, as long as it's defined!

266 ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)

280 ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)

267 | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

281 | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

@@ -523,7 +537,7 @@ wknV i t = return t

523convEq' ctxt hs x y = evalStateT (convEq ctxt hs x y) (0, [])

537convEq' ctxt hs x y = evalStateT (convEq ctxt hs x y) (0, [])

524

538

525convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

539convEq :: Context -> [Name] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

526−convEq ctxt holes = ceq [] where

540+convEq ctxt holes topx topy = ceq [] topx topy where

527 ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

541 ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

528 ceq ps (P xt x _) (P yt y _)

542 ceq ps (P xt x _) (P yt y _)

529 | x `elem` holes || y `elem` holes = return True

543 | x `elem` holes || y `elem` holes = return True

@@ -536,8 +550,14 @@ convEq ctxt holes = ceq [] where

536 ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y

550 ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y

537 | n == n' = ceq ps x y

551 | n == n' = ceq ps x y

538 ceq ps (V x) (V y) = return (x == y)

552 ceq ps (V x) (V y) = return (x == y)

553+ ceq ps (V x) (P _ y _)

554+ | x >= 0 && length ps > x = return (fst (ps!!x) == y)

555+ | otherwise = return False

556+ ceq ps (P _ x _) (V y)

557+ | y >= 0 && length ps > y = return (x == snd (ps!!y))

558+ | otherwise = return False

539− ceq ps (Bind _ xb xs) (Bind _ yb ys)

559+ ceq ps (Bind n xb xs) (Bind n' yb ys)

540− = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys)

560+ = liftM2 (&&) (ceqB ps xb yb) (ceq ((n,n'):ps) xs ys)

541 where

561 where

542 ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

562 ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

543 ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

563 ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

@@ -549,7 +569,7 @@ convEq ctxt holes = ceq [] where

549 return True

569 return True

550 ceq ps Erased _ = return True

570 ceq ps Erased _ = return True

551 ceq ps _ Erased = return True

571 ceq ps _ Erased = return True

552− ceq ps _ _ = return False

572+ ceq ps x y = return False

553

573

554 caseeq ps (Case n cs) (Case n' cs') = caseeqA ((n,n'):ps) cs cs'

574 caseeq ps (Case n cs) (Case n' cs') = caseeqA ((n,n'):ps) cs cs'

555 where

575 where

@@ -662,7 +682,7 @@ data Totality = Total [Int] -- ^ well-founded arguments

662

682

663-- | Reasons why a function may not be total

683-- | Reasons why a function may not be total

664data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name

684data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name

665− | BelieveMe | Mutual [Name] | NotProductive

685+ | ExternalIO | BelieveMe | Mutual [Name] | NotProductive

666 deriving (Show, Eq)

686 deriving (Show, Eq)

667

687

668instance Show Totality where

688instance Show Totality where

@@ -672,6 +692,7 @@ instance Show Totality where

672 show (Partial Itself) = "possibly not total as it is not well founded"

692 show (Partial Itself) = "possibly not total as it is not well founded"

673 show (Partial NotCovering) = "not total as there are missing cases"

693 show (Partial NotCovering) = "not total as there are missing cases"

674 show (Partial NotPositive) = "not strictly positive"

694 show (Partial NotPositive) = "not strictly positive"

695+ show (Partial ExternalIO) = "an external IO primitive"

675 show (Partial NotProductive) = "not productive"

696 show (Partial NotProductive) = "not productive"

676 show (Partial BelieveMe) = "not total due to use of believe_me in proof"

697 show (Partial BelieveMe) = "not total due to use of believe_me in proof"

677 show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns)

698 show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns)

@@ -769,6 +790,7 @@ addDatatype (Data n tag ty cons) uctxt

769-- FIXME: Too many arguments! Refactor all these Bools.

790-- FIXME: Too many arguments! Refactor all these Bools.

770addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

791addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

771 [Type] -> -- argument types

792 [Type] -> -- argument types

793+ [Int] -> -- inaccessible arguments

772 [Either Term (Term, Term)] ->

794 [Either Term (Term, Term)] ->

773 [([Name], Term, Term)] -> -- totality

795 [([Name], Term, Term)] -> -- totality

774 [([Name], Term, Term)] -> -- compile time

796 [([Name], Term, Term)] -> -- compile time

@@ -776,16 +798,16 @@ addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

776 [([Name], Term, Term)] -> -- run time

798 [([Name], Term, Term)] -> -- run time

777 Type -> Context -> Context

799 Type -> Context -> Context

778addCasedef n ci@(CaseInfo alwaysInline tcdict)

800addCasedef n ci@(CaseInfo alwaysInline tcdict)

779− tcase covering reflect asserted argtys

801+ tcase covering reflect asserted argtys inacc

780 ps_in ps_tot ps_inl ps_ct ps_rt ty uctxt

802 ps_in ps_tot ps_inl ps_ct ps_rt ty uctxt

781 = let ctxt = definitions uctxt

803 = let ctxt = definitions uctxt

782 access = case lookupDefAcc n False uctxt of

804 access = case lookupDefAcc n False uctxt of

783 [(_, acc)] -> acc

805 [(_, acc)] -> acc

784 _ -> Public

806 _ -> Public

785− ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC argtys ps_tot,

807+ ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_tot,

786− simpleCase tcase covering reflect CompileTime emptyFC argtys ps_ct,

808+ simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_ct,

787− simpleCase tcase covering reflect CompileTime emptyFC argtys ps_inl,

809+ simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_inl,

788− simpleCase tcase covering reflect RunTime emptyFC argtys ps_rt) of

810+ simpleCase tcase covering reflect RunTime emptyFC inacc argtys ps_rt) of

789 (OK (CaseDef args_tot sc_tot _),

811 (OK (CaseDef args_tot sc_tot _),

790 OK (CaseDef args_ct sc_ct _),

812 OK (CaseDef args_ct sc_ct _),

791 OK (CaseDef args_inl sc_inl _),

813 OK (CaseDef args_inl sc_inl _),

@@ -812,7 +834,7 @@ simplifyCasedef n uctxt

812 [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] ->

834 [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] ->

813 let ps_in' = map simpl ps_in

835 let ps_in' = map simpl ps_in

814 pdef = map debind ps_in' in

836 pdef = map debind ps_in' in

815− case simpleCase False True False CompileTime emptyFC atys pdef of

837+ case simpleCase False True False CompileTime emptyFC [] atys pdef of

816 OK (CaseDef args sc _) ->

838 OK (CaseDef args sc _) ->

817 addDef n (CaseOp ci

839 addDef n (CaseOp ci

818 ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }),

840 ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }),

@@ -846,14 +868,19 @@ lookupNames n ctxt

846 = let ns = lookupCtxtName n (definitions ctxt) in

868 = let ns = lookupCtxtName n (definitions ctxt) in

847 map fst ns

869 map fst ns

848

870

849−lookupTy :: Name -> Context -> [Type]

871+lookupTyName :: Name -> Context -> [(Name, Type)]

850−lookupTy n ctxt

872+lookupTyName n ctxt = do

851− = do def <- lookupCtxt n (definitions ctxt)

873+ (name, def) <- lookupCtxtName n (definitions ctxt)

852− case tfst def of

874+ ty <- case tfst def of

853 (Function ty _) -> return ty

875 (Function ty _) -> return ty

854 (TyDecl _ ty) -> return ty

876 (TyDecl _ ty) -> return ty

855 (Operator ty _ _) -> return ty

877 (Operator ty _ _) -> return ty

856 (CaseOp _ ty _ _ _ _) -> return ty

878 (CaseOp _ ty _ _ _ _) -> return ty

879+ return (name, ty)

880+

881+

882+lookupTy :: Name -> Context -> [Type]

883+lookupTy n ctxt = map snd (lookupTyName n ctxt)

857

884

858isConName :: Name -> Context -> Bool

885isConName :: Name -> Context -> Bool

859isConName n ctxt = isTConName n ctxt || isDConName n ctxt

886isConName n ctxt = isTConName n ctxt || isDConName n ctxt

@@ -874,12 +901,12 @@ isDConName n ctxt

874

901

875isFnName :: Name -> Context -> Bool

902isFnName :: Name -> Context -> Bool

876isFnName n ctxt

903isFnName n ctxt

877− = or $ do def <- lookupCtxt n (definitions ctxt)

904+ = let def = lookupCtxtExact n (definitions ctxt) in

878− case tfst def of

905+ case def of

879− (Function _ _) -> return True

906+ Just (Function _ _, _, _, _) -> True

880− (Operator _ _ _) -> return True

907+ Just (Operator _ _ _, _, _, _) -> True

881− (CaseOp _ _ _ _ _ _) -> return True

908+ Just (CaseOp _ _ _ _ _ _, _, _, _) -> True

882− _ -> return False

909+ _ -> False

883

910

884lookupP :: Name -> Context -> [Term]

911lookupP :: Name -> Context -> [Term]

885lookupP n ctxt

912lookupP n ctxt

@@ -893,8 +920,16 @@ lookupP n ctxt

893 Hidden -> []

920 Hidden -> []

894 _ -> return (fst p)

921 _ -> return (fst p)

895

922

923+lookupDefExact :: Name -> Context -> Maybe Def

924+lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)

925+

896lookupDef :: Name -> Context -> [Def]

926lookupDef :: Name -> Context -> [Def]

897−lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt)

927+lookupDef n ctxt = tfst <$> lookupCtxt n (definitions ctxt)

928+

929+lookupNameDef :: Name -> Context -> [(Name, Def)]

930+lookupNameDef n ctxt = mapSnd tfst $ lookupCtxtName n (definitions ctxt)

931+ where mapSnd f [] = []

932+ mapSnd f ((x,y):xys) = (x, f y) : mapSnd f xys

898

933

899lookupDefAcc :: Name -> Bool -> Context ->

934lookupDefAcc :: Name -> Bool -> Context ->

900 [(Def, Accessibility)]

935 [(Def, Accessibility)]

@@ -936,3 +971,10 @@ uniqueNameCtxt ctxt n hs

936 | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs

971 | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs

937 | [_] <- lookupTy n ctxt = uniqueNameCtxt ctxt (nextName n) hs

972 | [_] <- lookupTy n ctxt = uniqueNameCtxt ctxt (nextName n) hs

938 | otherwise = n

973 | otherwise = n

974+

975+uniqueBindersCtxt :: Context -> [Name] -> TT Name -> TT Name

976+uniqueBindersCtxt ctxt ns (Bind n b sc)

977+ = let n' = uniqueNameCtxt ctxt n ns in

978+ Bind n' (fmap (uniqueBindersCtxt ctxt (n':ns)) b) (uniqueBindersCtxt ctxt ns sc)

979+uniqueBindersCtxt ctxt ns (App f a) = App (uniqueBindersCtxt ctxt ns f) (uniqueBindersCtxt ctxt ns a)

980+uniqueBindersCtxt ctxt ns t = t

src/Idris/Core/Execute.hs+178−180

@@ -11,6 +11,8 @@ import Idris.Core.TT

11import Idris.Core.Evaluate

12import Idris.Core.CaseTree

13

14+import Idris.Error

15+

14import Debug.Trace

16import Debug.Trace

15

17

16import Util.DynamicLinker

18import Util.DynamicLinker

@@ -47,11 +49,8 @@ readMay s = case reads s of

47

49

48data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show

50data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show

49

51

50−data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs

51− , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness

52− , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad

53− , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad

52+newtype ExecState = ExecState { exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad

54− }

53+ }

55

54

56data ExecVal = EP NameType Name ExecVal

55data ExecVal = EP NameType Name ExecVal

57 | EV Int

56 | EV Int

@@ -61,20 +60,20 @@ data ExecVal = EP NameType Name ExecVal

61 | EErased

60 | EErased

62 | EConstant Const

61 | EConstant Const

63 | forall a. EPtr (Ptr a)

62 | forall a. EPtr (Ptr a)

64− | EThunk Int

63+ | EThunk Context ExecEnv Term

65 | EHandle Handle

64 | EHandle Handle

66

65

67instance Show ExecVal where

66instance Show ExecVal where

68− show (EP _ n _) = show n

67+ show (EP _ n _) = show n

69− show (EV i) = "!!V" ++ show i ++ "!!"

68+ show (EV i) = "!!V" ++ show i ++ "!!"

70− show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

69+ show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

71− show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

70+ show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

72− show (EType _) = "Type"

71+ show (EType _) = "Type"

73− show EErased = "[__]"

72+ show EErased = "[__]"

74− show (EConstant c) = show c

73+ show (EConstant c) = show c

75− show (EPtr p) = "<<ptr " ++ show p ++ ">>"

74+ show (EPtr p) = "<<ptr " ++ show p ++ ">>"

76− show (EThunk i) = "<<thunk " ++ show i ++ ">>"

75+ show (EThunk _ env tm) = "<<thunk " ++ show env ++ "||||" ++ show tm ++ ">>"

77− show (EHandle h) = "<<handle " ++ show h ++ ">>"

76+ show (EHandle h) = "<<handle " ++ show h ++ ">>"

78

77

79toTT :: ExecVal -> Exec Term

78toTT :: ExecVal -> Exec Term

80toTT (EP nt n ty) = (P nt n) <$> (toTT ty)

79toTT (EP nt n ty) = (P nt n) <$> (toTT ty)

@@ -82,22 +81,25 @@ toTT (EV i) = return $ V i

82toTT (EBind n b body) = do body' <- body $ EP Bound n EErased

81toTT (EBind n b body) = do body' <- body $ EP Bound n EErased

83 b' <- fixBinder b

82 b' <- fixBinder b

84 Bind n b' <$> toTT body'

83 Bind n b' <$> toTT body'

85− where fixBinder (Lam t) = Lam <$> toTT t

84+ where fixBinder (Lam t) = Lam <$> toTT t

86− fixBinder (Pi t) = Pi <$> toTT t

85+ fixBinder (Pi t) = Pi <$> toTT t

87− fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

86+ fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

88− fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

87+ fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

89− fixBinder (Hole t) = Hole <$> toTT t

88+ fixBinder (Hole t) = Hole <$> toTT t

90 fixBinder (GHole i t) = GHole i <$> toTT t

89 fixBinder (GHole i t) = GHole i <$> toTT t

91− fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2

90+ fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2

92− fixBinder (PVar t) = PVar <$> toTT t

91+ fixBinder (PVar t) = PVar <$> toTT t

93− fixBinder (PVTy t) = PVTy <$> toTT t

92+ fixBinder (PVTy t) = PVTy <$> toTT t

94toTT (EApp e1 e2) = do e1' <- toTT e1

93toTT (EApp e1 e2) = do e1' <- toTT e1

95 e2' <- toTT e2

94 e2' <- toTT e2

96 return $ App e1' e2'

95 return $ App e1' e2'

97toTT (EType u) = return $ TType u

96toTT (EType u) = return $ TType u

98toTT EErased = return Erased

97toTT EErased = return Erased

99toTT (EConstant c) = return (Constant c)

98toTT (EConstant c) = return (Constant c)

100−toTT (EThunk i) = return (P (DCon 0 0) (sMN i "THUNK") Erased) --(force i) >>= toTT

99+toTT (EThunk ctxt env tm) = do env' <- mapM toBinder env

100+ return $ normalise ctxt env' tm

101+ where toBinder (n, v) = do v' <- toTT v

102+ return (n, Let Erased v')

101toTT (EHandle _) = return Erased

103toTT (EHandle _) = return Erased

102

104

103unApplyV :: ExecVal -> (ExecVal, [ExecVal])

105unApplyV :: ExecVal -> (ExecVal, [ExecVal])

@@ -111,11 +113,11 @@ mkEApp f (a:args) = mkEApp (EApp f a) args

111

113

112initState :: Idris ExecState

114initState :: Idris ExecState

113initState = do ist <- getIState

115initState = do ist <- getIState

114− return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)

116+ return $ ExecState (idris_dynamic_libs ist)

115

117

116−type Exec = ErrorT String (StateT ExecState IO)

118+type Exec = ErrorT Err (StateT ExecState IO)

117

119

118−runExec :: Exec a -> ExecState -> IO (Either String a)

120+runExec :: Exec a -> ExecState -> IO (Either Err a)

119runExec ex st = fst <$> runStateT (runErrorT ex) st

121runExec ex st = fst <$> runStateT (runErrorT ex) st

120

122

121getExecState :: Exec ExecState

123getExecState :: Exec ExecState

@@ -124,53 +126,21 @@ getExecState = lift get

124putExecState :: ExecState -> Exec ()

126putExecState :: ExecState -> Exec ()

125putExecState = lift . put

127putExecState = lift . put

126

128

127−execFail :: String -> Exec a

129+execFail :: Err -> Exec a

128execFail = throwError

130execFail = throwError

129

131

130execIO :: IO a -> Exec a

132execIO :: IO a -> Exec a

131execIO = lift . lift

133execIO = lift . lift

132

134

133−delay :: ExecEnv -> Context -> Term -> Exec ExecVal

134−delay env ctxt tm =

135− do st <- getExecState

136− let i = exec_next_thunk st

137− putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)

138− , exec_next_thunk = exec_next_thunk st + 1

139− }

140− return $ EThunk i

141−

142−force :: Int -> Exec ExecVal

143−force i = do st <- getExecState

144− case M.lookup i (exec_thunks st) of

145− Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm

146− case tm' of

147− EThunk i ->

148− do res <- force i

149− update res i

150− return res

151− _ -> do update tm' i

152− return tm'

153− Just (Forced tm) -> return tm

154− Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"

155− where update :: ExecVal -> Int -> Exec ()

156− update tm i = do est <- getExecState

157− putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }

158−

159−tryForce :: ExecVal -> Exec ExecVal

160−tryForce (EThunk i) = force i

161−tryForce tm = return tm

162−

163−debugThunks :: Exec ()

164−debugThunks = do st <- getExecState

165− execIO $ putStrLn (take 4000 (show (exec_thunks st)))

166

135

167execute :: Term -> Idris Term

136execute :: Term -> Idris Term

168execute tm = do est <- initState

137execute tm = do est <- initState

169 ctxt <- getContext

138 ctxt <- getContext

170− res <- lift . lift $ flip runExec est $ do res <- doExec [] ctxt tm

139+ res <- lift . lift . flip runExec est $

140+ do res <- doExec [] ctxt tm

171− toTT res

141+ toTT res

172 case res of

142 case res of

173− Left err -> fail err

143+ Left err -> ierror err

174 Right tm' -> return tm'

144 Right tm' -> return tm'

175

145

176ioWrap :: ExecVal -> ExecVal

146ioWrap :: ExecVal -> ExecVal

@@ -192,23 +162,34 @@ doExec env ctxt p@(P Ref n ty) =

192 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun

162 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun

193 doExec env ctxt tm

163 doExec env ctxt tm

194 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] -> return (EP Ref n EErased)

164 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] -> return (EP Ref n EErased)

195− [] -> execFail $ "Could not find " ++ show n ++ " in definitions."

165+ [] -> execFail . Msg $ "Could not find " ++ show n ++ " in definitions."

196 thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined

166 thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined

197doExec env ctxt p@(P Bound n ty) =

167doExec env ctxt p@(P Bound n ty) =

198 case lookup n env of

168 case lookup n env of

199− Nothing -> execFail "not found"

169+ Nothing -> execFail . Msg $ "not found"

200 Just tm -> return tm

170 Just tm -> return tm

201doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)

171doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)

202doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)

172doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)

203doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))

173doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))

204− | otherwise = execFail "env too small"

174+ | otherwise = execFail . Msg $ "env too small"

205doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v

175doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v

206 doExec ((n, v'):env) ctxt body

176 doExec ((n, v'):env) ctxt body

207doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined

177doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined

208doExec env ctxt tm@(Bind n b body) = return $

178doExec env ctxt tm@(Bind n b body) = return $

209 EBind n (fmap (\_->EErased) b)

179 EBind n (fmap (\_->EErased) b)

210 (\arg -> doExec ((n, arg):env) ctxt body)

180 (\arg -> doExec ((n, arg):env) ctxt body)

211−doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)

181+doExec env ctxt a@(App _ _) =

182+ do let (f, args) = unApply a

183+ f' <- doExec env ctxt f

184+ args' <- case f' of

185+ (EP _ d _) | d == delay ->

186+ case args of

187+ [t,a,tm] -> do t' <- doExec env ctxt t

188+ a' <- doExec env ctxt a

189+ return [t', a', EThunk ctxt env tm]

190+ _ -> mapM (doExec env ctxt) args -- partial applications are fine to evaluate

191+ fun' -> do mapM (doExec env ctxt) args

192+ execApp env ctxt f' args'

212doExec env ctxt (Constant c) = return (EConstant c)

193doExec env ctxt (Constant c) = return (EConstant c)

213doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in

194doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in

214 doExec env ctxt ((x:xs) !! i)

195 doExec env ctxt ((x:xs) !! i)

@@ -216,120 +197,138 @@ doExec env ctxt Erased = return EErased

216doExec env ctxt Impossible = fail "Tried to execute an impossible case"

197doExec env ctxt Impossible = fail "Tried to execute an impossible case"

217doExec env ctxt (TType u) = return (EType u)

198doExec env ctxt (TType u) = return (EType u)

218

199

219−execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal

200+execApp :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

220−execApp env ctxt (f, args) = do newF <- doExec env ctxt f

221− laziness <- (++ repeat False) <$> (getLaziness newF)

222− newArgs <- mapM argExec (zip args laziness)

223− res <- execApp' env ctxt newF newArgs

224− return res

225− where getLaziness (EP _ l _) | l == sUN "lazy" = return [False, True]

226− getLaziness (EP _ n _) = do est <- getExecState

227− let argInfo = exec_implicits est

228− case lookupCtxtName n argInfo of

229− [] -> return (repeat False)

230− [ps] -> return $ map lazyarg (snd ps)

231− many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)

232− getLaziness _ = return (repeat False) -- ok due to zip above

233− argExec :: (Term, Bool) -> Exec ExecVal

234− argExec (tm, False) = doExec env ctxt tm

235− argExec (tm, True) = delay env ctxt tm

236−

237−

238−execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

239−execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls

201+execApp env ctxt v [] = return v -- no args is just a constant! can result from function calls

202+execApp env ctxt (EP _ f _) (t:a:delayed:rest)

203+ | f == force

204+ , (_, [_, _, EThunk tmCtxt tmEnv tm]) <- unApplyV delayed =

205+ do tm' <- doExec tmEnv tmCtxt tm

206+ execApp env ctxt tm' rest

240−execApp' env ctxt (EP _ fp _) (ty:action:rest)

207+execApp env ctxt (EP _ fp _) (ty:action:rest)

241 | fp == upio,

208 | fp == upio,

242 (prim__IO, [_, v]) <- unApplyV action

209 (prim__IO, [_, v]) <- unApplyV action

243− = execApp' env ctxt v rest

210+ = execApp env ctxt v rest

244

211

245−execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest)

212+execApp env ctxt (EP _ fp _) args@(_:_:v:k:rest)

246 | fp == piobind,

213 | fp == piobind,

247 (prim__IO, [_, v']) <- unApplyV v =

214 (prim__IO, [_, v']) <- unApplyV v =

248− do v'' <- tryForce v'

249− res <- execApp' env ctxt k [v''] >>= tryForce

215+ do res <- execApp env ctxt k [v']

250− execApp' env ctxt res rest

216+ execApp env ctxt res rest

251−execApp' env ctxt con@(EP _ fp _) args@(tp:v:rest)

217+execApp env ctxt con@(EP _ fp _) args@(tp:v:rest)

252− | fp == pioret =

253− do v' <- tryForce v

254− execApp' env ctxt (mkEApp con [tp, v']) rest

218+ | fp == pioret = execApp env ctxt (mkEApp con [tp, v]) rest

255

219

256-- Special cases arising from not having access to the C RTS in the interpreter

220-- Special cases arising from not having access to the C RTS in the interpreter

257−execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str arg):_:rest)

221+execApp env ctxt (EP _ fp _) (_:fn:str:_:rest)

222+ | fp == mkfprim,

223+ Just (FFun "putStr" _ _) <- foreignFromTT fn

224+ = case str of

225+ EConstant (Str arg) -> do execIO (putStr arg)

226+ execApp env ctxt ioUnit rest

227+ _ -> execFail . Msg $

228+ "The argument to putStr should be a constant string, but it was " ++

229+ show str ++

230+ ". Are all cases covered?"

231+execApp env ctxt (EP _ fp _) (_:fn:ch:_:rest)

258 | fp == mkfprim,

232 | fp == mkfprim,

259− Just (FFun "putStr" _ _) <- foreignFromTT fn

233+ Just (FFun "putchar" _ _) <- foreignFromTT fn

260− = do execIO (putStr arg)

234+ = case ch of

235+ EConstant (Ch c) -> do execIO (putChar c)

261− execApp' env ctxt ioUnit rest

236+ execApp env ctxt ioUnit rest

237+ EConstant (I i) -> do execIO (putChar (toEnum i))

238+ execApp env ctxt ioUnit rest

239+ _ -> execFail . Msg $

240+ "The argument to putchar should be a constant character, but it was " ++

241+ show str ++

242+ ". Are all cases covered?"

262−execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

243+execApp env ctxt (EP _ fp _) (_:fn:_:handle:_:rest)

263 | fp == mkfprim,

244 | fp == mkfprim,

264 Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

245 Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

246+ = case handle of

265− = do contents <- execIO $ hGetLine h

247+ EHandle h -> do contents <- execIO $ hGetLine h

266− execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

248+ execApp env ctxt (EConstant (Str (contents ++ "\n"))) rest

249+ _ -> execFail . Msg $

250+ "The argument to idris_readStr should be a handle, but it was " ++

251+ show handle ++

252+ ". Are all cases covered?"

267−execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

253+execApp env ctxt (EP _ fp _) (_:fn:fileStr:modeStr:rest)

268 | fp == mkfprim,

254 | fp == mkfprim,

269 Just (FFun "fileOpen" _ _) <- foreignFromTT fn

255 Just (FFun "fileOpen" _ _) <- foreignFromTT fn

256+ = case (fileStr, modeStr) of

257+ (EConstant (Str f), EConstant (Str mode)) ->

270− = do f <- execIO $

258+ do f <- execIO $

271− catch (do let m = case mode of

259+ catch (do let m = case mode of

272− "r" -> Right ReadMode

260+ "r" -> Right ReadMode

273− "w" -> Right WriteMode

261+ "w" -> Right WriteMode

274− "a" -> Right AppendMode

262+ "a" -> Right AppendMode

275− "rw" -> Right ReadWriteMode

263+ "rw" -> Right ReadWriteMode

276− "wr" -> Right ReadWriteMode

264+ "wr" -> Right ReadWriteMode

277− "r+" -> Right ReadWriteMode

265+ "r+" -> Right ReadWriteMode

278− _ -> Left ("Invalid mode for " ++ f ++ ": " ++ mode)

266+ _ -> Left ("Invalid mode for " ++ f ++ ": " ++ mode)

279− case fmap (openFile f) m of

267+ case fmap (openFile f) m of

280− Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest)

268+ Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest)

281− Left err -> return $ Left err)

269+ Left err -> return $ Left err)

282− (\e -> let _ = ( e::SomeException)

270+ (\e -> let _ = ( e::SomeException)

283− in return $ Right (ioWrap (EPtr nullPtr), tail rest))

271+ in return $ Right (ioWrap (EPtr nullPtr), tail rest))

284− case f of

272+ case f of

285− Left err -> execFail err

273+ Left err -> execFail . Msg $ err

286− Right (res, rest) -> execApp' env ctxt res rest

274+ Right (res, rest) -> execApp env ctxt res rest

287−

275+ _ -> execFail . Msg $

276+ "The arguments to fileOpen should be constant strings, but they were " ++

277+ show fileStr ++ " and " ++ show modeStr ++

278+ ". Are all cases covered?"

279+

288−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

280+execApp env ctxt (EP _ fp _) (_:fn:handle:rest)

289 | fp == mkfprim,

281 | fp == mkfprim,

290 Just (FFun "fileEOF" _ _) <- foreignFromTT fn

282 Just (FFun "fileEOF" _ _) <- foreignFromTT fn

283+ = case handle of

291− = do eofp <- execIO $ hIsEOF h

284+ EHandle h -> do eofp <- execIO $ hIsEOF h

292− let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

285+ let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

293− execApp' env ctxt res (tail rest)

286+ execApp env ctxt res (tail rest)

294−

287+ _ -> execFail . Msg $

288+ "The argument to fileEOF should be a file handle, but it was " ++

289+ show handle ++

290+ ". Are all cases covered?"

291+

295−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

292+execApp env ctxt (EP _ fp _) (_:fn:handle:rest)

296 | fp == mkfprim,

293 | fp == mkfprim,

297 Just (FFun "fileClose" _ _) <- foreignFromTT fn

294 Just (FFun "fileClose" _ _) <- foreignFromTT fn

295+ = case handle of

298− = do execIO $ hClose h

296+ EHandle h -> do execIO $ hClose h

299− execApp' env ctxt ioUnit (tail rest)

297+ execApp env ctxt ioUnit (tail rest)

300−

298+ _ -> execFail . Msg $

299+ "The argument to fileClose should be a file handle, but it was " ++

300+ show handle ++

301+ ". Are all cases covered?"

302+

301−execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

303+execApp env ctxt (EP _ fp _) (_:fn:ptr:rest)

302 | fp == mkfprim,

304 | fp == mkfprim,

303 Just (FFun "isNull" _ _) <- foreignFromTT fn

305 Just (FFun "isNull" _ _) <- foreignFromTT fn

306+ = case ptr of

304− = let res = ioWrap . EConstant . I $

307+ EPtr p -> let res = ioWrap . EConstant . I $

305− if p == nullPtr then 1 else 0

308+ if p == nullPtr then 1 else 0

309+ in execApp env ctxt res (tail rest)

310+ -- Handles will be checked as null pointers sometimes - but if we got a

311+ -- real Handle, then it's valid, so just return 1.

312+ EHandle h -> let res = ioWrap . EConstant . I $ 0

313+ in execApp env ctxt res (tail rest)

314+ -- A foreign-returned char* has to be tested for NULL sometimes

315+ EConstant (Str s) -> let res = ioWrap . EConstant . I $ 0

306− in execApp' env ctxt res (tail rest)

316+ in execApp env ctxt res (tail rest)

317+ _ -> execFail . Msg $

318+ "The argument to isNull should be a pointer or file handle or string, but it was " ++

319+ show ptr ++

320+ ". Are all cases covered?"

307

321

308−-- Handles will be checked as null pointers sometimes - but if we got a

309−-- real Handle, then it's valid, so just return 1.

310−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

311− | fp == mkfprim,

312− Just (FFun "isNull" _ _) <- foreignFromTT fn

313− = let res = ioWrap . EConstant . I $ 0

314− in execApp' env ctxt res (tail rest)

315−

316−-- A foreign-returned char* has to be tested for NULL sometimes

317−execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)

318− | fp == mkfprim,

319− Just (FFun "isNull" _ _) <- foreignFromTT fn

320− = let res = ioWrap . EConstant . I $ 0

321− in execApp' env ctxt res (tail rest)

322

323-- Right now, there's no way to send command-line arguments to the executor,

324-- so just return 0.

325−execApp' env ctxt (EP _ fp _) (_:fn:rest)

325+execApp env ctxt (EP _ fp _) (_:fn:rest)

326 | fp == mkfprim,

327 Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn

328 = let res = ioWrap . EConstant . I $ 0

329− in execApp' env ctxt res (tail rest)

329+ in execApp env ctxt res (tail rest)

330−-- Throw away the 'World' argument to the foreign function

331

330

332−execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

331+execApp env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

333 = case foreignFromTT fn of

332 = case foreignFromTT fn of

334 Just (FFun f argTs retT) | length xs >= length argTs ->

333 Just (FFun f argTs retT) | length xs >= length argTs ->

335 do let (args', xs') = (take (length argTs) xs, -- foreign args

334 do let (args', xs') = (take (length argTs) xs, -- foreign args

@@ -341,43 +340,41 @@ execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

341 Just r -> return (mkEApp r xs')

340 Just r -> return (mkEApp r xs')

342 Nothing -> return (mkEApp f args)

341 Nothing -> return (mkEApp f args)

343

342

344−execApp' env ctxt c@(EP (DCon _ arity) n _) args =

343+execApp env ctxt c@(EP (DCon _ arity) n _) args =

345− do args' <- mapM tryForce (take arity args)

344+ do let args' = take arity args

346 let restArgs = drop arity args

345 let restArgs = drop arity args

347− execApp' env ctxt (mkEApp c args') restArgs

346+ execApp env ctxt (mkEApp c args') restArgs

348

347

349−execApp' env ctxt c@(EP (TCon _ arity) n _) args =

348+execApp env ctxt c@(EP (TCon _ arity) n _) args =

350− do args' <- mapM tryForce (take arity args)

349+ do let args' = take arity args

351 let restArgs = drop arity args

350 let restArgs = drop arity args

352− execApp' env ctxt (mkEApp c args') restArgs

351+ execApp env ctxt (mkEApp c args') restArgs

353

352

354−execApp' env ctxt f@(EP _ n _) args =

353+execApp env ctxt f@(EP _ n _) args =

355 do let val = lookupDef n ctxt

354 do let val = lookupDef n ctxt

356 case val of

355 case val of

357 [Function _ tm] -> fail "should already have been eval'd"

356 [Function _ tm] -> fail "should already have been eval'd"

358 [TyDecl nt ty] -> return $ mkEApp f args

357 [TyDecl nt ty] -> return $ mkEApp f args

359 [Operator tp arity op] ->

358 [Operator tp arity op] ->

360 if length args >= arity

359 if length args >= arity

361− then do args' <- mapM tryForce $ take arity args

360+ then let args' = take arity args in

362− case getOp n args' of

361+ case getOp n args' of

363− Just res -> do r <- res

362+ Just res -> do r <- res

364− execApp' env ctxt r (drop arity args)

363+ execApp env ctxt r (drop arity args)

365− Nothing -> return (mkEApp f args)

364+ Nothing -> return (mkEApp f args)

366 else return (mkEApp f args)

365 else return (mkEApp f args)

367 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun

366 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun

368 do rhs <- doExec env ctxt tm

367 do rhs <- doExec env ctxt tm

369− execApp' env ctxt rhs args

368+ execApp env ctxt rhs args

370 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->

369 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->

371 do res <- execCase env ctxt ns sc args

370 do res <- execCase env ctxt ns sc args

372 return $ fromMaybe (mkEApp f args) res

371 return $ fromMaybe (mkEApp f args) res

373 thing -> return $ mkEApp f args

372 thing -> return $ mkEApp f args

374−execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg

373+execApp env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg

375− let (f', as) = unApplyV ret

374+ let (f', as) = unApplyV ret

376− execApp' env ctxt f' (as ++ args)

375+ execApp env ctxt f' (as ++ args)

377−execApp' env ctxt (EThunk i) args = do f <- force i

378− execApp' env ctxt f args

379−execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)

376+execApp env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp env ctxt f (args1 ++ args2)

380−execApp' env ctxt f args = return (mkEApp f args)

377+execApp env ctxt f args = return (mkEApp f args)

381

378

382prs = sUN "prim__readString"

379prs = sUN "prim__readString"

383pbm = sUN "prim__believe_me"

380pbm = sUN "prim__believe_me"

@@ -386,6 +383,8 @@ mkfprim = sUN "mkForeignPrim"

386pioret = sUN "prim_io_return"

383pioret = sUN "prim_io_return"

387piobind = sUN "prim_io_bind"

384piobind = sUN "prim_io_bind"

388upio = sUN "unsafePerformPrimIO"

385upio = sUN "unsafePerformPrimIO"

386+delay = sUN "Delay"

387+force = sUN "Force"

389

388

390-- | Look up primitive operations in the global table and transform them into ExecVal functions

389-- | Look up primitive operations in the global table and transform them into ExecVal functions

391getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

390getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

@@ -426,7 +425,7 @@ execCase env ctxt ns sc args =

426-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()

425-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()

427 caseRes <- execCase' env ctxt amap sc

426 caseRes <- execCase' env ctxt amap sc

428 case caseRes of

427 case caseRes of

429− Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)

428+ Just res -> Just <$> execApp (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)

430 Nothing -> return Nothing

429 Nothing -> return Nothing

431 else return Nothing

430 else return Nothing

432

431

@@ -436,8 +435,7 @@ execCase' env ctxt amap (UnmatchedCase _) = return Nothing

436execCase' env ctxt amap (STerm tm) =

435execCase' env ctxt amap (STerm tm) =

437 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm

436 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm

438execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =

437execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =

439− do tm' <- tryForce tm

440− case chooseAlt tm' alts of

438+ case chooseAlt tm alts of

441 Just (newCase, newBindings) ->

439 Just (newCase, newBindings) ->

442 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in

440 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in

443 execCase' env ctxt amap' newCase

441 execCase' env ctxt amap' newCase

src/Idris/Core/ProofState.hs+106−36

@@ -5,8 +5,8 @@

5 evaluation/checking inside the proof system, etc. --}

6

7module Idris.Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,

8− Tactic(..), Goal(..), processTactic,

8+ Tactic(..), Goal(..), processTactic, nowElaboratingPS, doneElaboratingAppPS,

9− dropGiven, keepGiven) where

9+ doneElaboratingArgPS, dropGiven, keepGiven) where

10

11import Idris.Core.Typecheck

12import Idris.Core.Evaluate

@@ -15,6 +15,7 @@ import Idris.Core.Unify

15

16import Control.Monad.State.Strict

17import Control.Applicative hiding (empty)

18+import Control.Arrow ((***))

18import Data.List

19import Data.List

19import Debug.Trace

20import Debug.Trace

20

21

@@ -38,7 +39,8 @@ data ProofState = PS { thname :: Name,

38 context :: Context,

39 context :: Context,

39 plog :: String,

40 plog :: String,

40 unifylog :: Bool,

41 unifylog :: Bool,

41− done :: Bool

42+ done :: Bool,

43+ while_elaborating :: [FailContext]

42 }

44 }

43

45

44data Goal = GD { premises :: Env,

46data Goal = GD { premises :: Env,

@@ -57,6 +59,7 @@ data Tactic = Attack

57 | Solve

59 | Solve

58 | StartUnify Name

60 | StartUnify Name

59 | EndUnify

61 | EndUnify

62+ | UnifyAll

60 | Compute

63 | Compute

61 | ComputeLet Name

64 | ComputeLet Name

62 | Simplify

65 | Simplify

@@ -89,9 +92,9 @@ data Tactic = Attack

89-- Some utilites on proof and tactic states

92-- Some utilites on proof and tactic states

90

93

91instance Show ProofState where

94instance Show ProofState where

92− show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _)

95+ show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)

93 = show nm ++ ": no more goals"

96 = show nm ++ ": no more goals"

94− show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _)

97+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _)

95 = let OK g = goal (Just h) tm

98 = let OK g = goal (Just h) tm

96 wkenv = premises g in

99 wkenv = premises g in

97 "Other goals: " ++ show hs ++ "\n" ++

100 "Other goals: " ++ show hs ++ "\n" ++

@@ -114,9 +117,9 @@ instance Show ProofState where

114 showG ps b = showEnv ps (binderTy b)

117 showG ps b = showEnv ps (binderTy b)

115

118

116instance Pretty ProofState OutputAnnotation where

119instance Pretty ProofState OutputAnnotation where

117− pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

120+ pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

118 pretty nm <+> colon <+> text " no more goals."

121 pretty nm <+> colon <+> text " no more goals."

119− pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _) =

122+ pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _) =

120 let OK g = goal (Just h) tm in

123 let OK g = goal (Just h) tm in

121 let wkEnv = premises g in

124 let wkEnv = premises g in

122 text "Other goals" <+> colon <+> pretty hs <+>

125 text "Other goals" <+> colon <+> pretty hs <+>

@@ -147,12 +150,13 @@ hole _ = False

147holeName i = sMN i "hole"

150holeName i = sMN i "hole"

148

151

149qshow :: Fails -> String

152qshow :: Fails -> String

150−qshow fs = show (map (\ (x, y, _, _, t) -> (t, x, y)) fs)

153+qshow fs = show (map (\ (x, y, _, _, _, t) -> (t, x, y)) fs)

151

154

152match_unify' :: Context -> Env -> TT Name -> TT Name ->

155match_unify' :: Context -> Env -> TT Name -> TT Name ->

153 StateT TState TC [(Name, TT Name)]

156 StateT TState TC [(Name, TT Name)]

154match_unify' ctxt env topx topy =

157match_unify' ctxt env topx topy =

155 do ps <- get

158 do ps <- get

159+ let while = while_elaborating ps

156 let dont = dontunify ps

160 let dont = dontunify ps

157 let inj = injective ps

161 let inj = injective ps

158 traceWhen (unifylog ps)

162 traceWhen (unifylog ps)

@@ -162,11 +166,11 @@ match_unify' ctxt env topx topy =

162 ++ "\n"

166 ++ "\n"

163 ++ "\n" ++ show (pterm ps) ++ "\n\n"

167 ++ "\n" ++ show (pterm ps) ++ "\n\n"

164 ) $

168 ) $

165− case match_unify ctxt env topx topy inj (holes ps) of

169+ case match_unify ctxt env topx topy inj (holes ps) while of

166 OK u -> do let (h, ns) = unified ps

170 OK u -> do let (h, ns) = unified ps

167 put (ps { unified = (h, u ++ ns) })

171 put (ps { unified = (h, u ++ ns) })

168 return u

172 return u

169− Error e -> do put (ps { problems = (topx, topy, env, e, Match) :

173+ Error e -> do put (ps { problems = (topx, topy, env, e, while, Match) :

170 problems ps })

174 problems ps })

171 return []

175 return []

172-- traceWhen (unifylog ps)

176-- traceWhen (unifylog ps)

@@ -176,41 +180,61 @@ match_unify' ctxt env topx topy =

176-- -- ++ show (pterm ps)

180-- -- ++ show (pterm ps)

177-- ++ "\n----------") $

181-- ++ "\n----------") $

178

182

183+mergeSolutions :: Env -> [(Name, TT Name)] -> StateT TState TC [(Name, TT Name)]

184+mergeSolutions env ns = merge [] ns

185+ where

186+ merge acc [] = return (reverse acc)

187+ merge acc ((n, t) : ns)

188+ | Just t' <- lookup n ns

189+ = do ps <- get

190+ let probs = problems ps

191+ put (ps { problems = probs ++ [(t,t',env,Msg "New problem",

192+ [], Unify)] })

193+ merge acc ns

194+ | otherwise = merge ((n, t): acc) ns

195+

179unify' :: Context -> Env -> TT Name -> TT Name ->

196unify' :: Context -> Env -> TT Name -> TT Name ->

180 StateT TState TC [(Name, TT Name)]

197 StateT TState TC [(Name, TT Name)]

181unify' ctxt env topx topy =

198unify' ctxt env topx topy =

182 do ps <- get

199 do ps <- get

200+ let while = while_elaborating ps

183 let dont = dontunify ps

201 let dont = dontunify ps

184 let inj = injective ps

202 let inj = injective ps

185 (u, fails) <- traceWhen (unifylog ps)

203 (u, fails) <- traceWhen (unifylog ps)

186 ("Trying " ++ show (topx, topy) ++

204 ("Trying " ++ show (topx, topy) ++

187 "\nNormalised " ++ show (normalise ctxt env topx,

205 "\nNormalised " ++ show (normalise ctxt env topx,

188− normalise ctxt env topy) ++

206+ normalise ctxt env topy) ++

189 " in " ++ show env ++

207 " in " ++ show env ++

190 "\nHoles: " ++ show (holes ps)

208 "\nHoles: " ++ show (holes ps)

191− ++ "\nInjective: " ++ show (injective ps)

209+ ++ "\nInjective: " ++ show (injective ps)

192 ++ "\n") $

210 ++ "\n") $

193− lift $ unify ctxt env topx topy inj (holes ps)

211+ lift $ unify ctxt env topx topy inj (holes ps) while

194 let notu = filter (\ (n, t) -> case t of

212 let notu = filter (\ (n, t) -> case t of

195 P _ _ _ -> False

213 P _ _ _ -> False

196 _ -> n `elem` dont) u

214 _ -> n `elem` dont) u

197 traceWhen (unifylog ps)

215 traceWhen (unifylog ps)

198 ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

216 ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

199 "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

217 "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

200− ++ "\nNot unified:\n" ++ show (notunified ps)

218+ ++ "\nNot unified:\n" ++ show (notunified ps)

201 ++ "\nCurrent problems:\n" ++ qshow (problems ps)

219 ++ "\nCurrent problems:\n" ++ qshow (problems ps)

202-- ++ show (pterm ps)

220-- ++ show (pterm ps)

203 ++ "\n----------") $

221 ++ "\n----------") $

204− do ps <- get

205− let (h, ns) = unified ps

222+ do let (h, ns) = unified ps

223+ -- if a metavar has multiple solutions, make a new unification

224+ -- problem for each.

225+ uns <- mergeSolutions env (u ++ ns)

226+ ps <- get

206− let (ns', probs') = updateProblems (context ps) (u ++ ns)

227+ let (ns', probs') = updateProblems (context ps) uns

207 (fails ++ problems ps)

228 (fails ++ problems ps)

208 (injective ps)

229 (injective ps)

209 (holes ps)

230 (holes ps)

231+ let (notu', probs_notu) = mergeNotunified env (notu ++ notunified ps)

232+ traceWhen (unifylog ps)

233+ ("Now solved: " ++ show ns') $

210− put (ps { problems = probs',

234+ put (ps { problems = probs' ++ probs_notu,

211− unified = (h, ns'),

235+ unified = (h, ns'),

212− injective = updateInj u (injective ps),

236+ injective = updateInj u (injective ps),

213− notunified = notu ++ notunified ps })

237+ notunified = notu' })

214 return u

238 return u

215 where updateInj ((n, a) : us) inj

239 where updateInj ((n, a) : us) inj

216 | (P _ n' _, _) <- unApply a,

240 | (P _ n' _, _) <- unApply a,

@@ -220,6 +244,24 @@ unify' ctxt env topx topy =

220 updateInj (_ : us) inj = updateInj us inj

244 updateInj (_ : us) inj = updateInj us inj

221 updateInj [] inj = inj

245 updateInj [] inj = inj

222

246

247+nowElaboratingPS :: FC -> Name -> Name -> ProofState -> ProofState

248+nowElaboratingPS fc f arg ps = ps { while_elaborating = FailContext fc f arg : while_elaborating ps }

249+

250+dropUntil :: (a -> Bool) -> [a] -> [a]

251+dropUntil p [] = []

252+dropUntil p (x:xs) | p x = xs

253+ | otherwise = dropUntil p xs

254+

255+doneElaboratingAppPS :: Name -> ProofState -> ProofState

256+doneElaboratingAppPS f ps = let while = while_elaborating ps

257+ while' = dropUntil (\ (FailContext _ f' _) -> f == f') while

258+ in ps { while_elaborating = while' }

259+

260+doneElaboratingArgPS :: Name -> Name -> ProofState -> ProofState

261+doneElaboratingArgPS f x ps = let while = while_elaborating ps

262+ while' = dropUntil (\ (FailContext _ f' x') -> f == f' && x == x') while

263+ in ps { while_elaborating = while' }

264+

223getName :: Monad m => String -> StateT TState m Name

265getName :: Monad m => String -> StateT TState m Name

224getName tag = do ps <- get

266getName tag = do ps <- get

225 let n = nextname ps

267 let n = nextname ps

@@ -230,6 +272,10 @@ action :: Monad m => (ProofState -> ProofState) -> StateT TState m ()

230action a = do ps <- get

272action a = do ps <- get

231 put (a ps)

273 put (a ps)

232

274

275+query :: Monad m => (ProofState -> r) -> StateT TState m r

276+query q = do ps <- get

277+ return $ q ps

278+

233addLog :: Monad m => String -> StateT TState m ()

279addLog :: Monad m => String -> StateT TState m ()

234addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

280addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

235

281

@@ -240,7 +286,7 @@ newProof n ctxt ty = let h = holeName 0

240 (P Bound h ty')) ty [] (h, []) []

286 (P Bound h ty')) ty [] (h, []) []

241 Nothing [] []

287 Nothing [] []

242 [] []

288 [] []

243− Nothing ctxt "" False False

289+ Nothing ctxt "" False False []

244

290

245type TState = ProofState -- [TacticAction])

291type TState = ProofState -- [TacticAction])

246type RunTactic = Context -> Env -> Term -> StateT TState TC Term

292type RunTactic = Context -> Env -> Term -> StateT TState TC Term

@@ -491,7 +537,8 @@ solve ctxt env (Bind x (Guess ty val) sc)

491 = do ps <- get

537 = do ps <- get

492 let (uh, uns) = unified ps

538 let (uh, uns) = unified ps

493 case lookup x (notunified ps) of

539 case lookup x (notunified ps) of

540+ Just tm -> -- trace ("NEED MATCH: " ++ show (tm, val)) $

494− Just tm -> match_unify' ctxt env tm val

541+ match_unify' ctxt env tm val

495 _ -> return []

542 _ -> return []

496 action (\ps -> ps { holes = holes ps \\ [x],

543 action (\ps -> ps { holes = holes ps \\ [x],

497 solved = Just (x, val),

544 solved = Just (x, val),

@@ -637,10 +684,11 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

637 let scr = last $ tail args'

684 let scr = last $ tail args'

638 let indxnames = makeIndexNames indicies

685 let indxnames = makeIndexNames indicies

639 prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t

686 prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t

687+ consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (pterm ps)) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (pterm ps))) consargs)

640− let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0)))

688+ 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])))

689+ (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))

642 action (\ps -> ps {holes = holes ps \\ [x]})

690 action (\ps -> ps {holes = holes ps \\ [x]})

643− mapM_ addConsHole (reverse consargs)

691+ mapM_ addConsHole (reverse consargs')

644 let res' = forget $ res

692 let res' = forget $ res

645 (scv, sct) <- lift $ check ctxt env res'

693 (scv, sct) <- lift $ check ctxt env res'

646 let scv' = specialise ctxt env [] scv

694 let scv' = specialise ctxt env [] scv

@@ -753,13 +801,15 @@ keepGiven du (u@(n, _) : us) hs

753 | n `elem` du = u : keepGiven du us hs

801 | n `elem` du = u : keepGiven du us hs

754keepGiven du (u : us) hs = keepGiven du us hs

802keepGiven du (u : us) hs = keepGiven du us hs

755

803

804+updateSolved :: [(Name, Term)] -> Term -> Term

756updateSolved xs x = updateSolved' xs x

805updateSolved xs x = updateSolved' xs x

757updateSolved' [] x = x

806updateSolved' [] x = x

758updateSolved' xs (Bind n (Hole ty) t)

807updateSolved' xs (Bind n (Hole ty) t)

759 | Just v <- lookup n xs

808 | Just v <- lookup n xs

760 = case xs of

809 = case xs of

761− [_] -> psubst n v t

810+ [_] -> substV v $ psubst n v t -- some may be Vs! Can't assume

811+ -- explicit names

762− _ -> psubst n v (updateSolved' xs t)

812+ _ -> substV v $ psubst n v (updateSolved' xs t)

763updateSolved' xs (Bind n b t)

813updateSolved' xs (Bind n b t)

764 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

814 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

765updateSolved' xs (App f a)

815updateSolved' xs (App f a)

@@ -773,6 +823,10 @@ updateEnv ns [] = []

773updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env

823updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env

774

824

775updateError [] err = err

825updateError [] err = err

826+updateError ns (At f e) = At f (updateError ns e)

827+updateError ns (Elaborating s n e) = Elaborating s n (updateError ns e)

828+updateError ns (ElaboratingArg f a env e)

829+ = ElaboratingArg f a env (updateError ns e)

776updateError ns (CantUnify b l r e xs sc)

830updateError ns (CantUnify b l r e xs sc)

777 = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc

831 = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc

778updateError ns e = e

832updateError ns e = e

@@ -782,42 +836,53 @@ solveInProblems x val ((l, r, env, err) : ps)

782 = ((psubst x val l, psubst x val r,

836 = ((psubst x val l, psubst x val r,

783 updateEnv [(x, val)] env, err) : solveInProblems x val ps)

837 updateEnv [(x, val)] env, err) : solveInProblems x val ps)

784

838

839+mergeNotunified :: Env -> [(Name, Term)] -> ([(Name, Term)], Fails)

840+mergeNotunified env ns = mnu ns [] [] where

841+ mnu [] ns_acc ps_acc = (reverse ns_acc, reverse ps_acc)

842+ mnu ((n, t):ns) ns_acc ps_acc

843+ | Just t' <- lookup n ns, t /= t'

844+ = mnu ns ((n,t') : ns_acc)

845+ ((t,t',env,Msg "", [],Unify) : ps_acc)

846+ | otherwise = mnu ns ((n,t) : ns_acc) ps_acc

847+

785updateNotunified [] nu = nu

848updateNotunified [] nu = nu

786updateNotunified ns nu = up nu where

849updateNotunified ns nu = up nu where

787 up [] = []

850 up [] = []

788 up ((n, t) : nus) = let t' = updateSolved ns t in

851 up ((n, t) : nus) = let t' = updateSolved ns t in

789 ((n, t') : up nus)

852 ((n, t') : up nus)

790

853

854+updateProblems :: Context -> [(Name, TT Name)] -> Fails -> [Name] -> [Name]

855+ -> ([(Name, TT Name)], Fails)

791updateProblems ctxt [] ps inj holes = ([], ps)

856updateProblems ctxt [] ps inj holes = ([], ps)

792updateProblems ctxt ns ps inj holes = up ns ps where

857updateProblems ctxt ns ps inj holes = up ns ps where

793 up ns [] = (ns, [])

858 up ns [] = (ns, [])

794− up ns ((x, y, env, err, um) : ps) =

859+ up ns ((x, y, env, err, while, um) : ps) =

795 let x' = updateSolved ns x

860 let x' = updateSolved ns x

796 y' = updateSolved ns y

861 y' = updateSolved ns y

797 err' = updateError ns err

862 err' = updateError ns err

798 env' = updateEnv ns env in

863 env' = updateEnv ns env in

799−-- trace ("Updating " ++ show (x',y')) $

864+-- trace ("Updating " ++ show (x',y')) $

800− case unify ctxt env' x' y' inj holes of

865+ case unify ctxt env' x' y' inj holes while of

801 OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

866 OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

802 up (ns ++ v) ps

867 up (ns ++ v) ps

803 e -> -- trace ("Failed " ++ show e) $

868 e -> -- trace ("Failed " ++ show e) $

804 let (ns', ps') = up ns ps in

869 let (ns', ps') = up ns ps in

805− (ns', (x',y',env',err', um) : ps')

870+ (ns', (x',y',env',err', while, um) : ps')

806

871

807-- attempt to solve remaining problems with match_unify

872-- attempt to solve remaining problems with match_unify

808matchProblems all ns ctxt ps inj holes = up ns ps where

873matchProblems all ns ctxt ps inj holes = up ns ps where

809 up ns [] = (ns, [])

874 up ns [] = (ns, [])

810− up ns ((x, y, env, err, um) : ps)

875+ up ns ((x, y, env, err, while, um) : ps)

811 | all || um == Match =

876 | all || um == Match =

812 let x' = updateSolved ns x

877 let x' = updateSolved ns x

813 y' = updateSolved ns y

878 y' = updateSolved ns y

814 err' = updateError ns err

879 err' = updateError ns err

815 env' = updateEnv ns env in

880 env' = updateEnv ns env in

816− case match_unify ctxt env' x' y' inj holes of

881+ case match_unify ctxt env' x' y' inj holes while of

817 OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

882 OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

818 up (ns ++ v) ps

883 up (ns ++ v) ps

819 _ -> let (ns', ps') = up ns ps in

884 _ -> let (ns', ps') = up ns ps in

820− (ns', (x',y',env',err',um) : ps')

885+ (ns', (x', y', env', err', while, um) : ps')

821 up ns (p : ps) = let (ns', ps') = up ns ps in

886 up ns (p : ps) = let (ns', ps') = up ns ps in

822 (ns', p : ps')

887 (ns', p : ps')

823

888

@@ -830,7 +895,7 @@ processTactic QED ps = case holes ps of

830 _ -> fail "Still holes to fill."

895 _ -> fail "Still holes to fill."

831processTactic ProofState ps = return (ps, showEnv [] (pterm ps))

896processTactic ProofState ps = return (ps, showEnv [] (pterm ps))

832processTactic Undo ps = case previous ps of

897processTactic Undo ps = case previous ps of

833− Nothing -> fail "Nothing to undo."

898+ Nothing -> Error . Msg $ "Nothing to undo."

834 Just pold -> return (pold, "")

899 Just pold -> return (pold, "")

835processTactic EndUnify ps

900processTactic EndUnify ps

836 = let (h, ns_in) = unified ps

901 = let (h, ns_in) = unified ps

@@ -844,6 +909,11 @@ processTactic EndUnify ps

844 problems = probs',

909 problems = probs',

845 notunified = updateNotunified ns'' (notunified ps),

910 notunified = updateNotunified ns'' (notunified ps),

846 holes = holes ps \\ map fst ns'' }, "")

911 holes = holes ps \\ map fst ns'' }, "")

912+processTactic UnifyAll ps

913+ = let tm' = updateSolved (notunified ps) (pterm ps) in

914+ return (ps { pterm = tm',

915+ notunified = [],

916+ holes = holes ps \\ map fst (notunified ps) }, "")

847processTactic (Reorder n) ps

917processTactic (Reorder n) ps

848 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

918 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

849 return (ps' { previous = Just ps, plog = "" }, plog ps')

919 return (ps' { previous = Just ps, plog = "" }, plog ps')

src/Idris/Core/TC.hs+9

@@ -2,6 +2,7 @@

2

3module Idris.Core.TC(TC'(..)) where

4

5+import Control.Applicative

5import Control.Monad

6import Control.Monad

6import Control.Monad.Trans.Error(Error(..))

7import Control.Monad.Trans.Error(Error(..))

7

8

@@ -26,3 +27,11 @@ instance Error e => MonadPlus (TC' e) where

26 _ `mplus` (OK y) = OK y

27 _ `mplus` (OK y) = OK y

27 err `mplus` _ = err

28 err `mplus` _ = err

28

29

30+

31+instance Error e => Applicative (TC' e) where

32+ pure = return

33+ (<*>) = ap

34+

35+instance Error e => Alternative (TC' e) where

36+ empty = mzero

37+ (<|>) = mplus

src/Idris/Core/TT.hs+110−21

@@ -27,6 +27,7 @@ import Control.Monad.Trans.Error (Error(..))

27import Debug.Trace

28import qualified Data.Map.Strict as Map

29import Data.Char

30+import Numeric (showIntAtBase)

30import qualified Data.Text as T

31import qualified Data.Text as T

31import Data.List

32import Data.List

32import Data.Maybe (listToMaybe)

33import Data.Maybe (listToMaybe)

@@ -44,8 +45,8 @@ data Option = TTypeInTType

44

45

45-- | Source location. These are typically produced by the parser 'Idris.Parser.getFC'

46-- | Source location. These are typically produced by the parser 'Idris.Parser.getFC'

46data FC = FC { fc_fname :: String, -- ^ Filename

47data FC = FC { fc_fname :: String, -- ^ Filename

47− fc_line :: Int, -- ^ Line number

48+ fc_start :: (Int, Int), -- ^ Line and column numbers for the start of the location span

48− fc_column :: Int -- ^ Column number

49+ fc_end :: (Int, Int) -- ^ Line and column numbers for the end of the location span

49 }

50 }

50

51

51-- | Ignore source location equality (so deriving classes do not compare FCs)

52-- | Ignore source location equality (so deriving classes do not compare FCs)

@@ -57,7 +58,7 @@ newtype FC' = FC' { unwrapFC :: FC }

57

58

58instance Eq FC' where

59instance Eq FC' where

59 FC' fc == FC' fc' = fcEq fc fc'

60 FC' fc == FC' fc' = fcEq fc fc'

60− where fcEq (FC n l c) (FC n' l' c') = n == n' && l == l' && c == c'

61+ where fcEq (FC n s e) (FC n' s' e') = n == n' && s == s' && e == e'

61

62

62-- | Empty source location

63-- | Empty source location

63emptyFC :: FC

64emptyFC :: FC

@@ -65,7 +66,7 @@ emptyFC = fileFC ""

65

66

66-- | Source location with file only

67-- | Source location with file only

67fileFC :: String -> FC

68fileFC :: String -> FC

68−fileFC s = FC s 0 0

69+fileFC s = FC s (0, 0) (0, 0)

69

70

70{-!

71{-!

71deriving instance Binary FC

72deriving instance Binary FC

@@ -73,20 +74,31 @@ deriving instance NFData FC

73!-}

74!-}

74

75

75instance Sized FC where

76instance Sized FC where

76− size (FC f l c) = 1 + length f

77+ size (FC f s e) = 4 + length f

77

78

78instance Show FC where

79instance Show FC where

79− show (FC f l c) = f ++ ":" ++ show l ++ ":" ++ show c

80+ show (FC f s e) = f ++ ":" ++ showLC s e

81+ where showLC (sl, sc) (el, ec) | sl == el && sc == ec = show sl ++ ":" ++ show sc

82+ | sl == el = show sl ++ ":" ++ show sc ++ "-" ++ show ec

83+ | otherwise = show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec

80

84

81-- | Output annotation for pretty-printed name - decides colour

85-- | Output annotation for pretty-printed name - decides colour

82−data NameOutput = TypeOutput | FunOutput | DataOutput

86+data NameOutput = TypeOutput | FunOutput | DataOutput | MetavarOutput | PostulateOutput

87+

88+-- | Text formatting output

89+data TextFormatting = BoldText | ItalicText | UnderlineText

83

90

84-- | Output annotations for pretty-printing

91-- | Output annotations for pretty-printing

85−data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe Type)

92+data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe String) (Maybe String)

93+ -- ^^ The name, classification, docs overview, and pretty-printed type

86 | AnnBoundName Name Bool

94 | AnnBoundName Name Bool

87− | AnnConstData

95+ -- ^^ The name and whether it is implicit

88− | AnnConstType

96+ | AnnConst Const

97+ | AnnData String String -- ^ type, doc overview

98+ | AnnType String String -- ^ name, doc overview

99+ | AnnKeyword

89 | AnnFC FC

100 | AnnFC FC

101+ | AnnTextFmt TextFormatting

90

102

91-- | Used for error reflection

103-- | Used for error reflection

92data ErrorReportPart = TextPart String

104data ErrorReportPart = TextPart String

@@ -121,7 +133,7 @@ data Err' t

121 | NoTypeDecl Name

133 | NoTypeDecl Name

122 | NotInjective t t t

134 | NotInjective t t t

123 | CantResolve t

135 | CantResolve t

124− | CantResolveAlts [String]

136+ | CantResolveAlts [Name]

125 | IncompleteTerm t

137 | IncompleteTerm t

126 | UniverseError

138 | UniverseError

127 | ProgramLineComment

139 | ProgramLineComment

@@ -132,6 +144,7 @@ data Err' t

132 | NoRewriting t

144 | NoRewriting t

133 | At FC (Err' t)

145 | At FC (Err' t)

134 | Elaborating String Name (Err' t)

146 | Elaborating String Name (Err' t)

147+ | ElaboratingArg Name Name [(Name, Name)] (Err' t)

135 | ProviderError String

148 | ProviderError String

136 | LoadingFailed String (Err' t)

149 | LoadingFailed String (Err' t)

137 | ReflectionError [[ErrorReportPart]] (Err' t)

150 | ReflectionError [[ErrorReportPart]] (Err' t)

@@ -162,6 +175,7 @@ instance Sized Err where

162 size ProgramLineComment = 1

175 size ProgramLineComment = 1

163 size (At fc err) = size fc + size err

176 size (At fc err) = size fc + size err

164 size (Elaborating _ n err) = size err

177 size (Elaborating _ n err) = size err

178+ size (ElaboratingArg _ _ _ err) = size err

165 size (ProviderError msg) = length msg

179 size (ProviderError msg) = length msg

166 size (LoadingFailed fn e) = 1 + length fn + size e

180 size (LoadingFailed fn e) = 1 + length fn + size e

167 size _ = 1

181 size _ = 1

@@ -170,9 +184,12 @@ score :: Err -> Int

170score (CantUnify _ _ _ m _ s) = s + score m

184score (CantUnify _ _ _ m _ s) = s + score m

171score (CantResolve _) = 20

185score (CantResolve _) = 20

172score (NoSuchVariable _) = 1000

186score (NoSuchVariable _) = 1000

173−score (ProofSearchFail _) = 10000

187+score (ProofSearchFail e) = score e

174−score (CantSolveGoal _ _) = 10000

188+score (CantSolveGoal _ _) = 100000

175score (InternalMsg _) = -1

189score (InternalMsg _) = -1

190+score (At _ e) = score e

191+score (ElaboratingArg _ _ _ e) = score e

192+score (Elaborating _ _ e) = score e

176score _ = 0

193score _ = 0

177

194

178instance Show Err where

195instance Show Err where

@@ -186,6 +203,10 @@ instance Show Err where

186 show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e

203 show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e

187 show ProgramLineComment = "Program line next to comment"

204 show ProgramLineComment = "Program line next to comment"

188 show (At f e) = show f ++ ":" ++ show e

205 show (At f e) = show f ++ ":" ++ show e

206+ show (ElaboratingArg f x prev e) = "Elaborating " ++ show f ++ " arg " ++

207+ show x ++ ": " ++ show e

208+ show (Elaborating what n e) = "Elaborating " ++ what ++ show n ++ ":" ++ show e

209+ show (ProofSearchFail e) = "Proof search fail: " ++ show e

189 show _ = "Error"

210 show _ = "Error"

190

211

191instance Pretty Err OutputAnnotation where

212instance Pretty Err OutputAnnotation where

@@ -241,7 +262,7 @@ traceWhen False _ a = a

241data Name = UN T.Text -- ^ User-provided name

262data Name = UN T.Text -- ^ User-provided name

242 | NS Name [T.Text] -- ^ Root, namespaces

263 | NS Name [T.Text] -- ^ Root, namespaces

243 | MN Int T.Text -- ^ Machine chosen names

264 | MN Int T.Text -- ^ Machine chosen names

244− | NErased -- ^ Name of somethng which is never used in scope

265+ | NErased -- ^ Name of something which is never used in scope

245 | SN SpecialName -- ^ Decorated function names

266 | SN SpecialName -- ^ Decorated function names

246 | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)

267 | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)

247 deriving (Eq, Ord)

268 deriving (Eq, Ord)

@@ -299,11 +320,11 @@ instance Sized Name where

299 size _ = 1

320 size _ = 1

300

321

301instance Pretty Name OutputAnnotation where

322instance Pretty Name OutputAnnotation where

302− pretty n@(UN n') = annotate (AnnName n Nothing Nothing) $ text (T.unpack n')

323+ pretty n@(UN n') = annotate (AnnName n Nothing Nothing Nothing) $ text (T.unpack n')

303− pretty n@(NS un s) = annotate (AnnName n Nothing Nothing) . noAnnotate $ pretty un

324+ pretty n@(NS un s) = annotate (AnnName n Nothing Nothing Nothing) . noAnnotate $ pretty un

304− pretty n@(MN i s) = annotate (AnnName n Nothing Nothing) $

325+ pretty n@(MN i s) = annotate (AnnName n Nothing Nothing Nothing) $

305 lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace

326 lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace

306− pretty n@(SN s) = annotate (AnnName n Nothing Nothing) $ text (show s)

327+ pretty n@(SN s) = annotate (AnnName n Nothing Nothing Nothing) $ text (show s)

307

328

308instance Pretty [Name] OutputAnnotation where

329instance Pretty [Name] OutputAnnotation where

309 pretty = encloseSep empty empty comma . map pretty

330 pretty = encloseSep empty empty comma . map pretty

@@ -368,6 +389,7 @@ implicitable _ = False

368nsroot (NS n _) = n

389nsroot (NS n _) = n

369nsroot n = n

390nsroot n = n

370

391

392+-- this will overwrite already existing definitions

371addDef :: Name -> a -> Ctxt a -> Ctxt a

393addDef :: Name -> a -> Ctxt a -> Ctxt a

372addDef n v ctxt = case Map.lookup (nsroot n) ctxt of

394addDef n v ctxt = case Map.lookup (nsroot n) ctxt of

373 Nothing -> Map.insert (nsroot n)

395 Nothing -> Map.insert (nsroot n)

@@ -410,6 +432,9 @@ lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt)

410lookupCtxtExact :: Name -> Ctxt a -> Maybe a

432lookupCtxtExact :: Name -> Ctxt a -> Maybe a

411lookupCtxtExact n ctxt = listToMaybe [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n]

433lookupCtxtExact n ctxt = listToMaybe [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n]

412

434

435+deleteDefExact :: Name -> Ctxt a -> Ctxt a

436+deleteDefExact n = Map.adjust (Map.delete n) (nsroot n)

437+

413updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a

438updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a

414updateDef n f ctxt

439updateDef n f ctxt

415 = let ds = lookupCtxtName n ctxt in

440 = let ds = lookupCtxtName n ctxt in

@@ -417,7 +442,7 @@ updateDef n f ctxt

417

442

418toAlist :: Ctxt a -> [(Name, a)]

443toAlist :: Ctxt a -> [(Name, a)]

419toAlist ctxt = let allns = map snd (Map.toList ctxt) in

444toAlist ctxt = let allns = map snd (Map.toList ctxt) in

420− concat (map (Map.toList) allns)

445+ concatMap (Map.toList) allns

421

446

422addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a

447addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a

423addAlist [] ctxt = ctxt

448addAlist [] ctxt = ctxt

@@ -505,6 +530,60 @@ instance Pretty Const OutputAnnotation where

505 pretty (B32 w) = text . show $ w

530 pretty (B32 w) = text . show $ w

506 pretty (B64 w) = text . show $ w

531 pretty (B64 w) = text . show $ w

507

532

533+-- | Determines whether the input constant represents a type

534+constIsType :: Const -> Bool

535+constIsType (I _) = False

536+constIsType (BI _) = False

537+constIsType (Fl _) = False

538+constIsType (Ch _) = False

539+constIsType (Str _) = False

540+constIsType (B8 _) = False

541+constIsType (B16 _) = False

542+constIsType (B32 _) = False

543+constIsType (B64 _) = False

544+constIsType (B8V _) = False

545+constIsType (B16V _) = False

546+constIsType (B32V _) = False

547+constIsType (B64V _) = False

548+constIsType _ = True

549+

550+-- | Get the docstring for a Const

551+constDocs :: Const -> String

552+constDocs c@(AType (ATInt ITBig)) = "Arbitrary-precision integers"

553+constDocs c@(AType (ATInt ITNative)) = "Fixed-precision integers of undefined size"

554+constDocs c@(AType (ATInt ITChar)) = "Characters in some unspecified encoding"

555+constDocs c@(AType ATFloat) = "Double-precision floating-point numbers"

556+constDocs StrType = "Strings in some unspecified encoding"

557+constDocs PtrType = "Foreign pointers"

558+constDocs ManagedPtrType = "Managed pointers"

559+constDocs BufferType = "Copy-on-write buffers"

560+constDocs c@(AType (ATInt (ITFixed IT8))) = "Eight bits (unsigned)"

561+constDocs c@(AType (ATInt (ITFixed IT16))) = "Sixteen bits (unsigned)"

562+constDocs c@(AType (ATInt (ITFixed IT32))) = "Thirty-two bits (unsigned)"

563+constDocs c@(AType (ATInt (ITFixed IT64))) = "Sixty-four bits (unsigned)"

564+constDocs c@(AType (ATInt (ITVec IT8 16))) = "Vectors of sixteen eight-bit values"

565+constDocs c@(AType (ATInt (ITVec IT16 8))) = "Vectors of eight sixteen-bit values"

566+constDocs c@(AType (ATInt (ITVec IT32 4))) = "Vectors of four thirty-two-bit values"

567+constDocs c@(AType (ATInt (ITVec IT64 2))) = "Vectors of two sixty-four-bit values"

568+constDocs (Fl f) = "A float"

569+constDocs (I i) = "A fixed-precision integer"

570+constDocs (BI i) = "An arbitrary-precision integer"

571+constDocs (Str s) = "A string of length " ++ show (length s)

572+constDocs (Ch c) = "A character"

573+constDocs (B8 w) = "The eight-bit value 0x" ++

574+ showIntAtBase 16 intToDigit w ""

575+constDocs (B16 w) = "The sixteen-bit value 0x" ++

576+ showIntAtBase 16 intToDigit w ""

577+constDocs (B32 w) = "The thirty-two-bit value 0x" ++

578+ showIntAtBase 16 intToDigit w ""

579+constDocs (B64 w) = "The sixty-four-bit value 0x" ++

580+ showIntAtBase 16 intToDigit w ""

581+constDocs (B8V v) = "A vector of eight-bit values"

582+constDocs (B16V v) = "A vector of sixteen-bit values"

583+constDocs (B32V v) = "A vector of thirty-two-bit values"

584+constDocs (B64V v) = "A vector of sixty-four-bit values"

585+constDocs prim = "Undocumented"

586+

508data Raw = Var Name

587data Raw = Var Name

509 | RBind Name (Binder Raw) Raw

588 | RBind Name (Binder Raw) Raw

510 | RApp Raw Raw

589 | RApp Raw Raw

@@ -981,8 +1060,9 @@ uniqueName n hs | n `elem` hs = uniqueName (nextName n) hs

981

1060

982uniqueBinders :: [Name] -> TT Name -> TT Name

1061uniqueBinders :: [Name] -> TT Name -> TT Name

983uniqueBinders ns (Bind n b sc)

1062uniqueBinders ns (Bind n b sc)

984− = let n' = uniqueName n ns in

1063+ = let n' = uniqueName n ns

1064+ ns' = n' : ns in

985− Bind n' (fmap (uniqueBinders (n':ns)) b) (uniqueBinders ns sc)

1065+ Bind n' (fmap (uniqueBinders ns') b) (uniqueBinders ns' sc)

986uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a)

1066uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a)

987uniqueBinders ns t = t

1067uniqueBinders ns t = t

988

1068

@@ -1207,3 +1287,12 @@ orderPats tm = op [] tm

1207 = (n', t') : insert n t ps

1287 = (n', t') : insert n t ps

1208 | otherwise = (n,t):(n',t'):ps

1288 | otherwise = (n,t):(n',t'):ps

1209

1289

1290+allTTNames :: Eq n => TT n -> [n]

1291+allTTNames = nub . allNamesIn

1292+ where allNamesIn (P _ n _) = [n]

1293+ allNamesIn (Bind n b t) = [n] ++ nb b ++ allNamesIn t

1294+ where nb (Let t v) = allNamesIn t ++ allNamesIn v

1295+ nb (Guess t v) = allNamesIn t ++ allNamesIn v

1296+ nb t = allNamesIn (binderTy t)

1297+ allNamesIn (App f a) = allNamesIn f ++ allNamesIn a

1298+ allNamesIn _ = []

src/Idris/Core/Unify.hs+116−65

@@ -1,6 +1,6 @@

1{-# LANGUAGE PatternGuards #-}

2

3−module Idris.Core.Unify(match_unify, unify, Fails, FailAt(..)) where

3+module Idris.Core.Unify(match_unify, unify, Fails, FailContext(..), FailAt(..)) where

4

5import Idris.Core.TT

6import Idris.Core.Evaluate

@@ -21,8 +21,14 @@ import Debug.Trace

21data FailAt = Match | Unify

22 deriving (Show, Eq)

23

24+data FailContext = FailContext { fail_sourceloc :: FC,

25+ fail_fn :: Name,

26+ fail_param :: Name

27+ }

28+ deriving (Eq, Show)

29+

24type Injs = [(TT Name, TT Name, TT Name)]

30type Injs = [(TT Name, TT Name, TT Name)]

25−type Fails = [(TT Name, TT Name, Env, Err, FailAt)]

31+type Fails = [(TT Name, TT Name, Env, Err, [FailContext], FailAt)]

26

32

27data UInfo = UI Int Fails

33data UInfo = UI Int Fails

28 deriving Show

34 deriving Show

@@ -31,17 +37,26 @@ data UResult a = UOK a

31 | UPartOK a

37 | UPartOK a

32 | UFail Err

38 | UFail Err

33

39

40+-- | Smart constructor for unification errors that takes into account the FailContext

41+cantUnify :: [FailContext] -> Bool -> t -> t -> (Err' t) -> [(Name, t)] -> Int -> Err' t

42+cantUnify [] r t1 t2 e ctxt i = CantUnify r t1 t2 e ctxt i

43+cantUnify (FailContext fc f x : prev) r t1 t2 e ctxt i =

44+ At fc (ElaboratingArg f x

45+ (map (\(FailContext _ f' x') -> (f', x')) prev)

46+ (CantUnify r t1 t2 e ctxt i))

47+

34-- Solve metavariables by matching terms against each other

48-- Solve metavariables by matching terms against each other

35-- Not really unification, of course!

49-- Not really unification, of course!

36

50

37−match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

51+match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->

38 TC [(Name, TT Name)]

52 TC [(Name, TT Name)]

39−match_unify ctxt env topx topy inj holes =

53+match_unify ctxt env topx topy inj holes from =

40− case runStateT (un [] topx topy) (UI 0 []) of

54+ case runStateT (un [] (renameBindersTm env topx)

55+ (renameBindersTm env topy)) (UI 0 []) of

41 OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v))

56 OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v))

42 res ->

57 res ->

43− let topxn = normalise ctxt env topx

58+ let topxn = renameBindersTm env (normalise ctxt env topx)

44− topyn = normalise ctxt env topy in

59+ topyn = renameBindersTm env (normalise ctxt env topy) in

45 case runStateT (un [] topxn topyn)

60 case runStateT (un [] topxn topyn)

46 (UI 0 []) of

61 (UI 0 []) of

47 OK (v, UI _ fails) ->

62 OK (v, UI _ fails) ->

@@ -54,7 +69,20 @@ match_unify ctxt env topx topy inj holes =

54 return (map (renameBinders env) (trimSolutions v))

69 return (map (renameBinders env) (trimSolutions v))

55 _ -> tfail e

70 _ -> tfail e

56 where

71 where

57−

72+ -- This rule is highly dubious... it certainly produces a valid answer

73+ -- but it scares me. However, matching is never guaranteed to give a unique

74+ -- answer, merely a valid one, so perhaps we're okay.

75+ -- In other words: it may vanish without warning some day :)

76+ un names x tm@(App (P _ f (Bind fn (Pi t) sc)) a)

77+ | (P (DCon _ _) _ _, _) <- unApply x,

78+ holeIn env f || f `elem` holes

79+ = let n' = uniqueName (sMN 0 "mv") (map fst env) in

80+ checkCycle names (f, Bind n' (Lam t) x)

81+ un names tm@(App (P _ f (Bind fn (Pi t) sc)) a) x

82+ | (P (DCon _ _) _ _, _) <- unApply x,

83+ holeIn env f || f `elem` holes

84+ = let n' = uniqueName fn (map fst env) in

85+ checkCycle names (f, Bind n' (Lam t) x)

58

86

59 un names (P _ x _) tm

87 un names (P _ x _) tm

60 | holeIn env x || x `elem` holes

88 | holeIn env x || x `elem` holes

@@ -70,7 +98,7 @@ match_unify ctxt env topx topy inj holes =

70 | length bnames > i,

98 | length bnames > i,

71 fst (fst (bnames!!i)) == x ||

99 fst (fst (bnames!!i)) == x ||

72 snd (fst (bnames!!i)) == x = do sc 1; return []

100 snd (fst (bnames!!i)) == x = do sc 1; return []

73− un bnames (Bind x bx sx) (Bind y by sy)

101+ un bnames (Bind x bx sx) (Bind y by sy) | notHole bx && notHole by

74 = do h1 <- uB bnames bx by

102 = do h1 <- uB bnames bx by

75 h2 <- un (((x, y), binderTy bx) : bnames) sx sy

103 h2 <- un (((x, y), binderTy bx) : bnames) sx sy

76 combine bnames h1 h2

104 combine bnames h1 h2

@@ -81,11 +109,12 @@ match_unify ctxt env topx topy inj holes =

81 un names x y

109 un names x y

82 | OK True <- convEq' ctxt holes x y = do sc 1; return []

110 | OK True <- convEq' ctxt holes x y = do sc 1; return []

83 | otherwise = do UI s f <- get

111 | otherwise = do UI s f <- get

84− let r = recoverable x y

112+ let r = recoverable (normalise ctxt env x)

85− let err = CantUnify r

113+ (normalise ctxt env y)

114+ let err = cantUnify from r

86 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

115 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

87 if (not r) then lift $ tfail err

116 if (not r) then lift $ tfail err

88− else do put (UI s ((x, y, env, err, Match) : f))

117+ else do put (UI s ((x, y, env, err, from, Match) : f))

89 lift $ tfail err

118 lift $ tfail err

90

119

91

120

@@ -95,13 +124,17 @@ match_unify ctxt env topx topy inj holes =

95 uB bnames (Lam tx) (Lam ty) = un bnames tx ty

124 uB bnames (Lam tx) (Lam ty) = un bnames tx ty

96 uB bnames (Pi tx) (Pi ty) = un bnames tx ty

125 uB bnames (Pi tx) (Pi ty) = un bnames tx ty

97 uB bnames x y = do UI s f <- get

126 uB bnames x y = do UI s f <- get

98− let r = recoverable (binderTy x) (binderTy y)

127+ let r = recoverable (normalise ctxt env (binderTy x))

128+ (normalise ctxt env (binderTy y))

99− let err = CantUnify r topx topy

129+ let err = cantUnify from r topx topy

100− (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

130+ (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

101− (errEnv env) s

131+ (errEnv env) s

102− put (UI s ((binderTy x, binderTy y, env, err, Match) : f))

132+ put (UI s ((binderTy x, binderTy y, env, err, from, Match) : f))

103 return []

133 return []

104

134

135+ notHole (Hole _) = False

136+ notHole _ = True

137+

105 -- TODO: there's an annoying amount of repetition between this and the

138 -- TODO: there's an annoying amount of repetition between this and the

106 -- main unification function. Consider lifting it out.

139 -- main unification function. Consider lifting it out.

107

140

@@ -109,10 +142,11 @@ match_unify ctxt env topx topy inj holes =

109 put (UI (s+i) f)

142 put (UI (s+i) f)

110

143

111 unifyFail x y = do UI s f <- get

144 unifyFail x y = do UI s f <- get

112− let r = recoverable x y

145+ let r = recoverable (normalise ctxt env x)

113− let err = CantUnify r

146+ (normalise ctxt env y)

147+ let err = cantUnify from r

114 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

148 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

115− put (UI s ((x, y, env, err, Match) : f))

149+ put (UI s ((x, y, env, err, from, Match) : f))

116 lift $ tfail err

150 lift $ tfail err

117 combine bnames as [] = return as

151 combine bnames as [] = return as

118 combine bnames as ((n, t) : bs)

152 combine bnames as ((n, t) : bs)

@@ -147,23 +181,30 @@ match_unify ctxt env topx topy inj holes =

147 App (Bind y (Lam ty) (bind (i-1) ns tm))

181 App (Bind y (Lam ty) (bind (i-1) ns tm))

148 (P Bound x ty)

182 (P Bound x ty)

149

183

184+renameBinders env (x, t) = (x, renameBindersTm env t)

185+

150−renameBinders :: Env -> (Name, TT Name) -> (Name, TT Name)

186+renameBindersTm :: Env -> TT Name -> TT Name

151−renameBinders env (x, tm) = (x, uniqueBinders tm)

187+renameBindersTm env tm = uniqueBinders (map fst env) tm

152 where

188 where

153− uniqueBinders (Bind n b sc)

189+ uniqueBinders env (Bind n b sc)

154− | n `elem` map fst env

190+ | n `elem` env

155− = let n' = uniqueName n (map fst env) in

191+ = let n' = uniqueName n env in

156− Bind n' (fmap uniqueBinders b)

192+ explicitHole $ Bind n' (fmap (uniqueBinders env) b)

157− (uniqueBinders (rename n n' sc))

193+ (uniqueBinders (n':env) (rename n n' sc))

158− | otherwise = Bind n (fmap uniqueBinders b) (uniqueBinders sc)

194+ | otherwise = Bind n (fmap (uniqueBinders (n:env)) b)

195+ (uniqueBinders (n:env) sc)

159− uniqueBinders (App f a) = App (uniqueBinders f) (uniqueBinders a)

196+ uniqueBinders env (App f a) = App (uniqueBinders env f) (uniqueBinders env a)

160− uniqueBinders t = t

197+ uniqueBinders env t = t

161

198

162 rename n n' (P nt x ty) | n == x = P nt n' ty

199 rename n n' (P nt x ty) | n == x = P nt n' ty

163 rename n n' (Bind x b sc) = Bind x (fmap (rename n n') b) (rename n n' sc)

200 rename n n' (Bind x b sc) = Bind x (fmap (rename n n') b) (rename n n' sc)

164 rename n n' (App f a) = App (rename n n' f) (rename n n' a)

201 rename n n' (App f a) = App (rename n n' f) (rename n n' a)

165 rename n n' t = t

202 rename n n' t = t

166

203

204+ explicitHole (Bind n (Hole ty) sc)

205+ = Bind n (Hole ty) (instantiate (P Bound n ty) sc)

206+ explicitHole t = t

207+

167trimSolutions ns = dropPairs ns

208trimSolutions ns = dropPairs ns

168 where dropPairs [] = []

209 where dropPairs [] = []

169 dropPairs (n@(x, P _ x' _) : ns)

210 dropPairs (n@(x, P _ x' _) : ns)

@@ -183,18 +224,24 @@ expandLets env (x, tm) = (x, doSubst (reverse env) tm)

183 doSubst (_ : env) tm

224 doSubst (_ : env) tm

184 = doSubst env tm

225 = doSubst env tm

185

226

227+hasv (V x) = True

228+hasv (App f a) = hasv f || hasv a

229+hasv (Bind x b sc) = hasv (binderTy b) || hasv sc

230+hasv _ = False

186

231

187−unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

232+unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->

188 TC ([(Name, TT Name)], Fails)

233 TC ([(Name, TT Name)], Fails)

189−unify ctxt env topx topy inj holes =

234+unify ctxt env topx topy inj holes from =

235+-- traceWhen (hasv topx || hasv topy)

190−-- trace ("Unifying " ++ show (topx, topy)) $

236+-- ("Unifying " ++ show topx ++ "\nAND\n" ++ show topy ++ "\n") $

191 -- don't bother if topx and topy are different at the head

237 -- don't bother if topx and topy are different at the head

192− case runStateT (un False [] topx topy) (UI 0 []) of

238+ case runStateT (un False [] (renameBindersTm env topx)

239+ (renameBindersTm env topy)) (UI 0 []) of

193 OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v),

240 OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v),

194 [])

241 [])

195 res ->

242 res ->

196− let topxn = normalise ctxt env topx

243+ let topxn = renameBindersTm env (normalise ctxt env topx)

197− topyn = normalise ctxt env topy in

244+ topyn = renameBindersTm env (normalise ctxt env topy) in

198-- trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $

245-- trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $

199 case runStateT (un False [] topxn topyn)

246 case runStateT (un False [] topxn topyn)

200 (UI 0 []) of

247 (UI 0 []) of

@@ -273,7 +320,7 @@ unify ctxt env topx topy inj holes =

273 | injective ty && not (holeIn env x || x `elem` holes)

320 | injective ty && not (holeIn env x || x `elem` holes)

274 = unifyTmpFail tx ty

321 = unifyTmpFail tx ty

275 un' fn bnames xtm@(P _ x _) tm

322 un' fn bnames xtm@(P _ x _) tm

276− | holeIn env x || x `elem` holes

323+ | pureTerm tm, holeIn env x || x `elem` holes

277 = do UI s f <- get

324 = do UI s f <- get

278 -- injectivity check

325 -- injectivity check

279 x <- checkCycle bnames (x, tm)

326 x <- checkCycle bnames (x, tm)

@@ -283,11 +330,11 @@ unify ctxt env topx topy inj holes =

283 then unifyTmpFail xtm tm

330 then unifyTmpFail xtm tm

284 else do sc 1

331 else do sc 1

285 return x

332 return x

286− | not (injective xtm) && injective tm

333+ | pureTerm tm, not (injective xtm) && injective tm

287 = do checkCycle bnames (x, tm)

334 = do checkCycle bnames (x, tm)

288 unifyTmpFail xtm tm

335 unifyTmpFail xtm tm

289 un' fn bnames tm ytm@(P _ y _)

336 un' fn bnames tm ytm@(P _ y _)

290− | holeIn env y || y `elem` holes

337+ | pureTerm tm, holeIn env y || y `elem` holes

291 = do UI s f <- get

338 = do UI s f <- get

292 -- injectivity check

339 -- injectivity check

293 x <- checkCycle bnames (y, tm)

340 x <- checkCycle bnames (y, tm)

@@ -297,7 +344,7 @@ unify ctxt env topx topy inj holes =

297 then unifyTmpFail tm ytm

344 then unifyTmpFail tm ytm

298 else do sc 1

345 else do sc 1

299 return x

346 return x

300− | not (injective ytm) && injective tm

347+ | pureTerm tm, not (injective ytm) && injective tm

301 = do checkCycle bnames (y, tm)

348 = do checkCycle bnames (y, tm)

302 unifyTmpFail tm ytm

349 unifyTmpFail tm ytm

303 un' fn bnames (V i) (P _ x _)

350 un' fn bnames (V i) (P _ x _)

@@ -358,17 +405,18 @@ unify ctxt env topx topy inj holes =

358 un' fn bnames x y

405 un' fn bnames x y

359 | OK True <- convEq' ctxt holes x y = do sc 1; return []

406 | OK True <- convEq' ctxt holes x y = do sc 1; return []

360 | otherwise = do UI s f <- get

407 | otherwise = do UI s f <- get

361− let r = recoverable x y

408+ let r = recoverable (normalise ctxt env x)

362− let err = CantUnify r

409+ (normalise ctxt env y)

410+ let err = cantUnify from r

363 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

411 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

364 if (not r) then lift $ tfail err

412 if (not r) then lift $ tfail err

365− else do put (UI s ((x, y, env, err, Unify) : f))

413+ else do put (UI s ((x, y, env, err, from, Unify) : f))

366 return [] -- lift $ tfail err

414 return [] -- lift $ tfail err

367

415

368 unApp fn bnames appx@(App fx ax) appy@(App fy ay)

416 unApp fn bnames appx@(App fx ax) appy@(App fy ay)

369 | (injectiveApp fx && injectiveApp fy)

417 | (injectiveApp fx && injectiveApp fy)

370− || (injectiveApp fx && rigid appx && metavarApp appy)

418+ || (injectiveApp fx && rigid appx && metavarApp appy && numArgs appx == numArgs appy)

371− || (injectiveApp fy && rigid appy && metavarApp appx)

419+ || (injectiveApp fy && rigid appy && metavarApp appx && numArgs appx == numArgs appy)

372 || (injectiveApp fx && metavarApp fy && ax == ay)

420 || (injectiveApp fx && metavarApp fy && ax == ay)

373 || (injectiveApp fy && metavarApp fx && ax == ay)

421 || (injectiveApp fy && metavarApp fx && ax == ay)

374 = do let (headx, _) = unApply fx

422 = do let (headx, _) = unApply fx

@@ -413,6 +461,8 @@ unify ctxt env topx topy inj holes =

413 vs <- combine bnames as as'

461 vs <- combine bnames as as'

414 unArgs vs xs ys

462 unArgs vs xs ys

415

463

464+ numArgs tm = let (f, args) = unApply tm in length args

465+

416 metavarApp tm = let (f, args) = unApply tm in

466 metavarApp tm = let (f, args) = unApply tm in

417 (metavar f &&

467 (metavar f &&

418 all (\x -> metavarApp x) args

468 all (\x -> metavarApp x) args

@@ -456,18 +506,18 @@ unify ctxt env topx topy inj holes =

456 unifyTmpFail :: Term -> Term -> StateT UInfo TC [(Name, TT Name)]

506 unifyTmpFail :: Term -> Term -> StateT UInfo TC [(Name, TT Name)]

457 unifyTmpFail x y

507 unifyTmpFail x y

458 = do UI s f <- get

508 = do UI s f <- get

459− let r = recoverable x y

509+ let r = recoverable (normalise ctxt env x) (normalise ctxt env y)

460− let err = CantUnify r

510+ let err = cantUnify from r

461 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

511 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

462− put (UI s ((topx, topy, env, err, Unify) : f))

512+ put (UI s ((topx, topy, env, err, from, Unify) : f))

463 return []

513 return []

464

514

465 -- shortcut failure, if we *know* nothing can fix it

515 -- shortcut failure, if we *know* nothing can fix it

466 unifyFail x y = do UI s f <- get

516 unifyFail x y = do UI s f <- get

467− let r = recoverable x y

517+ let r = recoverable (normalise ctxt env x) (normalise ctxt env y)

468− let err = CantUnify r

518+ let err = cantUnify from r

469 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

519 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

470− put (UI s ((topx, topy, env, err, Unify) : f))

520+ put (UI s ((topx, topy, env, err, from, Unify) : f))

471 lift $ tfail err

521 lift $ tfail err

472

522

473

523

@@ -486,11 +536,12 @@ unify ctxt env topx topy inj holes =

486 uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty

536 uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty

487 uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty

537 uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty

488 uB bnames x y = do UI s f <- get

538 uB bnames x y = do UI s f <- get

489− let r = recoverable (binderTy x) (binderTy y)

539+ let r = recoverable (normalise ctxt env (binderTy x))

540+ (normalise ctxt env (binderTy y))

490− let err = CantUnify r topx topy

541+ let err = cantUnify from r topx topy

491− (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

542+ (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

492− (errEnv env) s

543+ (errEnv env) s

493− put (UI s ((binderTy x, binderTy y, env, err, Unify) : f))

544+ put (UI s ((binderTy x, binderTy y, env, err, from, Unify) : f))

494 return [] -- lift $ tfail err

545 return [] -- lift $ tfail err

495

546

496 checkCycle ns p@(x, P _ _ _) = return [p]

547 checkCycle ns p@(x, P _ _ _) = return [p]

@@ -498,7 +549,7 @@ unify ctxt env topx topy inj holes =

498 | not (x `elem` freeNames tm) = checkScope ns (x, tm)

549 | not (x `elem` freeNames tm) = checkScope ns (x, tm)

499 | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env))

550 | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env))

500

551

501− checkScope ns (x, tm) =

552+ checkScope ns (x, tm) | pureTerm tm =

502-- case boundVs (envPos x 0 env) tm of

553-- case boundVs (envPos x 0 env) tm of

503-- [] -> return [(x, tm)]

554-- [] -> return [(x, tm)]

504-- (i:_) -> lift $ tfail (UnifyScope x (fst (fst (ns!!i)))

555-- (i:_) -> lift $ tfail (UnifyScope x (fst (fst (ns!!i)))

@@ -509,6 +560,7 @@ unify ctxt env topx topy inj holes =

509 else return [(x, bind v ns tm)]

560 else return [(x, bind v ns tm)]

510 where inst [] tm = tm

561 where inst [] tm = tm

511 inst (((n, _), _) : ns) tm = inst ns (substV (P Bound n Erased) tm)

562 inst (((n, _), _) : ns) tm = inst ns (substV (P Bound n Erased) tm)

563+ checkScope ns (x, tm) = lift $ tfail (Msg "HOLE ERROR")

512

564

513 bind i ns tm

565 bind i ns tm

514 | i < 0 = tm

566 | i < 0 = tm

@@ -556,17 +608,14 @@ envPos x i ((y, _) : ys) | x == y = i

556-- more work may help.

608-- more work may help.

557-- FIXME: Depending on how overloading gets used, this may cause problems. Better

609-- FIXME: Depending on how overloading gets used, this may cause problems. Better

558-- rethink overloading properly...

610-- rethink overloading properly...

611+-- ASSUMPTION: inputs are in normal form

559

612

560recoverable t@(App _ _) _

613recoverable t@(App _ _) _

561 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False

614 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False

562recoverable _ t@(App _ _)

615recoverable _ t@(App _ _)

563 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False

616 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False

564−recoverable (P (DCon _ _) x _) (P (DCon _ _) y _)

617+recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) = x == y

565− | x == y = True

566− | otherwise = False

567−recoverable (P (TCon _ _) x _) (P (TCon _ _) y _)

618+recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) = x == y

568− | x == y = True

569− | otherwise = False

570recoverable (Constant _) (P (DCon _ _) y _) = False

619recoverable (Constant _) (P (DCon _ _) y _) = False

571recoverable (P (DCon _ _) x _) (Constant _) = False

620recoverable (P (DCon _ _) x _) (Constant _) = False

572recoverable (Constant _) (P (TCon _ _) y _) = False

621recoverable (Constant _) (P (TCon _ _) y _) = False

@@ -576,7 +625,7 @@ recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False

576recoverable p@(Constant _) (App f a) = recoverable p f

625recoverable p@(Constant _) (App f a) = recoverable p f

577recoverable (App f a) p@(Constant _) = recoverable f p

626recoverable (App f a) p@(Constant _) = recoverable f p

578recoverable p@(P _ n _) (App f a) = recoverable p f

627recoverable p@(P _ n _) (App f a) = recoverable p f

579−-- recoverable (App f a) p@(P _ _ _) = recoverable f p

628+recoverable (App f a) p@(P _ _ _) = recoverable f p

580recoverable (App f a) (App f' a')

629recoverable (App f a) (App f' a')

581 = recoverable f f' -- && recoverable a a'

630 = recoverable f f' -- && recoverable a a'

582recoverable f (Bind _ (Pi _) sc)

631recoverable f (Bind _ (Pi _) sc)

@@ -585,7 +634,9 @@ recoverable f (Bind _ (Pi _) sc)

585recoverable (Bind _ (Pi _) sc) f

634recoverable (Bind _ (Pi _) sc) f

586 | (P (DCon _ _) _ _, _) <- unApply f = False

635 | (P (DCon _ _) _ _, _) <- unApply f = False

587 | (P (TCon _ _) _ _, _) <- unApply f = False

636 | (P (TCon _ _) _ _, _) <- unApply f = False

588−recoverable _ _ = True

637+recoverable (Bind _ (Lam _) sc) f = recoverable sc f

638+recoverable f (Bind _ (Lam _) sc) = recoverable f sc

639+recoverable x y = True

589

640

590errEnv = map (\(x, b) -> (x, binderTy b))

641errEnv = map (\(x, b) -> (x, binderTy b))

591

642

src/Idris/Coverage.hs+148−159

@@ -9,6 +9,7 @@ import Idris.Core.CaseTree

9import Idris.AbsSyntax

10import Idris.Delaborate

11import Idris.Error

12+import Idris.Output (iWarn, iputStrLn)

12

13

13import Data.List

14import Data.List

14import Data.Either

15import Data.Either

@@ -17,10 +18,14 @@ import Debug.Trace

17

18

18import Control.Monad.State.Strict

19import Control.Monad.State.Strict

19

20

21+-- Generate a pattern from an 'impossible' LHS. (Need this to eliminate the

22+-- pattern clauses which have been provided explicitly from new clause

23+-- generation.)

24+

20mkPatTm :: PTerm -> Idris Term

25mkPatTm :: PTerm -> Idris Term

21mkPatTm t = do i <- getIState

26mkPatTm t = do i <- getIState

22 let timp = addImpl' True [] [] i t

27 let timp = addImpl' True [] [] i t

23− evalStateT (toTT timp) 0

28+ evalStateT (toTT (mapPT deNS timp)) 0

24 where

29 where

25 toTT (PRef _ n) = do i <- lift getIState

30 toTT (PRef _ n) = do i <- lift getIState

26 case lookupDef n (tt_ctxt i) of

31 case lookupDef n (tt_ctxt i) of

@@ -29,10 +34,16 @@ mkPatTm t = do i <- getIState

29 toTT (PApp _ t args) = do t' <- toTT t

34 toTT (PApp _ t args) = do t' <- toTT t

30 args' <- mapM (toTT . getTm) args

35 args' <- mapM (toTT . getTm) args

31 return $ mkApp t' args'

36 return $ mkApp t' args'

37+ -- For alternatives, pick the first and drop the namespaces. It doesn't

38+ -- really matter which is taken since matching will ignore the namespace.

39+ toTT (PAlternative _ (a : as)) = toTT a

32 toTT _ = do v <- get

40 toTT _ = do v <- get

33 put (v + 1)

41 put (v + 1)

34 return (P Bound (sMN v "imp") Erased)

42 return (P Bound (sMN v "imp") Erased)

35

43

44+ deNS (PRef f (NS n _)) = PRef f n

45+ deNS t = t

46+

36-- Given a list of LHSs, generate a extra clauses which cover the remaining

47-- Given a list of LHSs, generate a extra clauses which cover the remaining

37-- cases. The ones which haven't been provided are marked 'absurd' so that the

48-- cases. The ones which haven't been provided are marked 'absurd' so that the

38-- checker will make sure they can't happen.

49-- checker will make sure they can't happen.

@@ -40,30 +51,36 @@ mkPatTm t = do i <- getIState

40-- This will only work after the given clauses have been typechecked and the

51-- This will only work after the given clauses have been typechecked and the

41-- names are fully explicit!

52-- names are fully explicit!

42

53

43−genClauses :: FC -> Name -> [Term] -> [PClause] -> Idris [PTerm]

54+genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm]

44genClauses fc n xs given

55genClauses fc n xs given

45 = do i <- getIState

56 = do i <- getIState

46− let lhss = map (getLHS i) xs

57+ let lhs_tms = map (\x -> delab' i x True True) xs

58+ -- if a placeholder was given, don't bother generating cases for it

59+ let lhs_tms' = zipWith mergePlaceholders lhs_tms given

60+ let lhss = map pUnApply lhs_tms'

61+

47 let argss = transpose lhss

62 let argss = transpose lhss

48 let all_args = map (genAll i) argss

63 let all_args = map (genAll i) argss

49 logLvl 5 $ "COVERAGE of " ++ show n

64 logLvl 5 $ "COVERAGE of " ++ show n

65+ logLvl 5 $ show lhss

50 logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

66 logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

51 logLvl 10 $ show argss ++ "\n" ++ show all_args

67 logLvl 10 $ show argss ++ "\n" ++ show all_args

52− logLvl 10 $ "Original: \n" ++

68+ logLvl 1 $ "Original: \n" ++

53 showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)

69 showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)

54 -- add an infinite supply of explicit arguments to update the possible

70 -- add an infinite supply of explicit arguments to update the possible

55− -- cases for (the return type may be variadic, or function type, sp

71+ -- cases for (the return type may be variadic, or function type, so

56 -- there may be more case splitting that the idris_implicits record

72 -- there may be more case splitting that the idris_implicits record

57 -- suggests)

73 -- suggests)

58 let parg = case lookupCtxt n (idris_implicits i) of

74 let parg = case lookupCtxt n (idris_implicits i) of

75+ (p : _) ->

59− (p : _) -> p ++ repeat (PExp 0 [] Placeholder "")

76+ p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder)

60− _ -> repeat (pexp Placeholder)

77+ _ -> repeat (pexp Placeholder)

61 let tryclauses = mkClauses parg all_args

78 let tryclauses = mkClauses parg all_args

62 logLvl 2 $ show (length tryclauses) ++ " initially to check"

79 logLvl 2 $ show (length tryclauses) ++ " initially to check"

63− logLvl 5 $ showSep "\n" (map (showTm i) tryclauses)

80+ logLvl 1 $ showSep "\n" (map (showTm i) tryclauses)

64 let new = filter (noMatch i) (nub tryclauses)

81 let new = filter (noMatch i) (nub tryclauses)

65 logLvl 1 $ show (length new) ++ " clauses to check for impossibility"

82 logLvl 1 $ show (length new) ++ " clauses to check for impossibility"

66− logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)

83+ logLvl 3 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)

67-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)

84-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)

68 return new

85 return new

69-- return (map (\t -> PClause n t [] PImpossible []) new)

86-- return (map (\t -> PClause n t [] PImpossible []) new)

@@ -71,13 +88,23 @@ genClauses fc n xs given

71 | (f, args) <- unApply term = map (\t -> delab' i t True True) args

88 | (f, args) <- unApply term = map (\t -> delab' i t True True) args

72 | otherwise = []

89 | otherwise = []

73

90

74− lhsApp (PClause _ _ l _ _ _) = l

91+ pUnApply (PApp _ _ args) = map getTm args

75− lhsApp (PWith _ _ l _ _ _) = l

92+ pUnApply _ = []

76

93

94+ -- Return whether the given clause matches none of the input clauses

95+ -- (xs)

77 noMatch i tm = all (\x -> case matchClause i (delab' i x True True) tm of

96 noMatch i tm = all (\x -> case matchClause i (delab' i x True True) tm of

78− Right _ -> False

97+ Right ms -> False

79− Left miss -> True) xs

98+ Left miss -> True) xs

99+

80

100

101+ mergePlaceholders :: PTerm -> PTerm -> PTerm

102+ mergePlaceholders x Placeholder = Placeholder

103+ mergePlaceholders (PApp fc f args) (PApp fc' f' args')

104+ = PApp fc' f' (zipWith mergePArg args args')

105+ where mergePArg x y = let xtm = mergePlaceholders (getTm x) (getTm y) in

106+ x { getTm = xtm}

107+ mergePlaceholders x _ = x

81

108

82 mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]

109 mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]

83 mkClauses parg args

110 mkClauses parg args

@@ -101,6 +128,7 @@ fnub' acc [] = acc

101

128

102-- quick check for constructor equality

129-- quick check for constructor equality

103quickEq :: PTerm -> PTerm -> Bool

130quickEq :: PTerm -> PTerm -> Bool

131+quickEq (PConstant n) (PConstant n') = n == n'

104quickEq (PRef _ n) (PRef _ n') = n == n'

132quickEq (PRef _ n) (PRef _ n') = n == n'

105quickEq (PApp _ t as) (PApp _ t' as')

133quickEq (PApp _ t as) (PApp _ t' as')

106 | length as == length as'

134 | length as == length as'

@@ -183,11 +211,11 @@ genAll i args

183 let p = resugar (PApp fc (PRef fc n) (zipWith upd xs' xs))

211 let p = resugar (PApp fc (PRef fc n) (zipWith upd xs' xs))

184 let tyn = getTy n (tt_ctxt i)

212 let tyn = getTy n (tt_ctxt i)

185 case lookupCtxt tyn (idris_datatypes i) of

213 case lookupCtxt tyn (idris_datatypes i) of

186− (TI ns _ _ _ : _) -> p : map (mkPat fc) (ns \\ [n])

214+ (TI ns _ _ _ _ : _) -> p : map (mkPat fc) (ns \\ [n])

187 _ -> [p]

215 _ -> [p]

188 ops fc n arg o = return Placeholder

216 ops fc n arg o = return Placeholder

189

217

190− getExpTm (PImp _ True _ _ _ _) = Placeholder -- machine inferred, no point!

218+ getExpTm (PImp _ True _ _ _) = Placeholder -- machine inferred, no point!

191 getExpTm t = getTm t

219 getExpTm t = getTm t

192

220

193 -- put it back to its original form

221 -- put it back to its original form

@@ -218,29 +246,57 @@ genAll i args

218

246

219upd p' p = p { getTm = p' }

247upd p' p = p { getTm = p' }

220

248

249+-- Check whether function and all descendants cover all cases (partial is

250+-- okay, as long as it's due to recursion)

251+

252+checkAllCovering :: FC -> [Name] -> Name -> Name -> Idris ()

253+checkAllCovering fc done top n | not (n `elem` done)

254+ = do i <- get

255+ case lookupTotal n (tt_ctxt i) of

256+ [tot@(Partial NotCovering)] ->

257+ do let msg = show top ++ " is " ++ show tot ++ " due to " ++ show n

258+ putIState i { idris_totcheckfail = (fc, msg) : idris_totcheckfail i }

259+ addIBC (IBCTotCheckErr fc msg)

260+ [Partial _] ->

261+ case lookupCtxt n (idris_callgraph i) of

262+ [cg] -> mapM_ (checkAllCovering fc (n : done) top)

263+ (map fst (calls cg))

264+ _ -> return ()

265+ x -> return () -- stop if total

266+checkAllCovering _ _ _ _ = return ()

267+

268+-- Check if, in a given group of type declarations mut_ns,

221−-- Check if, in a given type n, the constructor cn : ty is strictly positive,

269+-- the constructor cn : ty is strictly positive,

222-- and update the context accordingly

270-- and update the context accordingly

223

271

224−checkPositive :: Name -> (Name, Type) -> Idris ()

272+checkPositive :: [Name] -> (Name, Type) -> Idris Totality

225−checkPositive n (cn, ty')

273+checkPositive mut_ns (cn, ty')

226− = do let ty = delazy ty'

274+ = do let ty = delazy' True ty'

227 let p = cp ty

275 let p = cp ty

228 i <- getIState

276 i <- getIState

229 let tot = if p then Total (args ty) else Partial NotPositive

277 let tot = if p then Total (args ty) else Partial NotPositive

230 let ctxt' = setTotal cn tot (tt_ctxt i)

278 let ctxt' = setTotal cn tot (tt_ctxt i)

231 putIState (i { tt_ctxt = ctxt' })

279 putIState (i { tt_ctxt = ctxt' })

232− logLvl 5 $ "Constructor " ++ show cn ++ " is " ++ show tot

280+ logLvl 5 $ "Constructor " ++ show cn ++ " is " ++ show tot ++ " with " ++ show mut_ns

233 addIBC (IBCTotal cn tot)

281 addIBC (IBCTotal cn tot)

282+ return tot

234 where

283 where

235 args t = [0..length (getArgTys t)-1]

284 args t = [0..length (getArgTys t)-1]

236

285

237 cp (Bind n (Pi aty) sc) = posArg aty && cp sc

286 cp (Bind n (Pi aty) sc) = posArg aty && cp sc

287+ cp t | (P _ n' _, args) <- unApply t,

288+ n' `elem` mut_ns = all noRec args

238− cp t = True

289+ cp _ = True

239

290

240 posArg (Bind _ (Pi nty) sc)

291 posArg (Bind _ (Pi nty) sc)

241 | (P _ n' _, args) <- unApply nty

292 | (P _ n' _, args) <- unApply nty

242− = n /= n' && posArg sc

293+ = n' `notElem` mut_ns && all noRec args && posArg sc

243− posArg t = True

294+ posArg t | (P _ n' _, args) <- unApply t,

295+ n' `elem` mut_ns = all noRec args

296+ posArg _ = True

297+

298+ noRec arg = all (\x -> x `notElem` mut_ns) (allTTNames arg)

299+

244

300

245calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality

301calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality

246calcProd i fc topn pats

302calcProd i fc topn pats

@@ -256,7 +312,7 @@ calcProd i fc topn pats

256

312

257 prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

313 prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

258 prodRec n done _ | n `elem` done = return True

314 prodRec n done _ | n `elem` done = return True

259− prodRec n done (_, _, tm) = prod n done False (delazy tm)

315+ prodRec n done (_, _, tm) = prod n done False (delazy' True tm)

260

316

261 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

317 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

262 prod n done ok ap@(App _ _)

318 prod n done ok ap@(App _ _)

@@ -288,13 +344,16 @@ calcProd i fc topn pats

288 cotype (DCon _ _) n ty

344 cotype (DCon _ _) n ty

289 | (P _ t _, _) <- unApply (getRetTy ty)

345 | (P _ t _, _) <- unApply (getRetTy ty)

290 = case lookupCtxt t (idris_datatypes i) of

346 = case lookupCtxt t (idris_datatypes i) of

291− [TI _ True _ _] -> True

347+ [TI _ True _ _ _] -> True

292 _ -> False

348 _ -> False

293 cotype nt n ty = False

349 cotype nt n ty = False

294

350

351+-- Calculate the totality of a function from its patterns.

352+-- Either follow the size change graph (if inductive) or check for

353+-- productivity (if coinductive)

354+

295−calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]

355+calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality

296− -> Idris Totality

297−calcTotality path fc n pats

356+calcTotality fc n pats

298 = do i <- getIState

357 = do i <- getIState

299 let opts = case lookupCtxt n (idris_flags i) of

358 let opts = case lookupCtxt n (idris_flags i) of

300 [fs] -> fs

359 [fs] -> fs

@@ -329,20 +388,18 @@ checkTotality path fc n

329 [CaseOp _ _ _ _ pats _] ->

388 [CaseOp _ _ _ _ pats _] ->

330 do t' <- if AssertTotal `elem` opts

389 do t' <- if AssertTotal `elem` opts

331 then return $ Total []

390 then return $ Total []

332− else calcTotality path fc n pats

391+ else calcTotality fc n pats

333 setTotality n t'

392 setTotality n t'

334 addIBC (IBCTotal n t')

393 addIBC (IBCTotal n t')

335 return t'

394 return t'

336− -- if it's not total, it can't reduce, to keep

395+ [TyDecl (DCon _ _) ty] ->

337− -- typechecking decidable

396+ case unApply (getRetTy ty) of

338−-- case t' of

397+ (P _ tyn _, _) -> do

339−-- p@(Partial _) ->

398+ let ms = case lookupCtxt tyn (idris_datatypes i) of

340−-- do setAccessibility n Frozen

399+ [TI _ _ _ _ xs@(_:_)] -> xs

341−-- addIBC (IBCAccess n Frozen)

400+ ts -> [tyn]

342−-- logLvl 5 $ "HIDDEN: "

401+ checkPositive ms (n, ty)

343−-- ++ show n ++ show p

344−-- _ -> return ()

402+ _-> return $ Total []

345−-- return t'

346 _ -> return $ Total []

403 _ -> return $ Total []

347 x -> return x

404 x -> return x

348 case t' of

405 case t' of

@@ -350,18 +407,21 @@ checkTotality path fc n

350 Productive -> return t'

407 Productive -> return t'

351 e -> do w <- cmdOptType WarnPartial

408 e -> do w <- cmdOptType WarnPartial

352 if TotalFn `elem` opts

409 if TotalFn `elem` opts

353− then totalityError t'

410+ then do totalityError t'; return t'

354 else do when (w && not (PartialFn `elem` opts)) $

411 else do when (w && not (PartialFn `elem` opts)) $

355 warnPartial n t'

412 warnPartial n t'

356 return t'

413 return t'

357 where

414 where

358− totalityError t = tclift $ tfail (At fc (Msg (show n ++ " is " ++ show t)))

415+ totalityError t = do i <- getIState

416+ let msg = show n ++ " is " ++ show t

417+ putIState i { idris_totcheckfail = (fc, msg) : idris_totcheckfail i}

418+ addIBC (IBCTotCheckErr fc msg)

359

419

360 warnPartial n t

420 warnPartial n t

361 = do i <- getIState

421 = do i <- getIState

362 case lookupDef n (tt_ctxt i) of

422 case lookupDef n (tt_ctxt i) of

363 [x] -> do

423 [x] -> do

364− iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t

424+ iWarn fc . pprintErr i . Msg $ "Warning - " ++ show n ++ " is " ++ show t

365-- ++ "\n" ++ show x

425-- ++ "\n" ++ show x

366-- let cg = lookupCtxtName Nothing n (idris_callgraph i)

426-- let cg = lookupCtxtName Nothing n (idris_callgraph i)

367-- iputStrLn (show cg)

427-- iputStrLn (show cg)

@@ -372,7 +432,11 @@ checkDeclTotality (fc, n)

372 = do logLvl 2 $ "Checking " ++ show n ++ " for totality"

432 = do logLvl 2 $ "Checking " ++ show n ++ " for totality"

373-- buildSCG (fc, n)

433-- buildSCG (fc, n)

374-- logLvl 2 $ "Built SCG"

434-- logLvl 2 $ "Built SCG"

375− i <- getIState

435+ i <- getIState

436+ let opts = case lookupCtxt n (idris_flags i) of

437+ [fs] -> fs

438+ _ -> []

439+ when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n

376 t <- checkTotality [] fc n

440 t <- checkTotality [] fc n

377 case t of

441 case t of

378 -- if it's not total, it can't reduce, to keep

442 -- if it's not total, it can't reduce, to keep

@@ -411,41 +475,57 @@ buildSCG (_, n) = do

411 [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

475 [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

412 x -> error $ "buildSCG: " ++ show (n, x)

476 x -> error $ "buildSCG: " ++ show (n, x)

413

477

478+delazy = delazy' False -- not lazy codata

414−delazy t@(App f a)

479+delazy' all t@(App f a)

415− | (P _ (UN l) _, [_, arg]) <- unApply t,

480+ | (P _ (UN l) _, [_, _, arg]) <- unApply t,

416− l == txt "Force" = delazy arg

481+ l == txt "Force" = delazy' all arg

417− | (P _ (UN l) _, [_, arg]) <- unApply t,

482+ | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,

418− l == txt "Delay" = delazy arg

483+ l == txt "Delay" && (all || lty == txt "LazyEval") = delazy arg

419− | (P _ (UN l) _, [arg]) <- unApply t,

484+ | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,

420− l == txt "Lazy" = delazy arg

485+ l == txt "Lazy'" && (all || lty == txt "LazyEval") = delazy' all arg

421−delazy (App f a) = App (delazy f) (delazy a)

486+delazy' all (App f a) = App (delazy' all f) (delazy' all a)

422−delazy (Bind n b sc) = Bind n (fmap delazy b) (delazy sc)

487+delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc)

423−delazy t = t

488+delazy' all t = t

489+

490+data Guardedness = Toplevel | Unguarded | Guarded

424

491

425buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry]

492buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry]

426buildSCG' ist pats args = nub $ concatMap scgPat pats where

493buildSCG' ist pats args = nub $ concatMap scgPat pats where

427 scgPat (lhs, rhs) = let lhs' = delazy lhs

494 scgPat (lhs, rhs) = let lhs' = delazy lhs

428 rhs' = delazy rhs

495 rhs' = delazy rhs

429 (f, pargs) = unApply (dePat lhs') in

496 (f, pargs) = unApply (dePat lhs') in

430− findCalls (dePat rhs') (patvars lhs') pargs

497+ findCalls Toplevel (dePat rhs') (patvars lhs') pargs

431

498

432− findCalls ap@(App f a) pvs pargs

499+ findCalls guarded ap@(App f a) pvs pargs

433 -- under a call to "assert_total", don't do any checking, just believe

500 -- under a call to "assert_total", don't do any checking, just believe

434 -- that it is total.

501 -- that it is total.

435 | (P _ (UN at) _, [_, _]) <- unApply ap,

502 | (P _ (UN at) _, [_, _]) <- unApply ap,

436 at == txt "assert_total" = []

503 at == txt "assert_total" = []

504+ -- under a call to "Delay LazyCodata", don't do any checking of the

505+ -- immediate call, as long as the call is guarded.

506+ -- Then check its arguments

507+ | (P _ (UN del) _, [_,_,arg]) <- unApply ap,

508+ guarded <- Guarded,

509+ del == txt "Delay"

510+ = let (capp, args) = unApply arg in

511+ concatMap (\x -> findCalls Toplevel x pvs pargs) args

437 | (P _ n _, args) <- unApply ap

512 | (P _ n _, args) <- unApply ap

438− = mkChange n args pargs ++

513+ = let nguarded = case guarded of

514+ Unguarded -> Unguarded

515+ _ -> if isConName n (tt_ctxt ist)

516+ then Guarded

517+ else Unguarded in

518+ mkChange n args pargs ++

439− concatMap (\x -> findCalls x pvs pargs) args

519+ concatMap (\x -> findCalls nguarded x pvs pargs) args

440− findCalls (App f a) pvs pargs

520+ findCalls guarded (App f a) pvs pargs

441− = findCalls f pvs pargs ++ findCalls a pvs pargs

521+ = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs

442− findCalls (Bind n (Let t v) e) pvs pargs

522+ findCalls guarded (Bind n (Let t v) e) pvs pargs

443− = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs

523+ = findCalls Unguarded v pvs pargs ++ findCalls guarded e (n : pvs) pargs

444− findCalls (Bind n _ e) pvs pargs

524+ findCalls guarded (Bind n _ e) pvs pargs

445− = findCalls e (n : pvs) pargs

525+ = findCalls guarded e (n : pvs) pargs

446− findCalls (P _ f _ ) pvs pargs

526+ findCalls guarded (P _ f _ ) pvs pargs

447 | not (f `elem` pvs) = [(f, [])]

527 | not (f `elem` pvs) = [(f, [])]

448− findCalls _ _ _ = []

528+ findCalls _ _ _ _ = []

449

529

450 expandToArity n args

530 expandToArity n args

451 = case lookupTy n (tt_ctxt ist) of

531 = case lookupTy n (tt_ctxt ist) of

@@ -463,7 +543,7 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

463 -- find which argument in pargs <a> is smaller than, if any

543 -- find which argument in pargs <a> is smaller than, if any

464 checkSize a (p : ps) i

544 checkSize a (p : ps) i

465 | a == p = Just (i, Same)

545 | a == p = Just (i, Same)

466− | (P _ (UN as) _, [_,arg,_]) <- unApply a,

546+ | (P _ (UN as) _, [_,_,arg,_]) <- unApply a,

467 as == txt "assert_smaller" && arg == p

547 as == txt "assert_smaller" && arg == p

468 = Just (i, Smaller)

548 = Just (i, Smaller)

469 | smaller Nothing a (p, Nothing) = Just (i, Smaller)

549 | smaller Nothing a (p, Nothing) = Just (i, Smaller)

@@ -493,108 +573,17 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

493

573

494 isInductive (P _ nty _) (P _ nty' _) =

574 isInductive (P _ nty _) (P _ nty' _) =

495 let co = case lookupCtxt nty (idris_datatypes ist) of

575 let co = case lookupCtxt nty (idris_datatypes ist) of

496− [TI _ x _ _] -> x

576+ [TI _ x _ _ _] -> x

497 _ -> False in

577 _ -> False in

498 nty == nty' && not co

578 nty == nty' && not co

499 isInductive _ _ = False

579 isInductive _ _ = False

500

580

501−-- getTypeFam t | (P _ n _, _) <- unApply t

502−

503 dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)

581 dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)

504 dePat t = t

582 dePat t = t

505

583

506 patvars (Bind x (PVar _) sc) = x : patvars sc

584 patvars (Bind x (PVar _) sc) = x : patvars sc

507 patvars _ = []

585 patvars _ = []

508

586

509−{-

510−buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]

511−buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

512− nub $ scg sc (zip args args)

513− (zip args (zip args (repeat Same)))

514− where

515− scg :: SC -> [(Name, Name)] -> -- local var, originating top level var

516− [(Name, (Name, SizeChange))] -> -- orig to new, and relationship

517− [SCGEntry]

518− scg (Case x alts) vars szs

519− = let x' = findTL x vars in

520− concatMap (scgAlt x' vars szs) alts

521− where

522− findTL x vars

523− | Just x' <- lookup x vars

524− = if x' `elem` args then x'

525− else findTL x' vars

526− | otherwise = x

527−

528− scg (STerm tm) vars szs = scgTerm tm vars szs

529− scg _ _ _ = []

530−

531− -- how the arguments relate - either Smaller or Unknown

532− argRels :: Name -> [(Name, SizeChange)]

533− argRels n = let ctxt = tt_ctxt ist

534− [ty] = lookupTy n ctxt -- must exist!

535− P _ nty _ = fst (unApply (getRetTy ty))

536− co = case lookupCtxt nty (idris_datatypes ist) of

537− [TI _ x _ _] -> x

538− _ -> False

539− args = map snd (getArgTys ty) in

540− map (getRel co nty) (map (fst . unApply . getRetTy) args)

541− where

542− getRel True _ _ = (n, Unknown) -- coinductive

543− getRel _ ty (P _ n' _) | n' == ty = (n, Smaller)

544− getRel _ ty t = (n, Unknown)

545−

546− scgAlt x vars szs (ConCase n _ args sc)

547− -- all args smaller than top variable of x in sc

548− -- (as long as they are in the same type family, and it's

549− -- not coinductive)

550− | Just tvar <- lookup x vars

551− = let arel = argRels n

552− szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel

553− ++ szs

554− vars' = nub (zip args (repeat tvar) ++ vars) in

555− scg sc vars' szs'

556− | otherwise = scg sc vars szs

557− scgAlt x vars szs (ConstCase _ sc) = scg sc vars szs

558− scgAlt x vars szs (DefaultCase sc) = scg sc vars szs

559−

560− scgTerm f@(App _ _) vars szs

561− | (P _ (UN "lazy") _, [_, arg]) <- unApply f

562− = scgTerm arg vars szs

563− | (P _ fn _, args) <- unApply f

564− = let rest = concatMap (\x -> scgTerm x vars szs) args in

565− case lookup fn vars of

566− Just _ -> rest

567− Nothing -> nub $ (fn, map (mkChange szs) args) : rest

568− scgTerm (App f a) vars szs

569− = scgTerm f vars szs ++ scgTerm a vars szs

570− scgTerm (Bind n (Let t v) e) vars szs

571− = scgTerm v vars szs ++ scgTerm e vars szs

572− scgTerm (Bind n _ e) vars szs

573− = scgTerm e (nub ((n, n) : vars)) szs

574− scgTerm (P _ fn _) vars szs

575− = case lookup fn vars of

576− Just _ -> []

577− Nothing -> [(fn, [])]

578− scgTerm _ _ _ = []

579−

580− mkChange :: [(Name, (Name, SizeChange))] -> Term

581− -> Maybe (Int, SizeChange)

582− mkChange szs tm

583− | (P _ (UN "lazy") _, [_, arg]) <- unApply tm = mkChange szs arg

584− | (P _ n ty, _) <- unApply tm -- get higher order args too

585− = do sc <- lookup n szs

586− case sc of

587− (_, Unknown) -> Nothing

588− (o, sc) -> do i <- getArgPos 0 o args

589− return (i, sc)

590− mkChange _ _ = Nothing

591−

592− getArgPos :: Int -> Name -> [Name] -> Maybe Int

593− getArgPos i n [] = Nothing

594− getArgPos i n (x : xs) | n == x = Just i

595− | otherwise = getArgPos (i + 1) n xs

596−-}

597−

598checkSizeChange :: Name -> Idris Totality

587checkSizeChange :: Name -> Idris Totality

599checkSizeChange n = do

588checkSizeChange n = do

600 ist <- getIState

589 ist <- getIState

@@ -667,7 +656,7 @@ checkMP ist i mp = if i > 0

667 = case lookupTotal f (tt_ctxt ist) of

656 = case lookupTotal f (tt_ctxt ist) of

668 [Total _] -> Unchecked -- okay so far

657 [Total _] -> Unchecked -- okay so far

669 [Partial _] -> Partial (Other [f])

658 [Partial _] -> Partial (Other [f])

670− x -> error (show x)

659+ x -> error $ "CAN'T HAPPEN: " ++ (show x)

671 | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)

660 | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)

672 = Total []

661 = Total []

673 tryPath desc path (e@(f, args) : es) arg

662 tryPath desc path (e@(f, args) : es) arg

src/Idris/DSL.hs+2−2

@@ -57,10 +57,10 @@ expandDo dsl (PDoBlock ds)

57 block b [a] = PElabError (Msg "Last statement in do block must be an expression")

58 block b (DoBind fc n tm : rest)

59 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

60− block b (DoBindP fc p tm : rest)

60+ block b (DoBindP fc p tm alts : rest)

61 = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder

62 (PCase fc (PRef fc (sMN 0 "bpat"))

63− [(p, block b rest)]))]

63+ ((p, block b rest) : alts)))]

64 block b (DoLet fc n ty tm : rest)

65 = PLet n ty tm (block b rest)

66 block b (DoLetP fc p tm : rest)

src/Idris/DataOpts.hs+14−231

@@ -9,224 +9,48 @@ import Idris.AbsSyntaxTree

9import Idris.Core.TT

10

11import Control.Applicative

12−import qualified Data.IntMap as M

13import Data.List

12import Data.List

14import Data.Maybe

13import Data.Maybe

15import Debug.Trace

14import Debug.Trace

16

15

17−type ForceMap = M.IntMap Forceability

18−

19−-- Calculate the forceable arguments to a constructor

20−-- and update the set of optimisations.

21−forceArgs :: Name -> Name -> [Int] -> Type -> Idris ()

22−forceArgs typeName n expforce t = do

23− ist <- getIState

24− let fargs = getForcedArgs ist typeName t

25− copt = case lookupCtxt n (idris_optimisation ist) of

26− [] -> Optimise False False [] []

27− op:_ -> op

28− opts = addDef n (copt { forceable = M.toList fargs ++

29− zip expforce (repeat Unconditional) })

30− (idris_optimisation ist)

31− putIState (ist { idris_optimisation = opts })

32− addIBC (IBCOpt n)

33− iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t

34−

35−getForcedArgs :: IState -> Name -> Type -> ForceMap

36−getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

37− where

38− maxUnion = M.unionWith max

39−

40− -- Label all occurrences of the variable bound in Pi in the rest of

41− -- the term with the number i so that we can recognize them anytime later.

42− label i = instantiate $ P Bound (sMN i "ctor_arg") Erased

43−

44− addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap

45− addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable

46− = addCollapsibleArgs (i+1) (label i rest) (forceable $ unApply ty)

47− where

48− -- forceable takes an un-applied type of a ctor argument

49− forceable (P _ tn _, args)

50− -- if `ty' is collapsible, the argument is unconditionally forceable

51− | isCollapsible tn

52− = M.insert i Unconditional alreadyForceable

53−

54− -- a recursive occurrence with known indices is conditionally forceable

55− | tn == typeName

56− = M.insertWith max i Conditional alreadyForceable

57−

58− forceable _ = alreadyForceable

59−

60− isCollapsible :: Name -> Bool

61− isCollapsible n = case lookupCtxt n (idris_optimisation ist) of

62− [oi] -> collapsible oi

63− _ -> False

64−

65− addCollapsibleArgs _ _ fs = fs

66−

67− forcedInTarget :: Int -> Type -> ForceMap

68− forcedInTarget i (Bind _ (Pi _) rest) = forcedInTarget (i+1) (label i rest)

69− forcedInTarget i t@(App f a) | (_, as) <- unApply t = unionMap guardedArgs as

70− forcedInTarget _ _ = M.empty

71−

72− guardedArgs :: Term -> ForceMap

73− guardedArgs t@(App f a) | (P (DCon _ _) _ _, args) <- unApply t

74− = unionMap bareArg args `maxUnion` unionMap guardedArgs args

75− guardedArgs t = bareArg t

76−

77− bareArg :: Term -> ForceMap

78− bareArg (P _ (MN i ctor_arg) _)

79− | ctor_arg == txt "ctor_arg" = M.singleton i Unconditional

80− bareArg _ = M.empty

81−

82− unionMap :: (a -> ForceMap) -> [a] -> ForceMap

83− unionMap f = M.unionsWith max . map f

84−

85−-- Calculate whether a collection of constructors is collapsible

86−-- and update the state accordingly.

87−collapseCons :: Name -> [(Name, Type)] -> Idris ()

88−collapseCons tn ctors = do

89− ist <- getIState

90− case ctors of

91− _

92− | all (ctorCollapsible ist) ctors

93− , disjointTerms ctorTargetArgs

94− -> mapM_ setCollapsible (tn : map fst ctors)

95−

96− [(cn, ct)]

97− -> checkNewType ist cn ct

98−

99− _ -> return () -- nothing can be done

100− where

101− ctorTargetArgs = map (snd . unApply . getRetTy . snd) ctors

102−

103− ctorArity :: Type -> Int

104− ctorArity = length . getArgTys

105−

106− ctorCollapsible :: IState -> (Name, Type) -> Bool

107− ctorCollapsible ist (n, t) = all (`M.member` forceMap) [0 .. ctorArity t - 1]

108− where

109− forceMap = case lookupCtxt n (idris_optimisation ist) of

110− oi:_ -> M.fromList $ forceable oi

111− _ -> M.empty

112−

113− -- one constructor; if one remaining argument, treat as newtype

114− checkNewType :: IState -> Name -> Type -> Idris ()

115− checkNewType ist cn ct

116− | oi:_ <- lookupCtxt cn opt

117− , length (getArgTys ct) == 1 + forcedCnt (M.fromList $ forceable oi)

118− = putIState ist{ idris_optimisation = opt' oi }

119− | otherwise = return ()

120− where

121− opt = idris_optimisation ist

122− opt' oi = addDef cn oi{ isnewtype = True } opt

123−

124− setCollapsible :: Name -> Idris ()

125− setCollapsible n

126− = do i <- getIState

127− iLOG $ show n ++ " collapsible"

128− case lookupCtxt n (idris_optimisation i) of

129− (oi:_) -> do let oi' = oi { collapsible = True }

130− let opts = addDef n oi' (idris_optimisation i)

131− putIState (i { idris_optimisation = opts })

132− [] -> do let oi = Optimise True False [] []

133− let opts = addDef n oi (idris_optimisation i)

134− putIState (i { idris_optimisation = opts })

135− addIBC (IBCOpt n)

136−

137− disjointTerms :: [[Term]] -> Bool

138− disjointTerms [] = True

139− disjointTerms [xs] = True

140− disjointTerms (xs : xss) =

141− -- xs is disjoint with every pattern from xss

142− all (or . zipWith disjoint xs) xss

143− -- and xss is pairwise disjoint, too

144− && disjointTerms xss

145−

146− -- Return True if the two patterns are provably disjoint.

147− -- Return False if they're not or if unsure.

148− disjoint :: Term -> Term -> Bool

149− disjoint x y = case (cx, cy) of

150− -- data constructors -> compare their names

151− (P (DCon _ _) nx _, P (DCon _ _) ny _)

152− | nx /= ny -> True

153− | otherwise -> or $ zipWith disjoint xargs yargs

154− _ -> False

155− where

156− (cx, xargs) = unApply x

157− (cy, yargs) = unApply y

158−

159class Optimisable term where

16class Optimisable term where

160 applyOpts :: term -> Idris term

17 applyOpts :: term -> Idris term

161− stripCollapsed :: term -> Idris term

162

18

163instance (Optimisable a, Optimisable b) => Optimisable (a, b) where

19instance (Optimisable a, Optimisable b) => Optimisable (a, b) where

164 applyOpts (x, y) = (,) <$> applyOpts x <*> applyOpts y

20 applyOpts (x, y) = (,) <$> applyOpts x <*> applyOpts y

165− stripCollapsed (x, y) = (,) <$> stripCollapsed x <*> stripCollapsed y

166

21

167instance (Optimisable a, Optimisable b) => Optimisable (vs, a, b) where

22instance (Optimisable a, Optimisable b) => Optimisable (vs, a, b) where

168 applyOpts (v, x, y) = (,,) v <$> applyOpts x <*> applyOpts y

23 applyOpts (v, x, y) = (,,) v <$> applyOpts x <*> applyOpts y

169− stripCollapsed (v, x, y) = (,,) v <$> stripCollapsed x <*> stripCollapsed y

170

24

171instance Optimisable a => Optimisable [a] where

25instance Optimisable a => Optimisable [a] where

172 applyOpts = mapM applyOpts

26 applyOpts = mapM applyOpts

173− stripCollapsed = mapM stripCollapsed

174

27

175instance Optimisable a => Optimisable (Either a (a, a)) where

28instance Optimisable a => Optimisable (Either a (a, a)) where

176 applyOpts (Left t) = Left <$> applyOpts t

29 applyOpts (Left t) = Left <$> applyOpts t

177 applyOpts (Right t) = Right <$> applyOpts t

30 applyOpts (Right t) = Right <$> applyOpts t

178− stripCollapsed (Left t) = Left <$> stripCollapsed t

179− stripCollapsed (Right t) = Right <$> stripCollapsed t

180

31

181-- Raw is for compile time optimisation (before type checking)

32-- Raw is for compile time optimisation (before type checking)

182-- Term is for run time optimisation (after type checking, collapsing allowed)

33-- Term is for run time optimisation (after type checking, collapsing allowed)

183−

184-- Compile time: no collapsing

34-- Compile time: no collapsing

185

35

186instance Optimisable Raw where

36instance Optimisable Raw where

187 applyOpts t@(RApp f a)

37 applyOpts t@(RApp f a)

188 | (Var n, args) <- raw_unapply t -- MAGIC HERE

38 | (Var n, args) <- raw_unapply t -- MAGIC HERE

189− = do args' <- mapM applyOpts args

39+ = raw_apply (Var n) <$> mapM applyOpts args

190− i <- getIState

191− return $ case lookupCtxt n (idris_optimisation i) of

192− oi:_ -> applyDataOpt oi n args'

193− _ -> raw_apply (Var n) args'

194 | otherwise = RApp <$> applyOpts f <*> applyOpts a

40 | otherwise = RApp <$> applyOpts f <*> applyOpts a

195

41

196 applyOpts (RBind n b t) = RBind n <$> applyOpts b <*> applyOpts t

42 applyOpts (RBind n b t) = RBind n <$> applyOpts b <*> applyOpts t

197 applyOpts (RForce t) = applyOpts t

43 applyOpts (RForce t) = applyOpts t

198 applyOpts t = return t

44 applyOpts t = return t

199

45

200− stripCollapsed t = return t

201−

202-- Erase types (makes ibc smaller, and we don't need them)

46-- Erase types (makes ibc smaller, and we don't need them)

203instance Optimisable (Binder (TT Name)) where

47instance Optimisable (Binder (TT Name)) where

204 applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v

48 applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v

205 applyOpts b = return (b { binderTy = Erased })

49 applyOpts b = return (b { binderTy = Erased })

206− stripCollapsed (Let t v) = Let <$> return Erased <*> stripCollapsed v

207− stripCollapsed b = return (b { binderTy = Erased })

208

50

209instance Optimisable (Binder Raw) where

51instance Optimisable (Binder Raw) where

210 applyOpts b = do t' <- applyOpts (binderTy b)

52 applyOpts b = do t' <- applyOpts (binderTy b)

211 return (b { binderTy = t' })

53 return (b { binderTy = t' })

212− stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v

213− stripCollapsed b = do t' <- stripCollapsed (binderTy b)

214− return (b { binderTy = t' })

215−

216−forcedArgSeq :: OptInfo -> [Maybe Forceability]

217−forcedArgSeq oi = map (\i -> M.lookup i forceMap) [0..]

218− where

219− forceMap = M.fromList $ forceable oi

220−

221−forcedCnt :: ForceMap -> Int

222−forcedCnt = length . filter (== Unconditional) . M.elems

223−

224−applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw

225−applyDataOpt oi n args

226− = raw_apply (Var n) $ zipWith doForce (forcedArgSeq oi) args

227− where

228− doForce (Just Unconditional) a = RForce a

229− doForce _ a = a

230

54

231-- Run-time: do everything

55-- Run-time: do everything

232

56

@@ -249,54 +73,22 @@ instance Optimisable (TT Name) where

249 | fn == txt "toIntegerNat" && mod == prel

73 | fn == txt "toIntegerNat" && mod == prel

250 = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

74 = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

251 applyOpts c@(P (DCon t arity) n _)

75 applyOpts c@(P (DCon t arity) n _)

252− = do i <- getIState

253− case lookupCtxt n (idris_optimisation i) of

254− (oi:_) -> return $ applyDataOptRT oi n t arity []

76+ = return $ applyDataOptRT n t arity []

255− _ -> return c

256 applyOpts t@(App f a)

77 applyOpts t@(App f a)

257 | (c@(P (DCon t arity) n _), args) <- unApply t

78 | (c@(P (DCon t arity) n _), args) <- unApply t

258− = do args' <- mapM applyOpts args

259− i <- getIState

260− case lookupCtxt n (idris_optimisation i) of

261− (oi:_) -> do return $ applyDataOptRT oi n t arity args'

79+ = applyDataOptRT n t arity <$> mapM applyOpts args

262− _ -> return (mkApp c args')

80+ | otherwise = App <$> applyOpts f <*> applyOpts a

263− | otherwise = do f' <- applyOpts f

264− a' <- applyOpts a

265− return (App f' a')

266− applyOpts (Bind n b t) = do b' <- applyOpts b

81+ applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t

267− t' <- applyOpts t

268− return (Bind n b' t')

269− applyOpts (Proj t i) = do t' <- applyOpts t

82+ applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i

270− return (Proj t' i)

271 applyOpts t = return t

83 applyOpts t = return t

272

84

273− stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x

274− = do i <- getIState

275− -- NOTE: This assumes that 'ty' is in normal form, which it

276− -- has to be before now because we're not keeping track of

277− -- an environment so we can't do it here.

278− case lookupCtxt ty (idris_optimisation i) of

279− [oi] -> if collapsible oi

280− then do t' <- stripCollapsed t

281− return (Bind n (PVar x) (instantiate Erased t'))

282− else do t' <- stripCollapsed t

283− return (Bind n (PVar x) t')

284− _ -> do t' <- stripCollapsed t

285− return (Bind n (PVar x) t')

286− stripCollapsed (Bind n (PVar x) t)

287− = do t' <- stripCollapsed t

288− return (Bind n (PVar x) t')

289− stripCollapsed t = return t

290−

291−-- Need to saturate arguments first to ensure that erasure happens uniformly

85+-- Need to saturate arguments first to ensure that optimisation happens uniformly

292−

293−applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term

86+applyDataOptRT :: Name -> Int -> Int -> [Term] -> Term

294−applyDataOptRT oi n tag arity args

87+applyDataOptRT n tag arity args

295− | length args == arity = doOpts n args (collapsible oi) (M.fromList $ forceable oi)

88+ | length args == arity = doOpts n args

296 | otherwise = let extra = satArgs (arity - length args)

89 | otherwise = let extra = satArgs (arity - length args)

297 tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra)

90 tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra)

298− (collapsible oi) (M.fromList $ forceable oi) in

299− bind extra tm

91+ in bind extra tm

300 where

92 where

301 satArgs n = map (\i -> sMN i "sat") [1..n]

93 satArgs n = map (\i -> sMN i "sat") [1..n]

302

94

@@ -305,20 +97,11 @@ applyDataOptRT oi n tag arity args

305

97

306 -- Nat special cases

98 -- Nat special cases

307 -- TODO: Would be nice if this was configurable in idris source!

99 -- TODO: Would be nice if this was configurable in idris source!

308− doOpts (NS (UN z) [nat, prelude]) [] _ _

100+ doOpts (NS (UN z) [nat, prelude]) []

309 | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

101 | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

310 = Constant (BI 0)

102 = Constant (BI 0)

311− doOpts (NS (UN s) [nat, prelude]) [k] _ _

103+ doOpts (NS (UN s) [nat, prelude]) [k]

312 | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

104 | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

313 = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

105 = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

314

106

315− doOpts n args True _ = Erased

316− doOpts n args _ forceMap

317− | isnewtype oi = case args' of

318− [val] -> val

319− _ -> error $ "Can't happen (newtype not a singleton): " ++ show args'

320− | otherwise = mkApp ctor' args'

321− where

322− ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)

107+ doOpts n args = mkApp (P (DCon tag arity) n Erased) args

323− args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]

324−

src/Idris/DeepSeq.hs+75−38

@@ -6,11 +6,49 @@ import Idris.AbsSyntaxTree

6

7import Control.DeepSeq

8

9−-- All generated by 'derive'

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 = ()

10

50

11−instance NFData Forceability where

51+-- All generated by 'derive'

12− rnf Conditional = ()

13− rnf Unconditional = ()

14

52

15instance NFData IntTy where

53instance NFData IntTy where

16 rnf (ITFixed x1) = rnf x1 `seq` ()

54 rnf (ITFixed x1) = rnf x1 `seq` ()

@@ -57,14 +95,14 @@ instance NFData ArgOpt where

57 rnf _ = ()

95 rnf _ = ()

58

96

59instance NFData Plicity where

97instance NFData Plicity where

60− rnf (Imp x1 x2 x3 x4)

98+ rnf (Imp x1 x2 x3)

61− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

99+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

62− rnf (Exp x1 x2 x3 x4)

100+ rnf (Exp x1 x2 x3)

63− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

101+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

64− rnf (Constraint x1 x2 x3)

102+ rnf (Constraint x1 x2)

103+ = rnf x1 `seq` rnf x2 `seq` ()

104+ rnf (TacImp x1 x2 x3)

65 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

105 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

66− rnf (TacImp x1 x2 x3 x4)

67− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

68

106

69instance NFData FnOpt where

107instance NFData FnOpt where

70 rnf Inlinable = ()

108 rnf Inlinable = ()

@@ -84,29 +122,31 @@ instance NFData DataOpt where

84

122

85instance (NFData t) => NFData (PDecl' t) where

123instance (NFData t) => NFData (PDecl' t) where

86 rnf (PFix x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

124 rnf (PFix x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

87− rnf (PTy x1 x2 x3 x4 x5 x6)

125+ rnf (PTy x1 x2 x3 x4 x5 x6 x7)

88 = rnf x1 `seq`

126 = rnf x1 `seq`

127+ rnf x2 `seq`

89− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

128+ rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()

90 rnf (PPostulate x1 x2 x3 x4 x5 x6)

129 rnf (PPostulate x1 x2 x3 x4 x5 x6)

91 = rnf x1 `seq`

130 = rnf x1 `seq`

92 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

131 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

93 rnf (PClauses x1 x2 x3 x4)

132 rnf (PClauses x1 x2 x3 x4)

94 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

133 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

95 rnf (PCAF x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

134 rnf (PCAF x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

96− rnf (PData x1 x2 x3 x4 x5)

135+ rnf (PData x1 x2 x3 x4 x5 x6)

97 = rnf x1 `seq`

136 = rnf x1 `seq`

137+ rnf x2 `seq`

98− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

138+ rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

99 rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

139 rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

100 rnf (PNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

140 rnf (PNamespace x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

101− rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8)

141+ rnf (PRecord x1 x2 x3 x4 x5 x6 x7 x8 x9)

102 = rnf x1 `seq`

142 = rnf x1 `seq`

103 rnf x2 `seq`

143 rnf x2 `seq`

104 rnf x3 `seq`

144 rnf x3 `seq`

105− rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()

145+ rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` ()

106− rnf (PClass x1 x2 x3 x4 x5 x6 x7)

146+ rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7)

107 = rnf x1 `seq`

147 = rnf x1 `seq`

108 rnf x2 `seq`

148 rnf x2 `seq`

109− rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()

149+ rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()

110 rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8)

150 rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8)

111 = rnf x1 `seq`

151 = rnf x1 `seq`

112 rnf x2 `seq`

152 rnf x2 `seq`

@@ -116,16 +156,14 @@ instance (NFData t) => NFData (PDecl' t) where

116 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

156 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

117 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

157 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

118 rnf (PDirective x1) = ()

158 rnf (PDirective x1) = ()

119− rnf (PProvider x1 x2 x3 x4 x5 x6)

159+ rnf (PProvider x1 x2 x3 x4)

120− = rnf x1 `seq`

121− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

160+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

122 rnf (PTransform x1 x2 x3 x4)

161 rnf (PTransform x1 x2 x3 x4)

123 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

162 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

124

163

125−instance NFData ProvideWhat where

164+instance NFData t => NFData (ProvideWhat' t) where

126− rnf ProvAny = ()

165+ rnf (ProvTerm ty tm) = rnf ty `seq` rnf tm `seq` ()

127− rnf ProvTerm = ()

128− rnf ProvPostulate = ()

166+ rnf (ProvPostulate tm) = rnf tm `seq` ()

129

167

130instance NFData PunInfo where

168instance NFData PunInfo where

131 rnf x = x `seq` ()

169 rnf x = x `seq` ()

@@ -205,7 +243,7 @@ instance (NFData t) => NFData (PTactic' t) where

205 rnf (Exact x1) = rnf x1 `seq` ()

243 rnf (Exact x1) = rnf x1 `seq` ()

206 rnf Compute = ()

244 rnf Compute = ()

207 rnf Trivial = ()

245 rnf Trivial = ()

208− rnf (ProofSearch x1 x2)

246+ rnf (ProofSearch r r1 r2 x1 x2)

209 = rnf x1 `seq` rnf x2 `seq` ()

247 = rnf x1 `seq` rnf x2 `seq` ()

210 rnf Solve = ()

248 rnf Solve = ()

211 rnf Attack = ()

249 rnf Attack = ()

@@ -224,22 +262,21 @@ instance (NFData t) => NFData (PTactic' t) where

224instance (NFData t) => NFData (PDo' t) where

262instance (NFData t) => NFData (PDo' t) where

225 rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

263 rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

226 rnf (DoBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

264 rnf (DoBind x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

227− rnf (DoBindP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

265+ rnf (DoBindP x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

228 rnf (DoLet x1 x2 x3 x4)

266 rnf (DoLet x1 x2 x3 x4)

229 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

267 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

230 rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

268 rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

231

269

232instance (NFData t) => NFData (PArg' t) where

270instance (NFData t) => NFData (PArg' t) where

233− rnf (PImp x1 x2 x3 x4 x5 x6)

271+ rnf (PImp x1 x2 x3 x4 x5)

234− = rnf x1 `seq`

235− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

272+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

236 rnf (PExp x1 x2 x3 x4)

273 rnf (PExp x1 x2 x3 x4)

237 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

274 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

238 rnf (PConstraint x1 x2 x3 x4)

275 rnf (PConstraint x1 x2 x3 x4)

239 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

276 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

240− rnf (PTacImplicit x1 x2 x3 x4 x5 x6)

277+ rnf (PTacImplicit x1 x2 x3 x4 x5)

241 = rnf x1 `seq`

278 = rnf x1 `seq`

242− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

279+ rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

243

280

244instance NFData ClassInfo where

281instance NFData ClassInfo where

245 rnf (CI x1 x2 x3 x4 x5 x6)

282 rnf (CI x1 x2 x3 x4 x5 x6)

@@ -247,11 +284,11 @@ instance NFData ClassInfo where

247 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

284 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

248

285

249instance NFData OptInfo where

286instance NFData OptInfo where

250− rnf (Optimise x1 x2 x3 x4)

287+ rnf (Optimise x1 x2)

251− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

288+ = rnf x1 `seq` rnf x2 `seq` ()

252

289

253instance NFData TypeInfo where

290instance NFData TypeInfo where

254− rnf (TI x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

291+ rnf (TI x1 x2 x3 x4 x5) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

255

292

256instance (NFData t) => NFData (DSL' t) where

293instance (NFData t) => NFData (DSL' t) where

257 rnf (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9)

294 rnf (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9)

@@ -282,11 +319,11 @@ instance NFData Using where

282

319

283

320

284instance NFData SyntaxInfo where

321instance NFData SyntaxInfo where

285− rnf (Syn x1 x2 x3 x4 x5 x6 x7 x8)

322+ rnf (Syn x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)

286 = rnf x1 `seq`

323 = rnf x1 `seq`

287 rnf x2 `seq`

324 rnf x2 `seq`

288 rnf x3 `seq`

325 rnf x3 `seq`

289− rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()

326+ rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` ()

290

327

291

328

292

329

src/Idris/Delaborate.hs+83−32

@@ -1,6 +1,5 @@

1{-# LANGUAGE PatternGuards #-}

2−

3−module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', pshow, pprintErr) where

2+module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', fancifyAnnots, pprintErr) where

4

3

5-- Convert core TT back into high level syntax, primarily for display

4-- Convert core TT back into high level syntax, primarily for display

6-- purposes.

5-- purposes.

@@ -10,9 +9,11 @@ import Util.Pretty

10import Idris.AbsSyntax

9import Idris.AbsSyntax

11import Idris.Core.TT

10import Idris.Core.TT

12import Idris.Core.Evaluate

11import Idris.Core.Evaluate

12+import Idris.Docstrings (overview, renderDocstring)

13import Idris.ErrReverse

14

15import Data.List (intersperse)

16+import qualified Data.Text as T

16

17

17import Debug.Trace

18import Debug.Trace

18

19

@@ -56,19 +57,24 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

56 _ -> PRef un n

57 _ -> PRef un n

57 de env _ (Bind n (Lam ty) sc)

58 de env _ (Bind n (Lam ty) sc)

58 = PLam n (de env [] ty) (de ((n,n):env) [] sc)

59 = PLam n (de env [] ty) (de ((n,n):env) [] sc)

59− de env (PImp _ _ _ _ _ _:is) (Bind n (Pi ty) sc)

60+ de env ((PImp { argopts = opts }):is) (Bind n (Pi ty) sc)

60− = PPi impl n (de env [] ty) (de ((n,n):env) is sc)

61+ = PPi (Imp opts Dynamic False) n (de env [] ty) (de ((n,n):env) is sc)

61 de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc)

62 de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc)

62 = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)

63 = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)

63− de env (PTacImplicit _ _ _ tac _ _:is) (Bind n (Pi ty) sc)

64+ de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi ty) sc)

64 = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)

65 = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)

66+ de env (plic:is) (Bind n (Pi ty) sc)

67+ = PPi (Exp (argopts plic) Dynamic False)

68+ n

69+ (de env [] ty)

70+ (de ((n,n):env) is sc)

65− de env _ (Bind n (Pi ty) sc)

71+ de env [] (Bind n (Pi ty) sc)

66 = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

72 = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

67 de env _ (Bind n (Let ty val) sc)

73 de env _ (Bind n (Let ty val) sc)

68 = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

74 = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

69 de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc

75 de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc

70 de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc

76 de env _ (Bind n (Guess ty val) sc) = de ((n, sUN "[__]"):env) [] sc

71− de env _ (Bind n _ sc) = de ((n,n):env) [] sc

77+ de env plic (Bind n bb sc) = de ((n,n):env) [] sc

72 de env _ (Constant i) = PConstant i

78 de env _ (Constant i) = PConstant i

73 de env _ Erased = Placeholder

79 de env _ Erased = Placeholder

74 de env _ Impossible = Placeholder

80 de env _ Impossible = Placeholder

@@ -87,19 +93,22 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

87 | n == eqCon = PRefl un (de env [] r)

93 | n == eqCon = PRefl un (de env [] r)

88 | n == sUN "lazy" = de env [] r

94 | n == sUN "lazy" = de env [] r

89 deFn env (P _ n _) [ty, Bind x (Lam _) r]

95 deFn env (P _ n _) [ty, Bind x (Lam _) r]

90− | n == sUN "Exists"

96+ | n == sUN "Sigma"

91 = PDPair un IsType (PRef un x) (de env [] ty)

97 = PDPair un IsType (PRef un x) (de env [] ty)

92 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

98 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

93 deFn env (P _ n _) [_,_,l,r]

99 deFn env (P _ n _) [_,_,l,r]

94 | n == pairCon = PPair un IsTerm (de env [] l) (de env [] r)

100 | n == pairCon = PPair un IsTerm (de env [] l) (de env [] r)

95 | n == eqTy = PEq un (de env [] l) (de env [] r)

101 | n == eqTy = PEq un (de env [] l) (de env [] r)

96− | n == sUN "Ex_intro" = PDPair un IsTerm (de env [] l) Placeholder

102+ | n == sUN "Sg_intro" = PDPair un IsTerm (de env [] l) Placeholder

97 (de env [] r)

103 (de env [] r)

98− deFn env (P _ n _) args | not mvs

104+ deFn env f@(P _ n _) args

105+ | n `elem` map snd env

106+ = PApp un (de env [] f) (map pexp (map (de env []) args))

107+ deFn env (P _ n _) args

99− = case lookup n (idris_metavars ist) of

108+ | not mvs = case lookup n (idris_metavars ist) of

100− Just (Just _, mi, _) ->

109+ Just (Just _, mi, _) ->

101− mkMVApp n (drop mi (map (de env []) args))

110+ mkMVApp n (drop mi (map (de env []) args))

102− _ -> mkPApp n (map (de env []) args)

111+ _ -> mkPApp n (map (de env []) args)

103 | otherwise = mkPApp n (map (de env []) args)

112 | otherwise = mkPApp n (map (de env []) args)

104 deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args))

113 deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args))

105

114

@@ -108,14 +117,14 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

108 mkMVApp n args

117 mkMVApp n args

109 = PApp un (PMetavar n) (map pexp args)

118 = PApp un (PMetavar n) (map pexp args)

110 mkPApp n args

119 mkPApp n args

111− | [imps] <- lookupCtxt n (idris_implicits ist)

120+ | Just imps <- lookupCtxtExact n (idris_implicits ist)

112 = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)

121 = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)

113 | otherwise = PApp un (PRef un n) (map pexp args)

122 | otherwise = PApp un (PRef un n) (map pexp args)

114

123

115− imp (PImp p m l n _ d) arg = PImp p m l n arg d

124+ imp (PImp p m l n _) arg = PImp p m l n arg

116− imp (PExp p l _ d) arg = PExp p l arg d

125+ imp (PExp p l n _) arg = PExp p l n arg

117− imp (PConstraint p l _ d) arg = PConstraint p l arg d

126+ imp (PConstraint p l n _) arg = PConstraint p l n arg

118− imp (PTacImplicit p l n sc _ d) arg = PTacImplicit p l n sc arg d

127+ imp (PTacImplicit p l n sc _) arg = PTacImplicit p l n sc arg

119

128

120-- | How far to indent sub-errors

129-- | How far to indent sub-errors

121errorIndent :: Int

130errorIndent :: Int

@@ -130,12 +139,7 @@ pprintTerm :: IState -> PTerm -> Doc OutputAnnotation

130pprintTerm ist = pprintTerm' ist []

139pprintTerm ist = pprintTerm' ist []

131

140

132pprintTerm' :: IState -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

141pprintTerm' :: IState -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

133−pprintTerm' ist = pprintPTerm (opt_showimp (idris_options ist))

142+pprintTerm' ist bnd tm = pprintPTerm (ppOptionIst ist) bnd [] (idris_infixes ist) tm

134−

135−pshow :: IState -> Err -> String

136−pshow ist err = displayDecorated (consoleDecorate ist) .

137− renderPretty 1.0 80 .

138− fmap (fancifyAnnots ist) $ pprintErr ist err

139

143

140pprintErr :: IState -> Err -> Doc OutputAnnotation

144pprintErr :: IState -> Err -> Doc OutputAnnotation

141pprintErr i err = pprintErr' i (fmap (errReverse i) err)

145pprintErr i err = pprintErr' i (fmap (errReverse i) err)

@@ -192,7 +196,7 @@ pprintErr' i (NotInjective p x y) =

192 pprintTerm i (delab i y)

196 pprintTerm i (delab i y)

193pprintErr' i (CantResolve c) = text "Can't resolve type class" <+> pprintTerm i (delab i c)

197pprintErr' i (CantResolve c) = text "Can't resolve type class" <+> pprintTerm i (delab i c)

194pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+>

198pprintErr' i (CantResolveAlts as) = text "Can't disambiguate name:" <+>

195− cat (punctuate (comma <> space) (map text as))

199+ align (cat (punctuate (comma <> space) (map (fmap (fancifyAnnots i) . annName) as)))

196pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n

200pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n

197pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n

201pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n

198pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> pprintTerm i (delab i t)

202pprintErr' i (IncompleteTerm t) = text "Incomplete term" <+> pprintTerm i (delab i t)

@@ -209,16 +213,33 @@ pprintErr' i (At f e) = annotate (AnnFC f) (text (show f)) <> colon <> pprintErr

209pprintErr' i (Elaborating s n e) = text "When elaborating" <+> text s <>

213pprintErr' i (Elaborating s n e) = text "When elaborating" <+> text s <>

210 annName' n (showqual i n) <> colon <$>

214 annName' n (showqual i n) <> colon <$>

211 pprintErr' i e

215 pprintErr' i e

216+pprintErr' i (ElaboratingArg f x _ e)

217+ | isUN x =

218+ text "When elaborating argument" <+>

219+ annotate (AnnBoundName x False) (text (showbasic x)) <+> --TODO check plicity

220+ text "to" <+> whatIsName <> annName f <> colon <>

221+ indented (pprintErr' i e)

222+ | otherwise =

223+ text "When elaborating an application of" <+> whatIsName <>

224+ annName f <> colon <> indented (pprintErr' i e)

225+ where whatIsName = let ctxt = tt_ctxt i

226+ in if isTConName f ctxt

227+ then text "type constructor" <> space

228+ else if isConName f ctxt

229+ then text "constructor" <> space

230+ else if isFnName f ctxt

231+ then text "function" <> space

232+ else empty

212pprintErr' i (ProviderError msg) = text ("Type provider error: " ++ msg)

233pprintErr' i (ProviderError msg) = text ("Type provider error: " ++ msg)

213pprintErr' i (LoadingFailed fn e) = text "Loading" <+> text fn <+> text "failed:" <+> pprintErr' i e

234pprintErr' i (LoadingFailed fn e) = text "Loading" <+> text fn <+> text "failed:" <+> pprintErr' i e

214pprintErr' i (ReflectionError parts orig) =

235pprintErr' i (ReflectionError parts orig) =

215− let parts' = map (hsep . map showPart) parts in

236+ let parts' = map (fillSep . map showPart) parts in

216− vsep parts' <>

237+ align (fillSep parts') <>

217 if (opt_origerr (idris_options i))

238 if (opt_origerr (idris_options i))

218 then line <> line <> text "Original error:" <$> indented (pprintErr' i orig)

239 then line <> line <> text "Original error:" <$> indented (pprintErr' i orig)

219 else empty

240 else empty

220 where showPart :: ErrorReportPart -> Doc OutputAnnotation

241 where showPart :: ErrorReportPart -> Doc OutputAnnotation

221− showPart (TextPart str) = text str

242+ showPart (TextPart str) = fillSep . map text . words $ str

222 showPart (NamePart n) = annName n

243 showPart (NamePart n) = annName n

223 showPart (TermPart tm) = pprintTerm i (delab i tm)

244 showPart (TermPart tm) = pprintTerm i (delab i tm)

224 showPart (SubReport rs) = indented . hsep . map showPart $ rs

245 showPart (SubReport rs) = indented . hsep . map showPart $ rs

@@ -227,11 +248,40 @@ pprintErr' i (ReflectionFailed msg err) =

227 indented (pprintErr' i err) <>

248 indented (pprintErr' i err) <>

228 text ("This is probably a bug. Please consider reporting it at " ++ bugaddr)

249 text ("This is probably a bug. Please consider reporting it at " ++ bugaddr)

229

250

251+isUN :: Name -> Bool

252+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

253+isUN (NS n _) = isUN n

254+isUN _ = False

255+

230annName :: Name -> Doc OutputAnnotation

256annName :: Name -> Doc OutputAnnotation

231−annName n = annName' n (show n)

257+annName n = annName' n (showbasic n)

232

258

233annName' :: Name -> String -> Doc OutputAnnotation

259annName' :: Name -> String -> Doc OutputAnnotation

234−annName' n str = annotate (AnnName n Nothing Nothing) (text str)

260+annName' n str = annotate (AnnName n Nothing Nothing Nothing) (text str)

261+

262+fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation

263+fancifyAnnots ist annot@(AnnName n _ _ _) =

264+ do let ctxt = tt_ctxt ist

265+ docs = docOverview ist n

266+ ty = Just (getTy ist n)

267+ case () of

268+ _ | isDConName n ctxt -> AnnName n (Just DataOutput) docs ty

269+ _ | isFnName n ctxt -> AnnName n (Just FunOutput) docs ty

270+ _ | isTConName n ctxt -> AnnName n (Just TypeOutput) docs ty

271+ _ | isMetavarName n ist -> AnnName n (Just MetavarOutput) docs ty

272+ _ | isPostulateName n ist -> AnnName n (Just PostulateOutput) docs ty

273+ _ | otherwise -> annot

274+ where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs

275+ docOverview ist n = do docs <- lookupCtxtExact n (idris_docstrings ist)

276+ let o = overview (fst docs)

277+ -- TODO make width configurable

278+ out = displayS . renderPretty 1.0 50 $ renderDocstring o

279+ return (out "")

280+ getTy :: IState -> Name -> String -- fails if name not already extant!

281+ getTy ist n = let theTy = pprintPTerm (ppOptionIst ist) [] [] (idris_infixes ist) $

282+ delabTy ist n

283+ in (displayS . renderPretty 1.0 50 $ theTy) ""

284+fancifyAnnots _ annot = annot

235

285

236showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation

286showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation

237showSc i [] = empty

287showSc i [] = empty

@@ -244,13 +294,14 @@ showSc i xs = line <> line <> text "In context:" <>

244

294

245

295

246showqual :: IState -> Name -> String

296showqual :: IState -> Name -> String

247−showqual i n = showName (Just i) [] False False (dens n)

297+showqual i n = showName (Just i) [] (ppOptionIst i) { ppopt_impl = False } False (dens n)

248 where

298 where

249 dens ns@(NS n _) = case lookupCtxt n (idris_implicits i) of

299 dens ns@(NS n _) = case lookupCtxt n (idris_implicits i) of

250 [_] -> n -- just one thing

300 [_] -> n -- just one thing

251 _ -> ns

301 _ -> ns

252 dens n = n

302 dens n = n

253

303

304+showbasic :: Name -> String

254showbasic n@(UN _) = show n

305showbasic n@(UN _) = show n

255showbasic (MN _ s) = str s

306showbasic (MN _ s) = str s

256showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

307showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

src/Idris/Docs.hs+141−48

@@ -1,65 +1,138 @@

1+{-# LANGUAGE PatternGuards #-}

1−module Idris.Docs where

2+module Idris.Docs (pprintDocs, getDocs, pprintConstDocs, FunDoc(..), Docs (..)) where

2

3

3import Idris.AbsSyntax

4import Idris.AbsSyntax

4import Idris.AbsSyntaxTree

5import Idris.AbsSyntaxTree

5import Idris.Delaborate

6import Idris.Delaborate

6import Idris.Core.TT

7import Idris.Core.TT

7import Idris.Core.Evaluate

8import Idris.Core.Evaluate

9+import Idris.Docstrings

8

10

9import Util.Pretty

11import Util.Pretty

10

12

11import Data.Maybe

13import Data.Maybe

12import Data.List

14import Data.List

15+import qualified Data.Text as T

13

16

14-- TODO: Only include names with public/abstract accessibility

17-- TODO: Only include names with public/abstract accessibility

15

18

16−data FunDoc = FD Name String

19+data FunDoc = FD Name Docstring

17− [(Name, PTerm, Plicity)] -- args: name, ty, plicity

20+ [(Name, PTerm, Plicity, Maybe Docstring)] -- args: name, ty, implicit, docs

18 PTerm -- function type

21 PTerm -- function type

19 (Maybe Fixity)

22 (Maybe Fixity)

23+ deriving Show

20

24

21data Docs = FunDoc FunDoc

25data Docs = FunDoc FunDoc

22 | DataDoc FunDoc -- type constructor docs

26 | DataDoc FunDoc -- type constructor docs

23 [FunDoc] -- data constructor docs

27 [FunDoc] -- data constructor docs

24− | ClassDoc Name String -- class docs

28+ | ClassDoc Name Docstring -- class docs

25 [FunDoc] -- method docs

29 [FunDoc] -- method docs

26−

30+ [(Name, Maybe Docstring)] -- parameters and their docstrings

31+ [PTerm] -- instances

32+ [PTerm] -- superclasses

33+ deriving Show

34+

27−showDoc "" = empty

35+showDoc d | nullDocstring d = empty

28−showDoc x = text " -- " <> text x

36+ | otherwise = text " -- " <> renderDocstring d

29−

37+

30−pprintFD :: Bool -> FunDoc -> Doc OutputAnnotation

38+pprintFD :: IState -> FunDoc -> Doc OutputAnnotation

31−pprintFD imp (FD n doc args ty f)

39+pprintFD ist (FD n doc args ty f)

32− = nest 4 (prettyName imp [] n <+> colon <+> prettyImp imp ty <$> showDoc doc <$>

40+ = nest 4 (prettyName (ppopt_impl ppo) [] n <+> colon <+>

41+ pprintPTerm ppo [] [ n | (n@(UN n'),_,_,_) <- args

42+ , not (T.isPrefixOf (T.pack "__") n') ] infixes ty <$>

43+ renderDocstring doc <$>

33 maybe empty (\f -> text (show f) <> line) f <>

44 maybe empty (\f -> text (show f) <> line) f <>

34− let argshow = mapMaybe showArg args in

45+ let argshow = showArgs args [] in

35 if not (null argshow)

46 if not (null argshow)

36 then nest 4 $ text "Arguments:" <$> vsep argshow

47 then nest 4 $ text "Arguments:" <$> vsep argshow

37 else empty)

48 else empty)

38

49

39− where showArg (n, ty, arg@(Exp {}))

50+ where ppo = ppOptionIst ist

51+ infixes = idris_infixes ist

52+ showArgs ((n, ty, Exp {}, Just d):args) bnd

40− = Just $ bindingOf n False <+> colon <+> prettyImp imp ty <>

53+ = bindingOf n False <+> colon <+>

54+ pprintPTerm ppo bnd [] infixes ty <>

41− showDoc (pdocstr arg) <> line

55+ showDoc d <> line

56+ :

57+ showArgs args ((n, False):bnd)

42− showArg (n, ty, arg@(Constraint {}))

58+ showArgs ((n, ty, Constraint {}, Just d):args) bnd

43− = Just $ text "Class constraint" <+>

59+ = text "Class constraint" <+>

44− prettyImp imp ty <> showDoc (pdocstr arg) <> line

60+ pprintPTerm ppo bnd [] infixes ty <> showDoc d <> line

45− showArg (n, ty, arg@(Imp {}))

61+ :

46− | not (null doc)

62+ showArgs args ((n, True):bnd)

63+ showArgs ((n, ty, Imp {}, Just d):args) bnd

47− = Just $ text "(implicit)" <+>

64+ = text "(implicit)" <+>

48− bindingOf n True <+> colon <+> prettyImp imp ty

65+ bindingOf n True <+> colon <+>

66+ pprintPTerm ppo bnd [] infixes ty <>

49− <> showDoc (pdocstr arg) <> line

67+ showDoc d <> line

50− showArg (n, _, _) = Nothing

68+ :

51−

69+ showArgs args ((n, True):bnd)

52−

70+ showArgs ((n, _, _, _):args) bnd = showArgs args ((n, True):bnd)

53−

71+ showArgs [] _ = []

72+

73+

74+pprintDocs :: IState -> Docs -> Doc OutputAnnotation

54−pprintDocs imp (FunDoc d) = pprintFD imp d

75+pprintDocs ist (FunDoc d) = pprintFD ist d

55−pprintDocs imp (DataDoc t args)

76+pprintDocs ist (DataDoc t args)

56− = text "Data type" <+> pprintFD imp t <$>

77+ = text "Data type" <+> pprintFD ist t <$>

78+ if null args then text "No constructors."

57− nest 4 (text "Constructors:" <> line <>

79+ else nest 4 (text "Constructors:" <> line <>

58− vsep (map (pprintFD imp) args))

80+ vsep (map (pprintFD ist) args))

59−pprintDocs imp (ClassDoc n doc meths)

81+pprintDocs ist (ClassDoc n doc meths params instances superclasses)

60− = text "Type class" <+> prettyName imp [] n <$> -- parameters?

82+ = nest 4 (text "Type class" <+> prettyName (ppopt_impl ppo) [] n <>

83+ if nullDocstring doc then empty else line <> renderDocstring doc)

84+ <> line <$>

85+ nest 4 (text "Parameters:" <$> prettyParameters)

86+ <> line <$>

61 nest 4 (text "Methods:" <$>

87 nest 4 (text "Methods:" <$>

62− vsep (map (pprintFD imp) meths))

88+ vsep (map (pprintFD ist) meths))

89+ <$>

90+ nest 4 (text "Instances:" <$>

91+ vsep (if null instances' then [text "<no instances>"]

92+ else map dumpInstance instances'))

93+ <>

94+ (if null subclasses then empty

95+ else line <$> nest 4 (text "Subclasses:" <$>

96+ vsep (map (dumpInstance . prettifySubclasses) subclasses)))

97+ <>

98+ (if null superclasses then empty

99+ else line <$> nest 4 (text "Default superclass instances:" <$>

100+ vsep (map dumpInstance superclasses)))

101+ where

102+ params' = zip pNames (repeat False)

103+

104+ pNames = map fst params

105+

106+ ppo = ppOptionIst ist

107+ infixes = idris_infixes ist

108+

109+ dumpInstance :: PTerm -> Doc OutputAnnotation

110+ dumpInstance = pprintPTerm ppo params' [] infixes

111+

112+ prettifySubclasses (PPi (Constraint _ _) _ tm _) = prettifySubclasses tm

113+ prettifySubclasses (PPi plcity nm t1 t2) = PPi plcity (safeHead nm pNames) (prettifySubclasses t1) (prettifySubclasses t2)

114+ prettifySubclasses (PApp fc ref args) = PApp fc ref $ updateArgs pNames args

115+ prettifySubclasses tm = tm

116+

117+ safeHead _ (y:_) = y

118+ safeHead x [] = x

119+

120+ updateArgs (p:ps) ((PExp prty opts _ ref):as) = (PExp prty opts p (updateRef p ref)) : updateArgs ps as

121+ updateArgs ps (a:as) = a : updateArgs ps as

122+ updateArgs _ _ = []

123+

124+ updateRef nm (PRef fc _) = PRef fc nm

125+ updateRef _ pt = pt

126+

127+ isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args')) = nm == n && map getTm args == map getTm args'

128+ isSubclass (PPi _ _ _ pt) = isSubclass pt

129+ isSubclass _ = False

130+

131+ (subclasses, instances') = partition isSubclass instances

132+

133+ prettyParameters = if any (isJust . snd) params

134+ then vsep (map (\(nm,md) -> prettyName False params' nm <+> maybe empty showDoc md) params)

135+ else hsep (punctuate comma (map (prettyName False params' . fst) params))

63

136

64getDocs :: Name -> Idris Docs

137getDocs :: Name -> Idris Docs

65getDocs n

138getDocs n

@@ -80,20 +153,25 @@ docData n ti

80docClass :: Name -> ClassInfo -> Idris Docs

153docClass :: Name -> ClassInfo -> Idris Docs

81docClass n ci

154docClass n ci

82 = do i <- getIState

155 = do i <- getIState

83− let docstr = case lookupCtxt n (idris_docstrings i) of

156+ let docStrings = listToMaybe $ lookupCtxt n $ idris_docstrings i

84− [str] -> str

157+ docstr = maybe emptyDocstring fst docStrings

85− _ -> ""

158+ params = map (\pn -> (pn, docStrings >>= (lookup pn . snd))) (class_params ci)

159+ instances = map (delabTy i) (class_instances ci)

160+ superclasses = catMaybes $ map getDInst (class_default_superclasses ci)

86− mdocs <- mapM docFun (map fst (class_methods ci))

161+ mdocs <- mapM (docFun . fst) (class_methods ci)

87− return (ClassDoc n docstr mdocs)

162+ return $ ClassDoc n docstr mdocs params instances superclasses

163+ where

164+ getDInst (PInstance _ _ _ _ _ t _ _) = Just t

165+ getDInst _ = Nothing

88

166

89docFun :: Name -> Idris FunDoc

167docFun :: Name -> Idris FunDoc

90docFun n

168docFun n

91 = do i <- getIState

169 = do i <- getIState

92− let docstr = case lookupCtxt n (idris_docstrings i) of

170+ let (docstr, argDocs) = case lookupCtxt n (idris_docstrings i) of

93− [str] -> str

171+ [d] -> d

94− _ -> ""

172+ _ -> noDocs

95 let ty = delabTy i n

173 let ty = delabTy i n

96− let args = getPArgNames ty

174+ let args = getPArgNames ty argDocs

97 let infixes = idris_infixes i

175 let infixes = idris_infixes i

98 let fixdecls = filter (\(Fix _ x) -> x == funName n) infixes

176 let fixdecls = filter (\(Fix _ x) -> x == funName n) infixes

99 let f = case fixdecls of

177 let f = case fixdecls of

@@ -104,7 +182,22 @@ docFun n

104 where funName :: Name -> String

182 where funName :: Name -> String

105 funName (UN n) = str n

183 funName (UN n) = str n

106 funName (NS n _) = funName n

184 funName (NS n _) = funName n

107−

185+ funName n

186+ | n == falseTy = "_|_"

187+

108−getPArgNames :: PTerm -> [(Name, PTerm, Plicity)]

188+getPArgNames :: PTerm -> [(Name, Docstring)] -> [(Name, PTerm, Plicity, Maybe Docstring)]

109−getPArgNames (PPi plicity name ty body) = ((name, ty, plicity) : getPArgNames body)

189+getPArgNames (PPi plicity name ty body) ds =

190+ (name, ty, plicity, lookup name ds) : getPArgNames body ds

110−getPArgNames _ = []

191+getPArgNames _ _ = []

192+

193+pprintConstDocs :: IState -> Const -> String -> Doc OutputAnnotation

194+pprintConstDocs ist c str = text "Primitive" <+> text (if constIsType c then "type" else "value") <+>

195+ pprintPTerm (ppOptionIst ist) [] [] [] (PConstant c) <+> colon <+>

196+ pprintPTerm (ppOptionIst ist) [] [] [] (t c) <>

197+ nest 4 (line <> text str)

198+

199+ where t (Fl _) = PConstant $ AType ATFloat

200+ t (BI _) = PConstant $ AType (ATInt ITBig)

201+ t (Str _) = PConstant StrType

202+ t (Ch c) = PConstant $ AType (ATInt ITChar)

203+ t _ = PType

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 = softline

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+464−277

@@ -4,6 +4,7 @@

4module Idris.ElabDecls where

5

6import Idris.AbsSyntax

7+import Idris.ASTUtils

7import Idris.DSL

8import Idris.DSL

8import Idris.Error

9import Idris.Error

9import Idris.Delaborate

10import Idris.Delaborate

@@ -16,6 +17,7 @@ import Idris.Primitives

16import Idris.Inliner

17import Idris.Inliner

17import Idris.PartialEval

18import Idris.PartialEval

18import Idris.DeepSeq

19import Idris.DeepSeq

20+import Idris.Output (iputStrLn, pshow, iWarn)

19import IRTS.Lang

21import IRTS.Lang

20import Paths_idris

22import Paths_idris

21

23

@@ -26,6 +28,12 @@ import Idris.Core.Execute

26import Idris.Core.Typecheck

28import Idris.Core.Typecheck

27import Idris.Core.CaseTree

29import Idris.Core.CaseTree

28

30

31+import Idris.Docstrings

32+

33+import Prelude hiding (id, (.))

34+import Control.Category

35+

36+import Control.Applicative hiding (Const)

29import Control.DeepSeq

37import Control.DeepSeq

30import Control.Monad

38import Control.Monad

31import Control.Monad.State.Strict as State

39import Control.Monad.State.Strict as State

@@ -34,6 +42,7 @@ import Data.Maybe

34import Debug.Trace

42import Debug.Trace

35

43

36import qualified Data.Map as Map

44import qualified Data.Map as Map

45+import qualified Data.Set as S

37import qualified Data.Text as T

46import qualified Data.Text as T

38import Data.Char(isLetter, toLower)

47import Data.Char(isLetter, toLower)

39import Data.List.Split (splitOn)

48import Data.List.Split (splitOn)

@@ -56,32 +65,37 @@ checkAddDef add toplvl fc [] = return []

56checkAddDef add toplvl fc ((n, (i, top, t)) : ns)

65checkAddDef add toplvl fc ((n, (i, top, t)) : ns)

57 = do ctxt <- getContext

66 = do ctxt <- getContext

58 (t', _) <- recheckC fc [] t

67 (t', _) <- recheckC fc [] t

59− when add $ addDeferred [(n, (i, top, t, toplvl))]

68+ when add $ do addDeferred [(n, (i, top, t, toplvl))]

69+ addIBC (IBCDef n)

60 ns' <- checkAddDef add toplvl fc ns

70 ns' <- checkAddDef add toplvl fc ns

61 return ((n, (i, top, t')) : ns')

71 return ((n, (i, top, t')) : ns')

62-- mapM (\(n, (i, top, t)) -> do (t', _) <- recheckC fc [] t

72-- mapM (\(n, (i, top, t)) -> do (t', _) <- recheckC fc [] t

63-- return (n, (i, top, t'))) ns

73-- return (n, (i, top, t'))) ns

64

74

65-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

75-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

66−elabType :: ElabInfo -> SyntaxInfo -> String ->

76+elabType :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->

67 FC -> FnOpts -> Name -> PTerm -> Idris Type

77 FC -> FnOpts -> Name -> PTerm -> Idris Type

68elabType = elabType' False

78elabType = elabType' False

69

79

70elabType' :: Bool -> -- normalise it

80elabType' :: Bool -> -- normalise it

71− ElabInfo -> SyntaxInfo -> String ->

81+ ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->

72 FC -> FnOpts -> Name -> PTerm -> Idris Type

82 FC -> FnOpts -> Name -> PTerm -> Idris Type

73−elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in

83+elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in

74− n = liftname info n_in in -}

84+ n = liftname info n_in in -}

75 do checkUndefined fc n

85 do checkUndefined fc n

76 ctxt <- getContext

86 ctxt <- getContext

77 i <- getIState

87 i <- getIState

78

88

79− logLvl 1 $ show n ++ " pre-type " ++ showTmImpls ty'

89+ logLvl 5 $ show n ++ " pre-type " ++ showTmImpls ty'

80 ty' <- addUsingConstraints syn fc ty'

90 ty' <- addUsingConstraints syn fc ty'

81− ty' <- implicit syn n ty'

91+ ty' <- implicit info syn n ty'

92+

93+ let ty = addImpl i ty'

94+ inacc = inaccessibleArgs 0 ty

95+ logLvl 5 $ show n ++ " type pre-addimpl " ++ showTmImpls ty'

96+ logLvl 5 $ show n ++ " type " ++ showTmImpls ty

97+ logLvl 3 $ show n ++ ": inaccessible arguments: " ++ show inacc

82

98

83− let ty = addImpl i ty'

84− logLvl 1 $ show n ++ " type " ++ showTmImpls ty

85 ((tyT, defer, is), log) <-

99 ((tyT, defer, is), log) <-

86 tclift $ elaborate ctxt n (TType (UVal 0)) []

100 tclift $ elaborate ctxt n (TType (UVal 0)) []

87 (errAt "type of " n (erun fc (build i info False [] n ty)))

101 (errAt "type of " n (erun fc (build i info False [] n ty)))

@@ -89,8 +103,7 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

89 -- if the type is not complete, note that we'll need to infer

103 -- if the type is not complete, note that we'll need to infer

90 -- things later (for solving metavariables)

104 -- things later (for solving metavariables)

91 when (not (null ds)) $ addTyInferred n

105 when (not (null ds)) $ addTyInferred n

92−-- let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds

106+

93−-- addDeferred ds'

94 mapM_ (elabCaseBlock info opts) is

107 mapM_ (elabCaseBlock info opts) is

95 ctxt <- getContext

108 ctxt <- getContext

96 logLvl 5 $ "Rechecking"

109 logLvl 5 $ "Rechecking"

@@ -106,27 +119,32 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

106 -- Add normalised type to internals

119 -- Add normalised type to internals

107 rep <- useREPL

120 rep <- useREPL

108 when rep $ do

121 when rep $ do

109− addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

122+ addInternalApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')) -- TODO: Should use span instead of line and filename?

110− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))

123+ addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')))

111

124

112 let (t, _) = unApply (getRetTy nty')

125 let (t, _) = unApply (getRetTy nty')

113 let corec = case t of

126 let corec = case t of

114 P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of

127 P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of

115− [TI _ True _ _] -> True

128+ [TI _ True _ _ _] -> True

116 _ -> False

129 _ -> False

117 _ -> False

130 _ -> False

131+ -- Productivity checking now via checking for guarded 'Delay'

118− let opts' = if corec then (Coinductive : opts) else opts

132+ let opts' = opts -- if corec then (Coinductive : opts) else opts

119 let usety = if norm then nty' else nty

133 let usety = if norm then nty' else nty

120 ds <- checkDef fc [(n, (-1, Nothing, usety))]

134 ds <- checkDef fc [(n, (-1, Nothing, usety))]

121 addIBC (IBCDef n)

135 addIBC (IBCDef n)

122 let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds

136 let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds

123 addDeferred ds'

137 addDeferred ds'

124 setFlags n opts'

138 setFlags n opts'

139+ checkDocs fc argDocs ty

125− addDocStr n doc

140+ addDocStr n doc argDocs

126 addIBC (IBCDoc n)

141 addIBC (IBCDoc n)

127 addIBC (IBCFlags n opts')

142 addIBC (IBCFlags n opts')

143+ fputState (opt_inaccessible . ist_optimisation n) inacc

144+ addIBC (IBCOpt n)

128− when (Implicit `elem` opts) $ do addCoercion n

145+ when (Implicit `elem` opts') $ do addCoercion n

129− addIBC (IBCCoercion n)

146+ addIBC (IBCCoercion n)

147+

130 -- If the function is declared as an error handler and the language

148 -- If the function is declared as an error handler and the language

131 -- extension is enabled, then add it to the list of error handlers.

149 -- extension is enabled, then add it to the list of error handlers.

132 errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState

150 errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState

@@ -141,8 +159,6 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

141 addIBC (IBCErrorHandler n)

159 addIBC (IBCErrorHandler n)

142 else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

160 else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

143 else ifail "Error handlers can only be defined when the ErrorReflection language extension is enabled."

161 else ifail "Error handlers can only be defined when the ErrorReflection language extension is enabled."

144− when corec $ do setAccessibility n Frozen

145− addIBC (IBCAccess n Frozen)

146 return usety

162 return usety

147 where

163 where

148 -- for making an internalapp, we only want the explicit ones, and don't

164 -- for making an internalapp, we only want the explicit ones, and don't

@@ -167,59 +183,57 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

167 , ns2 == map txt ["Maybe", "Prelude"]

183 , ns2 == map txt ["Maybe", "Prelude"]

168 , ns3 == map txt ["List", "Prelude"]

184 , ns3 == map txt ["List", "Prelude"]

169 , ns4 == map txt ["Errors","Reflection","Language"] = True

185 , ns4 == map txt ["Errors","Reflection","Language"] = True

170− tyIsHandler _ = False

186+ tyIsHandler _ = False

187+

188+-- Get the list of (index, name) of inaccessible arguments from the type.

189+inaccessibleArgs :: Int -> PTerm -> [(Int, Name)]

190+inaccessibleArgs i (PPi (Imp _ _ _) n Placeholder t)

191+ = (i,n) : inaccessibleArgs (i+1) t -- unbound implicit

192+inaccessibleArgs i (PPi plicity n ty t)

193+ | InaccessibleArg `elem` pargopts plicity

194+ = (i,n) : inaccessibleArgs (i+1) t -- an .{erased : Implicit}

195+ | otherwise

196+ = inaccessibleArgs (i+1) t -- a {regular : Implicit}

197+inaccessibleArgs _ _ = []

198+

199+elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring ->

200+ FC -> FnOpts -> Name -> PTerm -> Idris ()

201+elabPostulate info syn doc fc opts n ty = do

202+ elabType info syn doc [] fc opts n ty

203+ putIState . (\ist -> ist{ idris_postulates = S.insert n (idris_postulates ist) }) =<< getIState

204+ addIBC (IBCPostulate n)

171

205

206+ -- remove it from the deferred definitions list

207+ solveDeferred n

172

208

173−elabPostulate :: ElabInfo -> SyntaxInfo -> String ->

209+elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris ()

174− FC -> FnOpts -> Name -> PTerm -> Idris ()

175−elabPostulate info syn doc fc opts n ty

176− = do elabType info syn doc fc opts n ty

177− -- make sure it's collapsible, so it is never needed at run time

178− -- start by getting the elaborated type

179− ctxt <- getContext

180− fty <- case lookupTy n ctxt of

181− [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen!

182− [ty] -> return ty

183− ist <- getIState

184− let (ap, _) = unApply (getRetTy (normalise ctxt [] fty))

185− logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

186− let postOK = case ap of

187− P _ tn _ -> case lookupCtxt tn

188− (idris_optimisation ist) of

189− [oi] -> collapsible oi

190− _ -> False

191− _ -> False

192− when (not postOK)

193− $ tclift $ tfail (At fc (NonCollapsiblePostulate n))

194− -- remove it from the deferred definitions list

195− solveDeferred n

196−

197−elabData :: ElabInfo -> SyntaxInfo -> String -> FC -> DataOpts -> PData -> Idris ()

198−elabData info syn doc fc opts (PLaterdecl n t_in)

210+elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

199 = do let codata = Codata `elem` opts

211 = do let codata = Codata `elem` opts

200 iLOG (show (fc, doc))

212 iLOG (show (fc, doc))

201 checkUndefined fc n

213 checkUndefined fc n

202 ctxt <- getContext

214 ctxt <- getContext

203 i <- getIState

215 i <- getIState

216+ -- TODO think: something more in info?

204− t_in <- implicit syn n t_in

217+ t_in <- implicit info syn n t_in

205 let t = addImpl i t_in

218 let t = addImpl i t_in

206 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

219 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

207 (erun fc (build i info False [] n t))

220 (erun fc (build i info False [] n t))

208 def' <- checkDef fc defer

221 def' <- checkDef fc defer

209 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def'

222 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def'

210 addDeferredTyCon def''

223 addDeferredTyCon def''

224+ addIBC (IBCDef n)

211 mapM_ (elabCaseBlock info []) is

225 mapM_ (elabCaseBlock info []) is

212 (cty, _) <- recheckC fc [] t'

226 (cty, _) <- recheckC fc [] t'

213 logLvl 2 $ "---> " ++ show cty

227 logLvl 2 $ "---> " ++ show cty

214 updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons

228 updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons

215

229

216−elabData info syn doc fc opts (PDatadecl n t_in dcons)

230+elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

217 = do let codata = Codata `elem` opts

231 = do let codata = Codata `elem` opts

218 iLOG (show fc)

232 iLOG (show fc)

219 undef <- isUndefined fc n

233 undef <- isUndefined fc n

220 ctxt <- getContext

234 ctxt <- getContext

221 i <- getIState

235 i <- getIState

222− t_in <- implicit syn n t_in

236+ t_in <- implicit info syn n t_in

223 let t = addImpl i t_in

237 let t = addImpl i t_in

224 ((t', defer, is), log) <-

238 ((t', defer, is), log) <-

225 tclift $ elaborate ctxt n (TType (UVal 0)) []

239 tclift $ elaborate ctxt n (TType (UVal 0)) []

@@ -235,33 +249,54 @@ elabData info syn doc fc opts (PDatadecl n t_in dcons)

235 logLvl 2 $ "---> " ++ show cty

249 logLvl 2 $ "---> " ++ show cty

236 -- temporary, to check cons

250 -- temporary, to check cons

237 when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

251 when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

252+ let cnameinfo = cinfo info (map cname dcons)

238− cons <- mapM (elabCon info syn n codata) dcons

253+ cons <- mapM (elabCon cnameinfo syn n codata) dcons

239 ttag <- getName

254 ttag <- getName

240 i <- getIState

255 i <- getIState

241 let as = map (const Nothing) (getArgTys cty)

256 let as = map (const Nothing) (getArgTys cty)

242 let params = findParams (map snd cons)

257 let params = findParams (map snd cons)

243 logLvl 2 $ "Parameters : " ++ show params

258 logLvl 2 $ "Parameters : " ++ show params

259+ -- TI contains information about mutually declared types - this will

260+ -- be updated when the mutual block is complete

244− putIState (i { idris_datatypes =

261+ putIState (i { idris_datatypes =

245− addDef n (TI (map fst cons) codata opts params)

262+ addDef n (TI (map fst cons) codata opts params [n])

246 (idris_datatypes i) })

263 (idris_datatypes i) })

247 addIBC (IBCDef n)

264 addIBC (IBCDef n)

248 addIBC (IBCData n)

265 addIBC (IBCData n)

266+ checkDocs fc argDocs t_in

249− addDocStr n doc

267+ addDocStr n doc argDocs

250 addIBC (IBCDoc n)

268 addIBC (IBCDoc n)

251 let metainf = DataMI params

269 let metainf = DataMI params

252 addIBC (IBCMetaInformation n metainf)

270 addIBC (IBCMetaInformation n metainf)

253 -- TMP HACK! Make this a data option

271 -- TMP HACK! Make this a data option

254− when (n /= sUN "Lazy") $ collapseCons n cons

255 updateContext (addDatatype (Data n ttag cty cons))

272 updateContext (addDatatype (Data n ttag cty cons))

256 updateContext (setMetaInformation n metainf)

273 updateContext (setMetaInformation n metainf)

274+ mapM_ totcheck (zip (repeat fc) (map fst cons))

257− mapM_ (checkPositive n) cons

275+-- mapM_ (checkPositive n) cons

276+

277+ -- if there's exactly one constructor,

278+ -- mark both the type and the constructor as detaggable

279+ case cons of

280+ [(cn,ct)] -> setDetaggable cn >> setDetaggable n

281+ >> addIBC (IBCOpt cn) >> addIBC (IBCOpt n)

282+ _ -> return ()

283+

284+ -- create an eliminator

285+ when (DefaultEliminator `elem` opts) $

258− if DefaultEliminator `elem` opts then evalStateT (elabEliminator params n t dcons info) Map.empty

286+ evalStateT (elabEliminator params n t dcons info) Map.empty

259− else return ()

260 where

287 where

288+ setDetaggable :: Name -> Idris ()

289+ setDetaggable n = do

290+ ist <- getIState

291+ let opt = idris_optimisation ist

292+ case lookupCtxt n opt of

293+ [oi] -> putIState ist{ idris_optimisation = addDef n oi{ detaggable = True } opt }

294+ _ -> putIState ist{ idris_optimisation = addDef n (Optimise [] True) opt }

295+

261 checkDefinedAs fc n t ctxt

296 checkDefinedAs fc n t ctxt

262 = case lookupDef n ctxt of

297 = case lookupDef n ctxt of

263 [] -> return ()

298 [] -> return ()

264− [TyDecl _ ty] ->

299+ [TyDecl _ ty] ->

265 case converts ctxt [] t ty of

300 case converts ctxt [] t ty of

266 OK () -> return ()

301 OK () -> return ()

267 _ -> tclift $ tfail (At fc (AlreadyDefined n))

302 _ -> tclift $ tfail (At fc (AlreadyDefined n))

@@ -316,38 +351,56 @@ elabData info syn doc fc opts (PDatadecl n t_in dcons)

316 | otherwise = count n ts

351 | otherwise = count n ts

317 mParam args (_ : rest) = Nothing : mParam args rest

352 mParam args (_ : rest) = Nothing : mParam args rest

318

353

354+ cname (_, _, n, _, _, _) = n

355+

356+ -- Abuse of ElabInfo.

357+ -- TODO Contemplate whether the ElabInfo type needs modification.

358+ cinfo :: ElabInfo -> [Name] -> ElabInfo

359+ cinfo info ds

360+ = let newps = params info

361+ dsParams = map (\n -> (n, [])) ds

362+ newb = addAlist dsParams (inblock info)

363+ l = liftname info in

364+ info { params = newps,

365+ inblock = newb,

366+ liftname = id -- Is this appropriate?

367+ }

368+

319type EliminatorState = StateT (Map.Map String Int) Idris

369type EliminatorState = StateT (Map.Map String Int) Idris

320

370

321−-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

371+-- TODO: Rewrite everything to use idris_implicits instead of manual splitting (or in TT)

322−elabEliminator :: [Int] -> Name -> PTerm -> [(String, Name, PTerm, FC, [Name])] ->

372+elabEliminator :: [Int] -> Name -> PTerm ->

373+ [(Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])] ->

323 ElabInfo -> EliminatorState ()

374 ElabInfo -> EliminatorState ()

324elabEliminator paramPos n ty cons info = do

375elabEliminator paramPos n ty cons info = do

325 elimLog $ "Elaborating eliminator"

376 elimLog $ "Elaborating eliminator"

377+ put (Map.fromList $ zip (concatMap (\(_, p, _, ty, _, _) -> (map show $ boundNamesIn ty) ++ map (show . fst) p) cons ++ (map show $ boundNamesIn ty)) (repeat 0))

326 let (cnstrs, _) = splitPi ty

378 let (cnstrs, _) = splitPi ty

327 let (splittedTy@(pms, idxs)) = splitPms cnstrs

379 let (splittedTy@(pms, idxs)) = splitPms cnstrs

328 generalParams <- namePis False pms

380 generalParams <- namePis False pms

329 motiveIdxs <- namePis False idxs

381 motiveIdxs <- namePis False idxs

330 let motive = mkMotive n paramPos generalParams motiveIdxs

382 let motive = mkMotive n paramPos generalParams motiveIdxs

331− consTerms <- mapM (\(c@(_,cnm,_,_,_)) -> do

383+ consTerms <- mapM (\(c@(_, _, cnm, _, _, _)) -> do

332− name <- freshName $ "elim_" ++ simpleName cnm

384+ name <- freshName $ "elim_" ++ simpleName cnm

333− consTerm <- extractConsTerm c generalParams

385+ consTerm <- extractConsTerm c generalParams

334− return (name, expl, consTerm)) cons

386+ return (name, expl, consTerm)) cons

335 scrutineeIdxs <- namePis False idxs

387 scrutineeIdxs <- namePis False idxs

336 let motiveConstr = [(motiveName, expl, motive)]

388 let motiveConstr = [(motiveName, expl, motive)]

337 let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))

389 let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))

338 let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC n) scrutineeIdxs) (PRef elimFC scrutineeName))

390 let eliminatorTy = piConstr (generalParams ++ motiveConstr ++ consTerms ++ scrutineeIdxs ++ [scrutinee]) (applyMotive (map (\(n,_,_) -> PRef elimFC n) scrutineeIdxs) (PRef elimFC scrutineeName))

339− let eliminatorTyDecl = PTy (show n) defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy

391+ let eliminatorTyDecl = PTy (parseDocstring . T.pack $ show n) [] defaultSyntax elimFC [TotalFn] elimDeclName eliminatorTy

340 let clauseConsElimArgs = map getPiName consTerms

392 let clauseConsElimArgs = map getPiName consTerms

341 let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs

393 let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs

342 let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'

394 let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'

343 let elimSig = "-- eliminator signature: " ++ showTmImpls eliminatorTy

395 let elimSig = "-- eliminator signature: " ++ showTmImpls eliminatorTy

396+ elimLog elimSig

344 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

397 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

345 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

398 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

346− elimLog $ "-- eliminator definition: " ++ (show . showDeclImp True) eliminatorDef

399+ elimLog $ "-- eliminator definition: " ++ (show . showDeclImp verbosePPOption) eliminatorDef

347 State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ())

400 State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ())

348 -- Do not elaborate clauses if there aren't any

401 -- Do not elaborate clauses if there aren't any

349 case eliminatorClauses of

402 case eliminatorClauses of

350− [] -> return ()

403+ [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type

351 _ -> State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

404 _ -> State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

352 where elimLog :: String -> EliminatorState ()

405 where elimLog :: String -> EliminatorState ()

353 elimLog s = State.lift (logLvl 2 s)

406 elimLog s = State.lift (logLvl 2 s)

@@ -410,9 +463,9 @@ elabEliminator paramPos n ty cons info = do

410 freshName key = do

463 freshName key = do

411 nameMap <- get

464 nameMap <- get

412 let i = fromMaybe 0 (Map.lookup key nameMap)

465 let i = fromMaybe 0 (Map.lookup key nameMap)

413− let name = key ++ show i

466+ let name = uniqueName (sUN (key ++ show i)) (map (\(nm, nb) -> sUN (nm ++ show nb)) $ Map.toList nameMap)

414 put $ Map.insert key (i+1) nameMap

467 put $ Map.insert key (i+1) nameMap

415− return (sUN name)

468+ return name

416

469

417 scrutineeName :: Name

470 scrutineeName :: Name

418 scrutineeName = sUN "scrutinee"

471 scrutineeName = sUN "scrutinee"

@@ -485,7 +538,7 @@ elabEliminator paramPos n ty cons info = do

485 splitArgPms _ = ([],[])

538 splitArgPms _ = ([],[])

486

539

487

540

488− implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

541+ implicitIndexes :: (Docstring, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

489 implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

542 implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

490 i <- State.lift getIState

543 i <- State.lift getIState

491 implargs' <- case lookupCtxt cnm (idris_implicits i) of

544 implargs' <- case lookupCtxt cnm (idris_implicits i) of

@@ -500,12 +553,12 @@ elabEliminator paramPos n ty cons info = do

500 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

553 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

501 _ -> return implargs

554 _ -> return implargs

502

555

503− extractConsTerm :: (String, Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

556+ extractConsTerm :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

504− extractConsTerm (doc, cnm, ty, fc, fs) generalParameters = do

557+ extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do

505 let cons' = replaceParams paramPos generalParameters ty

558 let cons' = replaceParams paramPos generalParameters ty

506 let (args, resTy) = splitPi cons'

559 let (args, resTy) = splitPi cons'

507 implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

560 implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

508− consArgs <- namePis True args

561+ consArgs <- namePis False args

509 let recArgs = findRecArgs consArgs

562 let recArgs = findRecArgs consArgs

510 let recMotives = map applyRecMotive recArgs

563 let recMotives = map applyRecMotive recArgs

511 let (_, consIdxs) = splitArgPms resTy

564 let (_, consIdxs) = splitArgPms resTy

@@ -536,15 +589,15 @@ elabEliminator paramPos n ty cons info = do

536 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

589 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

537 convertImplPi _ = Nothing

590 convertImplPi _ = Nothing

538

591

539− generateEliminatorClauses :: (String, Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

592+ generateEliminatorClauses :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

540− generateEliminatorClauses (doc, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

593+ generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

541 let cons' = replaceParams paramPos generalParameters ty

594 let cons' = replaceParams paramPos generalParameters ty

542 let (args, resTy) = splitPi cons'

595 let (args, resTy) = splitPi cons'

543 i <- State.lift getIState

596 i <- State.lift getIState

544 implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

597 implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

545 let (_, generalIdxs') = splitArgPms resTy

598 let (_, generalIdxs') = splitArgPms resTy

546 let generalIdxs = map pexp generalIdxs'

599 let generalIdxs = map pexp generalIdxs'

547− consArgs <- namePis True args

600+ consArgs <- namePis False args

548 let lhsPattern = PApp elimFC (PRef elimFC elimDeclName) (generalArgs ++ generalIdxs ++ [pexp $ applyCons cnm consArgs])

601 let lhsPattern = PApp elimFC (PRef elimFC elimDeclName) (generalArgs ++ generalIdxs ++ [pexp $ applyCons cnm consArgs])

549 let recArgs = findRecArgs consArgs

602 let recArgs = findRecArgs consArgs

550 let recElims = map applyRecElim recArgs

603 let recElims = map applyRecElim recArgs

@@ -558,10 +611,12 @@ elabEliminator paramPos n ty cons info = do

558

611

559elabPrims :: Idris ()

612elabPrims :: Idris ()

560elabPrims = do mapM_ (elabDecl EAll toplevel)

613elabPrims = do mapM_ (elabDecl EAll toplevel)

561− (map (\(opt, decl) -> PData "" defaultSyntax (fileFC "builtin") opt decl)

614+ (map (\(opt, decl, docs, argdocs) -> PData docs argdocs defaultSyntax (fileFC "builtin") opt decl)

562− (zip

615+ (zip4

563 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

616 [inferOpts, unitOpts, falseOpts, pairOpts, eqOpts]

564− [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]))

617+ [inferDecl, unitDecl, falseDecl, pairDecl, eqDecl]

618+ [emptyDocstring, unitDoc, falseDoc, pairDoc, eqDoc]

619+ [[], [], [], pairParamDoc, eqParamDoc]))

565 addNameHint eqTy (sUN "prf")

620 addNameHint eqTy (sUN "prf")

566 elabDecl EAll toplevel elimDecl

621 elabDecl EAll toplevel elimDecl

567 mapM_ elabPrim primitives

622 mapM_ elabPrim primitives

@@ -626,8 +681,8 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

626

681

627

682

628-- | Elaborate a type provider

683-- | Elaborate a type provider

629−elabProvider :: ElabInfo -> SyntaxInfo -> FC -> ProvideWhat -> Name -> PTerm -> PTerm -> Idris ()

684+elabProvider :: ElabInfo -> SyntaxInfo -> FC -> ProvideWhat -> Name -> Idris ()

630−elabProvider info syn fc what n ty tm

685+elabProvider info syn fc what n

631 = do i <- getIState

686 = do i <- getIState

632 -- Ensure that the experimental extension is enabled

687 -- Ensure that the experimental extension is enabled

633 unless (TypeProviders `elem` idris_language_extensions i) $

688 unless (TypeProviders `elem` idris_language_extensions i) $

@@ -637,12 +692,17 @@ elabProvider info syn fc what n ty tm

637 ctxt <- getContext

692 ctxt <- getContext

638

693

639 -- First elaborate the expected type (and check that it's a type)

694 -- First elaborate the expected type (and check that it's a type)

695+ -- The goal type for a postulate is always Type.

696+ (ty', typ) <- case what of

640− (ty', typ) <- elabVal toplevel False ty

697+ ProvTerm ty p -> elabVal toplevel False ty

698+ ProvPostulate _ -> elabVal toplevel False PType

641 unless (isTType typ) $

699 unless (isTType typ) $

642 ifail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ)

700 ifail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ)

643

701

644 -- Elaborate the provider term to TT and check that the type matches

702 -- Elaborate the provider term to TT and check that the type matches

703+ (e, et) <- case what of

704+ ProvTerm _ tm -> elabVal toplevel False tm

645− (e, et) <- elabVal toplevel False tm

705+ ProvPostulate tm -> elabVal toplevel False tm

646 unless (isProviderOf (normalise ctxt [] ty') et) $

706 unless (isProviderOf (normalise ctxt [] ty') et) $

647 ifail $ "Expected provider type IO (Provider (" ++

707 ifail $ "Expected provider type IO (Provider (" ++

648 show ty' ++ "))" ++ ", got " ++ show et ++ " instead."

708 show ty' ++ "))" ++ ", got " ++ show et ++ " instead."

@@ -653,25 +713,22 @@ elabProvider info syn fc what n ty tm

653 rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)

713 rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)

654 [Erased, e])

714 [Erased, e])

655 let rhs' = normalise ctxt [] rhs

715 let rhs' = normalise ctxt [] rhs

656− logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

716+ logLvl 3 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

657

717

658 -- Extract the provided term or postulate from the type provider

718 -- Extract the provided term or postulate from the type provider

659 provided <- getProvided fc rhs'

719 provided <- getProvided fc rhs'

660

720

661 case provided of

721 case provided of

662 Provide tm

722 Provide tm

663− | what `elem` [ProvTerm, ProvAny] ->

723+ | ProvTerm ty _ <- what ->

664 do -- Finally add a top-level definition of the provided term

724 do -- Finally add a top-level definition of the provided term

665− elabType info syn "" fc [] n ty

725+ elabType info syn emptyDocstring [] fc [] n ty

666 elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc n) []) [] (delab i tm) []]

726 elabClauses info fc [] n [PClause fc n (PApp fc (PRef fc n) []) [] (delab i tm) []]

667− logLvl 1 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

727+ logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

668− | otherwise ->

728+ | ProvPostulate _ <- what ->

669− ierror . Msg $ "Attempted to provide a term where a postulate was expected."

670− Postulate

671− | what `elem` [ProvPostulate, ProvAny] ->

672 do -- Add the postulate

729 do -- Add the postulate

673− elabPostulate info syn "Provided postulate" fc [] n ty

730+ elabPostulate info syn (parseDocstring $ T.pack "Provided postulate") fc [] n (delab i tm)

674− logLvl 1 $ "Elaborated provided postulate " ++ show n

731+ logLvl 3 $ "Elaborated provided postulate " ++ show n

675 | otherwise ->

732 | otherwise ->

676 ierror . Msg $ "Attempted to provide a postulate where a term was expected."

733 ierror . Msg $ "Attempted to provide a postulate where a term was expected."

677

734

@@ -687,7 +744,6 @@ elabProvider info syn fc what n ty tm

687 , prov == txt "Provider" && provs == txt "Providers" = True

744 , prov == txt "Provider" && provs == txt "Providers" = True

688 isProviderOf _ _ = False

745 isProviderOf _ _ = False

689

746

690−-- | Elaborate a type provider

691elabTransform :: ElabInfo -> FC -> Bool -> PTerm -> PTerm -> Idris ()

747elabTransform :: ElabInfo -> FC -> Bool -> PTerm -> PTerm -> Idris ()

692elabTransform info fc safe lhs_in rhs_in

748elabTransform info fc safe lhs_in rhs_in

693 = do ctxt <- getContext

749 = do ctxt <- getContext

@@ -721,12 +777,18 @@ elabTransform info fc safe lhs_in rhs_in

721 addIBC (IBCTrans (clhs_tm, crhs_tm))

777 addIBC (IBCTrans (clhs_tm, crhs_tm))

722

778

723

779

724−elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

780+elabRecord :: ElabInfo -> SyntaxInfo -> Docstring -> FC -> Name ->

725− PTerm -> String -> Name -> PTerm -> Idris ()

781+ PTerm -> DataOpts -> Docstring -> Name -> PTerm -> Idris ()

726−elabRecord info syn doc fc tyn ty cdoc cn cty

782+elabRecord info syn doc fc tyn ty opts cdoc cn cty_in

727− = do elabData info syn doc fc [] (PDatadecl tyn ty [(cdoc, cn, cty, fc, [])])

783+ = do elabData info syn doc [] fc opts (PDatadecl tyn ty [(cdoc, [], cn, cty_in, fc, [])])

784+ -- TODO think: something more in info?

728− cty' <- implicit syn cn cty

785+ cty' <- implicit info syn cn cty_in

729 i <- getIState

786 i <- getIState

787+

788+ -- get bound implicits and propagate to setters (in case they

789+ -- provide useful information for inference)

790+ let extraImpls = getBoundImpls cty'

791+

730 cty <- case lookupTy cn (tt_ctxt i) of

792 cty <- case lookupTy cn (tt_ctxt i) of

731 [t] -> return (delab i t)

793 [t] -> return (delab i t)

732 _ -> ifail "Something went inexplicably wrong"

794 _ -> ifail "Something went inexplicably wrong"

@@ -735,14 +797,29 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

735 let ptys = getProjs [] (renameBs cimp cty)

797 let ptys = getProjs [] (renameBs cimp cty)

736 let ptys_u = getProjs [] cty

798 let ptys_u = getProjs [] cty

737 let recty = getRecTy cty

799 let recty = getRecTy cty

800+

801+ -- rename indices when we generate the getter/setter types, so

802+ -- that they don't clash with the names of the projections

803+ -- we're generating

804+ let index_names_in = getRecNameMap "_in" recty

805+ let recty_in = substMatches index_names_in recty

806+

738− logLvl 6 $ show (recty, ptys)

807+ logLvl 1 $ show (recty, ptys)

739 let substs = map (\ (n, _) -> (n, PApp fc (PRef fc n)

808 let substs = map (\ (n, _) -> (n, PApp fc (PRef fc n)

740 [pexp (PRef fc rec)])) ptys

809 [pexp (PRef fc rec)])) ptys

810+

811+ -- Generate projection functions

741− proj_decls <- mapM (mkProj recty substs cimp) (zip ptys [0..])

812+ proj_decls <- mapM (mkProj recty_in substs cimp) (zip ptys [0..])

813+ logLvl 3 $ show proj_decls

742 let nonImp = mapMaybe isNonImp (zip cimp ptys_u)

814 let nonImp = mapMaybe isNonImp (zip cimp ptys_u)

743 let implBinds = getImplB id cty'

815 let implBinds = getImplB id cty'

816+

817+ -- Generate update functions

818+ update_decls <- mapM (mkUpdate recty index_names_in extraImpls

819+ (getFieldNames cty')

744− update_decls <- mapM (mkUpdate recty implBinds (length nonImp)) (zip nonImp [0..])

820+ implBinds (length nonImp)) (zip nonImp [0..])

745 mapM_ (elabDecl EAll info) (concat proj_decls)

821 mapM_ (elabDecl EAll info) (concat proj_decls)

822+ logLvl 3 $ show update_decls

746 mapM_ (tryElabDecl info) (update_decls)

823 mapM_ (tryElabDecl info) (update_decls)

747 where

824 where

748-- syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in }

825-- syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in }

@@ -757,17 +834,21 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

757 (\v -> do iputStrLn $ show fc ++

834 (\v -> do iputStrLn $ show fc ++

758 ":Warning - can't generate setter for " ++

835 ":Warning - can't generate setter for " ++

759 show fn ++ " (" ++ show ty ++ ")"

836 show fn ++ " (" ++ show ty ++ ")"

837+-- ++ "\n" ++ pshow i v

760 putIState i)

838 putIState i)

761

839

840+ getBoundImpls (PPi (Imp _ _ _) n ty sc) = (n, ty) : getBoundImpls sc

841+ getBoundImpls _ = []

842+

762− getImplB k (PPi (Imp l s _ _) n Placeholder sc)

843+ getImplB k (PPi (Imp l s _) n Placeholder sc)

763 = getImplB k sc

844 = getImplB k sc

764− getImplB k (PPi (Imp l s d p) n ty sc)

845+ getImplB k (PPi (Imp l s p) n ty sc)

765− = getImplB (\x -> k (PPi (Imp l s d p) n ty x)) sc

846+ = getImplB (\x -> k (PPi (Imp l s p) n ty x)) sc

766 getImplB k (PPi _ n ty sc)

847 getImplB k (PPi _ n ty sc)

767 = getImplB k sc

848 = getImplB k sc

768 getImplB k _ = k

849 getImplB k _ = k

769

850

770− renameBs (PImp _ _ _ _ _ _ : ps) (PPi p n ty s)

851+ renameBs (PImp _ _ _ _ _ : ps) (PPi p n ty s)

771 = PPi p (mkImp n) ty (renameBs ps (substMatch n (PRef fc (mkImp n)) s))

852 = PPi p (mkImp n) ty (renameBs ps (substMatch n (PRef fc (mkImp n)) s))

772 renameBs (_:ps) (PPi p n ty s) = PPi p n ty (renameBs ps s)

853 renameBs (_:ps) (PPi p n ty s) = PPi p n ty (renameBs ps s)

773 renameBs _ t = t

854 renameBs _ t = t

@@ -775,9 +856,19 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

775 getProjs acc (PPi _ n ty s) = getProjs ((n, ty) : acc) s

856 getProjs acc (PPi _ n ty s) = getProjs ((n, ty) : acc) s

776 getProjs acc r = reverse acc

857 getProjs acc r = reverse acc

777

858

859+ getFieldNames (PPi (Exp _ _ _) n _ s) = n : getFieldNames s

860+ getFieldNames (PPi _ _ _ s) = getFieldNames s

861+ getFieldNames _ = []

862+

778 getRecTy (PPi _ n ty s) = getRecTy s

863 getRecTy (PPi _ n ty s) = getRecTy s

779 getRecTy t = t

864 getRecTy t = t

780

865

866+ getRecNameMap x (PApp fc t args) = mapMaybe (toMN . getTm) args

867+ where

868+ toMN (PRef fc n) = Just (n, PRef fc (sMN 0 (show n ++ x)))

869+ toMN _ = Nothing

870+ getRecNameMap x _ = []

871+

781 rec = sMN 0 "rec"

872 rec = sMN 0 "rec"

782

873

783 mkp (UN n) = sMN 0 ("p_" ++ str n)

874 mkp (UN n) = sMN 0 ("p_" ++ str n)

@@ -794,7 +885,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

794

885

795 mkProj recty substs cimp ((pn_in, pty), pos)

886 mkProj recty substs cimp ((pn_in, pty), pos)

796 = do let pn = expandNS syn pn_in

887 = do let pn = expandNS syn pn_in

797− let pfnTy = PTy "" defaultSyntax fc [] pn

888+ let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] pn

798 (PPi expl rec recty

889 (PPi expl rec recty

799 (substMatches substs pty))

890 (substMatches substs pty))

800 let pls = repeat Placeholder

891 let pls = repeat Placeholder

@@ -810,13 +901,23 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

810

901

811 implicitise (pa, t) = pa { getTm = t }

902 implicitise (pa, t) = pa { getTm = t }

812

903

904+ -- If the 'pty' we're updating includes anything in 'substs', we're

905+ -- updating the type as well, so use recty', otherwise just use

906+ -- recty

813− mkUpdate recty k num ((pn, pty), pos)

907+ mkUpdate recty inames extras fnames k num ((pn, pty), pos)

814 = do let setname = expandNS syn $ mkType pn

908 = do let setname = expandNS syn $ mkType pn

815 let valname = sMN 0 "updateval"

909 let valname = sMN 0 "updateval"

816− let pt = k (PPi expl pn pty

910+ let pn_out = sMN 0 (show pn ++ "_out")

817− (PPi expl rec recty recty))

911+ let pn_in = sMN 0 (show pn ++ "_in")

818− let pfnTy = PTy "" defaultSyntax fc [] setname pt

912+ let recty_in = substMatches [(pn, PRef fc pn_in)] recty

819− let pls = map (\x -> PRef fc (sMN x "field")) [0..num-1]

913+ let recty_out = substMatches [(pn, PRef fc pn_out)] recty

914+ let pt = substMatches inames $

915+ k (implBindUp extras inames (PPi expl pn_out pty

916+ (PPi expl rec recty_in recty_out)))

917+ let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] setname pt

918+-- let pls = map (\x -> PRef fc (sMN x ("field" ++ show x))) [0..num-1]

919+ let inames_imp = map (\ (x,_) -> (x, Placeholder)) inames

920+ let pls = map (\x -> substMatches inames_imp (PRef fc x)) fnames

820 let lhsArgs = pls

921 let lhsArgs = pls

821 let rhsArgs = take pos pls ++ (PRef fc valname) :

922 let rhsArgs = take pos pls ++ (PRef fc valname) :

822 drop (pos + 1) pls

923 drop (pos + 1) pls

@@ -830,15 +931,31 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

830 (map pexp rhsArgs)) []

931 (map pexp rhsArgs)) []

831 return (pn, pfnTy, PClauses fc [] setname [pclause])

932 return (pn, pfnTy, PClauses fc [] setname [pclause])

832

933

934+ implBindUp [] is t = t

935+ implBindUp ((n, ty):ns) is t

936+ = let n' = case lookup n is of

937+ Just (PRef _ x) -> x

938+ _ -> n in

939+ if n `elem` allNamesIn t

940+ then PPi impl n' ty (implBindUp ns is t)

941+ else implBindUp ns is t

942+

943+-- FIXME: 'forcenames' is an almighty hack! Need a better way of

944+-- erasing non-forceable things

945+-- ^^^

946+-- TODO: the above is a comment from the past;

947+-- forcenames is probably no longer needed

833elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

948elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

834− (String, Name, PTerm, FC, [Name]) -> Idris (Name, Type)

949+ (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)

835−elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

950+elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

836 = do checkUndefined fc n

951 = do checkUndefined fc n

837 ctxt <- getContext

952 ctxt <- getContext

838 i <- getIState

953 i <- getIState

839− t_in <- implicit syn n (if codata then mkLazy t_in else t_in)

954+ t_in <- implicit info syn n (if codata then mkLazy t_in else t_in)

840 let t = addImpl i t_in

955 let t = addImpl i t_in

841 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t

956 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t

957+ let inacc = inaccessibleArgs 0 t

958+ logLvl 5 $ "Inaccessible args: " ++ show inacc

842 ((t', defer, is), log) <-

959 ((t', defer, is), log) <-

843 tclift $ elaborate ctxt n (TType (UVal 0)) []

960 tclift $ elaborate ctxt n (TType (UVal 0)) []

844 (errAt "constructor " n (erun fc (build i info False [] n t)))

961 (errAt "constructor " n (erun fc (build i info False [] n t)))

@@ -853,12 +970,11 @@ elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

853 tyIs cty'

970 tyIs cty'

854 logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty'

971 logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty'

855 addIBC (IBCDef n)

972 addIBC (IBCDef n)

856− addDocStr n doc

973+ checkDocs fc argDocs t_in

974+ addDocStr n doc argDocs

857 addIBC (IBCDoc n)

975 addIBC (IBCDoc n)

858− let fs = map (getNamePos 0 t) forcenames

976+ fputState (opt_inaccessible . ist_optimisation n) inacc

859− -- FIXME: 'forcenames' is an almighty hack! Need a better way of

977+ addIBC (IBCOpt n)

860− -- erasing non-forceable things

861− forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty'

862 return (n, cty')

978 return (n, cty')

863 where

979 where

864 tyIs (Bind n b sc) = tyIs sc

980 tyIs (Bind n b sc) = tyIs sc

@@ -869,12 +985,15 @@ elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

869

985

870 mkLazy (PPi pl n ty sc)

986 mkLazy (PPi pl n ty sc)

871 = let ty' = if getTyName ty

987 = let ty' = if getTyName ty

872− then PApp fc (PRef fc (sUN "Lazy")) [pexp ty]

988+ then PApp fc (PRef fc (sUN "Lazy'"))

989+ [pexp (PRef fc (sUN "LazyCodata")),

990+ pexp ty]

873 else ty in

991 else ty in

874 PPi pl n ty' (mkLazy sc)

992 PPi pl n ty' (mkLazy sc)

875 mkLazy t = t

993 mkLazy t = t

876

994

877 getTyName (PApp _ (PRef _ n) _) = n == nsroot tn

995 getTyName (PApp _ (PRef _ n) _) = n == nsroot tn

996+ getTyName (PRef _ n) = n == nsroot tn

878 getTyName _ = False

997 getTyName _ = False

879

998

880

999

@@ -888,6 +1007,9 @@ elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

888elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

1007elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

889elabClauses info fc opts n_in cs = let n = liftname info n_in in

1008elabClauses info fc opts n_in cs = let n = liftname info n_in in

890 do ctxt <- getContext

1009 do ctxt <- getContext

1010+ ist <- getIState

1011+ inacc <- map fst <$> fgetState (opt_inaccessible . ist_optimisation n)

1012+

891 -- Check n actually exists, with no definition yet

1013 -- Check n actually exists, with no definition yet

892 let tys = lookupTy n ctxt

1014 let tys = lookupTy n ctxt

893 let reflect = Reflection `elem` opts

1015 let reflect = Reflection `elem` opts

@@ -899,33 +1021,18 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

899 tclift $ tfail $ At fc (NoTypeDecl n)

1021 tclift $ tfail $ At fc (NoTypeDecl n)

900 [ty] -> return ty

1022 [ty] -> return ty

901 let atys = map snd (getArgTys fty)

1023 let atys = map snd (getArgTys fty)

902− pats_in <- mapM (elabClause info opts)

1024+ cs_elab <- mapM (elabClause info opts)

903 (zip [0..] cs)

1025 (zip [0..] cs)

1026+ let (pats_in, cs_full) = unzip cs_elab

1027+

904 logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in

1028 logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in

905

1029

906− -- if the return type of 'ty' is collapsible, the optimised version should

907− -- just do nothing

908− ist <- getIState

909− let (ap, _) = unApply (getRetTy fty)

910− logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

911− -- FIXME: Really ought to only do this for total functions!

912− let doNothing = case ap of

913− P _ tn _ -> case lookupCtxt tn

914− (idris_optimisation ist) of

915− [oi] -> collapsible oi

916− _ -> False

917− _ -> False

918 solveDeferred n

1030 solveDeferred n

919− ist <- getIState

1031+

920− when doNothing $

1032+ -- just ensure that the structure exists

921− case lookupCtxt n (idris_optimisation ist) of

1033+ fmodifyState (ist_optimisation n) id

922− [oi] -> do let opts = addDef n (oi { collapsible = True })

1034+ addIBC (IBCOpt n)

923− (idris_optimisation ist)

1035+

924− putIState (ist { idris_optimisation = opts })

925− _ -> do let opts = addDef n (Optimise True False [] [])

926− (idris_optimisation ist)

927− putIState (ist { idris_optimisation = opts })

928− addIBC (IBCOpt n)

929 ist <- getIState

1036 ist <- getIState

930 let pats = map (simple_lhs (tt_ctxt ist)) $ doTransforms ist pats_in

1037 let pats = map (simple_lhs (tt_ctxt ist)) $ doTransforms ist pats_in

931

1038

@@ -935,11 +1042,8 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

935 let tcase = opt_typecase (idris_options ist)

1042 let tcase = opt_typecase (idris_options ist)

936

1043

937 -- Summary of what's about to happen: Definitions go:

1044 -- Summary of what's about to happen: Definitions go:

938−

1045+ --

939− -- pats_in -> pats -> optpats

1046+ -- pats_in -> pats -> pdef -> pdef'

940− -- pdef comes from pats,

941− -- optpdef comes from optpats

942− -- Then pdef' is optpdef with forcing/collapsing applied everywhere

943

1047

944 -- addCaseDef builds case trees from <pdef> and <pdef'>

1048 -- addCaseDef builds case trees from <pdef> and <pdef'>

945

1049

@@ -968,24 +1072,16 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

968

1072

969 numArgs <- tclift $ sameLength pdef

1073 numArgs <- tclift $ sameLength pdef

970

1074

971− -- patterns after collapsing optimisation applied

972− -- (i.e. check if the function should do nothing at run time)

973− optpats <- if doNothing

974− then return $ [Right (mkApp (P Bound n Erased)

975− (take numArgs (repeat Erased)), Erased)]

976− else stripCollapsed pats

977−

978 case specNames opts of

1075 case specNames opts of

979 Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats

1076 Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats

980 _ -> return ()

1077 _ -> return ()

981

1078

982− let optpdef = map debind optpats -- \$ map (simple_lhs (tt_ctxt ist)) optpats

983 tree@(CaseDef scargs sc _) <- tclift $

1079 tree@(CaseDef scargs sc _) <- tclift $

984− simpleCase tcase False reflect CompileTime fc atys pdef

1080+ simpleCase tcase False reflect CompileTime fc inacc atys pdef

985 cov <- coverage

1081 cov <- coverage

986 pmissing <-

1082 pmissing <-

987− if cov

1083+ if cov && not (hasDefault cs)

988− then do missing <- genClauses fc n (map getLHS pdef) cs

1084+ then do missing <- genClauses fc n (map getLHS pdef) cs_full

989 -- missing <- genMissing n scargs sc

1085 -- missing <- genMissing n scargs sc

990 missing' <- filterM (checkPossible info fc True n) missing

1086 missing' <- filterM (checkPossible info fc True n) missing

991 let clhs = map getLHS pdef

1087 let clhs = map getLHS pdef

@@ -1003,7 +1099,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1003 let pcover = null pmissing

1099 let pcover = null pmissing

1004

1100

1005 -- pdef' is the version that gets compiled for run-time

1101 -- pdef' is the version that gets compiled for run-time

1006− pdef_in' <- applyOpts optpdef

1102+ pdef_in' <- applyOpts pdef

1007 let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'

1103 let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'

1008

1104

1009 logLvl 5 $ "After data structure transformations:\n" ++ show pdef'

1105 logLvl 5 $ "After data structure transformations:\n" ++ show pdef'

@@ -1013,6 +1109,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1013 let tot = if pcover || AssertTotal `elem` opts

1109 let tot = if pcover || AssertTotal `elem` opts

1014 then Unchecked -- finish checking later

1110 then Unchecked -- finish checking later

1015 else Partial NotCovering -- already know it's not total

1111 else Partial NotCovering -- already know it's not total

1112+

1016 -- case lookupCtxt (namespace info) n (idris_flags ist) of

1113 -- case lookupCtxt (namespace info) n (idris_flags ist) of

1017 -- [fs] -> if TotalFn `elem` fs

1114 -- [fs] -> if TotalFn `elem` fs

1018 -- then case tot of

1115 -- then case tot of

@@ -1029,11 +1126,12 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1029 let knowncovering = (pcover && cov) || AssertTotal `elem` opts

1126 let knowncovering = (pcover && cov) || AssertTotal `elem` opts

1030

1127

1031 tree' <- tclift $ simpleCase tcase knowncovering reflect

1128 tree' <- tclift $ simpleCase tcase knowncovering reflect

1032− RunTime fc atys pdef'

1129+ RunTime fc inacc atys pdef'

1033− logLvl 3 (show tree)

1130+ logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree

1034 logLvl 3 $ "Optimised: " ++ show tree'

1131 logLvl 3 $ "Optimised: " ++ show tree'

1035 ctxt <- getContext

1132 ctxt <- getContext

1036 ist <- getIState

1133 ist <- getIState

1134+ let opt = idris_optimisation ist

1037 putIState (ist { idris_patdefs = addDef n (force pdef', force pmissing)

1135 putIState (ist { idris_patdefs = addDef n (force pdef', force pmissing)

1038 (idris_patdefs ist) })

1136 (idris_patdefs ist) })

1039 let caseInfo = CaseInfo (inlinable opts) (dictionary opts)

1137 let caseInfo = CaseInfo (inlinable opts) (dictionary opts)

@@ -1043,6 +1141,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1043 reflect

1141 reflect

1044 (AssertTotal `elem` opts)

1142 (AssertTotal `elem` opts)

1045 atys

1143 atys

1144+ inacc

1046 pats

1145 pats

1047 pdef pdef pdef_inl pdef' ty)

1146 pdef pdef pdef_inl pdef' ty)

1048 addIBC (IBCDef n)

1147 addIBC (IBCDef n)

@@ -1059,7 +1158,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1059 let used = findUsedArgs sc' scargs'

1158 let used = findUsedArgs sc' scargs'

1060 -- let scg = buildSCG i sc scargs

1159 -- let scg = buildSCG i sc scargs

1061 -- add SCG later, when checking totality

1160 -- add SCG later, when checking totality

1062− let cg = CGInfo scargs' calls [] used []

1161+ let cg = CGInfo scargs' calls [] used [] -- TODO: remove this, not needed anymore

1063 logLvl 2 $ "Called names: " ++ show cg

1162 logLvl 2 $ "Called names: " ++ show cg

1064 addToCG n cg

1163 addToCG n cg

1065 addToCalledG n (nub (map fst calls)) -- plus names in type!

1164 addToCalledG n (nub (map fst calls)) -- plus names in type!

@@ -1068,7 +1167,10 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1068 return ()

1167 return ()

1069 -- addIBC (IBCTotal n tot)

1168 -- addIBC (IBCTotal n tot)

1070 [] -> return ()

1169 [] -> return ()

1071− return ()

1170+ -- Check it's covering, if 'covering' option is used. Chase

1171+ -- all called functions, and fail if any of them are also

1172+ -- 'Partial NotCovering'

1173+ when (CoveringFn `elem` opts) $ checkAllCovering fc [] n n

1072 where

1174 where

1073 noMatch i cs tm = all (\x -> case matchClause i (delab' i x True True) tm of

1175 noMatch i cs tm = all (\x -> case matchClause i (delab' i x True True) tm of

1074 Right _ -> False

1176 Right _ -> False

@@ -1088,13 +1190,18 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1088 depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)

1190 depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)

1089 depat acc x = (acc, x)

1191 depat acc x = (acc, x)

1090

1192

1193+ hasDefault cs | (PClause _ _ last _ _ _ :_) <- reverse cs

1194+ , (PApp fn s args) <- last = all ((==Placeholder) . getTm) args

1195+ hasDefault _ = False

1196+

1091 getLHS (_, l, _) = l

1197 getLHS (_, l, _) = l

1092

1198

1093 simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x,

1199 simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x,

1094 force (normalisePats ctxt [] y))

1200 force (normalisePats ctxt [] y))

1095 simple_lhs ctxt t = t

1201 simple_lhs ctxt t = t

1096

1202

1097− simple_rt ctxt (p, x, y) = (p, x, force (rt_simplify ctxt [] y))

1203+ simple_rt ctxt (p, x, y) = (p, x, force (uniqueBinders p

1204+ (rt_simplify ctxt [] y)))

1098

1205

1099 -- this is so pattern types are in the right form for erasure

1206 -- this is so pattern types are in the right form for erasure

1100 normalisePats ctxt env (Bind n (PVar t) sc)

1207 normalisePats ctxt env (Bind n (PVar t) sc)

@@ -1158,10 +1265,10 @@ elabPE info fc caller r =

1158 (map (\ (lhs, rhs) ->

1265 (map (\ (lhs, rhs) ->

1159 (showTmImpls lhs ++ " = " ++

1266 (showTmImpls lhs ++ " = " ++

1160 showTmImpls rhs)) pats)

1267 showTmImpls rhs)) pats)

1161− elabType info defaultSyntax "" fc opts newnm specTy

1268+ elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy

1162 let def = map (\ (lhs, rhs) -> PClause fc newnm lhs [] rhs []) pats

1269 let def = map (\ (lhs, rhs) -> PClause fc newnm lhs [] rhs []) pats

1163 elabClauses info fc opts newnm def

1270 elabClauses info fc opts newnm def

1164− logLvl 1 $ "Specialised " ++ show newnm)

1271+ logLvl 2 $ "Specialised " ++ show newnm)

1165 -- if it doesn't work, just don't specialise. Could happen for lots

1272 -- if it doesn't work, just don't specialise. Could happen for lots

1166 -- of valid reasons (e.g. local variables in scope which can't be

1273 -- of valid reasons (e.g. local variables in scope which can't be

1167 -- lifted out).

1274 -- lifted out).

@@ -1206,8 +1313,8 @@ elabPE info fc caller r =

1206

1313

1207-- Elaborate a value, returning any new bindings created (this will only

1314-- Elaborate a value, returning any new bindings created (this will only

1208-- happen if elaborating as a pattern clause)

1315-- happen if elaborating as a pattern clause)

1209−elabValBind :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type, [(Name, Type)])

1316+elabValBind :: ElabInfo -> Bool -> Bool -> PTerm -> Idris (Term, Type, [(Name, Type)])

1210−elabValBind info aspat tm_in

1317+elabValBind info aspat norm tm_in

1211 = do ctxt <- getContext

1318 = do ctxt <- getContext

1212 i <- getIState

1319 i <- getIState

1213 let tm = addImpl i tm_in

1320 let tm = addImpl i tm_in

@@ -1232,14 +1339,17 @@ elabValBind info aspat tm_in

1232 logLvl 3 ("Value: " ++ show vtm)

1339 logLvl 3 ("Value: " ++ show vtm)

1233-- recheckC (fileFC "(input)") [] tm'

1340-- recheckC (fileFC "(input)") [] tm'

1234-- logLvl 2 (show vtm)

1341-- logLvl 2 (show vtm)

1235− (vtm, vty) <- recheckC (fileFC "(input)") [] vtm

1342+ (vtm_in, vty) <- recheckC (fileFC "(input)") [] vtm

1343+

1344+ let vtm = if norm then normalise (tt_ctxt i) [] vtm_in

1345+ else vtm_in

1236 let bargs = getPBtys vtm

1346 let bargs = getPBtys vtm

1237

1347

1238 return (vtm, vty, bargs)

1348 return (vtm, vty, bargs)

1239

1349

1240elabVal :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type)

1350elabVal :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type)

1241elabVal info aspat tm_in

1351elabVal info aspat tm_in

1242− = do (tm, ty, _) <- elabValBind info aspat tm_in

1352+ = do (tm, ty, _) <- elabValBind info aspat False tm_in

1243 return (tm, ty)

1353 return (tm, ty)

1244

1354

1245-- checks if the clause is a possible left hand side. Returns the term if

1355-- checks if the clause is a possible left hand side. Returns the term if

@@ -1249,7 +1359,7 @@ checkPossible :: ElabInfo -> FC -> Bool -> Name -> PTerm -> Idris Bool

1249checkPossible info fc tcgen fname lhs_in

1359checkPossible info fc tcgen fname lhs_in

1250 = do ctxt <- getContext

1360 = do ctxt <- getContext

1251 i <- getIState

1361 i <- getIState

1252− let lhs = addImpl i lhs_in

1362+ let lhs = addImplPat i lhs_in

1253 -- if the LHS type checks, it is possible

1363 -- if the LHS type checks, it is possible

1254 case elaborate ctxt (sMN 0 "patLHS") infP []

1364 case elaborate ctxt (sMN 0 "patLHS") infP []

1255 (erun fc (buildTC i info True [] fname (infTerm lhs))) of

1365 (erun fc (buildTC i info True [] fname (infTerm lhs))) of

@@ -1258,24 +1368,53 @@ checkPossible info fc tcgen fname lhs_in

1258 case recheck ctxt [] (forget lhs_tm) lhs_tm of

1368 case recheck ctxt [] (forget lhs_tm) lhs_tm of

1259 OK _ -> return True

1369 OK _ -> return True

1260 err -> return False

1370 err -> return False

1261−

1371+ -- if it's a recoverable error, the case may become possible

1262−-- b <- inferredDiff fc (delab' i lhs_tm True) lhs

1372+ Error err -> if tcgen then return (recoverable ctxt err)

1263−-- return (not b) -- then return (Just lhs_tm) else return Nothing

1373+ else return (validCase ctxt err ||

1264−-- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)

1374+ recoverable ctxt err)

1265− Error err -> if tcgen then return False

1375+ where validCase ctxt (CantUnify _ topx topy e _ _)

1266− else return (impossibleError err)

1376+ = let topx' = normalise ctxt [] topx

1267− where impossibleError (CantUnify _ topx topy e _ _)

1377+ topy' = normalise ctxt [] topy in

1268− = not (sameFam topx topy || not (impossibleError e))

1378+ not (sameFam topx' topy' || not (validCase ctxt e))

1269− impossibleError (CantConvert _ _ _) = False

1379+ validCase ctxt (CantConvert _ _ _) = False

1270− impossibleError (At _ e) = impossibleError e

1380+ validCase ctxt (At _ e) = validCase ctxt e

1271− impossibleError (Elaborating _ _ e) = impossibleError e

1381+ validCase ctxt (Elaborating _ _ e) = validCase ctxt e

1272− impossibleError _ = True

1382+ validCase ctxt (ElaboratingArg _ _ _ e) = validCase ctxt e

1383+ validCase ctxt _ = True

1384+

1385+ recoverable ctxt (CantUnify r topx topy e _ _)

1386+ = let topx' = normalise ctxt [] topx

1387+ topy' = normalise ctxt [] topy in

1388+ checkRec topx' topy'

1389+ recoverable ctxt (At _ e) = recoverable ctxt e

1390+ recoverable ctxt (Elaborating _ _ e) = recoverable ctxt e

1391+ recoverable ctxt (ElaboratingArg _ _ _ e) = recoverable ctxt e

1392+ recoverable _ _ = False

1273

1393

1274 sameFam topx topy

1394 sameFam topx topy

1275 = case (unApply topx, unApply topy) of

1395 = case (unApply topx, unApply topy) of

1276 ((P _ x _, _), (P _ y _, _)) -> x == y

1396 ((P _ x _, _), (P _ y _, _)) -> x == y

1277 _ -> False

1397 _ -> False

1278

1398

1399+ -- different notion of recoverable than in unification, since we

1400+ -- have no metavars -- just looking to see if a constructor is failing

1401+ -- to unify with a function that may be reduced later

1402+

1403+ checkRec (App f a) p@(P _ _ _) = checkRec f p

1404+ checkRec p@(P _ _ _) (App f a) = checkRec p f

1405+ checkRec fa@(App _ _) fa'@(App _ _)

1406+ | (f, as) <- unApply fa,

1407+ (f', as') <- unApply fa'

1408+ = if (length as /= length as')

1409+ then checkRec f f'

1410+ else checkRec f f' && and (zipWith checkRec as as')

1411+ checkRec (P xt x _) (P yt y _) = x == y || ntRec xt yt

1412+ checkRec _ _ = False

1413+

1414+ ntRec x y | Ref <- x = True

1415+ | Ref <- y = True

1416+ | otherwise = False -- name is different, unrecoverable

1417+

1279getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)

1418getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)

1280 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

1419 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

1281getFixedInType i env (_ : is) (Bind n (Pi t) sc)

1420getFixedInType i env (_ : is) (Bind n (Pi t) sc)

@@ -1338,16 +1477,19 @@ propagateParams ps t (PRef fc n)

1338 = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)

1477 = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)

1339propagateParams ps t x = x

1478propagateParams ps t x = x

1340

1479

1480+-- Return the elaborated LHS/RHS, and the original LHS with implicits added

1341elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

1481elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

1342− Idris (Either Term (Term, Term))

1482+ Idris (Either Term (Term, Term), PTerm)

1343elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

1483elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

1344 = do let tcgen = Dictionary `elem` opts

1484 = do let tcgen = Dictionary `elem` opts

1485+ i <- get

1486+ let lhs = addImpl i lhs_in

1345 b <- checkPossible info fc tcgen fname lhs_in

1487 b <- checkPossible info fc tcgen fname lhs_in

1346 case b of

1488 case b of

1347 True -> tclift $ tfail (At fc

1489 True -> tclift $ tfail (At fc

1348 (Msg $ show lhs_in ++ " is a valid case"))

1490 (Msg $ show lhs_in ++ " is a valid case"))

1349 False -> do ptm <- mkPatTm lhs_in

1491 False -> do ptm <- mkPatTm lhs_in

1350− return (Left ptm)

1492+ return (Left ptm, lhs)

1351elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1493elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1352 = do let tcgen = Dictionary `elem` opts

1494 = do let tcgen = Dictionary `elem` opts

1353 ctxt <- getContext

1495 ctxt <- getContext

@@ -1378,7 +1520,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1378 inj <- get_inj

1520 inj <- get_inj

1379 return (res, probs, inj))

1521 return (res, probs, inj))

1380

1522

1381− when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_) -> (x,y)) probs)

1523+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)

1382

1524

1383 let lhs_tm = orderPats (getInferTerm lhs')

1525 let lhs_tm = orderPats (getInferTerm lhs')

1384 let lhs_ty = getInferType lhs'

1526 let lhs_ty = getInferType lhs'

@@ -1397,17 +1539,17 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1397

1539

1398 rep <- useREPL

1540 rep <- useREPL

1399 when rep $ do

1541 when rep $ do

1400− addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1542+ addInternalApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs) -- TODO: Should use span instead of line and filename?

1401− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (delabMV i clhs))

1543+ addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs))

1402

1544

1403 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

1545 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

1404 -- Elaborate where block

1546 -- Elaborate where block

1405 ist <- getIState

1547 ist <- getIState

1406 windex <- getName

1548 windex <- getName

1407− let winfo = pinfo (pvars ist lhs_tm) whereblock windex

1408 let decls = nub (concatMap declared whereblock)

1549 let decls = nub (concatMap declared whereblock)

1409 let defs = nub (decls ++ concatMap defined whereblock)

1550 let defs = nub (decls ++ concatMap defined whereblock)

1410 let newargs = pvars ist lhs_tm

1551 let newargs = pvars ist lhs_tm

1552+ let winfo = pinfo info newargs defs windex

1411 let wb = map (expandParamsD False ist decorate newargs defs) whereblock

1553 let wb = map (expandParamsD False ist decorate newargs defs) whereblock

1412

1554

1413 -- Split the where block into declarations with a type, and those

1555 -- Split the where block into declarations with a type, and those

@@ -1415,8 +1557,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1415 -- Elaborate those with a type *before* RHS, those without *after*

1557 -- Elaborate those with a type *before* RHS, those without *after*

1416 let (wbefore, wafter) = sepBlocks wb

1558 let (wbefore, wafter) = sepBlocks wb

1417

1559

1418− logLvl 1 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter

1560+ logLvl 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter

1419− mapM_ (elabDecl' EAll info) wbefore

1561+ mapM_ (elabDecl' EAll winfo) wbefore

1420 -- Now build the RHS, using the type of the LHS as the goal.

1562 -- Now build the RHS, using the type of the LHS as the goal.

1421 i <- getIState -- new implicits from where block

1563 i <- getIState -- new implicits from where block

1422 logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))

1564 logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))

@@ -1431,7 +1573,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1431 mapM_ setinj (nub (params ++ inj))

1573 mapM_ setinj (nub (params ++ inj))

1432 setNextName

1574 setNextName

1433 (_, _, is) <- errAt "right hand side of " fname

1575 (_, _, is) <- errAt "right hand side of " fname

1434− (erun fc (build i info False opts fname rhs))

1576+ (erun fc (build i winfo False opts fname rhs))

1435 errAt "right hand side of " fname

1577 errAt "right hand side of " fname

1436 (erun fc $ psolve lhs_tm)

1578 (erun fc $ psolve lhs_tm)

1437 hs <- get_holes

1579 hs <- get_holes

@@ -1442,14 +1584,16 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1442 probs <- get_probs

1584 probs <- get_probs

1443 return (tm, ds, is, probs))

1585 return (tm, ds, is, probs))

1444

1586

1445− when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_) -> (x,y)) probs)

1587+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)

1446

1588

1447 logLvl 5 "DONE CHECK"

1589 logLvl 5 "DONE CHECK"

1448 logLvl 2 $ "---> " ++ show rhs'

1590 logLvl 2 $ "---> " ++ show rhs'

1449− when (not (null defer)) $ iLOG $ "DEFERRED " ++ show (map fst defer)

1591+ when (not (null defer)) $ iLOG $ "DEFERRED " ++

1592+ show (map (\ (n, (_,_,t)) -> (n, t)) defer)

1450 def' <- checkDef fc defer

1593 def' <- checkDef fc defer

1451 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

1594 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

1452 addDeferred def''

1595 addDeferred def''

1596+ mapM_ (\(n, _) -> addIBC (IBCDef n)) def''

1453

1597

1454 when (not (null def')) $ do

1598 when (not (null def')) $ do

1455 mapM_ defer_totcheck (map (\x -> (fc, fst x)) def'')

1599 mapM_ defer_totcheck (map (\x -> (fc, fst x)) def'')

@@ -1457,8 +1601,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1457 -- Now the remaining deferred (i.e. no type declarations) clauses

1601 -- Now the remaining deferred (i.e. no type declarations) clauses

1458 -- from the where block

1602 -- from the where block

1459

1603

1460− mapM_ (elabDecl' EAll info) wafter

1604+ mapM_ (elabDecl' EAll winfo) wafter

1461− mapM_ (elabCaseBlock info opts) is

1605+ mapM_ (elabCaseBlock winfo opts) is

1462

1606

1463 ctxt <- getContext

1607 ctxt <- getContext

1464 logLvl 5 $ "Rechecking"

1608 logLvl 5 $ "Rechecking"

@@ -1478,7 +1622,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1478 rev <- case ret_fam of

1622 rev <- case ret_fam of

1479 P _ rfamn _ ->

1623 P _ rfamn _ ->

1480 case lookupCtxt rfamn (idris_datatypes i) of

1624 case lookupCtxt rfamn (idris_datatypes i) of

1481− [TI _ _ dopts _] ->

1625+ [TI _ _ dopts _ _] ->

1482 return (DataErrRev `elem` dopts)

1626 return (DataErrRev `elem` dopts)

1483 _ -> return False

1627 _ -> return False

1484 _ -> return False

1628 _ -> return False

@@ -1486,8 +1630,21 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1486 when (rev || ErrorReverse `elem` opts) $ do

1630 when (rev || ErrorReverse `elem` opts) $ do

1487 addIBC (IBCErrRev (crhs, clhs))

1631 addIBC (IBCErrRev (crhs, clhs))

1488 addErrRev (crhs, clhs)

1632 addErrRev (crhs, clhs)

1489− return $ Right (clhs, crhs)

1633+ return $ (Right (clhs, crhs), lhs)

1490 where

1634 where

1635+ pinfo :: ElabInfo -> [(Name, PTerm)] -> [Name] -> Int -> ElabInfo

1636+ pinfo info ns ds i

1637+ = let newps = params info ++ ns

1638+ dsParams = map (\n -> (n, map fst newps)) ds

1639+ newb = addAlist dsParams (inblock info)

1640+ l = liftname info in

1641+ info { params = newps,

1642+ inblock = newb,

1643+ liftname = id -- (\n -> case lookupCtxt n newb of

1644+ -- Nothing -> n

1645+ -- _ -> MN i (show n)) . l

1646+ }

1647+

1491 mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t []

1648 mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t []

1492 mkLHSapp t = t

1649 mkLHSapp t = t

1493

1650

@@ -1500,7 +1657,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1500-- = NS (UN ('#':show x)) [show cnum, show fname]

1657-- = NS (UN ('#':show x)) [show cnum, show fname]

1501

1658

1502 sepBlocks bs = sepBlocks' [] bs where

1659 sepBlocks bs = sepBlocks' [] bs where

1503− sepBlocks' ns (d@(PTy _ _ _ _ n t) : bs)

1660+ sepBlocks' ns (d@(PTy _ _ _ _ _ n t) : bs)

1504 = let (bf, af) = sepBlocks' (n : ns) bs in

1661 = let (bf, af) = sepBlocks' (n : ns) bs in

1505 (d : bf, af)

1662 (d : bf, af)

1506 sepBlocks' ns (d@(PClauses _ _ n _) : bs)

1663 sepBlocks' ns (d@(PClauses _ _ n _) : bs)

@@ -1510,19 +1667,6 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1510 (b : bf, af)

1667 (b : bf, af)

1511 sepBlocks' ns [] = ([], [])

1668 sepBlocks' ns [] = ([], [])

1512

1669

1513− pinfo ns ps i

1514− = let ds = concatMap declared ps

1515− newps = params info ++ ns

1516− dsParams = map (\n -> (n, map fst newps)) ds

1517− newb = addAlist dsParams (inblock info)

1518− l = liftname info in

1519− info { params = newps,

1520− inblock = newb,

1521− liftname = id -- (\n -> case lookupCtxt n newb of

1522− -- Nothing -> n

1523− -- _ -> MN i (show n)) . l

1524− }

1525−

1526

1670

1527 -- if a hole is just an argument/result of a case block, treat it as

1671 -- if a hole is just an argument/result of a case block, treat it as

1528 -- the unit type. Hack to help elaborate case in do blocks.

1672 -- the unit type. Hack to help elaborate case in do blocks.

@@ -1559,7 +1703,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1559 _ -> []

1703 _ -> []

1560 let params = getParamsInType i [] fn_is fn_ty

1704 let params = getParamsInType i [] fn_is fn_ty

1561 let lhs = propagateParams params fn_ty (addImplPat i (stripLinear i lhs_in))

1705 let lhs = propagateParams params fn_ty (addImplPat i (stripLinear i lhs_in))

1562− logLvl 1 ("LHS: " ++ show lhs)

1706+ logLvl 2 ("LHS: " ++ show lhs)

1563 ((lhs', dlhs, []), _) <-

1707 ((lhs', dlhs, []), _) <-

1564 tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

1708 tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

1565 (errAt "left hand side of with in " fname

1709 (errAt "left hand side of with in " fname

@@ -1589,6 +1733,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1589 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

1733 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

1590 addDeferred def''

1734 addDeferred def''

1591 mapM_ (elabCaseBlock info opts) is

1735 mapM_ (elabCaseBlock info opts) is

1736+ logLvl 5 ("Checked wval " ++ show wval')

1592 (cwval, cwvalty) <- recheckC fc [] (getInferTerm wval')

1737 (cwval, cwvalty) <- recheckC fc [] (getInferTerm wval')

1593 let cwvaltyN = explicitNames cwvalty

1738 let cwvaltyN = explicitNames cwvalty

1594 let cwvalN = explicitNames cwval

1739 let cwvalN = explicitNames cwval

@@ -1653,7 +1798,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1653 mapM_ (elabCaseBlock info opts) is

1798 mapM_ (elabCaseBlock info opts) is

1654 logLvl 5 ("Checked RHS " ++ show rhs')

1799 logLvl 5 ("Checked RHS " ++ show rhs')

1655 (crhs, crhsty) <- recheckC fc [] rhs'

1800 (crhs, crhsty) <- recheckC fc [] rhs'

1656− return $ Right (clhs, crhs)

1801+ return $ (Right (clhs, crhs), lhs)

1657 where

1802 where

1658 getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t

1803 getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t

1659 getImps _ = []

1804 getImps _ = []

@@ -1687,7 +1832,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1687 do lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

1832 do lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

1688 return $ PWith fc wname lhs ws wval withs'

1833 return $ PWith fc wname lhs ws wval withs'

1689 mkAux wname toplhs ns ns' c

1834 mkAux wname toplhs ns ns' c

1690− = ifail $ show fc ++ "badly formed with clause"

1835+ = ifail $ show fc ++ ":badly formed with clause"

1691

1836

1692 addArg (PApp fc f args) w = PApp fc f (args ++ [pexp w])

1837 addArg (PApp fc f args) w = PApp fc f (args ++ [pexp w])

1693 addArg (PRef fc f) w = PApp fc (PRef fc f) [pexp w]

1838 addArg (PRef fc f) w = PApp fc (PRef fc f) [pexp w]

@@ -1698,8 +1843,8 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1698 return $ substMatches mvars $

1843 return $ substMatches mvars $

1699 PApp fc (PRef fc' wname)

1844 PApp fc (PRef fc' wname)

1700 (map pexp ns ++ pexp w : (map pexp ns'))

1845 (map pexp ns ++ pexp w : (map pexp ns'))

1701− updateLHS n wname mvars ns ns' tm w

1846+ updateLHS n wname mvars ns_in ns_in' tm w

1702− = ifail $ "Not implemented match " ++ show tm

1847+ = updateLHS n wname mvars ns_in ns_in' (PApp fc tm []) w

1703

1848

1704 keepMvar mvs fc v | v `elem` mvs = PRef fc v

1849 keepMvar mvs fc v | v `elem` mvs = PRef fc v

1705 | otherwise = Placeholder

1850 | otherwise = Placeholder

@@ -1717,10 +1862,10 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1717

1862

1718data MArgTy = IA | EA | CA deriving Show

1863data MArgTy = IA | EA | CA deriving Show

1719

1864

1720−elabClass :: ElabInfo -> SyntaxInfo -> String ->

1865+elabClass :: ElabInfo -> SyntaxInfo -> Docstring ->

1721 FC -> [PTerm] ->

1866 FC -> [PTerm] ->

1722− Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

1867+ Name -> [(Name, PTerm)] -> [(Name, Docstring)] -> [PDecl] -> Idris ()

1723−elabClass info syn doc fc constraints tn ps ds

1868+elabClass info syn doc fc constraints tn ps pDocs ds

1724 = do let cn = SN (InstanceCtorN tn) -- sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)

1869 = do let cn = SN (InstanceCtorN tn) -- sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)

1725 let tty = pibind ps PType

1870 let tty = pibind ps PType

1726 let constraint = PApp fc (PRef fc tn)

1871 let constraint = PApp fc (PRef fc tn)

@@ -1744,10 +1889,10 @@ elabClass info syn doc fc constraints tn ps ds

1744 let cty = impbind ps $ conbind constraints

1889 let cty = impbind ps $ conbind constraints

1745 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

1890 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

1746 constraint

1891 constraint

1747− let cons = [("", cn, cty, fc, [])]

1892+ let cons = [(emptyDocstring, [], cn, cty, fc, [])]

1748 let ddecl = PDatadecl tn tty cons

1893 let ddecl = PDatadecl tn tty cons

1749− logLvl 5 $ "Class data " ++ show (showDImp True ddecl)

1894+ logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)

1750− elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc [] ddecl

1895+ elabData info (syn { no_imp = no_imp syn ++ mnames }) doc pDocs fc [] ddecl

1751 -- for each constraint, build a top level function to chase it

1896 -- for each constraint, build a top level function to chase it

1752 logLvl 5 $ "Building functions"

1897 logLvl 5 $ "Building functions"

1753 let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps

1898 let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps

@@ -1785,9 +1930,9 @@ elabClass info syn doc fc constraints tn ps ds

1785 conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

1930 conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

1786 conbind [] x = x

1931 conbind [] x = x

1787

1932

1788− getMName (PTy _ _ _ _ n _) = nsroot n

1933+ getMName (PTy _ _ _ _ _ n _) = nsroot n

1789− tdecl allmeths (PTy doc syn _ o n t)

1934+ tdecl allmeths (PTy doc _ syn _ o n t)

1790− = do t' <- implicit' syn allmeths n t

1935+ = do t' <- implicit' info syn allmeths n t

1791 logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

1936 logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

1792 return ( (n, (toExp (map fst ps) Exp t')),

1937 return ( (n, (toExp (map fst ps) Exp t')),

1793 (n, (doc, o, (toExp (map fst ps) Imp t'))),

1938 (n, (doc, o, (toExp (map fst ps) Imp t'))),

@@ -1799,7 +1944,7 @@ elabClass info syn doc fc constraints tn ps ds

1799 case lookup n mtys of

1944 case lookup n mtys of

1800 Just (syn, o, ty) -> do let ty' = insertConstraint c ty

1945 Just (syn, o, ty) -> do let ty' = insertConstraint c ty

1801 let ds = map (decorateid defaultdec)

1946 let ds = map (decorateid defaultdec)

1802− [PTy "" syn fc [] n ty',

1947+ [PTy emptyDocstring [] syn fc [] n ty',

1803 PClauses fc (o ++ opts) n cs]

1948 PClauses fc (o ++ opts) n cs]

1804 iLOG (show ds)

1949 iLOG (show ds)

1805 return (n, ((defaultdec n, ds!!1), ds))

1950 return (n, ((defaultdec n, ds!!1), ds))

@@ -1809,7 +1954,7 @@ elabClass info syn doc fc constraints tn ps ds

1809 defaultdec (UN n) = sUN ("default#" ++ str n)

1954 defaultdec (UN n) = sUN ("default#" ++ str n)

1810 defaultdec (NS n ns) = NS (defaultdec n) ns

1955 defaultdec (NS n ns) = NS (defaultdec n) ns

1811

1956

1812− tydecl (PTy _ _ _ _ _ _) = True

1957+ tydecl (PTy _ _ _ _ _ _ _) = True

1813 tydecl _ = False

1958 tydecl _ = False

1814 instdecl (PInstance _ _ _ _ _ _ _ _) = True

1959 instdecl (PInstance _ _ _ _ _ _ _ _) = True

1815 instdecl _ = False

1960 instdecl _ = False

@@ -1837,7 +1982,7 @@ elabClass info syn doc fc constraints tn ps ds

1837 addInstance False conn' cfn

1982 addInstance False conn' cfn

1838 addIBC (IBCInstance False conn' cfn)

1983 addIBC (IBCInstance False conn' cfn)

1839-- iputStrLn ("Added " ++ show (conn, cfn, ty))

1984-- iputStrLn ("Added " ++ show (conn, cfn, ty))

1840− return [PTy "" syn fc [] cfn ty,

1985+ return [PTy emptyDocstring [] syn fc [] cfn ty,

1841 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

1986 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

1842

1987

1843 -- Generate a top level function which looks up a method in a given

1988 -- Generate a top level function which looks up a method in a given

@@ -1853,35 +1998,35 @@ elabClass info syn doc fc constraints tn ps ds

1853 iLOG (showTmImpls ty)

1998 iLOG (showTmImpls ty)

1854 iLOG (show (m, ty', capp, margs))

1999 iLOG (show (m, ty', capp, margs))

1855 iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

2000 iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

1856− return [PTy doc syn fc o m ty',

2001+ return [PTy doc [] syn fc o m ty',

1857 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

2002 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

1858

2003

1859− getMArgs (PPi (Imp _ _ _ _) n ty sc) = IA : getMArgs sc

2004+ getMArgs (PPi (Imp _ _ _) n ty sc) = IA : getMArgs sc

1860− getMArgs (PPi (Exp _ _ _ _) n ty sc) = EA : getMArgs sc

2005+ getMArgs (PPi (Exp _ _ _) n ty sc) = EA : getMArgs sc

1861− getMArgs (PPi (Constraint _ _ _) n ty sc) = CA : getMArgs sc

2006+ getMArgs (PPi (Constraint _ _) n ty sc) = CA : getMArgs sc

1862 getMArgs _ = []

2007 getMArgs _ = []

1863

2008

1864 getMeth (m:ms) (a:as) x | x == a = PRef fc m

2009 getMeth (m:ms) (a:as) x | x == a = PRef fc m

1865 | otherwise = getMeth ms as x

2010 | otherwise = getMeth ms as x

1866

2011

1867− lhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : lhsArgs xs ns

2012+ lhsArgs (EA : xs) (n : ns) = [] -- pexp (PRef fc n) : lhsArgs xs ns

1868 lhsArgs (IA : xs) ns = lhsArgs xs ns

2013 lhsArgs (IA : xs) ns = lhsArgs xs ns

1869 lhsArgs (CA : xs) ns = lhsArgs xs ns

2014 lhsArgs (CA : xs) ns = lhsArgs xs ns

1870 lhsArgs [] _ = []

2015 lhsArgs [] _ = []

1871

2016

1872− rhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : rhsArgs xs ns

2017+ rhsArgs (EA : xs) (n : ns) = [] -- pexp (PRef fc n) : rhsArgs xs ns

1873 rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns

2018 rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns

1874 rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns

2019 rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns

1875 rhsArgs [] _ = []

2020 rhsArgs [] _ = []

1876

2021

1877− insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

2022+ insertConstraint c (PPi p@(Imp _ _ _) n ty sc)

1878 = PPi p n ty (insertConstraint c sc)

2023 = PPi p n ty (insertConstraint c sc)

1879 insertConstraint c sc = PPi constraint (sMN 0 "class") c sc

2024 insertConstraint c sc = PPi constraint (sMN 0 "class") c sc

1880

2025

1881 -- make arguments explicit and don't bind class parameters

2026 -- make arguments explicit and don't bind class parameters

1882− toExp ns e (PPi (Imp l s _ p) n ty sc)

2027+ toExp ns e (PPi (Imp l s p) n ty sc)

1883 | n `elem` ns = toExp ns e sc

2028 | n `elem` ns = toExp ns e sc

1884− | otherwise = PPi (e l s "" p) n ty (toExp ns e sc)

2029+ | otherwise = PPi (e l s p) n ty (toExp ns e sc)

1885 toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

2030 toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

1886 toExp ns e sc = sc

2031 toExp ns e sc = sc

1887

2032

@@ -1897,11 +2042,14 @@ elabInstance info syn what fc cs n ps t expn ds = do

1897 i <- getIState

2042 i <- getIState

1898 (n, ci) <- case lookupCtxtName n (idris_classes i) of

2043 (n, ci) <- case lookupCtxtName n (idris_classes i) of

1899 [c] -> return c

2044 [c] -> return c

1900− _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

2045+ [] -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

2046+ cs -> tclift $ tfail $ At fc

2047+ (CantResolveAlts (map fst cs))

1901 let constraint = PApp fc (PRef fc n) (map pexp ps)

2048 let constraint = PApp fc (PRef fc n) (map pexp ps)

1902 let iname = mkiname n ps expn

2049 let iname = mkiname n ps expn

1903− when (what /= EDefns) $ do

2050+ let emptyclass = null (class_methods ci)

1904− nty <- elabType' True info syn "" fc [] iname t

2051+ when (what /= EDefns || (null ds && not emptyclass)) $ do

2052+ nty <- elabType' True info syn emptyDocstring [] fc [] iname t

1905 -- if the instance type matches any of the instances we have already,

2053 -- if the instance type matches any of the instances we have already,

1906 -- and it's not a named instance, then it's overlapping, so report an error

2054 -- and it's not a named instance, then it's overlapping, so report an error

1907 case expn of

2055 case expn of

@@ -1909,7 +2057,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

1909 (class_instances ci)

2057 (class_instances ci)

1910 addInstance intInst n iname

2058 addInstance intInst n iname

1911 Just _ -> addInstance intInst n iname

2059 Just _ -> addInstance intInst n iname

1912− when (what /= ETypes) $ do

2060+ when (what /= ETypes && (not (null ds && not emptyclass))) $ do

1913 let ips = zip (class_params ci) ps

2061 let ips = zip (class_params ci) ps

1914 let ns = case n of

2062 let ns = case n of

1915 NS n ns' -> ns'

2063 NS n ns' -> ns'

@@ -1917,7 +2065,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

1917 -- get the implicit parameters that need passing through to the

2065 -- get the implicit parameters that need passing through to the

1918 -- where block

2066 -- where block

1919 wparams <- mapM (\p -> case p of

2067 wparams <- mapM (\p -> case p of

1920− PApp _ _ args -> getWParams args

2068+ PApp _ _ args -> getWParams (map getTm args)

1921 _ -> return []) ps

2069 _ -> return []) ps

1922 let pnames = map pname (concat (nub wparams))

2070 let pnames = map pname (concat (nub wparams))

1923 let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci)

2071 let superclassInstances = map (substInstance ips pnames) (class_default_superclasses ci)

@@ -1940,21 +2088,33 @@ elabInstance info syn what fc cs n ps t expn ds = do

1940 let wbTys = map mkTyDecl mtys

2088 let wbTys = map mkTyDecl mtys

1941 let wbVals = map (decorateid (decorate ns iname)) ds'

2089 let wbVals = map (decorateid (decorate ns iname)) ds'

1942 let wb = wbTys ++ wbVals

2090 let wb = wbTys ++ wbVals

1943− logLvl 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp True . mkTyDecl) mtys)

2091+ logLvl 3 $ "Method types " ++ showSep "\n" (map (show . showDeclImp verbosePPOption . mkTyDecl) mtys)

1944 logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++

2092 logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++

1945 show (concat (nub wparams))

2093 show (concat (nub wparams))

1946− let lhs = PRef fc iname

2094+

2095+ -- Bring variables in instance head into scope

2096+ ist <- getIState

2097+ let headVars = nub $ mapMaybe (\p -> case p of

2098+ PRef _ n ->

2099+ case lookupTy n (tt_ctxt ist) of

2100+ [] -> Just n

2101+ _ -> Nothing

2102+ _ -> Nothing) ps

2103+-- let lhs = PRef fc iname

2104+ let lhs = PApp fc (PRef fc iname)

2105+ (map (\n -> pimp n (PRef fc n) True) headVars)

1947 let rhs = PApp fc (PRef fc (instanceName ci))

2106 let rhs = PApp fc (PRef fc (instanceName ci))

1948 (map (pexp . mkMethApp) mtys)

2107 (map (pexp . mkMethApp) mtys)

2108+

2109+ logLvl 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars

2110+ logLvl 5 $ "Instance RHS " ++ show rhs

2111+

1949 let idecls = [PClauses fc [Dictionary] iname

2112 let idecls = [PClauses fc [Dictionary] iname

1950 [PClause fc iname lhs [] rhs wb]]

2113 [PClause fc iname lhs [] rhs wb]]

1951 iLOG (show idecls)

2114 iLOG (show idecls)

1952 mapM_ (elabDecl EAll info) idecls

2115 mapM_ (elabDecl EAll info) idecls

1953 addIBC (IBCInstance intInst n iname)

2116 addIBC (IBCInstance intInst n iname)

1954−-- -- for each constraint, build a top level function to chase it

2117+

1955−-- logLvl 5 $ "Building functions"

1956−-- fns <- mapM (cfun (instanceName ci) constraint syn idecls) cs

1957−-- mapM_ (elabDecl EAll info) (concat fns)

1958 where

2118 where

1959 intInst = case ps of

2119 intInst = case ps of

1960 [PConstant (AType (ATInt ITNative))] -> True

2120 [PConstant (AType (ATInt ITNative))] -> True

@@ -1979,7 +2139,8 @@ elabInstance info syn what fc cs n ps t expn ds = do

1979 -- TODO: largely based upon elabType' - should try to abstract

2139 -- TODO: largely based upon elabType' - should try to abstract

1980 elabFindOverlapping i ci iname syn t

2140 elabFindOverlapping i ci iname syn t

1981 = do ty' <- addUsingConstraints syn fc t

2141 = do ty' <- addUsingConstraints syn fc t

1982− ty' <- implicit syn iname ty'

2142+ -- TODO think: something more in info?

2143+ ty' <- implicit info syn iname ty'

1983 let ty = addImpl i ty'

2144 let ty = addImpl i ty'

1984 ctxt <- getContext

2145 ctxt <- getContext

1985 ((tyT, _, _), _) <-

2146 ((tyT, _, _), _) <-

@@ -2009,17 +2170,17 @@ elabInstance info syn what fc cs n ps t expn ds = do

2009

2170

2010 mkMethApp (n, _, _, ty)

2171 mkMethApp (n, _, _, ty)

2011 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

2172 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

2012− lamBind i (PPi (Constraint _ _ _) _ _ sc) sc'

2173+ lamBind i (PPi (Constraint _ _) _ _ sc) sc'

2013 = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

2174 = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

2014 lamBind i (PPi _ n ty sc) sc'

2175 lamBind i (PPi _ n ty sc) sc'

2015 = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

2176 = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

2016 lamBind i _ sc = sc

2177 lamBind i _ sc = sc

2017− methArgs i (PPi (Imp _ _ _ _) n ty sc)

2178+ methArgs i (PPi (Imp _ _ _) n ty sc)

2018− = PImp 0 True [] n (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc

2179+ = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc

2019− methArgs i (PPi (Exp _ _ _ _) n ty sc)

2180+ methArgs i (PPi (Exp _ _ _) n ty sc)

2020− = PExp 0 [] (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc

2181+ = PExp 0 [] (sMN 0 "marg") (PRef fc (sMN i "meth")) : methArgs (i+1) sc

2021− methArgs i (PPi (Constraint _ _ _) n ty sc)

2182+ methArgs i (PPi (Constraint _ _) n ty sc)

2022− = PConstraint 0 [] (PResolveTC fc) "" : methArgs (i+1) sc

2183+ = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc

2023 methArgs i _ = []

2184 methArgs i _ = []

2024

2185

2025 papp fc f [] = f

2186 papp fc f [] = f

@@ -2027,7 +2188,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

2027

2188

2028 getWParams [] = return []

2189 getWParams [] = return []

2029 getWParams (p : ps)

2190 getWParams (p : ps)

2030− | PRef _ n <- getTm p

2191+ | PRef _ n <- p

2031 = do ps' <- getWParams ps

2192 = do ps' <- getWParams ps

2032 ctxt <- getContext

2193 ctxt <- getContext

2033 case lookupP n ctxt of

2194 case lookupP n ctxt of

@@ -2035,15 +2196,15 @@ elabInstance info syn what fc cs n ps t expn ds = do

2035 _ -> return ps'

2196 _ -> return ps'

2036 getWParams (_ : ps) = getWParams ps

2197 getWParams (_ : ps) = getWParams ps

2037

2198

2038− decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

2199+ decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

2039 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

2200 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

2040

2201

2041− mkTyDecl (n, op, t, _) = PTy "" syn fc op n t

2202+ mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t

2042

2203

2043 conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

2204 conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

2044 conbind [] x = x

2205 conbind [] x = x

2045

2206

2046− coninsert cs (PPi p@(Imp _ _ _ _) n t sc) = PPi p n t (coninsert cs sc)

2207+ coninsert cs (PPi p@(Imp _ _ _) n t sc) = PPi p n t (coninsert cs sc)

2047 coninsert cs sc = conbind cs sc

2208 coninsert cs sc = conbind cs sc

2048

2209

2049 insertDefaults :: IState -> Name ->

2210 insertDefaults :: IState -> Name ->

@@ -2101,7 +2262,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

2101 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

2262 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

2102-}

2263-}

2103

2264

2104−decorateid decorate (PTy doc s f o n t) = PTy doc s f o (decorate n) t

2265+decorateid decorate (PTy doc argdocs s f o n t) = PTy doc argdocs s f o (decorate n) t

2105decorateid decorate (PClauses f o n cs)

2266decorateid decorate (PClauses f o n cs)

2106 = PClauses f o (decorate n) (map dc cs)

2267 = PClauses f o (decorate n) (map dc cs)

2107 where dc (PClause fc n t as w ds) = PClause fc (decorate n) (dappname t) as w ds

2268 where dc (PClause fc n t as w ds) = PClause fc (decorate n) (dappname t) as w ds

@@ -2155,22 +2316,22 @@ elabDecl' _ info (PFix _ _ _)

2155 = return () -- nothing to elaborate

2316 = return () -- nothing to elaborate

2156elabDecl' _ info (PSyntax _ p)

2317elabDecl' _ info (PSyntax _ p)

2157 = return () -- nothing to elaborate

2318 = return () -- nothing to elaborate

2158−elabDecl' what info (PTy doc s f o n ty)

2319+elabDecl' what info (PTy doc argdocs s f o n ty)

2159 | what /= EDefns

2320 | what /= EDefns

2160 = do iLOG $ "Elaborating type decl " ++ show n ++ show o

2321 = do iLOG $ "Elaborating type decl " ++ show n ++ show o

2161− elabType info s doc f o n ty

2322+ elabType info s doc argdocs f o n ty

2162 return ()

2323 return ()

2163elabDecl' what info (PPostulate doc s f o n ty)

2324elabDecl' what info (PPostulate doc s f o n ty)

2164 | what /= EDefns

2325 | what /= EDefns

2165 = do iLOG $ "Elaborating postulate " ++ show n ++ show o

2326 = do iLOG $ "Elaborating postulate " ++ show n ++ show o

2166 elabPostulate info s doc f o n ty

2327 elabPostulate info s doc f o n ty

2167−elabDecl' what info (PData doc s f co d)

2328+elabDecl' what info (PData doc argDocs s f co d)

2168 | what /= ETypes

2329 | what /= ETypes

2169 = do iLOG $ "Elaborating " ++ show (d_name d)

2330 = do iLOG $ "Elaborating " ++ show (d_name d)

2170− elabData info s doc f co d

2331+ elabData info s doc argDocs f co d

2171 | otherwise

2332 | otherwise

2172 = do iLOG $ "Elaborating [type of] " ++ show (d_name d)

2333 = do iLOG $ "Elaborating [type of] " ++ show (d_name d)

2173− elabData info s doc f co (PLaterdecl (d_name d) (d_tcon d))

2334+ elabData info s doc argDocs f co (PLaterdecl (d_name d) (d_tcon d))

2174elabDecl' what info d@(PClauses f o n ps)

2335elabDecl' what info d@(PClauses f o n ps)

2175 | what /= ETypes

2336 | what /= ETypes

2176 = do iLOG $ "Elaborating clause " ++ show n

2337 = do iLOG $ "Elaborating clause " ++ show n

@@ -2184,6 +2345,11 @@ elabDecl' what info (PMutual f ps)

2184 [p] -> elabDecl what info p

2345 [p] -> elabDecl what info p

2185 _ -> do mapM_ (elabDecl ETypes info) ps

2346 _ -> do mapM_ (elabDecl ETypes info) ps

2186 mapM_ (elabDecl EDefns info) ps

2347 mapM_ (elabDecl EDefns info) ps

2348+ -- record mutually defined data definitions

2349+ let datans = concatMap declared (filter isDataDecl ps)

2350+ mapM_ (setMutData datans) datans

2351+ iLOG $ "Rechecking for positivity " ++ show datans

2352+ mapM_ (\x -> do setTotality x Unchecked) datans

2187 -- Do totality checking after entire mutual block

2353 -- Do totality checking after entire mutual block

2188 i <- get

2354 i <- get

2189 mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

2355 mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

@@ -2192,6 +2358,16 @@ elabDecl' what info (PMutual f ps)

2192 mapM_ buildSCG (idris_totcheck i)

2358 mapM_ buildSCG (idris_totcheck i)

2193 mapM_ checkDeclTotality (idris_totcheck i)

2359 mapM_ checkDeclTotality (idris_totcheck i)

2194 clear_totcheck

2360 clear_totcheck

2361+ where isDataDecl (PData _ _ _ _ _ _) = True

2362+ isDataDecl _ = False

2363+

2364+ setMutData ns n

2365+ = do i <- getIState

2366+ case lookupCtxt n (idris_datatypes i) of

2367+ [x] -> do let x' = x { mutual_types = ns }

2368+ putIState $ i { idris_datatypes

2369+ = addDef n x' (idris_datatypes i) }

2370+ _ -> return ()

2195

2371

2196elabDecl' what info (PParams f ns ps)

2372elabDecl' what info (PParams f ns ps)

2197 = do i <- getIState

2373 = do i <- getIState

@@ -2214,30 +2390,30 @@ elabDecl' what info (PNamespace n ps) = mapM_ (elabDecl' what ninfo) ps

2214 ninfo = case namespace info of

2390 ninfo = case namespace info of

2215 Nothing -> info { namespace = Just [n] }

2391 Nothing -> info { namespace = Just [n] }

2216 Just ns -> info { namespace = Just (n:ns) }

2392 Just ns -> info { namespace = Just (n:ns) }

2217−elabDecl' what info (PClass doc s f cs n ps ds)

2393+elabDecl' what info (PClass doc s f cs n ps pdocs ds)

2218 | what /= EDefns

2394 | what /= EDefns

2219 = do iLOG $ "Elaborating class " ++ show n

2395 = do iLOG $ "Elaborating class " ++ show n

2220− elabClass info (s { syn_params = [] }) doc f cs n ps ds

2396+ elabClass info (s { syn_params = [] }) doc f cs n ps pdocs ds

2221elabDecl' what info (PInstance s f cs n ps t expn ds)

2397elabDecl' what info (PInstance s f cs n ps t expn ds)

2222 = do iLOG $ "Elaborating instance " ++ show n

2398 = do iLOG $ "Elaborating instance " ++ show n

2223 elabInstance info s what f cs n ps t expn ds

2399 elabInstance info s what f cs n ps t expn ds

2224−elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)

2400+elabDecl' what info (PRecord doc s f tyn ty opts cdoc cn cty)

2225 | what /= ETypes

2401 | what /= ETypes

2226 = do iLOG $ "Elaborating record " ++ show tyn

2402 = do iLOG $ "Elaborating record " ++ show tyn

2227− elabRecord info s doc f tyn ty cdoc cn cty

2403+ elabRecord info s doc f tyn ty opts cdoc cn cty

2228 | otherwise

2404 | otherwise

2229 = do iLOG $ "Elaborating [type of] " ++ show tyn

2405 = do iLOG $ "Elaborating [type of] " ++ show tyn

2230− elabData info s doc f [] (PLaterdecl tyn ty)

2406+ elabData info s doc [] f [] (PLaterdecl tyn ty)

2231elabDecl' _ info (PDSL n dsl)

2407elabDecl' _ info (PDSL n dsl)

2232 = do i <- getIState

2408 = do i <- getIState

2233 putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })

2409 putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })

2234 addIBC (IBCDSL n)

2410 addIBC (IBCDSL n)

2235elabDecl' what info (PDirective i)

2411elabDecl' what info (PDirective i)

2236 | what /= EDefns = i

2412 | what /= EDefns = i

2237−elabDecl' what info (PProvider syn fc provWhat n tp tm)

2413+elabDecl' what info (PProvider syn fc provWhat n)

2238 | what /= EDefns

2414 | what /= EDefns

2239 = do iLOG $ "Elaborating type provider " ++ show n

2415 = do iLOG $ "Elaborating type provider " ++ show n

2240− elabProvider info syn fc provWhat n tp tm

2416+ elabProvider info syn fc provWhat n

2241elabDecl' what info (PTransform fc safety old new)

2417elabDecl' what info (PTransform fc safety old new)

2242 = elabTransform info fc safety old new

2418 = elabTransform info fc safety old new

2243elabDecl' _ _ _ = return () -- skipped this time

2419elabDecl' _ _ _ = return () -- skipped this time

@@ -2282,3 +2458,14 @@ inferredDiff fc inf user =

2282 Right vs -> return False

2458 Right vs -> return False

2283 Left (x, y) -> return True

2459 Left (x, y) -> return True

2284

2460

2461+-- | Check a PTerm against documentation and ensure that every documented

2462+-- argument actually exists. This must be run _after_ implicits have been

2463+-- found, or it will give spurious errors.

2464+checkDocs :: FC -> [(Name, Docstring)] -> PTerm -> Idris ()

2465+checkDocs fc args tm = cd (Map.fromList args) tm

2466+ where cd as (PPi _ n _ sc) = cd (Map.delete n as) sc

2467+ cd as _ | Map.null as = return ()

2468+ | otherwise = ierror . At fc . Msg $

2469+ "There is documentation for argument(s) "

2470+ ++ (concat . intersperse ", " . map show . Map.keys) as

2471+ ++ " but they were not found."

src/Idris/ElabTerm.hs+194−153

@@ -3,38 +3,31 @@

3module Idris.ElabTerm where

4

5import Idris.AbsSyntax

6+import Idris.AbsSyntaxTree

6import Idris.DSL

7import Idris.DSL

7import Idris.Delaborate

8import Idris.Delaborate

8import Idris.Error

9import Idris.Error

9import Idris.ProofSearch

10import Idris.ProofSearch

11+import Idris.Output (pshow)

10

12

11import Idris.Core.Elaborate hiding (Tactic(..))

13import Idris.Core.Elaborate hiding (Tactic(..))

12import Idris.Core.TT

14import Idris.Core.TT

13import Idris.Core.Evaluate

15import Idris.Core.Evaluate

14import Idris.Core.Unify

16import Idris.Core.Unify

15import Idris.Core.Typecheck (check)

17import Idris.Core.Typecheck (check)

18+import Idris.ErrReverse (errReverse)

16

19

17import Control.Applicative ((<$>))

20import Control.Applicative ((<$>))

18import Control.Monad

21import Control.Monad

19import Control.Monad.State.Strict

22import Control.Monad.State.Strict

20import Data.List

23import Data.List

21import qualified Data.Map as M

24import qualified Data.Map as M

22−import Data.Maybe (mapMaybe)

25+import Data.Maybe (mapMaybe, fromMaybe)

23import qualified Data.Set as S

26import qualified Data.Set as S

24import qualified Data.Text as T

27import qualified Data.Text as T

25

28

26import Debug.Trace

29import Debug.Trace

27

30

28−-- Data to pass to recursively called elaborators; e.g. for where blocks,

29−-- paramaterised declarations, etc.

30−

31−data ElabInfo = EInfo { params :: [(Name, PTerm)],

32− inblock :: Ctxt [Name], -- names in the block, and their params

33− liftname :: Name -> Name,

34− namespace :: Maybe [String] }

35−

36−toplevel = EInfo [] emptyContext id Nothing

37−

38-- Using the elaborator, convert a term in raw syntax to a fully

31-- Using the elaborator, convert a term in raw syntax to a fully

39-- elaborated, typechecked term.

32-- elaborated, typechecked term.

40--

33--

@@ -72,13 +65,20 @@ build ist info pattern opts fn tm

72 tm <- get_term

65 tm <- get_term

73 ctxt <- get_context

66 ctxt <- get_context

74 probs <- get_probs

67 probs <- get_probs

68+ u <- getUnifyLog

69+ hs <- get_holes

70+

71+ when (not pattern) $

72+ traceWhen u ("Remaining holes:\n" ++ show hs ++ "\n" ++

73+ "Remaining problems:\n" ++ qshow probs) $

74+ do unify_all; matchProblems True; unifyProblems

75

76− when (not pattern) $ do matchProblems True; unifyProblems

77 probs <- get_probs

76 probs <- get_probs

78 case probs of

77 case probs of

79 [] -> return ()

78 [] -> return ()

80− ((_,_,_,e,_):es) -> if inf then return ()

79+ ((_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ show probs) $

81− else lift (Error e)

80+ if inf then return ()

81+ else lift (Error e)

82 is <- getAux

83 tt <- get_term

84 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

@@ -105,8 +105,8 @@ buildTC ist info pattern opts fn tm

105 tm <- get_term

106 case probs of

107 [] -> return ()

108− ((_,_,_,e,_):es) -> if inf then return ()

108+ ((_,_,_,e,_,_):es) -> if inf then return ()

109− else lift (Error e)

109+ else lift (Error e)

110 is <- getAux

111 tt <- get_term

112 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

@@ -127,6 +127,7 @@ elab ist info pattern opts fn tm

127 end_unify

128 when pattern -- convert remaining holes to pattern vars

129 (do update_term orderPats

130+ unify_all

130 matchProblems False -- only the ones we matched earlier

131 matchProblems False -- only the ones we matched earlier

131 unifyProblems

132 unifyProblems

132 mkPat)

133 mkPat)

@@ -154,39 +155,42 @@ elab ist info pattern opts fn tm

154

155

155 elabE :: (Bool, Bool, Bool) -> PTerm -> ElabD ()

156 elabE :: (Bool, Bool, Bool) -> PTerm -> ElabD ()

156 elabE ina t =

157 elabE ina t =

157−-- do g <- goal

158+ --do g <- goal

158−-- trace ("Elaborating " ++ show t ++ " : " ++ show g) $

159+ --trace ("Elaborating " ++ show t ++ " : " ++ show g) $

159 do ct <- insertCoerce ina t

160 do ct <- insertCoerce ina t

160 t' <- insertLazy ct

161 t' <- insertLazy ct

161 g <- goal

162 g <- goal

162 tm <- get_term

163 tm <- get_term

163 ps <- get_probs

164 ps <- get_probs

164 hs <- get_holes

165 hs <- get_holes

165−-- trace ("Elaborating " ++ show t' ++ " in " ++ show g

166+ --trace ("Elaborating " ++ show t' ++ " in " ++ show g

166−-- -- ++ "\n" ++ show tm

167+ -- ++ "\n" ++ show tm

167−-- ++ "\nholes " ++ show hs

168+ -- ++ "\nholes " ++ show hs

168−-- ++ "\nproblems " ++ show ps

169+ -- ++ "\nproblems " ++ show ps

169−-- ++ "\n-----------\n") $

170+ -- ++ "\n-----------\n") $

170−-- trace ("ELAB " ++ show t') $

171+ --trace ("ELAB " ++ show t') $

171 let fc = fileFC "Force"

172 let fc = fileFC "Force"

172− handleError forceErr

173+ env <- get_env

174+ handleError (forceErr env)

173 (elab' ina t')

175 (elab' ina t')

174 (elab' ina (PApp fc (PRef fc (sUN "Force"))

176 (elab' ina (PApp fc (PRef fc (sUN "Force"))

175− [pimp (sUN "a") Placeholder True,

177+ [pimp (sUN "t") Placeholder True,

178+ pimp (sUN "a") Placeholder True,

176 pexp ct])) True

179 pexp ct])) True

177

180

178− forceErr (CantUnify _ t t' _ _ _)

181+ forceErr env (CantUnify _ t t' _ _ _)

179− | (P _ (UN ht) _, _) <- unApply t,

182+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

180− ht == txt "Lazy" = True

183+ ht == txt "Lazy'" = True

181− forceErr (CantUnify _ t t' _ _ _)

184+ forceErr env (CantUnify _ t t' _ _ _)

182− | (P _ (UN ht) _, _) <- unApply t',

185+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t'),

183− ht == txt "Lazy" = True

186+ ht == txt "Lazy'" = True

184− forceErr (InfiniteUnify _ t _)

187+ forceErr env (InfiniteUnify _ t _)

185− | (P _ (UN ht) _, _) <- unApply t,

188+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

186− ht == txt "Lazy" = True

189+ ht == txt "Lazy'" = True

187− forceErr (Elaborating _ _ t) = forceErr t

190+ forceErr env (Elaborating _ _ t) = forceErr env t

188− forceErr (At _ t) = forceErr t

191+ forceErr env (ElaboratingArg _ _ _ t) = forceErr env t

189− forceErr t = False

192+ forceErr env (At _ t) = forceErr env t

193+ forceErr env t = False

190

194

191 local f = do e <- get_env

195 local f = do e <- get_env

192 return (f `elem` map fst e)

196 return (f `elem` map fst e)

@@ -263,13 +267,14 @@ elab ist info pattern opts fn tm

263 ty <- goal

267 ty <- goal

264 ctxt <- get_context

268 ctxt <- get_context

265 let (tc, _) = unApply ty

269 let (tc, _) = unApply ty

266− let as' = pruneByType tc ctxt as

270+ env <- get_env

271+ let as' = pruneByType (map fst env) tc ctxt as

267-- trace (show as ++ "\n ==> " ++ showSep ", " (map showTmImpls as')) $

272-- trace (show as ++ "\n ==> " ++ showSep ", " (map showTmImpls as')) $

268 tryAll (zip (map (elab' ina) as') (map showHd as'))

273 tryAll (zip (map (elab' ina) as') (map showHd as'))

269− where showHd (PApp _ (PRef _ n) _) = show n

274+ where showHd (PApp _ (PRef _ n) _) = n

270− showHd (PRef _ n) = show n

275+ showHd (PRef _ n) = n

271− showHd (PApp _ h _) = show h

276+ showHd (PApp _ h _) = showHd h

272− showHd x = show x

277+ showHd x = NErased -- We probably should do something better than this here

273 elab' ina (PAlternative False as)

278 elab' ina (PAlternative False as)

274 = trySeq as

279 = trySeq as

275 where -- if none work, take the error from the first

280 where -- if none work, take the error from the first

@@ -458,13 +463,15 @@ elab ist info pattern opts fn tm

458-- trace ("ns is " ++ show ns) $ return ()

463-- trace ("ns is " ++ show ns) $ return ()

459 -- mark any type class arguments as injective

464 -- mark any type class arguments as injective

460 mapM_ checkIfInjective (map snd ns)

465 mapM_ checkIfInjective (map snd ns)

466+ unifyProblems -- try again with the new information,

467+ -- to help with disambiguation

461 -- Sort so that the implicit tactics and alternatives go last

468 -- Sort so that the implicit tactics and alternatives go last

462 let (ns', eargs) = unzip $

469 let (ns', eargs) = unzip $

463 sortBy cmpArg (zip ns args)

470 sortBy cmpArg (zip ns args)

464 elabArgs ist (ina || not isinf, guarded, inty)

471 elabArgs ist (ina || not isinf, guarded, inty)

465 [] fc False f ns'

472 [] fc False f ns'

466 (f == sUN "Force")

473 (f == sUN "Force")

467− (map (\x -> (lazyarg x, getTm x)) eargs)

474+ (map (\x -> (False, getTm x)) eargs) -- TODO: remove this False arg

468 solve

475 solve

469 ivs' <- get_instances

476 ivs' <- get_instances

470 -- Attempt to resolve any type classes which have 'complete' types,

477 -- Attempt to resolve any type classes which have 'complete' types,

@@ -480,12 +487,22 @@ elab ist info pattern opts fn tm

480 (movelast n)

487 (movelast n)

481 else movelast n)

488 else movelast n)

482 (ivs' \\ ivs)

489 (ivs' \\ ivs)

483− where -- normal < tactic < default tactic

490+ where -- normal < alternatives < lambdas < rewrites < tactic < default tactic

491+ -- reason for lambdas after alternatives is that having

492+ -- the alternative resolved can help with typechecking the lambda

493+ -- or the rewrite. Rewrites/tactics need as much information

494+ -- as possible about the type.

495+ -- FIXME: Better would be to allow alternative resolution to be

496+ -- retried after more information is in.

484 cmpArg (_, x) (_, y)

497 cmpArg (_, x) (_, y)

485 = compare (conDepth 0 (getTm x) + priority x + alt x)

498 = compare (conDepth 0 (getTm x) + priority x + alt x)

486 (conDepth 0 (getTm y) + priority y + alt y)

499 (conDepth 0 (getTm y) + priority y + alt y)

487 where alt t = case getTm t of

500 where alt t = case getTm t of

488 PAlternative False _ -> 5

501 PAlternative False _ -> 5

502+ PAlternative True _ -> 1

503+ PTactics _ -> 150

504+ PLam _ _ _ -> 2

505+ PRewrite _ _ _ _ -> 3

489 _ -> 0

506 _ -> 0

490

507

491 -- Score a point for every level where there is a non-constructor

508 -- Score a point for every level where there is a non-constructor

@@ -549,7 +566,7 @@ elab ist info pattern opts fn tm

549 claim tyn RType

566 claim tyn RType

550 valn <- getNameFrom (sMN 0 "rval")

567 valn <- getNameFrom (sMN 0 "rval")

551 claim valn (Var tyn)

568 claim valn (Var tyn)

552− letn <- getNameFrom (sMN 0 "rewrite_rule")

569+ letn <- getNameFrom (sMN 0 "_rewrite_rule")

553 letbind letn (Var tyn) (Var valn)

570 letbind letn (Var tyn) (Var valn)

554 focus valn

571 focus valn

555 elab' ina r

572 elab' ina r

@@ -672,15 +689,18 @@ elab ist info pattern opts fn tm

672 let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)

689 let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)

673 let tries = if pattern then [t, mkDelay t] else [mkDelay t, t]

690 let tries = if pattern then [t, mkDelay t] else [mkDelay t, t]

674 case tyh of

691 case tyh of

675− P _ (UN l) _ | l == txt "Lazy"

692+ P _ (UN l) _ | l == txt "Lazy'"

676 -> return (PAlternative False tries)

693 -> return (PAlternative False tries)

677 _ -> return t

694 _ -> return t

678 where

695 where

679 mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)

696 mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)

680 mkDelay t = let fc = fileFC "Delay" in

697 mkDelay t = let fc = fileFC "Delay" in

681− addImpl ist (PApp fc (PRef fc (sUN "Delay")) [pexp t])

698+ addImpl ist (PApp fc (PRef fc (sUN "Delay"))

682−

699+ [pexp t])

683

700

701+ -- case is tricky enough without implicit coercions! If they are needed,

702+ -- they can go in the branches separately.

703+ insertCoerce ina t@(PCase _ _ _) = return t

684 insertCoerce ina t =

704 insertCoerce ina t =

685 do ty <- goal

705 do ty <- goal

686 -- Check for possible coercions to get to the goal

706 -- Check for possible coercions to get to the goal

@@ -709,67 +729,41 @@ elab ist info pattern opts fn tm

709 -> Bool -- ^ under a 'force'

729 -> Bool -- ^ under a 'force'

710 -> [(Bool, PTerm)] -- ^ (Laziness, argument)

730 -> [(Bool, PTerm)] -- ^ (Laziness, argument)

711 -> ElabD ()

731 -> ElabD ()

712− elabArgs ist ina failed fc retry f [] force _

732+ elabArgs ist ina failed fc retry f [] force _ = return ()

713−-- | retry = let (ns, ts) = unzip (reverse failed) in

714−-- elabArgs ina [] False ns ts

715− | otherwise = return ()

716 elabArgs ist ina failed fc r f (n:ns) force ((_, Placeholder) : args)

733 elabArgs ist ina failed fc r f (n:ns) force ((_, Placeholder) : args)

717 = elabArgs ist ina failed fc r f ns force args

734 = elabArgs ist ina failed fc r f ns force args

718 elabArgs ist ina failed fc r f ((argName, holeName):ns) force ((lazy, t) : args)

735 elabArgs ist ina failed fc r f ((argName, holeName):ns) force ((lazy, t) : args)

719 | lazy && not pattern

736 | lazy && not pattern

720− = elabArg argName holeName (PApp bi (PRef bi (sUN "lazy"))

737+ = elabArg argName holeName (PApp bi (PRef bi (sUN "Delay"))

721 [pimp (sUN "a") Placeholder True,

738 [pimp (sUN "a") Placeholder True,

722 pexp t])

739 pexp t])

723 | otherwise = elabArg argName holeName t

740 | otherwise = elabArg argName holeName t

724 where elabArg argName holeName t =

741 where elabArg argName holeName t =

725− reflectFunctionErrors ist f argName $

742+ do now_elaborating fc f argName

726− do hs <- get_holes

743+ wrapErr f argName $ do

727− tm <- get_term

744+ hs <- get_holes

728− -- No coercing under an explicit Force (or it can Force/Delay

745+ tm <- get_term

729− -- recursively!)

746+ -- No coercing under an explicit Force (or it can Force/Delay

730− let elab = if force then elab' else elabE

747+ -- recursively!)

731− failed' <- -- trace (show (n, t, hs, tm)) $

748+ let elab = if force then elab' else elabE

732− -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

749+ failed' <- -- trace (show (n, t, hs, tm)) $

733− case holeName `elem` hs of

750+ -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

734− True -> do focus holeName; elab ina t; return failed

751+ case holeName `elem` hs of

735− False -> return failed

752+ True -> do focus holeName; elab ina t; return failed

736− elabArgs ist ina failed fc r f ns force args

753+ False -> return failed

737−

754+ done_elaborating_arg f argName

738−-- | Perform error reflection for function applicaitons with specific error handlers

755+ elabArgs ist ina failed fc r f ns force args

739−reflectFunctionErrors :: IState -> Name -> Name -> ElabD a -> ElabD a

756+ wrapErr f argName action =

740−reflectFunctionErrors ist f arg action =

757+ do elabState <- get

741− do elabState <- get

758+ while <- elaborating_app

742− (result, newState) <- case runStateT action elabState of

759+ let while' = map (\(x, y, z)-> (y, z)) while

743− OK (res, newState) -> return (res, newState)

760+ (result, newState) <- case runStateT action elabState of

744− Error e@(ReflectionError _ _) -> (lift . tfail) e

761+ OK (res, newState) -> return (res, newState)

745− Error e@(ReflectionFailed _ _) -> (lift . tfail) e

762+ Error e -> do done_elaborating_arg f argName

746− Error e -> handle e >>= lift . tfail

763+ lift (tfail (elaboratingArgErr while' e))

747− put newState

764+ put newState

748− return result

765+ return result

749− where handle :: Err -> ElabD Err

766+

750− handle e = do let funhandlers = (maybe M.empty id . lookupCtxtExact f . idris_function_errorhandlers) ist

751− handlers = (maybe [] S.toList . M.lookup arg) funhandlers

752− reports = map (\n -> RApp (Var n) (reflectErr e)) handlers

753−

754−

755− -- Typecheck error handlers - if this fails, then something else was wrong earlier!

756− handlers <- case mapM (check (tt_ctxt ist) []) reports of

757− Error e -> lift . tfail $

758− ReflectionFailed "Type error while constructing reflected error" e

759− OK hs -> return hs

760−

761− -- Normalize error handler terms to produce the new messages

762− let ctxt = tt_ctxt ist

763− results = map (normalise ctxt []) (map fst handlers)

764−

765− -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

766− let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

767− errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

768− Left err -> lift (tfail err)

769− Right ok -> return ok

770− return $ case errorparts of

771− [] -> e

772− parts -> ReflectionError errorparts e

773

767

774-- For every alternative, look at the function at the head. Automatically resolve

768-- For every alternative, look at the function at the head. Automatically resolve

775-- any nested alternatives where that function is also at the head

769-- any nested alternatives where that function is also at the head

@@ -787,6 +781,7 @@ pruneAlt xs = map prune xs

787 case fs of

781 case fs of

788 [a] -> a

782 [a] -> a

789 _ -> PAlternative a as'

783 _ -> PAlternative a as'

784+

790 choose f (PApp fc f' as) = PApp fc (choose f f') (fmap (fmap (choose f)) as)

785 choose f (PApp fc f' as) = PApp fc (choose f f') (fmap (fmap (choose f)) as)

791 choose f t = t

786 choose f t = t

792

787

@@ -796,8 +791,21 @@ pruneAlt xs = map prune xs

796

791

797-- Rule out alternatives that don't return the same type as the head of the goal

792-- Rule out alternatives that don't return the same type as the head of the goal

798-- (If there are none left as a result, do nothing)

793-- (If there are none left as a result, do nothing)

799−pruneByType :: Term -> Context -> [PTerm] -> [PTerm]

794+pruneByType :: [Name] -> Term -> Context -> [PTerm] -> [PTerm]

800−pruneByType (P _ n _) c as

795+-- if an alternative has a locally bound name at the head, take it

796+pruneByType env t c as

797+ | Just a <- locallyBound as = [a]

798+ where

799+ locallyBound [] = Nothing

800+ locallyBound (t:ts)

801+ | Just n <- getName t,

802+ n `elem` env = Just t

803+ | otherwise = locallyBound ts

804+ getName (PRef _ n) = Just n

805+ getName (PApp _ f _) = getName f

806+ getName _ = Nothing

807+

808+pruneByType env (P _ n _) c as

801-- if the goal type is polymorphic, keep e

809-- if the goal type is polymorphic, keep e

802 | [] <- lookupTy n c = as

810 | [] <- lookupTy n c = as

803 | otherwise

811 | otherwise

@@ -823,7 +831,7 @@ pruneByType (P _ n _) c as

823 _ -> False

831 _ -> False

824 _ -> False

832 _ -> False

825

833

826−pruneByType t _ as = as

834+pruneByType _ t _ as = as

827

835

828findInstances :: IState -> Term -> [Name]

836findInstances :: IState -> Term -> [Name]

829findInstances ist t

837findInstances ist t

@@ -835,9 +843,10 @@ findInstances ist t

835

843

836trivial' ist

844trivial' ist

837 = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist

845 = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist

838−proofSearch' ist top n hints

846+proofSearch' ist rec depth prv top n hints

839− = proofSearch (elab ist toplevel False [] (sMN 0 "tac")) top n hints ist

847+ = do unifyProblems

840−

848+ proofSearch rec prv depth

849+ (elab ist toplevel False [] (sMN 0 "tac")) top n hints ist

841

850

842resolveTC :: Int -> Term -> Name -> IState -> ElabD ()

851resolveTC :: Int -> Term -> Name -> IState -> ElabD ()

843resolveTC = resTC' []

852resolveTC = resTC' []

@@ -926,7 +935,7 @@ resTC' tcs depth topg fn ist

926 ulog <- getUnifyLog

935 ulog <- getUnifyLog

927 solve

936 solve

928 traceWhen ulog ("Got " ++ show n) $ return ()

937 traceWhen ulog ("Got " ++ show n) $ return ()

929− where isImp (PImp p _ _ _ _ _) = (True, p)

938+ where isImp (PImp p _ _ _ _) = (True, p)

930 isImp arg = (False, priority arg)

939 isImp arg = (False, priority arg)

931

940

932collectDeferred :: Maybe Name ->

941collectDeferred :: Maybe Name ->

@@ -982,7 +991,7 @@ runTac autoSolve ist fn tac

982 ns -> return (map (\ (n, a) -> (n, map (const True) a)) ns)

991 ns -> return (map (\ (n, a) -> (n, map (const True) a)) ns)

983 let tacs = map (\ (fn', imps) ->

992 let tacs = map (\ (fn', imps) ->

984 (match_apply (Var fn') (map (\x -> (x, 0)) imps),

993 (match_apply (Var fn') (map (\x -> (x, 0)) imps),

985− show fn')) fnimps

994+ fn')) fnimps

986 tryAll tacs

995 tryAll tacs

987 when autoSolve solveAll

996 when autoSolve solveAll

988 where envArgs n = do e <- get_env

997 where envArgs n = do e <- get_env

@@ -998,10 +1007,10 @@ runTac autoSolve ist fn tac

998 ns -> return (map (\ (n, a) -> (n, map isImp a)) ns)

1007 ns -> return (map (\ (n, a) -> (n, map isImp a)) ns)

999 let tacs = map (\ (fn', imps) ->

1008 let tacs = map (\ (fn', imps) ->

1000 (apply (Var fn') (map (\x -> (x, 0)) imps),

1009 (apply (Var fn') (map (\x -> (x, 0)) imps),

1001− show fn')) fnimps

1010+ fn')) fnimps

1002 tryAll tacs

1011 tryAll tacs

1003 when autoSolve solveAll

1012 when autoSolve solveAll

1004− where isImp (PImp _ _ _ _ _ _) = True

1013+ where isImp (PImp _ _ _ _ _) = True

1005 isImp _ = False

1014 isImp _ = False

1006 envArgs n = do e <- get_env

1015 envArgs n = do e <- get_env

1007 case lookup n e of

1016 case lookup n e of

@@ -1010,6 +1019,8 @@ runTac autoSolve ist fn tac

1010 _ -> return []

1019 _ -> return []

1011 runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps)

1020 runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps)

1012 when autoSolve solveAll

1021 when autoSolve solveAll

1022+ runT DoUnify = do unify_all

1023+ when autoSolve solveAll

1013 runT (Equiv tm) -- let bind tm, then

1024 runT (Equiv tm) -- let bind tm, then

1014 = do attack

1025 = do attack

1015 tyn <- getNameFrom (sMN 0 "ety")

1026 tyn <- getNameFrom (sMN 0 "ety")

@@ -1065,8 +1076,9 @@ runTac autoSolve ist fn tac

1065 runT Compute = compute

1076 runT Compute = compute

1066 runT Trivial = do trivial' ist; when autoSolve solveAll

1077 runT Trivial = do trivial' ist; when autoSolve solveAll

1067 runT TCInstance = runT (Exact (PResolveTC emptyFC))

1078 runT TCInstance = runT (Exact (PResolveTC emptyFC))

1068− runT (ProofSearch top hints)

1079+ runT (ProofSearch rec prover depth top hints)

1069− = do proofSearch' ist top fn hints; when autoSolve solveAll

1080+ = do proofSearch' ist rec depth prover top fn hints

1081+ when autoSolve solveAll

1070 runT (Focus n) = focus n

1082 runT (Focus n) = focus n

1071 runT Solve = solve

1083 runT Solve = solve

1072 runT (Try l r) = do try' (runT l) (runT r) True

1084 runT (Try l r) = do try' (runT l) (runT r) True

@@ -1098,9 +1110,9 @@ runTac autoSolve ist fn tac

1098 runReflected tactic

1110 runReflected tactic

1099 where tacticTy = Var (reflm "Tactic")

1111 where tacticTy = Var (reflm "Tactic")

1100 listTy = Var (sNS (sUN "List") ["List", "Prelude"])

1112 listTy = Var (sNS (sUN "List") ["List", "Prelude"])

1101− scriptTy = (RBind (sUN "__pi_arg")

1113+ scriptTy = (RBind (sMN 0 "__pi_arg")

1102 (Pi (RApp listTy envTupleType))

1114 (Pi (RApp listTy envTupleType))

1103− (RBind (sUN "__pi_arg1")

1115+ (RBind (sMN 1 "__pi_arg")

1104 (Pi (Var $ reflm "TT")) tacticTy))

1116 (Pi (Var $ reflm "TT")) tacticTy))

1105 runT (ByReflection tm) -- run the reflection function 'tm' on the

1117 runT (ByReflection tm) -- run the reflection function 'tm' on the

1106 -- goal, then apply the resulting reflected Tactic

1118 -- goal, then apply the resulting reflected Tactic

@@ -1193,18 +1205,22 @@ reify _ t = fail ("Unknown tactic " ++ show t)

1193

1205

1194reifyApp :: IState -> Name -> [Term] -> ElabD PTactic

1206reifyApp :: IState -> Name -> [Term] -> ElabD PTactic

1195reifyApp ist t [l, r] | t == reflm "Try" = liftM2 Try (reify ist l) (reify ist r)

1207reifyApp ist t [l, r] | t == reflm "Try" = liftM2 Try (reify ist l) (reify ist r)

1208+reifyApp _ t [Constant (I i)]

1209+ | t == reflm "Search" = return (ProofSearch True True i Nothing [])

1196reifyApp _ t [x]

1210reifyApp _ t [x]

1197 | t == reflm "Refine" = do n <- reifyTTName x

1211 | t == reflm "Refine" = do n <- reifyTTName x

1198 return $ Refine n []

1212 return $ Refine n []

1199reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)

1213reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)

1200reifyApp ist t [Constant (Str n), x]

1214reifyApp ist t [Constant (Str n), x]

1201 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

1215 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

1202−reifyApp _ t [Constant (Str n)]

1216+reifyApp _ t [n] | t == reflm "Intro" = liftM (Intro . (:[])) (reifyTTName n)

1203− | t == reflm "Intro" = return $ Intro [sUN n]

1217+reifyApp _ t [n] | t == reflm "Induction" = liftM Induction (reifyTTName n)

1204reifyApp ist t [t']

1218reifyApp ist t [t']

1205 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

1219 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

1206reifyApp ist t [t']

1220reifyApp ist t [t']

1207 | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

1221 | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

1222+reifyApp ist t [t']

1223+ | t == reflm "ByReflection" = liftM (ByReflection . delab ist) (reifyTT t')

1208reifyApp _ t [t']

1224reifyApp _ t [t']

1209 | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')

1225 | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')

1210reifyApp ist t [t']

1226reifyApp ist t [t']

@@ -1593,8 +1609,8 @@ reflectErr (NotInjective t1 t2 t3) =

1593 ]

1609 ]

1594reflectErr (CantResolve t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

1610reflectErr (CantResolve t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

1595reflectErr (CantResolveAlts ss) =

1611reflectErr (CantResolveAlts ss) =

1596− raw_apply (Var $ reflErrName "CantResolve")

1612+ raw_apply (Var $ reflErrName "CantResolveAlts")

1597− [rawList (Var $ (sUN "String")) (map (RConstant . Str) ss)]

1613+ [rawList (Var $ (sUN "String")) (map Var ss)]

1598reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

1614reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

1599reflectErr UniverseError = Var $ reflErrName "UniverseError"

1615reflectErr UniverseError = Var $ reflErrName "UniverseError"

1600reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment"

1616reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment"

@@ -1603,24 +1619,20 @@ reflectErr (NonCollapsiblePostulate n) = raw_apply (Var $ reflErrName "NonCollab

1603reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n]

1619reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n]

1604reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]

1620reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]

1605reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm]

1621reflectErr (NoRewriting tm) = raw_apply (Var $ reflErrName "NoRewriting") [reflect tm]

1606−reflectErr (At fc err) = raw_apply (Var $ reflErrName "At") [reflectFC fc, reflectErr err]

1607− where reflectFC (FC source line col) = raw_apply (Var $ reflErrName "FileLoc")

1608− [ RConstant (Str source)

1609− , RConstant (I line)

1610− , RConstant (I col)

1611− ]

1612−reflectErr (Elaborating str n e) =

1613− raw_apply (Var $ reflErrName "Elaborating")

1614− [ RConstant (Str str)

1615− , reflectName n

1616− , reflectErr e

1617− ]

1618reflectErr (ProviderError str) =

1622reflectErr (ProviderError str) =

1619 raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

1623 raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

1620reflectErr (LoadingFailed str err) =

1624reflectErr (LoadingFailed str err) =

1621 raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

1625 raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

1622reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

1626reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

1623

1627

1628+elaboratingArgErr :: [(Name, Name)] -> Err -> Err

1629+elaboratingArgErr [] err = err

1630+elaboratingArgErr ((f,x):during) err = fromMaybe err (rewrite err)

1631+ where rewrite (ElaboratingArg _ _ _ _) = Nothing

1632+ rewrite (ProofSearchFail e) = fmap ProofSearchFail (rewrite e)

1633+ rewrite (At fc e) = fmap (At fc) (rewrite e)

1634+ rewrite err = Just (ElaboratingArg f x during err)

1635+

1624

1636

1625withErrorReflection :: Idris a -> Idris a

1637withErrorReflection :: Idris a -> Idris a

1626withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

1638withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

@@ -1629,30 +1641,59 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

1629 return e -- Don't do meta-reflection of errors

1641 return e -- Don't do meta-reflection of errors

1630 handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"

1642 handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"

1631 return e

1643 return e

1644+ -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them

1645+ handle e@(At fc err) = do logLvl 3 "Reflecting body of At"

1646+ err' <- handle err

1647+ return (At fc err')

1648+ handle e@(Elaborating what n err) = do logLvl 3 "Reflecting body of Elaborating"

1649+ err' <- handle err

1650+ return (Elaborating what n err')

1651+ handle e@(ElaboratingArg f a prev err) = do logLvl 3 "Reflecting body of ElaboratingArg"

1652+ hs <- getFnHandlers f a

1653+ err' <- if null hs

1654+ then handle err

1655+ else applyHandlers err hs

1656+ return (ElaboratingArg f a prev err')

1657+ -- ProofSearchFail is an internal detail - so don't expose it

1658+ handle (ProofSearchFail e) = handle e

1659+ -- TODO: argument-specific error handlers go here for ElaboratingArg

1632 handle e = do ist <- getIState

1660 handle e = do ist <- getIState

1633 logLvl 2 "Starting error reflection"

1661 logLvl 2 "Starting error reflection"

1634 let handlers = idris_errorhandlers ist

1662 let handlers = idris_errorhandlers ist

1635− logLvl 3 $ "Using reflection handlers " ++ concat (intersperse ", " (map show handlers))

1663+ applyHandlers e handlers

1636− let reports = map (\n -> RApp (Var n) (reflectErr e)) handlers

1664+ getFnHandlers :: Name -> Name -> Idris [Name]

1637−

1665+ getFnHandlers f arg = do ist <- getIState

1638− -- Typecheck error handlers - if this fails, then something else was wrong earlier!

1666+ let funHandlers = maybe M.empty id .

1639− handlers <- case mapM (check (tt_ctxt ist) []) reports of

1667+ lookupCtxtExact f .

1640− Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e

1668+ idris_function_errorhandlers $ ist

1641− OK hs -> return hs

1669+ return . maybe [] S.toList . M.lookup arg $ funHandlers

1642−

1670+

1643− -- Normalize error handler terms to produce the new messages

1671+

1644− ctxt <- getContext

1672+ applyHandlers e handlers =

1645− let results = map (normalise ctxt []) (map fst handlers)

1673+ do ist <- getIState

1646− logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

1674+ let err = fmap (errReverse ist) e

1647−

1675+ logLvl 3 $ "Using reflection handlers " ++

1648− -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

1676+ concat (intersperse ", " (map show handlers))

1649− let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

1677+ let reports = map (\n -> RApp (Var n) (reflectErr err)) handlers

1650− errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

1678+

1651− Left err -> ierror err

1679+ -- Typecheck error handlers - if this fails, then something else was wrong earlier!

1652− Right ok -> return ok

1680+ handlers <- case mapM (check (tt_ctxt ist) []) reports of

1653− return $ case errorparts of

1681+ Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e

1654− [] -> e

1682+ OK hs -> return hs

1655− parts -> ReflectionError errorparts e

1683+

1684+ -- Normalize error handler terms to produce the new messages

1685+ ctxt <- getContext

1686+ let results = map (normalise ctxt []) (map fst handlers)

1687+ logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

1688+

1689+ -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

1690+ let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

1691+ errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

1692+ Left err -> ierror err

1693+ Right ok -> return ok

1694+ return $ case errorparts of

1695+ [] -> e

1696+ parts -> ReflectionError errorparts e

1656

1697

1657fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

1698fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

1658fromTTMaybe (App (App (P (DCon _ _) (NS (UN just) _) _) ty) tm)

1699fromTTMaybe (App (App (P (DCon _ _) (NS (UN just) _) _) ty) tm)

src/Idris/Erasure.hsnew file+513

@@ -0,0 +1,513 @@

1+{-# LANGUAGE PatternGuards #-}

2+

3+module Idris.Erasure (performUsageAnalysis, mkFieldName) where

4+

5+import Idris.AbsSyntax

6+import Idris.ASTUtils

7+import Idris.Core.CaseTree

8+import Idris.Core.TT

9+import Idris.Core.Evaluate

10+import Idris.Primitives

11+import Idris.Error

12+

13+import Debug.Trace

14+import System.IO.Unsafe

15+

16+import Control.Category

17+import Prelude hiding (id, (.))

18+

19+import Control.Arrow

20+import Control.Applicative

21+import Control.Monad.State

22+import Data.Maybe

23+import Data.List

24+import qualified Data.Set as S

25+import qualified Data.IntSet as IS

26+import qualified Data.Map as M

27+import qualified Data.IntMap as IM

28+import Data.Set (Set)

29+import Data.IntSet (IntSet)

30+import Data.Map (Map)

31+import Data.IntMap (IntMap)

32+import Data.Text (pack)

33+import qualified Data.Text as T

34+

35+-- UseMap maps names to the set of used (reachable) argument positions.

36+type UseMap = Map Name (IntMap (Set Reason))

37+

38+data Arg = Arg Int | Result deriving (Eq, Ord)

39+

40+instance Show Arg where

41+ show (Arg i) = show i

42+ show Result = "*"

43+

44+type Node = (Name, Arg)

45+type Deps = Map Cond DepSet

46+type Reason = (Name, Int) -- function name, argument index

47+

48+-- Nodes along with sets of reasons for every one.

49+type DepSet = Map Node (Set Reason)

50+

51+-- "Condition" is the conjunction

52+-- of elementary assumptions along the path from the root.

53+-- Elementary assumption (f, i) means that "function f uses the argument i".

54+type Cond = Set Node

55+

56+-- Variables carry certain information with them.

57+data VarInfo = VI

58+ { viDeps :: DepSet -- dependencies drawn in by the variable

59+ , viFunArg :: Maybe Int -- which function argument this variable came from (defined only for patvars)

60+ , viMethod :: Maybe Name -- name of the metamethod represented by the var, if any

61+ }

62+ deriving Show

63+

64+type Vars = Map Name VarInfo

65+

66+-- Perform usage analysis, write the relevant information in the internal

67+-- structures, returning the list of reachable names.

68+performUsageAnalysis :: Idris [Name]

69+performUsageAnalysis = do

70+ ctx <- tt_ctxt <$> getIState

71+ mainName <- getMainName <$> getIState

72+

73+ case mainName of

74+ Left reason -> return [] -- no main -> not compiling -> reachability irrelevant

75+ Right main -> do

76+ ci <- idris_classes <$> getIState

77+ cg <- idris_callgraph <$> getIState

78+ opt <- idris_optimisation <$> getIState

79+

80+ -- Build the dependency graph.

81+ let depMap = buildDepMap ci ctx main

82+

83+ -- Search for reachable nodes in the graph.

84+ let (residDeps, (reachableNames, minUse)) = minimalUsage depMap

85+ usage = M.toList minUse

86+

87+ -- Print some debug info.

88+ logLvl 5 $ "Original deps:\n" ++ unlines (map fmtItem . M.toList $ depMap)

89+ logLvl 3 $ "Reachable names:\n" ++ unlines (map (indent . show) . S.toList $ reachableNames)

90+ logLvl 4 $ "Minimal usage:\n" ++ fmtUseMap usage

91+ logLvl 5 $ "Residual deps:\n" ++ unlines (map fmtItem . M.toList $ residDeps)

92+

93+ -- Check that everything reachable is accessible.

94+ checkEnabled <- (WarnReach `elem`) . opt_cmdline . idris_options <$> getIState

95+ when checkEnabled $

96+ mapM_ (checkAccessibility opt) usage

97+

98+ -- Check that no postulates are reachable.

99+ reachablePostulates <- S.intersection reachableNames . idris_postulates <$> getIState

100+ when (not . S.null $ reachablePostulates)

101+ $ ifail ("reachable postulates:\n" ++ intercalate "\n" [" " ++ show n | n <- S.toList reachablePostulates])

102+

103+ -- Store the usage info in the internal state.

104+ mapM_ storeUsage usage

105+

106+ return $ S.toList reachableNames

107+ where

108+ getMainName :: IState -> Either Err Name

109+ getMainName ist = case lookupCtxtName n (idris_implicits ist) of

110+ [(n', _)] -> Right n'

111+ [] -> Left (NoSuchVariable n)

112+ more -> Left (CantResolveAlts (map fst more))

113+ where

114+ n = sNS (sUN "main") ["Main"]

115+

116+ indent = (" " ++)

117+

118+ fmtItem :: (Cond, DepSet) -> String

119+ fmtItem (cond, deps) = indent $ show (S.toList cond) ++ " -> " ++ show (M.toList deps)

120+

121+ fmtUseMap :: [(Name, IntMap (Set Reason))] -> String

122+ fmtUseMap = unlines . map (\(n,is) -> indent $ show n ++ " -> " ++ fmtIxs is)

123+

124+ fmtIxs :: IntMap (Set Reason) -> String

125+ fmtIxs = intercalate ", " . map fmtArg . IM.toList

126+ where

127+ fmtArg (i, rs)

128+ | S.null rs = show i

129+ | otherwise = show i ++ " from " ++ intercalate ", " (map show $ S.toList rs)

130+

131+ storeUsage :: (Name, IntMap (Set Reason)) -> Idris ()

132+ storeUsage (n, args) = fputState (cg_usedpos . ist_callgraph n) flat

133+ where

134+ flat = [(i, S.toList rs) | (i,rs) <- IM.toList args]

135+

136+ checkAccessibility :: Ctxt OptInfo -> (Name, IntMap (Set Reason)) -> Idris ()

137+ checkAccessibility opt (n, reachable)

138+ | Just (Optimise inaccessible dt) <- lookupCtxtExact n opt

139+ , eargs@(_:_) <- [fmt n (S.toList rs) | (i,n) <- inaccessible, rs <- maybeToList $ IM.lookup i reachable]

140+ = warn $ show n ++ ": inaccessible arguments reachable:\n " ++ intercalate "\n " eargs

141+

142+ | otherwise = return ()

143+ where

144+ fmt n [] = show n ++ " (no more information available)"

145+ fmt n rs = show n ++ " from " ++ intercalate ", " [show rn ++ " arg# " ++ show ri | (rn,ri) <- rs]

146+ warn = logLvl 0

147+

148+-- Find the minimal consistent usage by forward chaining.

149+minimalUsage :: Deps -> (Deps, (Set Name, UseMap))

150+minimalUsage = second gather . forwardChain

151+ where

152+ gather :: DepSet -> (Set Name, UseMap)

153+ gather = foldr ins (S.empty, M.empty) . M.toList

154+ where

155+ ins :: (Node, Set Reason) -> (Set Name, UseMap) -> (Set Name, UseMap)

156+ ins ((n, Result), rs) (ns, umap) = (S.insert n ns, umap)

157+ ins ((n, Arg i ), rs) (ns, umap) = (ns, M.insertWith (IM.unionWith S.union) n (IM.singleton i rs) umap)

158+

159+forwardChain :: Deps -> (Deps, DepSet)

160+forwardChain deps

161+ | Just trivials <- M.lookup S.empty deps

162+ = (M.unionWith S.union trivials)

163+ `second` forwardChain (remove trivials . M.delete S.empty $ deps)

164+ | otherwise = (deps, M.empty)

165+ where

166+ -- Remove the given nodes from the Deps entirely,

167+ -- possibly creating new empty Conds.

168+ remove :: DepSet -> Deps -> Deps

169+ remove ds = M.mapKeysWith (M.unionWith S.union) (S.\\ M.keysSet ds)

170+

171+-- Build the dependency graph,

172+-- starting the depth-first search from a list of Names.

173+buildDepMap :: Ctxt ClassInfo -> Context -> Name -> Deps

174+buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]

175+ where

176+ -- mark the result of Main.main as used with the empty assumption

177+ addPostulates :: Deps -> Deps

178+ addPostulates deps = foldr (\(ds, rs) -> M.insertWith (M.unionWith S.union) ds rs) deps postulates

179+ where

180+ -- mini-DSL for postulates

181+ (==>) ds rs = (S.fromList ds, M.fromList [(r, S.empty) | r <- rs])

182+ it n is = [(sUN n, Arg i) | i <- is]

183+ mn n is = [(MN 0 $ pack n, Arg i) | i <- is]

184+

185+ -- believe_me is special because it does not use all its arguments

186+ specialPrims = S.fromList [sUN "prim__believe_me"]

187+ usedNames = allNames deps S.\\ specialPrims

188+ usedPrims = [(p_name p, p_arity p) | p <- primitives, p_name p `S.member` usedNames]

189+

190+ postulates =

191+ [ [] ==> concat

192+ -- These two, Main.main and run__IO, are always evaluated

193+ -- but they elude analysis since they come from the seed term.

194+ [ [(mainName, Result)]

195+ , [(sUN "run__IO", Result), (sUN "run__IO", Arg 0)]

196+

197+ -- MkIO is read by run__IO,

198+ -- but this cannot be observed in the source code of programs.

199+ , it "MkIO" [1]

200+ , it "prim__IO" [1]

201+

202+ -- these have been discovered as builtins but are not listed

203+ -- among Idris.Primitives.primitives

204+ , mn "__MkPair" [2,3]

205+ , it "prim_fork" [0]

206+ , it "unsafePerformPrimIO" [1]

207+

208+ -- believe_me is a primitive but it only uses its third argument

209+ -- it is special-cased in usedNames above

210+ , it "prim__believe_me" [2]

211+

212+ -- in general, all other primitives use all their arguments

213+ , [(n, Arg i) | (n,arity) <- usedPrims, i <- [0..arity-1]]

214+

215+ -- mkForeign* functions are special-cased below

216+ ]

217+ ]

218+

219+ -- perform depth-first search

220+ -- to discover all the names used in the program

221+ -- and call getDeps for every name

222+ dfs :: Set Name -> Deps -> [Name] -> Deps

223+ dfs visited deps [] = deps

224+ dfs visited deps (n : ns)

225+ | n `S.member` visited = dfs visited deps ns

226+ | otherwise = dfs (S.insert n visited) (M.unionWith (M.unionWith S.union) deps' deps) (next ++ ns)

227+ where

228+ next = [n | n <- S.toList depn, n `S.notMember` visited]

229+ depn = S.delete n $ allNames deps'

230+ deps' = getDeps n

231+

232+ -- extract all names that a function depends on

233+ -- from the Deps of the function

234+ allNames :: Deps -> Set Name

235+ allNames = S.unions . map names . M.toList

236+ where

237+ names (cs, ns) = S.map fst cs `S.union` S.map fst (M.keysSet ns)

238+

239+ -- get Deps for a Name

240+ getDeps :: Name -> Deps

241+ getDeps (SN (WhereN i (SN (InstanceCtorN classN)) (MN i' field)))

242+ = M.empty -- these deps are created when applying instance ctors

243+ getDeps n = case lookupDefExact n ctx of

244+ Just def -> getDepsDef n def

245+ Nothing -> error $ "erasure checker: unknown reference: " ++ show n

246+

247+ getDepsDef :: Name -> Def -> Deps

248+ getDepsDef fn (Function ty t) = error "a function encountered" -- TODO

249+ getDepsDef fn (TyDecl ty t) = M.empty

250+ getDepsDef fn (Operator ty n' f) = M.empty -- TODO: what's this?

251+ getDepsDef fn (CaseOp ci ty tys def tot cdefs)

252+ = getDepsSC fn etaVars (etaMap `M.union` varMap) sc

253+ where

254+ -- we must eta-expand the definition with fresh variables

255+ -- to capture these dependencies as well

256+ etaIdx = [length vars .. length tys - 1]

257+ etaVars = [eta i | i <- etaIdx]

258+ etaMap = M.fromList [varPair (eta i) i | i <- etaIdx]

259+ eta i = MN i (pack "eta")

260+

261+ -- the variables that arose as function arguments only depend on (n, i)

262+ varMap = M.fromList [varPair v i | (v,i) <- zip vars [0..]]

263+

264+ varPair n argNo = (n, VI

265+ { viDeps = M.singleton (fn, Arg argNo) S.empty

266+ , viFunArg = Just argNo

267+ , viMethod = Nothing

268+ })

269+

270+ (vars, sc) = cases_runtime cdefs

271+ -- we use cases_runtime in order to have case-blocks

272+ -- resolved to top-level functions before our analysis

273+

274+ etaExpand :: [Name] -> Term -> Term

275+ etaExpand [] t = t

276+ etaExpand (n : ns) t = etaExpand ns (App t (P Ref n Erased))

277+

278+ getDepsSC :: Name -> [Name] -> Vars -> SC -> Deps

279+ getDepsSC fn es vs ImpossibleCase = M.empty

280+ getDepsSC fn es vs (UnmatchedCase msg) = M.empty

281+

282+ -- for the purposes of erasure, we can disregard the projection

283+ getDepsSC fn es vs (ProjCase (Proj t i) alts) = getDepsSC fn es vs (ProjCase t alts) -- step

284+ getDepsSC fn es vs (ProjCase (P _ n _) alts) = getDepsSC fn es vs (Case n alts) -- base

285+

286+ -- other ProjCase's are not supported

287+ getDepsSC fn es vs (ProjCase t alts) = error $ "ProjCase not supported:\n" ++ show (ProjCase t alts)

288+

289+ getDepsSC fn es vs (STerm t) = getDepsTerm vs [] (S.singleton (fn, Result)) (etaExpand es t)

290+ getDepsSC fn es vs (Case n alts)

291+ -- we case-split on this variable, which marks it as used

292+ -- (unless there is exactly one case branch)

293+ -- hence we add a new dependency, whose only precondition is

294+ -- that the result of this function is used at all

295+ = addTagDep $ unionMap (getDepsAlt fn es vs casedVar) alts -- coming from the whole subtree

296+ where

297+ addTagDep = case alts of

298+ [_] -> id -- single branch, tag not used

299+ _ -> M.insertWith (M.unionWith S.union) (S.singleton (fn, Result)) (viDeps casedVar)

300+ casedVar = fromMaybe (error $ "nonpatvar in case: " ++ show n) (M.lookup n vs)

301+

302+ getDepsAlt :: Name -> [Name] -> Vars -> VarInfo -> CaseAlt -> Deps

303+ getDepsAlt fn es vs var (FnCase n ns sc) = error "an FnCase encountered" -- TODO: what's this?

304+ getDepsAlt fn es vs var (ConstCase c sc) = getDepsSC fn es vs sc

305+ getDepsAlt fn es vs var (DefaultCase sc) = getDepsSC fn es vs sc

306+ getDepsAlt fn es vs var (SucCase n sc)

307+ = getDepsSC fn es (M.insert n var vs) sc -- we're not inserting the S-dependency here because it's special-cased

308+

309+ -- data constructors

310+ getDepsAlt fn es vs var (ConCase n cnt ns sc)

311+ = getDepsSC fn es (vs' `M.union` vs) sc -- left-biased union

312+ where

313+ -- Here we insert dependencies that arose from pattern matching on a constructor.

314+ -- n = ctor name, j = ctor arg#, i = fun arg# of the cased var, cs = ctors of the cased var

315+ vs' = M.fromList [(v, VI

316+ { viDeps = M.insertWith S.union (n, Arg j) (S.singleton (fn, varIdx)) (viDeps var)

317+ , viFunArg = viFunArg var

318+ , viMethod = meth j

319+ })

320+ | (v, j) <- zip ns [0..]]

321+

322+ -- this is safe because it's certainly a patvar

323+ varIdx = fromJust (viFunArg var)

324+

325+ -- generate metamethod names, "n" is the instance ctor

326+ meth :: Int -> Maybe Name

327+ meth | SN (InstanceCtorN className) <- n = \j -> Just (mkFieldName n j)

328+ | otherwise = \j -> Nothing

329+

330+ -- Named variables -> DeBruijn variables -> Conds/guards -> Term -> Deps

331+ getDepsTerm :: Vars -> [(Name, Cond -> Deps)] -> Cond -> Term -> Deps

332+

333+ -- named variables introduce dependencies as described in `vs'

334+ getDepsTerm vs bs cd (P _ n _)

335+ -- de bruijns (lambda-bound, let-bound vars)

336+ | Just deps <- lookup n bs

337+ = deps cd

338+

339+ -- ctor-bound/arg-bound variables

340+ | Just var <- M.lookup n vs

341+ = M.singleton cd (viDeps var)

342+

343+ -- sanity check: machine-generated names shouldn't occur at top-level

344+ | MN _ _ <- n

345+ , n `notElem` specialMNs

346+ = error $ "erasure analysis: variable " ++ show n ++ " unbound in " ++ show (S.toList cd)

347+

348+ -- assumed to be a global reference

349+ | otherwise = M.singleton cd (M.singleton (n, Result) S.empty)

350+ where

351+ specialMNs = map (sMN 0 . ("__" ++)) $ words "Unit True False II"

352+

353+ -- dependencies of de bruijn variables are described in `bs'

354+ getDepsTerm vs bs cd (V i) = snd (bs !! i) cd

355+

356+ getDepsTerm vs bs cd (Bind n bdr t)

357+ -- here we just push IM.empty on the de bruijn stack

358+ -- the args will be marked as used at the usage site

359+ | Lam ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd t

360+ | Pi ty <- bdr = getDepsTerm vs ((n, const M.empty) : bs) cd t

361+

362+ -- let-bound variables can get partially evaluated

363+ -- it is sufficient just to plug the Cond in when the bound names are used

364+ | Let ty t <- bdr = getDepsTerm vs ((n, var t) : bs) cd t

365+ | NLet ty t <- bdr = getDepsTerm vs ((n, var t) : bs) cd t

366+ where

367+ var t cd = getDepsTerm vs bs cd t

368+

369+ -- applications may add items to Cond

370+ getDepsTerm vs bs cd app@(App _ _)

371+ | (fun, args) <- unApply app = case fun of

372+ -- instance constructors -> create metamethod deps

373+ P (DCon _ _) ctorName@(SN (InstanceCtorN className)) _

374+ -> conditionalDeps ctorName args -- regular data ctor stuff

375+ `union` unionMap (methodDeps ctorName) (zip [0..] args) -- method-specific stuff

376+

377+ -- ordinary constructors

378+ P (TCon _ _) n _ -> unconditionalDeps args -- does not depend on anything

379+ P (DCon _ _) n _ -> conditionalDeps n args -- depends on whether (n,#) is used

380+

381+ -- mkForeign* calls must be special-cased because they are variadic

382+ -- All arguments must be marked as used, except for the first one,

383+ -- which is the (Foreign a) spec that defines the type

384+ -- and is not needed at runtime.

385+ P _ (UN n) _

386+ | n `elem` map T.pack ["mkForeign", "mkForeignPrim", "mkLazyForeignPrim"]

387+ -> unconditionalDeps (drop 1 args)

388+

389+ -- a bound variable might draw in additional dependencies,

390+ -- think: f x = x 0 <-- here, `x' _is_ used

391+ P _ n _

392+ -- debruijn-bound name

393+ | Just deps <- lookup n bs

394+ -> deps cd `union` unconditionalDeps args

395+

396+ -- local name that refers to a method

397+ | Just var <- M.lookup n vs

398+ , Just meth <- viMethod var

399+ -> viDeps var `ins` conditionalDeps meth args -- use the method instead

400+

401+ -- local name

402+ | Just var <- M.lookup n vs

403+ -- unconditional use

404+ -> viDeps var `ins` unconditionalDeps args

405+

406+ -- global name

407+ | otherwise

408+ -- depends on whether the referred thing uses its argument

409+ -> conditionalDeps n args

410+

411+ -- TODO: could we somehow infer how bound variables use their arguments?

412+ V i -> snd (bs !! i) cd `union` unconditionalDeps args

413+

414+ -- we interpret applied lambdas as lets in order to reuse code here

415+ Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet [] app)

416+

417+ -- and we interpret applied lets as lambdas

418+ Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')

419+ Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')

420+

421+ Proj t i

422+ -> error $ "cannot[0] analyse projection !" ++ show i ++ " of " ++ show t

423+

424+ Erased -> M.empty

425+

426+ _ -> error $ "cannot analyse application of " ++ show fun ++ " to " ++ show args

427+ where

428+ union = M.unionWith $ M.unionWith S.union

429+ ins = M.insertWith (M.unionWith S.union) cd

430+

431+ unconditionalDeps :: [Term] -> Deps

432+ unconditionalDeps = unionMap (getDepsTerm vs bs cd)

433+

434+ conditionalDeps :: Name -> [Term] -> Deps

435+ conditionalDeps n

436+ = ins (M.singleton (n, Result) S.empty) . unionMap (getDepsArgs n) . zip indices

437+ where

438+ indices = map Just [0 .. getArity n - 1] ++ repeat Nothing

439+ getDepsArgs n (Just i, t) = getDepsTerm vs bs (S.insert (n, Arg i) cd) t -- conditional

440+ getDepsArgs n (Nothing, t) = getDepsTerm vs bs cd t -- unconditional

441+

442+ methodDeps :: Name -> (Int, Term) -> Deps

443+ methodDeps ctorName (methNo, t)

444+ = getDepsTerm (vars `M.union` vs) (bruijns ++ bs) cond body

445+ where

446+ vars = M.fromList [(v, VI

447+ { viDeps = deps i

448+ , viFunArg = Just i

449+ , viMethod = Nothing

450+ }) | (v, i) <- zip args [0..]]

451+ deps i = M.singleton (metameth, Arg i) S.empty

452+ bruijns = reverse [(n, \cd -> M.singleton cd (deps i)) | (i, n) <- zip [0..] args]

453+ cond = S.singleton (metameth, Result)

454+ metameth = mkFieldName ctorName methNo

455+ (args, body) = unfoldLams t

456+

457+ -- projections

458+ getDepsTerm vs bs cd (Proj t (-1)) = getDepsTerm vs bs cd t -- naturals, (S n) -> n

459+ getDepsTerm vs bs cd (Proj t i) = error $ "cannot[1] analyse projection !" ++ show i ++ " of " ++ show t

460+

461+ -- the easy cases

462+ getDepsTerm vs bs cd (Constant _) = M.empty

463+ getDepsTerm vs bs cd (TType _) = M.empty

464+ getDepsTerm vs bs cd Erased = M.empty

465+ getDepsTerm vs bs cd Impossible = M.empty

466+

467+ getDepsTerm vs bs cd t = error $ "cannot get deps of: " ++ show t

468+

469+ -- Get the number of arguments that might be considered for erasure.

470+ getArity :: Name -> Int

471+ getArity (SN (WhereN i' ctorName (MN i field)))

472+ | Just (TyDecl (DCon _ _) ty) <- lookupDefExact ctorName ctx

473+ = let argTys = map snd $ getArgTys ty

474+ in if i <= length argTys

475+ then length $ getArgTys (argTys !! i)

476+ else error $ "invalid field number " ++ show i ++ " for " ++ show ctorName

477+

478+ | otherwise = error $ "unknown instance constructor: " ++ show ctorName

479+

480+ getArity n = case lookupDefExact n ctx of

481+ Just (CaseOp ci ty tys def tot cdefs) -> length tys

482+ Just (TyDecl (DCon tag arity) _) -> arity

483+ Just (TyDecl (Ref) ty) -> length $ getArgTys ty

484+ Just (Operator ty arity op) -> arity

485+ Just df -> error $ "Erasure/getArity: unrecognised entity '"

486+ ++ show n ++ "' with definition: " ++ show df

487+ Nothing -> error $ "Erasure/getArity: definition not found for " ++ show n

488+

489+ -- convert applications of lambdas to lets

490+ -- Note that this transformation preserves de bruijn numbering

491+ lamToLet :: [Term] -> Term -> Term

492+ lamToLet xs (App f x) = lamToLet (x:xs) f

493+ lamToLet (x:xs) (Bind n (Lam ty) t) = Bind n (Let ty x) (lamToLet xs t)

494+ lamToLet (x:xs) t = App (lamToLet xs t) x

495+ lamToLet [] t = t

496+

497+ -- split "\x_i -> T(x_i)" into [x_i] and T

498+ unfoldLams :: Term -> ([Name], Term)

499+ unfoldLams (Bind n (Lam ty) t) = let (ns,t') = unfoldLams t in (n:ns, t')

500+ unfoldLams t = ([], t)

501+

502+ union :: Deps -> Deps -> Deps

503+ union = M.unionWith (M.unionWith S.union)

504+

505+ unions :: [Deps] -> Deps

506+ unions = M.unionsWith (M.unionWith S.union)

507+

508+ unionMap :: (a -> Deps) -> [a] -> Deps

509+ unionMap f = M.unionsWith (M.unionWith S.union) . map f

510+

511+-- Make a field name out of a data constructor name and field number.

512+mkFieldName :: Name -> Int -> Name

513+mkFieldName ctorName fieldNo = SN (WhereN fieldNo ctorName $ sMN fieldNo "field")

src/Idris/Error.hs+13−15

@@ -5,6 +5,7 @@ module Idris.Error where

5import Prelude hiding (catch)

6import Idris.AbsSyntax

7import Idris.Delaborate

8+import Idris.Output

8

9

9import Idris.Core.TT

10import Idris.Core.TT

10import Idris.Core.Typecheck

11import Idris.Core.Typecheck

@@ -23,7 +24,7 @@ iucheck = do tit <- typeInType

23 when (not tit) $

24 when (not tit) $

24 do ist <- getIState

25 do ist <- getIState

25 (tclift $ ucheck (idris_constraints ist)) `idrisCatch`

26 (tclift $ ucheck (idris_constraints ist)) `idrisCatch`

26− (\e -> do setErrLine (getErrLine e)

27+ (\e -> do setErrSpan (getErrSpan e)

27 iputStrLn (pshow ist e))

28 iputStrLn (pshow ist e))

28

29

29showErr :: Err -> Idris String

30showErr :: Err -> Idris String

@@ -42,11 +43,13 @@ idrisCatch = catchError

42setAndReport :: Err -> Idris ()

43setAndReport :: Err -> Idris ()

43setAndReport e = do ist <- getIState

44setAndReport e = do ist <- getIState

44 let h = idris_outh ist

45 let h = idris_outh ist

45− case e of

46+ case (unwrap e) of

46− At fc@(FC f l c) e -> do setErrLine l

47+ At fc e -> do setErrSpan fc

47− ihWarn h fc $ pprintErr ist e

48+ ihWarn h fc $ pprintErr ist e

48− _ -> do setErrLine (getErrLine e)

49+ _ -> do setErrSpan (getErrSpan e)

49− ihputStrLn h $ pshow ist e

50+ ihWarn h emptyFC $ pprintErr ist e

51+ where unwrap (ProofSearchFail e) = e -- remove bookkeeping constructor

52+ unwrap e = e

50

53

51ifail :: String -> Idris a

54ifail :: String -> Idris a

52ifail = throwError . Msg

55ifail = throwError . Msg

@@ -56,7 +59,7 @@ ierror = throwError

56

59

57tclift :: TC a -> Idris a

60tclift :: TC a -> Idris a

58tclift (OK v) = return v

61tclift (OK v) = return v

59−tclift (Error err@(At (FC f l c) e)) = do setErrLine l ; throwError err

62+tclift (Error err@(At fc e)) = do setErrSpan fc; throwError err

60tclift (Error err) = throwError err

63tclift (Error err) = throwError err

61

64

62tctry :: TC a -> TC a -> Idris a

65tctry :: TC a -> TC a -> Idris a

@@ -65,11 +68,6 @@ tctry tc1 tc2

65 OK v -> return v

68 OK v -> return v

66 Error err -> tclift tc2

69 Error err -> tclift tc2

67

70

68−getErrLine :: Err -> Int

71+getErrSpan :: Err -> FC

69−getErrLine (At (FC _ l _) _) = l

72+getErrSpan (At fc _) = fc

70−getErrLine _ = 0

73+getErrSpan _ = emptyFC

71−

72−getErrColumn :: Err -> Int

73−getErrColumn (At (FC _ _ c) _) = c

74−getErrColumn _ = 0

75−

src/Idris/Help.hs+12−6

@@ -4,6 +4,7 @@ data CmdArg = ExprArg -- ^ The command takes an expression

4 | NameArg -- ^ The command takes a name

5 | FileArg -- ^ The command takes a file

6 | ModuleArg -- ^ The command takes a module name

7+ | NamespaceArg -- ^ The command takes a namespace name

7 | OptionArg -- ^ The command takes an option

8 | OptionArg -- ^ The command takes an option

8 | MetaVarArg -- ^ The command takes a metavariable

9 | MetaVarArg -- ^ The command takes a metavariable

9 | ColourArg -- ^ The command is the colour-setting command

10 | ColourArg -- ^ The command is the colour-setting command

@@ -16,6 +17,7 @@ instance Show CmdArg where

16 show NameArg = "<name>"

17 show NameArg = "<name>"

17 show FileArg = "<filename>"

18 show FileArg = "<filename>"

18 show ModuleArg = "<module>"

19 show ModuleArg = "<module>"

20+ show NamespaceArg = "<namespace>"

19 show OptionArg = "<option>"

21 show OptionArg = "<option>"

20 show MetaVarArg = "<metavar>"

22 show MetaVarArg = "<metavar>"

21 show ColourArg = "<option>"

23 show ColourArg = "<option>"

@@ -29,22 +31,25 @@ help =

29 ([":t"], ExprArg, "Check the type of an expression"),

31 ([":t"], ExprArg, "Check the type of an expression"),

30 ([":miss", ":missing"], NameArg, "Show missing clauses"),

32 ([":miss", ":missing"], NameArg, "Show missing clauses"),

31 ([":doc"], NameArg, "Show internal documentation"),

33 ([":doc"], NameArg, "Show internal documentation"),

32− ([":i", ":info"], NameArg, "Display information about a type class"),

34+ ([":mkdoc"], NamespaceArg, "Generate IdrisDoc for namespace(s) and dependencies"),

35+ ([":apropos"], NoArg, "Search names, types, and documentation"),

36+ ([":search", ":s"], ExprArg, "Search for values by type"),

37+ ([":whocalls", ":wc"], NameArg, "List the callers of some name"),

38+ ([":callswho", ":cw"], NameArg, "List the callees of some name"),

33 ([":total"], NameArg, "Check the totality of a name"),

39 ([":total"], NameArg, "Check the totality of a name"),

34 ([":r",":reload"], NoArg, "Reload current file"),

40 ([":r",":reload"], NoArg, "Reload current file"),

35 ([":l",":load"], FileArg, "Load a new file"),

41 ([":l",":load"], FileArg, "Load a new file"),

36 ([":cd"], FileArg, "Change working directory"),

42 ([":cd"], FileArg, "Change working directory"),

37− ([":m",":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons

43+ ([":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons

38 ([":e",":edit"], NoArg, "Edit current file using $EDITOR or $VISUAL"),

44 ([":e",":edit"], NoArg, "Edit current file using $EDITOR or $VISUAL"),

39− ([":m",":metavars"], MetaVarArg, "Show remaining proof obligations (metavariables)"),

45+ ([":m",":metavars"], NoArg, "Show remaining proof obligations (metavariables)"),

40 ([":p",":prove"], MetaVarArg, "Prove a metavariable"),

46 ([":p",":prove"], MetaVarArg, "Prove a metavariable"),

41 ([":a",":addproof"], NameArg, "Add proof to source file"),

47 ([":a",":addproof"], NameArg, "Add proof to source file"),

42 ([":rmproof"], NameArg, "Remove proof from proof stack"),

48 ([":rmproof"], NameArg, "Remove proof from proof stack"),

43 ([":showproof"], NameArg, "Show proof"),

49 ([":showproof"], NameArg, "Show proof"),

44 ([":proofs"], NoArg, "Show available proofs"),

50 ([":proofs"], NoArg, "Show available proofs"),

45 ([":x"], ExprArg, "Execute IO actions resulting from an expression using the interpreter"),

51 ([":x"], ExprArg, "Execute IO actions resulting from an expression using the interpreter"),

46− ([":c",":compile"], FileArg, "Compile to an executable <filename>"),

52+ ([":c",":compile"], FileArg, "Compile to an executable [codegen] <filename>"),

47− ([":js", ":javascript"], FileArg, "Compile to JavaScript <filename>"),

48 ([":exec",":execute"], NoArg, "Compile to an executable and run"),

53 ([":exec",":execute"], NoArg, "Compile to an executable and run"),

49 ([":dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)"),

54 ([":dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)"),

50 ([":dynamic"], NoArg, "List dynamically loaded C libraries"),

55 ([":dynamic"], NoArg, "List dynamically loaded C libraries"),

@@ -53,7 +58,8 @@ help =

53 ([":unset"], OptionArg, "Unset an option"),

58 ([":unset"], OptionArg, "Unset an option"),

54 ([":colour", ":color"], ColourArg, "Turn REPL colours on or off; set a specific colour"),

59 ([":colour", ":color"], ColourArg, "Turn REPL colours on or off; set a specific colour"),

55 ([":consolewidth"], ConsoleWidthArg, "Set the width of the console"),

60 ([":consolewidth"], ConsoleWidthArg, "Set the width of the console"),

56− ([":q",":quit"], NoArg, "Exit the Idris system")

61+ ([":q",":quit"], NoArg, "Exit the Idris system"),

62+ ([":w", ":warranty"], NoArg, "Displays warranty information")

57 ]

63 ]

58

64

59-- | Use these for completion, but don't show them in :help

65-- | Use these for completion, but don't show them in :help

src/Idris/IBC.hs+229−86