git.iko.soy/Idris-dev

on master help sign in

.travis.yml+10−7

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

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

77 # trifecta dependencies

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

913install:

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

1115before_script:

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

1519 - cd idris*

1620script:

1721 - cabal configure -f FFI -f LLVM

18− - cabal build

19− - cabal copy

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

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

2024 - make -j2 $TESTS

2125env:

22− # TESTS=doc

23− - TESTS=test_c

24− - TESTS=test_java

25− - TESTS=test_llvm

26− - TESTS=test_js

26+ - TESTS="doc"

27+ - TESTS="test_c"

28+ - TESTS="test_llvm"

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+

140New in 0.9.12:

241--------------

342

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

544 type inference.

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

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

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

9−* Lots of performance patches for generated JavaScript

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

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

48+* Lots of performance patches for generated JavaScript.

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

11− or show the type of expressions

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

50+ or show the type of expressions.

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

1367

1468New in 0.9.11:

1569--------------

CONTRIBUTORS+7−4

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

88David Raymond Christiansen

99Jason Dagit

1010Simon Fowler

11+Google

1112Cezar Ionescu

1213Irene Knapp

14+Paul Koerbitz

15+Shea Levy

1316Mathnerd314

1417Hannes Mehnert

1518Mekeor Melire

1619Melissa Mozifian

1720Dominic Mulligan

1821Jan de Muijnck-Hughes

19−raichoo

2022Tom Prince

23+raichoo

24+Philip Rasmussen

25+Reynir Reynisson

2126Seo Sanghyeon

2227Benjamin Saunders

2328startling

2429Chetan T

30+Matúš Tejiščák

2531Dirk Ullrich

2632Leif Warner

2733Daniel Waterworth

2834Jonas Westerlund

29−Reynir Reynisson

30−Shea Levy

31−

Makefile+2−2

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

3939 $(CABAL) install $(CABALFLAGS)

4040

4141linecount:

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

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

4343

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

4545doc: dist/setup-config

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"

4747

4848

4949dist/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

22language with dependent types.

33

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

benchmarks/ALL+1

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

11trivial/sortvec 2000

22quasigroups/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

22CABAL :=cabal

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

44#CABALFLAGS :=

contribs/idrislang.sty+7−80

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

2424\RequirePackage{ifthen}

2525\RequirePackage{listings}

2626\RequirePackage{xspace}

27+\RequirePackage{textcomp}

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

2829\newboolean{literate}

2930\setboolean{literate}{false}

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

4849\lstdefinelanguage{idris}{%

4950 sensitive,%

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

51− xleftmargin=\parindent,

52+ xleftmargin=1.5em,

5253 tabsize=2,

54+ upquote=true,

5355 basicstyle=\ttfamily,

5456 flexiblecolumns=false,

5557 commentstyle=\footnotesize\sffamily,

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

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

6466},

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

66−%% Generated using

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

6868 morekeywords={%

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

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

7070 lambda, variable, index_first, index_next

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

97− % posInjective, negSInjective, posNotNeg, plusZeroLeftNeutralZ,

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

125− % maybeToList, listToMaybe, catMaybes, appendNilRightNeutral,

126− % appendAssociative, lengthAppend, mapPreservesLength,

127− % mapDistributesOverAppend, mapFusion, hasAnyByNilFalse,

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

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

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

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

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

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

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

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

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

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

13871 },

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

14073 morecomment=[l]--,%

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

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

167100

168101\lstdefinestyle{default}{%

169− xleftmargin=\parindent,

170− tabsize=2,

171102 basicstyle=\ttfamily

172103}

173104\lstdefinestyle{numbers}{%

174− xleftmargin=\parindent,

175− tabsize=2,

176105 numbers=left,

177106 numbersep=10pt,

178107 numberstyle=\footnotesize\sffamily,

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

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

187116 \lstset{language=literateidris}}{%

188117 \lstset{language=idris}}

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

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

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

192− }

193− {}

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

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

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

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

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

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

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

11Name: idris

2−Version: 0.9.11.2

2+Version: 0.9.13

33License: BSD3

44License-file: LICENSE

55Author: Edwin Brady

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

4646

4747Build-type: Custom

4848

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

49+Data-files: idrisdoc/styles.css

50+ jsrts/Runtime-browser.js

5051 jsrts/Runtime-common.js

5152 jsrts/Runtime-node.js

5253 jsrts/jsbn/jsbn.js

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

6566

6667 rts/*.c

6768 rts/*.h

69+ rts/windows/*.c

6870 rts/Makefile

6971

7072 libs/Makefile

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

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

8991 libs/base/Makefile

9092 libs/base/Network/*.idr

93+ libs/base/System/*.idr

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

9295 libs/base/Syntax/*.idr

9396

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

97100 libs/effects/Effect/*.idr

98101 libs/effects/*.idr

99102

100− libs/neweffects/Makefile

101− libs/neweffects/neweffects.ipkg

102− libs/neweffects/Effect/*.idr

103− libs/neweffects/*.idr

104−

105− libs/javascript/*.idr

106− libs/javascript/JavaScript/*.idr

107− libs/javascript/Makefile

108− libs/javascript/javascript.ipkg

103+ libs/oldeffects/Makefile

104+ libs/oldeffects/oldeffects.ipkg

105+ libs/oldeffects/Effect/*.idr

106+ libs/oldeffects/*.idr

109107

110108 llvm/*.c

111109 llvm/Makefile

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

221219 test/reg036/run

222220 test/reg036/*.idr

223221 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

224245

225246 test/basic001/run

226247 test/basic001/*.idr

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

250271 test/basic009/*.idr

251272 test/basic009/expected

252273 test/basic009/B/*.idr

274+ test/basic010/run

275+ test/basic010/*.idr

276+ test/basic010/expected

253277

254278 test/buffer001-disabled/*.idr

255279 test/buffer001-disabled/run

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

303327 test/ffi005/run

304328 test/ffi005/expected

305329

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+

306364 test/interactive001/run

307365 test/interactive001/input

308366 test/interactive001/*.idr

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

315373 test/interactive003/input

316374 test/interactive003/*.idr

317375 test/interactive003/expected

376+ test/interactive004/run

377+ test/interactive004/input

378+ test/interactive004/*.idr

379+ test/interactive004/expected

318380

319381 test/io001/run

320382 test/io001/*.idr

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

355417 test/records001/run

356418 test/records001/*.idr

357419 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

358426

359427 test/sugar001/run

360428 test/sugar001/*.idr

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

375443 test/totality003/run

376444 test/totality003/*.idr

377445 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

378481

379482source-repository head

380483 type: git

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

424527

425528 , Idris.AbsSyntax

426529 , Idris.AbsSyntaxTree

530+ , Idris.Apropos

531+ , Idris.ASTUtils

427532 , Idris.CaseSplit

428533 , Idris.Chaser

429534 , Idris.Colours

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

434539 , Idris.DeepSeq

435540 , Idris.Delaborate

436541 , Idris.Docs

542+ , Idris.Docstrings

437543 , Idris.ElabDecls

438544 , Idris.ElabTerm

545+ , Idris.Erasure

439546 , Idris.Error

440547 , Idris.ErrReverse

441548 , Idris.Help

442549 , Idris.IBC

443550 , Idris.IdeSlave

551+ , Idris.IdrisDoc

444552 , Idris.Imports

445553 , Idris.Inliner

554+ , Idris.Interactive

555+ , Idris.Output

446556 , Idris.Parser

447557 , Idris.ParseHelpers

448558 , Idris.ParseOps

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

456566 , Idris.REPL

457567 , Idris.REPLParser

458568 , Idris.Transforms

569+ , Idris.TypeSearch

459570 , Idris.Unlit

460− , Idris.UnusedArgs

571+ , Idris.WhoCalls

572+ , Idris.CmdOptions

461573

462574 , IRTS.BCImp

463575 , IRTS.Bytecode

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

499611 , ansi-terminal

500612 , ansi-wl-pprint

501613 , binary

614+ , blaze-html >= 0.6.1.3

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

502616 , bytestring

617+ , cheapskate

503618 , containers >= 0.5

504619 , directory

505620 , directory >= 1.2

506621 , filepath

507622 , haskeline >= 0.7

508623 , language-java >= 0.2.6

624+ , lens >= 4.1.1

509625 , mtl

510− , parsers >= 0.9

626+ , parsers >= 0.9 && < 0.11.0.2

511627 , pretty

512628 , process

513629 , split

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

523639 , xml

524640 , deepseq

525641 , zlib

642+ , optparse-applicative >= 0.8

526643 Extensions: MultiParamTypeClasses

527644 , FunctionalDependencies

528645 , 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 @@

11var __IDRRT__print = function(s) {

22 console.log(s);

33};

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−

41/** @constructor */

52var __IDRRT__Type = function(type) {

63 this.type = type;

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

3734

3835 return ret;

3936};

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

44 util.print(s);

55 };

66})();

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

12331233 return new BigInteger(val);

12341234}

12351235})();

1236+

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

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

libs/Makefile−6

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

22 $(MAKE) -C prelude build

33 $(MAKE) -C base build

44 $(MAKE) -C effects build

5− $(MAKE) -C neweffects build

6− $(MAKE) -C javascript build

75

86

97install:

108 $(MAKE) -C prelude install

119 $(MAKE) -C base install

1210 $(MAKE) -C effects install

13− $(MAKE) -C neweffects install

14− $(MAKE) -C javascript install

1511

1612clean:

1713 $(MAKE) -C prelude clean

1814 $(MAKE) -C base clean

1915 $(MAKE) -C effects clean

20− $(MAKE) -C neweffects clean

21− $(MAKE) -C javascript clean

2216

2317.PHONY: build install clean

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

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

1−module Category.Arrow

1+module Control.Arrow

22

33import Data.Morphisms

44import Control.Category

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

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

3838 y <- g a

3939 return (x, y)

40−

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

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

1−module Prelude.Catchable

1+module Control.Catchable

22

33import Control.IOExcept

44

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

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

44

55%default total

66

7−-- An isomorphism between two types

7+||| An isomorphism between two types

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

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

1010 (from : b -> a) ->

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

1414

1515-- Isomorphism properties

1616

17+||| Isomorphism is reflexive

1718isoRefl : Iso a a

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

1920

21+||| Isomorphism is transitive

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

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

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

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

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

2931 x QED)

3032

33+||| Isomorphism is symmetric

3134isoSym : Iso a b -> Iso b a

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

3336

3437-- Isomorphisms over sums

3538

39+||| Disjunction is commutative

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

3741eitherComm = MkIso swap swap swapSwap swapSwap

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

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

4246 swapSwap (Left x) = refl

4347 swapSwap (Right x) = refl

4448

49+||| Disjunction is associative

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

4651eitherAssoc = MkIso eitherAssoc1 eitherAssoc2 ok1 ok2

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

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

6469 ok2 (Left (Right x)) = refl

6570 ok2 (Right x) = refl

6671

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

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

6874eitherBotLeft = MkIso to from ok1 ok2

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

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

7783 ok2 (Left x) = FalseElim x

7884 ok2 (Right x) = refl

7985

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

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

8188eitherBotRight = isoTrans eitherComm eitherBotLeft

8289

83−

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

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

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

8693 (MkIso to from toFrom fromTo)

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

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

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

98105

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

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

100108eitherCongLeft i = eitherCong i isoRefl

101109

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

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

103112eitherCongRight i = eitherCong isoRefl i

104113

105114-- Isomorphisms over products

115+||| Conjunction is commutative

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

107117pairComm = MkIso swap swap swapSwap swapSwap

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

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

110−

120+

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

112122 swapSwap (x, y) = refl

113123

124+||| Conjunction is associative

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

115126pairAssoc = MkIso to from ok1 ok2

116127 where

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

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

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

125136

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

126138pairUnitRight : Iso (a, ()) a

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

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

129141 ok (x, ()) = refl

130142

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

131144pairUnitLeft : Iso ((), a) a

132145pairUnitLeft = isoTrans pairComm pairUnitRight

133146

147+||| Conjunction preserves falsehood

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

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

136150

151+||| Conjunction preserves falsehood

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

138153pairBotRight = isoTrans pairComm pairBotLeft

139154

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

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

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

142158 (MkIso to from toFrom fromTo)

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

155171 rewrite fromTo' y in

156172 refl

157173

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

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

159176pairCongLeft i = pairCong i isoRefl

160177

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

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

162180pairCongRight = pairCong isoRefl

163181

164182-- Distributivity of products over sums

183+||| Products distribute over sums

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

166185distribLeft = MkIso to from toFrom fromTo

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

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

177196 fromTo (Left x, y) = refl

178197 fromTo (Right x, y) = refl

179198

199+||| Products distribute over sums

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

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

182202

183203

184204-- Enable preorder reasoning syntax over isomorphisms

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

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

186207qed a = isoRefl

187208

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

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

189211step a iso1 iso2 = isoTrans iso1 iso2

190212

191213

192214

193215-- Isomorphisms over Maybe

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

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

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

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

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

200223 ok2 Nothing = refl

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

202225

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

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

204228maybeEither = MkIso to from iso1 iso2

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

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

215239 iso2 Nothing = refl

216240 iso2 (Just x) = refl

217241

242+||| Maybe of void is just unit

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

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

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

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

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

356356bitsToInt (MkBits x) = bitsToInt' x

357357

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

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

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

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

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

361361

362362--instance Cast Nat (Bits n) where

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

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

399399

400400-- TODO: Prove

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

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

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

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

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

404404 | (Z, Z) = believe_me x

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

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

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

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

414414

415−--public

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

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

415+public

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

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

418418

419419public

420420bitAt : Fin n -> Bits n

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

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

33%access public

44%default total

55

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

7− Nil : BoundedList a n

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

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

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

8+ Nil : BoundedList n a

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

910

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

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

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

1113length [] = fZ

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

1315

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

1517-- Indexing into bounded lists

1618--------------------------------------------------------------------------------

1719

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

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

1921index _ [] = Nothing

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

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

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

2426-- Adjusting bounds

2527--------------------------------------------------------------------------------

2628

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

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

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

2831weaken [] = []

2932weaken (x :: xs) = x :: weaken xs

3033

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

3235-- Conversions to and from list

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

3437

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

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

3639take _ [] = []

3740take Z _ = []

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

3942

40−toList : BoundedList a n -> List a

43+toList : BoundedList n a -> List a

4144toList [] = []

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

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

4346

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

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

4548fromList [] = []

4649fromList (x :: xs) = x :: fromList xs

4750

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

4952-- Building (bigger) bounded lists

5053--------------------------------------------------------------------------------

5154

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

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

5356replicate Z _ = []

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

5558

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

5760-- Folds

5861--------------------------------------------------------------------------------

5962

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

61−foldl f e [] = e

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

63−

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

65−foldr f e [] = e

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

63+instance Foldable (BoundedList n) where

64+ foldr f e [] = e

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

66+ foldl f e [] = e

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

6768

6869--------------------------------------------------------------------------------

6970-- Maps

7071--------------------------------------------------------------------------------

7172

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

73−map f [] = []

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

73+instance Functor (BoundedList n) where

74+ map f [] = []

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

7576

7677--------------------------------------------------------------------------------

7778-- Misc

7879--------------------------------------------------------------------------------

7980

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

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

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

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

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

8385pad {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

8789-- Simple properties

8890--------------------------------------------------------------------------------

8991

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

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

9193zeroBoundIsEmpty [] = refl

9294zeroBoundIsEmpty (_ :: _) impossible

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

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

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

2424-- would require exposing the offset argument of prim__appendBuffer

2525

26−-- A contiguous chunk of n bytes

26+||| A contiguous chunk of n bytes

2727abstract

2828record Buffer : Nat -> Type where

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

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

3636bitsFromFin fZ = 0

3737bitsFromFin (fS k) = 1 + bitsFromFin k

3838

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

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

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

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

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

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

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

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

4343public

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

4545allocate = MkBuffer Z . prim__allocate . bitsFromNat

4646

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

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

4848%assert_total

4949public

5050appendBuffer : Buffer n ->

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

6363 off : Bits64

6464 off = bitsFromNat o2

6565

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

67−-- pointed to to be freed

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

67+||| pointed to to be freed

6868public

6969copy : Buffer n -> Buffer n

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

7171

72−-- Create a view over a buffer

72+||| Create a view over a buffer

7373public

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

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

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

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

9494

9595

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

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

9797%assert_total

9898public

9999peekBits8 : Buffer ( 1 + n ) ->

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

101101 Bits8

102102peekBits8 = peekBits { m = 1 } prim__peekB8Native

103103

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

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

105105%assert_total

106106public

107107appendBits8 : Buffer n ->

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

110110 Buffer ( n + count * 1 )

111111appendBits8 = appendBits prim__appendB8Native

112112

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

114114%assert_total

115115public

116116peekBits16Native : Buffer ( 2 + n ) ->

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

118118 Bits16

119119peekBits16Native = peekBits { m = 2 } prim__peekB16Native

120120

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

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

122122%assert_total

123123public

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

125125peekBits16LE = peekBits { m = 2 } prim__peekB16LE

126126

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

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

128128%assert_total

129129public

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

131131peekBits16BE = peekBits { m = 2 } prim__peekB16BE

132132

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

134134%assert_total

135135public

136136appendBits16Native : Buffer n ->

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

139139 Buffer ( n + count * 2 )

140140appendBits16Native = appendBits prim__appendB16Native

141141

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

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

143143%assert_total

144144public

145145appendBits16LE : Buffer n ->

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

148148 Buffer ( n + count * 2 )

149149appendBits16LE = appendBits prim__appendB16LE

150150

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

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

152152%assert_total

153153public

154154appendBits16BE : Buffer n ->

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

157157 Buffer ( n + count * 2 )

158158appendBits16BE = appendBits prim__appendB16BE

159159

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

161161%assert_total

162162public

163163peekBits32Native : Buffer ( 4 + n ) ->

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

165165 Bits32

166166peekBits32Native = peekBits { m = 4 } prim__peekB32Native

167167

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

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

169169%assert_total

170170public

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

172172peekBits32LE = peekBits { m = 4 } prim__peekB32LE

173173

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

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

175175%assert_total

176176public

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

178178peekBits32BE = peekBits { m = 4 } prim__peekB32BE

179179

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

181181%assert_total

182182public

183183appendBits32Native : Buffer n ->

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

186186 Buffer ( n + count * 4 )

187187appendBits32Native = appendBits prim__appendB32Native

188188

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

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

190190%assert_total

191191public

192192appendBits32LE : Buffer n ->

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

195195 Buffer ( n + count * 4 )

196196appendBits32LE = appendBits prim__appendB32LE

197197

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

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

199199%assert_total

200200public

201201appendBits32BE : Buffer n ->

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

204204 Buffer ( n + count * 4 )

205205appendBits32BE = appendBits prim__appendB32BE

206206

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

208208%assert_total

209209public

210210peekBits64Native : Buffer ( 8 + n ) ->

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

212212 Bits64

213213peekBits64Native = peekBits { m = 8 } prim__peekB64Native

214214

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

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

216216%assert_total

217217public

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

219219peekBits64LE = peekBits { m = 8 } prim__peekB64LE

220220

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

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

222222%assert_total

223223public

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

225225peekBits64BE = peekBits { m = 8 } prim__peekB64BE

226226

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

228228%assert_total

229229public

230230appendBits64Native : Buffer n ->

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

233233 Buffer ( n + count * 8 )

234234appendBits64Native = appendBits prim__appendB64Native

235235

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

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

237237%assert_total

238238public

239239appendBits64LE : Buffer n ->

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

242242 Buffer ( n + count * 8 )

243243appendBits64LE = appendBits prim__appendB64LE

244244

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

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

246246%assert_total

247247public

248248appendBits64BE : Buffer n ->

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

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

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

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

6464instance Num (Complex Float) where

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

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

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

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

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

6868 fromInteger x = (fromInteger x:+0)

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

11module Data.Fun

22

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

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

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

3+%default total

4+

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

66Fun : Vect n Type -> Type -> Type

77Fun [] r = r

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

99

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

11−target {r} _ = r

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

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

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

1213

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

66%default total

77

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

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

10+ ||| the types of the contents.

911 data HVect : Vect k Type -> Type where

1012 Nil : HVect []

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

1214

15+ ||| Extract an element from an HVect

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

1417 index fZ (x::xs) = x

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

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

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

1821 deleteAt fZ (x::xs) = xs

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

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

2024 deleteAt _ [] impossible

2125

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

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

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

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

2933

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

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

3136 (++) [] ys = ys

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

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

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

5055 show xs = show (shows xs)

5156

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

58+ ||| @ t the goal type

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

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

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

5562

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

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

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

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

5967

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

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

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

6271 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

44

55%default total

66

7−-- Integers modulo 2^n

7+||| Integers modulo 2^n

88public

99data Mod2 : Nat -> Type where

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

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

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

22

33import Data.Fun

44

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

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

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

5+

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

87Rel : Vect n Type -> Type

98Rel ts = Fun ts Type

109

libs/base/Data/Sign.idr+2

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

11module Data.Sign

22

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

34data Sign = Plus | Minus

45

6+||| Discover the sign of some type

57class Signed t where

68 total sign : t -> Sign

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

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

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

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

185185

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

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

187187treeToList = treeToList' (:: [])

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

190190 treeToList' cont (Leaf k v) = cont (k, v)

191191 treeToList' cont (Branch2 t1 _ t2) = treeToList' (:: treeToList' cont t2) t1

192192 treeToList' cont (Branch3 t1 _ t2 _ t3) = treeToList' (:: treeToList' (:: treeToList' cont t3) t2) t1

@@ -223,7 +223,7 @@ delete k (M (S _) t) =

223223fromList : Ord k => List (k, v) -> SortedMap k v

224224fromList l = foldl (flip (uncurry insert)) empty l

225225

226−toList : Ord k => SortedMap k v -> List (k, v)

226+toList : SortedMap k v -> List (k, v)

227227toList Empty = []

228228toList (M _ t) = treeToList t

229229

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

@@ -21,5 +21,8 @@ contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)

2121fromList : Ord k => List k -> SortedSet k

2222fromList l = SetWrapper (Data.SortedMap.fromList (map (\i => (i, ())) l))

2323

24−toList : Ord k => SortedSet k -> List k

24+toList : SortedSet k -> List k

2525toList (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

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

1111

1212using (xs : Vect k a)

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

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

1415 Here : Elem x (x::xs)

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

1617

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

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

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

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

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

2041

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

@@ -7,8 +7,8 @@ import Data.Sign

77%access public

88

99

10−-- | An integer is either a positive nat or the negated successor of a nat.

11−-- Zero is chosen to be positive.

10+||| An integer is either a positive nat or the negated successor of a nat.

11+||| Zero is arbitrarily chosen to be positive.

1212data ZZ = Pos Nat | NegS Nat

1313

1414instance Signed ZZ where

libs/base/Debug/Trace.idr+4−1

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

11module Debug.Trace

22

3−trace : String -> a -> a

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

4+||| @ msg what to print

5+||| @ result the final result

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

47trace x val = unsafePerformIO (do putStrLn x; return val)

58

69

libs/base/Decidable/Order.idr+25−2

@@ -10,7 +10,7 @@ import Decidable.Equality

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

1111

1212--------------------------------------------------------------------------------

13−-- Preorders, Posets and total Orders

13+-- Preorders, Posets, total Orders, Equivalencies, Congruencies

1414--------------------------------------------------------------------------------

1515

1616class Preorder t (po : t -> t -> Type) where

@@ -21,7 +21,16 @@ class (Preorder t po) => Poset t (po : t -> t -> Type) where

2121 total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b

2222

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

2534

2635minimum : (Ordered t to) => t -> t -> t

2736minimum x y with (order x y)

@@ -33,6 +42,20 @@ maximum x y with (order x y)

3342 | Left _ = y

3443 | Right _ = x

3544

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+

3659--------------------------------------------------------------------------------

3760-- Natural numbers

3861--------------------------------------------------------------------------------

libs/base/Language/Reflection.idr+10−6

@@ -22,7 +22,7 @@ data TTUExp = UVar Int

2222 -- ^ explicit universe variable

2323%name TTUExp uexp

2424

25−-- | Primitive constants

25+||| Primitive constants

2626data Const = I Int | BI Integer | Fl Float | Ch Char | Str String

2727 | IType | BIType | FlType | ChType | StrType

2828 | B8 Bits8 | B16 Bits16 | B32 Bits32 | B64 Bits64

@@ -66,7 +66,7 @@ reflectConstant: (ReflConst a) => a -> Const

6666reflectConstant = toConst

6767

6868

69−-- | Types of named references

69+||| Types of named references

7070data NameType = Bound

7171 -- ^ reference which is just bound, e.g. by intro

7272 | Ref

@@ -77,8 +77,8 @@ data NameType = Bound

7777 -- ^ type constructor with tag and number

7878%name NameType nt, nt'

7979

80−-- | Types annotations for bound variables in different

81−-- binding contexts

80+||| Types annotations for bound variables in different

81+||| binding contexts

8282data Binder a = Lam a

8383 | Pi a

8484 | Let a a

@@ -124,7 +124,7 @@ instance Traversable Binder where

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

125125

126126

127−-- | Reflection of the well typed core language

127+||| Reflection of the well typed core language

128128data TT = P NameType TTName TT

129129 -- ^ named binders

130130 | V Int

@@ -146,7 +146,7 @@ data TT = P NameType TTName TT

146146

147147%name TT tm, tm'

148148

149−-- | Raw terms without types

149+||| Raw terms without types

150150data Raw = Var TTName

151151 | RBind TTName (Binder Raw) Raw

152152 | RApp Raw Raw

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

167167 -- ^ apply both tactics in sequence

168168 | Trivial

169169 -- ^ intelligently construct the proof target from the context

170+ | Search Int

171+ -- ^ build a proof by applying contructors up to a maximum depth

170172 | Instance

171173 -- ^ resolve a type class

172174 | Solve

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

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

181183 | Reflect TT

182184 -- ^ turn a value into its reflected representation

185+ | ByReflection TT

186+ -- ^ use a %reflection function

183187 | Fill Raw

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

185189 | Exact TT

libs/base/Language/Reflection/Errors.idr+2−4

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

33import Language.Reflection

44

55data SourceLocation : Type where

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

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

77

88%name SourceLocation loc

99

@@ -35,14 +35,12 @@ data Err = Msg String

3535 | AlreadyDefined TTName

3636 | ProofSearchFail Err

3737 | NoRewriting TT

38− | At SourceLocation Err

39− | Elaborating String TTName Err

4038 | ProviderError String

4139 | LoadingFailed String Err

4240

4341%name Err err, e

4442

45−-- | Error reports are a list of report parts

43+||| Error reports are a list of report parts

4644data ErrorReportPart = TextPart String

4745 | NamePart TTName

4846 | TermPart TT

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

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

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

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

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

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

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

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

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

259257

libs/base/Providers.idr+9−7

@@ -1,25 +1,27 @@

11module Providers

22

3+||| Type providers must build one of these in an IO computation.

34public

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

513

614-- instances

715instance Functor Provider where

816 map f (Provide a) = Provide (f a)

917 map f (Error err) = Error err

10− map f Postulate = Postulate

1118

1219instance Applicative Provider where

1320 (Provide f) <$> (Provide x) = Provide (f x)

1421 (Provide f) <$> (Error err) = Error err

15− (Provide f) <$> Postulate = Postulate

1622 (Error err) <$> _ = Error err

17− Postulate <$> (Error err) = Error err

18− Postulate <$> _ = Postulate

1923 pure = Provide

2024

21−-- is this correct for Postulate?

2225instance Monad Provider where

2326 (Provide x) >>= f = f x

2427 (Error err) >>= _ = Error err

25− Postulate >>= f = Postulate

libs/base/System.idr+9−6

@@ -5,6 +5,7 @@ import Prelude

55%default partial

66%access public

77

8+||| Get the command-line arguments that the program was called with.

89getArgs : IO (List String)

910getArgs = do n <- numArgs

1011 ga' [] 0 n

@@ -20,8 +21,8 @@ getArgs = do n <- numArgs

2021 do arg <- getArg i

2122 ga' (arg :: acc) (i+1) n

2223

23−-- Retrieves an value from the environment, if the given key is present,

24−-- otherwise it returns Nothing.

24+||| Retrieves an value from the environment, if the given key is present,

25+||| otherwise it returns Nothing.

2526getEnv : String -> IO (Maybe String)

2627getEnv key = do

2728 str_ptr <- getEnv'

@@ -33,15 +34,15 @@ getEnv key = do

3334 getEnv' : IO String

3435 getEnv' = mkForeign (FFun "getenv" [FString] FString) key

3536

36−-- Sets an environment variable with a given value.

37−-- Returns true if the operation was successful.

37+||| Sets an environment variable with a given value.

38+||| Returns true if the operation was successful.

3839setEnv : String -> String -> IO Bool

3940setEnv key value = do

4041 ok <- mkForeign (FFun "setenv" [FString, FString, FInt] FInt) key value 1

4142 return (ok == 0)

4243

43−-- Unsets an environment variable.

44−-- Returns true if the variable was able to be unset.

44+||| Unsets an environment variable.

45+||| Returns true if the variable was able to be unset.

4546unsetEnv : String -> IO Bool

4647unsetEnv key = do

4748 ok <- mkForeign (FFun "unsetenv" [FString] FInt) key

@@ -68,9 +69,11 @@ getEnvironment = getAllPairs 0 []

6869 then return $ reverse $ map splitEq acc

6970 else getAllPairs (n + 1) (envPair :: acc)

7071

72+||| Quit with a particular exit code

7173exit : Int -> IO ()

7274exit code = mkForeign (FFun "exit" [FInt] FUnit) code

7375

76+||| Get the Unix time

7477time : IO Int

7578time = mkForeign (FFun "idris_time" [] FInt)

7679

libs/base/System/Concurrency/Process.idr+7−14

@@ -9,9 +9,8 @@ import System.Concurrency.Raw

99abstract

1010data ProcID msg = MkPID Ptr

1111

12−-- Type safe message passing programs. Parameterised over the type of

13−-- message which can be send, and the return type.

14−

12+||| Type safe message passing programs. Parameterised over the type of

13+||| message which can be send, and the return type.

1514data Process : (msgType : Type) -> Type -> Type where

1615 lift : IO a -> Process msg a

1716

@@ -30,31 +29,26 @@ instance Monad (Process msg) where

3029run : Process msg x -> IO x

3130run (lift prog) = prog

3231

33−-- Get current process ID

34−

32+||| Get current process ID

3533myID : Process msg (ProcID msg)

3634myID = lift (return (MkPID prim__vm))

3735

38−-- Send a message to another process

39−

36+||| Send a message to another process

4037send : ProcID msg -> msg -> Process msg ()

4138send (MkPID p) m = lift (sendToThread p (prim__vm, m))

4239

43−-- Return whether a message is waiting in the queue

44−

40+||| Return whether a message is waiting in the queue

4541msgWaiting : Process msg Bool

4642msgWaiting = lift checkMsgs

4743

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

49−

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

5045recv : Process msg msg

5146recv {msg} = do (senderid, m) <- lift get

5247 return m

5348 where get : IO (Ptr, msg)

5449 get = getMsg

5550

56−-- receive a message, and return with the sender's process ID.

57−

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

5852recvWithSender : Process msg (ProcID msg, msg)

5953recvWithSender {msg}

6054 = do (senderid, m) <- lift get

@@ -65,4 +59,3 @@ recvWithSender {msg}

6559create : Process msg () -> Process msg (ProcID msg)

6660create (lift p) = do ptr <- lift (fork p)

6761 return (MkPID ptr)

68−

libs/base/System/Concurrency/Raw.idr+3−6

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

66

77import System

88

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

10−

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

1110sendToThread : (thread_id : Ptr) -> a -> IO ()

1211sendToThread {a} dest val

1312 = mkForeign (FFun "idris_sendMessage"

@@ -18,10 +17,8 @@ checkMsgs = do msgs <- mkForeign (FFun "idris_checkMessages"

1817 [FPtr] FInt) prim__vm

1918 return (intToBool msgs)

2019

21−-- Check inbox for messages. If there are none, blocks until a message

22−-- arrives.

23−

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

21+||| arrives.

2422getMsg : IO a

2523getMsg {a} = mkForeign (FFun "idris_recvMessage"

2624 [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,

66 Network.Cgi, Network.Socket,

77 Debug.Trace,

88

9+ System.Info,

910 System.Concurrency.Raw, System.Concurrency.Process,

1011

1112 Decidable.Decidable, Decidable.Order,

@@ -22,7 +23,8 @@ modules = System,

2223 Data.SortedMap, Data.SortedSet, Data.BoundedList,

2324 Data.Vect, Data.HVect, Data.Vect.Quantifiers,

2425 Data.Floats, Data.Complex, Data.Heap, Data.Fun,

25− Data.Rel, Data.Buffer,

26+ Data.Rel, Data.Buffer, Data.Erased,

27+ Data.List,

2628

2729 Control.Isomorphism, Control.Isomorphism.Primitives,

2830 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

44import System

55import Control.IOExcept

66

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

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

7+data Exception : Type -> Effect where

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

99

1010instance Handler (Exception a) Maybe where

1111 handle _ (Raise e) k = Nothing

1212

13+instance Handler (Exception a) List where

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

15+

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

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

1518 believe_me (exit 1)

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

2326EXCEPTION : Type -> EFFECT

2427EXCEPTION t = MkEff () (Exception t)

2528

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

27−raise err = Raise err

28−

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

30+raise err = call $ Raise err

2931

3032

3133

libs/effects/Effect/File.idr+108−49

@@ -1,69 +1,128 @@

1+-- -------------------------------------------------------- [ Effectful FileIO ]

12module Effect.File

23

34import Effects

45import Control.IOExcept

56

6−data OpenFile : Mode -> Type where

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.

13+data OpenFile : (m : Mode) -> Type where

714 FH : File -> OpenFile m

815

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

939data 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−

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.

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

57+

58+ ||| Read a line from the file.

59+ |||

60+ ||| Only files that are open for reading can be read.

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.

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

67+

68+ ||| End of file?

69+ |||

70+ ||| Only files open for reading can be tested for EOF

71+ EOF : {OpenFile Read} FileIO Bool

72+

73+-- ------------------------------------------------------------ [ The Handlers ]

74+

75+--- An implementation of the resource access protocol for the IO Context.

1876instance Handler FileIO IO where

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

2078 valid <- validFile h

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

22− else k (Left ()) False

79+ if valid then k True (FH h)

80+ else k False ()

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

2482 k () ()

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

26− k (FH h) str

84+ k str (FH h)

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

28− k (FH h) ()

86+ k () (FH h)

2987 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

88+ k e (FH h)

4589

90+-- -------------------------------------------------------------- [ The Effect ]

4691FILE_IO : Type -> EFFECT

4792FILE_IO t = MkEff t FileIO

4893

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−

94+-- ------------------------------------------------------------ [ The Bindings ]

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

107+ then OpenFile m

108+ else ())] } Eff e Bool

109+open f m = call $ Open f m

110+

111+

112+||| Close a file.

113+close : { [FILE_IO (OpenFile m)] ==> [FILE_IO ()] } Eff e ()

114+close = call $ Close

115+

116+||| Read a line from the file.

117+readLine : { [FILE_IO (OpenFile Read)] } Eff e String

118+readLine = call $ ReadLine

119+

120+||| Write a line to a file.

121+writeLine : String -> { [FILE_IO (OpenFile Write)] } Eff e ()

122+writeLine str = call $ WriteLine str

123+

124+||| End of file?

125+eof : { [FILE_IO (OpenFile Read)] } Eff e Bool

126+eof = call $ EOF

127+

128+-- --------------------------------------------------------------------- [ EOF ]

libs/effects/Effect/Memory.idr+38−32

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

1212abstract

1313data RawMemory : Effect where

1414 Allocate : (n : Nat) ->

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

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

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

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

1717 Initialize : Bits8 ->

1818 (size : Nat) ->

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

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

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

2121 Peek : (offset : Nat) ->

2222 (size : Nat) ->

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

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

24+ RawMemory (Vect size Bits8)

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

2526 Poke : (offset : Nat) ->

2627 (Vect size Bits8) ->

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

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

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

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

3031 (dst_offset : Nat) ->

3132 (src_offset : Nat) ->

3233 (size : Nat) ->

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

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

35− RawMemory (MemoryChunk dst_size dst_init)

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

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

36+ RawMemory () (MemoryChunk dst_size dst_init)

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

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

3839

3940private

4041do_malloc : Nat -> IOExcept String Ptr

@@ -79,58 +80,61 @@ do_poke ptr offset (b::bs)

7980instance Handler RawMemory (IOExcept String) where

8081 handle () (Allocate n) k

8182 = do ptr <- do_malloc n

82− k (CH ptr) ()

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

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

83+ k () (CH ptr)

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

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

8586 handle (CH ptr) (Free) k

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

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

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

89− k (CH ptr) res

90+ k res (CH ptr)

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

9192 = do ioe_lift (do_poke ptr offset content)

92− k (CH ptr) ()

93+ k () (CH ptr)

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

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

95− k (CH dest_ptr) ()

96+ k () (CH dest_ptr)

9697 handle chunk (GetRawPtr) k

9798 = k chunk chunk

9899

99100RAW_MEMORY : Type -> EFFECT

100101RAW_MEMORY t = MkEff t RawMemory

101102

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

103−allocate size = Allocate size

103+allocate : (n : Nat) ->

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

105+allocate size = call $ Allocate size

104106

105107initialize : {i : Nat} ->

106108 {n : Nat} ->

107109 Bits8 ->

108110 (size : Nat) ->

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

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

111−initialize c size prf = Initialize c size prf

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

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

114+initialize c size prf = call $ Initialize c size prf

112115

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

114−free = Free

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

117+free = call Free

115118

116119peek : {i : Nat} ->

117120 (offset : Nat) ->

118121 (size : Nat) ->

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

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

121−peek offset size prf = Peek offset size prf

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

124+peek offset size prf = call $ Peek offset size prf

122125

123126poke : {n : Nat} ->

124127 {i : Nat} ->

125128 (offset : Nat) ->

126129 Vect size Bits8 ->

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

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

129−poke offset content prf = Poke offset content prf

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

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

133+poke offset content prf = call $ Poke offset content prf

130134

131135private

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

133−getRawPtr = GetRawPtr

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

137+getRawPtr = call $ GetRawPtr

134138

135139private

136140move' : {dst_size : Nat} ->

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

142146 (size : Nat) ->

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

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

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

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

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

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

147151move' src_ptr dst_offset src_offset size dst_bounds src_bounds

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

149153

150154data MoveDescriptor = Dst | Src

151155

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

158162 (size : Nat) ->

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

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

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

165+ Eff m ()

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

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

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

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

168+ (\v =>

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

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

165171move dst_offset src_offset size dst_bounds src_bounds

166172 = do src_ptr <- Src :- getRawPtr

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

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

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

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

66

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

8− instance Functor (EffM m xs xs) where

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

99 map f prog = do t <- prog

1010 value (f t)

1111

12− instance Applicative (EffM m xs xs) where

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

1313 pure = value

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

1515 a' <- a

1616 value (f' a')

1717

18− instance Monad (EffM m xs xs) where

19− (>>=) = ebind

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

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

2020

2121

libs/effects/Effect/Random.idr+31−9

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

22

33import Effects

44

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

6− getRandom : Random Integer Integer Integer

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

5+data Random : Effect where

6+ getRandom : { Integer } Random Integer

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

88

99using (m : Type -> Type)

1010 instance Handler Random m where

1111 handle seed getRandom k

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

1313 k seed' seed'

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

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

1515

1616RND : EFFECT

1717RND = MkEff Integer Random

1818

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

20−rndInt lower upper = do v <- getRandom

19+||| Generates a random Integer in a given range

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

21+rndInt lower upper = do v <- call $ getRandom

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

2223

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

24−srand n = setSeed n

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

46+srand n = call $ setSeed n

2547

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

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

33import Effects

44

55data Selection : Effect where

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

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

77

88instance Handler Selection Maybe where

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

1010 tryAll [] = Nothing

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

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

1212 Nothing => tryAll xs

1313 Just v => Just v

1414

1515instance Handler Selection List where

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

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

1717

1818SELECT : EFFECT

1919SELECT = MkEff () Selection

2020

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

22−select xs = Select xs

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

22+select xs = call $ Select xs

2323

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

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

55%access public

66

77data State : Effect where

8− Get : State a a a

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

8+ Get : { a } State a

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

1010

1111using (m : Type -> Type)

1212 instance Handler State m where

1313 handle st Get k = k st st

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

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

1515

1616STATE : Type -> EFFECT

1717STATE t = MkEff t State

1818

19−get : Eff m [STATE x] x

20−get = Get

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

20+get = call $ Get

2121

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

23−put val = Put val

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

23+put val = call $ Put val

2424

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

26−putM val = Put val

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

26+putM val = call $ Put val

2727

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

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

2929update f = put (f !get)

3030

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

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

3232updateM f = putM (f !get)

3333

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

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

3535locally newst prog = do st <- get

3636 putM newst

3737 val <- prog

libs/effects/Effect/StdIO.idr+38−38

@@ -3,58 +3,58 @@ module Effect.StdIO

33import Effects

44import Control.IOExcept

55

6+-------------------------------------------------------------

7+-- IO effects internals

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

9+

10+||| The internal representation of StdIO effects

611data StdIO : Effect where

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

8− GetStr : StdIO () () String

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

13+ GetStr : { () } StdIO String

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

15+ GetCh : { () } StdIO Char

16+

17+

18+-------------------------------------------------------------

19+-- IO effects handlers

20+-------------------------------------------------------------

921

1022instance Handler StdIO IO where

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

1327

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

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

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

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

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

3533

34+-------------------------------------------------------------

3635--- The Effect and associated functions

36+-------------------------------------------------------------

3737

3838STDIO : EFFECT

3939STDIO = MkEff () StdIO

4040

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

42−putStr s = PutStr s

41+||| Write a string to standard output.

42+putStr : String -> { [STDIO] } Eff e ()

43+putStr s = call $ PutStr s

4344

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

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

45+||| Write a character to standard output.

46+putChar : Char -> { [STDIO] } Eff e ()

47+putChar c = call $ PutCh c

4648

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

48−getStr = GetStr

49+||| Write a string to standard output, terminating with a newline.

50+putStrLn : String -> { [STDIO] } Eff e ()

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

4952

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

53+||| Read a string from standard input.

54+getStr : { [STDIO] } Eff e String

55+getStr = call $ GetStr

5956

57+||| Read a character from standard input.

58+getChar : { [STDIO] } Eff e Char

59+getChar = call $ GetCh

6060

libs/neweffects/Effect/System.idr → libs/effects/Effect/System.idrrenamed+3−3

@@ -28,11 +28,11 @@ SYSTEM : EFFECT

2828SYSTEM = MkEff () System

2929

3030getArgs : Handler System e => { [SYSTEM] } Eff e (List String)

31−getArgs = Args

31+getArgs = call Args

3232

3333time : Handler System e => { [SYSTEM] } Eff e Int

34−time = Time

34+time = call Time

3535

3636getEnv : Handler System e => String -> { [SYSTEM] } Eff e (Maybe String)

37−getEnv s = GetEnv s

37+getEnv s = call $ GetEnv s

3838

libs/effects/Effects.idr+205−201

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

22

33import Language.Reflection

44import Control.Catchable

5+import Effect.Default

56

6−%access public

7−

8−---- Effects

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

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

99

10+%access public

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

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

13+|||

14+||| This type is parameterised by:

15+||| + The input resource.

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

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

1018Effect : Type

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

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

1220

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

22+||| description into a concrete effect.

1323%error_reverse

1424data EFFECT : Type where

1525 MkEff : Type -> Effect -> EFFECT

1626

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

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

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

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

30+ ||| How to handle the effect.

31+ |||

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

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

34+ ||| @ 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...)

1946

20−---- Properties and proof construction

47+-- No state transition

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

2149

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

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

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

53+

54+--- A simple state transition

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

56+

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

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

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

2460 SubNil : SubList {a} [] []

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

2965 subListId {xs = Nil} = SubNil

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

3167

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

33− Nil : Env m Nil

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

35−

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

68+namespace Env

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

70+ Nil : Env m Nil

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

72+

73+data EffElem : Effect -> Type ->

3774 List EFFECT -> Type where

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

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

4077

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

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

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

4380dropEnv [] SubNil = []

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

@@ -52,57 +89,23 @@ updateWith [] [] SubNil = []

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

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

5491

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

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

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

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

5895rebuildEnv [] SubNil env = env

96+rebuildEnv (x :: xs) SubNil env = x :: xs

97+rebuildEnv [] (Keep rest) (y :: env) = []

5998rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

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

101100

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

101+

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

103+

104+updateResTy : (val : t) ->

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

106+ List EFFECT

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

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

106109

107110infix 5 :::, :-, :=

108111

@@ -110,148 +113,117 @@ data LRes : lbl -> Type -> Type where

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

111114

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

114121

115122private

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

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

118125

119126private

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

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

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

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

130+

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

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.

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

139+ -> (x : Type)

140+ -> (es : List EFFECT)

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

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'

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

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

147+ callP : (prf : EffElem e a xs) ->

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

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

150+

151+ liftP : (prf : SubList ys xs) ->

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

153+ newInit : Handler e m =>

154+ res ->

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

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

157+ catch : Catchable m err =>

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

159+ Eff m a xs xs'

160+

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

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

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

164+

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

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

167+(>>=) = ebind

168+

169+-- namespace SimpleBind

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

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

172+-- (>>=) = ebind

173+

174+||| Run a subprogram which results in an effect state the same as the input.

175+staticEff : Eff m a xs (\v => xs) -> Eff m a xs (\v => xs)

176+staticEff = id

177+

178+||| Explicitly give the expected set of result effects for an effectful

179+||| operation.

180+toEff : .(xs' : List EFFECT) -> Eff m a xs (\v => xs') -> Eff m a xs (\v => xs')

181+toEff xs' = id

182+

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

187184return x = value x

188185

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 ]

193187

194188infixl 2 <$>

195189

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

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

197191pure = value

198192

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)

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

201198 arg <- v

202199 return (fn arg)

203200

204−-- an interpreter

201+-- ---------------------------------------------------------- [ an interpreter ]

205202

206203private

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

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

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

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

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

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

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

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

237212

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

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

240215

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

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

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

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

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

221+eff env (callP prf effP) k = execEff env prf effP k

222+eff env (liftP prf effP) k

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

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

225+eff env (newInit r prog) k

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

255227eff env (catch prog handler) k

256228 = catch (eff env prog k)

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

@@ -261,48 +233,80 @@ eff env (catch prog handler) k

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

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

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

265256

266257implicit

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

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

259+ {default tactics { search 100; }

260+ prf : SubList ys xs} ->

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

262+lift e {prf} = liftP prf e

272263

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

280264

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

281270

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)

271+-- --------------------------------------------------------- [ Running Effects ]

284272

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

273+||| Run an effectful program

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

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

287276

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

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

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

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

290279

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

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

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

293282

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)

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

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

296285

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

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

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

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

299288

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

301292

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

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

294+

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

303296mapE f [] = pure []

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

305298

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

307−when True e = e

299+

300+mapVE : Applicative m =>

301+ (a -> {xs} Eff m b) ->

302+ Vect n a ->

303+ {xs} Eff m (Vect n b)

304+mapVE f [] = pure []

305+mapVE f (x :: xs) = [| f x :: mapVE f xs |]

306+

307+

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

309+when True e = Force e

308310when False e = pure ()

311+

312+-- --------------------------------------------------------------------- [ EOF ]

libs/effects/effects.ipkg+3−2

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

11package effects

22

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

4−modules = Effects,

4+modules = Effects, Effect.Default,

5+

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

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

7− Effect.Memory, Effect.Monad

8+ Effect.Memory, Effect.System

89

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

44import System

55import Control.IOExcept

66

7−data Exception : Type -> Effect where

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

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

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

99

1010instance Handler (Exception a) Maybe where

1111 handle _ (Raise e) k = Nothing

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

2323EXCEPTION : Type -> EFFECT

2424EXCEPTION t = MkEff () (Exception t)

2525

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

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

2727raise err = Raise err

2828

2929

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

3131

3232

3333

34+

3435-- TODO: Catching exceptions mid program?

3536-- probably need to invoke a new interpreter

3637

libs/oldeffects/Effect/File.idrnew file+69

@@ -0,0 +1,69 @@

1+module Effect.File

2+

3+import Effects

4+import Control.IOExcept

5+

6+data OpenFile : Mode -> Type where

7+ FH : File -> OpenFile m

8+

9+data FileIO : Effect where

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

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

12+

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

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

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

16+

17+

18+instance Handler FileIO IO where

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

20+ valid <- validFile h

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

22+ else k (Left ()) False

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

24+ k () ()

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

26+ k (FH h) str

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

28+ k (FH h) ()

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

30+ k (FH h) e

31+

32+instance Handler FileIO (IOExcept String) where

33+ handle () (Open fname m) k

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

35+ valid <- ioe_lift (validFile h)

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

37+ else k (Left ()) False

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

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

40+ k (FH h) str

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

42+ k (FH h) ()

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

44+ k (FH h) e

45+

46+FILE_IO : Type -> EFFECT

47+FILE_IO t = MkEff t FileIO

48+

49+open : Handler FileIO e =>

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

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

52+open f m = Open f m

53+

54+close : Handler FileIO e =>

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

56+close = Close

57+

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

59+readLine = ReadLine

60+

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

62+writeLine str = WriteLine str

63+

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

65+eof = EOF

66+

67+

68+

69+

libs/neweffects/Effect/Memory.idr → libs/oldeffects/Effect/Memory.idrrenamed+25−31

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

1212abstract

1313data RawMemory : Effect where

1414 Allocate : (n : Nat) ->

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

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

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

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

1717 Initialize : Bits8 ->

1818 (size : Nat) ->

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

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

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

2121 Peek : (offset : Nat) ->

2222 (size : Nat) ->

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

24− RawMemory (Vect size Bits8)

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

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

2625 Poke : (offset : Nat) ->

2726 (Vect size Bits8) ->

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

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

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

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

3130 (dst_offset : Nat) ->

3231 (src_offset : Nat) ->

3332 (size : Nat) ->

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

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

36− RawMemory () (MemoryChunk dst_size dst_init)

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

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

35+ RawMemory (MemoryChunk dst_size dst_init)

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

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

3938

4039private

4140do_malloc : Nat -> IOExcept String Ptr

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

8079instance Handler RawMemory (IOExcept String) where

8180 handle () (Allocate n) k

8281 = do ptr <- do_malloc n

83− k () (CH ptr)

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

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

82+ k (CH ptr) ()

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

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

8685 handle (CH ptr) (Free) k

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

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

8988 = do res <- ioe_lift (do_peek ptr offset size)

90− k res (CH ptr)

89+ k (CH ptr) res

9190 handle (CH ptr) (Poke offset content _) k

9291 = do ioe_lift (do_poke ptr offset content)

93− k () (CH ptr)

92+ k (CH ptr) ()

9493 handle (CH dest_ptr) (Move (CH src_ptr) dest_offset src_offset size _ _) k

9594 = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)

96− k () (CH dest_ptr)

95+ k (CH dest_ptr) ()

9796 handle chunk (GetRawPtr) k

9897 = k chunk chunk

9998

10099RAW_MEMORY : Type -> EFFECT

101100RAW_MEMORY t = MkEff t RawMemory

102101

103−allocate : (n : Nat) ->

104− Eff m () [RAW_MEMORY ()] (\v => [RAW_MEMORY (MemoryChunk n 0)])

102+allocate : (n : Nat) -> EffM m [RAW_MEMORY ()] [RAW_MEMORY (MemoryChunk n 0)] ()

105103allocate size = Allocate size

106104

107105initialize : {i : Nat} ->

@@ -109,18 +107,17 @@ initialize : {i : Nat} ->

109107 Bits8 ->

110108 (size : Nat) ->

111109 so (i + size <= n) ->

112− Eff m () [RAW_MEMORY (MemoryChunk n i)]

113− (\v => [RAW_MEMORY (MemoryChunk n (i + size))])

110+ EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (i + size))] ()

114111initialize c size prf = Initialize c size prf

115112

116−free : Eff m () [RAW_MEMORY (MemoryChunk n i)] (\v => [RAW_MEMORY ()])

113+free : EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY ()] ()

117114free = Free

118115

119116peek : {i : Nat} ->

120117 (offset : Nat) ->

121118 (size : Nat) ->

122119 so (offset + size <= i) ->

123− { [RAW_MEMORY (MemoryChunk n i)] } Eff m (Vect size Bits8)

120+ Eff m [RAW_MEMORY (MemoryChunk n i)] (Vect size Bits8)

124121peek offset size prf = Peek offset size prf

125122

126123poke : {n : Nat} ->

@@ -128,12 +125,11 @@ poke : {n : Nat} ->

128125 (offset : Nat) ->

129126 Vect size Bits8 ->

130127 so (offset <= i && offset + size <= n) ->

131− Eff m () [RAW_MEMORY (MemoryChunk n i)]

132− (\v => [RAW_MEMORY (MemoryChunk n (max i (offset + size)))])

128+ EffM m [RAW_MEMORY (MemoryChunk n i)] [RAW_MEMORY (MemoryChunk n (max i (offset + size)))] ()

133129poke offset content prf = Poke offset content prf

134130

135131private

136−getRawPtr : { [RAW_MEMORY (MemoryChunk n i)] } Eff m (MemoryChunk n i)

132+getRawPtr : Eff m [RAW_MEMORY (MemoryChunk n i)] (MemoryChunk n i)

137133getRawPtr = GetRawPtr

138134

139135private

@@ -146,8 +142,8 @@ move' : {dst_size : Nat} ->

146142 (size : Nat) ->

147143 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

148144 so (src_offset + size <= src_init) ->

149− Eff m () [RAW_MEMORY (MemoryChunk dst_size dst_init)]

150− (\v => [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))])

145+ EffM m [RAW_MEMORY (MemoryChunk dst_size dst_init)]

146+ [RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))] ()

151147move' src_ptr dst_offset src_offset size dst_bounds src_bounds

152148 = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

153149

@@ -162,12 +158,10 @@ move : {dst_size : Nat} ->

162158 (size : Nat) ->

163159 so (dst_offset <= dst_init && dst_offset + size <= dst_size) ->

164160 so (src_offset + size <= src_init) ->

165− Eff m ()

166− [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)

161+ EffM m [ Dst ::: RAW_MEMORY (MemoryChunk dst_size dst_init)

167162 , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)]

168− (\v =>

169− [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))

170− , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)])

163+ [ Dst ::: RAW_MEMORY (MemoryChunk dst_size (max dst_init (dst_offset + size)))

164+ , Src ::: RAW_MEMORY (MemoryChunk src_size src_init)] ()

171165move dst_offset src_offset size dst_bounds src_bounds

172166 = do src_ptr <- Src :- getRawPtr

173167 Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds

libs/neweffects/Effect/Monad.idr → libs/oldeffects/Effect/Monad.idrrenamed+4−4

@@ -5,17 +5,17 @@ import Effects

55-- Eff is a monad too, so we can happily use it in a monad transformer.

66

77using (xs : List EFFECT, m : Type -> Type)

8− instance Functor (\a => EffM m a xs (\v => xs)) where

8+ instance Functor (EffM m xs xs) where

99 map f prog = do t <- prog

1010 value (f t)

1111

12− instance Applicative (\a => EffM m a xs (\v => xs)) where

12+ instance Applicative (EffM m xs xs) where

1313 pure = value

1414 (<$>) f a = do f' <- f

1515 a' <- a

1616 value (f' a')

1717

18− instance Monad (\a => Eff m a xs (\v => xs)) where

19− (>>=) = Effects.(>>=)

18+ instance Monad (EffM m xs xs) where

19+ (>>=) = ebind

2020

2121

libs/oldeffects/Effect/Random.idrnew file+25

@@ -0,0 +1,25 @@

1+module Effect.Random

2+

3+import Effects

4+

5+data Random : Type -> Type -> Type -> Type where

6+ getRandom : Random Integer Integer Integer

7+ setSeed : Integer -> Random Integer Integer ()

8+

9+using (m : Type -> Type)

10+ instance Handler Random m where

11+ handle seed getRandom k

12+ = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in

13+ k seed' seed'

14+ handle seed (setSeed n) k = k n ()

15+

16+RND : EFFECT

17+RND = MkEff Integer Random

18+

19+rndInt : Integer -> Integer -> Eff m [RND] Integer

20+rndInt lower upper = do v <- getRandom

21+ return (v `prim__sremBigInt` (upper - lower) + lower)

22+

23+srand : Integer -> Eff m [RND] ()

24+srand n = setSeed n

25+

libs/neweffects/Effect/Select.idr → libs/oldeffects/Effect/Select.idrrenamed+4−4

@@ -3,21 +3,21 @@ module Effect.Select

33import Effects

44

55data Selection : Effect where

6− Select : List a -> { () } Selection a

6+ Select : List a -> Selection () () a

77

88instance Handler Selection Maybe where

99 handle _ (Select xs) k = tryAll xs where

1010 tryAll [] = Nothing

11− tryAll (x :: xs) = case k x () of

11+ tryAll (x :: xs) = case k () x of

1212 Nothing => tryAll xs

1313 Just v => Just v

1414

1515instance Handler Selection List where

16− handle r (Select xs) k = concatMap (\x => k x r) xs

16+ handle r (Select xs) k = concatMap (k r) xs

1717

1818SELECT : EFFECT

1919SELECT = MkEff () Selection

2020

21−select : List a -> { [SELECT] } Eff m a

21+select : List a -> Eff m [SELECT] a

2222select xs = Select xs

2323

libs/neweffects/Effect/State.idr → libs/oldeffects/Effect/State.idrrenamed+9−9

@@ -5,33 +5,33 @@ import Effects

55%access public

66

77data State : Effect where

8− Get : { a } State a

9− Put : b -> { a ==> b } State ()

8+ Get : State a a a

9+ Put : b -> State a b ()

1010

1111using (m : Type -> Type)

1212 instance Handler State m where

1313 handle st Get k = k st st

14− handle st (Put n) k = k () n

14+ handle st (Put n) k = k n ()

1515

1616STATE : Type -> EFFECT

1717STATE t = MkEff t State

1818

19−get : { [STATE x] } Eff m x

19+get : Eff m [STATE x] x

2020get = Get

2121

22−put : x -> { [STATE x] } Eff m ()

22+put : x -> Eff m [STATE x] ()

2323put val = Put val

2424

25−putM : y -> { [STATE x] ==> [STATE y] } Eff m ()

25+putM : y -> EffM m [STATE x] [STATE y] ()

2626putM val = Put val

2727

28−update : (x -> x) -> { [STATE x] } Eff m ()

28+update : (x -> x) -> Eff m [STATE x] ()

2929update f = put (f !get)

3030

31−updateM : (x -> y) -> { [STATE x] ==> [STATE y] } Eff m ()

31+updateM : (x -> y) -> EffM m [STATE x] [STATE y] ()

3232updateM f = putM (f !get)

3333

34−locally : x -> ({ [STATE x] } Eff m t) -> { [STATE y] } Eff m t

34+locally : x -> Eff m [STATE x] t -> Eff m [STATE y] t

3535locally newst prog = do st <- get

3636 putM newst

3737 val <- prog

libs/oldeffects/Effect/StdIO.idrnew file+60

@@ -0,0 +1,60 @@

1+module Effect.StdIO

2+

3+import Effects

4+import Control.IOExcept

5+

6+data StdIO : Effect where

7+ PutStr : String -> StdIO () () ()

8+ GetStr : StdIO () () String

9+

10+instance Handler StdIO IO where

11+ handle () (PutStr s) k = do putStr s; k () ()

12+ handle () GetStr k = do x <- getLine; k () x

13+

14+instance Handler StdIO (IOExcept a) where

15+ handle () (PutStr s) k = do ioe_lift (putStr s); k () ()

16+ handle () GetStr k = do x <- ioe_lift getLine; k () x

17+

18+-- Handle effects in a pure way, for simulating IO for unit testing/proof

19+

20+data IOStream a = MkStream (List String -> (a, List String))

21+

22+instance Handler StdIO IOStream where

23+ handle () (PutStr s) k

24+ = MkStream (\x => case k () () of

25+ MkStream f => let (res, str) = f x in

26+ (res, s :: str))

27+ handle {a} () GetStr k

28+ = MkStream (\x => case x of

29+ [] => cont "" []

30+ (t :: ts) => cont t ts)

31+ where

32+ cont : String -> List String -> (a, List String)

33+ cont t ts = case k () t of

34+ MkStream f => f ts

35+

36+--- The Effect and associated functions

37+

38+STDIO : EFFECT

39+STDIO = MkEff () StdIO

40+

41+putStr : Handler StdIO e => String -> Eff e [STDIO] ()

42+putStr s = PutStr s

43+

44+putStrLn : Handler StdIO e => String -> Eff e [STDIO] ()

45+putStrLn s = putStr (s ++ "\n")

46+

47+getStr : Handler StdIO e => Eff e [STDIO] String

48+getStr = GetStr

49+

50+mkStrFn : Env IOStream xs ->

51+ Eff IOStream xs a ->

52+ List String -> (a, List String)

53+mkStrFn {a} env p input = case mkStrFn' of

54+ MkStream f => f input

55+ where injStream : a -> IOStream a

56+ injStream v = MkStream (\x => (v, []))

57+ mkStrFn' : IOStream a

58+ mkStrFn' = runWith injStream env p

59+

60+

libs/oldeffects/Effects.idrnew file+308

@@ -0,0 +1,308 @@

1+module Effects

2+

3+import Language.Reflection

4+import Control.Catchable

5+

6+%access public

7+

8+---- Effects

9+

10+Effect : Type

11+Effect = Type -> Type -> Type -> Type

12+

13+%error_reverse

14+data EFFECT : Type where

15+ MkEff : Type -> Effect -> EFFECT

16+

17+class Handler (e : Effect) (m : Type -> Type) where

18+ handle : res -> (eff : e res res' t) -> (res' -> t -> m a) -> m a

19+

20+---- Properties and proof construction

21+

22+using (xs : List a, ys : List a)

23+ data SubList : List a -> List a -> Type where

24+ SubNil : SubList {a} [] []

25+ Keep : SubList xs ys -> SubList (x :: xs) (x :: ys)

26+ Drop : SubList xs ys -> SubList xs (x :: ys)

27+

28+ subListId : SubList xs xs

29+ subListId {xs = Nil} = SubNil

30+ subListId {xs = x :: xs} = Keep subListId

31+

32+data Env : (m : Type -> Type) -> List EFFECT -> Type where

33+ Nil : Env m Nil

34+ (::) : Handler eff m => a -> Env m xs -> Env m (MkEff a eff :: xs)

35+

36+data EffElem : (Type -> Type -> Type -> Type) -> Type ->

37+ List EFFECT -> Type where

38+ Here : EffElem x a (MkEff a x :: xs)

39+ There : EffElem x a xs -> EffElem x a (y :: xs)

40+

41+-- make an environment corresponding to a sub-list

42+dropEnv : Env m ys -> SubList xs ys -> Env m xs

43+dropEnv [] SubNil = []

44+dropEnv (v :: vs) (Keep rest) = v :: dropEnv vs rest

45+dropEnv (v :: vs) (Drop rest) = dropEnv vs rest

46+

47+updateWith : (ys' : List a) -> (xs : List a) ->

48+ SubList ys xs -> List a

49+updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

50+updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest

51+updateWith [] [] SubNil = []

52+updateWith (y :: ys) [] SubNil = y :: ys

53+updateWith [] (x :: xs) (Keep rest) = []

54+

55+-- put things back, replacing old with new in the sub-environment

56+rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->

57+ Env m xs -> Env m (updateWith ys' xs prf)

58+rebuildEnv [] SubNil env = env

59+rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

60+rebuildEnv xs (Drop rest) (y :: env) = y :: rebuildEnv xs rest env

61+rebuildEnv (x :: xs) SubNil [] = x :: xs

62+

63+---- The Effect EDSL itself ----

64+

65+-- some proof automation

66+

67+%reflection

68+reflectListEffElem : List a -> Tactic

69+reflectListEffElem [] = Refine "Here" `Seq` Solve

70+reflectListEffElem (x :: xs)

71+ = Try (Refine "Here" `Seq` Solve)

72+ (Refine "There" `Seq` (Solve `Seq` reflectListEffElem xs))

73+-- TMP HACK! FIXME!

74+-- The evaluator needs a 'function case' to know its a reflection function

75+-- until we propagate that information! Without this, the _ case won't get

76+-- matched.

77+reflectListEffElem (x ++ y) = Refine "Here" `Seq` Solve

78+reflectListEffElem _ = Refine "Here" `Seq` Solve

79+

80+%reflection

81+reflectSubList : List a -> Tactic

82+reflectSubList [] = Refine "SubNil" `Seq` Solve

83+reflectSubList (x :: xs)

84+ = Try (Refine "subListId" `Seq` Solve)

85+ (Try (Refine "Keep" `Seq` (Solve `Seq` reflectSubList xs))

86+ (Refine "Drop" `Seq` (Solve `Seq` reflectSubList xs)))

87+reflectSubList (x ++ y) = Refine "subListId" `Seq` Solve

88+reflectSubList _ = Refine "subListId" `Seq` Solve

89+

90+%reflection

91+reflectEff : (P : Type) -> Tactic

92+reflectEff (EffElem m a xs)

93+ = reflectListEffElem xs `Seq` Solve

94+reflectEff (SubList xs ys)

95+ = reflectSubList ys `Seq` Solve

96+

97+updateResTy : (xs : List EFFECT) -> EffElem e a xs -> e a b t ->

98+ List EFFECT

99+updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs

100+updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n

101+

102+updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->

103+ List EFFECT

104+updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs

105+updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b

106+

107+infix 5 :::, :-, :=

108+

109+data LRes : lbl -> Type -> Type where

110+ (:=) : (x : lbl) -> res -> LRes x res

111+

112+(:::) : lbl -> EFFECT -> EFFECT

113+(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff

114+

115+private

116+unlabel : {l : ty} -> Env m [l ::: x] -> Env m [x]

117+unlabel {m} {x = MkEff a eff} [l := v] = [v]

118+

119+private

120+relabel : (l : ty) -> Env m [x] -> Env m [l ::: x]

121+relabel {x = MkEff a eff} l [v] = [l := v]

122+

123+-- the language of Effects

124+

125+data EffM : (m : Type -> Type) ->

126+ List EFFECT -> List EFFECT -> Type -> Type where

127+ value : a -> EffM m xs xs a

128+ ebind : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b

129+ effect : (prf : EffElem e a xs) ->

130+ (eff : e a b t) ->

131+ EffM m xs (updateResTy xs prf eff) t

132+ lift : (prf : SubList ys xs) ->

133+ EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t

134+ new : Handler e m =>

135+ res -> EffM m (MkEff res e :: xs) (MkEff res' e :: xs') a ->

136+ EffM m xs xs' a

137+ test : (prf : EffElem e (Either l r) xs) ->

138+ EffM m (updateResTyImm xs prf l) xs' t ->

139+ EffM m (updateResTyImm xs prf r) xs' t ->

140+ EffM m xs xs' t

141+ test_lbl : {x : lbl} ->

142+ (prf : EffElem e (LRes x (Either l r)) xs) ->

143+ EffM m (updateResTyImm xs prf (LRes x l)) xs' t ->

144+ EffM m (updateResTyImm xs prf (LRes x r)) xs' t ->

145+ EffM m xs xs' t

146+ catch : Catchable m err =>

147+ EffM m xs xs' a -> (err -> EffM m xs xs' a) ->

148+ EffM m xs xs' a

149+ (:-) : (l : ty) -> EffM m [x] [y] t -> EffM m [l ::: x] [l ::: y] t

150+

151+syntax [tag] ":!" [val] = !(tag :- val)

152+

153+-- Eff : List (EFFECT m) -> Type -> Type

154+

155+-- For making proofs implicitly for 'test' and 'test_lbl'

156+

157+syntax if_valid then [e] else [t] =

158+ test (tactics { byReflection reflectEff; }) t e

159+

160+syntax if_valid [lbl] then [e] else [t] =

161+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

162+

163+syntax if_error then [t] else [e] =

164+ test (tactics { byReflection reflectEff; }) t e

165+

166+syntax if_error [lbl] then [t] else [e] =

167+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

168+

169+-- These may read better in some contexts

170+

171+syntax if_right then [e] else [t] =

172+ test (tactics { byReflection reflectEff; }) t e

173+

174+syntax if_right [lbl] then [e] else [t] =

175+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

176+

177+syntax if_left then [t] else [e] =

178+ test (tactics { byReflection reflectEff; }) t e

179+

180+syntax if_left [lbl] then [t] else [e] =

181+ test_lbl {x=lbl} (tactics { byReflection reflectEff; }) t e

182+

183+

184+-- for 'do' notation

185+

186+return : a -> EffM m xs xs a

187+return x = value x

188+

189+(>>=) : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b

190+(>>=) = ebind

191+

192+-- for idiom brackets

193+

194+infixl 2 <$>

195+

196+pure : a -> EffM m xs xs a

197+pure = value

198+

199+(<$>) : EffM m xs xs (a -> b) -> EffM m xs xs a -> EffM m xs xs b

200+(<$>) prog v = do fn <- prog

201+ arg <- v

202+ return (fn arg)

203+

204+-- an interpreter

205+

206+private

207+execEff : Env m xs -> (p : EffElem e res xs) ->

208+ (eff : e res b a) ->

209+ (Env m (updateResTy xs p eff) -> a -> m t) -> m t

210+execEff (val :: env) Here eff' k

211+ = handle val eff' (\res, v => k (res :: env) v)

212+execEff {e} {res} {b} {a} (val :: env) (There p) eff k

213+ = execEff {e} {res} {b} {a} env p eff (\env', v => k (val :: env') v)

214+

215+private

216+testEff : Env m xs -> (p : EffElem e (Either l r) xs) ->

217+ (Env m (updateResTyImm xs p l) -> m b) ->

218+ (Env m (updateResTyImm xs p r) -> m b) ->

219+ m b

220+testEff (Left err :: env) Here lk rk = lk (err :: env)

221+testEff (Right ok :: env) Here lk rk = rk (ok :: env)

222+testEff (val :: env) (There p) lk rk

223+ = testEff env p (\envk => lk (val :: envk))

224+ (\envk => rk (val :: envk))

225+

226+private

227+testEffLbl : {x : lblTy} ->

228+ Env m xs -> (p : EffElem e (LRes x (Either l r)) xs) ->

229+ (Env m (updateResTyImm xs p (LRes x l)) -> m b) ->

230+ (Env m (updateResTyImm xs p (LRes x r)) -> m b) ->

231+ m b

232+testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env)

233+testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env)

234+testEffLbl (val :: env) (There p) lk rk

235+ = testEffLbl env p (\envk => lk (val :: envk))

236+ (\envk => rk (val :: envk))

237+

238+-- Q: Instead of m b, implement as StateT (Env m xs') m b, so that state

239+-- updates can be propagated even through failing computations?

240+

241+eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b

242+eff env (value x) k = k env x

243+eff env (prog `ebind` c) k

244+ = eff env prog (\env', p' => eff env' (c p') k)

245+eff env (effect prf effP) k = execEff env prf effP k

246+eff env (lift prf effP) k

247+ = let env' = dropEnv env prf in

248+ eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p')

249+eff env (new r prog) k

250+ = eff (r :: env) prog (\(v :: envk), p' => k envk p')

251+eff env (test prf l r) k

252+ = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)

253+eff env (test_lbl prf l r) k

254+ = testEffLbl env prf (\envk => eff envk l k) (\envk => eff envk r k)

255+eff env (catch prog handler) k

256+ = catch (eff env prog k)

257+ (\e => eff env (handler e) k)

258+-- FIXME:

259+-- xs is needed explicitly because otherwise the pattern binding for

260+-- 'l' appears too late. Solution seems to be to reorder patterns at the

261+-- end so that everything is in scope when it needs to be.

262+eff {xs = [l ::: x]} env (l :- prog) k

263+ = let env' = unlabel env in

264+ eff env' prog (\envk, p' => k (relabel l envk) p')

265+

266+implicit

267+lift' : EffM m ys ys' t ->

268+ {default tactics { byReflection reflectEff; }

269+ prf : SubList ys xs} ->

270+ EffM m xs (updateWith ys' xs prf) t

271+lift' e {prf} = lift prf e

272+

273+implicit

274+effect' : {a, b: _} -> {e : Effect} ->

275+ (eff : e a b t) ->

276+ {default tactics { byReflection reflectEff; }

277+ prf : EffElem e a xs} ->

278+ EffM m xs (updateResTy xs prf eff) t

279+effect' e {prf} = effect prf e

280+

281+

282+run : Applicative m => Env m xs -> EffM m xs xs' a -> m a

283+run env prog = eff env prog (\env, r => pure r)

284+

285+runEnv : Applicative m => Env m xs -> EffM m xs xs' a -> m (Env m xs', a)

286+runEnv env prog = eff env prog (\env, r => pure (env, r))

287+

288+runPure : Env id xs -> EffM id xs xs' a -> a

289+runPure env prog = eff env prog (\env, r => r)

290+

291+-- runPureEnv : Env id xs -> EffM id xs xs' a -> (Env id xs', a)

292+-- runPureEnv env prog = eff env prog (\env, r => (env, r))

293+

294+runWith : (a -> m a) -> Env m xs -> EffM m xs xs' a -> m a

295+runWith inj env prog = eff env prog (\env, r => inj r)

296+

297+Eff : (Type -> Type) -> List EFFECT -> Type -> Type

298+Eff m xs t = EffM m xs xs t

299+

300+-- some higher order things

301+

302+mapE : Applicative m => (a -> Eff m xs b) -> List a -> Eff m xs (List b)

303+mapE f [] = pure []

304+mapE f (x :: xs) = [| f x :: mapE f xs |]

305+

306+when : Applicative m => Bool -> 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 @@

11IDRIS := idris

22

33build:

4− $(IDRIS) --build neweffects.ipkg

4+ $(IDRIS) --build oldeffects.ipkg

55

66clean:

7− $(IDRIS) --clean neweffects.ipkg

7+ $(IDRIS) --clean oldeffects.ipkg

88

99install:

10− $(IDRIS) --install neweffects.ipkg

10+ $(IDRIS) --install oldeffects.ipkg

1111

1212rebuild: clean build

1313

libs/neweffects/neweffects.ipkg → libs/oldeffects/oldeffects.ipkgrenamed+3−4

@@ -1,9 +1,8 @@

1−package neweffects

1+package oldeffects

22

33opts = "--nobasepkgs -i ../prelude -i ../base"

4−modules = Effects, Effect.Default,

5−

4+modules = Effects,

65 Effect.Exception, Effect.File, Effect.State,

76 Effect.Random, Effect.StdIO, Effect.Select,

8− Effect.Memory, Effect.System

7+ Effect.Memory, Effect.Monad

98

libs/prelude/Builtins.idr+59−28

@@ -3,44 +3,69 @@

33%access public

44%default total

55

6−data Exists : (a : Type) -> (P : a -> Type) -> Type where

7− Ex_intro : {P : a -> Type} -> (x : a) -> P x -> Exists 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

6+||| Dependent pairs, in their internal representation

7+||| @ a the type of the witness

8+||| @ P the type of the proof

9+data Sigma : (a : Type) -> (P : a -> Type) -> Type where

10+ Sg_intro : .{P : a -> Type} -> (x : a) -> (pf : P x) -> Sigma a P

1411

12+||| The eliminator for the empty type.

1513FalseElim : _|_ -> a

1614

17−-- For 'symbol syntax. 'foo becomes Symbol_ "foo"

15+||| For 'symbol syntax. 'foo becomes Symbol_ "foo"

1816data Symbol_ : String -> Type where

1917

2018-- ------------------------------------------------------ [ For rewrite tactic ]

19+||| Perform substitution in a term according to some equality.

20+|||

21+||| This is used by the `rewrite` tactic and term.

2122replace : {a:_} -> {x:_} -> {y:_} -> {P : a -> Type} -> x = y -> P x -> P y

2223replace refl prf = prf

2324

25+||| Symmetry of propositional equality

2426sym : {l:a} -> {r:a} -> l = r -> r = l

2527sym refl = refl

2628

27−trans : {a:x} -> {b:x} -> {c:x} -> a = b -> b = c -> a = c

29+||| Transitivity of propositional equality

30+trans : {a:x} -> {b:y} -> {c:z} -> a = b -> b = c -> a = c

2831trans refl refl = refl

2932

30−lazy : a -> a

31−lazy x = x -- compiled specially

32−

33−force : a -> a

34−force x = x -- compiled specially

33+||| There are two types of laziness: that arising from lazy functions, and that

34+||| arising from codata. They differ in their totality condition.

35+data LazyType = LazyCodata | LazyEval

36+

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

3555

36−data Lazy : Type -> Type where

37− Delay : (val : a) -> Lazy a

56+||| Lazily evaluated values. This has special evaluation semantics.

57+Lazy : Type -> Type

58+Lazy t = Lazy' LazyEval t

3859

39−Force : Lazy a -> a

40−Force (Delay x) = x

60+||| Recursive parameters to codata. Inserted automatically by the elaborator

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

4165

42−par : Lazy a -> a

43−par (Delay x) = x -- compiled specially

66+par : Lazy a -> a -- Doesn't actually do anything yet. Maybe a 'Par a' type

67+ -- is better in any case?

68+par (Delay x) = x

4469

4570malloc : Int -> a -> a

4671malloc size x = x -- compiled specially

@@ -48,21 +73,27 @@ malloc size x = x -- compiled specially

4873trace_malloc : a -> a

4974trace_malloc x = x -- compiled specially

5075

51−-- Assert to the totality checker than y is always structureally smaller than

52−-- x (which is typically a pattern argument)

53−assert_smaller : a -> a -> a

76+||| Assert to the totality checker than y is always structurally smaller than

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)

80+assert_smaller : (x : a) -> (y : b) -> b

5481assert_smaller x y = y

5582

56−-- Assert to the totality checker than the given expression will always

57−-- terminate.

83+||| Assert to the totality checker than the given expression will always

84+||| terminate.

5885assert_total : a -> a

5986assert_total x = x

6087

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!

6190abstract %assert_total -- need to pretend

62−believe_me : a -> b -- compiled specially as id, use with care!

91+believe_me : a -> b

6392believe_me x = prim__believe_me _ _ x

6493

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

6697really_believe_me : a -> b

6798really_believe_me x = prim__believe_me _ _ x

6899

libs/prelude/Decidable/Equality.idr+36−19

@@ -12,6 +12,7 @@ import Prelude.Maybe

1212-- Utility lemmas

1313--------------------------------------------------------------------------------

1414

15+||| The negation of equality is symmetric (follows from symmetry of equality)

1516total negEqSym : {a : t} -> {b : t} -> (a = b -> _|_) -> (b = a -> _|_)

1617negEqSym p h = p (sym h)

1718

@@ -20,7 +21,9 @@ negEqSym p h = p (sym h)

2021-- Decidable equality

2122--------------------------------------------------------------------------------

2223

24+||| Decision procedures for propositional equality

2325class DecEq t where

26+ ||| Decide whether two elements of `t` are propositionally equal

2427 total decEq : (x1 : t) -> (x2 : t) -> Dec (x1 = x2)

2528

2629--------------------------------------------------------------------------------

@@ -33,7 +36,6 @@ instance DecEq () where

3336--------------------------------------------------------------------------------

3437-- Booleans

3538--------------------------------------------------------------------------------

36−

3739total trueNotFalse : True = False -> _|_

3840trueNotFalse refl impossible

3941

@@ -122,13 +124,13 @@ lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} ->

122124lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl

123125

124126instance (DecEq a, DecEq b) => DecEq (a, b) where

125− decEq (a, b) (a', b') with (decEq a a')

126− decEq (a, b) (a, b') | (Yes refl) with (decEq b b')

127− decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl

128− decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq)

129− decEq (a, b) (a', b') | (No p) with (decEq b b')

130− decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq)

131− decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq)

127+ decEq (a, b) (a', b') with (decEq a a')

128+ decEq (a, b) (a, b') | (Yes refl) with (decEq b b')

129+ decEq (a, b) (a, b) | (Yes refl) | (Yes refl) = Yes refl

130+ decEq (a, b) (a, b') | (Yes refl) | (No p) = No (\eq => lemma_snd_neq refl p eq)

131+ decEq (a, b) (a', b') | (No p) with (decEq b b')

132+ decEq (a, b) (a', b) | (No p) | (Yes refl) = No (\eq => lemma_fst_neq_snd_eq p refl eq)

133+ decEq (a, b) (a', b') | (No p) | (No p') = No (\eq => lemma_both_neq p p' eq)

132134

133135

134136--------------------------------------------------------------------------------

@@ -172,13 +174,23 @@ total

172174vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys

173175vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl

174176

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+

175187instance DecEq a => DecEq (Vect n a) where

176188 decEq [] [] = Yes refl

177189 decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)

178190 decEq (x :: xs) (x :: xs) | (Yes refl, Yes refl) = Yes refl

179191 decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))

180192 decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))

181−

193+-}

182194

183195-- For the primitives, we have to cheat because we don't have access to their

184196-- internal implementations.

@@ -188,39 +200,44 @@ instance DecEq a => DecEq (Vect n a) where

188200--------------------------------------------------------------------------------

189201

190202instance DecEq Int where

191− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

192− else No (really_believe_me _|_)

203+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

204+ where postulate primitiveEq : x = y

205+ postulate primitiveNotEq : x = y -> _|_

193206

194207--------------------------------------------------------------------------------

195208-- Char

196209--------------------------------------------------------------------------------

197210

198211instance DecEq Char where

199− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

200− else No (really_believe_me _|_)

212+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

213+ where postulate primitiveEq : x = y

214+ postulate primitiveNotEq : x = y -> _|_

201215

202216--------------------------------------------------------------------------------

203217-- Integer

204218--------------------------------------------------------------------------------

205219

206220instance DecEq Integer where

207− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

208− else No (really_believe_me _|_)

221+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

222+ where postulate primitiveEq : x = y

223+ postulate primitiveNotEq : x = y -> _|_

209224

210225--------------------------------------------------------------------------------

211226-- Float

212227--------------------------------------------------------------------------------

213228

214229instance DecEq Float where

215− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

216− else No (really_believe_me _|_)

230+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

231+ where postulate primitiveEq : x = y

232+ postulate primitiveNotEq : x = y -> _|_

217233

218234--------------------------------------------------------------------------------

219235-- String

220236--------------------------------------------------------------------------------

221237

222238instance DecEq String where

223− decEq x y = if x == y then Yes (really_believe_me {a = x=x} {b = x=y} refl)

224− else No (really_believe_me _|_)

239+ decEq x y = if x == y then Yes primitiveEq else No primitiveNotEq

240+ where postulate primitiveEq : x = y

241+ postulate primitiveNotEq : x = y -> _|_

225242

226243

libs/prelude/IO.idr+13−7

@@ -4,8 +4,10 @@ import Prelude.List

44

55%access public

66

7+||| Idris's primitive IO, for building abstractions on top of

78abstract data PrimIO a = prim__IO a

89

10+||| A token representing the world, for use in `IO`

911abstract data World = TheWorld

1012

1113abstract WorldRes : Type -> Type

@@ -26,7 +28,10 @@ abstract

2628prim_io_return : a -> PrimIO a

2729prim_io_return x = prim__IO x

2830

31+||| Descriptions of the various sorts of Ints that Idris supports

2932data IntTy = ITChar | ITNative | IT8 | IT16 | IT32 | IT64 | IT8x16 | IT16x8 | IT32x4 | IT64x2

33+

34+||| Types available for foreign function calls

3035data FTy = FIntT IntTy

3136 | FFunction FTy FTy

3237 | FFloat

@@ -75,6 +80,7 @@ FBits32x4 = FIntT IT32x4

7580FBits64x2 : FTy

7681FBits64x2 = FIntT IT64x2

7782

83+||| Interpret an FFI type as the type of the Idris function that it will become

7884interpFTy : FTy -> Type

7985interpFTy (FIntT ITNative) = Int

8086interpFTy (FIntT ITChar) = Char

@@ -95,7 +101,10 @@ interpFTy FUnit = ()

95101

96102interpFTy (FFunction a b) = interpFTy a -> interpFTy b

97103

98−ForeignTy : (xs:List FTy) -> (t:FTy) -> Type

104+||| Type signatures for foreign functions

105+||| @ xs the argument types

106+||| @ t the return type

107+ForeignTy : (xs : List FTy) -> (t : FTy) -> Type

99108ForeignTy Nil rt = World -> PrimIO (interpFTy rt)

100109ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt

101110

@@ -123,16 +132,13 @@ io_return : a -> IO a

123132io_return x = MkIO (\w => prim_io_return x)

124133

125134liftPrimIO : (World -> PrimIO a) -> IO a

126−liftPrimIO f = MkIO (\w => prim_io_bind (f w)

127− (\x => prim_io_return x))

135+liftPrimIO = MkIO

128136

129137run__IO : IO () -> PrimIO ()

130−run__IO (MkIO f) = prim_io_bind (f TheWorld)

131− (\ b => prim_io_return b)

138+run__IO (MkIO f) = f TheWorld

132139

133140run__provider : IO a -> PrimIO a

134−run__provider (MkIO f) = prim_io_bind (f TheWorld)

135− (\ b => prim_io_return b)

141+run__provider (MkIO f) = f TheWorld

136142

137143-- io_bind v (\v' => io_return v')

138144

libs/prelude/Prelude.idr+64−16

@@ -21,6 +21,7 @@ import Prelude.Traversable

2121import Prelude.Bits

2222import Prelude.Stream

2323import Prelude.Uninhabited

24+import Prelude.Pairs

2425

2526import Decidable.Equality

2627

@@ -347,27 +348,38 @@ natRange n = List.reverse (go n)

347348 where go Z = []

348349 go (S n) = n :: go n

349350

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+

350360class Enum a where

351361 total pred : a -> a

352362 total succ : a -> a

363+ succ e = fromNat (S (toNat e))

353364 total toNat : a -> Nat

354365 total fromNat : Nat -> a

355366 total enumFrom : a -> Stream a

356367 enumFrom n = n :: enumFrom (succ n)

357368 total enumFromThen : a -> a -> Stream a

369+ enumFromThen x y = map fromNat (natEnumFromThen (toNat x) (toNat y))

358370 total enumFromTo : a -> a -> List a

371+ enumFromTo x y = map fromNat (natEnumFromTo (toNat x) (toNat y))

359372 total enumFromThenTo : a -> a -> a -> List a

360−

373+ enumFromThenTo x1 x2 y = map fromNat (natEnumFromThenTo (toNat x1) (toNat x2) (toNat y))

361374

362375instance Enum Nat where

363− pred = Nat.pred

364− succ = S

365− toNat = id

366− fromNat = id

367− enumFromThen n inc = n :: enumFromThen (fromNat (plus (toNat inc) (toNat n))) inc

368− enumFromThenTo _ Z _ = []

369− enumFromThenTo n inc m = map (plus n . (* inc)) (natRange (S ((m - n) `div` inc)))

370− enumFromTo n m = map (plus n) (natRange ((S m) - n))

376+ pred n = Nat.pred n

377+ succ n = S n

378+ toNat x = id x

379+ fromNat x = id x

380+ enumFromThen x y = natEnumFromThen x y

381+ enumFromThenTo x y z = natEnumFromThenTo x y z

382+ enumFromTo x y = natEnumFromTo x y

371383

372384instance Enum Integer where

373385 pred n = n - 1

@@ -407,14 +419,25 @@ instance Enum Int where

407419 go [] = []

408420 go (x :: xs) = n + (cast x * inc) :: go xs

409421

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+

410433syntax "[" [start] ".." [end] "]"

411434 = enumFromTo start end

412435syntax "[" [start] "," [next] ".." [end] "]"

413436 = enumFromThenTo start (next - start) end

414437

415−syntax "[" [start] "..]"

438+syntax "[" [start] ".." "]"

416439 = enumFrom start

417−syntax "[" [start] "," [next] "..]"

440+syntax "[" [start] "," [next] ".." "]"

418441 = enumFromThen start (next - start)

419442

420443---- More utilities

@@ -439,26 +462,32 @@ uniformB64x2 x = prim__mkB64x2 x x

439462

440463---- some basic io

441464

465+||| Output a string to stdout without a trailing newline

442466partial

443467putStr : String -> IO ()

444468putStr x = mkForeign (FFun "putStr" [FString] FUnit) x

445469

470+||| Output a string to stdout with a trailing newline

446471partial

447472putStrLn : String -> IO ()

448473putStrLn x = putStr (x ++ "\n")

449474

475+||| Output something showable to stdout, with a trailing newline

450476partial

451477print : Show a => a -> IO ()

452478print x = putStrLn (show x)

453479

480+||| Read one line of input from stdin

454481partial

455482getLine : IO String

456483getLine = prim_fread prim__stdin

457484

485+||| Write a single character to stdout

458486partial

459487putChar : Char -> IO ()

460488putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)

461489

490+||| Read a single character from stdin

462491partial

463492getChar : IO Char

464493getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

@@ -468,21 +497,38 @@ getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

468497abstract

469498data File = FHandle Ptr

470499

500+||| Standard input

471501partial stdin : File

472502stdin = FHandle prim__stdin

473503

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

474513do_fopen : String -> String -> IO Ptr

475514do_fopen f m

476515 = mkForeign (FFun "fileOpen" [FString, FString] FPtr) f m

477516

478−fopen : String -> String -> IO File

517+||| Open a file

518+||| @ f the filename

519+||| @ m the mode as a String (`"r"`, `"w"`, or `"r+"`)

520+fopen : (f : String) -> (m : String) -> IO File

479521fopen f m = do h <- do_fopen f m

480522 return (FHandle h)

481523

524+||| Modes for opening files

482525data Mode = Read | Write | ReadWrite

483526

527+||| Open a file

528+||| @ f the filename

529+||| @ m the mode

484530partial

485−openFile : String -> Mode -> IO File

531+openFile : (f : String) -> (m : Mode) -> IO File

486532openFile f m = fopen f (modeStr m) where

487533 modeStr Read = "r"

488534 modeStr Write = "w"

@@ -504,9 +550,9 @@ fgetc : File -> IO Char

504550fgetc (FHandle h) = return (cast !(mkForeign (FFun "fgetc" [FPtr] FInt) h))

505551

506552fgetc' : File -> IO (Maybe Char)

507−fgetc' (FHandle h)

553+fgetc' (FHandle h)

508554 = do x <- mkForeign (FFun "fgetc" [FPtr] FInt) h

509− if (x < 0) then return Nothing

555+ if (x < 0) then return Nothing

510556 else return (Just (cast x))

511557

512558fflush : File -> IO ()

@@ -567,15 +613,18 @@ nullPtr : Ptr -> IO Bool

567613nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

568614 return (ok /= 0)

569615

616+||| Check if a supposed string was actually a null pointer

570617partial

571618nullStr : String -> IO Bool

572619nullStr p = do ok <- mkForeign (FFun "isNull" [FString] FInt) p

573620 return (ok /= 0)

574621

622+||| Pointer equality

575623eqPtr : Ptr -> Ptr -> IO Bool

576624eqPtr x y = do eq <- mkForeign (FFun "idris_eqPtr" [FPtr, FPtr] FInt) x y

577625 return (eq /= 0)

578626

627+||| Check whether a file handle is actually a null pointer

579628partial

580629validFile : File -> IO Bool

581630validFile (FHandle h) = do x <- nullPtr h

@@ -602,4 +651,3 @@ readFile fn = do h <- openFile fn Read

602651 if not x then do l <- fread h

603652 readFile' h (contents ++ l)

604653 else return contents

605−

libs/prelude/Prelude/Algebra.idr+191−176

@@ -13,238 +13,253 @@ infixl 6 <*>

1313-- A modest class hierarchy

1414--------------------------------------------------------------------------------

1515

16−-- Sets equipped with a single binary operation that is associative. Must

17−-- satisfy the following laws:

18−-- Associativity of <+>:

19−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

16+||| Sets equipped with a single binary operation that is associative. Must

17+||| satisfy the following laws:

18+|||

19+||| + Associativity of `<+>`:

20+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

2021class Semigroup a where

2122 (<+>) : a -> a -> a

2223

2324class 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

2526

26−-- 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−-- laws:

29−-- Associativity of <+>:

30−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

31−-- Neutral for <+>:

32−-- forall a, a <+> neutral == a

33−-- forall a, neutral <+> a == a

27+||| Sets equipped with a single binary operation that is associative, along with

28+||| a neutral element for that binary operation. Must satisfy the following

29+||| laws:

30+|||

31+||| + Associativity of `<+>`:

32+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

33+||| + Neutral for `<+>`:

34+||| forall a, a <+> neutral == a

35+||| forall a, neutral <+> a == a

3436class Semigroup a => Monoid a where

3537 neutral : a

3638

3739class (VerifiedSemigroup a, Monoid a) => VerifiedMonoid a where

38− monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l

39− monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r

40+ total monoidNeutralIsNeutralL : (l : a) -> l <+> neutral = l

41+ total monoidNeutralIsNeutralR : (r : a) -> neutral <+> r = r

4042

41−-- 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.

43−-- Must satisfy the following laws:

44−-- Associativity of <+>:

45−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

46−-- Neutral for <+>:

47−-- forall a, a <+> neutral == a

48−-- forall a, neutral <+> a == a

49−-- Inverse for <+>:

50−-- forall a, a <+> inverse a == neutral

51−-- forall a, inverse a <+> a == neutral

43+||| Sets equipped with a single binary operation that is associative, along with

44+||| a neutral element for that binary operation and inverses for all elements.

45+||| Must satisfy the following laws:

46+||| + Associativity of `<+>`:

47+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

48+||| + Neutral for `<+>`:

49+||| forall a, a <+> neutral == a

50+||| forall a, neutral <+> a == a

51+||| + Inverse for `<+>`:

52+||| forall a, a <+> inverse a == neutral

53+||| forall a, inverse a <+> a == neutral

5254class Monoid a => Group a where

5355 inverse : a -> a

5456

5557class (VerifiedMonoid a, Group a) => VerifiedGroup a where

56− groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral

57− groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral

58+ total groupInverseIsInverseL : (l : a) -> l <+> inverse l = neutral

59+ total groupInverseIsInverseR : (r : a) -> inverse r <+> r = neutral

5860

5961(<->) : Group a => a -> a -> a

6062(<->) left right = left <+> (inverse right)

6163

62−-- Sets equipped with a single binary operation that is associative and

63−-- commutative, along with a neutral element for that binary operation and

64−-- inverses for all elements. Must satisfy the following laws:

65−-- Associativity of <+>:

66−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

67−-- Commutativity of <+>:

68−-- forall a b, a <+> b == b <+> a

69−-- Neutral for <+>:

70−-- forall a, a <+> neutral == a

71−-- forall a, neutral <+> a == a

72−-- Inverse for <+>:

73−-- forall a, a <+> inverse a == neutral

74−-- forall a, inverse a <+> a == neutral

64+||| Sets equipped with a single binary operation that is associative and

65+||| commutative, along with a neutral element for that binary operation and

66+||| inverses for all elements. Must satisfy the following laws:

67+|||

68+||| + Associativity of `<+>`:

69+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

70+||| + Commutativity of `<+>`:

71+||| forall a b, a <+> b == b <+> a

72+||| + Neutral for `<+>`:

73+||| forall a, a <+> neutral == a

74+||| forall a, neutral <+> a == a

75+||| + Inverse for `<+>`:

76+||| forall a, a <+> inverse a == neutral

77+||| forall a, inverse a <+> a == neutral

7578class Group a => AbelianGroup a where { }

7679

7780class (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

7982

80−-- Sets equipped with two binary operations, one associative and commutative

81−-- supplied with a neutral element, and the other associative, with

82−-- distributivity laws relating the two operations. Must satisfy the following

83−-- laws:

84−-- Associativity of <+>:

85−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

86−-- Commutativity of <+>:

87−-- forall a b, a <+> b == b <+> a

88−-- Neutral for <+>:

89−-- forall a, a <+> neutral == a

90−-- forall a, neutral <+> a == a

91−-- Inverse for <+>:

92−-- forall a, a <+> inverse a == neutral

93−-- forall a, inverse a <+> a == neutral

94−-- Associativity of <*>:

95−-- forall a b c, a <*> (b <*> c) == (a <*> b) <*> c

96−-- Distributivity of <*> and <->:

97−-- forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)

98−-- forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)

83+||| Sets equipped with two binary operations, one associative and commutative

84+||| supplied with a neutral element, and the other associative, with

85+||| distributivity laws relating the two operations. Must satisfy the following

86+||| laws:

87+|||

88+||| + Associativity of `<+>`:

89+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

90+||| + Commutativity of `<+>`:

91+||| forall a b, a <+> b == b <+> a

92+||| + Neutral for `<+>`:

93+||| forall a, a <+> neutral == a

94+||| forall a, neutral <+> a == a

95+||| + Inverse for `<+>`:

96+||| forall a, a <+> inverse a == neutral

97+||| forall a, inverse a <+> a == neutral

98+||| + Associativity of `<*>`:

99+||| forall a b c, a <*> (b <*> c) == (a <*> b) <*> c

100+||| + Distributivity of `<*>` and `<->`:

101+||| forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)

102+||| forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)

99103class AbelianGroup a => Ring a where

100104 (<*>) : a -> a -> a

101105

102106class (VerifiedAbelianGroup a, Ring a) => VerifiedRing a where

103− ringOpIsAssociative : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r

104− 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)

107+ total ringOpIsAssociative : (l, c, r : a) -> l <*> (c <*> r) = (l <*> c) <*> r

108+ total ringOpIsDistributiveL : (l, c, r : a) -> l <*> (c <+> r) = (l <*> c) <+> (l <*> r)

109+ total ringOpIsDistributiveR : (l, c, r : a) -> (l <+> c) <*> r = (l <*> r) <+> (c <*> r)

106110

107−-- Sets equipped with two binary operations, one associative and commutative

108−-- supplied with a neutral element, and the other associative supplied with a

109−-- neutral element, with distributivity laws relating the two operations. Must

110−-- satisfy the following laws:

111−-- Associativity of <+>:

112−-- forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

113−-- Commutativity of <+>:

114−-- forall a b, a <+> b == b <+> a

115−-- Neutral for <+>:

116−-- forall a, a <+> neutral == a

117−-- forall a, neutral <+> a == a

118−-- Inverse for <+>:

119−-- forall a, a <+> inverse a == neutral

120−-- forall a, inverse a <+> a == neutral

121−-- Associativity of <*>:

122−-- forall a b c, a <*> (b <*> c) == (a <*> b) <*> c

123−-- Neutral for <*>:

124−-- forall a, a <*> unity == a

125−-- forall a, unity <*> a == a

126−-- Distributivity of <*> and <->:

127−-- forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)

128−-- forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)

111+||| Sets equipped with two binary operations, one associative and commutative

112+||| supplied with a neutral element, and the other associative supplied with a

113+||| neutral element, with distributivity laws relating the two operations. Must

114+||| satisfy the following laws:

115+|||

116+||| + Associativity of `<+>`:

117+||| forall a b c, a <+> (b <+> c) == (a <+> b) <+> c

118+||| + Commutativity of `<+>`:

119+||| forall a b, a <+> b == b <+> a

120+||| + Neutral for `<+>`:

121+||| forall a, a <+> neutral == a

122+||| forall a, neutral <+> a == a

123+||| + Inverse for `<+>`:

124+||| forall a, a <+> inverse a == neutral

125+||| forall a, inverse a <+> a == neutral

126+||| + Associativity of `<*>a:

127+||| forall a b c, a <*> (b <*> c) == (a <*> b) <*> c

128+||| + Neutral for `<*>`:

129+||| forall a, a <*> unity == a

130+||| forall a, unity <*> a == a

131+||| + Distributivity of `<*>` and `<->`:

132+||| forall a b c, a <*> (b <+> c) == (a <*> b) <+> (a <*> c)

133+||| forall a b c, (a <+> b) <*> c == (a <*> c) <+> (b <*> c)

129134class Ring a => RingWithUnity a where

130135 unity : a

131136

132137class (VerifiedRing a, RingWithUnity a) => VerifiedRingWithUnity a where

133− ringWithUnityIsUnityL : (l : a) -> l <*> unity = l

134− ringWithUnityIsUnityR : (r : a) -> unity <*> r = r

138+ total ringWithUnityIsUnityL : (l : a) -> l <*> unity = l

139+ total ringWithUnityIsUnityR : (r : a) -> unity <*> r = r

135140

136−-- Sets equipped with a binary operation that is commutative, associative and

137−-- idempotent. Must satisfy the following laws:

138−-- Associativity of join:

139−-- forall a b c, join a (join b c) == join (join a b) c

140−-- Commutativity of join:

141−-- forall a b, join a b == join b a

142−-- Idempotency of join:

143−-- forall a, join a a == a

144−-- Join semilattices capture the notion of sets with a "least upper bound".

141+||| Sets equipped with a binary operation that is commutative, associative and

142+||| idempotent. Must satisfy the following laws:

143+|||

144+||| + Associativity of join:

145+||| forall a b c, join a (join b c) == join (join a b) c

146+||| + Commutativity of join:

147+||| forall a b, join a b == join b a

148+||| + Idempotency of join:

149+||| forall a, join a a == a

150+|||

151+||| Join semilattices capture the notion of sets with a "least upper bound".

145152class JoinSemilattice a where

146153 join : a -> a -> a

147154

148155class JoinSemilattice a => VerifiedJoinSemilattice a where

149− 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

151− joinSemilatticeJoinIsIdempotent : (e : a) -> join e e = e

156+ total joinSemilatticeJoinIsAssociative : (l, c, r : a) -> join l (join c r) = join (join l c) r

157+ total joinSemilatticeJoinIsCommutative : (l, r : a) -> join l r = join r l

158+ total joinSemilatticeJoinIsIdempotent : (e : a) -> join e e = e

152159

153−-- Sets equipped with a binary operation that is commutative, associative and

154−-- idempotent. Must satisfy the following laws:

155−-- Associativity of meet:

156−-- forall a b c, meet a (meet b c) == meet (meet a b) c

157−-- Commutativity of meet:

158−-- forall a b, meet a b == meet b a

159−-- Idempotency of meet:

160−-- forall a, meet a a == a

161−-- Meet semilattices capture the notion of sets with a "greatest lower bound".

160+||| Sets equipped with a binary operation that is commutative, associative and

161+||| idempotent. Must satisfy the following laws:

162+|||

163+||| + Associativity of meet:

164+||| forall a b c, meet a (meet b c) == meet (meet a b) c

165+||| + Commutativity of meet:

166+||| forall a b, meet a b == meet b a

167+||| + Idempotency of meet:

168+||| forall a, meet a a == a

169+|||

170+||| Meet semilattices capture the notion of sets with a "greatest lower bound".

162171class MeetSemilattice a where

163172 meet : a -> a -> a

164173

165174class MeetSemilattice a => VerifiedMeetSemilattice a where

166− 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

168− meetSemilatticeMeetIsIdempotent : (e : a) -> meet e e = e

175+ total meetSemilatticeMeetIsAssociative : (l, c, r : a) -> meet l (meet c r) = meet (meet l c) r

176+ total meetSemilatticeMeetIsCommutative : (l, r : a) -> meet l r = meet r l

177+ total meetSemilatticeMeetIsIdempotent : (e : a) -> meet e e = e

169178

170−-- Sets equipped with a binary operation that is commutative, associative and

171−-- idempotent and supplied with a neutral element. Must satisfy the following

172−-- laws:

173−-- Associativity of join:

174−-- forall a b c, join a (join b c) == join (join a b) c

175−-- Commutativity of join:

176−-- forall a b, join a b == join b a

177−-- Idempotency of join:

178−-- forall a, join a a == a

179−-- Bottom:

180−-- forall a, join a bottom == bottom

181−-- Join semilattices capture the notion of sets with a "least upper bound"

182−-- equipped with a "bottom" element.

179+||| Sets equipped with a binary operation that is commutative, associative and

180+||| idempotent and supplied with a neutral element. Must satisfy the following

181+||| laws:

182+|||

183+||| + Associativity of join:

184+||| forall a b c, join a (join b c) == join (join a b) c

185+||| + Commutativity of join:

186+||| forall a b, join a b == join b a

187+||| + Idempotency of join:

188+||| forall a, join a a == a

189+||| + Bottom:

190+||| forall a, join a bottom == bottom

191+|||

192+||| Join semilattices capture the notion of sets with a "least upper bound"

193+||| equipped with a "bottom" element.

183194class JoinSemilattice a => BoundedJoinSemilattice a where

184195 bottom : a

185196

186197class (VerifiedJoinSemilattice a, BoundedJoinSemilattice a) => VerifiedBoundedJoinSemilattice a where

187− boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom

198+ total boundedJoinSemilatticeBottomIsBottom : (e : a) -> join e bottom = bottom

188199

189−-- Sets equipped with a binary operation that is commutative, associative and

190−-- idempotent and supplied with a neutral element. Must satisfy the following

191−-- laws:

192−-- Associativity of meet:

193−-- forall a b c, meet a (meet b c) == meet (meet a b) c

194−-- Commutativity of meet:

195−-- forall a b, meet a b == meet b a

196−-- Idempotency of meet:

197−-- forall a, meet a a == a

198−-- Top:

199−-- forall a, meet a top == top

200−-- Meet semilattices capture the notion of sets with a "greatest lower bound"

201−-- equipped with a "top" element.

200+||| Sets equipped with a binary operation that is commutative, associative and

201+||| idempotent and supplied with a neutral element. Must satisfy the following

202+||| laws:

203+|||

204+||| + Associativity of meet:

205+||| forall a b c, meet a (meet b c) == meet (meet a b) c

206+||| + Commutativity of meet:

207+||| forall a b, meet a b == meet b a

208+||| + Idempotency of meet:

209+||| forall a, meet a a == a

210+||| + Top:

211+||| forall a, meet a top == top

212+|||

213+||| Meet semilattices capture the notion of sets with a "greatest lower bound"

214+||| equipped with a "top" element.

202215class MeetSemilattice a => BoundedMeetSemilattice a where

203216 top : a

204217

205218class (VerifiedMeetSemilattice a, BoundedMeetSemilattice a) => VerifiedBoundedMeetSemilattice a where

206− boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top

219+ total boundedMeetSemilatticeTopIsTop : (e : a) -> meet e top = top

207220

208−-- Sets equipped with two binary operations that are both commutative,

209−-- associative and idempotent, along with absorbtion laws for relating the two

210−-- binary operations. Must satisfy the following:

211−-- Associativity of meet and join:

212−-- 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

214−-- Commutativity of meet and join:

215−-- forall a b, meet a b == meet b a

216−-- forall a b, join a b == join b a

217−-- Idempotency of meet and join:

218−-- forall a, meet a a == a

219−-- forall a, join a a == a

220−-- Absorbtion laws for meet and join:

221−-- forall a b, meet a (join a b) == a

222−-- forall a b, join a (meet a b) == a

221+||| Sets equipped with two binary operations that are both commutative,

222+||| associative and idempotent, along with absorbtion laws for relating the two

223+||| binary operations. Must satisfy the following:

224+|||

225+||| + Associativity of meet and join:

226+||| forall a b c, meet a (meet b c) == meet (meet a b) c

227+||| forall a b c, join a (join b c) == join (join a b) c

228+||| + Commutativity of meet and join:

229+||| forall a b, meet a b == meet b a

230+||| forall a b, join a b == join b a

231+||| + Idempotency of meet and join:

232+||| forall a, meet a a == a

233+||| forall a, join a a == a

234+||| + Absorbtion laws for meet and join:

235+||| forall a b, meet a (join a b) == a

236+||| forall a b, join a (meet a b) == a

223237class (JoinSemilattice a, MeetSemilattice a) => Lattice a where { }

224238

225239class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice a where

226− latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l

227− latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l

240+ total latticeMeetAbsorbsJoin : (l, r : a) -> meet l (join l r) = l

241+ total latticeJoinAbsorbsMeet : (l, r : a) -> join l (meet l r) = l

228242

229−-- Sets equipped with two binary operations that are both commutative,

230−-- associative and idempotent and supplied with neutral elements, along with

231−-- absorbtion laws for relating the two binary operations. Must satisfy the

232−-- following:

233−-- Associativity of meet and join:

234−-- 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

236−-- Commutativity of meet and join:

237−-- forall a b, meet a b == meet b a

238−-- forall a b, join a b == join b a

239−-- Idempotency of meet and join:

240−-- forall a, meet a a == a

241−-- forall a, join a a == a

242−-- Absorbtion laws for meet and join:

243−-- forall a b, meet a (join a b) == a

244−-- forall a b, join a (meet a b) == a

245−-- Neutral for meet and join:

246−-- forall a, meet a top == top

247−-- forall a, join a bottom == bottom

243+||| Sets equipped with two binary operations that are both commutative,

244+||| associative and idempotent and supplied with neutral elements, along with

245+||| absorbtion laws for relating the two binary operations. Must satisfy the

246+||| following:

247+|||

248+||| + Associativity of meet and join:

249+||| forall a b c, meet a (meet b c) == meet (meet a b) c

250+||| forall a b c, join a (join b c) == join (join a b) c

251+||| + Commutativity of meet and join:

252+||| forall a b, meet a b == meet b a

253+||| forall a b, join a b == join b a

254+||| + Idempotency of meet and join:

255+||| forall a, meet a a == a

256+||| forall a, join a a == a

257+||| + Absorbtion laws for meet and join:

258+||| forall a b, meet a (join a b) == a

259+||| forall a b, join a (meet a b) == a

260+||| + Neutral for meet and join:

261+||| forall a, meet a top == top

262+||| forall a, join a bottom == bottom

248263class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }

249264

250265class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }

libs/prelude/Prelude/Applicative.idr+10−2

@@ -1,6 +1,8 @@

11module Prelude.Applicative

22

33import Builtins

4+import Prelude.Basics

5+import Prelude.Classes

46import Prelude.Functor

57

68---- Applicative functors/Idioms

@@ -19,12 +21,15 @@ infixl 2 $>

1921($>) : Applicative f => f a -> f b -> f b

2022a $> b = map (const id) a <$> b

2123

24+||| Lift a function to an applicative

2225liftA : Applicative f => (a -> b) -> f a -> f b

2326liftA f a = pure f <$> a

2427

28+||| Lift a two-argument function to an applicative

2529liftA2 : Applicative f => (a -> b -> c) -> f a -> f b -> f c

2630liftA2 f a b = (map f a) <$> b

2731

32+||| Lift a three-argument function to an applicative

2833liftA3 : Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d

2934liftA3 f a b c = (map f a) <$> b <$> c

3035

@@ -33,8 +38,11 @@ class Applicative f => Alternative (f : Type -> Type) where

3338 empty : f a

3439 (<|>) : f a -> f a -> f a

3540

41+||| `guard a` is `pure ()` if `a` is `True` and `empty` if `a` is `False`

3642guard : Alternative f => Bool -> f ()

3743guard a = if a then pure () else empty

3844

39−when : Applicative f => Bool -> f () -> f ()

40−when a f = if a then f else pure ()

45+||| Conditionally execute an applicative expression

46+when : Applicative f => Bool -> Lazy (f ()) -> f ()

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

33Not : Type -> Type

44Not a = a -> _|_

55

6−-- | Identity function.

6+||| Identity function.

77id : a -> a

88id x = x

99

10−-- | Manually assign a type to an expression.

11−the : (a : Type) -> a -> a

10+||| Manually assign a type to an expression.

11+||| @ a the type to assign

12+||| @ x the element to get the type

13+the : (a : Type) -> (x : a) -> a

1214the _ = id

1315

14−-- | Constant function.

16+||| Constant function. Ignores its second argument.

1517const : a -> b -> a

1618const x = \v => x

1719

18−-- | Return the first element of a pair.

20+||| Return the first element of a pair.

1921fst : (s, t) -> s

2022fst (x, y) = x

2123

22−-- | Return the second element of a pair.

24+||| Return the second element of a pair.

2325snd : (a, b) -> b

2426snd (x, y) = y

2527

2628infixl 9 .

2729

28−-- | Function composition

30+||| Function composition

2931(.) : (b -> c) -> (a -> b) -> a -> c

3032(.) f g x = f (g x)

3133

32−-- | Takes in the first two arguments in reverse order.

33−flip : (a -> b -> c) -> b -> a -> c

34+||| Takes in the first two arguments in reverse order.

35+||| @ f the function to flip

36+flip : (f : a -> b -> c) -> b -> a -> c

3437flip f x y = f y x

3538

36−-- | Function application.

39+||| Function application.

3740apply : (a -> b) -> a -> b

3841apply f a = f a

3942

43+||| Equality is a congruence.

4044cong : {f : t -> u} -> (a = b) -> f a = f b

4145cong refl = refl

4246

47+||| Decidability. A decidable property either holds or is a contradiction.

4348data Dec : Type -> Type where

44− Yes : {A : Type} -> A -> Dec A

45− No : {A : Type} -> (A -> _|_) -> Dec A

49+

50+ ||| The case where the property holds

51+ ||| @ prf the proof

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

56+ No : {A : Type} -> (contra : A -> _|_) -> Dec A

4657

libs/prelude/Prelude/Bool.idr+28−10

@@ -1,33 +1,51 @@

11module Prelude.Bool

22

3−-- | Boolean Data Type

3+import Builtins

4+

5+import Prelude.Uninhabited

6+

7+||| Boolean Data Type

48data Bool = False | True

59

6−-- | Boolean elimination

7−boolElim : Bool -> (t : Lazy a) -> (e : Lazy a) -> a

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

14+boolElim : (b : Bool) -> (t : Lazy a) -> (e : Lazy a) -> a

815boolElim True t e = t

916boolElim False t e = e

1017

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.

1227data so : Bool -> Type where oh : so True

1328

14−-- Syntaxtic sugar for boolean elimination.

29+instance Uninhabited (so False) where

30+ uninhabited oh impossible

31+

32+-- Syntactic sugar for boolean elimination.

1533syntax if [test] then [t] else [e] = boolElim test (Delay t) (Delay e)

1634

1735-- Boolean Operator Precedence

1836infixl 4 &&, ||

1937

20−-- | Boolean OR

21−(||) : Bool -> Bool -> Bool

38+||| Boolean OR only evaluates the second argument if the first is `False`.

39+(||) : Bool -> Lazy Bool -> Bool

2240(||) False x = x

2341(||) True _ = True

2442

25−-- | Boolean AND

26−(&&) : Bool -> Bool -> Bool

43+||| Boolean AND only evaluates the second argument if the first is `True`.

44+(&&) : Bool -> Lazy Bool -> Bool

2745(&&) True x = x

2846(&&) False _ = False

2947

30−-- | Boolean NOT

48+||| Boolean NOT

3149not : Bool -> Bool

3250not True = False

3351not False = True

libs/prelude/Prelude/Cast.idr+5−3

@@ -1,7 +1,11 @@

11module Prelude.Cast

22

3+||| Type class for transforming a instance of a data type to another type.

34class Cast from to where

4− cast : from -> to

5+ ||| Perform a cast operation.

6+ |||

7+ ||| @orig The original type.

8+ cast : (orig : from) -> to

59

610-- String casts

711

@@ -45,5 +49,3 @@ instance Cast Integer String where

4549

4650instance Cast Char Int where

4751 cast = prim__charToInt

48−

49−

libs/prelude/Prelude/Chars.idr+19−16

@@ -1,69 +1,72 @@

11module Prelude.Char

22-- Functions operating over Chars

33

4+import Prelude.Bool

5+import Prelude.Classes

6+import Prelude.List

47import Builtins

58

6−-- | Return the ASCII representation of the character.

9+||| Return the ASCII representation of the character.

710chr : Int -> Char

811chr x = prim__intToChar x

912

10−-- | Convert the number to its ASCII equivalent.

13+||| Convert the number to its ASCII equivalent.

1114ord : Char -> Int

1215ord x = prim__charToInt x

1316

14−-- | Returns true if the character is in the range [A-Z].

17+||| Returns true if the character is in the range [A-Z].

1518isUpper : Char -> Bool

1619isUpper x = x >= 'A' && x <= 'Z'

1720

18−-- | Returns true if the character is in the range [a-z]

21+||| Returns true if the character is in the range [a-z]

1922isLower : Char -> Bool

2023isLower x = x >= 'a' && x <= 'z'

2124

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].

2326isAlpha : Char -> Bool

2427isAlpha x = isUpper x || isLower x

2528

26−-- | Returns true if the character is in the range [0-9]

29+||| Returns true if the character is in the range [0-9]

2730isDigit : Char -> Bool

2831isDigit x = (x >= '0' && x <= '9')

2932

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]

3134isAlphaNum : Char -> Bool

3235isAlphaNum x = isDigit x || isAlpha x

3336

34−-- | Returns true if the character is a whitespace character.

37+||| Returns true if the character is a whitespace character.

3538isSpace : Char -> Bool

3639isSpace x = x == ' ' || x == '\t' || x == '\r' ||

3740 x == '\n' || x == '\f' || x == '\v' ||

3841 x == '\xa0'

3942

40−-- | Returns true if the character represents a new line.

43+||| Returns true if the character represents a new line.

4144isNL : Char -> Bool

4245isNL x = x == '\r' || x == '\n'

4346

44−-- | Convert a letter to the corresponding upper-case letter, if any.

45−-- Non-letters are ignored.

47+||| Convert a letter to the corresponding upper-case letter, if any.

48+||| Non-letters are ignored.

4649toUpper : Char -> Char

4750toUpper x = if (isLower x)

4851 then (prim__intToChar (prim__charToInt x - 32))

4952 else x

5053

51−-- | Convert a letter to the corresponding lower-case letter, if any.

52−-- Non-letters are ignored.

54+||| Convert a letter to the corresponding lower-case letter, if any.

55+||| Non-letters are ignored.

5356toLower : Char -> Char

5457toLower x = if (isUpper x)

5558 then (prim__intToChar (prim__charToInt x + 32))

5659 else x

5760

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]

5962isHexDigit : Char -> Bool

6063isHexDigit x = elem (toUpper x) hexChars where

6164 hexChars : List Char

6265 hexChars = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9',

6366 'A', 'B', 'C', 'D', 'E', 'F']

6467

65−-- | Returns true if the character is an octal digit.

68+||| Returns true if the character is an octal digit.

6669isOctDigit : Char -> Bool

6770isOctDigit x = (x >= '0' && x <= '7')

6871

69−-- --------------------------------------------------------------------- [ EOF ]

72+

libs/prelude/Prelude/Classes.idr+16−10

@@ -20,7 +20,7 @@ boolOp : (a -> a -> Int) -> a -> a -> Bool

2020boolOp op x y = intToBool (op x y)

2121

2222-- ---------------------------------------------------------- [ Equality Class ]

23−-- | The Eq class defines inequality and equality.

23+||| The Eq class defines inequality and equality.

2424class Eq a where

2525 (==) : a -> a -> Bool

2626 (/=) : a -> a -> Bool

@@ -65,7 +65,7 @@ instance Eq Ordering where

6565 GT == GT = True

6666 _ == _ = False

6767

68−-- | The Ord class defines comparison operations on ordered data types.

68+||| The Ord class defines comparison operations on ordered data types.

6969class Eq a => Ord a where

7070 compare : a -> a -> Ordering

7171

@@ -131,14 +131,14 @@ instance (Ord a, Ord b) => Ord (a, b) where

131131 else compare xr yr

132132

133133-- --------------------------------------------------------- [ Numerical Class ]

134−-- | The Num class defines basic numerical arithmetic.

134+||| The Num class defines basic numerical arithmetic.

135135class Num a where

136136 (+) : a -> a -> a

137137 (-) : a -> a -> a

138138 (*) : a -> a -> a

139− -- | Absolute value

139+ ||| Absolute value

140140 abs : a -> a

141− -- | Conversion from Integer.

141+ ||| Conversion from Integer.

142142 fromInteger : Integer -> a

143143

144144instance Num Integer where

@@ -244,14 +244,20 @@ instance Ord Bits64 where

244244

245245-- ------------------------------------------------------------- [ Bounded ]

246246

247−class MinBound b where

248− -- | The lower bound for the type

247+class Ord b => MinBound b where

248+ ||| The lower bound for the type

249249 minBound : b

250250

251−class MaxBound b where

252− -- | The upper bound for the type

251+class Ord b => MaxBound b where

252+ ||| The upper bound for the type

253253 maxBound : b

254254

255+instance MinBound Bits8 where

256+ minBound = 0x0

257+

258+instance MaxBound Bits8 where

259+ maxBound = 0xff

260+

255261instance MinBound Bits16 where

256262 minBound = 0x0

257263

@@ -273,7 +279,7 @@ instance MaxBound Bits64 where

273279

274280-- ------------------------------------------------------------- [ Fractionals ]

275281

276−-- | Fractional division of two Floats.

282+||| Fractional division of two Floats.

277283(/) : Float -> Float -> Float

278284(/) = prim__divFloat

279285

libs/prelude/Prelude/Either.idr+26−8

@@ -1,22 +1,27 @@

1−module Prelude.Either

1+ module Prelude.Either

22

33import Builtins

44

55import Prelude.Maybe

66import Prelude.List

77

8−data Either a b

9− = Left a

10− | Right b

8+||| A sum type

9+data Either a b =

10+ ||| One possibility of the sum, conventionally used to represent errors

11+ Left a |

12+ ||| The other possibility, conventionally used to represent success

13+ Right b

1114

1215--------------------------------------------------------------------------------

1316-- Syntactic tests

1417--------------------------------------------------------------------------------

1518

19+||| True if the argument is Left, False otherwise

1620isLeft : Either a b -> Bool

1721isLeft (Left l) = True

1822isLeft (Right r) = False

1923

24+||| True if the argument is Right, False otherwise

2025isRight : Either a b -> Bool

2126isRight (Left l) = False

2227isRight (Right r) = True

@@ -25,14 +30,20 @@ isRight (Right r) = True

2530-- Misc.

2631--------------------------------------------------------------------------------

2732

33+||| Perform a case analysis on a Boolean, providing clients with a `so` proof

2834choose : (b : Bool) -> Either (so b) (so (not b))

2935choose True = Left oh

3036choose False = Right oh

3137

32−either : (a -> c) -> (b -> c) -> Either a b -> c

33−either l r (Left x) = l x

34−either l r (Right x) = r x

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

42+either : (f : Lazy (a -> c)) -> (g : Lazy (b -> c)) -> (e : Either a b) -> c

43+either l r (Left x) = (Force l) x

44+either l r (Right x) = (Force r) x

3545

46+||| Keep the payloads of all Left constructors in a list of Eithers

3647lefts : List (Either a b) -> List a

3748lefts [] = []

3849lefts (x::xs) =

@@ -40,6 +51,7 @@ lefts (x::xs) =

4051 Left l => l :: lefts xs

4152 Right r => lefts xs

4253

54+||| Keep the payloads of all Right constructors in a list of Eithers

4355rights : List (Either a b) -> List b

4456rights [] = []

4557rights (x::xs) =

@@ -47,9 +59,11 @@ rights (x::xs) =

4759 Left l => rights xs

4860 Right r => r :: rights xs

4961

62+||| Split a list of Eithers into a list of the left elements and a list of the right elements

5063partitionEithers : List (Either a b) -> (List a, List b)

5164partitionEithers l = (lefts l, rights l)

5265

66+||| Remove a "useless" Either by collapsing the case distinction

5367fromEither : Either a a -> a

5468fromEither (Left l) = l

5569fromEither (Right r) = r

@@ -58,7 +72,9 @@ fromEither (Right r) = r

5872-- Conversions

5973--------------------------------------------------------------------------------

6074

61−maybeToEither : e -> Maybe a -> Either e a

75+||| Convert a Maybe to an Either by using a default value in case of Nothing

76+||| @ e the default value

77+maybeToEither : (def : Lazy e) -> Maybe a -> Either e a

6278maybeToEither def (Just j) = Right j

6379maybeToEither def Nothing = Left def

6480

@@ -78,10 +94,12 @@ instance (Eq a, Eq b) => Eq (Either a b) where

7894-- Injectivity of constructors

7995--------------------------------------------------------------------------------

8096

97+||| Left is injective

8198total leftInjective : {b : Type} -> {x : a} -> {y : a}

8299 -> (Left {b = b} x = Left {b = b} y) -> (x = y)

83100leftInjective refl = refl

84101

102+||| Right is injective

85103total rightInjective : {a : Type} -> {x : b} -> {y : b}

86104 -> (Right {a = a} x = Right {a = a} y) -> (x = y)

87105rightInjective refl = refl

libs/prelude/Prelude/Fin.idr+55−5

@@ -2,13 +2,23 @@ module Prelude.Fin

22

33import Prelude.Nat

44import Prelude.Either

5+import Prelude.Uninhabited

56

67%default total

78

8−data Fin : Nat -> Type where

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

14+data Fin : (n : Nat) -> Type where

915 fZ : Fin (S k)

1016 fS : Fin k -> Fin (S k)

1117

18+instance Uninhabited (Fin Z) where

19+ uninhabited fZ impossible

20+ uninhabited (fS f) impossible

21+

1222fSInjective : (m : Fin k) -> (n : Fin k) -> fS m = fS n -> m = n

1323fSInjective left _ refl = refl

1424

@@ -17,16 +27,19 @@ instance Eq (Fin n) where

1727 (==) (fS k) (fS k') = k == k'

1828 (==) _ _ = False

1929

30+||| There are no elements of `Fin Z`

2031FinZAbsurd : Fin Z -> _|_

2132FinZAbsurd fZ impossible

2233

2334FinZElim : Fin Z -> a

2435FinZElim x = FalseElim (FinZAbsurd x)

2536

37+||| Convert a Fin to a Nat

2638finToNat : Fin n -> Nat

2739finToNat fZ = Z

2840finToNat (fS k) = S (finToNat k)

2941

42+||| `finToNat` is injective

3043finToNatInjective : (fm : Fin k) -> (fn : Fin k) -> (finToNat fm) = (finToNat fn) -> fm = fn

3144finToNatInjective fZ fZ refl = refl

3245finToNatInjective (fS m) fZ refl impossible

@@ -37,6 +50,7 @@ finToNatInjective (fS m) (fS n) prf =

3750instance Cast (Fin n) Nat where

3851 cast x = finToNat x

3952

53+||| Convert a Fin to an Integer

4054finToInteger : Fin n -> Integer

4155finToInteger fZ = 0

4256finToInteger (fS k) = 1 + finToInteger k

@@ -44,14 +58,18 @@ finToInteger (fS k) = 1 + finToInteger k

4458instance Cast (Fin n) Integer where

4559 cast x = finToInteger x

4660

61+||| Weaken the bound on a Fin by 1

4762weaken : Fin n -> Fin (S n)

4863weaken fZ = fZ

4964weaken (fS k) = fS (weaken k)

5065

66+||| Weaken the bound on a Fin by some amount

5167weakenN : (n : Nat) -> Fin m -> Fin (m + n)

5268weakenN n fZ = fZ

5369weakenN n (fS f) = fS (weakenN n f)

5470

71+||| Attempt to tighten the bound on a Fin.

72+||| Return `Left` if the bound could not be tightened, or `Right` if it could.

5573strengthen : Fin (S n) -> Either (Fin (S n)) (Fin n)

5674strengthen {n = S k} fZ = Right fZ

5775strengthen {n = S k} (fS i) with (strengthen i)

@@ -59,10 +77,14 @@ strengthen {n = S k} (fS i) with (strengthen i)

5977 strengthen (fS k) | Right x = Right (fS x)

6078strengthen f = Left f

6179

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

6283shift : (m : Nat) -> Fin n -> Fin (m + n)

6384shift Z f = f

6485shift {n=n} (S m) f = fS {k = (m + n)} (shift m f)

6586

87+||| The largest element of some Fin type

6688last : Fin (S n)

6789last {n=Z} = fZ

6890last {n=S _} = fS last

@@ -70,7 +92,12 @@ last {n=S _} = fS last

7092total fSinjective : {f : Fin n} -> {f' : Fin n} -> (fS f = fS f') -> f = f'

7193fSinjective refl = refl

7294

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+

74101instance MinBound (Fin (S n)) where

75102 minBound = fZ

76103

@@ -78,6 +105,24 @@ instance MaxBound (Fin (S n)) where

78105 maxBound = last

79106

80107

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+

81126-- Construct a Fin from an integer literal which must fit in the given Fin

82127

83128natToFin : Nat -> (n : Nat) -> Maybe (Fin n)

@@ -90,12 +135,17 @@ natToFin _ _ = Nothing

90135integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)

91136integerToFin x n = if x >= 0 then natToFin (cast x) n else Nothing

92137

138+||| Proof that some `Maybe` is actually `Just`

93139data IsJust : Maybe a -> Type where

94− ItIsJust : IsJust {a} (Just x)

140+ ItIsJust : IsJust {a} (Just x)

95141

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

96145fromInteger : (x : Integer) ->

97− {default ItIsJust

98− prf : (IsJust (integerToFin x n))} -> Fin n

146+ {default ItIsJust

147+ prf : (IsJust (integerToFin x n))} ->

148+ Fin n

99149fromInteger {n} x {prf} with (integerToFin x n)

100150 fromInteger {n} x {prf = ItIsJust} | Just y = y

101151

libs/prelude/Prelude/Foldable.idr+27−11

@@ -10,31 +10,47 @@ import Prelude.Algebra

1010

1111class Foldable (t : Type -> Type) where

1212 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

1315

14−foldl : Foldable t => (acc -> elt -> acc) -> acc -> t elt -> acc

15−foldl f z t = foldr (flip (.) . flip f) id t z

16−

16+||| Combine each element of a structure into a monoid

1717concat : (Foldable t, Monoid a) => t a -> a

1818concat = foldr (<+>) neutral

1919

20+||| Combine into a monoid the collective results of applying a function

21+||| to each element of a structure

2022concatMap : (Foldable t, Monoid m) => (a -> m) -> t a -> m

2123concatMap f = foldr ((<+>) . f) neutral

2224

23−and : Foldable t => t Bool -> Bool

24−and = foldr (&&) True

25−

26−or : Foldable t => t Bool -> Bool

27−or = foldr (||) False

28−

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.

28+and : Foldable t => t (Lazy Bool) -> Bool

29+and = foldl (&&) True

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.

34+or : Foldable t => t (Lazy Bool) -> Bool

35+or = foldl (||) False

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.

2940any : Foldable t => (a -> Bool) -> t a -> Bool

30−any p = foldr ((||) . p) False

41+any p = foldl (\x => \y => x || p y) False

3142

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.

3246all : Foldable t => (a -> Bool) -> t a -> Bool

33−all p = foldr ((&&) . p) True

47+all p = foldl (\x => \y => x && p y) True

3448

49+||| Add together all the elements of a structure

3550sum : (Foldable t, Num a) => t a -> a

3651sum = foldr (+) 0

3752

53+||| Multiply together all elements of a structure

3854product : (Foldable t, Num a) => t a -> a

3955product = foldr (*) 1

4056

libs/prelude/Prelude/Functor.idr+6−1

@@ -1,4 +1,9 @@

11module Prelude.Functor

22

3+||| Functors

4+||| @ f the action of the functor on objects

35class Functor (f : Type -> Type) where

4− map : (a -> b) -> f a -> f b

6+ ||| The action of the functor on morphisms

7+ ||| @ f the functor

8+ ||| @ m the morphism

9+ map : (m : a -> b) -> f a -> f b

libs/prelude/Prelude/List.idr+178−42

@@ -12,11 +12,15 @@ import Prelude.Nat

1212%access public

1313%default total

1414

15+infix 5 \\

1516infixr 7 ::,++

1617

17−%elim data List a

18− = Nil

19− | (::) a (List a)

18+||| Linked lists

19+%elim data List a =

20+ ||| The empty list

21+ Nil |

22+ ||| Cons cell

23+ (::) a (List a)

2024

2125-- Name hints for interactive editing

2226%name List xs, ys, zs, ws

@@ -25,10 +29,12 @@ infixr 7 ::,++

2529-- Syntactic tests

2630--------------------------------------------------------------------------------

2731

32+||| Returns `True` iff the argument is empty

2833isNil : List a -> Bool

2934isNil [] = True

3035isNil (x::xs) = False

3136

37+||| Returns `True` iff the argument is not empty

3238isCons : List a -> Bool

3339isCons [] = False

3440isCons (x::xs) = True

@@ -37,6 +43,9 @@ isCons (x::xs) = True

3743-- Length

3844--------------------------------------------------------------------------------

3945

46+||| Compute the length of a list.

47+|||

48+||| Runs in linear time

4049length : List a -> Nat

4150length [] = 0

4251length (x::xs) = 1 + length xs

@@ -45,49 +54,74 @@ length (x::xs) = 1 + length xs

4554-- Indexing into lists

4655--------------------------------------------------------------------------------

4756

48−index : (n : Nat) -> (l : List a) -> (lt n (length l) = True) -> a

57+||| Find a particular element of a list.

58+|||

59+||| @ ok a proof that the index is within bounds

60+index : (n : Nat) -> (l : List a) -> (ok : lt n (length l) = True) -> a

4961index Z (x::xs) p = x

5062index (S n) (x::xs) p = index n xs ?indexTailProof

5163index _ [] refl impossible

5264

65+||| Attempt to find a particular element of a list.

66+|||

67+||| If the provided index is out of bounds, return Nothing.

5368index' : (n : Nat) -> (l : List a) -> Maybe a

5469index' Z (x::xs) = Just x

5570index' (S n) (x::xs) = index' n xs

5671index' _ [] = Nothing

5772

58−head : (l : List a) -> (isCons l = True) -> a

73+||| Get the first element of a non-empty list

74+||| @ ok proof that the list is non-empty

75+head : (l : List a) -> (ok : isCons l = True) -> a

5976head [] refl impossible

6077head (x::xs) p = x

6178

79+||| Attempt to get the first element of a list. If the list is empty, return

80+||| `Nothing`.

6281head' : (l : List a) -> Maybe a

6382head' [] = Nothing

6483head' (x::xs) = Just x

6584

66−tail : (l : List a) -> (isCons l = True) -> List a

85+||| Get the tail of a non-empty list.

86+||| @ ok proof that the list is non-empty

87+tail : (l : List a) -> (ok : isCons l = True) -> List a

6788tail [] refl impossible

6889tail (x::xs) p = xs

6990

91+||| Attempt to get the tail of a list.

92+|||

93+||| If the list is empty, return `Nothing`.

7094tail' : (l : List a) -> Maybe (List a)

7195tail' [] = Nothing

7296tail' (x::xs) = Just xs

7397

74−last : (l : List a) -> (isCons l = True) -> a

98+||| Retrieve the last element of a non-empty list.

99+||| @ ok proof that the list is non-empty

100+last : (l : List a) -> (ok : isCons l = True) -> a

75101last [] refl impossible

76102last [x] p = x

77103last (x::y::ys) p = last (y::ys) refl

78104

105+||| Attempt to retrieve the last element of a non-empty list.

106+|||

107+||| If the list is empty, return `Nothing`.

79108last' : (l : List a) -> Maybe a

80109last' [] = Nothing

81−last' (x::xs) =

110+last' (x::xs) =

82111 case xs of

83112 [] => Just x

84113 y :: ys => last' xs

85114

86−init : (l : List a) -> (isCons l = True) -> List a

115+||| Return all but the last element of a non-empty list.

116+||| @ ok proof that the list is non-empty

117+init : (l : List a) -> (ok : isCons l = True) -> List a

87118init [] refl impossible

88119init [x] p = []

89120init (x::y::ys) p = x :: init (y::ys) refl

90121

122+||| Attempt to Return all but the last element of a list.

123+|||

124+||| If the list is empty, return `Nothing`.

91125init' : (l : List a) -> Maybe (List a)

92126init' [] = Nothing

93127init' (x::xs) =

@@ -103,21 +137,39 @@ init' (x::xs) =

103137-- Sublists

104138--------------------------------------------------------------------------------

105139

106−take : Nat -> List a -> List a

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

145+take : (n : Nat) -> (xs : List a) -> List a

107146take Z xs = []

108147take (S n) [] = []

109148take (S n) (x::xs) = x :: take n xs

110149

111−drop : Nat -> List a -> List a

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

155+drop : (n : Nat) -> (xs : List a) -> List a

112156drop Z xs = xs

113157drop (S n) [] = []

114158drop (S n) (x::xs) = drop n xs

115159

116−takeWhile : (a -> Bool) -> List a -> List a

160+||| Take the longest prefix of a list such that all elements satsify some

161+||| Boolean predicate.

162+|||

163+||| @ p the predicate

164+takeWhile : (p : a -> Bool) -> List a -> List a

117165takeWhile p [] = []

118166takeWhile p (x::xs) = if p x then x :: takeWhile p xs else []

119167

120−dropWhile : (a -> Bool) -> List a -> List a

168+||| Remove the longest prefix of a list such that all removed elements satsify some

169+||| Boolean predicate.

170+|||

171+||| @ p the predicate

172+dropWhile : (p : a -> Bool) -> List a -> List a

121173dropWhile p [] = []

122174dropWhile p (x::xs) = if p x then dropWhile p xs else x::xs

123175

@@ -125,24 +177,29 @@ dropWhile p (x::xs) = if p x then dropWhile p xs else x::xs

125177-- Misc.

126178--------------------------------------------------------------------------------

127179

128−list : a -> (a -> List a -> a) -> List a -> a

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

185+list : (nil : Lazy b) -> (cons : Lazy (a -> List a -> b)) -> (xs : List a) -> b

129186list nil cons [] = nil

130−list nil cons (x::xs) = cons x xs

187+list nil cons (x::xs) = (Force cons) x xs

131188

132189--------------------------------------------------------------------------------

133190-- Building (bigger) lists

134191--------------------------------------------------------------------------------

135192

193+||| Append two lists

136194(++) : List a -> List a -> List a

137−(++) [] right = right

195+(++) [] right = right

138196(++) (x::xs) right = x :: (xs ++ right)

139197

140−partial

141−repeat : a -> List a

142−repeat x = x :: lazy (repeat x)

143−

144−replicate : Nat -> a -> List a

145−replicate Z x = []

198+||| Construct a list with `n` copies of `x`

199+||| @ n how many copies

200+||| @ x the element to replicate

201+replicate : (n : Nat) -> (x : a) -> List a

202+replicate Z x = []

146203replicate (S n) x = x :: replicate n x

147204

148205--------------------------------------------------------------------------------

@@ -187,15 +244,27 @@ instance Functor List where

187244-- Zips and unzips

188245--------------------------------------------------------------------------------

189246

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

190252zipWith : (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

192254zipWith f [] (y::ys) refl impossible

193255zipWith f (x::xs) [] refl impossible

194256zipWith f [] [] p = []

195257zipWith f (x::xs) (y::ys) p = f x y :: (zipWith f xs ys ?zipWithTailProof)

196258

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

197266zipWith3 : (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

199268zipWith3 f _ [] (z::zs) p refl impossible

200269zipWith3 f _ (y::ys) [] p refl impossible

201270zipWith3 f [] (y::ys) _ refl q impossible

@@ -204,18 +273,22 @@ zipWith3 f [] [] [] p q = []

204273zipWith3 f (x::xs) (y::ys) (z::zs) p q =

205274 f x y z :: (zipWith3 f xs ys zs ?zipWith3TailProof ?zipWith3TailProof')

206275

276+||| Combine two lists elementwise into pairs

207277zip : (l : List a) -> (r : List b) -> (length l = length r) -> List (a, b)

208278zip = zipWith (\x => \y => (x, y))

209279

280+||| Combine three lists elementwise into tuples

210281zip3 : (x : List a) -> (y : List b) -> (z : List c) -> (length x = length y) ->

211282 (length y = length z) -> List (a, b, c)

212283zip3 = zipWith3 (\x => \y => \z => (x, y, z))

213284

285+||| Split a list of pairs into two lists

214286unzip : List (a, b) -> (List a, List b)

215287unzip [] = ([], [])

216288unzip ((l, r)::xs) with (unzip xs)

217289 | (lefts, rights) = (l::lefts, r::rights)

218290

291+||| Split a list of triples into three lists

219292unzip3 : List (a, b, c) -> (List a, List b, List c)

220293unzip3 [] = ([], [], [])

221294unzip3 ((l, c, r)::xs) with (unzip3 xs)

@@ -225,6 +298,8 @@ unzip3 ((l, c, r)::xs) with (unzip3 xs)

225298-- Maps

226299--------------------------------------------------------------------------------

227300

301+||| Apply a partial function to the elements of a list, keeping the ones at which

302+||| it is defined.

228303mapMaybe : (a -> Maybe b) -> List a -> List b

229304mapMaybe f [] = []

230305mapMaybe f (x::xs) =

@@ -236,14 +311,19 @@ mapMaybe f (x::xs) =

236311-- Folds

237312--------------------------------------------------------------------------------

238313

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+

239319instance Foldable List where

240− foldr f e [] = e

241− foldr f e (x::xs) = f x (foldr f e xs)

320+ foldr f e xs = foldrImpl f e id xs

242321

243322--------------------------------------------------------------------------------

244323-- Special folds

245324--------------------------------------------------------------------------------

246325

326+||| Convert any Foldable structure to a list.

247327toList : Foldable t => t a -> List a

248328toList = foldr (::) []

249329

@@ -251,6 +331,7 @@ toList = foldr (::) []

251331-- Transformations

252332--------------------------------------------------------------------------------

253333

334+||| Return the elements of a list in reverse order.

254335reverse : List a -> List a

255336reverse = reverse' []

256337 where

@@ -258,6 +339,7 @@ reverse = reverse' []

258339 reverse' acc [] = acc

259340 reverse' acc (x::xs) = reverse' (x::acc) xs

260341

342+||| Insert some separator between the elements of a list.

261343intersperse : a -> List a -> List a

262344intersperse sep [] = []

263345intersperse sep (x::xs) = x :: intersperse' sep xs

@@ -269,17 +351,17 @@ intersperse sep (x::xs) = x :: intersperse' sep xs

269351intercalate : List a -> List (List a) -> List a

270352intercalate sep l = concat $ intersperse sep l

271353

272−-- | Transposes rows and columns of a list of lists.

273−--

274−-- > transpose [[1, 2], [3, 4]] = [[1, 3], [2, 4]]

275−--

276−-- This also works for non square scenarios, thus

277−-- involution does not always hold:

278−--

279−-- > transpose [[], [1, 2]] = [[1], [2]]

280−-- > transpose (transpose [[], [1, 2]]) = [[1, 2]]

281−--

282−-- TODO: Solution which satisfies the totality checker?

354+||| Transposes rows and columns of a list of lists.

355+|||

356+||| > transpose [[1, 2], [3, 4]] = [[1, 3], [2, 4]]

357+|||

358+||| This also works for non square scenarios, thus

359+||| involution does not always hold:

360+|||

361+||| > transpose [[], [1, 2]] = [[1], [2]]

362+||| > transpose (transpose [[], [1, 2]]) = [[1, 2]]

363+|||

364+||| TODO: Solution which satisfies the totality checker?

283365%assert_total

284366transpose : List (List a) -> List (List a)

285367transpose [] = []

@@ -290,6 +372,7 @@ transpose ((x::xs) :: xss) = (x :: (mapMaybe head' xss)) :: (transpose (xs :: (m

290372-- Membership tests

291373--------------------------------------------------------------------------------

292374

375+||| Check if something is a member of a list using a custom comparison.

293376elemBy : (a -> a -> Bool) -> a -> List a -> Bool

294377elemBy p e [] = False

295378elemBy p e (x::xs) =

@@ -298,9 +381,11 @@ elemBy p e (x::xs) =

298381 else

299382 elemBy p e xs

300383

384+||| Check if something is a member of a list using the default Boolean equality.

301385elem : Eq a => a -> List a -> Bool

302386elem = elemBy (==)

303387

388+||| Find associated information in a list using a custom comparison.

304389lookupBy : (a -> a -> Bool) -> a -> List (a, b) -> Maybe b

305390lookupBy p e [] = Nothing

306391lookupBy p e (x::xs) =

@@ -310,9 +395,12 @@ lookupBy p e (x::xs) =

310395 else

311396 lookupBy p e xs

312397

398+||| Find associated information in a list using Boolean equality.

313399lookup : Eq a => a -> List (a, b) -> Maybe b

314400lookup = lookupBy (==)

315401

402+||| Check if any elements of the first list are found in the second, using

403+||| a custom comparison.

316404hasAnyBy : (a -> a -> Bool) -> List a -> List a -> Bool

317405hasAnyBy p elems [] = False

318406hasAnyBy p elems (x::xs) =

@@ -321,6 +409,8 @@ hasAnyBy p elems (x::xs) =

321409 else

322410 hasAnyBy p elems xs

323411

412+||| Check if any elements of the first list are found in the second, using

413+||| Boolean equality.

324414hasAny : Eq a => List a -> List a -> Bool

325415hasAny = hasAnyBy (==)

326416

@@ -328,6 +418,7 @@ hasAny = hasAnyBy (==)

328418-- Searching with a predicate

329419--------------------------------------------------------------------------------

330420

421+||| Find the first element of a list that satisfies a predicate, or `Nothing` if none do.

331422find : (a -> Bool) -> List a -> Maybe a

332423find p [] = Nothing

333424find p (x::xs) =

@@ -336,6 +427,8 @@ find p (x::xs) =

336427 else

337428 find p xs

338429

430+||| Find the index of the first element of a list that satisfies a predicate, or

431+||| `Nothing` if none do.

339432findIndex : (a -> Bool) -> List a -> Maybe Nat

340433findIndex = findIndex' Z

341434 where

@@ -347,6 +440,7 @@ findIndex = findIndex' Z

347440 else

348441 findIndex' (S cnt) p xs

349442

443+||| Find the indices of all elements that satisfy some predicate.

350444findIndices : (a -> Bool) -> List a -> List Nat

351445findIndices = findIndices' Z

352446 where

@@ -396,10 +490,28 @@ nubBy = nubBy' []

396490nub : Eq a => List a -> List a

397491nub = nubBy (==)

398492

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+

399509--------------------------------------------------------------------------------

400510-- Splitting and breaking lists

401511--------------------------------------------------------------------------------

402512

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.

403515span : (a -> Bool) -> List a -> (List a, List a)

404516span p [] = ([], [])

405517span p (x::xs) =

@@ -413,12 +525,19 @@ break : (a -> Bool) -> List a -> (List a, List a)

413525break p = span (not . p)

414526

415527split : (a -> Bool) -> List a -> List (List a)

416−split p [] = []

417528split p xs =

418529 case break p xs of

419530 (chunk, []) => [chunk]

420531 (chunk, (c :: rest)) => chunk :: split p (assert_smaller xs rest)

421532

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+

422541partition : (a -> Bool) -> List a -> (List a, List a)

423542partition p [] = ([], [])

424543partition p (x::xs) =

@@ -428,6 +547,16 @@ partition p (x::xs) =

428547 else

429548 (lefts, x::rights)

430549

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+

431560--------------------------------------------------------------------------------

432561-- Predicates

433562--------------------------------------------------------------------------------

@@ -490,6 +619,7 @@ sort xs = let (x, y) = split xs in

490619-- Conversions

491620--------------------------------------------------------------------------------

492621

622+||| Either return the head of a list, or `Nothing` if it is empty.

493623listToMaybe : List a -> Maybe a

494624listToMaybe [] = Nothing

495625listToMaybe (x::xs) = Just x

@@ -509,7 +639,7 @@ catMaybes (x::xs) =

509639-- Properties

510640--------------------------------------------------------------------------------

511641

512−-- append

642+||| The empty list is a right identity for append.

513643appendNilRightNeutral : (l : List a) ->

514644 l ++ [] = l

515645appendNilRightNeutral [] = refl

@@ -517,6 +647,7 @@ appendNilRightNeutral (x::xs) =

517647 let inductiveHypothesis = appendNilRightNeutral xs in

518648 ?appendNilRightNeutralStepCase

519649

650+||| Appending lists is associative.

520651appendAssociative : (l : List a) -> (c : List a) -> (r : List a) ->

521652 l ++ (c ++ r) = (l ++ c) ++ r

522653appendAssociative [] c r = refl

@@ -524,7 +655,8 @@ appendAssociative (x::xs) c r =

524655 let inductiveHypothesis = appendAssociative xs c r in

525656 ?appendAssociativeStepCase

526657

527−-- length

658+||| The length of two lists that are appended is the sum of the lengths

659+||| of the input lists.

528660lengthAppend : (left : List a) -> (right : List a) ->

529661 length (left ++ right) = length left + length right

530662lengthAppend [] right = refl

@@ -532,7 +664,7 @@ lengthAppend (x::xs) right =

532664 let inductiveHypothesis = lengthAppend xs right in

533665 ?lengthAppendStepCase

534666

535−-- map

667+||| Mapping a function over a list doesn't change its length.

536668mapPreservesLength : (f : a -> b) -> (l : List a) ->

537669 length (map f l) = length l

538670mapPreservesLength f [] = refl

@@ -540,6 +672,8 @@ mapPreservesLength f (x::xs) =

540672 let inductiveHypothesis = mapPreservesLength f xs in

541673 ?mapPreservesLengthStepCase

542674

675+||| Mapping a function over two lists and appending them is equivalent

676+||| to appending them and then mapping the function.

543677mapDistributesOverAppend : (f : a -> b) -> (l : List a) -> (r : List a) ->

544678 map f (l ++ r) = map f l ++ map f r

545679mapDistributesOverAppend f [] r = refl

@@ -547,6 +681,7 @@ mapDistributesOverAppend f (x::xs) r =

547681 let inductiveHypothesis = mapDistributesOverAppend f xs r in

548682 ?mapDistributesOverAppendStepCase

549683

684+||| Mapping two functions is the same as mapping their composition.

550685mapFusion : (f : b -> c) -> (g : a -> b) -> (l : List a) ->

551686 map f (map g l) = map (f . g) l

552687mapFusion f g [] = refl

@@ -554,7 +689,7 @@ mapFusion f g (x::xs) =

554689 let inductiveHypothesis = mapFusion f g xs in

555690 ?mapFusionStepCase

556691

557−-- hasAny

692+||| No list contains an element of the empty list by any predicate.

558693hasAnyByNilFalse : (p : a -> a -> Bool) -> (l : List a) ->

559694 hasAnyBy p [] l = False

560695hasAnyByNilFalse p [] = refl

@@ -562,6 +697,7 @@ hasAnyByNilFalse p (x::xs) =

562697 let inductiveHypothesis = hasAnyByNilFalse p xs in

563698 ?hasAnyByNilFalseStepCase

564699

700+||| No list contains an element of the empty list.

565701hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False

566702hasAnyNilFalse l = ?hasAnyNilFalseBody

567703

libs/prelude/Prelude/Maybe.idr+10−3

@@ -28,25 +28,32 @@ isJust (Just j) = True

2828-- Misc

2929--------------------------------------------------------------------------------

3030

31−maybe : Lazy b -> (a -> b) -> Maybe a -> b

31+maybe : Lazy b -> Lazy (a -> b) -> Maybe a -> b

3232maybe n j Nothing = n

33−maybe n j (Just x) = j x

33+maybe n j (Just x) = (Force j) x

3434

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`.

3537fromMaybe : (Lazy a) -> Maybe a -> a

3638fromMaybe def Nothing = def

3739fromMaybe def (Just j) = j

3840

39−toMaybe : Bool -> a -> Maybe a

41+||| Returns `Just` the given value if the conditional is `True`

42+||| and `Nothing` if the conditional is `False`.

43+toMaybe : Bool -> Lazy a -> Maybe a

4044toMaybe True j = Just j

4145toMaybe False j = Nothing

4246

4347justInjective : {x : t} -> {y : t} -> (Just x = Just y) -> x = y

4448justInjective refl = refl

4549

50+||| Convert a `Maybe a` value to an `a` value, using `neutral` in the case

51+||| that the `Maybe` value is `Nothing`.

4652lowerMaybe : Monoid a => Maybe a -> a

4753lowerMaybe Nothing = neutral

4854lowerMaybe (Just x) = x

4955

56+||| Returns `Nothing` when applied to `neutral`, and `Just` the value otherwise.

5057raiseToMaybe : (Monoid a, Eq a) => a -> Maybe a

5158raiseToMaybe x = if x == neutral then Nothing else Just x

5259

libs/prelude/Prelude/Monad.idr+4−1

@@ -13,8 +13,11 @@ infixl 5 >>=

1313class Applicative m => Monad (m : Type -> Type) where

1414 (>>=) : m a -> (a -> m b) -> m b

1515

16+||| Also called `join` or mu

1617flatten : Monad m => m (m a) -> m a

1718flatten a = a >>= id

1819

20+||| For compatibility with Haskell. Note that monads are **not** free to

21+||| define `return` and `pure` differently!

1922return : Monad m => a -> m a

20−return = pure

23+return = pure

libs/prelude/Prelude/Nat.idr+42−5

@@ -6,17 +6,24 @@ import Prelude.Algebra

66import Prelude.Bool

77import Prelude.Cast

88import Prelude.Classes

9+import Prelude.Uninhabited

910

1011%access public

1112%default total

1213

13−%elim data Nat

14− = Z

15− | S Nat

14+||| Unary natural numbers

15+%elim data Nat =

16+ ||| Zero

17+ Z |

18+ ||| Successor

19+ S Nat

1620

1721-- name hints for interactive editing

1822%name Nat k,j,i,n,m

1923

24+instance Uninhabited (Z = S n) where

25+ uninhabited refl impossible

26+

2027--------------------------------------------------------------------------------

2128-- Syntactic tests

2229--------------------------------------------------------------------------------

@@ -33,14 +40,19 @@ isSucc (S n) = True

3340-- Basic arithmetic functions

3441--------------------------------------------------------------------------------

3542

36−total plus : Nat -> Nat -> Nat

43+||| Add two natural numbers.

44+||| @ n the number to case-split on

45+||| @ m the other number

46+total plus : (n, m : Nat) -> Nat

3747plus Z right = right

3848plus (S left) right = S (plus left right)

3949

50+||| Multiply natural numbers

4051total mult : Nat -> Nat -> Nat

4152mult Z right = Z

4253mult (S left) right = plus right $ mult left right

4354

55+||| Convert an Integer to a Nat, mapping negative numbers to 0

4456fromIntegerNat : Integer -> Nat

4557fromIntegerNat 0 = Z

4658fromIntegerNat n =

@@ -49,15 +61,18 @@ fromIntegerNat n =

4961 else

5062 Z

5163

64+||| Convert a Nat to an Integer

5265toIntegerNat : Nat -> Integer

5366toIntegerNat Z = 0

5467toIntegerNat (S k) = 1 + toIntegerNat k

5568

69+||| Subtract natural numbers. If the second number is larger than the first, return 0.

5670total minus : Nat -> Nat -> Nat

5771minus Z right = Z

5872minus left Z = left

5973minus (S left) (S right) = minus left right

6074

75+||| Exponentiation of natural numbers

6176total power : Nat -> Nat -> Nat

6277power base Z = S Z

6378power 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)

7489-- Comparisons

7590--------------------------------------------------------------------------------

7691

77−data LTE : Nat -> Nat -> Type where

92+||| Proofs that `n` is less than or equal to `m`

93+||| @ n the smaller number

94+||| @ m the larger number

95+data LTE : (n, m : Nat) -> Type where

96+ ||| Zero is the smallest Nat

7897 lteZero : LTE Z right

98+ ||| If n <= m, then n + 1 <= m + 1

7999 lteSucc : LTE left right -> LTE (S left) (S right)

80100

101+||| Greater than or equal to

81102total GTE : Nat -> Nat -> Type

82103GTE left right = LTE right left

83104

105+||| Strict less than

84106total LT : Nat -> Nat -> Type

85107LT left right = LTE (S left) right

86108

109+||| Strict greater than

87110total GT : Nat -> Nat -> Type

88111GT left right = LT right left

89112

113+||| Boolean test than one Nat is less than or equal to another

90114total lte : Nat -> Nat -> Bool

91115lte Z right = True

92116lte left Z = False

93117lte (S left) (S right) = lte left right

94118

119+||| Boolean test than one Nat is greater than or equal to another

95120total gte : Nat -> Nat -> Bool

96121gte left right = lte right left

97122

123+||| Boolean test than one Nat is strictly less than another

98124total lt : Nat -> Nat -> Bool

99125lt left right = lte (S left) right

100126

127+||| Boolean test than one Nat is strictly greater than another

101128total gt : Nat -> Nat -> Bool

102129gt left right = lt right left

103130

131+||| Find the least of two natural numbers

104132total minimum : Nat -> Nat -> Nat

105133minimum left right =

106134 if lte left right then

@@ -108,6 +136,7 @@ minimum left right =

108136 else

109137 right

110138

139+||| Find the greatest of two natural numbers

111140total maximum : Nat -> Nat -> Nat

112141maximum left right =

113142 if lte left right then

@@ -148,9 +177,11 @@ instance MinBound Nat where

148177instance Cast Integer Nat where

149178 cast = fromInteger

150179

180+||| A wrapper for Nat that specifies the semigroup and monad instances that use (+)

151181record Multiplicative : Type where

152182 getMultiplicative : Nat -> Multiplicative

153183

184+||| A wrapper for Nat that specifies the semigroup and monad instances that use (*)

154185record Additive : Type where

155186 getAdditive : Nat -> Additive

156187

@@ -210,6 +241,7 @@ instance Cast Nat Int where

210241-- Auxilliary notions

211242--------------------------------------------------------------------------------

212243

244+||| The predecessor of a natural number. `pred Z` is `Z`.

213245total pred : Nat -> Nat

214246pred Z = Z

215247pred (S n) = n

@@ -218,11 +250,13 @@ pred (S n) = n

218250-- Fibonacci and factorial

219251--------------------------------------------------------------------------------

220252

253+||| Fibonacci numbers

221254total fib : Nat -> Nat

222255fib Z = Z

223256fib (S Z) = S Z

224257fib (S (S n)) = fib (S n) + fib n

225258

259+||| Factorial function

226260total fact : Nat -> Nat

227261fact Z = S Z

228262fact (S n) = (S n) * fact n

@@ -283,10 +317,13 @@ lcm x y = divNat (x * y) (gcd x y)

283317--------------------------------------------------------------------------------

284318

285319-- Succ

320+

321+||| S preserves equality

286322total eqSucc : (left : Nat) -> (right : Nat) -> (p : left = right) ->

287323 S left = S right

288324eqSucc left _ refl = refl

289325

326+||| S is injective

290327total succInjective : (left : Nat) -> (right : Nat) -> (p : S left = S right) ->

291328 left = right

292329succInjective 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

66%access public

77%default total

88

9+||| An infinite stream

910codata Stream : Type -> Type where

1011 (::) : a -> Stream a -> Stream a

1112

13+-- Hints for interactive editing

14+%name Stream xs,ys,zs,ws

15+

1216instance Functor Stream where

1317 map f (x::xs) = f x :: map f xs

1418

19+||| The first element of an infinite stream

1520head : Stream a -> a

1621head (x::xs) = x

1722

23+||| All but the first element

1824tail : Stream a -> Stream a

1925tail (x::xs) = xs

2026

21−take : (n : Nat) -> Stream a -> Vect n a

27+||| Take precisely n elements from the stream

28+||| @ n how many elements to take

29+||| @ xs the stream

30+take : (n : Nat) -> (xs : Stream a) -> Vect n a

2231take Z _ = []

2332take (S n) (x :: xs) = x :: (take n xs)

2433

34+||| Drop the first n elements from the stream

35+||| @ n how many elements to drop

2536%assert_total

26−drop : Nat -> Stream a -> Stream a

27−drop Z xs = xs

37+drop : (n : Nat) -> Stream a -> Stream a

38+drop Z xs = xs

2839drop (S k) (x::xs) = drop k xs

2940

41+||| An infinite stream of repetitions of the same thing

3042repeat : a -> Stream a

3143repeat x = x :: repeat x

3244

33−iterate : (a -> a) -> a -> Stream a

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

48+iterate : (f : a -> a) -> (x : a) -> Stream a

3449iterate f x = x :: iterate f (f x)

3550

51+||| Get the nth element of a stream

3652index : Nat -> Stream a -> a

37−index Z (x::xs) = x

53+index Z (x::xs) = x

3854index (S k) (x::xs) = index k xs

3955

56+||| Combine two streams element-wise using a function

4057zipWith : (a -> b -> c) -> Stream a -> Stream b -> Stream c

4158zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

4259

60+||| Create a stream of pairs from two streams

4361zip : Stream a -> Stream b -> Stream (a, b)

4462zip = zipWith (\x,y => (x,y))

4563

64+||| Create a pair of streams from a stream of pairs

4665unzip : Stream (a, b) -> (Stream a, Stream b)

4766unzip xs = (map fst xs, map snd xs)

4867

68+||| Return the diagonal elements of a stream of streams

4969diag : Stream (Stream a) -> Stream a

5070diag ((x::xs)::xss) = x :: diag (map tail xss)

5171

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

5299

libs/prelude/Prelude/Strings.idr+121−7

@@ -7,30 +7,60 @@ import Prelude.Cast

77import Prelude.Either

88import Prelude.Foldable

99

10−-- | Appends two strings together.

10+||| Appends two strings together.

11+|||

12+||| Idris> "AB" ++ "C"

13+||| "ABC" : String

1114(++) : String -> String -> String

1215(++) = prim__concat

1316

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

1523partial

1624strHead : String -> Char

1725strHead = prim__strHead

1826

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

2035partial

2136strTail : String -> String

2237strTail = prim__strTail

2338

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

2545strCons : Char -> String -> String

2646strCons = prim__strCons

2747

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

2954partial

3055strIndex : String -> Int -> Char

3156strIndex = prim__strIndex

3257

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

3464reverse : String -> String

3565reverse = prim__strRev

3666

@@ -43,9 +73,11 @@ data StrM : String -> Type where

4373 StrNil : StrM ""

4474 StrCons : (x : Char) -> (xs : String) -> StrM (strCons x xs)

4575

76+||| Version of 'strHead' that statically verifies that the string is not empty.

4677strHead' : (x : String) -> so (not (x == "")) -> Char

4778strHead' x p = assert_total $ prim__strHead x

4879

80+||| Version of 'strTail' that statically verifies that the string is not empty.

4981strTail' : (x : String) -> so (not (x == "")) -> String

5082strTail' x p = assert_total $ prim__strTail x

5183

@@ -61,14 +93,23 @@ strM x with (choose (not (x == "")))

6193-- a recursive argument, therefore the termination checker doesn't believe

6294-- the string is guaranteed smaller. It makes a good point.

6395

96+||| Turns a string into a list of characters.

97+|||

98+||| Idris> unpack "ABC"

99+||| ['A', 'B', 'C'] : List Char

64100unpack : String -> List Char

65101unpack s with (strM s)

66102 unpack "" | StrNil = []

67103 unpack (strCons x xs) | (StrCons x xs) = x :: assert_total (unpack xs)

68104

105+||| Turns a Foldable of characters into a string.

69106pack : (Foldable t) => t Char -> String

70107pack = foldr strCons ""

71108

109+||| Creates a string of a single character.

110+|||

111+||| Idris> singleton 'A'

112+||| "A" : String

72113singleton : Char -> String

73114singleton c = strCons c ""

74115

@@ -87,6 +128,13 @@ instance Semigroup String where

87128instance Monoid String where

88129 neutral = ""

89130

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)

90138span : (Char -> Bool) -> String -> (String, String)

91139span p xs with (strM xs)

92140 span p "" | StrNil = ("", "")

@@ -95,44 +143,92 @@ span p xs with (strM xs)

95143 | (ys, zs) = (strCons x ys, zs)

96144 | False = ("", strCons x xs)

97145

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)

98153break : (Char -> Bool) -> String -> (String, String)

99154break p = span (not . p)

100155

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

101161split : (Char -> Bool) -> String -> List String

102162split p xs = map pack (split p (unpack xs))

103163

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

104171ltrim : String -> String

105172ltrim xs with (strM xs)

106173 ltrim "" | StrNil = ""

107174 ltrim (strCons x xs) | StrCons _ _

108175 = if (isSpace x) then assert_total (ltrim xs) else (strCons x xs)

109176

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

110182trim : String -> String

111183trim xs = ltrim (reverse (ltrim (reverse xs)))

112184

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)

113189words' : List Char -> List (List Char)

114190words' s = case dropWhile isSpace s of

115191 [] => []

116192 s' => let (w, s'') = break isSpace s'

117193 in w :: words' (assert_smaller s s'')

118194

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

119199words : String -> List String

120200words s = map pack $ words' $ unpack s

121201

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)

122206lines' : List Char -> List (List Char)

123207lines' s = case dropWhile isNL s of

124208 [] => []

125209 s' => let (w, s'') = break isNL s'

126210 in w :: lines' (assert_smaller s s'')

127211

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

128216lines : String -> List String

129217lines s = map pack $ lines' $ unpack s

130218

131219partial

132220foldr1 : (a -> a -> a) -> List a -> a

133−foldr1 f [x] = x

221+foldr1 _ [x] = x

134222foldr1 f (x::xs) = f x (foldr1 f xs)

135223

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

136232unwords' : List (List Char) -> List Char

137233unwords' [] = []

138234unwords' ws = assert_total (foldr1 addSpace ws)

@@ -140,18 +236,36 @@ unwords' ws = assert_total (foldr1 addSpace ws)

140236 addSpace : List Char -> List Char -> List Char

141237 addSpace w s = w ++ (' ' :: s)

142238

239+||| Joins the strings by spaces into a single string.

240+|||

241+||| Idris> unwords ["A", "BC", "D", "E"]

242+||| "A BC D E" : String

143243unwords : List String -> String

144244unwords = pack . unwords' . map unpack

145245

246+||| Returns the length of the string.

247+|||

248+||| Idris> length ""

249+||| 0 : Nat

250+||| Idris> length "ABC"

251+||| 3 : Nat

146252length : String -> Nat

147253length = fromInteger . prim__zextInt_BigInt . prim_lenString

148254

255+||| Lowercases all characters in the string.

256+|||

257+||| Idris> toLower "aBc12!"

258+||| "abc12!" : String

149259toLower : String -> String

150260toLower x with (strM x)

151261 strToLower "" | StrNil = ""

152262 strToLower (strCons c cs) | (StrCons c cs) =

153263 strCons (toLower c) (toLower (assert_smaller (strCons c cs) cs))

154264

265+||| Uppercases all characters in the string.

266+|||

267+||| Idris> toLower "aBc12!"

268+||| "ABC12!" : String

155269toUpper : String -> String

156270toUpper x with (strM x)

157271 strToLower "" | StrNil = ""

libs/prelude/Prelude/Uninhabited.idr+13−9

@@ -1,15 +1,19 @@

11module Prelude.Uninhabited

22

3+import Builtins

4+

5+||| A canonical proof that some type is empty

36class Uninhabited t where

7+ ||| If I have a t, I've had a contradiction

8+ ||| @ t the uninhabited type

49 total uninhabited : t -> _|_

510

6−instance Uninhabited (Fin Z) where

7− uninhabited fZ impossible

8− uninhabited (fS f) impossible

9−

10−instance Uninhabited (Z = S n) where

11− uninhabited refl impossible

11+instance Uninhabited _|_ where

12+ uninhabited a = a

1213

13−-- | Use an absurd assumption to discharge a proof obligation

14−absurd : Uninhabited t => t -> a

15−absurd t = FalseElim (uninhabited t)

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

18+absurd : Uninhabited t => (h : t) -> a

19+absurd h = FalseElim (uninhabited h)

libs/prelude/Prelude/Vect.idr+174−33

@@ -7,6 +7,7 @@ import Prelude.List

77import Prelude.Classes

88import Prelude.Nat

99import Prelude.Bool

10+import Prelude.Uninhabited

1011

1112%access public

1213%default total

@@ -20,39 +21,76 @@ infixr 7 ::

2021-- Hints for interactive editing

2122%name Vect xs,ys,zs,ws

2223

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+

2343--------------------------------------------------------------------------------

2444-- Indexing into vectors

2545--------------------------------------------------------------------------------

2646

47+||| All but the first element of the vector

2748tail : Vect (S n) a -> Vect n a

2849tail (x::xs) = xs

2950

51+||| Only the first element of the vector

3052head : Vect (S n) a -> a

3153head (x::xs) = x

3254

55+||| The last element of the vector

3356last : Vect (S n) a -> a

3457last (x::[]) = x

3558last (x::y::ys) = last $ y::ys

3659

60+||| All but the last element of the vector

3761init : Vect (S n) a -> Vect n a

3862init (x::[]) = []

3963init (x::y::ys) = x :: init (y::ys)

4064

65+||| Extract a particular element from a vector

4166index : Fin n -> Vect n a -> a

4267index fZ (x::xs) = x

4368index (fS k) (x::xs) = index k xs

4469index fZ [] impossible

4570

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

4678deleteAt : Fin (S n) -> Vect (S n) a -> Vect n a

4779deleteAt fZ (x::xs) = xs

4880deleteAt {n = S m} (fS k) (x::xs) = x :: deleteAt k xs

81+deleteAt {n = Z} (fS k) (x::xs) = absurd k

4982deleteAt _ [] impossible

5083

84+||| Replace an element at a particlar index with another

5185replaceAt : Fin n -> t -> Vect n t -> Vect n t

5286replaceAt fZ y (x::xs) = y :: xs

5387replaceAt (fS k) y (x::xs) = x :: replaceAt k y xs

5488

55−updateAt : Fin n -> (t -> t) -> Vect n t -> Vect n t

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

93+updateAt : (i : Fin n) -> (f : t -> t) -> (xs : Vect n t) -> Vect n t

5694updateAt fZ f (x::xs) = f x :: xs

5795updateAt (fS k) f (x::xs) = x :: updateAt k f xs

5896

@@ -60,33 +98,82 @@ updateAt (fS k) f (x::xs) = x :: updateAt k f xs

6098-- Subvectors

6199--------------------------------------------------------------------------------

62100

101+||| Get the first m elements of a Vect

102+||| @ m the number of elements to take

63103take : {n : Nat} -> (m : Fin (S n)) -> Vect n a -> Vect (cast m) a

64104take (fS k) [] = FinZElim k

65105take fZ _ = []

66106take (fS k) (x::xs) = x :: take k xs

67107

108+||| Remove the first m elements of a Vect

109+||| @ m the number of elements to remove

68110drop : (m : Fin (S n)) -> Vect n a -> Vect (n - cast m) a

69111drop (fS k) [] = FinZElim k

70112drop fZ xs ?= xs

71113drop (fS k) (x::xs) = drop k xs

72114

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+

73144--------------------------------------------------------------------------------

74145-- Conversion from list (toList is provided by Foldable)

75146--------------------------------------------------------------------------------

76147

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.

77159fromList : (l : List a) -> Vect (length l) a

78−fromList [] = []

79−fromList (x::xs) = x :: fromList xs

160+fromList l =

161+ rewrite (sym $ plusZeroRightNeutral (length l)) in

162+ reverse $ fromList' [] l

80163

81164--------------------------------------------------------------------------------

82165-- Building (bigger) vectors

83166--------------------------------------------------------------------------------

84167

168+||| Append two vectors

85169(++) : Vect m a -> Vect n a -> Vect (m + n) a

86170(++) [] ys = ys

87171(++) (x::xs) ys = x :: xs ++ ys

88172

89−replicate : (n : Nat) -> a -> Vect n a

173+||| Repeate some value n times

174+||| @ n the number of times to repeat it

175+||| @ x the value to repeat

176+replicate : (n : Nat) -> (x : a) -> Vect n a

90177replicate Z x = []

91178replicate (S k) x = x :: replicate k x

92179

@@ -94,18 +181,21 @@ replicate (S k) x = x :: replicate k x

94181-- Zips and unzips

95182--------------------------------------------------------------------------------

96183

184+||| Combine two equal-length vectors pairwise with some function

97185zipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

98186zipWith f [] [] = []

99187zipWith f (x::xs) (y::ys) = f x y :: zipWith f xs ys

100188

189+||| Combine two equal-length vectors pairwise

101190zip : Vect n a -> Vect n b -> Vect n (a, b)

102191zip = zipWith (\x => \y => (x,y))

103192

193+||| Convert a vector of pairs to a pair of vectors

104194unzip : Vect n (a, b) -> (Vect n a, Vect n b)

105195unzip [] = ([], [])

106196unzip ((l, r)::xs) with (unzip xs)

107197 | (lefts, rights) = (l::lefts, r::rights)

108−

198+

109199--------------------------------------------------------------------------------

110200-- Equality

111201--------------------------------------------------------------------------------

@@ -154,65 +244,81 @@ instance Functor (Vect n) where

154244-- Folds

155245--------------------------------------------------------------------------------

156246

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+

157251instance Foldable (Vect n) where

158− foldr f e [] = e

159− foldr f e (x::xs) = f x (foldr f e xs)

252+ foldr f e xs = foldrImpl f e id xs

160253

161254--------------------------------------------------------------------------------

162255-- Special folds

163256--------------------------------------------------------------------------------

164257

258+||| Flatten a vector of equal-length vectors

165259concat : Vect m (Vect n a) -> Vect (m * n) a

166260concat [] = []

167261concat (v::vs) = v ++ concat vs

168262

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

169270--------------------------------------------------------------------------------

170−-- Transformations

271+-- Scans

171272--------------------------------------------------------------------------------

172273

173−total reverse : Vect n a -> Vect n a

174−reverse = reverse' []

175− where

176− total reverse' : Vect m a -> Vect n a -> Vect (m + n) a

177− reverse' acc [] ?= acc

178− reverse' acc (x::xs) ?= reverse' (x::acc) xs

179−

180−intersperse : a -> Vect n a -> Vect (n + pred n) a

181−intersperse sep [] = []

182−intersperse sep (x::xs) = x :: intersperse' sep xs

183− where

184− intersperse' : a -> Vect n a -> Vect (n + n) a

185− intersperse' sep [] = []

186− intersperse' sep (x::xs) ?= sep :: x :: intersperse' sep xs

274+scanl : (b -> a -> b) -> b -> Vect n a -> Vect (S n) b

275+scanl f q [] = [q]

276+scanl f q (x::xs) = q :: scanl f (f q x) xs

187277

188278--------------------------------------------------------------------------------

189279-- Membership tests

190280--------------------------------------------------------------------------------

191281

192−elemBy : (a -> a -> Bool) -> a -> Vect n a -> Bool

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

286+elemBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n a) -> Bool

193287elemBy p e [] = False

194288elemBy p e (x::xs) with (p e x)

195289 | True = True

196290 | False = elemBy p e xs

197291

198−elem : Eq a => a -> Vect n a -> Bool

292+||| Use the default Boolean equality on elements to search for an item

293+||| @ x what to search for

294+||| @ xs where to search

295+elem : Eq a => (x : a) -> (xs : Vect n a) -> Bool

199296elem = elemBy (==)

200297

201−lookupBy : (a -> a -> Bool) -> a -> Vect n (a, b) -> Maybe b

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

301+lookupBy : (p : a -> a -> Bool) -> (e : a) -> (xs : Vect n (a, b)) -> Maybe b

202302lookupBy p e [] = Nothing

203303lookupBy p e ((l, r)::xs) with (p e l)

204304 | True = Just r

205305 | False = lookupBy p e xs

206306

307+||| Find the assocation of some key using the default Boolean equality test

207308lookup : Eq a => a -> Vect n (a, b) -> Maybe b

208309lookup = lookupBy (==)

209310

210−hasAnyBy : (a -> a -> Bool) -> Vect m a -> Vect n a -> Bool

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

315+hasAnyBy : (p : a -> a -> Bool) -> (elems : Vect m a) -> (xs : Vect n a) -> Bool

211316hasAnyBy p elems [] = False

212317hasAnyBy p elems (x::xs) with (elemBy p x elems)

213318 | True = True

214319 | False = hasAnyBy p elems xs

215320

321+||| Check if any element of xs is found in elems using the default Boolean equality test

216322hasAny : Eq a => Vect m a -> Vect n a -> Bool

217323hasAny = hasAnyBy (==)

218324

@@ -220,12 +326,15 @@ hasAny = hasAnyBy (==)

220326-- Searching with a predicate

221327--------------------------------------------------------------------------------

222328

223−find : (a -> Bool) -> Vect n a -> Maybe a

329+||| Find the first element of the vector that satisfies some test

330+||| @ p the test to satisfy

331+find : (p : a -> Bool) -> (xs : Vect n a) -> Maybe a

224332find p [] = Nothing

225333find p (x::xs) with (p x)

226334 | True = Just x

227335 | False = find p xs

228336

337+||| Find the index of the first element of the vector that satisfies some test

229338findIndex : (a -> Bool) -> Vect n a -> Maybe Nat

230339findIndex = findIndex' 0

231340 where

@@ -235,6 +344,7 @@ findIndex = findIndex' 0

235344 | True = Just cnt

236345 | False = findIndex' (S cnt) p xs

237346

347+||| Find the indices of all elements that satisfy some test

238348total findIndices : (a -> Bool) -> Vect m a -> (p ** Vect p Nat)

239349findIndices = findIndices' 0

240350 where

@@ -263,6 +373,7 @@ elemIndices = elemIndicesBy (==)

263373-- Filters

264374--------------------------------------------------------------------------------

265375

376+||| Find all elements of a vector that satisfy some test

266377total filter : (a -> Bool) -> Vect n a -> (p ** Vect p a)

267378filter p [] = ( _ ** [] )

268379filter p (x::xs) with (filter p xs)

@@ -272,6 +383,7 @@ filter p (x::xs) with (filter p xs)

272383 else

273384 (_ ** tail)

274385

386+||| Make the elements of some vector unique by some test

275387nubBy : (a -> a -> Bool) -> Vect n a -> (p ** Vect p a)

276388nubBy = nubBy' []

277389 where

@@ -282,6 +394,7 @@ nubBy = nubBy' []

282394 | False with (nubBy' (x::acc) p xs)

283395 | (_ ** tail) = (_ ** x::tail)

284396

397+||| Make the elements of some vector unique by the default Boolean equality

285398nub : Eq a => Vect n a -> (p ** Vect p a)

286399nub = nubBy (==)

287400

@@ -289,6 +402,14 @@ nub = nubBy (==)

289402-- Splitting and breaking lists

290403--------------------------------------------------------------------------------

291404

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+

292413--------------------------------------------------------------------------------

293414-- Predicates

294415--------------------------------------------------------------------------------

@@ -339,6 +460,31 @@ range : Vect n (Fin n)

339460range {n=Z} = []

340461range {n=S _} = fZ :: map fS range

341462

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+

342488--------------------------------------------------------------------------------

343489-- Proofs

344490--------------------------------------------------------------------------------

@@ -349,14 +495,9 @@ Prelude.Vect.drop_lemma_1 = proof {

349495 trivial;

350496}

351497

352−Prelude.Vect.reverse'_lemma_2 = proof {

353− intros;

354− rewrite (plusSuccRightSucc m n1);

355− exact value;

356−}

357−

358498Prelude.Vect.reverse'_lemma_1 = proof {

359499 intros;

500+ rewrite prf;

360501 rewrite sym (plusZeroRightNeutral m);

361502 exact value;

362503}

libs/prelude/prelude.ipkg+1−1

@@ -8,7 +8,7 @@ modules = Builtins, Prelude, IO,

88 Prelude.Maybe, Prelude.Monad, Prelude.Applicative, Prelude.Either,

99 Prelude.Vect, Prelude.Strings, Prelude.Chars, Prelude.Functor,

1010 Prelude.Foldable, Prelude.Traversable, Prelude.Bits, Prelude.Stream,

11− Prelude.Uninhabited,

11+ Prelude.Uninhabited, Prelude.Pairs,

1212

1313 Decidable.Equality

1414

main/Main.hs+10−60

@@ -24,6 +24,7 @@ import Idris.ElabDecls

2424import Idris.Primitives

2525import Idris.Imports

2626import Idris.Error

27+import Idris.CmdOptions

2728

2829import IRTS.System ( getLibFlags, getIdrisLibDir, getIncFlags )

2930

@@ -36,8 +37,7 @@ import Paths_idris

3637-- Main program reads command line options, parses the main program, and gets

3738-- on with the REPL.

3839

39−main = do xs <- getArgs

40− let opts = parseArgs xs

40+main = do opts <- runArgParser

4141 result <- runErrorT $ execStateT (runIdris opts) idrisInit

4242 case result of

4343 Left err -> putStrLn $ "Uncaught error: " ++ show err

@@ -48,8 +48,6 @@ runIdris [Client c] = do setVerbose False

4848 setQuiet True

4949 runIO $ runClient c

5050runIdris opts = do

51− when (Ver `elem` opts) $ runIO showver

52− when (Usage `elem` opts) $ runIO usage

5351 when (ShowIncs `elem` opts) $ runIO showIncs

5452 when (ShowLibs `elem` opts) $ runIO showLibs

5553 when (ShowLibdir `elem` opts) $ runIO showLibdir

@@ -61,6 +59,14 @@ runIdris opts = do

6159 [] -> return ()

6260 fs -> do runIO $ mapM_ cleanPkg fs

6361 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

6470 case opt getPkg opts of

6571 [] -> case opt getPkgREPL opts of

6672 [] -> idrisMain opts

@@ -68,9 +74,6 @@ runIdris opts = do

6874 _ -> ifail "Too many packages"

6975 fs -> runIO $ mapM_ (buildPkg (WarnOnly `elem` opts)) fs

7076

71−usage = do putStrLn usagemsg

72− exitWith ExitSuccess

73−

7477showver = do putStrLn $ "Idris version " ++ ver

7578 exitWith ExitSuccess

7679

@@ -85,56 +88,3 @@ showLibdir = do dir <- getIdrisLibDir

8588showIncs = do incFlags <- getIncFlags

8689 putStrLn incFlags

8790 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

33OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_bitstring.o \

44 idris_opts.o idris_stats.o mini-gmp.o

55HDRS = 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

77CFLAGS:=-fPIC $(CFLAGS)

8−CFLAGS += $(GMP_INCLUDE_DIR) $(GMP)

8+CFLAGS += $(GMP_INCLUDE_DIR) $(GMP) -DIDRIS_TARGET_OS="\"$(OS)\""

9+CFLAGS += -DIDRIS_TARGET_TRIPLE="\"$(MACHINE)\""

910

1011ifeq ($(OS), windows)

1112 OBJS += windows/idris_stdfgn.o windows/idris_net.o

12− HDRS += windows/idris_stdfgn.h windows/idris_net.h

1313else

1414 OBJS += idris_stdfgn.o idris_net.o

15− HDRS += idris_stdfgn.h idris_net.h

1615endif

1716

1817LIBTARGET = libidris_rts.a

rts/idris_net.c+11−1

@@ -1,9 +1,19 @@

11// C-Side of the Idris network library

22// (C) Simon Fowler, 2014

33// 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>

513#include <arpa/inet.h>

614

15+#include "idris_net.h"

16+

717void* idrnet_malloc(int size) {

818 return malloc(size);

919}

rts/idris_net.h−10

@@ -1,16 +1,6 @@

11#ifndef IDRISNET_H

22#define IDRISNET_H

33

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−

144typedef struct idrnet_recv_result {

155 int result;

166 void* payload;

rts/idris_rts.c+25−3

@@ -38,9 +38,18 @@ VM* init_vm(int stack_size, size_t heap_size,

3838 vm->inbox_ptr = vm->inbox;

3939 vm->inbox_write = vm->inbox;

4040

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+

4150 pthread_mutex_init(&(vm->inbox_lock), NULL);

4251 pthread_mutex_init(&(vm->inbox_block), NULL);

43− pthread_mutex_init(&(vm->alloc_lock), NULL);

52+ pthread_mutex_init(&(vm->alloc_lock), &rec_attr);

4453 pthread_cond_init(&(vm->inbox_waiting), NULL);

4554

4655 vm->max_threads = max_threads;

@@ -75,7 +84,7 @@ void idris_requireAlloc(VM* vm, size_t size) {

7584 }

7685#ifdef HAS_PTHREAD

7786 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

7988 pthread_mutex_lock(&vm->alloc_lock);

8089 }

8190#endif

@@ -84,7 +93,7 @@ void idris_requireAlloc(VM* vm, size_t size) {

8493void idris_doneAlloc(VM* vm) {

8594#ifdef HAS_PTHREAD

8695 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

8897 pthread_mutex_unlock(&vm->alloc_lock);

8998 }

9099#endif

@@ -508,6 +517,19 @@ VAL idris_strRev(VM* vm, VAL str) {

508517 return cl;

509518}

510519

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+

511533VAL MKBUFFERc(VM* vm, Buffer* buf) {

512534 Closure* cl = allocate(vm, sizeof(Closure) + sizeof *buf + buf->cap, 1);

513535 SETTY(cl, BUFFER);

rts/idris_rts.h+6

@@ -283,6 +283,12 @@ VAL idris_peekB64Native(VM* vm, VAL buf, VAL off);

283283VAL idris_peekB64LE(VM* vm, VAL buf, VAL off);

284284VAL idris_peekB64BE(VM* vm, VAL buf, VAL off);

285285

286+// system infox

287+// used indices:

288+// 0 returns backend

289+// 1 returns OS

290+VAL idris_systemInfo(VM* vm, VAL index);

291+

286292// Command line args

287293

288294extern int __idris_argc;

rts/windows/idris_net.c+15−4

@@ -1,7 +1,7 @@

11// C-Side of the Idris network library

22// (C) Simon Fowler, 2014

33// MIT Licensed. Have fun!

4−#include "idris_net.h"

4+#include "../idris_net.h"

55

66#include <errno.h>

77#include <stdbool.h>

@@ -11,6 +11,12 @@

1111#include <Winsock2.h>

1212#include <Ws2tcpip.h>

1313

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+

1420static int socket_inited = 0;

1521static WSADATA wsa_data;

1622

@@ -22,12 +28,17 @@ void idrnet_free(void* ptr) {

2228 free(ptr);

2329}

2430

25−static int check_init()

31+static void clean_sockets(void) {

32+ WSACleanup();

33+}

34+

35+static int check_init(void)

2636{

2737 if (!socket_inited) {

2838 int result = WSAStartup(MAKEWORD(2, 2), &wsa_data);

2939 if (result == NO_ERROR) {

3040 socket_inited = 1;

41+ atexit(clean_sockets);

3142 }

3243 }

3344 return socket_inited;

@@ -104,7 +115,7 @@ int idrnet_sockaddr_family(void* sockaddr) {

104115char* idrnet_sockaddr_ipv4(void* sockaddr) {

105116 struct sockaddr_in* addr = (struct sockaddr_in*) sockaddr;

106117 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);

108119 return ip_addr;

109120}

110121

@@ -139,7 +150,7 @@ int idrnet_send_buf(int sockfd, void* data, int len) {

139150

140151void* idrnet_recv(int sockfd, int len) {

141152 if (!check_init()) {

142− return -1;

153+ return NULL;

143154 }

144155 idrnet_recv_result* res_struct =

145156 (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"

22#include "../idris_rts.h"

3+#include "../idris_gc.h"

4+

35#include <fcntl.h>

46#include <stdio.h>

7+#include <time.h>

58

69extern char** environ;

710

@@ -61,3 +64,12 @@ void* idris_stdin() {

6164char* getEnvPair(int i) {

6265 return *(environ + i);

6366}

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

22

33import Language.Reflection

44

5−-- | The reflected term for (\ x => reverse "bba")

5+||| The reflected term for (\ x => reverse "bba")

66reflectVal : TT

77reflectVal = ?valPrf

88

9−-- | intEq for the integers 3 and 3

9+||| intEq for the integers 3 and 3

1010applyTac1 : Int

1111applyTac1 = ?tacPrf1

1212

13−-- | intEq for the integers 3 and 42

13+||| intEq for the integers 3 and 42

1414applyTac0 : Int

1515applyTac0 = ?tacPrf0

1616

17−-- | intEq for the two arguments

17+||| intEq for the two arguments

1818applyTacDyn : Int -> Int -> Int

1919applyTacDyn x y = ?tacPrfDyn

2020

21−-- | Restored version for RConstant (I 42)

21+||| Restored version for RConstant (I 42)

2222fill : Int

2323fill = ?fillPrf

2424

25−-- | The type (TTName, TT) computed from its reflected raw rep.

25+||| The type (TTName, TT) computed from its reflected raw rep.

2626envTuple : Type

2727envTuple = ?envTuplePrf

2828

29−-- | The type List (TTName, TT) computed from its reflected raw rep.

29+||| The type List (TTName, TT) computed from its reflected raw rep.

3030envList : List (TTName, TT)

3131envList = ?envListPrf

3232

33−-- | Reflected raw rep. for the type (TTName, TT)

33+||| Reflected raw rep. for the type (TTName, TT)

3434tupleType : Raw

3535tupleType = RApp (RApp (Var (MN 0 "__Pair"))

3636 (Var (NS (UN "TTName") ["Reflection", "Language"])))

3737 (Var (NS (UN "TT") ["Reflection", "Language"]))

3838

39−-- | Reflected raw rep for the type List (TTName, TT)

39+||| Reflected raw rep for the type List (TTName, TT)

4040mkTuple : Raw

4141mkTuple = RApp (RApp (Var (MN 0 "__MkPair"))

4242 (Var (NS (UN "TTName") ["Reflection", "Language"])))

4343 (Var (NS (UN "TT") ["Reflection", "Language"]))

4444

45−-- | Reflected raw rep for Prelude.List.Nil

45+||| Reflected raw rep for Prelude.List.Nil

4646nil : Raw

4747nil = (Var (NS (UN "Nil") ["List", "Prelude"]))

4848

49−-- | Reflected raw rep for Prelude.List.::

49+||| Reflected raw rep for Prelude.List.::

5050cons : Raw

5151cons = (Var (NS (UN "::") ["List", "Prelude"]))

5252

53−-- | 1 if the two arguments are equal, 0 otherwise

54−-- This function is chosen as simple as possible for

55−-- demo purposes.

53+||| 1 if the two arguments are equal, 0 otherwise

54+||| This function is chosen as simple as possible for

55+||| demo purposes.

5656intEq : Int -> Int -> Int

5757intEq x y = case x == y of

5858 True => 1

5959 False => 0

6060

61−-- | A tactic script to run intEq on two let-bound or introduced

62−-- arguments of the current (otherwise empty) proof context

61+||| A tactic script to run intEq on two let-bound or introduced

62+||| arguments of the current (otherwise empty) proof context

6363firstEq : List (TTName, Binder TT) -> TT -> Tactic

6464firstEq ((_, (Let _ y))::(_, (Let _ x))::(_, Let _ f)::Nil) _ = Exact (App (App f x) y)

6565firstEq ((y, Lam yt)::(x, Lam xt)::(_, Let _ f)::Nil) _ = Exact (App (App f (P (Bound) x xt)) (P Bound y yt))

6666firstEq xs _ = Exact (TConst (I 0))

6767

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

70−-- will push dispatch, as first env agrument.

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

70+||| will push dispatch, as first env agrument.

7171innerTac : List (TTName, Binder TT) -> TT -> Tactic

7272innerTac (_::(x, Lam xt)::_) _ = Exact (P Bound x xt)

7373

74−-- | Returns the reflected representation of innerTac

74+||| Returns the reflected representation of innerTac

7575innerTacTT : TT

7676innerTacTT = ?innerTacTTPrf

7777

78−-- | Dispatch to the reflected rep. of innerTac

78+||| Dispatch to the reflected rep. of innerTac

7979dispatch : List (TTName, Binder TT) -> TT -> Tactic

8080dispatch xs _ = ApplyTactic (innerTacTT)

8181

82−-- | Call dispatch which will then dispatch to innerTac.

82+||| Call dispatch which will then dispatch to innerTac.

8383tacticalDispatch : Int -> Int

8484tacticalDispatch = ?tacticalDispatchPrf

8585

86−-- | A tactic to get the representation of its goal

86+||| A tactic to get the representation of its goal

8787studyGoalTac : List (TTName, Binder TT) -> TT -> Tactic

8888studyGoalTac _ goal = Reflect goal

8989

90−-- | Returns the representation of its goal, TT

91−-- (so this is reflect on the type TT)

90+||| Returns the representation of its goal, TT

91+||| (so this is reflect on the type TT)

9292studyGoal : TT

9393studyGoal = ?studyGoalPrf

9494

src/IRTS/CodegenC.hs+35−18

@@ -20,16 +20,32 @@ import System.Directory

2020import System.FilePath ((</>), (<.>))

2121import Control.Monad

2222

23−codegenC :: [(Name, SDecl)] ->

24− String -> -- output file name

25− OutputType -> -- generate executable if True, only .o if False

26− [FilePath] -> -- include files

27− String -> -- extra object files

28− String -> -- extra compiler flags (libraries)

29− String -> -- extra compiler flags (anything)

30− DbgLevel ->

31− IO ()

32−codegenC defs out exec incs objs libs flags dbg

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+

39+codegenC' :: [(Name, SDecl)] ->

40+ String -> -- output file name

41+ OutputType -> -- generate executable if True, only .o if False

42+ [FilePath] -> -- include files

43+ String -> -- extra object files

44+ String -> -- extra compiler flags (libraries)

45+ String -> -- extra compiler flags (anything)

46+ DbgLevel ->

47+ IO ()

48+codegenC' defs out exec incs objs libs flags dbg

3349 = do -- print defs

3450 let bc = map toBC defs

3551 let h = concatMap toDecl (map fst bc)

@@ -46,7 +62,6 @@ codegenC defs out exec incs objs libs flags dbg

4662 hPutStr tmph cout

4763 hFlush tmph

4864 hClose tmph

49− let useclang = False

5065 comp <- getCC

5166 libFlags <- getLibFlags

5267 incFlags <- getIncFlags

@@ -132,10 +147,10 @@ bcc i (ASSIGNCONST l c)

132147 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

133148 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

134149 mkConst (Str s) = "MKSTR(vm, " ++ showCStr s ++ ")"

135− mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"

136− mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"

137− mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"

138− mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")"

150+ mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ "U)"

151+ mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ "U)"

152+ mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ "UL)"

153+ mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ "ULL)"

139154 mkConst _ = "MKINT(42424242)"

140155bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

141156bcc i (MKCON l tag args)

@@ -159,15 +174,15 @@ bcc i (CASE True r code def)

159174 | length code < 4 = showCase i def code

160175 where

161176 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 ++

163178 indent i ++ "}\n"

164179

165180 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String

166181 showCase i Nothing [(t, c)] = showCode i c

167182 showCase i (Just def) [] = showCode i def

168183 showCase i def ((t, c) : cs)

169− = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c

170− ++ "else " ++ showCase i def cs

184+ = indent i ++ "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c

185+ ++ indent i ++ "else " ++ showCase i def cs

171186

172187bcc i (CASE safe r code def)

173188 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++

@@ -478,6 +493,8 @@ doOp v (LChInt ITNative) args = v ++ creg (last args)

478493doOp v (LChInt ITChar) args = doOp v (LChInt ITNative) args

479494doOp v (LIntCh ITNative) args = v ++ creg (last args)

480495doOp v (LIntCh ITChar) args = doOp v (LIntCh ITNative) args

496+

497+doOp v LSystemInfo [x] = v ++ "idris_systemInfo(vm, " ++ creg x ++ ")"

481498doOp v LNoOp args = v ++ creg (last args)

482499doOp _ op _ = "FAIL /* " ++ show op ++ " */"

483500

src/IRTS/CodegenCommon.hs+25

@@ -2,8 +2,11 @@ module IRTS.CodegenCommon where

22

33import Idris.Core.TT

44import IRTS.Simplified

5+import IRTS.Defunctionalise

6+import IRTS.Lang

57

68import Control.Exception

9+import Data.Word

710import System.Environment

811

912data DbgLevel = NONE | DEBUG | TRACE deriving Eq

@@ -13,3 +16,25 @@ environment :: String -> IO (Maybe String)

1316environment x = Control.Exception.catch (do e <- getEnv x

1417 return (Just e))

1518 (\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

3434

3535-----------------------------------------------------------------------

3636-- Main function

37−codegenJava :: [(Name, SExp)] -> -- initialization of globals

38− [(Name, SDecl)] -> -- decls

39− FilePath -> -- output file name

40− [String] -> -- headers

41− [String] -> -- libs

42− OutputType ->

43− IO ()

44−codegenJava globalInit defs out hdrs libs exec =

37+codegenJava :: CodeGenerator

38+codegenJava cg = codegenJava' [] (simpleDecls cg) (outputFile cg)

39+ (includes cg) (compileLibs cg)

40+ (outputType cg)

41+

42+codegenJava' :: [(Name, SExp)] -> -- initialization of globals

43+ [(Name, SDecl)] -> -- decls

44+ FilePath -> -- output file name

45+ [String] -> -- headers

46+ [String] -> -- libs

47+ OutputType ->

48+ IO ()

49+codegenJava' globalInit defs out hdrs libs exec =

4550 withTgtDir exec out (codegenJava' exec)

4651 where

4752 codegenJava' :: OutputType -> FilePath -> IO ()

src/IRTS/CodegenJavaScript.hs+731−112

@@ -1,6 +1,6 @@

11{-# LANGUAGE PatternGuards #-}

22

3−module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where

3+module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where

44

55import Idris.AbsSyntax hiding (TypeCase)

66import IRTS.Bytecode

@@ -17,9 +17,11 @@ import Data.Char

1717import Numeric

1818import Data.List

1919import Data.Maybe

20+import Data.Word

2021import System.IO

2122import System.Directory

2223

24+

2325idrNamespace :: String

2426idrNamespace = "__IDR__"

2527idrRTNamespace = "__IDRRT__"

@@ -52,6 +54,20 @@ data JSNum = JSInt Int

5254 deriving Eq

5355

5456

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+

5571data JS = JSRaw String

5672 | JSIdent String

5773 | JSFunction [String] JS

@@ -73,6 +89,7 @@ data JS = JSRaw String

7389 | JSArray [JS]

7490 | JSString String

7591 | JSNum JSNum

92+ | JSWord JSWord

7693 | JSAssign JS JS

7794 | JSAlloc String (Maybe JS)

7895 | JSIndex JS JS

@@ -80,13 +97,56 @@ data JS = JSRaw String

8097 | JSTernary JS JS JS

8198 | JSParens JS

8299 | JSWhile JS JS

100+ | JSFFI String [JS]

101+ | JSAnnotation JSAnnotation JS

83102 | JSNoop

84103 deriving Eq

85104

86105

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+

87141compileJS :: JS -> String

88142compileJS JSNoop = ""

89143

144+compileJS (JSAnnotation annotation js) =

145+ "/** @" ++ show annotation ++ " */\n" ++ compileJS js

146+

147+compileJS (JSFFI raw args) =

148+ ffi raw (map compileJS args)

149+

90150compileJS (JSRaw code) =

91151 code

92152

@@ -206,6 +266,13 @@ compileJS (JSWhile cond body) =

206266 ++ compileJS body

207267 ++ "\n}"

208268

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+

209276jsTailcall :: JS -> JS

210277jsTailcall call =

211278 jsCall (idrRTNamespace ++ "tailcall") [

@@ -229,6 +296,8 @@ jsInstanceOf = JSBinOp "instanceof"

229296jsEq :: JS -> JS -> JS

230297jsEq = JSBinOp "=="

231298

299+jsNotEq :: JS -> JS -> JS

300+jsNotEq = JSBinOp "!="

232301

233302jsAnd :: JS -> JS -> JS

234303jsAnd = JSBinOp "&&"

@@ -276,6 +345,28 @@ jsLet name value body =

276345jsError :: String -> JS

277346jsError err = JSApp (JSFunction [] (JSError err)) []

278347

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+

279370

280371foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a

281372foldJS tr add acc js =

@@ -316,6 +407,10 @@ foldJS tr add acc js =

316407 add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds

317408 | JSWhile cond body <- js =

318409 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

319414 | otherwise =

320415 tr js

321416

@@ -342,7 +437,9 @@ transformJS tr js =

342437 | JSCond conds <- js = JSCond $ map (tr *** tr) conds

343438 | JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)

344439 | 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)

346443 | otherwise = js

347444

348445

@@ -350,6 +447,9 @@ moveJSDeclToTop :: String -> [JS] -> [JS]

350447moveJSDeclToTop decl js = move ([], js)

351448 where

352449 move :: ([JS], [JS]) -> [JS]

450+ move (front, js@(JSAnnotation _ (JSAlloc name _)):back)

451+ | name == decl = js : front ++ back

452+

353453 move (front, js@(JSAlloc name _):back)

354454 | name == decl = js : front ++ back

355455

@@ -519,8 +619,6 @@ removeEval js =

519619 match (JSApp (JSIdent "__IDR__mEVAL0") [val]) = val

520620 match js = transformJS match js

521621

522− removeEvalApp js = js

523−

524622 checkEval :: [JS] -> ([JS], Bool)

525623 checkEval js = foldr f ([], False) $ map checkEval' js

526624 where

@@ -644,33 +742,56 @@ removeIDs js =

644742 JSReturn (JSApp (JSIdent fun) args)

645743 )])

646744 | Just pos <- lookup fun ids

647− , pos < length args = args !! pos

745+ , pos < length args = removeIDCall ids (args !! pos)

648746

649747 removeIDCall ids (JSNew _ [JSFunction [] (

650748 JSReturn (JSApp (JSIdent fun) args)

651749 )])

652750 | Just pos <- lookup fun ids

653− , pos < length args = args !! pos

751+ , pos < length args = removeIDCall ids (args !! pos)

654752

655753 removeIDCall ids js@(JSApp id@(JSIdent fun) args)

656754 | Just pos <- lookup fun ids

657− , pos < length args = args !! pos

755+ , pos < length args = removeIDCall ids (args !! pos)

658756

659757 removeIDCall ids js = transformJS (removeIDCall ids) js

660758

661759

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+

662783inlineFunctions :: [JS] -> [JS]

663784inlineFunctions js =

664785 inlineHelper ([], js)

665786 where

666787 inlineHelper :: ([JS], [JS]) -> [JS]

667− inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)

788+ inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)

668789 | countAll fun front + countAll fun back == 0 =

669790 inlineHelper (front, back)

670791 | Just new <- inlineAble (

671792 countAll fun front + countAll fun back

672793 ) fun args body =

673− let f = map (inline fun args new) in

794+ let f = map (inlineFunction fun args new) in

674795 inlineHelper (f front, f back)

675796

676797 inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)

@@ -687,29 +808,6 @@ inlineFunctions js =

687808 inlineAble _ _ _ _ = Nothing

688809

689810

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−

713811 nonRecur :: String -> JS -> Bool

714812 nonRecur name body = countInvokations name body == 0

715813

@@ -1012,7 +1110,7 @@ unfoldLookupTable input =

10121110 adaptCon js =

10131111 adaptCon' [] js

10141112 where

1015− adaptCon' front ((JSAlloc "__IDRRT__Con" (Just _)):back) =

1113+ adaptCon' front ((JSAnnotation _ (JSAlloc "__IDRRT__Con" _)):back) =

10161114 front ++ (new:back)

10171115

10181116 adaptCon' front (next:back) =

@@ -1022,11 +1120,12 @@ unfoldLookupTable input =

10221120

10231121

10241122 new =

1025− JSAlloc "__IDRRT__Con" (Just $

1026− JSFunction newArgs (

1027− JSSeq (map newVar newArgs)

1123+ JSAnnotation JSConstructor $

1124+ JSAlloc "__IDRRT__Con" (Just $

1125+ JSFunction newArgs (

1126+ JSSeq (map newVar newArgs)

1127+ )

10281128 )

1029− )

10301129 where

10311130 newVar var = JSAssign (JSProj JSThis var) (JSIdent var)

10321131 newArgs = ["tag", "eval", "app", "vars"]

@@ -1095,7 +1194,7 @@ unfoldLookupTable input =

10951194

10961195removeInstanceChecks :: JS -> JS

10971196removeInstanceChecks (JSCond conds) =

1098− JSCond $ eliminateDeadBranches $ map (

1197+ removeNoopConds $ JSCond $ eliminateDeadBranches $ map (

10991198 removeHelper *** removeInstanceChecks

11001199 ) conds

11011200 where

@@ -1110,6 +1209,11 @@ removeInstanceChecks (JSCond conds) =

11101209 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs

11111210 eliminateDeadBranches [] = []

11121211

1212+

1213+ removeNoopConds :: JS -> JS

1214+ removeNoopConds (JSCond [(JSNoop, js)]) = js

1215+ removeNoopConds js = js

1216+

11131217removeInstanceChecks js = transformJS removeInstanceChecks js

11141218

11151219

@@ -1314,6 +1418,67 @@ evalCons js =

13141418 match js = transformJS match js

13151419

13161420

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+

13171482getGlobalCons :: JS -> [(String, JS)]

13181483getGlobalCons js = foldJS match (++) [] js

13191484 where

@@ -1330,15 +1495,23 @@ getGlobalCons js = foldJS match (++) [] js

13301495getIncludes :: [FilePath] -> IO [String]

13311496getIncludes = mapM readFile

13321497

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

13341507 :: JSTarget

13351508 -> [(Name, SDecl)]

13361509 -> [FilePath]

13371510 -> FilePath

13381511 -> OutputType

13391512 -> IO ()

1340−codegenJavaScript target definitions includes filename outputType = do

1341− let (header, runtime) = case target of

1513+codegenJS_all target definitions includes filename outputType = do

1514+ let (header, rt) = case target of

13421515 Node ->

13431516 ("#!/usr/bin/env node\n", "-node")

13441517 JavaScript ->

@@ -1346,13 +1519,10 @@ codegenJavaScript target definitions includes filename outputType = do

13461519 included <- getIncludes includes

13471520 path <- (++) <$> getDataDir <*> (pure "/jsrts/")

13481521 idrRuntime <- readFile $ path ++ "Runtime-common.js"

1349− tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]

1522+ tgtRuntime <- readFile $ concat [path, "Runtime", rt, ".js"]

13501523 jsbn <- readFile $ path ++ "jsbn/jsbn.js"

13511524 writeFile filename $ header ++ (

1352− intercalate "\n" $ included ++ [ jsbn

1353− , idrRuntime

1354− , tgtRuntime

1355− ] ++ functions

1525+ intercalate "\n" $ included ++ runtime jsbn idrRuntime tgtRuntime ++ functions

13561526 )

13571527

13581528 setPermissions filename (emptyPermissions { readable = True

@@ -1364,15 +1534,33 @@ codegenJavaScript target definitions includes filename outputType = do

13641534 def = map (first translateNamespace) definitions

13651535

13661536

1367− functions :: [String]

1368− functions = translate >>> optimize >>> compile $ def

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]

1558+ optimized = translate >>> optimize $ def

13691559 where

13701560 translate p =

13711561 prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]

13721562 optimize p =

13731563 foldl' (flip ($)) p opt

1374− compile =

1375− map compileJS

13761564

13771565 opt =

13781566 [ removeEval

@@ -1392,39 +1580,59 @@ codegenJavaScript target definitions includes filename outputType = do

13921580 , extractLocalConstructors

13931581 , unfoldLookupTable

13941582 , evalCons

1583+ , elimConds

1584+ , removeUselessCons

13951585 ]

13961586

1587+ functions :: [String]

1588+ functions = map compileJS optimized

1589+

13971590 prelude :: [JS]

13981591 prelude =

1399− [ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (

1400− JSAssign (JSProj JSThis "k") (JSIdent "k")

1401− ))

1402− , JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (

1403− JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")

1404− , JSAssign (JSProj JSThis "vars") (JSIdent "vars")

1405− ]

1406− ))

1592+ [ JSAnnotation JSConstructor $

1593+ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (

1594+ JSAssign (JSProj JSThis "k") (JSIdent "k")

1595+ ))

1596+ , JSAnnotation JSConstructor $

1597+ JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (

1598+ JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")

1599+ , JSAssign (JSProj JSThis "vars") (JSIdent "vars")

1600+ ]

1601+ ))

14071602 ]

14081603

14091604 mainLoop :: JS

14101605 mainLoop =

1411− JSAlloc "main" $ Just $ JSFunction [] (

1412− case target of

1413− Node -> mainFun

1414− JavaScript -> JSCond [(isReady, mainFun), (JSTrue, jsMeth (JSIdent "window") "addEventListener" [

1415− JSString "DOMContentLoaded", JSFunction [] (

1416− mainFun

1417− ), JSFalse

1418− ])]

1606+ JSAlloc "main" $ Just $ JSFunction [] (

1607+ case target of

1608+ Node -> mainFun

1609+ JavaScript -> JSCond [ (exists document `jsAnd` isReady, mainFun)

1610+ , (exists window, windowMainFun)

1611+ , (JSTrue, mainFun)

1612+ ]

14191613 )

14201614 where

1615+ exists :: JS -> JS

1616+ exists js = (JSPreOp "typeof " js) `jsNotEq` JSString "undefined"

1617+

14211618 mainFun :: JS

14221619 mainFun = jsTailcall $ jsCall runMain []

14231620

1621+ window :: JS

1622+ window = JSIdent "window"

14241623

1425− isReady :: JS

1426− isReady = readyState `jsEq` JSString "complete" `jsOr` readyState `jsEq` JSString "loaded"

1624+ document :: JS

1625+ document = JSIdent "document"

14271626

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"

14281636

14291637 readyState :: JS

14301638 readyState = JSProj (JSIdent "document") "readyState"

@@ -1542,6 +1750,10 @@ translateConstant (AType (ATInt ITChar)) = JSType JSCharTy

15421750translateConstant PtrType = JSType JSPtrTy

15431751translateConstant Forgot = JSType JSForgotTy

15441752translateConstant (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)

15451757translateConstant c =

15461758 jsError $ "Unimplemented Constant: " ++ show c

15471759

@@ -1718,6 +1930,10 @@ translateExpression (SApp tc name vars)

17181930translateExpression (SOp op vars)

17191931 | LNoOp <- op = JSVar (last vars)

17201932

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+

17211937 | (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]

17221938 | (LPlus (ATInt ITBig)) <- op

17231939 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]

@@ -1759,6 +1975,435 @@ translateExpression (SOp op vars)

17591975 | (LSGe ATFloat) <- op

17601976 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs

17611977

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+

17622407 | (LPlus _) <- op

17632408 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

17642409 | (LMinus _) <- op

@@ -1793,7 +2438,7 @@ translateExpression (SOp op vars)

17932438 , (arg:_) <- vars = JSPreOp "~" (JSVar arg)

17942439

17952440 | LStrConcat <- op

1796− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

2441+ , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]

17972442 | LStrEq <- op

17982443 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs

17992444 | LStrLt <- op

@@ -1822,9 +2467,9 @@ translateExpression (SOp op vars)

18222467 | (LFloatInt ITNative) <- op

18232468 , (arg:_) <- vars = JSVar arg

18242469 | (LChInt ITNative) <- op

1825− , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"

2470+ , (arg:_) <- vars = jsCall "__IDRRT__charCode" [JSVar arg]

18262471 | (LIntCh ITNative) <- op

1827− , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]

2472+ , (arg:_) <- vars = jsCall "__IDRRT__fromCharCode" [JSVar arg]

18282473

18292474 | LFExp <- op

18302475 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]

@@ -1850,7 +2495,7 @@ translateExpression (SOp op vars)

18502495 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]

18512496

18522497 | LStrCons <- op

1853− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

2498+ , (lhs:rhs:_) <- vars = invokeMeth lhs "concat" [rhs]

18542499 | LStrHead <- op

18552500 , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))

18562501 | LStrRev <- op

@@ -1863,12 +2508,14 @@ translateExpression (SOp op vars)

18632508 JSNum (JSInt 1),

18642509 JSBinOp "-" (JSProj (JSIdent v) "length") (JSNum (JSInt 1))

18652510 ]

2511+ | LSystemInfo <- op

2512+ , (arg:_) <- vars = jsCall "__IDRRT__systemInfo" [JSVar arg]

18662513 | LNullPtr <- op

18672514 , (_) <- vars = JSNull

18682515

18692516 where

18702517 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)

18722519

18732520

18742521 invokeMeth :: LVar -> String -> [LVar] -> JS

@@ -1886,17 +2533,24 @@ translateExpression (SForeign _ _ "isNull" [(FPtr, var)]) =

18862533translateExpression (SForeign _ _ "idris_eqPtr" [(FPtr, lhs),(FPtr, rhs)]) =

18872534 JSBinOp "==" (JSVar lhs) (JSVar rhs)

18882535

2536+translateExpression (SForeign _ _ "idris_time" []) =

2537+ JSRaw "(new Date()).getTime()"

2538+

18892539translateExpression (SForeign _ _ fun args) =

1890− ffi fun (map generateWrapper args)

2540+ JSFFI fun (map generateWrapper args)

18912541 where

18922542 generateWrapper (ffunc, name)

18932543 | FFunction <- ffunc =

1894− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"

2544+ JSApp (

2545+ JSIdent $ idrRTNamespace ++ "ffiWrap"

2546+ ) [JSIdent $ translateVariableName name]

18952547 | FFunctionIO <- ffunc =

1896− idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"

2548+ JSApp (

2549+ JSIdent $ idrRTNamespace ++ "ffiWrap"

2550+ ) [JSIdent $ translateVariableName name]

18972551

18982552 generateWrapper (_, name) =

1899− translateVariableName name

2553+ JSIdent $ translateVariableName name

19002554

19012555translateExpression patterncase

19022556 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"

@@ -1939,41 +2593,6 @@ translateExpression e =

19392593 jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)

19402594

19412595

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−

19772596data CaseType = ConCase Int

19782597 | TypeCase JSType

19792598 | DefaultCase

src/IRTS/CodegenLLVM.hs+13−8

@@ -58,14 +58,19 @@ import Debug.Trace

5858

5959data Target = Target { triple :: String, dataLayout :: DataLayout }

6060

61−codegenLLVM :: [(TT.Name, SDecl)] ->

62− String -> -- target triple

63− String -> -- target CPU

64− Word -> -- Optimization degree

65− FilePath -> -- output file name

66− OutputType ->

67− IO ()

68−codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do

61+codegenLLVM :: CodeGenerator

62+codegenLLVM ci = codegenLLVM' (simpleDecls ci) (targetTriple ci)

63+ (targetCPU ci) (optimisation ci)

64+ (outputFile ci) (outputType ci)

65+

66+codegenLLVM' :: [(TT.Name, SDecl)] ->

67+ String -> -- target triple

68+ String -> -- target CPU

69+ Word -> -- Optimization degree

70+ FilePath -> -- output file name

71+ OutputType ->

72+ IO ()

73+codegenLLVM' defs triple cpu optimize file outty = withContext $ \context -> do

6974 initializeAllTargets

7075 (target, _) <- failInIO $ lookupTarget Nothing triple

7176 withTargetOptions $ \options ->

src/IRTS/Compiler.hs+522−324

@@ -18,15 +18,29 @@ import Util.LLVMStubs

1818import IRTS.Inliner

1919

2020import Idris.AbsSyntax

21−import Idris.UnusedArgs

21+import Idris.AbsSyntaxTree

22+import Idris.ASTUtils

23+import Idris.Erasure

2224import Idris.Error

2325

26+import Debug.Trace

27+

2428import Idris.Core.TT

2529import Idris.Core.Evaluate

2630import Idris.Core.CaseTree

2731

32+import Control.Category

33+import Prelude hiding (id, (.))

34+

35+import Control.Applicative

2836import Control.Monad.State

37+import Data.Maybe

2938import 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

3044import System.Process

3145import System.IO

3246import System.Directory

@@ -37,18 +51,17 @@ import Paths_idris

3751

3852compile :: Codegen -> FilePath -> Term -> Idris ()

3953compile codegen f tm

40− = do checkMVs

41− let tmnames = namesUsed (STerm tm)

42− usedIn <- mapM (allNames []) tmnames

43− let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn

44− defsIn <- mkDecls tm (concat used)

45− findUnusedArgs (concat used)

54+ = do checkMVs -- check for undefined metavariables

55+ checkTotality -- refuse to compile if there are totality problems

56+ reachableNames <- performUsageAnalysis

4657 maindef <- irMain tm

58+ iLOG $ "MAIN: " ++ show maindef

4759 objs <- getObjectFiles codegen

4860 libs <- getLibs codegen

4961 flags <- getFlags codegen

5062 hdrs <- getHdrs codegen

5163 impdirs <- allImportDirs

64+ defsIn <- mkDecls tm reachableNames

5265 let defs = defsIn ++ [(sMN 0 "runMain", maindef)]

5366 -- iputStrLn $ showSep "\n" (map show defs)

5467 let (nexttag, tagged) = addTags 65536 (liftAll defs)

@@ -71,67 +84,79 @@ compile codegen f tm

7184 case dumpDefun of

7285 Nothing -> return ()

7386 Just f -> runIO $ writeFile f (dumpDefuns defuns)

74− triple <- targetTriple

75− cpu <- targetCPU

76− optimize <- optLevel

87+ triple <- Idris.AbsSyntax.targetTriple

88+ cpu <- Idris.AbsSyntax.targetCPU

89+ optimise <- optLevel

7790 iLOG "Building output"

91+

7892 case checked of

79− OK c -> runIO $ case codegen of

80− ViaC ->

81− codegenC c f outty hdrs

82− (concatMap mkObj objs)

83− (concatMap mkLib libs)

84− (concatMap mkFlag flags ++

85− concatMap incdir impdirs) NONE

86− ViaJava ->

87− codegenJava [] c f hdrs libs outty

88− ViaJavaScript ->

89− codegenJavaScript JavaScript c hdrs f outty

90− ViaNode ->

91− codegenJavaScript Node c hdrs f outty

92− ViaLLVM -> codegenLLVM c triple cpu optimize f outty

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

97+ runIO $ case codegen of

98+ ViaC -> codegenC cginfo

99+ ViaJava -> codegenJava cginfo

100+ ViaJavaScript -> codegenJavaScript cginfo

101+ ViaNode -> codegenNode cginfo

102+ ViaLLVM -> codegenLLVM cginfo

93103 Bytecode -> dumpBC c f

94104 Error e -> ierror e

95105 where checkMVs = do i <- getIState

96106 case map fst (idris_metavars i) \\ primDefs of

97107 [] -> return ()

98108 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

99113 inDir d h = do let f = d </> h

100114 ex <- doesFileExist f

101115 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−

108116

109117irMain :: TT Name -> Idris LDecl

110−irMain tm = do i <- ir tm

111− return $ LFun [] (sMN 0 "runMain") [] (LForce i)

118+irMain tm = do

119+ i <- irTerm M.empty [] tm

120+ return $ LFun [] (sMN 0 "runMain") [] (LForce i)

112121

113122mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]

114123mkDecls t used

115124 = do i <- getIState

116− let ds = filter (\ (n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)

117− mapM traceUnused used

125+ let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)

118126 decls <- mapM build ds

119127 return decls

120128

121129showCaseTrees :: [(Name, LDecl)] -> String

122−showCaseTrees ds = showSep "\n\n" (map showCT ds)

130+showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)

123131 where

124132 showCT (n, LFun _ f args lexp)

125− = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t "

133+ = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t"

126134 ++ show lexp

127135 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a

128136

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+

129157isCon (TyDecl _ _) = True

130158isCon _ = False

131159

132−class ToIR a where

133− ir :: a -> Idris LExp

134−

135160build :: (Name, Def) -> Idris (Name, LDecl)

136161build (n, d)

137162 = do i <- getIState

@@ -144,295 +169,468 @@ build (n, d)

144169 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def

145170 return (n, def)

146171

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−

155172declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x

156173declArgs args inl n x = LFun (if inl then [Inline] else []) n args x

157174

158−mkLDecl n (Function tm _) = do e <- ir tm

159− return (declArgs [] True n e)

175+mkLDecl n (Function tm _)

176+ = declArgs [] True n <$> irTerm M.empty [] tm

177+

160178mkLDecl 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)

164−mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a

179+ = declArgs [] (case_inlinable ci) n <$> irTree args sc

180+ where

181+ (args, sc) = cases_runtime cd

182+

183+mkLDecl n (TyDecl (DCon tag arity) _) =

184+ LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)

185+

165186mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a

166−mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n)))

167−

168−instance ToIR (TT Name) where

169− ir tm = ir' [] tm where

170− ir' env tm@(App f a)

171− | (P _ (UN m) _, args) <- unApply tm,

172− m == txt "mkForeignPrim"

173− = doForeign env args

174− | (P _ (UN u) _, [_, arg]) <- unApply tm,

175− u == txt "unsafePerformPrimIO"

176− = ir' env arg

177− -- TMP HACK - until we get inlining.

178− | (P _ (UN r) _, [_, _, _, _, _, arg]) <- unApply tm,

179− r == txt "replace"

180− = ir' env arg

181− -- Laziness, the old way

182− | (P _ (UN l) _, [_, arg]) <- unApply tm,

183− l == txt "lazy"

184− = do arg' <- ir' env arg

185− error "lazy has crept in somehow"

186−-- return $ LLazyExp arg'

187− | (P _ (UN l) _, [_, arg]) <- unApply tm,

188− l == txt "force"

189− = do arg' <- ir' env arg

190− return $ LForce arg'

191− -- Laziness, the new way

192− | (P _ (UN l) _, [arg]) <- unApply tm,

193− l == txt "Delay"

194− = do arg' <- ir' env arg

195− return $ LLazyExp arg'

196− | (P _ (UN l) _, [_, arg]) <- unApply tm,

197− l == txt "Force"

198− = do arg' <- ir' env arg

199− return $ LForce arg'

200− | (P _ (UN a) _, [_, _, arg]) <- unApply tm,

201− a == txt "assert_smaller"

202− = ir' env arg

203− | (P _ (UN a) _, [_, arg]) <- unApply tm,

204− a == txt "assert_total"

205− = ir' env arg

206− | (P _ (UN p) _, [_, arg]) <- unApply tm,

207− p == txt "par"

208− = do arg' <- ir' env arg

209− return $ LOp LPar [LLazyExp arg']

210− | (P _ (UN pf) _, [arg]) <- unApply tm,

211− pf == txt "prim_fork"

212− = do arg' <- ir' env arg

213− return $ LOp LFork [LLazyExp arg']

214− | (P _ (UN m) _, [_,size,t]) <- unApply tm,

215− m == txt "malloc"

216− = do size' <- ir' env size

217− t' <- ir' env t

218− return t' -- TODO $ malloc_ size' t'

219− | (P _ (UN tm) _, [_,t]) <- unApply tm,

220− tm == txt "trace_malloc"

221− = do t' <- ir' env t

222− return t' -- TODO

223− -- This case is here until we get more general inlining. It's just

224− -- a really common case, and the laziness hurts...

225− | (P _ (NS (UN be) [b,p]) _, [_,x,(App (P _ (UN d) _) t),

226− (App (P _ (UN d') _) e)]) <- unApply tm,

227− be == txt "boolElim" && d == txt "Delay" && d' == txt "Delay"

228− = do x' <- ir' env x

229− t' <- ir' env t

230− e' <- ir' env e

231− return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e',

232− LConCase 1 (sNS (sUN "True") ["Bool","Prelude"]) [] t'])

233− | (P (DCon t a) n _, args) <- unApply tm

234− = irCon env t a n args

235− | (P (TCon t a) n _, args) <- unApply tm

236− = return LNothing

237− | (P _ n _, args) <- unApply tm

238− = do i <- getIState

239− args' <- mapM (ir' env) args

240− case getPrim i n args' of

241− Just tm -> return tm

242− _ -> do

243− let collapse

244− = case lookupCtxtExact n

245− (idris_optimisation i) of

246− Just oi -> collapsible oi

247− _ -> False

248− let unused

249− = case lookupCtxtExact n

250− (idris_callgraph i) of

251− Just (CGInfo _ _ _ _ unusedpos) ->

252− unusedpos

253− _ -> []

254− if collapse

255− then return LNothing

256− else return (LApp False (LV (Glob n))

257− (mkUnused unused 0 args'))

258− | (f, args) <- unApply tm

259− = do f' <- ir' env f

260− args' <- mapM (ir' env) args

261− return (LApp False f' args')

262− where mkUnused u i [] = []

263− mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs

264− | otherwise = x : mkUnused u (i + 1) xs

265−-- ir' env (P _ (NS (UN "Z") ["Nat", "Prelude"]) _)

266−-- = return $ LConst (BI 0)

267− ir' env (P _ n _) = return $ LV (Glob n)

268− ir' env (V i) | i >= 0 && i < length env = return $ LV (Glob (env!!i))

269− | otherwise = ifail $ "IR fail " ++ show i ++ " " ++ show tm

270− ir' env (Bind n (Lam _) sc)

271− = do let n' = uniqueName n env

272− sc' <- ir' (n' : env) sc

273− return $ LLam [n'] sc'

274− ir' env (Bind n (Let _ v) sc)

275− = do sc' <- ir' (n : env) sc

276− v' <- ir' env v

277− return $ LLet n v' sc'

278− ir' env (Bind _ _ _) = return $ LNothing

279− ir' env (Proj t i) | i == -1

280− = do t' <- ir' env t

281− return $ LOp (LMinus (ATInt ITBig))

282− [t', LConst (BI 1)]

283− ir' env (Proj t i) = do t' <- ir' env t

284− return $ LProj t' i

285− ir' env (Constant c) = return $ LConst c

286− ir' env (TType _) = return $ LNothing

287− ir' env Erased = return $ LNothing

288− ir' env Impossible = return $ LNothing

289−-- ir' env _ = return $ LError "Impossible"

290−

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

305− doForeign env (_ : fgn : args)

306− | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn

307− = let maybeTys = getFTypes fgnArgTys

308− rty = mkIty' ret in

309− case maybeTys of

310− Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)

311− Just tys -> do

312− args' <- mapM (ir' 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')

317− | otherwise = ifail "Badly formed foreign function call"

318−

319−getFTypes :: TT Name -> Maybe [FType]

320−getFTypes tm = case unApply tm of

321− (nil, []) -> Just []

322− (cons, [ty, xs]) ->

323− fmap (mkIty' ty :) (getFTypes xs)

324− _ -> Nothing

325−

326−mkIty' (P _ (UN ty) _) = mkIty (str ty)

327−mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))

328− | fi == txt "FIntT" = mkIntIty (str intTy)

329−mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))

330− | ff == txt "FFunction" && fa == txt "FAny" &&

331− io == txt "IO"

187+mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run

188+

189+data VarInfo = VI

190+ { viMethod :: Maybe Name

191+ }

192+ deriving Show

193+

194+type Vars = M.Map Name VarInfo

195+

196+irTerm :: Vars -> [Name] -> Term -> Idris LExp

197+irTerm vs env tm@(App f a) = case unApply tm of

198+ (P _ (UN m) _, args)

199+ | m == txt "mkForeignPrim"

200+ -> doForeign vs env args

201+

202+ (P _ (UN u) _, [_, arg])

203+ | u == txt "unsafePerformPrimIO"

204+ -> irTerm vs env arg

205+

206+ -- TMP HACK - until we get inlining.

207+ (P _ (UN r) _, [_, _, _, _, _, arg])

208+ | r == txt "replace"

209+ -> irTerm vs env arg

210+

211+ -- Laziness, the old way

212+ (P _ (UN l) _, [_, arg])

213+ | l == txt "lazy"

214+ -> error "lazy has crept in somehow"

215+

216+ (P _ (UN l) _, [_, arg])

217+ | l == txt "force"

218+ -> LForce <$> irTerm vs env arg

219+

220+ -- Laziness, the new way

221+ (P _ (UN l) _, [_, _, arg])

222+ | l == txt "Delay"

223+ -> LLazyExp <$> irTerm vs env arg

224+

225+ (P _ (UN l) _, [_, _, arg])

226+ | l == txt "Force"

227+ -> LForce <$> irTerm vs env arg

228+

229+ (P _ (UN a) _, [_, _, _, arg])

230+ | a == txt "assert_smaller"

231+ -> irTerm vs env arg

232+

233+ (P _ (UN a) _, [_, arg])

234+ | a == txt "assert_total"

235+ -> irTerm vs env arg

236+

237+ (P _ (UN p) _, [_, arg])

238+ | p == txt "par"

239+ -> do arg' <- irTerm vs env arg

240+ return $ LOp LPar [LLazyExp arg']

241+

242+ (P _ (UN pf) _, [arg])

243+ | pf == txt "prim_fork"

244+ -> do arg' <- irTerm vs env arg

245+ return $ LOp LFork [LLazyExp arg']

246+

247+ (P _ (UN m) _, [_,size,t])

248+ | m == txt "malloc"

249+ -> irTerm vs env t

250+

251+ (P _ (UN tm) _, [_,t])

252+ | tm == txt "trace_malloc"

253+ -> irTerm vs env t -- TODO

254+

255+ -- This case is here until we get more general inlining. It's just

256+ -- a really common case, and the laziness hurts...

257+ (P _ (NS (UN be) [b,p]) _, [_,x,(App (App (App (P _ (UN d) _) _) _) t),

258+ (App (App (App (P _ (UN d') _) _) _) e)])

259+ | be == txt "boolElim"

260+ , d == txt "Delay"

261+ , d' == txt "Delay"

262+ -> do

263+ x' <- irTerm vs env x

264+ t' <- irTerm vs env t

265+ e' <- irTerm vs env e

266+ return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'

267+ ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'

268+ ])

269+

270+ -- data constructor

271+ (P (DCon t arity) n _, args) -> do

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

328+ (P (TCon t a) n _, args) -> return LNothing

329+

330+ -- a name applied to arguments

331+ (P _ n _, args) -> do

332+ ist <- getIState

333+ case lookup n (idris_scprims ist) of

334+ -- if it's a primitive that is already saturated,

335+ -- compile to the corresponding op here already to save work

336+ Just (arity, op) | length args == arity

337+ -> LOp op <$> mapM (irTerm vs env) args

338+

339+ -- otherwise, just apply the name

340+ _ -> applyName n ist args

341+

342+ -- turn de bruijn vars into regular named references and try again

343+ (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args

344+

345+ (f, args)

346+ -> LApp False

347+ <$> irTerm vs env f

348+ <*> mapM (irTerm vs env) args

349+

350+ where

351+ buildApp :: LExp -> [Term] -> Idris LExp

352+ buildApp e [] = return e

353+ buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs

354+

355+ applyToNames :: LExp -> [Name] -> LExp

356+ applyToNames tm [] = tm

357+ applyToNames tm ns = LApp False tm $ map (LV . Glob) ns

358+

359+ padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp

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+

390+irTerm vs env (P _ n _) = return $ LV (Glob n)

391+irTerm vs env (V i)

392+ | i >= 0 && i < length env = return $ LV (Glob (env!!i))

393+ | otherwise = ifail $ "bad de bruijn index: " ++ show i

394+

395+irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc

396+ where

397+ n' = uniqueName n env

398+

399+irTerm vs env (Bind n (Let _ v) sc)

400+ = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc

401+

402+irTerm vs env (Bind _ _ _) = return $ LNothing

403+

404+irTerm vs env (Proj t (-1)) = do

405+ t' <- irTerm vs env t

406+ return $ LOp (LMinus (ATInt ITBig))

407+ [t', LConst (BI 1)]

408+

409+irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i

410+irTerm vs env (Constant c) = return $ LConst c

411+irTerm vs env (TType _) = return $ LNothing

412+irTerm vs env Erased = return $ LNothing

413+irTerm vs env Impossible = return $ LNothing

414+

415+doForeign :: Vars -> [Name] -> [TT Name] -> Idris LExp

416+doForeign vs env (_ : fgn : args)

417+ | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn

418+ = case getFTypes fgnArgTys of

419+ Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)

420+ Just tys -> do

421+ args' <- mapM (irTerm vs env) (init args)

422+ return $ LForeign LANG_C (mkIty' ret) fgnName (zip tys args')

423+

424+ | otherwise = ifail "Badly formed foreign function call"

425+ where

426+ getFTypes :: TT Name -> Maybe [FType]

427+ getFTypes tm = case unApply tm of

428+ -- nil : {a : Type} -> List a

429+ (nil, [_]) -> Just []

430+ -- cons : {a : Type} -> a -> List a -> List a

431+ (cons, [_, ty, xs]) -> (mkIty' ty :) <$> getFTypes xs

432+ _ -> Nothing

433+

434+ mkIty' (P _ (UN ty) _) = mkIty (str ty)

435+ mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))

436+ | fi == txt "FIntT"

437+ = mkIntIty (str intTy)

438+

439+ mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))

440+ | ff == txt "FFunction"

441+ , fa == txt "FAny"

442+ , io == txt "IO"

332443 = 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

438444

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)

195195 (DApp False n (map (DV . Glob) (take i (genArgs 0))))))))

196196 : [] -- mkApplyCase n 0 i

197197 | otherwise = []

198− where dupdate tlarg x = x

198+ where dupdate tlarg x = DUpdate tlarg x

199199

200200toConsA :: [(Name, Int)] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]

201201toConsA ns (n, i)

src/IRTS/Lang.hs+58−31

@@ -55,6 +55,8 @@ data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy

5555 -- Buffers

5656 | LAllocate

5757 | LAppendBuffer

58+ -- system info

59+ | LSystemInfo

5860 -- Note that for Bits8 only Native endianness is actually used

5961 -- and the user-exposed interface for Bits8 doesn't mention

6062 -- endianness

@@ -213,36 +215,61 @@ usedIn env (LOp f args) = concatMap (usedIn env) args

213215usedIn env _ = []

214216

215217instance Show LExp where

216− show e = show' [] e where

217− show' env (LV (Loc i)) = env!!i

218− show' env (LV (Glob n)) = show n

219− show' env (LLazyApp e args) = show e ++ "|(" ++

220− showSep ", " (map (show' env) args) ++")"

221− show' env (LApp _ e args) = show' env e ++ "(" ++

222− showSep ", " (map (show' env) args) ++")"

223− show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"

224− show' env (LForce e) = "%force(" ++ show' env e ++ ")"

225− show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++

226− show' (env ++ [show n]) e

227− show' env (LLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++

228− show' (env ++ (map show args)) e

229− show' env (LProj t i) = show t ++ "!" ++ show i

230− show' env (LCon i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"

231− show' env (LCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++

232− showSep "\n\t| " (map (showAlt env) alts)

233− show' env (LConst c) = show c

234− show' env (LForeign lang ty n args)

235− = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"

236− show' env (LOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"

237− show' env (LError str) = "error " ++ show str

238− show' env LNothing = "____"

239−

240− showAlt env (LConCase _ n args e)

218+ show e = show' [] "" e where

219+ show' env ind (LV (Loc i)) = env!!i

220+ show' env ind (LV (Glob n)) = show n

221+

222+ show' env ind (LLazyApp e args)

223+ = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")"

224+

225+ show' env ind (LApp _ e args)

226+ = show' env ind e ++ "(" ++ showSep ", " (map (show' env ind) args) ++")"

227+

228+ show' env ind (LLazyExp e) = "lazy{ " ++ show' env ind e ++ " }"

229+ show' env ind (LForce e) = "force{ " ++ show' env ind e ++ " }"

230+ show' env ind (LLet n v e)

231+ = "let " ++ show n ++ " = " ++ show' env ind v

232+ ++ " in " ++ show' (env ++ [show n]) ind e

233+

234+ show' env ind (LLam args e)

235+ = "\\ " ++ showSep "," (map show args)

236+ ++ " => " ++ show' (env ++ (map show args)) ind e

237+

238+ show' env ind (LProj t i) = show t ++ "!" ++ show i

239+

240+ show' env ind (LCon i n args)

241+ = show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

242+

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)

250+ = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ". ") alt

251+ ++ "\n" ++ fmt as

252+

253+ show' env ind (LConst c) = show c

254+

255+ show' env ind (LForeign lang ty n args) = concat

256+ [ "foreign{ "

257+ , n ++ "("

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)

265+ = show f ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

266+

267+ show' env ind (LError str) = "error " ++ show str

268+ show' env ind LNothing = "____"

269+

270+ showAlt env ind (LConCase _ n args e)

241271 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "

242− ++ show' env e

243− showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e

244− showAlt env (LDefaultCase e) = "_ => " ++ show' env e

245−

246−

247−

272+ ++ show' env ind e

248273

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)

125125 return xs'

126126checkDefs ctxt ((n, DFun n' args exp) : xs)

127127 = 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)

129129 xs' <- checkDefs ctxt xs

130130 return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')

131131

132132lvar v = do i <- get

133133 put (max i v)

134134

135−scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp

136−scopecheck ctxt envTop tm = sc envTop tm where

135+scopecheck :: Name -> DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp

136+scopecheck fn ctxt envTop tm = sc envTop tm where

137+ failsc err = fail $ "Codegen error in " ++ show fn ++ ":" ++ err

138+

137139 sc env (SV (Glob n)) =

138140 case lookup n (reverse env) of -- most recent first

139141 Just i -> do lvar i; return (SV (Loc i))

@@ -141,20 +143,20 @@ scopecheck ctxt envTop tm = sc envTop tm where

141143 Just (DConstructor _ i ar) ->

142144 if True -- ar == 0

143145 then return (SCon i n [])

144− else fail $ "Codegen error: Constructor " ++ show n ++

146+ else failsc $ "Constructor " ++ show n ++

145147 " has arity " ++ show ar

146148 Just _ -> return (SV (Glob n))

147− Nothing -> fail $ "Codegen error: No such variable " ++ show n

149+ Nothing -> failsc $ "No such variable " ++ show n

148150 sc env (SApp tc f args)

149151 = do args' <- mapM (scVar env) args

150152 case lookupCtxtExact f ctxt of

151153 Just (DConstructor n tag ar) ->

152154 if True -- (ar == length args)

153155 then return $ SCon tag n args'

154− else fail $ "Codegen error: Constructor " ++ show f ++

156+ else failsc $ "Constructor " ++ show f ++

155157 " has arity " ++ show ar

156158 Just _ -> return $ SApp tc f args'

157− Nothing -> fail $ "Codegen error: No such variable " ++ show f

159+ Nothing -> failsc $ "No such variable " ++ show f

158160 sc env (SForeign l ty f args)

159161 = do args' <- mapM (\ (t, a) -> do a' <- scVar env a

160162 return (t, a')) args

@@ -165,9 +167,9 @@ scopecheck ctxt envTop tm = sc envTop tm where

165167 Just (DConstructor n tag ar) ->

166168 if True -- (ar == length args)

167169 then return $ SCon tag n args'

168− else fail $ "Codegen error: Constructor " ++ show f ++

169− " has arity " ++ show ar

170− _ -> fail $ "Codegen error: No such constructor " ++ show f

170+ else failsc $ "Constructor " ++ show f ++

171+ " has arity " ++ show ar

172+ _ -> failsc $ "No such constructor " ++ show f

171173 sc env (SProj e i)

172174 = do e' <- scVar env e

173175 return (SProj e' i)

@@ -200,9 +202,9 @@ scopecheck ctxt envTop tm = sc envTop tm where

200202 Just i -> do lvar i; return (Loc i)

201203 Nothing -> case lookupCtxtExact n ctxt of

202204 Just (DConstructor _ i ar) ->

203− fail $ "Codegen error : can't pass constructor here"

205+ failsc $ "can't pass constructor here"

204206 Just _ -> return (Glob n)

205− Nothing -> fail $ "Codegen error: No such variable " ++ show n ++

207+ Nothing -> failsc $ "No such variable " ++ show n ++

206208 " in " ++ show tm ++ " " ++ show envTop

207209 scVar _ x = return x

208210

@@ -212,9 +214,9 @@ scopecheck ctxt envTop tm = sc envTop tm where

212214 Just (DConstructor _ i ar) ->

213215 if True -- (length args == ar)

214216 then return i

215− else fail $ "Codegen error: Constructor " ++ show n ++

217+ else failsc $ "Constructor " ++ show n ++

216218 " has arity " ++ show ar

217− _ -> fail $ "Codegen error: No constructor " ++ show n

219+ _ -> failsc $ "No constructor " ++ show n

218220 e' <- sc env' e

219221 return (SConCase (length env) tag n args e')

220222 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(..))

99import Idris.Core.Typecheck

1010import Idris.AbsSyntaxTree

1111import Idris.Colours

12−import Idris.IdeSlave

12+import Idris.Docstrings

13+import Idris.IdeSlave hiding (Opt(..))

1314import IRTS.CodegenCommon

1415import Util.DynamicLinker

1516

@@ -87,6 +88,10 @@ addDyLib libs = do i <- getIState

8788addHdr :: Codegen -> String -> Idris ()

8889addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i }

8990

91+addImported :: FilePath -> Idris ()

92+addImported f = do i <- getIState

93+ putIState $ i { idris_imported = nub $ f : idris_imported i }

94+

9095addLangExt :: LanguageExt -> Idris ()

9196addLangExt TypeProviders = do i <- getIState

9297 putIState $ i {

@@ -262,10 +267,10 @@ addCoercion :: Name -> Idris ()

262267addCoercion n = do i <- getIState

263268 putIState $ i { idris_coercions = nub $ n : idris_coercions i }

264269

265−addDocStr :: Name -> String -> Idris ()

266−addDocStr n doc

270+addDocStr :: Name -> Docstring -> [(Name, Docstring)] -> Idris ()

271+addDocStr n doc args

267272 = 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) }

269274

270275addNameHint :: Name -> Name -> Idris ()

271276addNameHint ty n

@@ -273,7 +278,7 @@ addNameHint ty n

273278 ty' <- case lookupCtxtName ty (idris_implicits i) of

274279 [(tyn, _)] -> return tyn

275280 [] -> throwError (NoSuchVariable ty)

276− tyns -> throwError (CantResolveAlts (map show (map fst tyns)))

281+ tyns -> throwError (CantResolveAlts (map fst tyns))

277282 let ns' = case lookupCtxt ty' (idris_namehints i) of

278283 [ns] -> ns ++ [n]

279284 _ -> [n]

@@ -356,15 +361,18 @@ addNameIdx' i n

356361getHdrs :: Codegen -> Idris [String]

357362getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

358363

359−setErrLine :: Int -> Idris ()

360−setErrLine x = do i <- getIState;

361− case (errLine i) of

362− Nothing -> putIState $ i { errLine = Just x }

364+getImported :: Idris [FilePath]

365+getImported = do i <- getIState; return (idris_imported i)

366+

367+setErrSpan :: FC -> Idris ()

368+setErrSpan x = do i <- getIState;

369+ case (errSpan i) of

370+ Nothing -> putIState $ i { errSpan = Just x }

363371 Just _ -> return ()

364372

365373clearErr :: Idris ()

366374clearErr = do i <- getIState

367− putIState $ i { errLine = Nothing }

375+ putIState $ i { errSpan = Nothing }

368376

369377getSO :: Idris (Maybe String)

370378getSO = do i <- getIState

@@ -380,6 +388,16 @@ getIState = get

380388putIState :: IState -> Idris ()

381389putIState = put

382390

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+

383401-- | A version of liftIO that puts errors into the exception type of the Idris monad

384402runIO :: IO a -> Idris a

385403runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return

@@ -391,6 +409,8 @@ getName = do i <- getIState;

391409 putIState $ (i { idris_name = idx + 1 })

392410 return idx

393411

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

394414addInternalApp :: FilePath -> Int -> PTerm -> Idris ()

395415addInternalApp fp l t

396416 = do i <- getIState

@@ -487,6 +507,12 @@ getUndefined :: Idris [Name]

487507getUndefined = do i <- getIState

488508 return (map fst (idris_metavars i) \\ primDefs)

489509

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+

490516getWidth :: Idris ConsoleWidth

491517getWidth = fmap idris_consolewidth getIState

492518

@@ -502,153 +528,27 @@ renderWidth = do iw <- getWidth

502528 AutomaticWidth -> runIO getScreenWidth

503529

504530

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

584531

585532type1Doc :: Doc OutputAnnotation

586−type1Doc = (annotate AnnConstType $ text "Type 1")

587−

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

533+type1Doc = (annotate (AnnType "Type" "The type of types, one level up") $ text "Type 1")

534+

635535

636536isetPrompt :: String -> Idris ()

637537isetPrompt p = do i <- getIState

638538 case idris_outputmode i of

639539 IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n

640540

641−ihWarn :: Handle -> FC -> Doc OutputAnnotation -> Idris ()

642−ihWarn h fc err = do i <- getIState

643− err' <- iRender . fmap (fancifyAnnots i) $ err

644− case idris_outputmode i of

645− RawOutput ->

646− runIO $

647− hPutStrLn h (show fc ++ ":" ++ displayDecorated (consoleDecorate i) err')

648− IdeSlave n ->

649− do let (str, spans) = displaySpans err'

650− runIO . hPutStrLn h $

651− convSExp "warning" (fc_fname fc, fc_line fc, fc_column fc, str, spans) n

541+-- | Tell clients how much was parsed and loaded

542+isetLoadedRegion :: Idris ()

543+isetLoadedRegion = do i <- getIState

544+ let span = idris_parsedSpan i

545+ case span of

546+ Just fc ->

547+ case idris_outputmode i of

548+ IdeSlave n ->

549+ runIO . putStrLn $

550+ convSExp "set-loaded-region" fc n

551+ Nothing -> return ()

652552

653553setLogLevel :: Int -> Idris ()

654554setLogLevel l = do i <- getIState

@@ -713,6 +613,12 @@ setShowOrigErr b = do i <- getIState

713613 let opt' = opts { opt_origerr = b }

714614 putIState $ i { idris_options = opt' }

715615

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+

716622setNoBanner :: Bool -> Idris ()

717623setNoBanner n = do i <- getIState

718624 let opts = idris_options i

@@ -872,13 +778,14 @@ setColour :: ColourType -> IdrisColour -> Idris ()

872778setColour ct c = do i <- getIState

873779 let newTheme = setColour' ct c (idris_colourTheme i)

874780 putIState $ i { idris_colourTheme = newTheme }

875− where setColour' KeywordColour c t = t { keywordColour = c }

876− setColour' BoundVarColour c t = t { boundVarColour = c }

877− setColour' ImplicitColour c t = t { implicitColour = c }

878− setColour' FunctionColour c t = t { functionColour = c }

879− setColour' TypeColour c t = t { typeColour = c }

880− setColour' DataColour c t = t { dataColour = c }

881− setColour' PromptColour c t = t { promptColour = c }

781+ where setColour' KeywordColour c t = t { keywordColour = c }

782+ setColour' BoundVarColour c t = t { boundVarColour = c }

783+ setColour' ImplicitColour c t = t { implicitColour = c }

784+ setColour' FunctionColour c t = t { functionColour = c }

785+ setColour' TypeColour c t = t { typeColour = c }

786+ setColour' DataColour c t = t { dataColour = c }

787+ setColour' PromptColour c t = t { promptColour = c }

788+ setColour' PostulateColour c t = t { postulateColour = c }

882789

883790logLvl :: Int -> String -> Idris ()

884791logLvl l str = do i <- getIState

@@ -899,7 +806,7 @@ iLOG = logLvl 1

899806

900807noErrors :: Idris Bool

901808noErrors = do i <- getIState

902− case errLine i of

809+ case errSpan i of

903810 Nothing -> return True

904811 _ -> return False

905812

@@ -935,9 +842,9 @@ expandParams dec ps ns infs tm = en tm

935842 | otherwise = PLam n (en t) (en s)

936843 en (PPi p n t s)

937844 | n `elem` (map fst ps ++ ns)

938− = let n' = mkShadow n in

939− PPi p n' (en t) (en (shadow n n' s))

940− | otherwise = PPi p n (en t) (en s)

845+ = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp?

846+ PPi (enTacImp p) n' (en t) (en (shadow n n' s))

847+ | otherwise = PPi (enTacImp p) n (en t) (en s)

941848 en (PLet n ty v s)

942849 | n `elem` (map fst ps ++ ns)

943850 = let n' = mkShadow n in

@@ -996,15 +903,18 @@ expandParams dec ps ns infs tm = en tm

996903

997904 nseq x y = nsroot x == nsroot y

998905

906+ enTacImp (TacImp aos st scr) = TacImp aos st (en scr)

907+ enTacImp other = other

908+

999909expandParamsD :: Bool -> -- True = RHS only

1000910 IState ->

1001911 (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)

1003913 = if n `elem` ns && (not rhsonly)

1004914 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))

1006916 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)

1008918expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty)

1009919 = if n `elem` ns && (not rhsonly)

1010920 then -- trace (show (n, expandParams dec ps ns ty)) $

@@ -1040,7 +950,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

1040950 updateps yn nm [] = []

1041951 updateps yn nm (((a, t), i):as)

1042952 | (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

1044954

1045955 removeBound lhs ns = ns \\ nub (bnames lhs)

1046956

@@ -1050,8 +960,9 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

1050960 bnames (PDPair _ _ l Placeholder r) = bnames l ++ bnames r

1051961 bnames _ = []

1052962

1053−expandParamsD rhs ist dec ps ns (PData doc syn fc co pd)

1054− = PData doc syn fc co (expandPData pd)

963+-- | Expands parameters defined in parameter and where blocks inside of declarations

964+expandParamsD rhs ist dec ps ns (PData doc argDocs syn fc co pd)

965+ = PData doc argDocs syn fc co (expandPData pd)

1055966 where

1056967 -- just do the type decl, leave constructors alone (parameters will be

1057968 -- added implicitly)

@@ -1060,26 +971,27 @@ expandParamsD rhs ist dec ps ns (PData doc syn fc co pd)

1060971 then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))

1061972 (map econ cons)

1062973 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

1063− econ (doc, n, t, fc, fs)

1064− = (doc, dec n, piBindp impl ps (expandParams dec ps ns [] t), fc, fs)

1065−expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty cdoc cn cty)

1066− = if tn `elem` ns

974+ econ (doc, argDocs, n, t, fc, fs)

975+ = (doc, argDocs, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc, fs)

976+expandParamsD rhs ist dec ps ns (PRecord doc syn fc tn tty opts cdoc cn cty)

977+ = if tn `elem` ns

1067978 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

1069980 else PRecord doc syn fc (dec tn) (expandParams dec ps ns [] tty)

1070− cdoc (dec cn) conty

1071− where conty = piBindp impl ps (expandParams dec ps ns [] cty)

981+ opts cdoc (dec cn) conty

982+ where conty = piBindp expl ps (expandParams dec ps ns [] cty)

1072983expandParamsD rhs ist dec ps ns (PParams f params pds)

1073984 = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

1074985 (map (expandParamsD True ist dec ps ns) pds)

1075986-- (map (expandParamsD ist dec ps ns) pds)

1076987expandParamsD rhs ist dec ps ns (PMutual f pds)

1077988 = 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)

1079990 = PClass doc info f

1080991 (map (expandParams dec ps ns []) cs)

1081992 n

1082993 (map (mapsnd (expandParams dec ps ns [])) params)

994+ pDocs

1083995 (map (expandParamsD rhs ist dec ps ns) decls)

1084996expandParamsD rhs ist dec ps ns (PInstance info f cs n params ty cn decls)

1085997 = PInstance info f

@@ -1125,6 +1037,7 @@ getPriority i tm = 1 -- pri tm

11251037 pri Placeholder = 1

11261038 pri _ = 3

11271039

1040+

11281041addStatics :: Name -> Term -> PTerm -> Idris ()

11291042addStatics n tm ptm =

11301043 do let (statics, dynamics) = initStatics tm ptm

@@ -1158,8 +1071,8 @@ addStatics n tm ptm =

11581071 -- if a name appears in a type class or tactic implicit index, it doesn't

11591072 -- affect its 'uniquely inferrable' from a static status since these are

11601073 -- resolved by searching.

1161− searchArg (Constraint _ _ _) = True

1162− searchArg (TacImp _ _ _ _) = True

1074+ searchArg (Constraint _ _) = True

1075+ searchArg (TacImp _ _ _) = True

11631076 searchArg _ = False

11641077

11651078 staticList sts (Bind n (Pi _) sc) = (n `elem` sts) : staticList sts sc

@@ -1186,14 +1099,14 @@ addUsingConstraints syn fc t

11861099 -- if all of args in ns, then add it

11871100 doAdd (UConstraint c args : cs) ns t

11881101 | all (\n -> elem n ns) args

1189− = PPi (Constraint [] Dynamic "") (sMN 0 "cu")

1102+ = PPi (Constraint [] Dynamic) (sMN 0 "cu")

11901103 (mkConst c args) (doAdd cs ns t)

11911104 | otherwise = doAdd cs ns t

11921105

11931106 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)

11951108

1196− getConstraints (PPi (Constraint _ _ _) _ c sc)

1109+ getConstraints (PPi (Constraint _ _) _ c sc)

11971110 = getcapp c ++ getConstraints sc

11981111 getConstraints (PPi _ _ c sc) = getConstraints sc

11991112 getConstraints _ = []

@@ -1203,7 +1116,7 @@ addUsingConstraints syn fc t

12031116 return (UConstraint c ns)

12041117 getcapp _ = []

12051118

1206− getName (PExp _ _ (PRef _ n) _) = return n

1119+ getName (PExp _ _ _ (PRef _ n)) = return n

12071120 getName _ = []

12081121

12091122-- Add implicit Pi bindings for any names in the term which appear in an

@@ -1211,13 +1124,14 @@ addUsingConstraints syn fc t

12111124

12121125-- This has become a right mess already. Better redo it some time...

12131126

1214−implicit :: SyntaxInfo -> Name -> PTerm -> Idris PTerm

1215−implicit syn n ptm = implicit' syn [] n ptm

1127+implicit :: ElabInfo -> SyntaxInfo -> Name -> PTerm -> Idris PTerm

1128+implicit info syn n ptm = implicit' info syn [] n ptm

12161129

1217−implicit' :: SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1218−implicit' syn ignore n ptm

1130+implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1131+implicit' info syn ignore n ptm

12191132 = do i <- getIState

12201133 let (tm', impdata) = implicitise syn ignore i ptm

1134+ defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

12211135-- let (tm'', spos) = findStatics i tm'

12221136 putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

12231137 addIBC (IBCImp n)

@@ -1225,6 +1139,23 @@ implicit' syn ignore n ptm

12251139-- i <- get

12261140-- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

12271141 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

12281159

12291160implicitise :: SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg])

12301161implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

@@ -1249,38 +1180,44 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

12491180 | otherwise = x : dropAll xs ys

12501181 dropAll [] ys = []

12511182

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+

12521189 imps top env (PApp _ f as)

12531190 = do (decls, ns) <- get

12541191 let isn = concatMap (namesIn uvars ist) (map getTm as)

12551192 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1256− imps top env (PPi (Imp l _ doc _) n ty sc)

1257− = do let isn = nub (namesIn uvars ist ty) `dropAll` [n]

1193+ imps top env (PPi (Imp l _ _) n ty sc)

1194+ = do let isn = nub (implNamesIn uvars ty) `dropAll` [n]

12581195 (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,

12601197 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

12611198 imps True (n:env) sc

1262− imps top env (PPi (Exp l _ doc _) n ty sc)

1263− = do let isn = nub (namesIn uvars ist ty ++ case sc of

1199+ imps top env (PPi (Exp l _ _) n ty sc)

1200+ = do let isn = nub (implNamesIn uvars ty ++ case sc of

12641201 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

12651202 _ -> [])

12661203 (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,

12681205 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

12691206 imps True (n:env) sc

1270− imps top env (PPi (Constraint l _ doc) n ty sc)

1271− = do let isn = nub (namesIn uvars ist ty ++ case sc of

1207+ imps top env (PPi (Constraint l _) n ty sc)

1208+ = do let isn = nub (implNamesIn uvars ty ++ case sc of

12721209 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

12731210 _ -> [])

12741211 (decls, ns) <- get -- ignore decls in HO types

1275− put (PConstraint 10 l Placeholder doc : decls,

1212+ put (PConstraint 10 l n Placeholder : decls,

12761213 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

12771214 imps True (n:env) sc

1278− imps top env (PPi (TacImp l _ scr doc) n ty sc)

1279− = do let isn = nub (namesIn uvars ist ty ++ case sc of

1215+ imps top env (PPi (TacImp l _ scr) n ty sc)

1216+ = do let isn = nub (implNamesIn uvars ty ++ case sc of

12801217 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

12811218 _ -> [])

12821219 (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,

12841221 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

12851222 imps True (n:env) sc

12861223 imps top env (PEq _ l r)

@@ -1321,8 +1258,8 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

13211258 pibind using [] sc = sc

13221259 pibind using (n:ns) sc

13231260 = case lookup n using of

1324− Just ty -> PPi (Imp [] Dynamic "" False) n ty (pibind using ns sc)

1325− Nothing -> PPi (Imp [] Dynamic "" False) n Placeholder

1261+ Just ty -> PPi (Imp [] Dynamic False) n ty (pibind using ns sc)

1262+ Nothing -> PPi (Imp [] Dynamic False) n Placeholder

13261263 (pibind using ns sc)

13271264

13281265-- Add implicit arguments in function calls

@@ -1393,9 +1330,11 @@ addImpl' inpat env infns ist ptm

13931330 as' = map (fmap (ai env ds)) as in

13941331 mkPApp fc 1 f' as'

13951332 ai env ds (PCase fc c os)

1396− = let c' = ai env ds c

1397− os' = map (pmap (ai env ds)) os in

1398− PCase fc c' os'

1333+ = let c' = ai env ds c 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

1337+ PCase fc c' os

13991338 ai env ds (PLam n ty sc)

14001339 = let ty' = ai env ds ty

14011340 sc' = ai ((n, Just ty):env) ds sc in

@@ -1485,32 +1424,46 @@ aiFn inpat expat ist fc f ds as

14851424 [(n,t)] -> t

14861425 _ -> Public

14871426

1488−

14891427 insertImpl :: [PArg] -> [PArg] -> [PArg]

1490− insertImpl (PExp p l ty _ : ps) (PExp _ _ tm d : given) =

1491− PExp p l tm d : insertImpl ps given

1492− insertImpl (PConstraint p l ty _ : ps) (PConstraint _ _ tm d : given) =

1493− PConstraint p l tm d : insertImpl ps given

1494− insertImpl (PConstraint p l ty d : ps) given =

1495− PConstraint p l (PResolveTC fc) d : insertImpl ps given

1496− insertImpl (PImp p _ l n ty d : ps) given =

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]

1434+ insImpAcc pnas (PExp p l n ty : ps) (PExp _ _ _ tm : given) =

1435+ PExp p l n tm : insImpAcc (M.insert n tm pnas) ps given

1436+ insImpAcc pnas (PConstraint p l n ty : ps) (PConstraint _ _ _ tm : given) =

1437+ PConstraint p l n tm : insImpAcc (M.insert n tm pnas) ps given

1438+ insImpAcc pnas (PConstraint p l n ty : ps) given =

1439+ let rtc = PResolveTC fc in

1440+ PConstraint p l n rtc : insImpAcc (M.insert n rtc pnas) ps given

1441+ insImpAcc pnas (PImp p _ l n ty : ps) given =

14971442 case find n given [] of

1498− Just (tm, given') -> PImp p False l n tm "" : insertImpl ps given'

1499− Nothing -> PImp p True l n Placeholder "" : insertImpl ps given

1500− insertImpl (PTacImplicit p l n sc' ty d : ps) given =

1501− let sc = addImpl ist sc' in

1443+ Just (tm, given') ->

1444+ PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given'

1445+ Nothing ->

1446+ PImp p True l n Placeholder :

1447+ insImpAcc (M.insert n Placeholder pnas) ps given

1448+ insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given =

1449+ let sc = addImpl ist (substMatches (M.toList pnas) sc') in

15021450 case find n given [] of

1503− Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given'

1504− Nothing -> if inpat

1505− then PTacImplicit p l n sc Placeholder "" : insertImpl ps given

1506− else PTacImplicit p l n sc sc "" : insertImpl ps given

1507− insertImpl expected [] = []

1508− insertImpl _ given = given

1451+ Just (tm, given') ->

1452+ PTacImplicit p l n sc tm :

1453+ insImpAcc (M.insert n tm pnas) ps given'

1454+ Nothing ->

1455+ if inpat

1456+ then PTacImplicit p l n sc Placeholder :

1457+ insImpAcc (M.insert n Placeholder pnas) ps given

1458+ else PTacImplicit p l n sc sc :

1459+ insImpAcc (M.insert n sc pnas) ps given

1460+ insImpAcc _ expected [] = []

1461+ insImpAcc _ _ given = given

15091462

15101463 find n [] acc = Nothing

1511− find n (PImp _ _ _ n' t _ : gs) acc

1464+ find n (PImp _ _ _ n' t : gs) acc

15121465 | n == n' = Just (t, reverse acc ++ gs)

1513− find n (PTacImplicit _ _ n' _ t _ : gs) acc

1466+ find n (PTacImplicit _ _ n' _ t : gs) acc

15141467 | n == n' = Just (t, reverse acc ++ gs)

15151468 find n (g : gs) acc = find n gs (g : acc)

15161469

@@ -1537,19 +1490,19 @@ stripLinear i tm = evalState (sl tm) [] where

15371490 return (PPatvar fc f)

15381491 sl t@(PAlternative _ (a : as)) = do sl a

15391492 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

15411494 args' <- mapM slA args

1542− return $ PApp fc fn' args'

1543− where slA (PImp p m l n t d) = do t' <- sl t

1544− return $ PImp p m l n t' d

1545− slA (PExp p l t d) = do t' <- sl t

1546− return $ PExp p l t' d

1547− slA (PConstraint p l t d)

1495+ return $ PApp fc fn args'

1496+ where slA (PImp p m l n t) = do t' <- sl t

1497+ return $ PImp p m l n t'

1498+ slA (PExp p l n t) = do t' <- sl t

1499+ return $ PExp p l n t'

1500+ slA (PConstraint p l n t)

15481501 = do t' <- sl t

1549− return $ PConstraint p l t' d

1550− slA (PTacImplicit p l n sc t d)

1502+ return $ PConstraint p l n t'

1503+ slA (PTacImplicit p l n sc t)

15511504 = do t' <- sl t

1552− return $ PTacImplicit p l n sc t' d

1505+ return $ PTacImplicit p l n sc t'

15531506 sl x = return x

15541507

15551508-- 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

16491602 = do mf <- match' f f'

16501603 ms <- zipWithM matchArg args args'

16511604 return (mf ++ concat ms)

1652−-- match (PRef _ n) (PRef _ n') | n == n' = return []

1653−-- | otherwise = Nothing

16541605 match (PRef f n) (PApp _ x []) = match (PRef f n) x

16551606 match (PPatvar f n) xr = match (PRef f n) xr

16561607 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

16601611 (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i))

16611612 || tm == Placeholder)

16621613 = return [(n, tm)]

1663− | n == n' = return []

1614+ -- if one namespace is missing, drop the other

1615+ | n == n' || n == dropNS n' || dropNS n == n' = return []

1616+ where dropNS (NS n _) = n

1617+ dropNS n = n

16641618 match (PRef _ n) tm

16651619 | not names && (not (isConName n (tt_ctxt i) ||

16661620 isFnName n (tt_ctxt i)) || tm == Placeholder)

@@ -1803,6 +1757,12 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

18031757 mkUniqA arg = do t' <- mkUniq (getTm arg)

18041758 return (arg { getTm = t' })

18051759

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+

18061766 -- FIXME: Probably ought to do this for completeness! It's fine as

18071767 -- long as there are no bindings inside tactics though.

18081768 mkUniqT tac = return tac

@@ -1812,7 +1772,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

18121772 = do env <- get

18131773 (n', sc') <-

18141774 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)

18161777 return (n', shadow n n' sc)

18171778 else return (n, sc)

18181779 put (n' : env)

@@ -1823,7 +1784,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

18231784 = do env <- get

18241785 (n', sc') <-

18251786 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)

18271789 return (n', shadow n n' sc)

18281790 else return (n, sc)

18291791 put (n' : env)

@@ -1834,7 +1796,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

18341796 = do env <- get

18351797 (n', sc') <-

18361798 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)

18381801 return (n', shadow n n' sc)

18391802 else return (n, sc)

18401803 put (n' : env)

src/Idris/AbsSyntaxTree.hs+403−271

@@ -7,6 +7,7 @@ import Idris.Core.TT

77import Idris.Core.Evaluate

88import Idris.Core.Elaborate hiding (Tactic(..))

99import Idris.Core.Typecheck

10+import Idris.Docstrings

1011import IRTS.Lang

1112import IRTS.CodegenCommon

1213import Util.Pretty

@@ -30,11 +31,25 @@ import qualified Data.Map as M

3031import Data.Either

3132import qualified Data.Set as S

3233import Data.Word (Word)

34+import Data.Maybe (fromMaybe)

3335

3436import Debug.Trace

3537

3638import Text.PrettyPrint.Annotated.Leijen

3739

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+

3853data IOption = IOption { opt_logLevel :: Int,

3954 opt_typecase :: Bool,

4055 opt_typeintype :: Bool,

@@ -53,7 +68,8 @@ data IOption = IOption { opt_logLevel :: Int,

5368 opt_cpu :: String,

5469 opt_optLevel :: Word,

5570 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

5773 }

5874 deriving (Show, Eq)

5975

@@ -76,8 +92,31 @@ defaultOpts = IOption { opt_logLevel = 0

7692 , opt_optLevel = 2

7793 , opt_cmdline = []

7894 , opt_origerr = False

95+ , opt_autoSolve = True

7996 }

8097

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+

81120data LanguageExt = TypeProviders | ErrorReflection deriving (Show, Eq, Read, Ord)

82121

83122-- | The output mode in use

@@ -88,11 +127,6 @@ data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines sh

88127 | ColsWide Int -- ^ Manually specified - must be positive

89128 | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise

90129

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−

96130-- | The global state used in the Idris monad

97131data IState = IState {

98132 tt_ctxt :: Context, -- ^ All the currently defined names and their terms

@@ -111,10 +145,11 @@ data IState = IState {

111145 idris_flags :: Ctxt [FnOpt],

112146 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

113147 idris_calledgraph :: Ctxt [Name],

114− idris_docstrings :: Ctxt String,

148+ idris_docstrings :: Ctxt (Docstring, [(Name, Docstring)]),

115149 idris_tyinfodata :: Ctxt TIData,

116− idris_totcheck :: [(FC, Name)], -- names to check totality on

150+ idris_totcheck :: [(FC, Name)], -- names to check totality on

117151 idris_defertotcheck :: [(FC, Name)], -- names to check at the end

152+ idris_totcheckfail :: [(FC, String)],

118153 idris_options :: IOption,

119154 idris_name :: Int,

120155 idris_lineapps :: [((FilePath, Int), PTerm)],

@@ -131,12 +166,15 @@ data IState = IState {

131166 idris_libs :: [(Codegen, String)],

132167 idris_cgflags :: [(Codegen, String)],

133168 idris_hdrs :: [(Codegen, String)],

169+ idris_imported :: [FilePath], -- ^ Imported ibc file names

134170 proof_list :: [(Name, [String])],

135− errLine :: Maybe Int,

171+ errSpan :: Maybe FC,

136172 parserWarnings :: [(FC, Err)],

137173 lastParse :: Maybe Name,

138174 indent_stack :: [Int],

139175 brace_stack :: [Maybe Int],

176+ lastTokenSpan :: Maybe FC, -- ^ What was the span of the latest token parsed?

177+ idris_parsedSpan :: Maybe FC,

140178 hide_list :: [(Name, Maybe Accessibility)],

141179 default_access :: Accessibility,

142180 default_total :: Bool,

@@ -152,7 +190,10 @@ data IState = IState {

152190 idris_nameIdx :: (Int, Ctxt (Int, Name)),

153191 idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers

154192 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])

156197 }

157198

158199data SizeChange = Smaller | Same | Bigger | Unknown

@@ -163,12 +204,13 @@ deriving instance NFData SizeChange

163204!-}

164205

165206type SCGEntry = (Name, [Maybe (Int, SizeChange)])

207+type UsageReason = (Name, Int) -- fn_name, its_arg_number

166208

167209data CGInfo = CGInfo { argsdef :: [Name],

168210 calls :: [(Name, [[Name]])],

169211 scg :: [SCGEntry],

170212 argsused :: [Name],

171− unusedpos :: [Int] }

213+ usedpos :: [(Int, [UsageReason])] }

172214 deriving Show

173215{-!

174216deriving instance Binary CGInfo

@@ -212,6 +254,9 @@ data IBCWrite = IBCFix FixDecl

212254 | IBCLineApp FilePath Int PTerm

213255 | IBCErrorHandler Name

214256 | IBCFunctionErrorHandler Name Name Name

257+ | IBCPostulate Name

258+ | IBCTotCheckErr FC String

259+ | IBCParsedRegion FC

215260 deriving Show

216261

217262-- | The initial state for the compiler

@@ -220,10 +265,10 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

220265 emptyContext emptyContext emptyContext emptyContext

221266 emptyContext emptyContext emptyContext emptyContext

222267 emptyContext emptyContext

223− [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

224− [] Nothing [] Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

268+ [] [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

269+ [] [] Nothing [] Nothing [] [] Nothing Nothing [] Hidden False [] Nothing [] [] RawOutput

225270 True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty

226− AutomaticWidth

271+ AutomaticWidth S.empty Nothing Nothing

227272

228273-- | The monad for the main REPL - reading and processing files and updating

229274-- global state (hence the IO inner monad).

@@ -245,10 +290,10 @@ data Command = Quit

245290 | Help

246291 | Eval PTerm

247292 | Check PTerm

248− | DocStr Name

293+ | DocStr (Either Name Const)

249294 | TotCheck Name

250295 | Reload

251− | Load FilePath

296+ | Load FilePath (Maybe Int) -- up to maximum line number

252297 | ChangeDirectory FilePath

253298 | ModImport String

254299 | Edit

@@ -267,7 +312,6 @@ data Command = Quit

267312 | HNF PTerm

268313 | TestInline PTerm

269314 | Defn Name

270− | Info Name

271315 | Missing Name

272316 | DynamicLink FilePath

273317 | ListDynamic

@@ -279,7 +323,10 @@ data Command = Quit

279323 | AddProofClauseFrom Bool Int Name

280324 | AddMissing Bool Int Name

281325 | MakeWith Bool Int Name

282− | DoProofSearch Bool Int Name [Name]

326+ | MakeLemma Bool Int 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)

283330 | SetOpt Opt

284331 | UnsetOpt Opt

285332 | NOP

@@ -288,10 +335,13 @@ data Command = Quit

288335 | ColourOff

289336 | ListErrorHandlers

290337 | SetConsoleWidth ConsoleWidth

338+ | Apropos String

339+ | WhoCalls Name

340+ | CallsWho Name

341+ | MakeDoc String -- IdrisDoc

342+ | Warranty

291343

292344data Opt = Filename String

293− | Ver

294− | Usage

295345 | Quiet

296346 | NoBanner

297347 | ColourREPL Bool

@@ -310,6 +360,7 @@ data Opt = Filename String

310360 | DefaultTotal

311361 | DefaultPartial

312362 | WarnPartial

363+ | WarnReach

313364 | NoCoverage

314365 | ErrContext

315366 | ShowImpl

@@ -321,6 +372,8 @@ data Opt = Filename String

321372 | PkgClean String

322373 | PkgCheck String

323374 | PkgREPL String

375+ | PkgMkDoc String -- IdrisDoc

376+ | PkgTest String

324377 | WarnOnly

325378 | Pkg String

326379 | BCAsm String

@@ -330,12 +383,14 @@ data Opt = Filename String

330383 | OutputTy OutputType

331384 | Extension LanguageExt

332385 | InterpretScript String

386+ | EvalExpr String

333387 | TargetTriple String

334388 | TargetCPU String

335389 | OptLevel Word

336390 | Client String

337391 | ShowOrigErr

338392 | AutoWidth -- ^ Automatically adjust terminal width

393+ | AutoSolve -- ^ Automatically issue "solve" tactic in interactive prover

339394 deriving (Show, Eq)

340395

341396-- Parsed declarations

@@ -381,44 +436,37 @@ deriving instance NFData Static

381436-- Mark bindings with their explicitness, and laziness

382437data Plicity = Imp { pargopts :: [ArgOpt],

383438 pstatic :: Static,

384− pdocstr :: String,

385439 pparam :: Bool }

386440 | Exp { pargopts :: [ArgOpt],

387441 pstatic :: Static,

388− pdocstr :: String,

389− pparam :: Bool }

442+ pparam :: Bool } -- this is a param (rather than index)

390443 | Constraint { pargopts :: [ArgOpt],

391− pstatic :: Static,

392− pdocstr :: String }

444+ pstatic :: Static }

393445 | TacImp { pargopts :: [ArgOpt],

394446 pstatic :: Static,

395− pscript :: PTerm,

396− pdocstr :: String }

447+ pscript :: PTerm }

397448 deriving (Show, Eq)

398449

399−plazy :: Plicity -> Bool

400−plazy tm = Lazy `elem` pargopts tm

401−

402450{-!

403451deriving instance Binary Plicity

404452deriving instance NFData Plicity

405453!-}

406454

407−impl = Imp [Lazy] Dynamic "" False

408−expl = Exp [] Dynamic "" False

409−expl_param = Exp [] Dynamic "" True

410−constraint = Constraint [] Dynamic ""

411−tacimpl t = TacImp [] Dynamic t ""

455+impl = Imp [] Dynamic False

456+expl = Exp [] Dynamic False

457+expl_param = Exp [] Dynamic True

458+constraint = Constraint [] Dynamic

459+tacimpl t = TacImp [] Dynamic t

412460

413461data FnOpt = Inlinable -- always evaluate when simplifying

414− | TotalFn | PartialFn

462+ | TotalFn | PartialFn | CoveringFn

415463 | Coinductive | AssertTotal

416464 | Dictionary -- type class dictionary, eval only when

417465 -- a function argument, and further evaluation resutls

418466 | Implicit -- implicit coercion

419467 | CExport String -- export, with a C name

420468 | 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

422470 | Reflection -- a reflecting function, compile-time only

423471 | Specialise [(Name, Maybe Int)] -- specialise it, freeze these names

424472 deriving (Show, Eq)

@@ -445,27 +493,29 @@ data DataOpt = Codata -- Set if the the data-type is coinductive

445493type DataOpts = [DataOpt]

446494

447495-- | Type provider - what to provide

448−data ProvideWhat = ProvTerm -- ^ only allow providing terms

449− | ProvPostulate -- ^ only allow postulates

450− | ProvAny -- ^ either is ok

451− deriving (Show, Eq)

496+data ProvideWhat' t = ProvTerm t t -- ^ the first is the goal type, the second is the term

497+ | ProvPostulate t -- ^ goal type must be Type, so only term

498+ deriving (Show, Eq, Functor)

499+

500+type ProvideWhat = ProvideWhat' PTerm

452501

453502-- | Top-level declarations such as compiler directives, definitions,

454503-- datatypes and typeclasses.

455504data PDecl' t

456505 = PFix FC Fixity [String] -- ^ Fixity declaration

457− | PTy String SyntaxInfo FC FnOpts Name t -- ^ Type declaration

458− | PPostulate String SyntaxInfo FC FnOpts Name t -- ^ Postulate

506+ | PTy Docstring [(Name, Docstring)] SyntaxInfo FC FnOpts Name t -- ^ Type declaration

507+ | PPostulate Docstring SyntaxInfo FC FnOpts Name t -- ^ Postulate

459508 | PClauses FC FnOpts Name [PClause' t] -- ^ Pattern clause

460509 | 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.

462511 | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block

463512 | PNamespace String [PDecl' t] -- ^ New namespace

464− | PRecord String SyntaxInfo FC Name t String Name t -- ^ Record declaration

465− | PClass String SyntaxInfo FC

513+ | PRecord Docstring SyntaxInfo FC Name t DataOpts Docstring Name t -- ^ Record declaration

514+ | PClass Docstring SyntaxInfo FC

466515 [t] -- constraints

467516 Name

468517 [(Name, t)] -- parameters

518+ [(Name, Docstring)] -- parameter docstrings

469519 [PDecl' t] -- declarations

470520 -- ^ Type class: arguments are documentation, syntax info, source location, constraints,

471521 -- class name, parameters, method declarations

@@ -481,7 +531,7 @@ data PDecl' t

481531 | PSyntax FC Syntax -- ^ Syntax definition

482532 | PMutual FC [PDecl' t] -- ^ Mutual block

483533 | 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

485535 | PTransform FC Bool t t -- ^ Source-to-source transformation rule. If

486536 -- bool is True, lhs and rhs must be convertible

487537 deriving Functor

@@ -516,7 +566,7 @@ deriving instance NFData PClause'

516566-- | Data declaration

517567data PData' t = PDatadecl { d_name :: Name, -- ^ The name of the datatype

518568 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

520570 }

521571 -- ^ Data declaration

522572 | PLaterdecl { d_name :: Name, d_tcon :: t }

@@ -538,17 +588,17 @@ type PClause = PClause' PTerm

538588

539589declared :: PDecl -> [Name]

540590declared (PFix _ _ _) = []

541−declared (PTy _ _ _ _ n t) = [n]

591+declared (PTy _ _ _ _ _ n t) = [n]

542592declared (PPostulate _ _ _ _ n t) = [n]

543593declared (PClauses _ _ n _) = [] -- not a declaration

544594declared (PCAF _ n _) = [n]

545−declared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

546− where fstt (_, a, _, _, _) = a

547−declared (PData _ _ _ _ (PLaterdecl n _)) = [n]

595+declared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

596+ where fstt (_, _, a, _, _, _) = a

597+declared (PData _ _ _ _ _ (PLaterdecl n _)) = [n]

548598declared (PParams _ _ ds) = concatMap declared ds

549599declared (PNamespace _ ds) = concatMap declared ds

550−declared (PRecord _ _ _ n _ _ c _) = [n, c]

551−declared (PClass _ _ _ _ n _ ms) = n : concatMap declared ms

600+declared (PRecord _ _ _ n _ _ _ c _) = [n, c]

601+declared (PClass _ _ _ _ n _ _ ms) = n : concatMap declared ms

552602declared (PInstance _ _ _ _ _ _ _ _) = []

553603declared (PDSL n _) = [n]

554604declared (PSyntax _ _) = []

@@ -558,32 +608,32 @@ declared (PDirective _) = []

558608-- get the names declared, not counting nested parameter blocks

559609tldeclared :: PDecl -> [Name]

560610tldeclared (PFix _ _ _) = []

561−tldeclared (PTy _ _ _ _ n t) = [n]

611+tldeclared (PTy _ _ _ _ _ n t) = [n]

562612tldeclared (PPostulate _ _ _ _ n t) = [n]

563613tldeclared (PClauses _ _ n _) = [] -- not a declaration

564−tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]

565−tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

566− where fstt (_, a, _, _, _) = a

614+tldeclared (PRecord _ _ _ n _ _ _ c _) = [n, c]

615+tldeclared (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

616+ where fstt (_, _, a, _, _, _) = a

567617tldeclared (PParams _ _ ds) = []

568618tldeclared (PMutual _ ds) = concatMap tldeclared ds

569619tldeclared (PNamespace _ ds) = concatMap tldeclared ds

570−tldeclared (PClass _ _ _ _ n _ ms) = concatMap tldeclared ms

620+tldeclared (PClass _ _ _ _ n _ _ ms) = concatMap tldeclared ms

571621tldeclared (PInstance _ _ _ _ _ _ _ _) = []

572622tldeclared _ = []

573623

574624defined :: PDecl -> [Name]

575625defined (PFix _ _ _) = []

576−defined (PTy _ _ _ _ n t) = []

626+defined (PTy _ _ _ _ _ n t) = []

577627defined (PPostulate _ _ _ _ n t) = []

578628defined (PClauses _ _ n _) = [n] -- not a declaration

579629defined (PCAF _ n _) = [n]

580−defined (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

581− where fstt (_, a, _, _, _) = a

582−defined (PData _ _ _ _ (PLaterdecl n _)) = []

630+defined (PData _ _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

631+ where fstt (_, _, a, _, _, _) = a

632+defined (PData _ _ _ _ _ (PLaterdecl n _)) = []

583633defined (PParams _ _ ds) = concatMap defined ds

584634defined (PNamespace _ ds) = concatMap defined ds

585−defined (PRecord _ _ _ n _ _ c _) = [n, c]

586−defined (PClass _ _ _ _ n _ ms) = n : concatMap defined ms

635+defined (PRecord _ _ _ n _ _ _ c _) = [n, c]

636+defined (PClass _ _ _ _ n _ _ ms) = n : concatMap defined ms

587637defined (PInstance _ _ _ _ _ _ _ _) = []

588638defined (PDSL n _) = [n]

589639defined (PSyntax _ _) = []

@@ -620,26 +670,26 @@ data PTerm = PQuote Raw

620670 | PInferRef FC Name -- ^ A name to be defined later

621671 | PPatvar FC Name

622672 | PLam Name PTerm PTerm

623− | PPi Plicity Name PTerm PTerm

673+ | PPi Plicity Name PTerm PTerm -- ^ (n : t1) -> t2

624674 | PLet Name PTerm PTerm PTerm

625675 | PTyped PTerm PTerm -- ^ Term with explicit type

626− | PApp FC PTerm [PArg]

676+ | PApp FC PTerm [PArg] -- ^ e.g. IO (), List Char, length x

627677 | PAppBind FC PTerm [PArg] -- ^ implicitly bound application

628678 | PMatchApp FC Name -- ^ Make an application by type matching

629679 | PCase FC PTerm [(PTerm, PTerm)]

630− | PTrue FC PunInfo

631− | PFalse FC

680+ | PTrue FC PunInfo -- ^ Unit type..?

681+ | PFalse FC -- ^ _|_

632682 | PRefl FC PTerm

633683 | PResolveTC FC

634− | PEq FC PTerm PTerm

684+ | PEq FC PTerm PTerm -- ^ Equality type: A = B

635685 | PRewrite FC PTerm PTerm (Maybe PTerm)

636686 | PPair FC PunInfo PTerm PTerm

637687 | PDPair FC PunInfo PTerm PTerm PTerm

638688 | PAlternative Bool [PTerm] -- True if only one may work

639689 | PHidden PTerm -- ^ Irrelevant or hidden pattern

640− | PType

690+ | PType -- ^ 'Type' type

641691 | PGoal FC PTerm Name PTerm

642− | PConstant Const

692+ | PConstant Const -- ^ Builtin types

643693 | Placeholder

644694 | PDoBlock [PDo]

645695 | PIdiom FC PTerm

@@ -688,13 +738,14 @@ mapPT f t = f (mpt t) where

688738

689739

690740data PTactic' t = Intro [Name] | Intros | Focus Name

691− | Refine Name [Bool] | Rewrite t

741+ | Refine Name [Bool] | Rewrite t | DoUnify

692742 | Induction Name

693743 | Equiv t

694744 | MatchRefine Name

695745 | LetTac Name t | LetTacTy Name t t

696746 | 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

698749 | Solve

699750 | Attack

700751 | ProofState | ProofTerm | Undo

@@ -741,7 +792,7 @@ type PTactic = PTactic' PTerm

741792

742793data PDo' t = DoExp FC t

743794 | DoBind FC Name t

744− | DoBindP FC t t

795+ | DoBindP FC t t [(t,t)]

745796 | DoLet FC Name t t

746797 | DoLetP FC t t

747798 deriving (Eq, Functor)

@@ -753,7 +804,7 @@ deriving instance NFData PDo'

753804instance Sized a => Sized (PDo' a) where

754805 size (DoExp fc t) = 1 + size fc + size t

755806 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

757808 size (DoLet fc nm l r) = 1 + size fc + size nm + size l + size r

758809 size (DoLetP fc l r) = 1 + size fc + size l + size r

759810

@@ -766,45 +817,40 @@ type PDo = PDo' PTerm

766817data PArg' t = PImp { priority :: Int,

767818 machine_inf :: Bool, -- true if the machine inferred it

768819 argopts :: [ArgOpt],

769− pname :: Name, getTm :: t,

770− pargdoc :: String }

820+ pname :: Name, getTm :: t }

771821 | PExp { priority :: Int,

772822 argopts :: [ArgOpt],

773− getTm :: t,

774− pargdoc :: String }

823+ pname :: Name,

824+ getTm :: t }

775825 | PConstraint { priority :: Int,

776826 argopts :: [ArgOpt],

777− getTm :: t,

778− pargdoc :: String }

827+ pname :: Name,

828+ getTm :: t }

779829 | PTacImplicit { priority :: Int,

780830 argopts :: [ArgOpt],

781831 pname :: Name,

782832 getScript :: t,

783− getTm :: t,

784− pargdoc :: String }

833+ getTm :: t }

785834 deriving (Show, Eq, Functor)

786835

787−data ArgOpt = Lazy | HideDisplay

836+data ArgOpt = HideDisplay | InaccessibleArg

788837 deriving (Show, Eq)

789838

790−lazyarg :: PArg' t -> Bool

791−lazyarg tm = Lazy `elem` argopts tm

792−

793839instance Sized a => Sized (PArg' a) where

794− size (PImp p _ l nm trm _) = 1 + size nm + size trm

795− size (PExp p l trm _) = 1 + size trm

796− size (PConstraint p l trm _) = 1 + size trm

797− size (PTacImplicit p l nm scr trm _) = 1 + size nm + size scr + size trm

840+ size (PImp p _ l nm trm) = 1 + size nm + size trm

841+ size (PExp p l nm trm) = 1 + size nm + size trm

842+ size (PConstraint p l nm trm) = 1 + size nm +size nm + size trm

843+ size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

798844

799845{-!

800846deriving instance Binary PArg'

801847deriving instance NFData PArg'

802848!-}

803849

804−pimp n t mach = PImp 1 mach [Lazy] n t ""

805−pexp t = PExp 1 [] t ""

806−pconst t = PConstraint 1 [] t ""

807−ptacimp n s t = PTacImplicit 2 [Lazy] n s t ""

850+pimp n t mach = PImp 1 mach [] n t

851+pexp t = PExp 1 [] (sMN 0 "arg") t

852+pconst t = PConstraint 1 [] (sMN 0 "carg") t

853+ptacimp n s t = PTacImplicit 2 [] n s t

808854

809855type PArg = PArg' PTerm

810856

@@ -825,25 +871,11 @@ deriving instance NFData ClassInfo

825871-- Type inference data

826872

827873data 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

829875 deriving Show

830876

831−-- An argument is conditionally forceable iff its forceability

832−-- depends on the collapsibility of the whole type.

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] }

877+data OptInfo = Optimise { inaccessible :: [(Int,Name)], -- includes names for error reporting

878+ detaggable :: Bool }

847879 deriving Show

848880{-!

849881deriving instance Binary OptInfo

@@ -854,7 +886,8 @@ deriving instance NFData OptInfo

854886data TypeInfo = TI { con_names :: [Name],

855887 codata :: Bool,

856888 data_opts :: DataOpts,

857− param_pos :: [Int] }

889+ param_pos :: [Int],

890+ mutual_types :: [Name] }

858891 deriving Show

859892{-!

860893deriving instance Binary TypeInfo

@@ -932,6 +965,8 @@ data SyntaxInfo = Syn { using :: [Using],

932965 decoration :: Name -> Name,

933966 inPattern :: Bool,

934967 implicitAllowed :: Bool,

968+ maxline :: Maybe Int,

969+ mut_nesting :: Int,

935970 dsl_info :: DSL }

936971 deriving Show

937972{-!

@@ -939,7 +974,7 @@ deriving instance NFData SyntaxInfo

939974deriving instance Binary SyntaxInfo

940975!-}

941976

942−defaultSyntax = Syn [] [] [] [] id False False initDSL

977+defaultSyntax = Syn [] [] [] [] id False False Nothing 0 initDSL

943978

944979expandNS :: SyntaxInfo -> Name -> Name

945980expandNS syn n@(NS _ _) = n

@@ -956,9 +991,9 @@ inferTy = sMN 0 "__Infer"

956991inferCon = sMN 0 "__infer"

957992inferDecl = PDatadecl inferTy

958993 PType

959− [("", inferCon, PPi impl (sMN 0 "iType") PType (

960− PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

961− (PRef bi inferTy)), bi, [])]

994+ [(emptyDocstring, [], inferCon, PPi impl (sMN 0 "iType") PType (

995+ PPi expl (sMN 0 "ival") (PRef bi (sMN 0 "iType"))

996+ (PRef bi inferTy)), bi, [])]

962997inferOpts = []

963998

964999infTerm t = PApp bi (PRef bi inferCon) [pimp (sMN 0 "iType") Placeholder True, pexp t]

@@ -983,52 +1018,92 @@ primNames = [unitTy, unitCon,

9831018 falseTy, pairTy, pairCon,

9841019 eqTy, eqCon, inferTy, inferCon]

9851020

1021+unitDoc = parseDocstring . T.pack $ "The canonical single-element type, also known as the trivially true proposition."

9861022unitTy = sMN 0 "__Unit"

9871023unitCon = sMN 0 "__II"

9881024unitDecl = PDatadecl unitTy PType

989− [("", unitCon, PRef bi unitTy, bi, [])]

1025+ [(parseDocstring . T.pack $ "The trivial constructor for `()`. ", [], unitCon, PRef bi unitTy, bi, [])]

9901026unitOpts = [DefaultEliminator]

9911027

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."

9921033falseTy = sMN 0 "__False"

9931034falseDecl = PDatadecl falseTy PType []

9941035falseOpts = []

9951036

1037+pairDoc = parseDocstring . T.pack $ "The non-dependent pair type, also known as conjunction."

9961038pairTy = sMN 0 "__Pair"

9971039pairCon = sMN 0 "__MkPair"

9981040pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

999− [("", pairCon, PPi impl (n "A") PType (

1000− PPi impl (n "B") PType (

1001− PPi expl (n "a") (PRef bi (n "A")) (

1002− PPi expl (n "b") (PRef bi (n "B"))

1003− (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

1004− pexp (PRef bi (n "B"))])))), bi, [])]

1041+ [(pairConDoc, pairConParamDoc,

1042+ pairCon, PPi impl (n "A") PType (

1043+ PPi impl (n "B") PType (

1044+ PPi expl (n "a") (PRef bi (n "A")) (

1045+ PPi expl (n "b") (PRef bi (n "B"))

1046+ (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

1047+ pexp (PRef bi (n "B"))])))), bi, [])]

10051048 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")]

10061052pairOpts = []

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

10071056

10081057eqTy = sUN "="

10091058eqCon = 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+

10101073eqDecl = PDatadecl eqTy (piBind [(n "A", PType), (n "B", PType),

10111074 (n "x", PRef bi (n "A")), (n "y", PRef bi (n "B"))]

10121075 PType)

1013− [("", eqCon, PPi impl (n "A") PType (

1014− PPi impl (n "x") (PRef bi (n "A"))

1015− (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1016− pimp (n "B") Placeholder False,

1017− pexp (PRef bi (n "x")),

1018− pexp (PRef bi (n "x"))])), bi, [])]

1076+ [(reflDoc, reflParamDoc,

1077+ eqCon, PPi impl (n "A") PType (

1078+ PPi impl (n "x") (PRef bi (n "A"))

1079+ (PApp bi (PRef bi eqTy) [pimp (n "A") Placeholder False,

1080+ pimp (n "B") Placeholder False,

1081+ pexp (PRef bi (n "x")),

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+ ]

10191093 where n a = sMN 0 a

1094+

10201095eqOpts = []

10211096

10221097elimName = sUN "__Elim"

10231098elimMethElimTy = sUN "__elimTy"

10241099elimMethElim = sUN "elim"

1025−elimDecl = PClass "Type class for eliminators" defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)]

1026− [PTy "" defaultSyntax bi [TotalFn] elimMethElimTy PType,

1027− PTy "" defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

1100+elimDecl = PClass (parseDocstring . T.pack $ "Type class for eliminators") defaultSyntax bi [] elimName [(sUN "scrutineeType", PType)] []

1101+ [PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElimTy PType,

1102+ PTy emptyDocstring [] defaultSyntax bi [TotalFn] elimMethElim (PRef bi elimMethElimTy)]

10281103

10291104-- Defined in builtins.idr

1030−sigmaTy = sUN "Exists"

1031−existsCon = sUN "Ex_intro"

1105+sigmaTy = sUN "Sigma"

1106+existsCon = sUN "Sg_intro"

10321107

10331108piBind :: [(Name, PTerm)] -> PTerm -> PTerm

10341109piBind = piBindp expl

@@ -1044,52 +1119,69 @@ piBindp p ((n, ty):ns) t = PPi p n ty (piBindp p ns t)

10441119-- could interfere with interactive editing, which calls "show".

10451120

10461121instance 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

10481123

10491124instance 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

10511126

10521127instance 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

10541129

10551130instance 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

10571132

10581133instance Pretty PTerm OutputAnnotation where

1059− pretty = prettyImp False

1134+ pretty = prettyImp defaultPPOption

10601135

10611136-- | Colourise annotations according to an Idris state. It ignores the names

10621137-- in the annotation, as there's no good way to show extended information on a

10631138-- terminal.

10641139consoleDecorate :: IState -> OutputAnnotation -> String -> String

10651140consoleDecorate ist _ | not (idris_colourRepl ist) = id

1066−consoleDecorate ist AnnConstData = let theme = idris_colourTheme ist

1067− in colouriseData theme

1068−consoleDecorate ist AnnConstType = let theme = idris_colourTheme ist

1069− in colouriseType theme

1141+consoleDecorate ist (AnnConst c) = let theme = idris_colourTheme ist

1142+ in if constIsType c

1143+ then colouriseType theme

1144+ else colouriseData theme

1145+consoleDecorate ist (AnnData _ _) = colouriseData (idris_colourTheme ist)

1146+consoleDecorate ist (AnnType _ _) = colouriseType (idris_colourTheme ist)

10701147consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist)

10711148consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)

1072−consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist

1073− theme = idris_colourTheme ist

1074− in case () of

1075− _ | isDConName n ctxt -> colouriseData theme

1076− _ | isFnName n ctxt -> colouriseFun theme

1077− _ | isTConName n ctxt -> colouriseType theme

1078− _ | otherwise -> id -- don't colourise unknown names

1149+consoleDecorate ist AnnKeyword = colouriseKeyword (idris_colourTheme ist)

1150+consoleDecorate ist (AnnName n _ _ _) = let ctxt = tt_ctxt ist

1151+ theme = idris_colourTheme ist

1152+ in case () of

1153+ _ | isDConName n ctxt -> colouriseData theme

1154+ _ | isFnName n ctxt -> colouriseFun theme

1155+ _ | isTConName n ctxt -> colouriseType theme

1156+ _ | isPostulateName n ist -> colourisePostulate theme

1157+ _ | otherwise -> id -- don't colourise unknown names

10791158consoleDecorate 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

10801163

1081−-- | Pretty-print a high-level closed Idris term

1082−prettyImp :: Bool -- ^^ whether to show implicits

1164+isPostulateName :: Name -> IState -> Bool

1165+isPostulateName n ist = S.member n (idris_postulates ist)

1166+

1167+-- | Pretty-print a high-level closed Idris term with no information about precedence/associativity

1168+prettyImp :: PPOption -- ^^ pretty printing options

10831169 -> PTerm -- ^^ the term to pretty-print

10841170 -> 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)

10861176

1087−-- | Pretty-print a high-level Idris term in some bindings context

1088−pprintPTerm :: Bool -- ^^ whether to show implicits

1177+-- | Pretty-print a high-level Idris term in some bindings context with infix info

1178+pprintPTerm :: PPOption -- ^^ pretty printing options

10891179 -> [(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

10901182 -> PTerm -- ^^ the term to pretty-print

10911183 -> Doc OutputAnnotation

1092−pprintPTerm impl bnd = prettySe 10 bnd

1184+pprintPTerm ppo bnd docArgs infixes = prettySe 10 bnd

10931185 where

10941186 prettySe :: Int -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

10951187 prettySe p bnd (PQuote r) =

@@ -1097,81 +1189,90 @@ pprintPTerm impl bnd = prettySe 10 bnd

10971189 prettySe p bnd (PPatvar fc n) = pretty n

10981190 prettySe p bnd e

10991191 | Just str <- slist p bnd e = str

1100− | Just n <- snat p e = annotate AnnConstData (text (show n))

1101− prettySe p bnd (PRef fc n) = prettyName impl bnd n

1192+ | Just n <- snat p e = annotate (AnnData "Nat" "") (text (show n))

1193+ prettySe p bnd (PRef fc n) = prettyName (ppopt_impl ppo) bnd n

11021194 prettySe p bnd (PLam n ty sc) =

11031195 bracket p 2 . group . align . hang 2 $

11041196 text "\\" <> bindingOf n False <+> text "=>" <$>

11051197 prettySe 10 ((n, False):bnd) sc

11061198 prettySe p bnd (PLet n ty v sc) =

11071199 bracket p 2 $

1108− text "let" <+> bindingOf n False <+> text "=" </>

1109− prettySe 10 bnd v <+> text "in" </>

1200+ kwd "let" <+> bindingOf n False <+> text "=" </>

1201+ prettySe 10 bnd v <+> kwd "in" </>

11101202 prettySe 10 ((n, False):bnd) sc

1111− prettySe p bnd (PPi (Exp l s _ _) n ty sc)

1112− | n `elem` allNamesIn sc || impl =

1113− let open = if Lazy `elem` l then text "|" <> lparen else lparen in

1114− bracket p 2 . group $

1115− enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

1116− st <> text "->" <$> prettySe 10 ((n, False):bnd) sc

1203+ prettySe p bnd (PPi (Exp l s _) n ty sc)

1204+ | n `elem` allNamesIn sc || ppopt_impl ppo || n `elem` docArgs =

1205+ bracket p 2 . group $

1206+ enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

1207+ st <> text "->" <$> prettySe 10 ((n, False):bnd) sc

11171208 | otherwise =

11181209 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)

11201211 where

11211212 st =

11221213 case s of

11231214 Static -> text "[static]" <> space

11241215 _ -> empty

1125− prettySe p bnd (PPi (Imp l s _ _) n ty sc)

1126− | impl =

1127− let open = if Lazy `elem` l then text "|" <> lbrace else lbrace in

1128− bracket p 2 $

1129− open <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>

1130− st <> text "->" </> prettySe 10 ((n, True):bnd) sc

1216+ prettySe p bnd (PPi (Imp l s _) n ty sc)

1217+ | ppopt_impl ppo =

1218+ bracket p 2 $

1219+ lbrace <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>

1220+ st <> text "->" </> prettySe 10 ((n, True):bnd) sc

11311221 | otherwise = prettySe 10 ((n, True):bnd) sc

11321222 where

11331223 st =

11341224 case s of

11351225 Static -> text "[static]" <> space

11361226 _ -> empty

1137− prettySe p bnd (PPi (Constraint _ _ _) n ty sc) =

1227+ prettySe p bnd (PPi (Constraint _ _) n ty sc) =

11381228 bracket p 2 $

11391229 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) =

11411231 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 <>

11431233 rbrace <+> text "->" </> prettySe 10 ((n, True):bnd) sc

11441234 prettySe p bnd (PApp _ (PRef _ f) args) -- normal names, no explicit args

11451235 | UN nm <- basename f

1146− , not impl && null (getExps args) = if isAlpha (thead nm)

1147− then prettyName impl bnd f

1148− else enclose lparen rparen $

1149− prettyName impl bnd f

1236+ , not (ppopt_impl ppo) && null (getExps args) =

1237+ if isAlpha (thead nm)

1238+ then prettyName (ppopt_impl ppo) bnd f

1239+ else enclose lparen rparen $ prettyName (ppopt_impl ppo) bnd f

11501240 prettySe p bnd (PAppBind _ (PRef _ f) [])

1151− | not impl = text "!" <> prettyName impl bnd f

1152− prettySe p bnd (PApp _ (PRef _ op) args)

1241+ | not (ppopt_impl ppo) = text "!" <> prettyName (ppopt_impl ppo) bnd f

1242+ prettySe p bnd (PApp _ (PRef _ op) args) -- infix operators

11531243 | UN nm <- basename op

11541244 , not (tnull nm) &&

1155− (not impl) && (not $ isAlpha (thead nm)) =

1245+ (not (ppopt_impl ppo)) && (not $ isAlpha (thead nm)) =

11561246 case getExps args of

11571247 [] -> enclose lparen rparen opName

11581248 [x] -> group (enclose lparen rparen opName <$> group (prettySe 0 bnd x))

1159− [l,r] -> bracket p 1 $ inFix l r

1249+ [l,r] -> let precedence = fromMaybe 20 (fmap prec f)

1250+ in bracket p precedence $ inFix l r

11601251 (l:r:rest) -> bracket p 1 $

11611252 enclose lparen rparen (inFix l r) <+>

11621253 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

11641264 inFix l r = align . group $

1165− (prettySe 1 bnd l <+> opName) <$> group (prettySe 0 bnd r)

1166− prettySe p bnd (PApp _ hd@(PRef fc f) [tm])

1265+ (left l <+> opName) <$> group (right r)

1266+ prettySe p bnd (PApp _ hd@(PRef fc f) [tm]) -- symbols, like 'foo

11671267 | PConstant (Idris.Core.TT.Str str) <- getTm tm,

1168− f == sUN "Symbol_" = char '\'' <> prettySe 10 bnd (PRef fc (sUN str))

1169− prettySe p bnd (PApp _ f as) =

1268+ f == sUN "Symbol_" = annotate (AnnType ("'" ++ str) ("The symbol " ++ str)) $

1269+ char '\'' <> prettySe 10 bnd (PRef fc (sUN str))

1270+ prettySe p bnd (PApp _ f as) = -- Normal prefix applications

11701271 let args = getExps as

11711272 fp = prettySe 1 bnd f

11721273 in

11731274 bracket p 1 . group $

1174− if impl

1275+ if ppopt_impl ppo

11751276 then if null as

11761277 then fp

11771278 else fp <+> align (vsep (map (prettyArgS bnd) as))

@@ -1179,22 +1280,22 @@ pprintPTerm impl bnd = prettySe 10 bnd

11791280 then fp

11801281 else fp <+> align (vsep (map (prettyArgSe bnd) args))

11811282 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

11831284 where

11841285 prettyBody = foldr (<>) empty $ intersperse (text "|") $ map sc opts

11851286

11861287 sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r

11871288 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"

11891290 prettySe p bnd (PResolveTC _) = text "resolvetc"

1190− prettySe p bnd (PTrue _ IsType) = annotate (AnnName unitTy Nothing Nothing) $ text "()"

1191− prettySe p bnd (PTrue _ IsTerm) = annotate (AnnName unitCon Nothing Nothing) $ text "()"

1291+ prettySe p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1292+ prettySe p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

11921293 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 "_|_"

11941295 prettySe p bnd (PEq _ l r) =

11951296 bracket p 2 . align . group $

11961297 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 "=")

11981299 prettySe p bnd (PRewrite _ l r _) =

11991300 bracket p 2 $

12001301 text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r

@@ -1206,72 +1307,75 @@ pprintPTerm impl bnd = prettySe 10 bnd

12061307 map (prettySe 10 bnd) elts

12071308 where ann = case pun of

12081309 TypeOrTerm -> id

1209− IsType -> annotate (AnnName pairTy Nothing Nothing)

1210− IsTerm -> annotate (AnnName pairCon Nothing Nothing)

1310+ IsType -> annName pairTy

1311+ IsTerm -> annName pairCon

12111312 prettySe p bnd (PDPair _ TypeOrTerm l t r) =

12121313 lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen

12131314 prettySe p bnd (PDPair _ IsType (PRef _ n) t r) =

1214− annotate (AnnName sigmaTy Nothing Nothing) lparen <>

1315+ annName sigmaTy lparen <>

12151316 bindingOf n False <+>

1216− annotate (AnnName sigmaTy Nothing Nothing) (text "**") <+>

1317+ annName sigmaTy (text "**") <+>

12171318 prettySe 10 ((n, False):bnd) r <>

1218− annotate (AnnName sigmaTy Nothing Nothing) rparen

1319+ annName sigmaTy rparen

12191320 prettySe p bnd (PDPair _ IsType l t r) =

1220− annotate (AnnName sigmaTy Nothing Nothing) lparen <>

1321+ annName sigmaTy lparen <>

12211322 prettySe 10 bnd l <+>

1222− annotate (AnnName sigmaTy Nothing Nothing) (text "**") <+>

1323+ annName sigmaTy (text "**") <+>

12231324 prettySe 10 bnd r <>

1224− annotate (AnnName sigmaTy Nothing Nothing) rparen

1325+ annName sigmaTy rparen

12251326 prettySe p bnd (PDPair _ IsTerm l t r) =

1226− annotate (AnnName existsCon Nothing Nothing) lparen <>

1327+ annName existsCon lparen <>

12271328 prettySe 10 bnd l <+>

1228− annotate (AnnName existsCon Nothing Nothing) (text "**") <+>

1329+ annName existsCon (text "**") <+>

12291330 prettySe 10 bnd r <>

1230− annotate (AnnName existsCon Nothing Nothing) rparen

1331+ annName existsCon rparen

12311332 prettySe p bnd (PAlternative a as) =

12321333 lparen <> text "|" <> prettyAs <> text "|" <> rparen

12331334 where

12341335 prettyAs =

12351336 foldr (\l -> \r -> l <+> text "," <+> r) empty $ map (prettySe 10 bnd) as

1236− prettySe p bnd PType = annotate AnnConstType $ text "Type"

1237− prettySe p bnd (PConstant c) = annotate (annot c) (text (show c))

1238− where annot (AType _) = AnnConstType

1239− annot StrType = AnnConstType

1240− annot PtrType = AnnConstType

1241− annot VoidType = AnnConstType

1242− annot _ = AnnConstData

1337+ prettySe p bnd PType = annotate (AnnType "Type" "The type of types") $ text "Type"

1338+ prettySe p bnd (PConstant c) = annotate (AnnConst c) (text (show c))

12431339 -- XXX: add pretty for tactics

12441340 prettySe p bnd (PProof ts) =

12451341 text "proof" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

12461342 prettySe p bnd (PTactics ts) =

12471343 text "tactics" <+> lbrace <> nest nestingSize (text . show $ ts) <> rbrace

12481344 prettySe p bnd (PMetavar n) = text "?" <> pretty n

1249− prettySe p bnd (PReturn f) = text "return"

1250− prettySe p bnd PImpossible = text "impossible"

1345+ prettySe p bnd (PReturn f) = kwd "return"

1346+ prettySe p bnd PImpossible = kwd "impossible"

12511347 prettySe p bnd Placeholder = text "_"

12521348 prettySe p bnd (PDoBlock _) = text "do block pretty not implemented"

1349+ prettySe p bnd (PCoerced t) = prettySe p bnd t

12531350 prettySe p bnd (PElabError s) = pretty s

12541351

12551352 prettySe p bnd _ = text "test"

12561353

1257− prettyArgS bnd (PImp _ _ _ n tm _) = prettyArgSi bnd (n, tm)

1258− prettyArgS bnd (PExp _ _ tm _) = prettyArgSe bnd tm

1259− prettyArgS bnd (PConstraint _ _ tm _) = prettyArgSc bnd tm

1260− prettyArgS bnd (PTacImplicit _ _ n _ tm _) = prettyArgSti bnd (n, tm)

1354+ prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)

1355+ prettyArgS bnd (PExp _ _ _ tm) = prettyArgSe bnd tm

1356+ prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm

1357+ prettyArgS bnd (PTacImplicit _ _ n _ tm) = prettyArgSti bnd (n, tm)

12611358

12621359 prettyArgSe bnd arg = prettySe 0 bnd arg

12631360 prettyArgSi bnd (n, val) = lbrace <> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

12641361 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

12661370

12671371 basename :: Name -> Name

12681372 basename (NS n _) = basename n

12691373 basename n = n

12701374

12711375 slist' p bnd (PApp _ (PRef _ nil) _)

1272− | not impl && nsroot nil == sUN "Nil" = Just []

1376+ | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []

12731377 slist' p bnd (PRef _ nil)

1274− | not impl && nsroot nil == sUN "Nil" = Just []

1378+ | not (ppopt_impl ppo) && nsroot nil == sUN "Nil" = Just []

12751379 slist' p bnd (PApp _ (PRef _ cons) args)

12761380 | nsroot cons == sUN "::",

12771381 (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,

@@ -1284,16 +1388,16 @@ pprintPTerm impl bnd = prettySe 10 bnd

12841388 slist' _ _ tm = Nothing

12851389

12861390 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 "[]"

12881392 [x] -> enclose left right . group $

12891393 prettySe p bnd x

12901394 xs -> (enclose left right .

12911395 align . group . vsep .

12921396 punctuate comma .

12931397 map (prettySe p bnd)) xs

1294− where left = (annotate AnnConstData (text "["))

1295− right = (annotate AnnConstData (text "]"))

1296− comma = (annotate AnnConstData (text ","))

1398+ where left = (annotate (AnnData "" "") (text "["))

1399+ right = (annotate (AnnData "" "") (text "]"))

1400+ comma = (annotate (AnnData "" "") (text ","))

12971401 slist _ _ _ = Nothing

12981402

12991403 pairElts :: PTerm -> Maybe [PTerm]

@@ -1315,6 +1419,19 @@ pprintPTerm impl bnd = prettySe 10 bnd

13151419 | inner > outer = lparen <> doc <> rparen

13161420 | otherwise = doc

13171421

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+

13181435-- | Pretty-printer helper for the binding site of a name

13191436bindingOf :: Name -- ^^ the bound name

13201437 -> Bool -- ^^ whether the name is implicit

@@ -1327,68 +1444,69 @@ prettyName :: Bool -- ^^ whether to show namespaces

13271444 -> Name -- ^^ the name to pprint

13281445 -> Doc OutputAnnotation

13291446prettyName 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))

13311448 where strName (UN n) = T.unpack n

13321449 strName (NS n ns) | showNS = (concatMap (++ ".") . map T.unpack . reverse) ns ++ strName n

13331450 | otherwise = strName n

1451+ strName n | n == falseTy = "_|_"

13341452 strName (MN i s) = T.unpack s

13351453 strName other = show other

13361454

13371455

1338−showCImp :: Bool -> PClause -> Doc OutputAnnotation

1339−showCImp impl (PClause _ n l ws r w)

1340− = prettyImp impl l <+> showWs ws <+> text "=" <+> prettyImp impl r

1456+showCImp :: PPOption -> PClause -> Doc OutputAnnotation

1457+showCImp ppo (PClause _ n l ws r w)

1458+ = prettyImp ppo l <+> showWs ws <+> text "=" <+> prettyImp ppo r

13411459 <+> text "where" <+> text (show w)

13421460 where

13431461 showWs [] = empty

1344− showWs (x : xs) = text "|" <+> prettyImp impl x <+> showWs xs

1345−showCImp impl (PWith _ n l ws r w)

1346− = prettyImp impl l <+> showWs ws <+> text "with" <+> prettyImp impl r

1462+ showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

1463+showCImp ppo (PWith _ n l ws r w)

1464+ = prettyImp ppo l <+> showWs ws <+> text "with" <+> prettyImp ppo r

13471465 <+> braces (text (show w))

13481466 where

13491467 showWs [] = empty

1350− showWs (x : xs) = text "|" <+> prettyImp impl x <+> showWs xs

1468+ showWs (x : xs) = text "|" <+> prettyImp ppo x <+> showWs xs

13511469

13521470

1353−showDImp :: Bool -> PData -> Doc OutputAnnotation

1354−showDImp impl (PDatadecl n ty cons)

1355− = text "data" <+> text (show n) <+> colon <+> prettyImp impl ty <+> text "where" <$>

1356− (indent 2 $ vsep (map (\ (_, n, t, _, _) -> pipe <+> prettyName False [] n <+> colon <+> prettyImp impl t) cons))

1471+showDImp :: PPOption -> PData -> Doc OutputAnnotation

1472+showDImp ppo (PDatadecl n ty cons)

1473+ = text "data" <+> text (show n) <+> colon <+> prettyImp ppo ty <+> text "where" <$>

1474+ (indent 2 $ vsep (map (\ (_, _, n, t, _, _) -> pipe <+> prettyName False [] n <+> colon <+> prettyImp ppo t) cons))

13571475

1358−showDecls :: Bool -> [PDecl] -> Doc OutputAnnotation

1359−showDecls i ds = vsep (map (showDeclImp i) ds)

1476+showDecls :: PPOption -> [PDecl] -> Doc OutputAnnotation

1477+showDecls o ds = vsep (map (showDeclImp o) ds)

13601478

13611479showDeclImp _ (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

1363−showDeclImp i (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>

1364− indent 2 (vsep (map (showCImp i) cs))

1365−showDeclImp _ (PData _ _ _ _ d) = showDImp True d

1366−showDeclImp i (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls i ps <> line)

1367−showDeclImp i (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls i ps <> line)

1480+showDeclImp o (PTy _ _ _ _ _ n t) = text "tydecl" <+> text (showCG n) <+> colon <+> prettyImp o t

1481+showDeclImp o (PClauses _ _ n cs) = text "pat" <+> text (showCG n) <+> text "\t" <+>

1482+ indent 2 (vsep (map (showCImp o) cs))

1483+showDeclImp o (PData _ _ _ _ _ d) = showDImp o { ppopt_impl = True } d

1484+showDeclImp o (PParams _ ns ps) = text "params" <+> braces (text (show ns) <> line <> showDecls o ps <> line)

1485+showDeclImp o (PNamespace n ps) = text "namespace" <+> text n <> braces (line <> showDecls o ps <> line)

13681486showDeclImp _ (PSyntax _ syn) = text "syntax" <+> text (show syn)

1369−showDeclImp i (PClass _ _ _ cs n ps ds)

1370− = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls i ds

1371−showDeclImp i (PInstance _ _ cs n _ t _ ds)

1372− = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp i t <> line <> showDecls i ds

1487+showDeclImp o (PClass _ _ _ cs n ps _ ds)

1488+ = text "class" <+> text (show cs) <+> text (show n) <+> text (show ps) <> line <> showDecls o ds

1489+showDeclImp o (PInstance _ _ cs n _ t _ ds)

1490+ = text "instance" <+> text (show cs) <+> text (show n) <+> prettyImp o t <> line <> showDecls o ds

13731491showDeclImp _ _ = text "..."

1374−-- showDeclImp (PImport i) = "import " ++ i

1492+-- showDeclImp (PImport o) = "import " ++ o

13751493

13761494instance Show (Doc OutputAnnotation) where

13771495 show = flip (displayS . renderCompact) ""

13781496

13791497getImps :: [PArg] -> [(Name, PTerm)]

13801498getImps [] = []

1381−getImps (PImp _ _ _ n tm _ : xs) = (n, tm) : getImps xs

1499+getImps (PImp _ _ _ n tm : xs) = (n, tm) : getImps xs

13821500getImps (_ : xs) = getImps xs

13831501

13841502getExps :: [PArg] -> [PTerm]

13851503getExps [] = []

1386−getExps (PExp _ _ tm _ : xs) = tm : getExps xs

1504+getExps (PExp _ _ _ tm : xs) = tm : getExps xs

13871505getExps (_ : xs) = getExps xs

13881506

13891507getConsts :: [PArg] -> [PTerm]

13901508getConsts [] = []

1391−getConsts (PConstraint _ _ tm _ : xs) = tm : getConsts xs

1509+getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

13921510getConsts (_ : xs) = getConsts xs

13931511

13941512getAll :: [PArg] -> [PTerm]

@@ -1398,14 +1516,14 @@ getAll = map getTm

13981516-- | Show Idris name

13991517showName :: Maybe IState -- ^^ the Idris state, for information about names and colours

14001518 -> [(Name, Bool)] -- ^^ the bound variables and whether they're implicit

1401− -> Bool -- ^^ whether to show implicits

1519+ -> PPOption -- ^^ pretty printing options

14021520 -> Bool -- ^^ whether to colourise

14031521 -> Name -- ^^ the term to show

14041522 -> String

1405−showName ist bnd impl colour n = case ist of

1523+showName ist bnd ppo colour n = case ist of

14061524 Just i -> if colour then colourise n (idris_colourTheme i) else showbasic n

14071525 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

14091527 showbasic n@(UN _) = showCG n

14101528 showbasic (MN _ s) = str s

14111529 showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

@@ -1427,11 +1545,14 @@ showName ist bnd impl colour n = case ist of

14271545showTm :: IState -- ^^ the Idris state, for information about identifiers and colours

14281546 -> PTerm -- ^^ the term to show

14291547 -> 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)

14311551

14321552-- | Show a term with implicits, no colours

14331553showTmImpls :: PTerm -> String

1434−showTmImpls = flip (displayS . renderCompact . prettyImp True) ""

1554+showTmImpls = flip (displayS . renderCompact . prettyImp verbosePPOption) ""

1555+

14351556

14361557

14371558instance Sized PTerm where

@@ -1476,7 +1597,7 @@ getPArity _ = 0

14761597

14771598allNamesIn :: PTerm -> [Name]

14781599allNamesIn tm = nub $ ni [] tm

1479− where

1600+ where -- TODO THINK added niTacImp, but is it right?

14801601 ni env (PRef _ n)

14811602 | not (n `elem` env) = [n]

14821603 ni env (PPatvar _ n) = [n]

@@ -1484,7 +1605,7 @@ allNamesIn tm = nub $ ni [] tm

14841605 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

14851606 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

14861607 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

14881609 ni env (PHidden tm) = ni env tm

14891610 ni env (PEq _ l r) = ni env l ++ ni env r

14901611 ni env (PRewrite _ l r _) = ni env l ++ ni env r

@@ -1498,16 +1619,19 @@ allNamesIn tm = nub $ ni [] tm

14981619 ni env (PNoImplicits tm) = ni env tm

14991620 ni env _ = []

15001621

1622+ niTacImp env (TacImp _ _ scr) = ni env scr

1623+ niTacImp _ _ = []

1624+

15011625-- Return all names defined in binders in the given term

15021626boundNamesIn :: PTerm -> [Name]

15031627boundNamesIn tm = nub $ ni tm

1504− where

1628+ where -- TODO THINK Added niTacImp, but is it right?

15051629 ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as)

15061630 ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as)

15071631 ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os)

15081632 ni (PLam n ty sc) = n : (ni ty ++ ni sc)

15091633 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))

15111635 ni (PEq _ l r) = ni l ++ ni r

15121636 ni (PRewrite _ l r _) = ni l ++ ni r

15131637 ni (PTyped l r) = ni l ++ ni r

@@ -1521,6 +1645,9 @@ boundNamesIn tm = nub $ ni tm

15211645 ni (PNoImplicits tm) = ni tm

15221646 ni _ = []

15231647

1648+ niTacImp (TacImp _ _ scr) = ni scr

1649+ niTacImp _ = []

1650+

15241651-- Return names which are free in the given term.

15251652namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

15261653namesIn uvars ist tm = nub $ ni [] tm

@@ -1534,7 +1661,7 @@ namesIn uvars ist tm = nub $ ni [] tm

15341661 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

15351662 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

15361663 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

15381665 ni env (PEq _ l r) = ni env l ++ ni env r

15391666 ni env (PRewrite _ l r _) = ni env l ++ ni env r

15401667 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1548,21 +1675,24 @@ namesIn uvars ist tm = nub $ ni [] tm

15481675 ni env (PNoImplicits tm) = ni env tm

15491676 ni env _ = []

15501677

1678+ niTacImp env (TacImp _ _ scr) = ni env scr

1679+ niTacImp _ _ = []

1680+

15511681-- Return which of the given names are used in the given term.

15521682

15531683usedNamesIn :: [Name] -> IState -> PTerm -> [Name]

15541684usedNamesIn vars ist tm = nub $ ni [] tm

1555− where

1685+ where -- TODO THINK added niTacImp, but is it right?

15561686 ni env (PRef _ n)

15571687 | n `elem` vars && not (n `elem` env)

1558− = case lookupTy n (tt_ctxt ist) of

1559− [] -> [n]

1688+ = case lookupDefExact n (tt_ctxt ist) of

1689+ Nothing -> [n]

15601690 _ -> []

15611691 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

15621692 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

15631693 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

15641694 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

15661696 ni env (PEq _ l r) = ni env l ++ ni env r

15671697 ni env (PRewrite _ l r _) = ni env l ++ ni env r

15681698 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1576,3 +1706,5 @@ usedNamesIn vars ist tm = nub $ ni [] tm

15761706 ni env (PNoImplicits tm) = ni env tm

15771707 ni env _ = []

15781708

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

1414import Idris.Delaborate

1515import Idris.Parser

1616import Idris.Error

17+import Idris.Output

1718

1819import Idris.Core.TT

1920import Idris.Core.Typecheck

@@ -21,6 +22,7 @@ import Idris.Core.Evaluate

2122

2223import Data.Maybe

2324import Data.Char

25+import Data.List (isPrefixOf, isSuffixOf)

2426import Control.Monad

2527import Control.Monad.State.Strict

2628

@@ -51,7 +53,12 @@ names over '_', patterns over names, etc.

5153split :: Name -> PTerm -> Idris [[(Name, PTerm)]]

5254split n t'

5355 = do ist <- getIState

54− (tm, ty, pats) <- elabValBind toplevel True (addImplPat ist t')

56+ -- Make sure all the names in the term are accessible

57+ mapM_ (\n -> setAccessibility n Public) (allNamesIn 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

5562 logLvl 4 ("Elaborated:\n" ++ show tm ++ " : " ++ show ty ++ "\n" ++ show pats)

5663-- iputStrLn (show (delab ist tm) ++ " : " ++ show (delab ist ty))

5764-- iputStrLn (show pats)

@@ -150,7 +157,7 @@ mergePat ist (PApp _ _ args) (PApp fc f args') t

150157 where mergeArg x (y, t)

151158 = do tm' <- mergePat ist (getTm x) (getTm y) t

152159 case x of

153− (PImp _ _ _ _ _ _) ->

160+ (PImp _ _ _ _ _) ->

154161 return (y { machine_inf = machine_inf x,

155162 getTm = tm' })

156163 _ -> return (y { getTm = tm' })

@@ -273,6 +280,8 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

273280 nshow t = show t

274281

275282 -- if there's any {n} replace with {n=n}

283+ -- but don't replace it in comments

284+ expandBraces ('{' : '-' : xs) = '{' : '-' : xs

276285 expandBraces ('{' : xs)

277286 = let (brace, (_:rest)) = span (/= '}') xs in

278287 if (not ('=' `elem` brace))

@@ -291,9 +300,11 @@ replaceSplits l ups = updateRHSs 1 (map (rep (expandBraces l)) ups)

291300 if (before == n && not (isAlphaNum next))

292301 then addBrackets tm ++ updatePat False n tm after

293302 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

295304

296− addBrackets tm | ' ' `elem` tm = "(" ++ tm ++ ")"

305+ addBrackets tm | ' ' `elem` tm

306+ , not (isPrefixOf "(" tm)

307+ , not (isSuffixOf ")" tm) = "(" ++ tm ++ ")"

297308 | otherwise = tm

298309

299310getUniq nm i

@@ -313,19 +324,24 @@ getClause :: Int -- ^ line number that the type is declared on

313324 -> Name -- ^ Function name

314325 -> FilePath -- ^ Source file name

315326 -> Idris String

316−getClause l fn fp = do ty <- getInternalApp fp l

317− ist <- get

318− let ap = mkApp ist ty []

319− return (show fn ++ " " ++ ap ++

320− "= ?" ++ show fn ++ "_rhs")

321− where mkApp i (PPi (Exp _ _ _ False) (MN _ _) ty sc) used

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))

331+ _ -> do ty <- getInternalApp fp l

332+ ist <- get

333+ let ap = mkApp ist ty []

334+ return (show fn ++ " " ++ ap ++ "= ?"

335+ ++ show fn ++ "_rhs")

336+ where mkApp :: IState -> PTerm -> [Name] -> String

337+ mkApp i (PPi (Exp _ _ False) (MN _ _) ty sc) used

322338 = let n = getNameFrom i used ty in

323339 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

325341 | thead n == '_'

326342 = let n = getNameFrom i used ty in

327343 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

329345 = show n ++ " " ++ mkApp i sc (n : used)

330346 mkApp i (PPi _ _ _ sc) used = mkApp i sc used

331347 mkApp i _ _ = ""

@@ -340,6 +356,19 @@ getClause l fn fp = do ty <- getInternalApp fp l

340356 ns -> uniqueNameFrom (mkSupply ns) used

341357 getNameFrom i used _ = uniqueName (sUN "x") used

342358

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+

343372getProofClause :: Int -- ^ line number that the type is declared

344373 -> Name -- ^ Function name

345374 -> FilePath -- ^ Source file name

@@ -355,16 +384,19 @@ getProofClause l fn fp

355384

356385mkWith :: String -> Name -> String

357386mkWith 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

361388

362389 where replaceRHS [] str = str

363390 replaceRHS ('?':'=': rest) str = str

364− replaceRHS ('=': rest) str

391+ replaceRHS ('=': rest) str

365392 | not ('=' `elem` rest) = str

366393 replaceRHS (x : rest) str = x : replaceRHS rest str

367394

395+ newpat ('>':patstr) = '>':newpat patstr

396+ newpat patstr =

397+ " " ++

398+ replaceRHS patstr "| with_pat = ?" ++ show n ++ "_rhs"

399+

368400-- Replace _ with names in missing clauses

369401

370402nameMissing :: [PTerm] -> Idris [PTerm]

src/Idris/Chaser.hs+1−1

@@ -82,7 +82,7 @@ buildTree built fp = btree [] fp

8282 iLOG $ "CHASING " ++ show file

8383 ibcsd <- valIBCSubDir i

8484 ids <- allImportDirs

85− fp <- runIO $ findImport ids ibcsd file

85+ fp <- findImport ids ibcsd file

8686 iLOG $ "Found " ++ show fp

8787 mt <- runIO $ getIModTime fp

8888 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 (

22 IdrisColour(..),

33 ColourTheme(..),

44 defaultTheme,

5− colouriseKwd, colouriseBound, colouriseImplicit,

6− colouriseType, colouriseFun, colouriseData,

7− colourisePrompt,

8− ColourType(..)) where

5+ colouriseKwd, colouriseBound, colouriseImplicit, colourisePostulate,

6+ colouriseType, colouriseFun, colouriseData, colouriseKeyword,

7+ colourisePrompt, colourise, ColourType(..)) where

98

109import System.Console.ANSI

1110

@@ -20,27 +19,30 @@ data IdrisColour = IdrisColour { colour :: Maybe Color

2019mkColour :: Color -> IdrisColour

2120mkColour c = IdrisColour (Just c) True False False False

2221

23−data ColourTheme = ColourTheme { keywordColour :: IdrisColour

24− , boundVarColour :: IdrisColour

25− , implicitColour :: IdrisColour

26− , functionColour :: IdrisColour

27− , typeColour :: IdrisColour

28− , dataColour :: IdrisColour

29− , promptColour :: IdrisColour

22+data ColourTheme = ColourTheme { keywordColour :: IdrisColour

23+ , boundVarColour :: IdrisColour

24+ , implicitColour :: IdrisColour

25+ , functionColour :: IdrisColour

26+ , typeColour :: IdrisColour

27+ , dataColour :: IdrisColour

28+ , promptColour :: IdrisColour

29+ , postulateColour :: IdrisColour

3030 }

3131 deriving (Eq, Show)

3232

33+-- | Idris's default console colour theme

3334defaultTheme :: ColourTheme

34−defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True True True False

35+defaultTheme = ColourTheme { keywordColour = IdrisColour Nothing True False True False

3536 , boundVarColour = mkColour Magenta

3637 , implicitColour = IdrisColour (Just Magenta) True True False False

3738 , functionColour = mkColour Green

3839 , typeColour = mkColour Blue

3940 , dataColour = mkColour Red

4041 , promptColour = IdrisColour Nothing True False True False

42+ , postulateColour = IdrisColour (Just Green) True False True False

4143 }

4244

43−-- Set the colour of a string using POSIX escape codes

45+-- | Set the colour of a string using POSIX escape codes

4446colourise :: IdrisColour -> String -> String

4547colourise (IdrisColour c v u b i) str = setSGRCode sgr ++ str ++ setSGRCode [Reset]

4648 where sgr = fg c ++

@@ -71,6 +73,12 @@ colouriseData t = colourise (dataColour t)

7173colourisePrompt :: ColourTheme -> String -> String

7274colourisePrompt t = colourise (promptColour t)

7375

76+colouriseKeyword :: ColourTheme -> String -> String

77+colouriseKeyword t = colourise (keywordColour t)

78+

79+colourisePostulate :: ColourTheme -> String -> String

80+colourisePostulate t = colourise (postulateColour t)

81+

7482

7583data ColourType = KeywordColour

7684 | BoundVarColour

@@ -79,4 +87,5 @@ data ColourType = KeywordColour

7987 | TypeColour

8088 | DataColour

8189 | PromptColour

90+ | PostulateColour

8291 deriving (Eq, Show, Bounded, Enum)

src/Idris/Completion.hs+8−2

@@ -51,7 +51,7 @@ tacticArgs = [ ("intro", Nothing) -- FIXME syntax for intro (fresh name)

5151 , (":eval", Just ExprTArg)

5252 ] ++ map (\x -> (x, Nothing)) [

5353 "intros", "compute", "trivial", "search", "solve", "attack",

54− "state", "term", "undo", "qed", "abandon", ":q"

54+ "unify", "state", "term", "undo", "qed", "abandon", ":q"

5555 ]

5656tactics = map fst tacticArgs

5757

@@ -108,7 +108,12 @@ completeMetaVar = completeWord Nothing (" \t(){}:" ++ opChars) completeM

108108

109109completeOption :: CompletionFunc Idris

110110completeOption = completeWord Nothing " \t" completeOpt

111− where completeOpt = return . completeWith ["errorcontext", "showimplicits", "originalerrors"]

111+ where completeOpt = return . completeWith [ "errorcontext"

112+ , "showimplicits"

113+ , "originalerrors"

114+ , "autosolve"

115+ , "nobanner"

116+ ]

112117

113118completeConsoleWidth :: CompletionFunc Idris

114119completeConsoleWidth = completeWord Nothing " \t" completeW

@@ -156,6 +161,7 @@ completeCmd cmd (prev, next) = fromMaybe completeCmdName $ fmap completeArg $ lo

156161 completeArg NameArg = completeExpr [] (prev, next) -- FIXME only complete one name

157162 completeArg OptionArg = completeOption (prev, next)

158163 completeArg ModuleArg = noCompletion (prev, next) -- FIXME do later

164+ completeArg NamespaceArg = noCompletion (prev, next) -- FIXME do later

159165 completeArg ExprArg = completeExpr [] (prev, next)

160166 completeArg MetaVarArg = completeMetaVar (prev, next) -- FIXME only complete one name

161167 completeArg ColourArg = completeColour (prev, next)

src/Idris/Core/CaseTree.hs+189−106

@@ -2,20 +2,34 @@

22

33module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..),

44 Phase(..), CaseTree,

5− simpleCase, small, namesUsed, findCalls, findUsedArgs) where

5+ simpleCase, small, namesUsed, findCalls, findUsedArgs,

6+ substSC, substAlt, mkForce) where

67

78import Idris.Core.TT

89

910import Control.Monad.State

1011import Data.Maybe

1112import Data.List hiding (partition)

13+import qualified Data.List(partition)

1214import Debug.Trace

1315

1416data CaseDef = CaseDef [Name] !SC [Term]

1517 deriving Show

1618

17−data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

18− | ProjCase t [CaseAlt' t] -- ^ special case for projections

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+--

31+data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

32+ | ProjCase t [CaseAlt' t] -- ^ special case for projections/thunk-forcing before inspection

1933 | STerm !t

2034 | UnmatchedCase String -- ^ error message

2135 | ImpossibleCase -- ^ already checked to be impossible

@@ -96,8 +110,7 @@ small n args t = let as = findAllUsedArgs t args in

96110namesUsed :: SC -> [Name]

97111namesUsed sc = nub $ nu' [] sc where

98112 nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n]

99− nu' ps (ProjCase t alts) = nub $ (nut ps t ++

100− (concatMap (nua ps) alts))

113+ nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts

101114 nu' ps (STerm t) = nub $ nut ps t

102115 nu' ps _ = []

103116

@@ -122,7 +135,7 @@ namesUsed sc = nub $ nu' [] sc where

122135findCalls :: SC -> [Name] -> [(Name, [[Name]])]

123136findCalls sc topargs = nub $ nu' topargs sc where

124137 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

126139 nu' ps (STerm t) = nub $ nut ps t

127140 nu' ps _ = []

128141

@@ -159,7 +172,7 @@ directUse fn@(App f a)

159172 | (P Ref (UN pfk) _, [App e w]) <- unApply fn,

160173 pfk == txt "prim_fork"

161174 = 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,

163176 fce == txt "Force"

164177 = directUse a -- forcing a value counts as a use

165178 | (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

185198 nua (SucCase _ sc) = nu' sc

186199 nua (DefaultCase sc) = nu' sc

187200

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+

188217data Phase = CompileTime | RunTime

189218 deriving (Show, Eq)

190219

@@ -192,10 +221,10 @@ data Phase = CompileTime | RunTime

192221-- Work Right to Left

193222

194223simpleCase :: Bool -> Bool -> Bool ->

195− Phase -> FC -> [Type] ->

224+ Phase -> FC -> [Int] -> [Type] ->

196225 [([Name], Term, Term)] ->

197226 TC CaseDef

198−simpleCase tc cover reflect phase fc argtys cs

227+simpleCase tc cover reflect phase fc inacc argtys cs

199228 = sc' tc cover phase fc (filter (\(_, _, r) ->

200229 case r of

201230 Impossible -> False

@@ -213,7 +242,7 @@ simpleCase tc cover reflect phase fc argtys cs

213242 OK pats ->

214243 let numargs = length (fst (head pats))

215244 ns = take numargs args

216− (ns', ps') = order ns pats

245+ (ns', ps') = order [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats

217246 (tree, st) = runState

218247 (match ns' ps' (defaultCase cover))

219248 ([], numargs, [])

@@ -382,21 +411,42 @@ partition xs = error $ "Partition " ++ show xs

382411-- reorder the patterns so that the one with most distinct names

383412-- comes next. Take rightmost first, otherwise (i.e. pick value rather

384413-- than dependency)

385−

386−order :: [Name] -> [Clause] -> ([Name], [Clause])

387−order [] cs = ([], cs)

388−order ns [] = (ns, [])

389−order ns cs = let patnames = transpose (map (zip ns) (map fst cs))

390− pats' = transpose (sortBy moreDistinct (reverse patnames)) in

391− (getNOrder pats', zipWith rebuild pats' cs)

414+--

415+-- The first argument means [(Name, IsInaccessible)].

416+

417+order :: [(Name, Bool)] -> [Clause] -> ([Name], [Clause])

418+order [] cs = ([], cs)

419+order ns' [] = (map fst ns', [])

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

428+ pats' = transpose (sortBy moreDistinct (reverse patnames_ord)

429+ ++ patnames_rest) in

430+ (getNOrder pats', zipWith rebuild pats' cs)

392431 where

393− getNOrder [] = error $ "Failed order on " ++ show (ns, cs)

394− getNOrder (c : _) = map fst c

432+ getNOrder [] = error $ "Failed order on " ++ show (map fst ns', cs)

433+ getNOrder (c : _) = map (fst . fst) c

395434

396435 rebuild patnames clause = (map snd patnames, snd clause)

397436

398− moreDistinct xs ys = compare (numNames [] (map snd ys))

399− (numNames [] (map snd xs))

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)

448+ moreDistinct xs ys = compare (snd . fst . head $ xs, numNames [] (map snd ys))

449+ (snd . fst . head $ ys, numNames [] (map snd xs))

400450

401451 numNames xs (PCon n _ _ : ps)

402452 | not (Left n `elem` xs) = numNames (Left n : xs) ps

@@ -576,91 +626,79 @@ depatt ns tm = dp [] tm

576626-- FIXME: Do this for SucCase too

577627prune :: Bool -- ^ Convert single branches to projections (only useful at runtime)

578628 -> SC -> SC

579−prune proj (Case n alts)

580− = let alts' = filter notErased (map pruneAlt alts) in

581− case alts' of

582− [] -> ImpossibleCase

583− as@(ConCase (UN delay) i [arg] sc : _)

584− | delay == txt "Delay"

585− -> if proj then mkForce n arg sc

586− else Case n as

587− as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc

588− else Case n as

589− as@[SucCase cn sc] -> if proj then mkProj n (-1) [cn] sc

590− else Case n as

591− as@[ConstCase _ sc] -> prune proj sc

592− -- Bit of a hack here! The default case will always be 0, make sure

593− -- it gets caught first.

594− [s@(SucCase _ _), DefaultCase dc]

595− -> Case n [ConstCase (BI 0) dc, s]

596− as -> Case n as

597− where 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)

599− pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

600− pruneAlt (SucCase n sc) = SucCase n (prune proj sc)

601− pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

602−

603− notErased (DefaultCase (STerm Erased)) = False

604− notErased (DefaultCase ImpossibleCase) = False

605− notErased _ = True

606−

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

643− projRep arg n i (Case x alts)

644− | x == arg = ProjCase (Proj (P Bound n Erased) i)

645− (map (projRepAlt arg n i) alts)

646− | otherwise = Case x (map (projRepAlt arg n i) alts)

647− projRep arg n i (ProjCase t alts)

648− = 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)

650− projRep arg n i c = c -- unmatched

651−

652− projRepAlt arg n i (ConCase cn t args rhs)

653− = ConCase cn t args (projRep arg n i rhs)

654− projRepAlt arg n i (FnCase cn args rhs)

655− = FnCase cn args (projRep arg n i rhs)

656− projRepAlt arg n i (ConstCase t rhs)

657− = ConstCase t (projRep arg n i rhs)

658− projRepAlt arg n i (SucCase sn rhs)

659− = SucCase sn (projRep arg n i rhs)

660− projRepAlt arg n i (DefaultCase rhs)

661− = DefaultCase (projRep arg n i rhs)

662−

663− projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

629+prune proj (Case n alts) = case alts' of

630+ [] -> ImpossibleCase

631+

632+ -- Projection transformations prevent us from seeing some uses of ctor fields

633+ -- because they delete information about which ctor is being used.

634+ -- Consider:

635+ -- f (X x) = ... x ...

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

651+ then Case n [ConCase cn i args sc']

652+ else sc'

653+

654+ [SucCase cn sc]

655+ | proj

656+ -> projRep cn n (-1) $ prune proj sc

657+

658+ [ConstCase _ sc]

659+ -> prune proj sc

660+

661+ -- Bit of a hack here! The default case will always be 0, make sure

662+ -- it gets caught first.

663+ [s@(SucCase _ _), DefaultCase dc]

664+ -> Case n [ConstCase (BI 0) dc, s]

665+

666+ as -> Case n as

667+ where

668+ alts' = filter (not . erased) $ map pruneAlt alts

669+

670+ pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)

671+ pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)

672+ pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

673+ pruneAlt (SucCase n sc) = SucCase n (prune proj sc)

674+ pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

675+

676+ erased (DefaultCase (STerm Erased)) = True

677+ erased (DefaultCase ImpossibleCase) = True

678+ erased _ = False

679+

680+ projRep :: Name -> Name -> Int -> SC -> SC

681+ projRep arg n i (Case x alts) | x == arg

682+ = ProjCase (Proj (P Bound n Erased) i) $ map (projRepAlt arg n i) alts

683+ projRep arg n i (Case x alts)

684+ = Case x (map (projRepAlt arg n i) alts)

685+ projRep arg n i (ProjCase t alts)

686+ = ProjCase (projRepTm arg n i t) $ map (projRepAlt arg n i) alts

687+ projRep arg n i (STerm t) = STerm (projRepTm arg n i t)

688+ projRep arg n i c = c

689+

690+ projRepAlt arg n i (ConCase cn t args rhs)

691+ = ConCase cn t args (projRep arg n i rhs)

692+ projRepAlt arg n i (FnCase cn args rhs)

693+ = FnCase cn args (projRep arg n i rhs)

694+ projRepAlt arg n i (ConstCase t rhs)

695+ = ConstCase t (projRep arg n i rhs)

696+ projRepAlt arg n i (SucCase sn rhs)

697+ = SucCase sn (projRep arg n i rhs)

698+ projRepAlt arg n i (DefaultCase rhs)

699+ = DefaultCase (projRep arg n i rhs)

700+

701+ projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

664702

665703prune _ t = t

666704

@@ -669,6 +707,51 @@ stripLambdas (CaseDef ns (STerm (Bind x (Lam _) sc)) tm)

669707 = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm)

670708stripLambdas x = x

671709

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

672742

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)

673753

754+ forceTm n arg t = subst arg (forceArg n) t

674755

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 ()

6464loadState = do (ES p s e) <- get

6565 case e of

6666 Just st -> put st

67− _ -> fail "Nothing to undo"

67+ _ -> lift $ Error . Msg $ "Nothing to undo"

6868

6969getNameFrom :: Name -> Elab' aux Name

7070getNameFrom n = do (ES (p, a) s e) <- get

@@ -131,14 +131,17 @@ force_term :: Elab' aux ()

131131force_term = do ES (ps, a) l p <- get

132132 put (ES (ps { pterm = force (pterm ps) }, a) l p)

133133

134+-- | Modify the auxiliary state

134135updateAux :: (aux -> aux) -> Elab' aux ()

135136updateAux f = do ES (ps, a) l p <- get

136137 put (ES (ps, f a) l p)

137138

139+-- | Get the auxiliary state

138140getAux :: Elab' aux aux

139141getAux = do ES (ps, a) _ _ <- get

140142 return $! a

141143

144+-- | Set whether to show the unifier log

142145unifyLog :: Bool -> Elab' aux ()

143146unifyLog log = do ES (ps, a) l p <- get

144147 put (ES (ps { unifylog = log }, a) l p)

@@ -147,11 +150,28 @@ getUnifyLog :: Elab' aux Bool

147150getUnifyLog = do ES (ps, a) l p <- get

148151 return (unifylog ps)

149152

153+-- | Process a tactic within the current elaborator state

154+processTactic' :: Tactic -> Elab' aux ()

150155processTactic' t = do ES (p, a) logs prev <- get

151156 (p', log) <- lift $ processTactic t p

152157 put (ES (p', a) (logs ++ log) prev)

153158 return $! ()

154159

160+updatePS :: (ProofState -> ProofState) -> Elab' aux ()

161+updatePS f = do ES (ps, a) logs prev <- get

162+ put $ ES (f ps, a) logs prev

163+

164+now_elaborating :: FC -> Name -> Name -> Elab' aux ()

165+now_elaborating fc f a = updatePS (nowElaboratingPS fc f a)

166+done_elaborating_app :: Name -> Elab' aux ()

167+done_elaborating_app f = updatePS (doneElaboratingAppPS f)

168+done_elaborating_arg :: Name -> Name -> Elab' aux ()

169+done_elaborating_arg f a = updatePS (doneElaboratingArgPS f a)

170+elaborating_app :: Elab' aux [(FC, Name, Name)]

171+elaborating_app = do ES (ps, _) _ _ <- get

172+ return $ map (\ (FailContext x y z) -> (x, y, z))

173+ (while_elaborating ps)

174+

155175-- Some handy gadgets for pulling out bits of state

156176

157177-- get the global context

@@ -308,6 +328,10 @@ start_unify n = processTactic' (StartUnify n)

308328end_unify :: Elab' aux ()

309329end_unify = processTactic' EndUnify

310330

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+

311335regret :: Elab' aux ()

312336regret = processTactic' Regret

313337

@@ -595,10 +619,10 @@ simple_app fun arg appstr =

595619 hs <- get_holes

596620 env <- get_env

597621 -- We don't need a and b in the hole queue any more since they were

598− -- just for checking f, so discard them if they are still there.

599− -- If they haven't been solved, regret will fail

600− when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr)

601− when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr)

622+ -- just for checking f, so move them to the end. If they never end up

623+ -- getting solved, we'll get an 'Incomplete term' error.

624+ when (a `elem` hs) $ do movelast a

625+ when (b `elem` hs) $ do movelast b

602626 end_unify

603627 where regretWith err = try regret

604628 (lift $ tfail err)

@@ -622,12 +646,16 @@ no_errors tac err

622646 Error _ -> lift $ Error e

623647 OK (a, s') -> do put s'

624648 return a

649+ unifyProblems

625650 ps' <- get_probs

626651 if (length ps' > length ps) then

627652 case reverse ps' of

628− ((x,y,env,err,_) : _) ->

653+ ((x, y, env, inerr, while, _) : _) ->

629654 let env' = map (\(x, b) -> (x, binderTy b)) env in

630− lift $ tfail $ CantUnify False x y err env' 0

655+ lift $ tfail $

656+ case err of

657+ Nothing -> CantUnify False x y inerr env' 0

658+ Just e -> e

631659 else return $! ()

632660

633661-- Try a tactic, if it fails, try another

@@ -653,11 +681,13 @@ try' :: Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a

653681try' t1 t2 proofSearch

654682 = do s <- get

655683 ps <- get_probs

684+ ulog <- getUnifyLog

656685 case prunStateT 999999 False ps t1 s of

657686 OK ((v, _, _), s') -> do put s'

658687 return $! v

659− Error e1 -> if recoverableErr e1 then

660− do case runStateT t2 s of

688+ Error e1 -> traceWhen ulog ("try failed " ++ show e1) $

689+ if recoverableErr e1 then

690+ do case runStateT t2 s of

661691 OK (v, s') -> do put s'; return $! v

662692 Error e2 -> if score e1 >= score e2

663693 then lift (tfail e1)

@@ -667,7 +697,10 @@ try' t1 t2 proofSearch

667697 = -- traceWhen r (show err) $

668698 r || proofSearch

669699 recoverableErr (CantSolveGoal _ _) = False

700+ recoverableErr (ProofSearchFail (Msg _)) = True

670701 recoverableErr (ProofSearchFail _) = False

702+ recoverableErr (ElaboratingArg _ _ _ e) = recoverableErr e

703+ recoverableErr (At _ e) = recoverableErr e

671704 recoverableErr _ = True

672705

673706tryWhen :: Bool -> Elab' aux a -> Elab' aux a -> Elab' aux a

@@ -676,7 +709,7 @@ tryWhen False a b = a

676709

677710

678711-- 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

680713tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs

681714 where

682715 cantResolve :: Elab' aux a

@@ -685,7 +718,7 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs

685718 tryAll' :: [Elab' aux a] -> -- successes

686719 Int -> -- most problems

687720 (Elab' aux a, Int) -> -- smallest failure

688− [(Elab' aux a, String)] -> -- still to try

721+ [(Elab' aux a, Name)] -> -- still to try

689722 Elab' aux a

690723 tryAll' [res] pmax _ [] = res

691724 tryAll' (_:_) pmax _ [] = cantResolve

@@ -694,7 +727,7 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) xs

694727 = do s <- get

695728 ps <- get_probs

696729 case prunStateT pmax True ps x s of

697− OK ((v, newps, probs), s') ->

730+ OK ((v, newps, probs), s') ->

698731 do let cs' = if (newps < pmax)

699732 then [do put s'; return $! v]

700733 else (do put s'; return $! v) : cs

@@ -716,12 +749,12 @@ prunStateT pmax zok ps x s

716749 newpmax = if newps < 0 then 0 else newps in

717750 if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))

718751 then case reverse (problems p) of

719− ((_,_,_,e,_):_) -> Error e

752+ ((_,_,_,e,_,_):_) -> Error e

720753 else OK ((v, newpmax, problems p), s')

721754 Error e -> Error e

722755

723756qshow :: Fails -> String

724−qshow fs = show (map (\ (x, y, _, _, _) -> (x, y)) fs)

757+qshow fs = show (map (\ (x, y, _, _, _, _) -> (x, y)) fs)

725758

726759dumpprobs [] = ""

727760dumpprobs ((_,_,_,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,

88 Context, initContext, ctxtAlist, uconstraints, next_tvar,

99 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,

1010 addDatatype, addCasedef, simplifyCasedef, addOperator,

11− lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal,

11+ lookupNames, lookupTyName, lookupTy, lookupP, lookupDef, lookupNameDef, lookupDefExact, lookupDefAcc, lookupVal,

1212 mapDefCtxt,

1313 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

14− Value(..), Quote(..), initEval, uniqueNameCtxt) where

14+ Value(..), Quote(..), initEval, uniqueNameCtxt, uniqueBindersCtxt, definitions) where

1515

1616import Debug.Trace

17+import Control.Applicative hiding (Const)

1718import Control.Monad.State -- not Strict!

1819import qualified Data.Binary as B

1920import Data.Binary hiding (get, put)

@@ -257,11 +258,24 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

257258 return $ VBind True n (Let t' v') (\x -> return sc')

258259 ev ntimes stk top env (Bind n b sc)

259260 = do b' <- vbind env b

260− let n' = uniqueName n (map fst env)

261+ let n' = uniqueName n (map fst genv ++ map fst env)

261262 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)

263264 where vbind env t

264265 = 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'

265279 -- Treat "assert_total" specially, as long as it's defined!

266280 ev ntimes stk top env (App (App (P _ n@(UN at) _) _) arg)

267281 | [(CaseOp _ _ _ _ _ _, _)] <- lookupDefAcc n (spec || atRepl) ctxt,

@@ -523,7 +537,7 @@ wknV i t = return t

523537convEq' ctxt hs x y = evalStateT (convEq ctxt hs x y) (0, [])

524538

525539convEq :: 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

527541 ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs (TC' Err) Bool

528542 ceq ps (P xt x _) (P yt y _)

529543 | x `elem` holes || y `elem` holes = return True

@@ -536,8 +550,14 @@ convEq ctxt holes = ceq [] where

536550 ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y

537551 | n == n' = ceq ps x y

538552 ceq ps (V x) (V y) = return (x == y)

539− ceq ps (Bind _ xb xs) (Bind _ yb ys)

540− = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys)

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

559+ ceq ps (Bind n xb xs) (Bind n' yb ys)

560+ = liftM2 (&&) (ceqB ps xb yb) (ceq ((n,n'):ps) xs ys)

541561 where

542562 ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

543563 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

549569 return True

550570 ceq ps Erased _ = return True

551571 ceq ps _ Erased = return True

552− ceq ps _ _ = return False

572+ ceq ps x y = return False

553573

554574 caseeq ps (Case n cs) (Case n' cs') = caseeqA ((n,n'):ps) cs cs'

555575 where

@@ -662,7 +682,7 @@ data Totality = Total [Int] -- ^ well-founded arguments

662682

663683-- | Reasons why a function may not be total

664684data PReason = Other [Name] | Itself | NotCovering | NotPositive | UseUndef Name

665− | BelieveMe | Mutual [Name] | NotProductive

685+ | ExternalIO | BelieveMe | Mutual [Name] | NotProductive

666686 deriving (Show, Eq)

667687

668688instance Show Totality where

@@ -672,6 +692,7 @@ instance Show Totality where

672692 show (Partial Itself) = "possibly not total as it is not well founded"

673693 show (Partial NotCovering) = "not total as there are missing cases"

674694 show (Partial NotPositive) = "not strictly positive"

695+ show (Partial ExternalIO) = "an external IO primitive"

675696 show (Partial NotProductive) = "not productive"

676697 show (Partial BelieveMe) = "not total due to use of believe_me in proof"

677698 show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns)

@@ -769,6 +790,7 @@ addDatatype (Data n tag ty cons) uctxt

769790-- FIXME: Too many arguments! Refactor all these Bools.

770791addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

771792 [Type] -> -- argument types

793+ [Int] -> -- inaccessible arguments

772794 [Either Term (Term, Term)] ->

773795 [([Name], Term, Term)] -> -- totality

774796 [([Name], Term, Term)] -> -- compile time

@@ -776,16 +798,16 @@ addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

776798 [([Name], Term, Term)] -> -- run time

777799 Type -> Context -> Context

778800addCasedef n ci@(CaseInfo alwaysInline tcdict)

779− tcase covering reflect asserted argtys

801+ tcase covering reflect asserted argtys inacc

780802 ps_in ps_tot ps_inl ps_ct ps_rt ty uctxt

781803 = let ctxt = definitions uctxt

782804 access = case lookupDefAcc n False uctxt of

783805 [(_, acc)] -> acc

784806 _ -> Public

785− ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC argtys ps_tot,

786− simpleCase tcase covering reflect CompileTime emptyFC argtys ps_ct,

787− simpleCase tcase covering reflect CompileTime emptyFC argtys ps_inl,

788− simpleCase tcase covering reflect RunTime emptyFC argtys ps_rt) of

807+ ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_tot,

808+ simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_ct,

809+ simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_inl,

810+ simpleCase tcase covering reflect RunTime emptyFC inacc argtys ps_rt) of

789811 (OK (CaseDef args_tot sc_tot _),

790812 OK (CaseDef args_ct sc_ct _),

791813 OK (CaseDef args_inl sc_inl _),

@@ -812,7 +834,7 @@ simplifyCasedef n uctxt

812834 [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] ->

813835 let ps_in' = map simpl ps_in

814836 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

816838 OK (CaseDef args sc _) ->

817839 addDef n (CaseOp ci

818840 ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }),

@@ -846,14 +868,19 @@ lookupNames n ctxt

846868 = let ns = lookupCtxtName n (definitions ctxt) in

847869 map fst ns

848870

849−lookupTy :: Name -> Context -> [Type]

850−lookupTy n ctxt

851− = do def <- lookupCtxt n (definitions ctxt)

852− case tfst def of

871+lookupTyName :: Name -> Context -> [(Name, Type)]

872+lookupTyName n ctxt = do

873+ (name, def) <- lookupCtxtName n (definitions ctxt)

874+ ty <- case tfst def of

853875 (Function ty _) -> return ty

854876 (TyDecl _ ty) -> return ty

855877 (Operator ty _ _) -> return ty

856878 (CaseOp _ ty _ _ _ _) -> return ty

879+ return (name, ty)

880+

881+

882+lookupTy :: Name -> Context -> [Type]

883+lookupTy n ctxt = map snd (lookupTyName n ctxt)

857884

858885isConName :: Name -> Context -> Bool

859886isConName n ctxt = isTConName n ctxt || isDConName n ctxt

@@ -874,12 +901,12 @@ isDConName n ctxt

874901

875902isFnName :: Name -> Context -> Bool

876903isFnName n ctxt

877− = or $ do def <- lookupCtxt n (definitions ctxt)

878− case tfst def of

879− (Function _ _) -> return True

880− (Operator _ _ _) -> return True

881− (CaseOp _ _ _ _ _ _) -> return True

882− _ -> return False

904+ = let def = lookupCtxtExact n (definitions ctxt) in

905+ case def of

906+ Just (Function _ _, _, _, _) -> True

907+ Just (Operator _ _ _, _, _, _) -> True

908+ Just (CaseOp _ _ _ _ _ _, _, _, _) -> True

909+ _ -> False

883910

884911lookupP :: Name -> Context -> [Term]

885912lookupP n ctxt

@@ -893,8 +920,16 @@ lookupP n ctxt

893920 Hidden -> []

894921 _ -> return (fst p)

895922

923+lookupDefExact :: Name -> Context -> Maybe Def

924+lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)

925+

896926lookupDef :: 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

898933

899934lookupDefAcc :: Name -> Bool -> Context ->

900935 [(Def, Accessibility)]

@@ -936,3 +971,10 @@ uniqueNameCtxt ctxt n hs

936971 | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs

937972 | [_] <- lookupTy n ctxt = uniqueNameCtxt ctxt (nextName n) hs

938973 | 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

1111import Idris.Core.Evaluate

1212import Idris.Core.CaseTree

1313

14+import Idris.Error

15+

1416import Debug.Trace

1517

1618import Util.DynamicLinker

@@ -47,11 +49,8 @@ readMay s = case reads s of

4749

4850data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show

4951

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

54− }

52+newtype ExecState = ExecState { exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad

53+ }

5554

5655data ExecVal = EP NameType Name ExecVal

5756 | EV Int

@@ -61,20 +60,20 @@ data ExecVal = EP NameType Name ExecVal

6160 | EErased

6261 | EConstant Const

6362 | forall a. EPtr (Ptr a)

64− | EThunk Int

63+ | EThunk Context ExecEnv Term

6564 | EHandle Handle

6665

6766instance Show ExecVal where

68− show (EP _ n _) = show n

69− show (EV i) = "!!V" ++ show i ++ "!!"

70− show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

71− show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

72− show (EType _) = "Type"

73− show EErased = "[__]"

74− show (EConstant c) = show c

75− show (EPtr p) = "<<ptr " ++ show p ++ ">>"

76− show (EThunk i) = "<<thunk " ++ show i ++ ">>"

77− show (EHandle h) = "<<handle " ++ show h ++ ">>"

67+ show (EP _ n _) = show n

68+ show (EV i) = "!!V" ++ show i ++ "!!"

69+ show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

70+ show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

71+ show (EType _) = "Type"

72+ show EErased = "[__]"

73+ show (EConstant c) = show c

74+ show (EPtr p) = "<<ptr " ++ show p ++ ">>"

75+ show (EThunk _ env tm) = "<<thunk " ++ show env ++ "||||" ++ show tm ++ ">>"

76+ show (EHandle h) = "<<handle " ++ show h ++ ">>"

7877

7978toTT :: ExecVal -> Exec Term

8079toTT (EP nt n ty) = (P nt n) <$> (toTT ty)

@@ -82,22 +81,25 @@ toTT (EV i) = return $ V i

8281toTT (EBind n b body) = do body' <- body $ EP Bound n EErased

8382 b' <- fixBinder b

8483 Bind n b' <$> toTT body'

85− where fixBinder (Lam t) = Lam <$> toTT t

86− fixBinder (Pi t) = Pi <$> toTT t

87− fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

88− fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

89− fixBinder (Hole t) = Hole <$> toTT t

84+ where fixBinder (Lam t) = Lam <$> toTT t

85+ fixBinder (Pi t) = Pi <$> toTT t

86+ fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

87+ fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

88+ fixBinder (Hole t) = Hole <$> toTT t

9089 fixBinder (GHole i t) = GHole i <$> toTT t

91− fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2

92− fixBinder (PVar t) = PVar <$> toTT t

93− fixBinder (PVTy t) = PVTy <$> toTT t

90+ fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2

91+ fixBinder (PVar t) = PVar <$> toTT t

92+ fixBinder (PVTy t) = PVTy <$> toTT t

9493toTT (EApp e1 e2) = do e1' <- toTT e1

9594 e2' <- toTT e2

9695 return $ App e1' e2'

9796toTT (EType u) = return $ TType u

9897toTT EErased = return Erased

9998toTT (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')

101103toTT (EHandle _) = return Erased

102104

103105unApplyV :: ExecVal -> (ExecVal, [ExecVal])

@@ -111,11 +113,11 @@ mkEApp f (a:args) = mkEApp (EApp f a) args

111113

112114initState :: Idris ExecState

113115initState = do ist <- getIState

114− return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)

116+ return $ ExecState (idris_dynamic_libs ist)

115117

116−type Exec = ErrorT String (StateT ExecState IO)

118+type Exec = ErrorT Err (StateT ExecState IO)

117119

118−runExec :: Exec a -> ExecState -> IO (Either String a)

120+runExec :: Exec a -> ExecState -> IO (Either Err a)

119121runExec ex st = fst <$> runStateT (runErrorT ex) st

120122

121123getExecState :: Exec ExecState

@@ -124,53 +126,21 @@ getExecState = lift get

124126putExecState :: ExecState -> Exec ()

125127putExecState = lift . put

126128

127−execFail :: String -> Exec a

129+execFail :: Err -> Exec a

128130execFail = throwError

129131

130132execIO :: IO a -> Exec a

131133execIO = lift . lift

132134

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)))

166135

167136execute :: Term -> Idris Term

168137execute tm = do est <- initState

169138 ctxt <- getContext

170− res <- lift . lift $ flip runExec est $ do res <- doExec [] ctxt tm

171− toTT res

139+ res <- lift . lift . flip runExec est $

140+ do res <- doExec [] ctxt tm

141+ toTT res

172142 case res of

173− Left err -> fail err

143+ Left err -> ierror err

174144 Right tm' -> return tm'

175145

176146ioWrap :: ExecVal -> ExecVal

@@ -192,23 +162,34 @@ doExec env ctxt p@(P Ref n ty) =

192162 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun

193163 doExec env ctxt tm

194164 [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."

196166 thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined

197167doExec env ctxt p@(P Bound n ty) =

198168 case lookup n env of

199− Nothing -> execFail "not found"

169+ Nothing -> execFail . Msg $ "not found"

200170 Just tm -> return tm

201171doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)

202172doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)

203173doExec 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"

205175doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v

206176 doExec ((n, v'):env) ctxt body

207177doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined

208178doExec env ctxt tm@(Bind n b body) = return $

209179 EBind n (fmap (\_->EErased) b)

210180 (\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'

212193doExec env ctxt (Constant c) = return (EConstant c)

213194doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in

214195 doExec env ctxt ((x:xs) !! i)

@@ -216,120 +197,138 @@ doExec env ctxt Erased = return EErased

216197doExec env ctxt Impossible = fail "Tried to execute an impossible case"

217198doExec env ctxt (TType u) = return (EType u)

218199

219−execApp :: ExecEnv -> Context -> (Term, [Term]) -> 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

240−execApp' env ctxt (EP _ fp _) (ty:action:rest)

200+execApp :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

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

207+execApp env ctxt (EP _ fp _) (ty:action:rest)

241208 | fp == upio,

242209 (prim__IO, [_, v]) <- unApplyV action

243− = execApp' env ctxt v rest

210+ = execApp env ctxt v rest

244211

245−execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest)

212+execApp env ctxt (EP _ fp _) args@(_:_:v:k:rest)

246213 | fp == piobind,

247214 (prim__IO, [_, v']) <- unApplyV v =

248− do v'' <- tryForce v'

249− res <- execApp' env ctxt k [v''] >>= tryForce

250− execApp' env ctxt res rest

251−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

215+ do res <- execApp env ctxt k [v']

216+ execApp env ctxt res rest

217+execApp env ctxt con@(EP _ fp _) args@(tp:v:rest)

218+ | fp == pioret = execApp env ctxt (mkEApp con [tp, v]) rest

255219

256220-- 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)

258232 | fp == mkfprim,

259− Just (FFun "putStr" _ _) <- foreignFromTT fn

260− = do execIO (putStr arg)

261− execApp' env ctxt ioUnit rest

262−execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

233+ Just (FFun "putchar" _ _) <- foreignFromTT fn

234+ = case ch of

235+ EConstant (Ch c) -> do execIO (putChar c)

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?"

243+execApp env ctxt (EP _ fp _) (_:fn:_:handle:_:rest)

263244 | fp == mkfprim,

264245 Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

265− = do contents <- execIO $ hGetLine h

266− execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

267−execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

246+ = case handle of

247+ EHandle h -> do contents <- execIO $ hGetLine h

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?"

253+execApp env ctxt (EP _ fp _) (_:fn:fileStr:modeStr:rest)

268254 | fp == mkfprim,

269255 Just (FFun "fileOpen" _ _) <- foreignFromTT fn

270− = do f <- execIO $

271− catch (do let m = case mode of

272− "r" -> Right ReadMode

273− "w" -> Right WriteMode

274− "a" -> Right AppendMode

275− "rw" -> Right ReadWriteMode

276− "wr" -> Right ReadWriteMode

277− "r+" -> Right ReadWriteMode

278− _ -> Left ("Invalid mode for " ++ f ++ ": " ++ mode)

279− case fmap (openFile f) m of

280− Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest)

281− Left err -> return $ Left err)

282− (\e -> let _ = ( e::SomeException)

283− in return $ Right (ioWrap (EPtr nullPtr), tail rest))

284− case f of

285− Left err -> execFail err

286− Right (res, rest) -> execApp' env ctxt res rest

287−

288−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

256+ = case (fileStr, modeStr) of

257+ (EConstant (Str f), EConstant (Str mode)) ->

258+ do f <- execIO $

259+ catch (do let m = case mode of

260+ "r" -> Right ReadMode

261+ "w" -> Right WriteMode

262+ "a" -> Right AppendMode

263+ "rw" -> Right ReadWriteMode

264+ "wr" -> Right ReadWriteMode

265+ "r+" -> Right ReadWriteMode

266+ _ -> Left ("Invalid mode for " ++ f ++ ": " ++ mode)

267+ case fmap (openFile f) m of

268+ Right h -> do h' <- h; return $ Right (ioWrap (EHandle h'), tail rest)

269+ Left err -> return $ Left err)

270+ (\e -> let _ = ( e::SomeException)

271+ in return $ Right (ioWrap (EPtr nullPtr), tail rest))

272+ case f of

273+ Left err -> execFail . Msg $ err

274+ Right (res, rest) -> execApp env ctxt res rest

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+

280+execApp env ctxt (EP _ fp _) (_:fn:handle:rest)

289281 | fp == mkfprim,

290282 Just (FFun "fileEOF" _ _) <- foreignFromTT fn

291− = do eofp <- execIO $ hIsEOF h

292− let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

293− execApp' env ctxt res (tail rest)

294−

295−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

283+ = case handle of

284+ EHandle h -> do eofp <- execIO $ hIsEOF h

285+ let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

286+ execApp env ctxt res (tail rest)

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+

292+execApp env ctxt (EP _ fp _) (_:fn:handle:rest)

296293 | fp == mkfprim,

297294 Just (FFun "fileClose" _ _) <- foreignFromTT fn

298− = do execIO $ hClose h

299− execApp' env ctxt ioUnit (tail rest)

300−

301−execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

295+ = case handle of

296+ EHandle h -> do execIO $ hClose h

297+ execApp env ctxt ioUnit (tail rest)

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+

303+execApp env ctxt (EP _ fp _) (_:fn:ptr:rest)

302304 | fp == mkfprim,

303305 Just (FFun "isNull" _ _) <- foreignFromTT fn

304− = let res = ioWrap . EConstant . I $

305− if p == nullPtr then 1 else 0

306− in execApp' env ctxt res (tail rest)

306+ = case ptr of

307+ EPtr p -> let res = ioWrap . EConstant . I $

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

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?"

307321

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)

322322

323323-- Right now, there's no way to send command-line arguments to the executor,

324324-- so just return 0.

325−execApp' env ctxt (EP _ fp _) (_:fn:rest)

325+execApp env ctxt (EP _ fp _) (_:fn:rest)

326326 | fp == mkfprim,

327327 Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn

328328 = let res = ioWrap . EConstant . I $ 0

329− in execApp' env ctxt res (tail rest)

330−-- Throw away the 'World' argument to the foreign function

329+ in execApp env ctxt res (tail rest)

331330

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

333332 = case foreignFromTT fn of

334333 Just (FFun f argTs retT) | length xs >= length argTs ->

335334 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

341340 Just r -> return (mkEApp r xs')

342341 Nothing -> return (mkEApp f args)

343342

344−execApp' env ctxt c@(EP (DCon _ arity) n _) args =

345− do args' <- mapM tryForce (take arity args)

343+execApp env ctxt c@(EP (DCon _ arity) n _) args =

344+ do let args' = take arity args

346345 let restArgs = drop arity args

347− execApp' env ctxt (mkEApp c args') restArgs

346+ execApp env ctxt (mkEApp c args') restArgs

348347

349−execApp' env ctxt c@(EP (TCon _ arity) n _) args =

350− do args' <- mapM tryForce (take arity args)

348+execApp env ctxt c@(EP (TCon _ arity) n _) args =

349+ do let args' = take arity args

351350 let restArgs = drop arity args

352− execApp' env ctxt (mkEApp c args') restArgs

351+ execApp env ctxt (mkEApp c args') restArgs

353352

354−execApp' env ctxt f@(EP _ n _) args =

353+execApp env ctxt f@(EP _ n _) args =

355354 do let val = lookupDef n ctxt

356355 case val of

357356 [Function _ tm] -> fail "should already have been eval'd"

358357 [TyDecl nt ty] -> return $ mkEApp f args

359358 [Operator tp arity op] ->

360359 if length args >= arity

361− then do args' <- mapM tryForce $ take arity args

362− case getOp n args' of

363− Just res -> do r <- res

364− execApp' env ctxt r (drop arity args)

365− Nothing -> return (mkEApp f args)

360+ then let args' = take arity args in

361+ case getOp n args' of

362+ Just res -> do r <- res

363+ execApp env ctxt r (drop arity args)

364+ Nothing -> return (mkEApp f args)

366365 else return (mkEApp f args)

367366 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun

368367 do rhs <- doExec env ctxt tm

369− execApp' env ctxt rhs args

368+ execApp env ctxt rhs args

370369 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->

371370 do res <- execCase env ctxt ns sc args

372371 return $ fromMaybe (mkEApp f args) res

373372 thing -> return $ mkEApp f args

374−execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg

375− let (f', as) = unApplyV ret

376− 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)

380−execApp' env ctxt f args = return (mkEApp f args)

373+execApp env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg

374+ let (f', as) = unApplyV ret

375+ execApp env ctxt f' (as ++ args)

376+execApp env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp env ctxt f (args1 ++ args2)

377+execApp env ctxt f args = return (mkEApp f args)

381378

382379prs = sUN "prim__readString"

383380pbm = sUN "prim__believe_me"

@@ -386,6 +383,8 @@ mkfprim = sUN "mkForeignPrim"

386383pioret = sUN "prim_io_return"

387384piobind = sUN "prim_io_bind"

388385upio = sUN "unsafePerformPrimIO"

386+delay = sUN "Delay"

387+force = sUN "Force"

389388

390389-- | Look up primitive operations in the global table and transform them into ExecVal functions

391390getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

@@ -426,7 +425,7 @@ execCase env ctxt ns sc args =

426425-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()

427426 caseRes <- execCase' env ctxt amap sc

428427 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)

430429 Nothing -> return Nothing

431430 else return Nothing

432431

@@ -436,8 +435,7 @@ execCase' env ctxt amap (UnmatchedCase _) = return Nothing

436435execCase' env ctxt amap (STerm tm) =

437436 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm

438437execCase' 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

441439 Just (newCase, newBindings) ->

442440 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in

443441 execCase' env ctxt amap' newCase

src/Idris/Core/ProofState.hs+106−36

@@ -5,8 +5,8 @@

55 evaluation/checking inside the proof system, etc. --}

66

77module Idris.Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,

8− Tactic(..), Goal(..), processTactic,

9− dropGiven, keepGiven) where

8+ Tactic(..), Goal(..), processTactic, nowElaboratingPS, doneElaboratingAppPS,

9+ doneElaboratingArgPS, dropGiven, keepGiven) where

1010

1111import Idris.Core.Typecheck

1212import Idris.Core.Evaluate

@@ -15,6 +15,7 @@ import Idris.Core.Unify

1515

1616import Control.Monad.State.Strict

1717import Control.Applicative hiding (empty)

18+import Control.Arrow ((***))

1819import Data.List

1920import Debug.Trace

2021

@@ -38,7 +39,8 @@ data ProofState = PS { thname :: Name,

3839 context :: Context,

3940 plog :: String,

4041 unifylog :: Bool,

41− done :: Bool

42+ done :: Bool,

43+ while_elaborating :: [FailContext]

4244 }

4345

4446data Goal = GD { premises :: Env,

@@ -57,6 +59,7 @@ data Tactic = Attack

5759 | Solve

5860 | StartUnify Name

5961 | EndUnify

62+ | UnifyAll

6063 | Compute

6164 | ComputeLet Name

6265 | Simplify

@@ -89,9 +92,9 @@ data Tactic = Attack

8992-- Some utilites on proof and tactic states

9093

9194instance Show ProofState where

92− show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _)

95+ show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)

9396 = show nm ++ ": no more goals"

94− show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _)

97+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _ _)

9598 = let OK g = goal (Just h) tm

9699 wkenv = premises g in

97100 "Other goals: " ++ show hs ++ "\n" ++

@@ -114,9 +117,9 @@ instance Show ProofState where

114117 showG ps b = showEnv ps (binderTy b)

115118

116119instance Pretty ProofState OutputAnnotation where

117− pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

120+ pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) =

118121 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 _ _ _ _) =

120123 let OK g = goal (Just h) tm in

121124 let wkEnv = premises g in

122125 text "Other goals" <+> colon <+> pretty hs <+>

@@ -147,12 +150,13 @@ hole _ = False

147150holeName i = sMN i "hole"

148151

149152qshow :: 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)

151154

152155match_unify' :: Context -> Env -> TT Name -> TT Name ->

153156 StateT TState TC [(Name, TT Name)]

154157match_unify' ctxt env topx topy =

155158 do ps <- get

159+ let while = while_elaborating ps

156160 let dont = dontunify ps

157161 let inj = injective ps

158162 traceWhen (unifylog ps)

@@ -162,11 +166,11 @@ match_unify' ctxt env topx topy =

162166 ++ "\n"

163167 ++ "\n" ++ show (pterm ps) ++ "\n\n"

164168 ) $

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

166170 OK u -> do let (h, ns) = unified ps

167171 put (ps { unified = (h, u ++ ns) })

168172 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) :

170174 problems ps })

171175 return []

172176-- traceWhen (unifylog ps)

@@ -176,41 +180,61 @@ match_unify' ctxt env topx topy =

176180-- -- ++ show (pterm ps)

177181-- ++ "\n----------") $

178182

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+

179196unify' :: Context -> Env -> TT Name -> TT Name ->

180197 StateT TState TC [(Name, TT Name)]

181198unify' ctxt env topx topy =

182199 do ps <- get

200+ let while = while_elaborating ps

183201 let dont = dontunify ps

184202 let inj = injective ps

185203 (u, fails) <- traceWhen (unifylog ps)

186204 ("Trying " ++ show (topx, topy) ++

187205 "\nNormalised " ++ show (normalise ctxt env topx,

188− normalise ctxt env topy) ++

206+ normalise ctxt env topy) ++

189207 " in " ++ show env ++

190208 "\nHoles: " ++ show (holes ps)

191− ++ "\nInjective: " ++ show (injective ps)

209+ ++ "\nInjective: " ++ show (injective ps)

192210 ++ "\n") $

193− lift $ unify ctxt env topx topy inj (holes ps)

211+ lift $ unify ctxt env topx topy inj (holes ps) while

194212 let notu = filter (\ (n, t) -> case t of

195213 P _ _ _ -> False

196214 _ -> n `elem` dont) u

197215 traceWhen (unifylog ps)

198216 ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

199217 "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

200− ++ "\nNot unified:\n" ++ show (notunified ps)

218+ ++ "\nNot unified:\n" ++ show (notunified ps)

201219 ++ "\nCurrent problems:\n" ++ qshow (problems ps)

202220-- ++ show (pterm ps)

203221 ++ "\n----------") $

204− do ps <- get

205− let (h, ns) = unified ps

206− let (ns', probs') = updateProblems (context ps) (u ++ ns)

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

227+ let (ns', probs') = updateProblems (context ps) uns

207228 (fails ++ problems ps)

208229 (injective ps)

209230 (holes ps)

210− put (ps { problems = probs',

211− unified = (h, ns'),

212− injective = updateInj u (injective ps),

213− notunified = notu ++ notunified ps })

231+ let (notu', probs_notu) = mergeNotunified env (notu ++ notunified ps)

232+ traceWhen (unifylog ps)

233+ ("Now solved: " ++ show ns') $

234+ put (ps { problems = probs' ++ probs_notu,

235+ unified = (h, ns'),

236+ injective = updateInj u (injective ps),

237+ notunified = notu' })

214238 return u

215239 where updateInj ((n, a) : us) inj

216240 | (P _ n' _, _) <- unApply a,

@@ -220,6 +244,24 @@ unify' ctxt env topx topy =

220244 updateInj (_ : us) inj = updateInj us inj

221245 updateInj [] inj = inj

222246

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+

223265getName :: Monad m => String -> StateT TState m Name

224266getName tag = do ps <- get

225267 let n = nextname ps

@@ -230,6 +272,10 @@ action :: Monad m => (ProofState -> ProofState) -> StateT TState m ()

230272action a = do ps <- get

231273 put (a ps)

232274

275+query :: Monad m => (ProofState -> r) -> StateT TState m r

276+query q = do ps <- get

277+ return $ q ps

278+

233279addLog :: Monad m => String -> StateT TState m ()

234280addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

235281

@@ -240,7 +286,7 @@ newProof n ctxt ty = let h = holeName 0

240286 (P Bound h ty')) ty [] (h, []) []

241287 Nothing [] []

242288 [] []

243− Nothing ctxt "" False False

289+ Nothing ctxt "" False False []

244290

245291type TState = ProofState -- [TacticAction])

246292type RunTactic = Context -> Env -> Term -> StateT TState TC Term

@@ -491,7 +537,8 @@ solve ctxt env (Bind x (Guess ty val) sc)

491537 = do ps <- get

492538 let (uh, uns) = unified ps

493539 case lookup x (notunified ps) of

494− Just tm -> match_unify' ctxt env tm val

540+ Just tm -> -- trace ("NEED MATCH: " ++ show (tm, val)) $

541+ match_unify' ctxt env tm val

495542 _ -> return []

496543 action (\ps -> ps { holes = holes ps \\ [x],

497544 solved = Just (x, val),

@@ -637,10 +684,11 @@ induction nm ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' = do

637684 let scr = last $ tail args'

638685 let indxnames = makeIndexNames indicies

639686 prop <- replaceIndicies indxnames indicies $ Bind nm (Lam tmt') t

640− let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0)))

641− (params ++ [prop] ++ map makeConsArg consargs ++ indicies ++ [tmv])))

687+ consargs' <- query (\ps -> map (flip (uniqueNameCtxt (context ps)) (holes ps ++ allTTNames (pterm ps)) *** uniqueBindersCtxt (context ps) (holes ps ++ allTTNames (pterm ps))) consargs)

688+ let res = flip (foldr substV) params $ (substV prop $ bindConsArgs consargs' (mkApp (P Ref (SN (ElimN tnm)) (TType (UVal 0)))

689+ (params ++ [prop] ++ map makeConsArg consargs' ++ indicies ++ [tmv])))

642690 action (\ps -> ps {holes = holes ps \\ [x]})

643− mapM_ addConsHole (reverse consargs)

691+ mapM_ addConsHole (reverse consargs')

644692 let res' = forget $ res

645693 (scv, sct) <- lift $ check ctxt env res'

646694 let scv' = specialise ctxt env [] scv

@@ -753,13 +801,15 @@ keepGiven du (u@(n, _) : us) hs

753801 | n `elem` du = u : keepGiven du us hs

754802keepGiven du (u : us) hs = keepGiven du us hs

755803

804+updateSolved :: [(Name, Term)] -> Term -> Term

756805updateSolved xs x = updateSolved' xs x

757806updateSolved' [] x = x

758807updateSolved' xs (Bind n (Hole ty) t)

759808 | Just v <- lookup n xs

760809 = case xs of

761− [_] -> psubst n v t

762− _ -> psubst n v (updateSolved' xs t)

810+ [_] -> substV v $ psubst n v t -- some may be Vs! Can't assume

811+ -- explicit names

812+ _ -> substV v $ psubst n v (updateSolved' xs t)

763813updateSolved' xs (Bind n b t)

764814 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

765815updateSolved' xs (App f a)

@@ -773,6 +823,10 @@ updateEnv ns [] = []

773823updateEnv ns ((n, b) : env) = (n, fmap (updateSolved ns) b) : updateEnv ns env

774824

775825updateError [] 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)

776830updateError ns (CantUnify b l r e xs sc)

777831 = CantUnify b (updateSolved ns l) (updateSolved ns r) (updateError ns e) xs sc

778832updateError ns e = e

@@ -782,42 +836,53 @@ solveInProblems x val ((l, r, env, err) : ps)

782836 = ((psubst x val l, psubst x val r,

783837 updateEnv [(x, val)] env, err) : solveInProblems x val ps)

784838

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+

785848updateNotunified [] nu = nu

786849updateNotunified ns nu = up nu where

787850 up [] = []

788851 up ((n, t) : nus) = let t' = updateSolved ns t in

789852 ((n, t') : up nus)

790853

854+updateProblems :: Context -> [(Name, TT Name)] -> Fails -> [Name] -> [Name]

855+ -> ([(Name, TT Name)], Fails)

791856updateProblems ctxt [] ps inj holes = ([], ps)

792857updateProblems ctxt ns ps inj holes = up ns ps where

793858 up ns [] = (ns, [])

794− up ns ((x, y, env, err, um) : ps) =

859+ up ns ((x, y, env, err, while, um) : ps) =

795860 let x' = updateSolved ns x

796861 y' = updateSolved ns y

797862 err' = updateError ns err

798863 env' = updateEnv ns env in

799−-- trace ("Updating " ++ show (x',y')) $

800− case unify ctxt env' x' y' inj holes of

864+-- trace ("Updating " ++ show (x',y')) $

865+ case unify ctxt env' x' y' inj holes while of

801866 OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

802867 up (ns ++ v) ps

803868 e -> -- trace ("Failed " ++ show e) $

804869 let (ns', ps') = up ns ps in

805− (ns', (x',y',env',err', um) : ps')

870+ (ns', (x',y',env',err', while, um) : ps')

806871

807872-- attempt to solve remaining problems with match_unify

808873matchProblems all ns ctxt ps inj holes = up ns ps where

809874 up ns [] = (ns, [])

810− up ns ((x, y, env, err, um) : ps)

875+ up ns ((x, y, env, err, while, um) : ps)

811876 | all || um == Match =

812877 let x' = updateSolved ns x

813878 y' = updateSolved ns y

814879 err' = updateError ns err

815880 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

817882 OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

818883 up (ns ++ v) ps

819884 _ -> let (ns', ps') = up ns ps in

820− (ns', (x',y',env',err',um) : ps')

885+ (ns', (x', y', env', err', while, um) : ps')

821886 up ns (p : ps) = let (ns', ps') = up ns ps in

822887 (ns', p : ps')

823888

@@ -830,7 +895,7 @@ processTactic QED ps = case holes ps of

830895 _ -> fail "Still holes to fill."

831896processTactic ProofState ps = return (ps, showEnv [] (pterm ps))

832897processTactic Undo ps = case previous ps of

833− Nothing -> fail "Nothing to undo."

898+ Nothing -> Error . Msg $ "Nothing to undo."

834899 Just pold -> return (pold, "")

835900processTactic EndUnify ps

836901 = let (h, ns_in) = unified ps

@@ -844,6 +909,11 @@ processTactic EndUnify ps

844909 problems = probs',

845910 notunified = updateNotunified ns'' (notunified ps),

846911 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) }, "")

847917processTactic (Reorder n) ps

848918 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

849919 return (ps' { previous = Just ps, plog = "" }, plog ps')

src/Idris/Core/TC.hs+9

@@ -2,6 +2,7 @@

22

33module Idris.Core.TC(TC'(..)) where

44

5+import Control.Applicative

56import Control.Monad

67import Control.Monad.Trans.Error(Error(..))

78

@@ -26,3 +27,11 @@ instance Error e => MonadPlus (TC' e) where

2627 _ `mplus` (OK y) = OK y

2728 err `mplus` _ = err

2829

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(..))

2727import Debug.Trace

2828import qualified Data.Map.Strict as Map

2929import Data.Char

30+import Numeric (showIntAtBase)

3031import qualified Data.Text as T

3132import Data.List

3233import Data.Maybe (listToMaybe)

@@ -44,8 +45,8 @@ data Option = TTypeInTType

4445

4546-- | Source location. These are typically produced by the parser 'Idris.Parser.getFC'

4647data FC = FC { fc_fname :: String, -- ^ Filename

47− fc_line :: Int, -- ^ Line number

48− fc_column :: Int -- ^ Column number

48+ fc_start :: (Int, Int), -- ^ Line and column numbers for the start of the location span

49+ fc_end :: (Int, Int) -- ^ Line and column numbers for the end of the location span

4950 }

5051

5152-- | Ignore source location equality (so deriving classes do not compare FCs)

@@ -57,7 +58,7 @@ newtype FC' = FC' { unwrapFC :: FC }

5758

5859instance Eq FC' where

5960 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'

6162

6263-- | Empty source location

6364emptyFC :: FC

@@ -65,7 +66,7 @@ emptyFC = fileFC ""

6566

6667-- | Source location with file only

6768fileFC :: String -> FC

68−fileFC s = FC s 0 0

69+fileFC s = FC s (0, 0) (0, 0)

6970

7071{-!

7172deriving instance Binary FC

@@ -73,20 +74,31 @@ deriving instance NFData FC

7374!-}

7475

7576instance Sized FC where

76− size (FC f l c) = 1 + length f

77+ size (FC f s e) = 4 + length f

7778

7879instance 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

8084

8185-- | 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

8390

8491-- | 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

8694 | AnnBoundName Name Bool

87− | AnnConstData

88− | AnnConstType

95+ -- ^^ The name and whether it is implicit

96+ | AnnConst Const

97+ | AnnData String String -- ^ type, doc overview

98+ | AnnType String String -- ^ name, doc overview

99+ | AnnKeyword

89100 | AnnFC FC

101+ | AnnTextFmt TextFormatting

90102

91103-- | Used for error reflection

92104data ErrorReportPart = TextPart String

@@ -121,7 +133,7 @@ data Err' t

121133 | NoTypeDecl Name

122134 | NotInjective t t t

123135 | CantResolve t

124− | CantResolveAlts [String]

136+ | CantResolveAlts [Name]

125137 | IncompleteTerm t

126138 | UniverseError

127139 | ProgramLineComment

@@ -132,6 +144,7 @@ data Err' t

132144 | NoRewriting t

133145 | At FC (Err' t)

134146 | Elaborating String Name (Err' t)

147+ | ElaboratingArg Name Name [(Name, Name)] (Err' t)

135148 | ProviderError String

136149 | LoadingFailed String (Err' t)

137150 | ReflectionError [[ErrorReportPart]] (Err' t)

@@ -162,6 +175,7 @@ instance Sized Err where

162175 size ProgramLineComment = 1

163176 size (At fc err) = size fc + size err

164177 size (Elaborating _ n err) = size err

178+ size (ElaboratingArg _ _ _ err) = size err

165179 size (ProviderError msg) = length msg

166180 size (LoadingFailed fn e) = 1 + length fn + size e

167181 size _ = 1

@@ -170,9 +184,12 @@ score :: Err -> Int

170184score (CantUnify _ _ _ m _ s) = s + score m

171185score (CantResolve _) = 20

172186score (NoSuchVariable _) = 1000

173−score (ProofSearchFail _) = 10000

174−score (CantSolveGoal _ _) = 10000

187+score (ProofSearchFail e) = score e

188+score (CantSolveGoal _ _) = 100000

175189score (InternalMsg _) = -1

190+score (At _ e) = score e

191+score (ElaboratingArg _ _ _ e) = score e

192+score (Elaborating _ _ e) = score e

176193score _ = 0

177194

178195instance Show Err where

@@ -186,6 +203,10 @@ instance Show Err where

186203 show (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: (TT) " ++ show e

187204 show ProgramLineComment = "Program line next to comment"

188205 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

189210 show _ = "Error"

190211

191212instance Pretty Err OutputAnnotation where

@@ -241,7 +262,7 @@ traceWhen False _ a = a

241262data Name = UN T.Text -- ^ User-provided name

242263 | NS Name [T.Text] -- ^ Root, namespaces

243264 | 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

245266 | SN SpecialName -- ^ Decorated function names

246267 | SymRef Int -- ^ Reference to IBC file symbol table (used during serialisation)

247268 deriving (Eq, Ord)

@@ -299,11 +320,11 @@ instance Sized Name where

299320 size _ = 1

300321

301322instance Pretty Name OutputAnnotation where

302− pretty n@(UN n') = annotate (AnnName n Nothing Nothing) $ text (T.unpack n')

303− pretty n@(NS un s) = annotate (AnnName n Nothing Nothing) . noAnnotate $ pretty un

304− pretty n@(MN i s) = annotate (AnnName n Nothing Nothing) $

323+ pretty n@(UN n') = annotate (AnnName n Nothing Nothing Nothing) $ text (T.unpack n')

324+ pretty n@(NS un s) = annotate (AnnName n Nothing Nothing Nothing) . noAnnotate $ pretty un

325+ pretty n@(MN i s) = annotate (AnnName n Nothing Nothing Nothing) $

305326 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)

307328

308329instance Pretty [Name] OutputAnnotation where

309330 pretty = encloseSep empty empty comma . map pretty

@@ -368,6 +389,7 @@ implicitable _ = False

368389nsroot (NS n _) = n

369390nsroot n = n

370391

392+-- this will overwrite already existing definitions

371393addDef :: Name -> a -> Ctxt a -> Ctxt a

372394addDef n v ctxt = case Map.lookup (nsroot n) ctxt of

373395 Nothing -> Map.insert (nsroot n)

@@ -410,6 +432,9 @@ lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt)

410432lookupCtxtExact :: Name -> Ctxt a -> Maybe a

411433lookupCtxtExact n ctxt = listToMaybe [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n]

412434

435+deleteDefExact :: Name -> Ctxt a -> Ctxt a

436+deleteDefExact n = Map.adjust (Map.delete n) (nsroot n)

437+

413438updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a

414439updateDef n f ctxt

415440 = let ds = lookupCtxtName n ctxt in

@@ -417,7 +442,7 @@ updateDef n f ctxt

417442

418443toAlist :: Ctxt a -> [(Name, a)]

419444toAlist ctxt = let allns = map snd (Map.toList ctxt) in

420− concat (map (Map.toList) allns)

445+ concatMap (Map.toList) allns

421446

422447addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a

423448addAlist [] ctxt = ctxt

@@ -505,6 +530,60 @@ instance Pretty Const OutputAnnotation where

505530 pretty (B32 w) = text . show $ w

506531 pretty (B64 w) = text . show $ w

507532

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+

508587data Raw = Var Name

509588 | RBind Name (Binder Raw) Raw

510589 | RApp Raw Raw

@@ -981,8 +1060,9 @@ uniqueName n hs | n `elem` hs = uniqueName (nextName n) hs

9811060

9821061uniqueBinders :: [Name] -> TT Name -> TT Name

9831062uniqueBinders ns (Bind n b sc)

984− = let n' = uniqueName n ns in

985− Bind n' (fmap (uniqueBinders (n':ns)) b) (uniqueBinders ns sc)

1063+ = let n' = uniqueName n ns

1064+ ns' = n' : ns in

1065+ Bind n' (fmap (uniqueBinders ns') b) (uniqueBinders ns' sc)

9861066uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a)

9871067uniqueBinders ns t = t

9881068

@@ -1207,3 +1287,12 @@ orderPats tm = op [] tm

12071287 = (n', t') : insert n t ps

12081288 | otherwise = (n,t):(n',t'):ps

12091289

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 @@

11{-# LANGUAGE PatternGuards #-}

22

3−module Idris.Core.Unify(match_unify, unify, Fails, FailAt(..)) where

3+module Idris.Core.Unify(match_unify, unify, Fails, FailContext(..), FailAt(..)) where

44

55import Idris.Core.TT

66import Idris.Core.Evaluate

@@ -21,8 +21,14 @@ import Debug.Trace

2121data FailAt = Match | Unify

2222 deriving (Show, Eq)

2323

24+data FailContext = FailContext { fail_sourceloc :: FC,

25+ fail_fn :: Name,

26+ fail_param :: Name

27+ }

28+ deriving (Eq, Show)

29+

2430type Injs = [(TT Name, TT Name, TT Name)]

25−type Fails = [(TT Name, TT Name, Env, Err, FailAt)]

31+type Fails = [(TT Name, TT Name, Env, Err, [FailContext], FailAt)]

2632

2733data UInfo = UI Int Fails

2834 deriving Show

@@ -31,17 +37,26 @@ data UResult a = UOK a

3137 | UPartOK a

3238 | UFail Err

3339

40+-- | Smart constructor for unification errors that takes into account the FailContext

41+cantUnify :: [FailContext] -> Bool -> t -> t -> (Err' t) -> [(Name, t)] -> Int -> Err' t

42+cantUnify [] r t1 t2 e ctxt i = CantUnify r t1 t2 e ctxt i

43+cantUnify (FailContext fc f x : prev) r t1 t2 e ctxt i =

44+ At fc (ElaboratingArg f x

45+ (map (\(FailContext _ f' x') -> (f', x')) prev)

46+ (CantUnify r t1 t2 e ctxt i))

47+

3448-- Solve metavariables by matching terms against each other

3549-- Not really unification, of course!

3650

37−match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

51+match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->

3852 TC [(Name, TT Name)]

39−match_unify ctxt env topx topy inj holes =

40− case runStateT (un [] topx topy) (UI 0 []) of

53+match_unify ctxt env topx topy inj holes from =

54+ case runStateT (un [] (renameBindersTm env topx)

55+ (renameBindersTm env topy)) (UI 0 []) of

4156 OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v))

4257 res ->

43− let topxn = normalise ctxt env topx

44− topyn = normalise ctxt env topy in

58+ let topxn = renameBindersTm env (normalise ctxt env topx)

59+ topyn = renameBindersTm env (normalise ctxt env topy) in

4560 case runStateT (un [] topxn topyn)

4661 (UI 0 []) of

4762 OK (v, UI _ fails) ->

@@ -54,7 +69,20 @@ match_unify ctxt env topx topy inj holes =

5469 return (map (renameBinders env) (trimSolutions v))

5570 _ -> tfail e

5671 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)

5886

5987 un names (P _ x _) tm

6088 | holeIn env x || x `elem` holes

@@ -70,7 +98,7 @@ match_unify ctxt env topx topy inj holes =

7098 | length bnames > i,

7199 fst (fst (bnames!!i)) == x ||

72100 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

74102 = do h1 <- uB bnames bx by

75103 h2 <- un (((x, y), binderTy bx) : bnames) sx sy

76104 combine bnames h1 h2

@@ -81,11 +109,12 @@ match_unify ctxt env topx topy inj holes =

81109 un names x y

82110 | OK True <- convEq' ctxt holes x y = do sc 1; return []

83111 | otherwise = do UI s f <- get

84− let r = recoverable x y

85− let err = CantUnify r

112+ let r = recoverable (normalise ctxt env x)

113+ (normalise ctxt env y)

114+ let err = cantUnify from r

86115 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

87116 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))

89118 lift $ tfail err

90119

91120

@@ -95,13 +124,17 @@ match_unify ctxt env topx topy inj holes =

95124 uB bnames (Lam tx) (Lam ty) = un bnames tx ty

96125 uB bnames (Pi tx) (Pi ty) = un bnames tx ty

97126 uB bnames x y = do UI s f <- get

98− let r = recoverable (binderTy x) (binderTy y)

99− let err = CantUnify r topx topy

100− (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

101− (errEnv env) s

102− put (UI s ((binderTy x, binderTy y, env, err, Match) : f))

127+ let r = recoverable (normalise ctxt env (binderTy x))

128+ (normalise ctxt env (binderTy y))

129+ let err = cantUnify from r topx topy

130+ (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

131+ (errEnv env) s

132+ put (UI s ((binderTy x, binderTy y, env, err, from, Match) : f))

103133 return []

104134

135+ notHole (Hole _) = False

136+ notHole _ = True

137+

105138 -- TODO: there's an annoying amount of repetition between this and the

106139 -- main unification function. Consider lifting it out.

107140

@@ -109,10 +142,11 @@ match_unify ctxt env topx topy inj holes =

109142 put (UI (s+i) f)

110143

111144 unifyFail x y = do UI s f <- get

112− let r = recoverable x y

113− let err = CantUnify r

145+ let r = recoverable (normalise ctxt env x)

146+ (normalise ctxt env y)

147+ let err = cantUnify from r

114148 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))

116150 lift $ tfail err

117151 combine bnames as [] = return as

118152 combine bnames as ((n, t) : bs)

@@ -147,23 +181,30 @@ match_unify ctxt env topx topy inj holes =

147181 App (Bind y (Lam ty) (bind (i-1) ns tm))

148182 (P Bound x ty)

149183

150−renameBinders :: Env -> (Name, TT Name) -> (Name, TT Name)

151−renameBinders env (x, tm) = (x, uniqueBinders tm)

184+renameBinders env (x, t) = (x, renameBindersTm env t)

185+

186+renameBindersTm :: Env -> TT Name -> TT Name

187+renameBindersTm env tm = uniqueBinders (map fst env) tm

152188 where

153− uniqueBinders (Bind n b sc)

154− | n `elem` map fst env

155− = let n' = uniqueName n (map fst env) in

156− Bind n' (fmap uniqueBinders b)

157− (uniqueBinders (rename n n' sc))

158− | otherwise = Bind n (fmap uniqueBinders b) (uniqueBinders sc)

159− uniqueBinders (App f a) = App (uniqueBinders f) (uniqueBinders a)

160− uniqueBinders t = t

189+ uniqueBinders env (Bind n b sc)

190+ | n `elem` env

191+ = let n' = uniqueName n env in

192+ explicitHole $ Bind n' (fmap (uniqueBinders env) b)

193+ (uniqueBinders (n':env) (rename n n' sc))

194+ | otherwise = Bind n (fmap (uniqueBinders (n:env)) b)

195+ (uniqueBinders (n:env) sc)

196+ uniqueBinders env (App f a) = App (uniqueBinders env f) (uniqueBinders env a)

197+ uniqueBinders env t = t

161198

162199 rename n n' (P nt x ty) | n == x = P nt n' ty

163200 rename n n' (Bind x b sc) = Bind x (fmap (rename n n') b) (rename n n' sc)

164201 rename n n' (App f a) = App (rename n n' f) (rename n n' a)

165202 rename n n' t = t

166203

204+ explicitHole (Bind n (Hole ty) sc)

205+ = Bind n (Hole ty) (instantiate (P Bound n ty) sc)

206+ explicitHole t = t

207+

167208trimSolutions ns = dropPairs ns

168209 where dropPairs [] = []

169210 dropPairs (n@(x, P _ x' _) : ns)

@@ -183,18 +224,24 @@ expandLets env (x, tm) = (x, doSubst (reverse env) tm)

183224 doSubst (_ : env) tm

184225 = doSubst env tm

185226

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

186231

187−unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

232+unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] -> [FailContext] ->

188233 TC ([(Name, TT Name)], Fails)

189−unify ctxt env topx topy inj holes =

190−-- trace ("Unifying " ++ show (topx, topy)) $

234+unify ctxt env topx topy inj holes from =

235+-- traceWhen (hasv topx || hasv topy)

236+-- ("Unifying " ++ show topx ++ "\nAND\n" ++ show topy ++ "\n") $

191237 -- 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

193240 OK (v, UI _ []) -> return (map (renameBinders env) (trimSolutions v),

194241 [])

195242 res ->

196− let topxn = normalise ctxt env topx

197− topyn = normalise ctxt env topy in

243+ let topxn = renameBindersTm env (normalise ctxt env topx)

244+ topyn = renameBindersTm env (normalise ctxt env topy) in

198245-- trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $

199246 case runStateT (un False [] topxn topyn)

200247 (UI 0 []) of

@@ -273,7 +320,7 @@ unify ctxt env topx topy inj holes =

273320 | injective ty && not (holeIn env x || x `elem` holes)

274321 = unifyTmpFail tx ty

275322 un' fn bnames xtm@(P _ x _) tm

276− | holeIn env x || x `elem` holes

323+ | pureTerm tm, holeIn env x || x `elem` holes

277324 = do UI s f <- get

278325 -- injectivity check

279326 x <- checkCycle bnames (x, tm)

@@ -283,11 +330,11 @@ unify ctxt env topx topy inj holes =

283330 then unifyTmpFail xtm tm

284331 else do sc 1

285332 return x

286− | not (injective xtm) && injective tm

333+ | pureTerm tm, not (injective xtm) && injective tm

287334 = do checkCycle bnames (x, tm)

288335 unifyTmpFail xtm tm

289336 un' fn bnames tm ytm@(P _ y _)

290− | holeIn env y || y `elem` holes

337+ | pureTerm tm, holeIn env y || y `elem` holes

291338 = do UI s f <- get

292339 -- injectivity check

293340 x <- checkCycle bnames (y, tm)

@@ -297,7 +344,7 @@ unify ctxt env topx topy inj holes =

297344 then unifyTmpFail tm ytm

298345 else do sc 1

299346 return x

300− | not (injective ytm) && injective tm

347+ | pureTerm tm, not (injective ytm) && injective tm

301348 = do checkCycle bnames (y, tm)

302349 unifyTmpFail tm ytm

303350 un' fn bnames (V i) (P _ x _)

@@ -358,17 +405,18 @@ unify ctxt env topx topy inj holes =

358405 un' fn bnames x y

359406 | OK True <- convEq' ctxt holes x y = do sc 1; return []

360407 | otherwise = do UI s f <- get

361− let r = recoverable x y

362− let err = CantUnify r

408+ let r = recoverable (normalise ctxt env x)

409+ (normalise ctxt env y)

410+ let err = cantUnify from r

363411 topx topy (CantUnify r x y (Msg "") (errEnv env) s) (errEnv env) s

364412 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))

366414 return [] -- lift $ tfail err

367415

368416 unApp fn bnames appx@(App fx ax) appy@(App fy ay)

369417 | (injectiveApp fx && injectiveApp fy)

370− || (injectiveApp fx && rigid appx && metavarApp appy)

371− || (injectiveApp fy && rigid appy && metavarApp appx)

418+ || (injectiveApp fx && rigid appx && metavarApp appy && numArgs appx == numArgs appy)

419+ || (injectiveApp fy && rigid appy && metavarApp appx && numArgs appx == numArgs appy)

372420 || (injectiveApp fx && metavarApp fy && ax == ay)

373421 || (injectiveApp fy && metavarApp fx && ax == ay)

374422 = do let (headx, _) = unApply fx

@@ -413,6 +461,8 @@ unify ctxt env topx topy inj holes =

413461 vs <- combine bnames as as'

414462 unArgs vs xs ys

415463

464+ numArgs tm = let (f, args) = unApply tm in length args

465+

416466 metavarApp tm = let (f, args) = unApply tm in

417467 (metavar f &&

418468 all (\x -> metavarApp x) args

@@ -456,18 +506,18 @@ unify ctxt env topx topy inj holes =

456506 unifyTmpFail :: Term -> Term -> StateT UInfo TC [(Name, TT Name)]

457507 unifyTmpFail x y

458508 = do UI s f <- get

459− let r = recoverable x y

460− let err = CantUnify r

509+ let r = recoverable (normalise ctxt env x) (normalise ctxt env y)

510+ let err = cantUnify from r

461511 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))

463513 return []

464514

465515 -- shortcut failure, if we *know* nothing can fix it

466516 unifyFail x y = do UI s f <- get

467− let r = recoverable x y

468− let err = CantUnify r

517+ let r = recoverable (normalise ctxt env x) (normalise ctxt env y)

518+ let err = cantUnify from r

469519 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))

471521 lift $ tfail err

472522

473523

@@ -486,11 +536,12 @@ unify ctxt env topx topy inj holes =

486536 uB bnames (Hole tx) (Hole ty) = un' False bnames tx ty

487537 uB bnames (PVar tx) (PVar ty) = un' False bnames tx ty

488538 uB bnames x y = do UI s f <- get

489− let r = recoverable (binderTy x) (binderTy y)

490− let err = CantUnify r topx topy

491− (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

492− (errEnv env) s

493− put (UI s ((binderTy x, binderTy y, env, err, Unify) : f))

539+ let r = recoverable (normalise ctxt env (binderTy x))

540+ (normalise ctxt env (binderTy y))

541+ let err = cantUnify from r topx topy

542+ (CantUnify r (binderTy x) (binderTy y) (Msg "") (errEnv env) s)

543+ (errEnv env) s

544+ put (UI s ((binderTy x, binderTy y, env, err, from, Unify) : f))

494545 return [] -- lift $ tfail err

495546

496547 checkCycle ns p@(x, P _ _ _) = return [p]

@@ -498,7 +549,7 @@ unify ctxt env topx topy inj holes =

498549 | not (x `elem` freeNames tm) = checkScope ns (x, tm)

499550 | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env))

500551

501− checkScope ns (x, tm) =

552+ checkScope ns (x, tm) | pureTerm tm =

502553-- case boundVs (envPos x 0 env) tm of

503554-- [] -> return [(x, tm)]

504555-- (i:_) -> lift $ tfail (UnifyScope x (fst (fst (ns!!i)))

@@ -509,6 +560,7 @@ unify ctxt env topx topy inj holes =

509560 else return [(x, bind v ns tm)]

510561 where inst [] tm = tm

511562 inst (((n, _), _) : ns) tm = inst ns (substV (P Bound n Erased) tm)

563+ checkScope ns (x, tm) = lift $ tfail (Msg "HOLE ERROR")

512564

513565 bind i ns tm

514566 | i < 0 = tm

@@ -556,17 +608,14 @@ envPos x i ((y, _) : ys) | x == y = i

556608-- more work may help.

557609-- FIXME: Depending on how overloading gets used, this may cause problems. Better

558610-- rethink overloading properly...

611+-- ASSUMPTION: inputs are in normal form

559612

560613recoverable t@(App _ _) _

561614 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False

562615recoverable _ t@(App _ _)

563616 | (P _ (UN l) _, _) <- unApply t, l == txt "Lazy" = False

564−recoverable (P (DCon _ _) x _) (P (DCon _ _) y _)

565− | x == y = True

566− | otherwise = False

567−recoverable (P (TCon _ _) x _) (P (TCon _ _) y _)

568− | x == y = True

569− | otherwise = False

617+recoverable (P (DCon _ _) x _) (P (DCon _ _) y _) = x == y

618+recoverable (P (TCon _ _) x _) (P (TCon _ _) y _) = x == y

570619recoverable (Constant _) (P (DCon _ _) y _) = False

571620recoverable (P (DCon _ _) x _) (Constant _) = False

572621recoverable (Constant _) (P (TCon _ _) y _) = False

@@ -576,7 +625,7 @@ recoverable (P (TCon _ _) x _) (P (DCon _ _) y _) = False

576625recoverable p@(Constant _) (App f a) = recoverable p f

577626recoverable (App f a) p@(Constant _) = recoverable f p

578627recoverable 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

580629recoverable (App f a) (App f' a')

581630 = recoverable f f' -- && recoverable a a'

582631recoverable f (Bind _ (Pi _) sc)

@@ -585,7 +634,9 @@ recoverable f (Bind _ (Pi _) sc)

585634recoverable (Bind _ (Pi _) sc) f

586635 | (P (DCon _ _) _ _, _) <- unApply f = False

587636 | (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

589640

590641errEnv = map (\(x, b) -> (x, binderTy b))

591642

src/Idris/Coverage.hs+148−159

@@ -9,6 +9,7 @@ import Idris.Core.CaseTree

99import Idris.AbsSyntax

1010import Idris.Delaborate

1111import Idris.Error

12+import Idris.Output (iWarn, iputStrLn)

1213

1314import Data.List

1415import Data.Either

@@ -17,10 +18,14 @@ import Debug.Trace

1718

1819import Control.Monad.State.Strict

1920

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+

2025mkPatTm :: PTerm -> Idris Term

2126mkPatTm t = do i <- getIState

2227 let timp = addImpl' True [] [] i t

23− evalStateT (toTT timp) 0

28+ evalStateT (toTT (mapPT deNS timp)) 0

2429 where

2530 toTT (PRef _ n) = do i <- lift getIState

2631 case lookupDef n (tt_ctxt i) of

@@ -29,10 +34,16 @@ mkPatTm t = do i <- getIState

2934 toTT (PApp _ t args) = do t' <- toTT t

3035 args' <- mapM (toTT . getTm) args

3136 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

3240 toTT _ = do v <- get

3341 put (v + 1)

3442 return (P Bound (sMN v "imp") Erased)

3543

44+ deNS (PRef f (NS n _)) = PRef f n

45+ deNS t = t

46+

3647-- Given a list of LHSs, generate a extra clauses which cover the remaining

3748-- cases. The ones which haven't been provided are marked 'absurd' so that the

3849-- checker will make sure they can't happen.

@@ -40,30 +51,36 @@ mkPatTm t = do i <- getIState

4051-- This will only work after the given clauses have been typechecked and the

4152-- names are fully explicit!

4253

43−genClauses :: FC -> Name -> [Term] -> [PClause] -> Idris [PTerm]

54+genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm]

4455genClauses fc n xs given

4556 = 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+

4762 let argss = transpose lhss

4863 let all_args = map (genAll i) argss

4964 logLvl 5 $ "COVERAGE of " ++ show n

65+ logLvl 5 $ show lhss

5066 logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

5167 logLvl 10 $ show argss ++ "\n" ++ show all_args

52− logLvl 10 $ "Original: \n" ++

68+ logLvl 1 $ "Original: \n" ++

5369 showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)

5470 -- 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

5672 -- there may be more case splitting that the idris_implicits record

5773 -- suggests)

5874 let parg = case lookupCtxt n (idris_implicits i) of

59− (p : _) -> p ++ repeat (PExp 0 [] Placeholder "")

60− _ -> repeat (pexp Placeholder)

75+ (p : _) ->

76+ p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder)

77+ _ -> repeat (pexp Placeholder)

6178 let tryclauses = mkClauses parg all_args

6279 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)

6481 let new = filter (noMatch i) (nub tryclauses)

6582 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)

6784-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)

6885 return new

6986-- return (map (\t -> PClause n t [] PImpossible []) new)

@@ -71,13 +88,23 @@ genClauses fc n xs given

7188 | (f, args) <- unApply term = map (\t -> delab' i t True True) args

7289 | otherwise = []

7390

74− lhsApp (PClause _ _ l _ _ _) = l

75− lhsApp (PWith _ _ l _ _ _) = l

91+ pUnApply (PApp _ _ args) = map getTm args

92+ pUnApply _ = []

7693

94+ -- Return whether the given clause matches none of the input clauses

95+ -- (xs)

7796 noMatch i tm = all (\x -> case matchClause i (delab' i x True True) tm of

78− Right _ -> False

79− Left miss -> True) xs

97+ Right ms -> False

98+ Left miss -> True) xs

99+

80100

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

81108

82109 mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]

83110 mkClauses parg args

@@ -101,6 +128,7 @@ fnub' acc [] = acc

101128

102129-- quick check for constructor equality

103130quickEq :: PTerm -> PTerm -> Bool

131+quickEq (PConstant n) (PConstant n') = n == n'

104132quickEq (PRef _ n) (PRef _ n') = n == n'

105133quickEq (PApp _ t as) (PApp _ t' as')

106134 | length as == length as'

@@ -183,11 +211,11 @@ genAll i args

183211 let p = resugar (PApp fc (PRef fc n) (zipWith upd xs' xs))

184212 let tyn = getTy n (tt_ctxt i)

185213 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])

187215 _ -> [p]

188216 ops fc n arg o = return Placeholder

189217

190− getExpTm (PImp _ True _ _ _ _) = Placeholder -- machine inferred, no point!

218+ getExpTm (PImp _ True _ _ _) = Placeholder -- machine inferred, no point!

191219 getExpTm t = getTm t

192220

193221 -- put it back to its original form

@@ -218,29 +246,57 @@ genAll i args

218246

219247upd p' p = p { getTm = p' }

220248

221−-- Check if, in a given type n, the constructor cn : ty is strictly positive,

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,

269+-- the constructor cn : ty is strictly positive,

222270-- and update the context accordingly

223271

224−checkPositive :: Name -> (Name, Type) -> Idris ()

225−checkPositive n (cn, ty')

226− = do let ty = delazy ty'

272+checkPositive :: [Name] -> (Name, Type) -> Idris Totality

273+checkPositive mut_ns (cn, ty')

274+ = do let ty = delazy' True ty'

227275 let p = cp ty

228276 i <- getIState

229277 let tot = if p then Total (args ty) else Partial NotPositive

230278 let ctxt' = setTotal cn tot (tt_ctxt i)

231279 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

233281 addIBC (IBCTotal cn tot)

282+ return tot

234283 where

235284 args t = [0..length (getArgTys t)-1]

236285

237286 cp (Bind n (Pi aty) sc) = posArg aty && cp sc

238− cp t = True

287+ cp t | (P _ n' _, args) <- unApply t,

288+ n' `elem` mut_ns = all noRec args

289+ cp _ = True

239290

240291 posArg (Bind _ (Pi nty) sc)

241292 | (P _ n' _, args) <- unApply nty

242− = n /= n' && posArg sc

243− posArg t = True

293+ = n' `notElem` mut_ns && all noRec args && posArg sc

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+

244300

245301calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality

246302calcProd i fc topn pats

@@ -256,7 +312,7 @@ calcProd i fc topn pats

256312

257313 prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

258314 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)

260316

261317 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

262318 prod n done ok ap@(App _ _)

@@ -288,13 +344,16 @@ calcProd i fc topn pats

288344 cotype (DCon _ _) n ty

289345 | (P _ t _, _) <- unApply (getRetTy ty)

290346 = case lookupCtxt t (idris_datatypes i) of

291− [TI _ True _ _] -> True

347+ [TI _ True _ _ _] -> True

292348 _ -> False

293349 cotype nt n ty = False

294350

295−calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]

296− -> Idris Totality

297−calcTotality path fc n pats

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+

355+calcTotality :: FC -> Name -> [([Name], Term, Term)] -> Idris Totality

356+calcTotality fc n pats

298357 = do i <- getIState

299358 let opts = case lookupCtxt n (idris_flags i) of

300359 [fs] -> fs

@@ -329,20 +388,18 @@ checkTotality path fc n

329388 [CaseOp _ _ _ _ pats _] ->

330389 do t' <- if AssertTotal `elem` opts

331390 then return $ Total []

332− else calcTotality path fc n pats

391+ else calcTotality fc n pats

333392 setTotality n t'

334393 addIBC (IBCTotal n t')

335394 return t'

336− -- if it's not total, it can't reduce, to keep

337− -- typechecking decidable

338−-- case t' of

339−-- p@(Partial _) ->

340−-- do setAccessibility n Frozen

341−-- addIBC (IBCAccess n Frozen)

342−-- logLvl 5 $ "HIDDEN: "

343−-- ++ show n ++ show p

344−-- _ -> return ()

345−-- return t'

395+ [TyDecl (DCon _ _) ty] ->

396+ case unApply (getRetTy ty) of

397+ (P _ tyn _, _) -> do

398+ let ms = case lookupCtxt tyn (idris_datatypes i) of

399+ [TI _ _ _ _ xs@(_:_)] -> xs

400+ ts -> [tyn]

401+ checkPositive ms (n, ty)

402+ _-> return $ Total []

346403 _ -> return $ Total []

347404 x -> return x

348405 case t' of

@@ -350,18 +407,21 @@ checkTotality path fc n

350407 Productive -> return t'

351408 e -> do w <- cmdOptType WarnPartial

352409 if TotalFn `elem` opts

353− then totalityError t'

410+ then do totalityError t'; return t'

354411 else do when (w && not (PartialFn `elem` opts)) $

355412 warnPartial n t'

356413 return t'

357414 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)

359419

360420 warnPartial n t

361421 = do i <- getIState

362422 case lookupDef n (tt_ctxt i) of

363423 [x] -> do

364− iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t

424+ iWarn fc . pprintErr i . Msg $ "Warning - " ++ show n ++ " is " ++ show t

365425-- ++ "\n" ++ show x

366426-- let cg = lookupCtxtName Nothing n (idris_callgraph i)

367427-- iputStrLn (show cg)

@@ -372,7 +432,11 @@ checkDeclTotality (fc, n)

372432 = do logLvl 2 $ "Checking " ++ show n ++ " for totality"

373433-- buildSCG (fc, n)

374434-- 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

376440 t <- checkTotality [] fc n

377441 case t of

378442 -- if it's not total, it can't reduce, to keep

@@ -411,41 +475,57 @@ buildSCG (_, n) = do

411475 [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

412476 x -> error $ "buildSCG: " ++ show (n, x)

413477

414−delazy t@(App f a)

415− | (P _ (UN l) _, [_, arg]) <- unApply t,

416− l == txt "Force" = delazy arg

417− | (P _ (UN l) _, [_, arg]) <- unApply t,

418− l == txt "Delay" = delazy arg

419− | (P _ (UN l) _, [arg]) <- unApply t,

420− l == txt "Lazy" = delazy arg

421−delazy (App f a) = App (delazy f) (delazy a)

422−delazy (Bind n b sc) = Bind n (fmap delazy b) (delazy sc)

423−delazy t = t

478+delazy = delazy' False -- not lazy codata

479+delazy' all t@(App f a)

480+ | (P _ (UN l) _, [_, _, arg]) <- unApply t,

481+ l == txt "Force" = delazy' all arg

482+ | (P _ (UN l) _, [P _ (UN lty) _, _, arg]) <- unApply t,

483+ l == txt "Delay" && (all || lty == txt "LazyEval") = delazy arg

484+ | (P _ (UN l) _, [P _ (UN lty) _, arg]) <- unApply t,

485+ l == txt "Lazy'" && (all || lty == txt "LazyEval") = delazy' all arg

486+delazy' all (App f a) = App (delazy' all f) (delazy' all a)

487+delazy' all (Bind n b sc) = Bind n (fmap (delazy' all) b) (delazy' all sc)

488+delazy' all t = t

489+

490+data Guardedness = Toplevel | Unguarded | Guarded

424491

425492buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry]

426493buildSCG' ist pats args = nub $ concatMap scgPat pats where

427494 scgPat (lhs, rhs) = let lhs' = delazy lhs

428495 rhs' = delazy rhs

429496 (f, pargs) = unApply (dePat lhs') in

430− findCalls (dePat rhs') (patvars lhs') pargs

497+ findCalls Toplevel (dePat rhs') (patvars lhs') pargs

431498

432− findCalls ap@(App f a) pvs pargs

499+ findCalls guarded ap@(App f a) pvs pargs

433500 -- under a call to "assert_total", don't do any checking, just believe

434501 -- that it is total.

435502 | (P _ (UN at) _, [_, _]) <- unApply ap,

436503 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

437512 | (P _ n _, args) <- unApply ap

438− = mkChange n args pargs ++

439− concatMap (\x -> findCalls x pvs pargs) args

440− findCalls (App f a) pvs pargs

441− = findCalls f pvs pargs ++ findCalls a pvs pargs

442− findCalls (Bind n (Let t v) e) pvs pargs

443− = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs

444− findCalls (Bind n _ e) pvs pargs

445− = findCalls e (n : pvs) pargs

446− findCalls (P _ f _ ) pvs pargs

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 ++

519+ concatMap (\x -> findCalls nguarded x pvs pargs) args

520+ findCalls guarded (App f a) pvs pargs

521+ = findCalls Unguarded f pvs pargs ++ findCalls Unguarded a pvs pargs

522+ findCalls guarded (Bind n (Let t v) e) pvs pargs

523+ = findCalls Unguarded v pvs pargs ++ findCalls guarded e (n : pvs) pargs

524+ findCalls guarded (Bind n _ e) pvs pargs

525+ = findCalls guarded e (n : pvs) pargs

526+ findCalls guarded (P _ f _ ) pvs pargs

447527 | not (f `elem` pvs) = [(f, [])]

448− findCalls _ _ _ = []

528+ findCalls _ _ _ _ = []

449529

450530 expandToArity n args

451531 = case lookupTy n (tt_ctxt ist) of

@@ -463,7 +543,7 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

463543 -- find which argument in pargs <a> is smaller than, if any

464544 checkSize a (p : ps) i

465545 | a == p = Just (i, Same)

466− | (P _ (UN as) _, [_,arg,_]) <- unApply a,

546+ | (P _ (UN as) _, [_,_,arg,_]) <- unApply a,

467547 as == txt "assert_smaller" && arg == p

468548 = Just (i, Smaller)

469549 | smaller Nothing a (p, Nothing) = Just (i, Smaller)

@@ -493,108 +573,17 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

493573

494574 isInductive (P _ nty _) (P _ nty' _) =

495575 let co = case lookupCtxt nty (idris_datatypes ist) of

496− [TI _ x _ _] -> x

576+ [TI _ x _ _ _] -> x

497577 _ -> False in

498578 nty == nty' && not co

499579 isInductive _ _ = False

500580

501−-- getTypeFam t | (P _ n _, _) <- unApply t

502−

503581 dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)

504582 dePat t = t

505583

506584 patvars (Bind x (PVar _) sc) = x : patvars sc

507585 patvars _ = []

508586

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−

598587checkSizeChange :: Name -> Idris Totality

599588checkSizeChange n = do

600589 ist <- getIState

@@ -667,7 +656,7 @@ checkMP ist i mp = if i > 0

667656 = case lookupTotal f (tt_ctxt ist) of

668657 [Total _] -> Unchecked -- okay so far

669658 [Partial _] -> Partial (Other [f])

670− x -> error (show x)

659+ x -> error $ "CAN'T HAPPEN: " ++ (show x)

671660 | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)

672661 = Total []

673662 tryPath desc path (e@(f, args) : es) arg

src/Idris/DSL.hs+2−2

@@ -57,10 +57,10 @@ expandDo dsl (PDoBlock ds)

5757 block b [a] = PElabError (Msg "Last statement in do block must be an expression")

5858 block b (DoBind fc n tm : rest)

5959 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

60− block b (DoBindP fc p tm : rest)

60+ block b (DoBindP fc p tm alts : rest)

6161 = PApp fc b [pexp tm, pexp (PLam (sMN 0 "bpat") Placeholder

6262 (PCase fc (PRef fc (sMN 0 "bpat"))

63− [(p, block b rest)]))]

63+ ((p, block b rest) : alts)))]

6464 block b (DoLet fc n ty tm : rest)

6565 = PLet n ty tm (block b rest)

6666 block b (DoLetP fc p tm : rest)

src/Idris/DataOpts.hs+14−231

@@ -9,224 +9,48 @@ import Idris.AbsSyntaxTree

99import Idris.Core.TT

1010

1111import Control.Applicative

12−import qualified Data.IntMap as M

1312import Data.List

1413import Data.Maybe

1514import Debug.Trace

1615

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−

15916class Optimisable term where

16017 applyOpts :: term -> Idris term

161− stripCollapsed :: term -> Idris term

16218

16319instance (Optimisable a, Optimisable b) => Optimisable (a, b) where

16420 applyOpts (x, y) = (,) <$> applyOpts x <*> applyOpts y

165− stripCollapsed (x, y) = (,) <$> stripCollapsed x <*> stripCollapsed y

16621

16722instance (Optimisable a, Optimisable b) => Optimisable (vs, a, b) where

16823 applyOpts (v, x, y) = (,,) v <$> applyOpts x <*> applyOpts y

169− stripCollapsed (v, x, y) = (,,) v <$> stripCollapsed x <*> stripCollapsed y

17024

17125instance Optimisable a => Optimisable [a] where

17226 applyOpts = mapM applyOpts

173− stripCollapsed = mapM stripCollapsed

17427

17528instance Optimisable a => Optimisable (Either a (a, a)) where

17629 applyOpts (Left t) = Left <$> applyOpts t

17730 applyOpts (Right t) = Right <$> applyOpts t

178− stripCollapsed (Left t) = Left <$> stripCollapsed t

179− stripCollapsed (Right t) = Right <$> stripCollapsed t

18031

18132-- Raw is for compile time optimisation (before type checking)

18233-- Term is for run time optimisation (after type checking, collapsing allowed)

183−

18434-- Compile time: no collapsing

18535

18636instance Optimisable Raw where

18737 applyOpts t@(RApp f a)

18838 | (Var n, args) <- raw_unapply t -- MAGIC HERE

189− = do args' <- 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'

39+ = raw_apply (Var n) <$> mapM applyOpts args

19440 | otherwise = RApp <$> applyOpts f <*> applyOpts a

19541

19642 applyOpts (RBind n b t) = RBind n <$> applyOpts b <*> applyOpts t

19743 applyOpts (RForce t) = applyOpts t

19844 applyOpts t = return t

19945

200− stripCollapsed t = return t

201−

20246-- Erase types (makes ibc smaller, and we don't need them)

20347instance Optimisable (Binder (TT Name)) where

20448 applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v

20549 applyOpts b = return (b { binderTy = Erased })

206− stripCollapsed (Let t v) = Let <$> return Erased <*> stripCollapsed v

207− stripCollapsed b = return (b { binderTy = Erased })

20850

20951instance Optimisable (Binder Raw) where

21052 applyOpts b = do t' <- applyOpts (binderTy b)

21153 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

23054

23155-- Run-time: do everything

23256

@@ -249,54 +73,22 @@ instance Optimisable (TT Name) where

24973 | fn == txt "toIntegerNat" && mod == prel

25074 = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

25175 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 []

255− _ -> return c

76+ = return $ applyDataOptRT n t arity []

25677 applyOpts t@(App f a)

25778 | (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'

262− _ -> return (mkApp c args')

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

267− t' <- applyOpts t

268− return (Bind n b' t')

269− applyOpts (Proj t i) = do t' <- applyOpts t

270− return (Proj t' i)

79+ = applyDataOptRT n t arity <$> mapM applyOpts args

80+ | otherwise = App <$> applyOpts f <*> applyOpts a

81+ applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t

82+ applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i

27183 applyOpts t = return t

27284

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

292−

293−applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term

294−applyDataOptRT oi n tag arity args

295− | length args == arity = doOpts n args (collapsible oi) (M.fromList $ forceable oi)

85+-- Need to saturate arguments first to ensure that optimisation happens uniformly

86+applyDataOptRT :: Name -> Int -> Int -> [Term] -> Term

87+applyDataOptRT n tag arity args

88+ | length args == arity = doOpts n args

29689 | otherwise = let extra = satArgs (arity - length args)

29790 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

30092 where

30193 satArgs n = map (\i -> sMN i "sat") [1..n]

30294

@@ -305,20 +97,11 @@ applyDataOptRT oi n tag arity args

30597

30698 -- Nat special cases

30799 -- 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]) []

309101 | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

310102 = Constant (BI 0)

311− doOpts (NS (UN s) [nat, prelude]) [k] _ _

103+ doOpts (NS (UN s) [nat, prelude]) [k]

312104 | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

313105 = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

314106

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)

323− args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]

324−

107+ doOpts n args = mkApp (P (DCon tag arity) n Erased) args

src/Idris/DeepSeq.hs+75−38

@@ -6,11 +6,49 @@ import Idris.AbsSyntaxTree

66

77import Control.DeepSeq

88

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 = ()

1050

11−instance NFData Forceability where

12− rnf Conditional = ()

13− rnf Unconditional = ()

51+-- All generated by 'derive'

1452

1553instance NFData IntTy where

1654 rnf (ITFixed x1) = rnf x1 `seq` ()

@@ -57,14 +95,14 @@ instance NFData ArgOpt where

5795 rnf _ = ()

5896

5997instance NFData Plicity where

60− rnf (Imp x1 x2 x3 x4)

61− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

62− rnf (Exp x1 x2 x3 x4)

63− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

64− rnf (Constraint x1 x2 x3)

98+ rnf (Imp x1 x2 x3)

99+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

100+ rnf (Exp x1 x2 x3)

101+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

102+ rnf (Constraint x1 x2)

103+ = rnf x1 `seq` rnf x2 `seq` ()

104+ rnf (TacImp x1 x2 x3)

65105 = 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` ()

68106

69107instance NFData FnOpt where

70108 rnf Inlinable = ()

@@ -84,29 +122,31 @@ instance NFData DataOpt where

84122

85123instance (NFData t) => NFData (PDecl' t) where

86124 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)

88126 = rnf x1 `seq`

89− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

127+ rnf x2 `seq`

128+ rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` ()

90129 rnf (PPostulate x1 x2 x3 x4 x5 x6)

91130 = rnf x1 `seq`

92131 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

93132 rnf (PClauses x1 x2 x3 x4)

94133 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

95134 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)

97136 = rnf x1 `seq`

98− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

137+ rnf x2 `seq`

138+ rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

99139 rnf (PParams x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

100140 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)

102142 = rnf x1 `seq`

103143 rnf x2 `seq`

104144 rnf x3 `seq`

105− rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` ()

106− rnf (PClass x1 x2 x3 x4 x5 x6 x7)

145+ rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` ()

146+ rnf (PClass x1 x2 x3 x4 x5 x6 x8 x7)

107147 = rnf x1 `seq`

108148 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` ()

110150 rnf (PInstance x1 x2 x3 x4 x5 x6 x7 x8)

111151 = rnf x1 `seq`

112152 rnf x2 `seq`

@@ -116,16 +156,14 @@ instance (NFData t) => NFData (PDecl' t) where

116156 rnf (PSyntax x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

117157 rnf (PMutual x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

118158 rnf (PDirective x1) = ()

119− rnf (PProvider x1 x2 x3 x4 x5 x6)

120− = rnf x1 `seq`

121− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

159+ rnf (PProvider x1 x2 x3 x4)

160+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

122161 rnf (PTransform x1 x2 x3 x4)

123162 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

124163

125−instance NFData ProvideWhat where

126− rnf ProvAny = ()

127− rnf ProvTerm = ()

128− rnf ProvPostulate = ()

164+instance NFData t => NFData (ProvideWhat' t) where

165+ rnf (ProvTerm ty tm) = rnf ty `seq` rnf tm `seq` ()

166+ rnf (ProvPostulate tm) = rnf tm `seq` ()

129167

130168instance NFData PunInfo where

131169 rnf x = x `seq` ()

@@ -205,7 +243,7 @@ instance (NFData t) => NFData (PTactic' t) where

205243 rnf (Exact x1) = rnf x1 `seq` ()

206244 rnf Compute = ()

207245 rnf Trivial = ()

208− rnf (ProofSearch x1 x2)

246+ rnf (ProofSearch r r1 r2 x1 x2)

209247 = rnf x1 `seq` rnf x2 `seq` ()

210248 rnf Solve = ()

211249 rnf Attack = ()

@@ -224,22 +262,21 @@ instance (NFData t) => NFData (PTactic' t) where

224262instance (NFData t) => NFData (PDo' t) where

225263 rnf (DoExp x1 x2) = rnf x1 `seq` rnf x2 `seq` ()

226264 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` ()

228266 rnf (DoLet x1 x2 x3 x4)

229267 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

230268 rnf (DoLetP x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

231269

232270instance (NFData t) => NFData (PArg' t) where

233− rnf (PImp x1 x2 x3 x4 x5 x6)

234− = rnf x1 `seq`

235− rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

271+ rnf (PImp x1 x2 x3 x4 x5)

272+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

236273 rnf (PExp x1 x2 x3 x4)

237274 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

238275 rnf (PConstraint x1 x2 x3 x4)

239276 = 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)

241278 = 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` ()

243280

244281instance NFData ClassInfo where

245282 rnf (CI x1 x2 x3 x4 x5 x6)

@@ -247,11 +284,11 @@ instance NFData ClassInfo where

247284 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

248285

249286instance NFData OptInfo where

250− rnf (Optimise x1 x2 x3 x4)

251− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

287+ rnf (Optimise x1 x2)

288+ = rnf x1 `seq` rnf x2 `seq` ()

252289

253290instance 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` ()

255292

256293instance (NFData t) => NFData (DSL' t) where

257294 rnf (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9)

@@ -282,11 +319,11 @@ instance NFData Using where

282319

283320

284321instance 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)

286323 = rnf x1 `seq`

287324 rnf x2 `seq`

288325 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` ()

290327

291328

292329

src/Idris/Delaborate.hs+83−32

@@ -1,6 +1,5 @@

11{-# 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

43

54-- Convert core TT back into high level syntax, primarily for display

65-- purposes.

@@ -10,9 +9,11 @@ import Util.Pretty

109import Idris.AbsSyntax

1110import Idris.Core.TT

1211import Idris.Core.Evaluate

12+import Idris.Docstrings (overview, renderDocstring)

1313import Idris.ErrReverse

1414

1515import Data.List (intersperse)

16+import qualified Data.Text as T

1617

1718import Debug.Trace

1819

@@ -56,19 +57,24 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

5657 _ -> PRef un n

5758 de env _ (Bind n (Lam ty) sc)

5859 = PLam n (de env [] ty) (de ((n,n):env) [] sc)

59− de env (PImp _ _ _ _ _ _:is) (Bind n (Pi ty) sc)

60− = PPi impl n (de env [] ty) (de ((n,n):env) is sc)

60+ de env ((PImp { argopts = opts }):is) (Bind n (Pi ty) sc)

61+ = PPi (Imp opts Dynamic False) n (de env [] ty) (de ((n,n):env) is sc)

6162 de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc)

6263 = 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)

6465 = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)

65− de env _ (Bind n (Pi ty) 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)

71+ de env [] (Bind n (Pi ty) sc)

6672 = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

6773 de env _ (Bind n (Let ty val) sc)

6874 = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

6975 de env _ (Bind n (Hole ty) sc) = de ((n, sUN "[__]"):env) [] sc

7076 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

7278 de env _ (Constant i) = PConstant i

7379 de env _ Erased = Placeholder

7480 de env _ Impossible = Placeholder

@@ -87,19 +93,22 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

8793 | n == eqCon = PRefl un (de env [] r)

8894 | n == sUN "lazy" = de env [] r

8995 deFn env (P _ n _) [ty, Bind x (Lam _) r]

90− | n == sUN "Exists"

96+ | n == sUN "Sigma"

9197 = PDPair un IsType (PRef un x) (de env [] ty)

9298 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

9399 deFn env (P _ n _) [_,_,l,r]

94100 | n == pairCon = PPair un IsTerm (de env [] l) (de env [] r)

95101 | 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

97103 (de env [] r)

98− deFn env (P _ n _) args | not mvs

99− = case lookup n (idris_metavars ist) of

100− Just (Just _, mi, _) ->

101− mkMVApp n (drop mi (map (de env []) args))

102− _ -> mkPApp n (map (de env []) args)

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

108+ | not mvs = case lookup n (idris_metavars ist) of

109+ Just (Just _, mi, _) ->

110+ mkMVApp n (drop mi (map (de env []) args))

111+ _ -> mkPApp n (map (de env []) args)

103112 | otherwise = mkPApp n (map (de env []) args)

104113 deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args))

105114

@@ -108,14 +117,14 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

108117 mkMVApp n args

109118 = PApp un (PMetavar n) (map pexp args)

110119 mkPApp n args

111− | [imps] <- lookupCtxt n (idris_implicits ist)

120+ | Just imps <- lookupCtxtExact n (idris_implicits ist)

112121 = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)

113122 | otherwise = PApp un (PRef un n) (map pexp args)

114123

115− imp (PImp p m l n _ d) arg = PImp p m l n arg d

116− imp (PExp p l _ d) arg = PExp p l arg d

117− imp (PConstraint p l _ d) arg = PConstraint p l arg d

118− imp (PTacImplicit p l n sc _ d) arg = PTacImplicit p l n sc arg d

124+ imp (PImp p m l n _) arg = PImp p m l n arg

125+ imp (PExp p l n _) arg = PExp p l n arg

126+ imp (PConstraint p l n _) arg = PConstraint p l n arg

127+ imp (PTacImplicit p l n sc _) arg = PTacImplicit p l n sc arg

119128

120129-- | How far to indent sub-errors

121130errorIndent :: Int

@@ -130,12 +139,7 @@ pprintTerm :: IState -> PTerm -> Doc OutputAnnotation

130139pprintTerm ist = pprintTerm' ist []

131140

132141pprintTerm' :: IState -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

133−pprintTerm' ist = pprintPTerm (opt_showimp (idris_options ist))

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

142+pprintTerm' ist bnd tm = pprintPTerm (ppOptionIst ist) bnd [] (idris_infixes ist) tm

139143

140144pprintErr :: IState -> Err -> Doc OutputAnnotation

141145pprintErr i err = pprintErr' i (fmap (errReverse i) err)

@@ -192,7 +196,7 @@ pprintErr' i (NotInjective p x y) =

192196 pprintTerm i (delab i y)

193197pprintErr' i (CantResolve c) = text "Can't resolve type class" <+> pprintTerm i (delab i c)

194198pprintErr' 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)))

196200pprintErr' i (NoTypeDecl n) = text "No type declaration for" <+> annName n

197201pprintErr' i (NoSuchVariable n) = text "No such variable" <+> annName n

198202pprintErr' 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

209213pprintErr' i (Elaborating s n e) = text "When elaborating" <+> text s <>

210214 annName' n (showqual i n) <> colon <$>

211215 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

212233pprintErr' i (ProviderError msg) = text ("Type provider error: " ++ msg)

213234pprintErr' i (LoadingFailed fn e) = text "Loading" <+> text fn <+> text "failed:" <+> pprintErr' i e

214235pprintErr' i (ReflectionError parts orig) =

215− let parts' = map (hsep . map showPart) parts in

216− vsep parts' <>

236+ let parts' = map (fillSep . map showPart) parts in

237+ align (fillSep parts') <>

217238 if (opt_origerr (idris_options i))

218239 then line <> line <> text "Original error:" <$> indented (pprintErr' i orig)

219240 else empty

220241 where showPart :: ErrorReportPart -> Doc OutputAnnotation

221− showPart (TextPart str) = text str

242+ showPart (TextPart str) = fillSep . map text . words $ str

222243 showPart (NamePart n) = annName n

223244 showPart (TermPart tm) = pprintTerm i (delab i tm)

224245 showPart (SubReport rs) = indented . hsep . map showPart $ rs

@@ -227,11 +248,40 @@ pprintErr' i (ReflectionFailed msg err) =

227248 indented (pprintErr' i err) <>

228249 text ("This is probably a bug. Please consider reporting it at " ++ bugaddr)

229250

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+

230256annName :: Name -> Doc OutputAnnotation

231−annName n = annName' n (show n)

257+annName n = annName' n (showbasic n)

232258

233259annName' :: 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

235285

236286showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation

237287showSc i [] = empty

@@ -244,13 +294,14 @@ showSc i xs = line <> line <> text "In context:" <>

244294

245295

246296showqual :: 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)

248298 where

249299 dens ns@(NS n _) = case lookupCtxt n (idris_implicits i) of

250300 [_] -> n -- just one thing

251301 _ -> ns

252302 dens n = n

253303

304+showbasic :: Name -> String

254305showbasic n@(UN _) = show n

255306showbasic (MN _ s) = str s

256307showbasic (NS n s) = showSep "." (map str (reverse s)) ++ "." ++ showbasic n

src/Idris/Docs.hs+141−48

@@ -1,65 +1,138 @@

1−module Idris.Docs where

1+{-# LANGUAGE PatternGuards #-}

2+module Idris.Docs (pprintDocs, getDocs, pprintConstDocs, FunDoc(..), Docs (..)) where

23

34import Idris.AbsSyntax

45import Idris.AbsSyntaxTree

56import Idris.Delaborate

67import Idris.Core.TT

78import Idris.Core.Evaluate

9+import Idris.Docstrings

810

911import Util.Pretty

1012

1113import Data.Maybe

1214import Data.List

15+import qualified Data.Text as T

1316

1417-- TODO: Only include names with public/abstract accessibility

1518

16−data FunDoc = FD Name String

17− [(Name, PTerm, Plicity)] -- args: name, ty, plicity

19+data FunDoc = FD Name Docstring

20+ [(Name, PTerm, Plicity, Maybe Docstring)] -- args: name, ty, implicit, docs

1821 PTerm -- function type

1922 (Maybe Fixity)

23+ deriving Show

2024

2125data Docs = FunDoc FunDoc

2226 | DataDoc FunDoc -- type constructor docs

2327 [FunDoc] -- data constructor docs

24− | ClassDoc Name String -- class docs

28+ | ClassDoc Name Docstring -- class docs

2529 [FunDoc] -- method docs

26−

27−showDoc "" = empty

28−showDoc x = text " -- " <> text x

29−

30−pprintFD :: Bool -> FunDoc -> Doc OutputAnnotation

31−pprintFD imp (FD n doc args ty f)

32− = nest 4 (prettyName imp [] n <+> colon <+> prettyImp imp ty <$> showDoc doc <$>

30+ [(Name, Maybe Docstring)] -- parameters and their docstrings

31+ [PTerm] -- instances

32+ [PTerm] -- superclasses

33+ deriving Show

34+

35+showDoc d | nullDocstring d = empty

36+ | otherwise = text " -- " <> renderDocstring d

37+

38+pprintFD :: IState -> FunDoc -> Doc OutputAnnotation

39+pprintFD ist (FD n doc args ty f)

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 <$>

3344 maybe empty (\f -> text (show f) <> line) f <>

34− let argshow = mapMaybe showArg args in

45+ let argshow = showArgs args [] in

3546 if not (null argshow)

3647 then nest 4 $ text "Arguments:" <$> vsep argshow

3748 else empty)

3849

39− where showArg (n, ty, arg@(Exp {}))

40− = Just $ bindingOf n False <+> colon <+> prettyImp imp ty <>

41− showDoc (pdocstr arg) <> line

42− showArg (n, ty, arg@(Constraint {}))

43− = Just $ text "Class constraint" <+>

44− prettyImp imp ty <> showDoc (pdocstr arg) <> line

45− showArg (n, ty, arg@(Imp {}))

46− | not (null doc)

47− = Just $ text "(implicit)" <+>

48− bindingOf n True <+> colon <+> prettyImp imp ty

49− <> showDoc (pdocstr arg) <> line

50− showArg (n, _, _) = Nothing

51−

52−

53−

54−pprintDocs imp (FunDoc d) = pprintFD imp d

55−pprintDocs imp (DataDoc t args)

56− = text "Data type" <+> pprintFD imp t <$>

57− nest 4 (text "Constructors:" <> line <>

58− vsep (map (pprintFD imp) args))

59−pprintDocs imp (ClassDoc n doc meths)

60− = text "Type class" <+> prettyName imp [] n <$> -- parameters?

50+ where ppo = ppOptionIst ist

51+ infixes = idris_infixes ist

52+ showArgs ((n, ty, Exp {}, Just d):args) bnd

53+ = bindingOf n False <+> colon <+>

54+ pprintPTerm ppo bnd [] infixes ty <>

55+ showDoc d <> line

56+ :

57+ showArgs args ((n, False):bnd)

58+ showArgs ((n, ty, Constraint {}, Just d):args) bnd

59+ = text "Class constraint" <+>

60+ pprintPTerm ppo bnd [] infixes ty <> showDoc d <> line

61+ :

62+ showArgs args ((n, True):bnd)

63+ showArgs ((n, ty, Imp {}, Just d):args) bnd

64+ = text "(implicit)" <+>

65+ bindingOf n True <+> colon <+>

66+ pprintPTerm ppo bnd [] infixes ty <>

67+ showDoc d <> line

68+ :

69+ showArgs args ((n, True):bnd)

70+ showArgs ((n, _, _, _):args) bnd = showArgs args ((n, True):bnd)

71+ showArgs [] _ = []

72+

73+

74+pprintDocs :: IState -> Docs -> Doc OutputAnnotation

75+pprintDocs ist (FunDoc d) = pprintFD ist d

76+pprintDocs ist (DataDoc t args)

77+ = text "Data type" <+> pprintFD ist t <$>

78+ if null args then text "No constructors."

79+ else nest 4 (text "Constructors:" <> line <>

80+ vsep (map (pprintFD ist) args))

81+pprintDocs ist (ClassDoc n doc meths params instances superclasses)

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 <$>

6187 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))

63136

64137getDocs :: Name -> Idris Docs

65138getDocs n

@@ -80,20 +153,25 @@ docData n ti

80153docClass :: Name -> ClassInfo -> Idris Docs

81154docClass n ci

82155 = do i <- getIState

83− let docstr = case lookupCtxt n (idris_docstrings i) of

84− [str] -> str

85− _ -> ""

86− mdocs <- mapM docFun (map fst (class_methods ci))

87− return (ClassDoc n docstr mdocs)

156+ let docStrings = listToMaybe $ lookupCtxt n $ idris_docstrings i

157+ docstr = maybe emptyDocstring fst docStrings

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)

161+ mdocs <- mapM (docFun . fst) (class_methods ci)

162+ return $ ClassDoc n docstr mdocs params instances superclasses

163+ where

164+ getDInst (PInstance _ _ _ _ _ t _ _) = Just t

165+ getDInst _ = Nothing

88166

89167docFun :: Name -> Idris FunDoc

90168docFun n

91169 = do i <- getIState

92− let docstr = case lookupCtxt n (idris_docstrings i) of

93− [str] -> str

94− _ -> ""

170+ let (docstr, argDocs) = case lookupCtxt n (idris_docstrings i) of

171+ [d] -> d

172+ _ -> noDocs

95173 let ty = delabTy i n

96− let args = getPArgNames ty

174+ let args = getPArgNames ty argDocs

97175 let infixes = idris_infixes i

98176 let fixdecls = filter (\(Fix _ x) -> x == funName n) infixes

99177 let f = case fixdecls of

@@ -104,7 +182,22 @@ docFun n

104182 where funName :: Name -> String

105183 funName (UN n) = str n

106184 funName (NS n _) = funName n

107−

108−getPArgNames :: PTerm -> [(Name, PTerm, Plicity)]

109−getPArgNames (PPi plicity name ty body) = ((name, ty, plicity) : getPArgNames body)

110−getPArgNames _ = []

185+ funName n

186+ | n == falseTy = "_|_"

187+

188+getPArgNames :: PTerm -> [(Name, Docstring)] -> [(Name, PTerm, Plicity, Maybe Docstring)]

189+getPArgNames (PPi plicity name ty body) ds =

190+ (name, ty, plicity, lookup name ds) : getPArgNames body ds

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 @@

44module Idris.ElabDecls where

55

66import Idris.AbsSyntax

7+import Idris.ASTUtils

78import Idris.DSL

89import Idris.Error

910import Idris.Delaborate

@@ -16,6 +17,7 @@ import Idris.Primitives

1617import Idris.Inliner

1718import Idris.PartialEval

1819import Idris.DeepSeq

20+import Idris.Output (iputStrLn, pshow, iWarn)

1921import IRTS.Lang

2022import Paths_idris

2123

@@ -26,6 +28,12 @@ import Idris.Core.Execute

2628import Idris.Core.Typecheck

2729import Idris.Core.CaseTree

2830

31+import Idris.Docstrings

32+

33+import Prelude hiding (id, (.))

34+import Control.Category

35+

36+import Control.Applicative hiding (Const)

2937import Control.DeepSeq

3038import Control.Monad

3139import Control.Monad.State.Strict as State

@@ -34,6 +42,7 @@ import Data.Maybe

3442import Debug.Trace

3543

3644import qualified Data.Map as Map

45+import qualified Data.Set as S

3746import qualified Data.Text as T

3847import Data.Char(isLetter, toLower)

3948import Data.List.Split (splitOn)

@@ -56,32 +65,37 @@ checkAddDef add toplvl fc [] = return []

5665checkAddDef add toplvl fc ((n, (i, top, t)) : ns)

5766 = do ctxt <- getContext

5867 (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)

6070 ns' <- checkAddDef add toplvl fc ns

6171 return ((n, (i, top, t')) : ns')

6272-- mapM (\(n, (i, top, t)) -> do (t', _) <- recheckC fc [] t

6373-- return (n, (i, top, t'))) ns

6474

6575-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

66−elabType :: ElabInfo -> SyntaxInfo -> String ->

76+elabType :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->

6777 FC -> FnOpts -> Name -> PTerm -> Idris Type

6878elabType = elabType' False

6979

7080elabType' :: Bool -> -- normalise it

71− ElabInfo -> SyntaxInfo -> String ->

81+ ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] ->

7282 FC -> FnOpts -> Name -> PTerm -> Idris Type

73−elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in

74− n = liftname info n_in in -}

83+elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params info) ty_in

84+ n = liftname info n_in in -}

7585 do checkUndefined fc n

7686 ctxt <- getContext

7787 i <- getIState

7888

79− logLvl 1 $ show n ++ " pre-type " ++ showTmImpls ty'

89+ logLvl 5 $ show n ++ " pre-type " ++ showTmImpls ty'

8090 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

8298

83− let ty = addImpl i ty'

84− logLvl 1 $ show n ++ " type " ++ showTmImpls ty

8599 ((tyT, defer, is), log) <-

86100 tclift $ elaborate ctxt n (TType (UVal 0)) []

87101 (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

89103 -- if the type is not complete, note that we'll need to infer

90104 -- things later (for solving metavariables)

91105 when (not (null ds)) $ addTyInferred n

92−-- let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds

93−-- addDeferred ds'

106+

94107 mapM_ (elabCaseBlock info opts) is

95108 ctxt <- getContext

96109 logLvl 5 $ "Rechecking"

@@ -106,27 +119,32 @@ elabType' norm info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty

106119 -- Add normalised type to internals

107120 rep <- useREPL

108121 when rep $ do

109− addInternalApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty'))

110− addIBC (IBCLineApp (fc_fname fc) (fc_line fc) (mergeTy ty' (delab i nty')))

122+ addInternalApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')) -- TODO: Should use span instead of line and filename?

123+ addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (mergeTy ty' (delab i nty')))

111124

112125 let (t, _) = unApply (getRetTy nty')

113126 let corec = case t of

114127 P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of

115− [TI _ True _ _] -> True

128+ [TI _ True _ _ _] -> True

116129 _ -> False

117130 _ -> False

118− let opts' = if corec then (Coinductive : opts) else opts

131+ -- Productivity checking now via checking for guarded 'Delay'

132+ let opts' = opts -- if corec then (Coinductive : opts) else opts

119133 let usety = if norm then nty' else nty

120134 ds <- checkDef fc [(n, (-1, Nothing, usety))]

121135 addIBC (IBCDef n)

122136 let ds' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) ds

123137 addDeferred ds'

124138 setFlags n opts'

125− addDocStr n doc

139+ checkDocs fc argDocs ty

140+ addDocStr n doc argDocs

126141 addIBC (IBCDoc n)

127142 addIBC (IBCFlags n opts')

128− when (Implicit `elem` opts) $ do addCoercion n

129− addIBC (IBCCoercion n)

143+ fputState (opt_inaccessible . ist_optimisation n) inacc

144+ addIBC (IBCOpt n)

145+ when (Implicit `elem` opts') $ do addCoercion n

146+ addIBC (IBCCoercion n)

147+

130148 -- If the function is declared as an error handler and the language

131149 -- extension is enabled, then add it to the list of error handlers.

132150 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

141159 addIBC (IBCErrorHandler n)

142160 else ifail $ "The type " ++ show nty' ++ " is invalid for an error handler"

143161 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)

146162 return usety

147163 where

148164 -- 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

167183 , ns2 == map txt ["Maybe", "Prelude"]

168184 , ns3 == map txt ["List", "Prelude"]

169185 , 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)

171205

206+ -- remove it from the deferred definitions list

207+ solveDeferred n

172208

173−elabPostulate :: ElabInfo -> SyntaxInfo -> String ->

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)

209+elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris ()

210+elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

199211 = do let codata = Codata `elem` opts

200212 iLOG (show (fc, doc))

201213 checkUndefined fc n

202214 ctxt <- getContext

203215 i <- getIState

204− t_in <- implicit syn n t_in

216+ -- TODO think: something more in info?

217+ t_in <- implicit info syn n t_in

205218 let t = addImpl i t_in

206219 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

207220 (erun fc (build i info False [] n t))

208221 def' <- checkDef fc defer

209222 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def'

210223 addDeferredTyCon def''

224+ addIBC (IBCDef n)

211225 mapM_ (elabCaseBlock info []) is

212226 (cty, _) <- recheckC fc [] t'

213227 logLvl 2 $ "---> " ++ show cty

214228 updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons

215229

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)

217231 = do let codata = Codata `elem` opts

218232 iLOG (show fc)

219233 undef <- isUndefined fc n

220234 ctxt <- getContext

221235 i <- getIState

222− t_in <- implicit syn n t_in

236+ t_in <- implicit info syn n t_in

223237 let t = addImpl i t_in

224238 ((t', defer, is), log) <-

225239 tclift $ elaborate ctxt n (TType (UVal 0)) []

@@ -235,33 +249,54 @@ elabData info syn doc fc opts (PDatadecl n t_in dcons)

235249 logLvl 2 $ "---> " ++ show cty

236250 -- temporary, to check cons

237251 when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

238− cons <- mapM (elabCon info syn n codata) dcons

252+ let cnameinfo = cinfo info (map cname dcons)

253+ cons <- mapM (elabCon cnameinfo syn n codata) dcons

239254 ttag <- getName

240255 i <- getIState

241256 let as = map (const Nothing) (getArgTys cty)

242257 let params = findParams (map snd cons)

243258 logLvl 2 $ "Parameters : " ++ show params

244− putIState (i { idris_datatypes =

245− addDef n (TI (map fst cons) codata opts params)

259+ -- TI contains information about mutually declared types - this will

260+ -- be updated when the mutual block is complete

261+ putIState (i { idris_datatypes =

262+ addDef n (TI (map fst cons) codata opts params [n])

246263 (idris_datatypes i) })

247264 addIBC (IBCDef n)

248265 addIBC (IBCData n)

249− addDocStr n doc

266+ checkDocs fc argDocs t_in

267+ addDocStr n doc argDocs

250268 addIBC (IBCDoc n)

251269 let metainf = DataMI params

252270 addIBC (IBCMetaInformation n metainf)

253271 -- TMP HACK! Make this a data option

254− when (n /= sUN "Lazy") $ collapseCons n cons

255272 updateContext (addDatatype (Data n ttag cty cons))

256273 updateContext (setMetaInformation n metainf)

257− mapM_ (checkPositive n) cons

258− if DefaultEliminator `elem` opts then evalStateT (elabEliminator params n t dcons info) Map.empty

259− else return ()

274+ mapM_ totcheck (zip (repeat fc) (map fst 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) $

286+ evalStateT (elabEliminator params n t dcons info) Map.empty

260287 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+

261296 checkDefinedAs fc n t ctxt

262297 = case lookupDef n ctxt of

263298 [] -> return ()

264− [TyDecl _ ty] ->

299+ [TyDecl _ ty] ->

265300 case converts ctxt [] t ty of

266301 OK () -> return ()

267302 _ -> tclift $ tfail (At fc (AlreadyDefined n))

@@ -316,38 +351,56 @@ elabData info syn doc fc opts (PDatadecl n t_in dcons)

316351 | otherwise = count n ts

317352 mParam args (_ : rest) = Nothing : mParam args rest

318353

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+

319369type EliminatorState = StateT (Map.Map String Int) Idris

320370

321−-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

322−elabEliminator :: [Int] -> Name -> PTerm -> [(String, Name, PTerm, FC, [Name])] ->

371+-- TODO: Rewrite everything to use idris_implicits instead of manual splitting (or in TT)

372+elabEliminator :: [Int] -> Name -> PTerm ->

373+ [(Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name])] ->

323374 ElabInfo -> EliminatorState ()

324375elabEliminator paramPos n ty cons info = do

325376 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))

326378 let (cnstrs, _) = splitPi ty

327379 let (splittedTy@(pms, idxs)) = splitPms cnstrs

328380 generalParams <- namePis False pms

329381 motiveIdxs <- namePis False idxs

330382 let motive = mkMotive n paramPos generalParams motiveIdxs

331− consTerms <- mapM (\(c@(_,cnm,_,_,_)) -> do

332− name <- freshName $ "elim_" ++ simpleName cnm

333− consTerm <- extractConsTerm c generalParams

334− return (name, expl, consTerm)) cons

383+ consTerms <- mapM (\(c@(_, _, cnm, _, _, _)) -> do

384+ name <- freshName $ "elim_" ++ simpleName cnm

385+ consTerm <- extractConsTerm c generalParams

386+ return (name, expl, consTerm)) cons

335387 scrutineeIdxs <- namePis False idxs

336388 let motiveConstr = [(motiveName, expl, motive)]

337389 let scrutinee = (scrutineeName, expl, applyCons n (interlievePos paramPos generalParams scrutineeIdxs 0))

338390 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

340392 let clauseConsElimArgs = map getPiName consTerms

341393 let clauseGeneralArgs' = map getPiName generalParams ++ [motiveName] ++ clauseConsElimArgs

342394 let clauseGeneralArgs = map (\arg -> pexp (PRef elimFC arg)) clauseGeneralArgs'

343395 let elimSig = "-- eliminator signature: " ++ showTmImpls eliminatorTy

396+ elimLog elimSig

344397 eliminatorClauses <- mapM (\(cns, cnsElim) -> generateEliminatorClauses cns cnsElim clauseGeneralArgs generalParams) (zip cons clauseConsElimArgs)

345398 let eliminatorDef = PClauses emptyFC [TotalFn] elimDeclName eliminatorClauses

346− elimLog $ "-- eliminator definition: " ++ (show . showDeclImp True) eliminatorDef

399+ elimLog $ "-- eliminator definition: " ++ (show . showDeclImp verbosePPOption) eliminatorDef

347400 State.lift $ idrisCatch (elabDecl EAll info eliminatorTyDecl) (\err -> return ())

348401 -- Do not elaborate clauses if there aren't any

349402 case eliminatorClauses of

350− [] -> return ()

403+ [] -> State.lift $ solveDeferred elimDeclName -- Remove meta-variable for type

351404 _ -> State.lift $ idrisCatch (elabDecl EAll info eliminatorDef) (\err -> return ())

352405 where elimLog :: String -> EliminatorState ()

353406 elimLog s = State.lift (logLvl 2 s)

@@ -410,9 +463,9 @@ elabEliminator paramPos n ty cons info = do

410463 freshName key = do

411464 nameMap <- get

412465 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)

414467 put $ Map.insert key (i+1) nameMap

415− return (sUN name)

468+ return name

416469

417470 scrutineeName :: Name

418471 scrutineeName = sUN "scrutinee"

@@ -485,7 +538,7 @@ elabEliminator paramPos n ty cons info = do

485538 splitArgPms _ = ([],[])

486539

487540

488− implicitIndexes :: (String, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

541+ implicitIndexes :: (Docstring, Name, PTerm, FC, [Name]) -> EliminatorState [(Name, Plicity, PTerm)]

489542 implicitIndexes (cns@(doc, cnm, ty, fc, fs)) = do

490543 i <- State.lift getIState

491544 implargs' <- case lookupCtxt cnm (idris_implicits i) of

@@ -500,12 +553,12 @@ elabEliminator paramPos n ty cons info = do

500553 in return $ filter (\(n,_,_) -> not (n `elem` oldParams))implargs

501554 _ -> return implargs

502555

503− extractConsTerm :: (String, Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

504− extractConsTerm (doc, cnm, ty, fc, fs) generalParameters = do

556+ extractConsTerm :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> [(Name, Plicity, PTerm)] -> EliminatorState PTerm

557+ extractConsTerm (doc, argDocs, cnm, ty, fc, fs) generalParameters = do

505558 let cons' = replaceParams paramPos generalParameters ty

506559 let (args, resTy) = splitPi cons'

507560 implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

508− consArgs <- namePis True args

561+ consArgs <- namePis False args

509562 let recArgs = findRecArgs consArgs

510563 let recMotives = map applyRecMotive recArgs

511564 let (_, consIdxs) = splitArgPms resTy

@@ -536,15 +589,15 @@ elabEliminator paramPos n ty cons info = do

536589 convertImplPi (PImp {getTm = t, pname = n}) = Just (n, expl, t)

537590 convertImplPi _ = Nothing

538591

539− generateEliminatorClauses :: (String, Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

540− generateEliminatorClauses (doc, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

592+ generateEliminatorClauses :: (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Name -> [PArg] -> [(Name, Plicity, PTerm)] -> EliminatorState PClause

593+ generateEliminatorClauses (doc, _, cnm, ty, fc, fs) cnsElim generalArgs generalParameters = do

541594 let cons' = replaceParams paramPos generalParameters ty

542595 let (args, resTy) = splitPi cons'

543596 i <- State.lift getIState

544597 implidxs <- implicitIndexes (doc, cnm, ty, fc, fs)

545598 let (_, generalIdxs') = splitArgPms resTy

546599 let generalIdxs = map pexp generalIdxs'

547− consArgs <- namePis True args

600+ consArgs <- namePis False args

548601 let lhsPattern = PApp elimFC (PRef elimFC elimDeclName) (generalArgs ++ generalIdxs ++ [pexp $ applyCons cnm consArgs])

549602 let recArgs = findRecArgs consArgs

550603 let recElims = map applyRecElim recArgs

@@ -558,10 +611,12 @@ elabEliminator paramPos n ty cons info = do

558611

559612elabPrims :: Idris ()

560613elabPrims = do mapM_ (elabDecl EAll toplevel)

561− (map (\(opt, decl) -> PData "" defaultSyntax (fileFC "builtin") opt decl)

562− (zip

614+ (map (\(opt, decl, docs, argdocs) -> PData docs argdocs defaultSyntax (fileFC "builtin") opt decl)

615+ (zip4

563616 [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]))

565620 addNameHint eqTy (sUN "prf")

566621 elabDecl EAll toplevel elimDecl

567622 mapM_ elabPrim primitives

@@ -626,8 +681,8 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

626681

627682

628683-- | Elaborate a type provider

629−elabProvider :: ElabInfo -> SyntaxInfo -> FC -> ProvideWhat -> Name -> PTerm -> PTerm -> Idris ()

630−elabProvider info syn fc what n ty tm

684+elabProvider :: ElabInfo -> SyntaxInfo -> FC -> ProvideWhat -> Name -> Idris ()

685+elabProvider info syn fc what n

631686 = do i <- getIState

632687 -- Ensure that the experimental extension is enabled

633688 unless (TypeProviders `elem` idris_language_extensions i) $

@@ -637,12 +692,17 @@ elabProvider info syn fc what n ty tm

637692 ctxt <- getContext

638693

639694 -- First elaborate the expected type (and check that it's a type)

640− (ty', typ) <- elabVal toplevel False ty

695+ -- The goal type for a postulate is always Type.

696+ (ty', typ) <- case what of

697+ ProvTerm ty p -> elabVal toplevel False ty

698+ ProvPostulate _ -> elabVal toplevel False PType

641699 unless (isTType typ) $

642700 ifail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ)

643701

644702 -- Elaborate the provider term to TT and check that the type matches

645− (e, et) <- elabVal toplevel False tm

703+ (e, et) <- case what of

704+ ProvTerm _ tm -> elabVal toplevel False tm

705+ ProvPostulate tm -> elabVal toplevel False tm

646706 unless (isProviderOf (normalise ctxt [] ty') et) $

647707 ifail $ "Expected provider type IO (Provider (" ++

648708 show ty' ++ "))" ++ ", got " ++ show et ++ " instead."

@@ -653,25 +713,22 @@ elabProvider info syn fc what n ty tm

653713 rhs <- execute (mkApp (P Ref (sUN "run__provider") Erased)

654714 [Erased, e])

655715 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

657717

658718 -- Extract the provided term or postulate from the type provider

659719 provided <- getProvided fc rhs'

660720

661721 case provided of

662722 Provide tm

663− | what `elem` [ProvTerm, ProvAny] ->

723+ | ProvTerm ty _ <- what ->

664724 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

666726 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

668− | otherwise ->

669− ierror . Msg $ "Attempted to provide a term where a postulate was expected."

670− Postulate

671− | what `elem` [ProvPostulate, ProvAny] ->

727+ logLvl 3 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

728+ | ProvPostulate _ <- what ->

672729 do -- Add the postulate

673− elabPostulate info syn "Provided postulate" fc [] n ty

674− logLvl 1 $ "Elaborated provided postulate " ++ show n

730+ elabPostulate info syn (parseDocstring $ T.pack "Provided postulate") fc [] n (delab i tm)

731+ logLvl 3 $ "Elaborated provided postulate " ++ show n

675732 | otherwise ->

676733 ierror . Msg $ "Attempted to provide a postulate where a term was expected."

677734

@@ -687,7 +744,6 @@ elabProvider info syn fc what n ty tm

687744 , prov == txt "Provider" && provs == txt "Providers" = True

688745 isProviderOf _ _ = False

689746

690−-- | Elaborate a type provider

691747elabTransform :: ElabInfo -> FC -> Bool -> PTerm -> PTerm -> Idris ()

692748elabTransform info fc safe lhs_in rhs_in

693749 = do ctxt <- getContext

@@ -721,12 +777,18 @@ elabTransform info fc safe lhs_in rhs_in

721777 addIBC (IBCTrans (clhs_tm, crhs_tm))

722778

723779

724−elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

725− PTerm -> String -> Name -> PTerm -> Idris ()

726−elabRecord info syn doc fc tyn ty cdoc cn cty

727− = do elabData info syn doc fc [] (PDatadecl tyn ty [(cdoc, cn, cty, fc, [])])

728− cty' <- implicit syn cn cty

780+elabRecord :: ElabInfo -> SyntaxInfo -> Docstring -> FC -> Name ->

781+ PTerm -> DataOpts -> Docstring -> Name -> PTerm -> Idris ()

782+elabRecord info syn doc fc tyn ty opts cdoc cn cty_in

783+ = do elabData info syn doc [] fc opts (PDatadecl tyn ty [(cdoc, [], cn, cty_in, fc, [])])

784+ -- TODO think: something more in info?

785+ cty' <- implicit info syn cn cty_in

729786 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+

730792 cty <- case lookupTy cn (tt_ctxt i) of

731793 [t] -> return (delab i t)

732794 _ -> ifail "Something went inexplicably wrong"

@@ -735,14 +797,29 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

735797 let ptys = getProjs [] (renameBs cimp cty)

736798 let ptys_u = getProjs [] cty

737799 let recty = getRecTy cty

738− logLvl 6 $ show (recty, ptys)

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+

807+ logLvl 1 $ show (recty, ptys)

739808 let substs = map (\ (n, _) -> (n, PApp fc (PRef fc n)

740809 [pexp (PRef fc rec)])) ptys

741− proj_decls <- mapM (mkProj recty substs cimp) (zip ptys [0..])

810+

811+ -- Generate projection functions

812+ proj_decls <- mapM (mkProj recty_in substs cimp) (zip ptys [0..])

813+ logLvl 3 $ show proj_decls

742814 let nonImp = mapMaybe isNonImp (zip cimp ptys_u)

743815 let implBinds = getImplB id cty'

744− update_decls <- mapM (mkUpdate recty implBinds (length nonImp)) (zip nonImp [0..])

816+

817+ -- Generate update functions

818+ update_decls <- mapM (mkUpdate recty index_names_in extraImpls

819+ (getFieldNames cty')

820+ implBinds (length nonImp)) (zip nonImp [0..])

745821 mapM_ (elabDecl EAll info) (concat proj_decls)

822+ logLvl 3 $ show update_decls

746823 mapM_ (tryElabDecl info) (update_decls)

747824 where

748825-- 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

757834 (\v -> do iputStrLn $ show fc ++

758835 ":Warning - can't generate setter for " ++

759836 show fn ++ " (" ++ show ty ++ ")"

837+-- ++ "\n" ++ pshow i v

760838 putIState i)

761839

762− getImplB k (PPi (Imp l s _ _) n Placeholder sc)

840+ getBoundImpls (PPi (Imp _ _ _) n ty sc) = (n, ty) : getBoundImpls sc

841+ getBoundImpls _ = []

842+

843+ getImplB k (PPi (Imp l s _) n Placeholder sc)

763844 = getImplB k sc

764− getImplB k (PPi (Imp l s d p) n ty sc)

765− = getImplB (\x -> k (PPi (Imp l s d p) n ty x)) sc

845+ getImplB k (PPi (Imp l s p) n ty sc)

846+ = getImplB (\x -> k (PPi (Imp l s p) n ty x)) sc

766847 getImplB k (PPi _ n ty sc)

767848 = getImplB k sc

768849 getImplB k _ = k

769850

770− renameBs (PImp _ _ _ _ _ _ : ps) (PPi p n ty s)

851+ renameBs (PImp _ _ _ _ _ : ps) (PPi p n ty s)

771852 = PPi p (mkImp n) ty (renameBs ps (substMatch n (PRef fc (mkImp n)) s))

772853 renameBs (_:ps) (PPi p n ty s) = PPi p n ty (renameBs ps s)

773854 renameBs _ t = t

@@ -775,9 +856,19 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

775856 getProjs acc (PPi _ n ty s) = getProjs ((n, ty) : acc) s

776857 getProjs acc r = reverse acc

777858

859+ getFieldNames (PPi (Exp _ _ _) n _ s) = n : getFieldNames s

860+ getFieldNames (PPi _ _ _ s) = getFieldNames s

861+ getFieldNames _ = []

862+

778863 getRecTy (PPi _ n ty s) = getRecTy s

779864 getRecTy t = t

780865

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+

781872 rec = sMN 0 "rec"

782873

783874 mkp (UN n) = sMN 0 ("p_" ++ str n)

@@ -794,7 +885,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

794885

795886 mkProj recty substs cimp ((pn_in, pty), pos)

796887 = do let pn = expandNS syn pn_in

797− let pfnTy = PTy "" defaultSyntax fc [] pn

888+ let pfnTy = PTy emptyDocstring [] defaultSyntax fc [] pn

798889 (PPi expl rec recty

799890 (substMatches substs pty))

800891 let pls = repeat Placeholder

@@ -810,13 +901,23 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

810901

811902 implicitise (pa, t) = pa { getTm = t }

812903

813− mkUpdate recty k num ((pn, pty), pos)

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

907+ mkUpdate recty inames extras fnames k num ((pn, pty), pos)

814908 = do let setname = expandNS syn $ mkType pn

815909 let valname = sMN 0 "updateval"

816− let pt = k (PPi expl pn pty

817− (PPi expl rec recty recty))

818− let pfnTy = PTy "" defaultSyntax fc [] setname pt

819− let pls = map (\x -> PRef fc (sMN x "field")) [0..num-1]

910+ let pn_out = sMN 0 (show pn ++ "_out")

911+ let pn_in = sMN 0 (show pn ++ "_in")

912+ let recty_in = substMatches [(pn, PRef fc pn_in)] recty

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

820921 let lhsArgs = pls

821922 let rhsArgs = take pos pls ++ (PRef fc valname) :

822923 drop (pos + 1) pls

@@ -830,15 +931,31 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

830931 (map pexp rhsArgs)) []

831932 return (pn, pfnTy, PClauses fc [] setname [pclause])

832933

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

833948elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

834− (String, Name, PTerm, FC, [Name]) -> Idris (Name, Type)

835−elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

949+ (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)

950+elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

836951 = do checkUndefined fc n

837952 ctxt <- getContext

838953 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)

840955 let t = addImpl i t_in

841956 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t

957+ let inacc = inaccessibleArgs 0 t

958+ logLvl 5 $ "Inaccessible args: " ++ show inacc

842959 ((t', defer, is), log) <-

843960 tclift $ elaborate ctxt n (TType (UVal 0)) []

844961 (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)

853970 tyIs cty'

854971 logLvl 2 $ "---> " ++ show n ++ " : " ++ show cty'

855972 addIBC (IBCDef n)

856− addDocStr n doc

973+ checkDocs fc argDocs t_in

974+ addDocStr n doc argDocs

857975 addIBC (IBCDoc n)

858− let fs = map (getNamePos 0 t) forcenames

859− -- FIXME: 'forcenames' is an almighty hack! Need a better way of

860− -- erasing non-forceable things

861− forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty'

976+ fputState (opt_inaccessible . ist_optimisation n) inacc

977+ addIBC (IBCOpt n)

862978 return (n, cty')

863979 where

864980 tyIs (Bind n b sc) = tyIs sc

@@ -869,12 +985,15 @@ elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

869985

870986 mkLazy (PPi pl n ty sc)

871987 = 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]

873991 else ty in

874992 PPi pl n ty' (mkLazy sc)

875993 mkLazy t = t

876994

877995 getTyName (PApp _ (PRef _ n) _) = n == nsroot tn

996+ getTyName (PRef _ n) = n == nsroot tn

878997 getTyName _ = False

879998

880999

@@ -888,6 +1007,9 @@ elabCon info syn tn codata (doc, n, t_in, fc, forcenames)

8881007elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

8891008elabClauses info fc opts n_in cs = let n = liftname info n_in in

8901009 do ctxt <- getContext

1010+ ist <- getIState

1011+ inacc <- map fst <$> fgetState (opt_inaccessible . ist_optimisation n)

1012+

8911013 -- Check n actually exists, with no definition yet

8921014 let tys = lookupTy n ctxt

8931015 let reflect = Reflection `elem` opts

@@ -899,33 +1021,18 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

8991021 tclift $ tfail $ At fc (NoTypeDecl n)

9001022 [ty] -> return ty

9011023 let atys = map snd (getArgTys fty)

902− pats_in <- mapM (elabClause info opts)

1024+ cs_elab <- mapM (elabClause info opts)

9031025 (zip [0..] cs)

1026+ let (pats_in, cs_full) = unzip cs_elab

1027+

9041028 logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in

9051029

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

9181030 solveDeferred n

919− ist <- getIState

920− when doNothing $

921− case lookupCtxt n (idris_optimisation ist) of

922− [oi] -> do let opts = addDef n (oi { collapsible = True })

923− (idris_optimisation ist)

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)

1031+

1032+ -- just ensure that the structure exists

1033+ fmodifyState (ist_optimisation n) id

1034+ addIBC (IBCOpt n)

1035+

9291036 ist <- getIState

9301037 let pats = map (simple_lhs (tt_ctxt ist)) $ doTransforms ist pats_in

9311038

@@ -935,11 +1042,8 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

9351042 let tcase = opt_typecase (idris_options ist)

9361043

9371044 -- Summary of what's about to happen: Definitions go:

938−

939− -- pats_in -> pats -> optpats

940− -- pdef comes from pats,

941− -- optpdef comes from optpats

942− -- Then pdef' is optpdef with forcing/collapsing applied everywhere

1045+ --

1046+ -- pats_in -> pats -> pdef -> pdef'

9431047

9441048 -- addCaseDef builds case trees from <pdef> and <pdef'>

9451049

@@ -968,24 +1072,16 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

9681072

9691073 numArgs <- tclift $ sameLength pdef

9701074

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−

9781075 case specNames opts of

9791076 Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats

9801077 _ -> return ()

9811078

982− let optpdef = map debind optpats -- \$ map (simple_lhs (tt_ctxt ist)) optpats

9831079 tree@(CaseDef scargs sc _) <- tclift $

984− simpleCase tcase False reflect CompileTime fc atys pdef

1080+ simpleCase tcase False reflect CompileTime fc inacc atys pdef

9851081 cov <- coverage

9861082 pmissing <-

987− if cov

988− then do missing <- genClauses fc n (map getLHS pdef) cs

1083+ if cov && not (hasDefault cs)

1084+ then do missing <- genClauses fc n (map getLHS pdef) cs_full

9891085 -- missing <- genMissing n scargs sc

9901086 missing' <- filterM (checkPossible info fc True n) missing

9911087 let clhs = map getLHS pdef

@@ -1003,7 +1099,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

10031099 let pcover = null pmissing

10041100

10051101 -- pdef' is the version that gets compiled for run-time

1006− pdef_in' <- applyOpts optpdef

1102+ pdef_in' <- applyOpts pdef

10071103 let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'

10081104

10091105 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

10131109 let tot = if pcover || AssertTotal `elem` opts

10141110 then Unchecked -- finish checking later

10151111 else Partial NotCovering -- already know it's not total

1112+

10161113 -- case lookupCtxt (namespace info) n (idris_flags ist) of

10171114 -- [fs] -> if TotalFn `elem` fs

10181115 -- then case tot of

@@ -1029,11 +1126,12 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

10291126 let knowncovering = (pcover && cov) || AssertTotal `elem` opts

10301127

10311128 tree' <- tclift $ simpleCase tcase knowncovering reflect

1032− RunTime fc atys pdef'

1033− logLvl 3 (show tree)

1129+ RunTime fc inacc atys pdef'

1130+ logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree

10341131 logLvl 3 $ "Optimised: " ++ show tree'

10351132 ctxt <- getContext

10361133 ist <- getIState

1134+ let opt = idris_optimisation ist

10371135 putIState (ist { idris_patdefs = addDef n (force pdef', force pmissing)

10381136 (idris_patdefs ist) })

10391137 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

10431141 reflect

10441142 (AssertTotal `elem` opts)

10451143 atys

1144+ inacc

10461145 pats

10471146 pdef pdef pdef_inl pdef' ty)

10481147 addIBC (IBCDef n)

@@ -1059,7 +1158,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

10591158 let used = findUsedArgs sc' scargs'

10601159 -- let scg = buildSCG i sc scargs

10611160 -- 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

10631162 logLvl 2 $ "Called names: " ++ show cg

10641163 addToCG n cg

10651164 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

10681167 return ()

10691168 -- addIBC (IBCTotal n tot)

10701169 [] -> 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

10721174 where

10731175 noMatch i cs tm = all (\x -> case matchClause i (delab' i x True True) tm of

10741176 Right _ -> False

@@ -1088,13 +1190,18 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

10881190 depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)

10891191 depat acc x = (acc, x)

10901192

1193+ hasDefault cs | (PClause _ _ last _ _ _ :_) <- reverse cs

1194+ , (PApp fn s args) <- last = all ((==Placeholder) . getTm) args

1195+ hasDefault _ = False

1196+

10911197 getLHS (_, l, _) = l

10921198

10931199 simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x,

10941200 force (normalisePats ctxt [] y))

10951201 simple_lhs ctxt t = t

10961202

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)))

10981205

10991206 -- this is so pattern types are in the right form for erasure

11001207 normalisePats ctxt env (Bind n (PVar t) sc)

@@ -1158,10 +1265,10 @@ elabPE info fc caller r =

11581265 (map (\ (lhs, rhs) ->

11591266 (showTmImpls lhs ++ " = " ++

11601267 showTmImpls rhs)) pats)

1161− elabType info defaultSyntax "" fc opts newnm specTy

1268+ elabType info defaultSyntax emptyDocstring [] fc opts newnm specTy

11621269 let def = map (\ (lhs, rhs) -> PClause fc newnm lhs [] rhs []) pats

11631270 elabClauses info fc opts newnm def

1164− logLvl 1 $ "Specialised " ++ show newnm)

1271+ logLvl 2 $ "Specialised " ++ show newnm)

11651272 -- if it doesn't work, just don't specialise. Could happen for lots

11661273 -- of valid reasons (e.g. local variables in scope which can't be

11671274 -- lifted out).

@@ -1206,8 +1313,8 @@ elabPE info fc caller r =

12061313

12071314-- Elaborate a value, returning any new bindings created (this will only

12081315-- happen if elaborating as a pattern clause)

1209−elabValBind :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type, [(Name, Type)])

1210−elabValBind info aspat tm_in

1316+elabValBind :: ElabInfo -> Bool -> Bool -> PTerm -> Idris (Term, Type, [(Name, Type)])

1317+elabValBind info aspat norm tm_in

12111318 = do ctxt <- getContext

12121319 i <- getIState

12131320 let tm = addImpl i tm_in

@@ -1232,14 +1339,17 @@ elabValBind info aspat tm_in

12321339 logLvl 3 ("Value: " ++ show vtm)

12331340-- recheckC (fileFC "(input)") [] tm'

12341341-- 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

12361346 let bargs = getPBtys vtm

12371347

12381348 return (vtm, vty, bargs)

12391349

12401350elabVal :: ElabInfo -> Bool -> PTerm -> Idris (Term, Type)

12411351elabVal info aspat tm_in

1242− = do (tm, ty, _) <- elabValBind info aspat tm_in

1352+ = do (tm, ty, _) <- elabValBind info aspat False tm_in

12431353 return (tm, ty)

12441354

12451355-- 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

12491359checkPossible info fc tcgen fname lhs_in

12501360 = do ctxt <- getContext

12511361 i <- getIState

1252− let lhs = addImpl i lhs_in

1362+ let lhs = addImplPat i lhs_in

12531363 -- if the LHS type checks, it is possible

12541364 case elaborate ctxt (sMN 0 "patLHS") infP []

12551365 (erun fc (buildTC i info True [] fname (infTerm lhs))) of

@@ -1258,24 +1368,53 @@ checkPossible info fc tcgen fname lhs_in

12581368 case recheck ctxt [] (forget lhs_tm) lhs_tm of

12591369 OK _ -> return True

12601370 err -> return False

1261−

1262−-- b <- inferredDiff fc (delab' i lhs_tm True) lhs

1263−-- return (not b) -- then return (Just lhs_tm) else return Nothing

1264−-- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)

1265− Error err -> if tcgen then return False

1266− else return (impossibleError err)

1267− where impossibleError (CantUnify _ topx topy e _ _)

1268− = not (sameFam topx topy || not (impossibleError e))

1269− impossibleError (CantConvert _ _ _) = False

1270− impossibleError (At _ e) = impossibleError e

1271− impossibleError (Elaborating _ _ e) = impossibleError e

1272− impossibleError _ = True

1371+ -- if it's a recoverable error, the case may become possible

1372+ Error err -> if tcgen then return (recoverable ctxt err)

1373+ else return (validCase ctxt err ||

1374+ recoverable ctxt err)

1375+ where validCase ctxt (CantUnify _ topx topy e _ _)

1376+ = let topx' = normalise ctxt [] topx

1377+ topy' = normalise ctxt [] topy in

1378+ not (sameFam topx' topy' || not (validCase ctxt e))

1379+ validCase ctxt (CantConvert _ _ _) = False

1380+ validCase ctxt (At _ e) = validCase ctxt e

1381+ validCase ctxt (Elaborating _ _ e) = validCase ctxt e

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

12731393

12741394 sameFam topx topy

12751395 = case (unApply topx, unApply topy) of

12761396 ((P _ x _, _), (P _ y _, _)) -> x == y

12771397 _ -> False

12781398

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+

12791418getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)

12801419 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

12811420getFixedInType i env (_ : is) (Bind n (Pi t) sc)

@@ -1338,16 +1477,19 @@ propagateParams ps t (PRef fc n)

13381477 = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)

13391478propagateParams ps t x = x

13401479

1480+-- Return the elaborated LHS/RHS, and the original LHS with implicits added

13411481elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

1342− Idris (Either Term (Term, Term))

1482+ Idris (Either Term (Term, Term), PTerm)

13431483elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

13441484 = do let tcgen = Dictionary `elem` opts

1485+ i <- get

1486+ let lhs = addImpl i lhs_in

13451487 b <- checkPossible info fc tcgen fname lhs_in

13461488 case b of

13471489 True -> tclift $ tfail (At fc

13481490 (Msg $ show lhs_in ++ " is a valid case"))

13491491 False -> do ptm <- mkPatTm lhs_in

1350− return (Left ptm)

1492+ return (Left ptm, lhs)

13511493elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

13521494 = do let tcgen = Dictionary `elem` opts

13531495 ctxt <- getContext

@@ -1378,7 +1520,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

13781520 inj <- get_inj

13791521 return (res, probs, inj))

13801522

1381− when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_) -> (x,y)) probs)

1523+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)

13821524

13831525 let lhs_tm = orderPats (getInferTerm lhs')

13841526 let lhs_ty = getInferType lhs'

@@ -1397,17 +1539,17 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

13971539

13981540 rep <- useREPL

13991541 when rep $ do

1400− addInternalApp (fc_fname fc) (fc_line fc) (delabMV i clhs)

1401− addIBC (IBCLineApp (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?

1543+ addIBC (IBCLineApp (fc_fname fc) (fst . fc_start $ fc) (delabMV i clhs))

14021544

14031545 logLvl 5 ("Checked " ++ show clhs ++ "\n" ++ show clhsty)

14041546 -- Elaborate where block

14051547 ist <- getIState

14061548 windex <- getName

1407− let winfo = pinfo (pvars ist lhs_tm) whereblock windex

14081549 let decls = nub (concatMap declared whereblock)

14091550 let defs = nub (decls ++ concatMap defined whereblock)

14101551 let newargs = pvars ist lhs_tm

1552+ let winfo = pinfo info newargs defs windex

14111553 let wb = map (expandParamsD False ist decorate newargs defs) whereblock

14121554

14131555 -- 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)

14151557 -- Elaborate those with a type *before* RHS, those without *after*

14161558 let (wbefore, wafter) = sepBlocks wb

14171559

1418− logLvl 1 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter

1419− mapM_ (elabDecl' EAll info) wbefore

1560+ logLvl 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter

1561+ mapM_ (elabDecl' EAll winfo) wbefore

14201562 -- Now build the RHS, using the type of the LHS as the goal.

14211563 i <- getIState -- new implicits from where block

14221564 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)

14311573 mapM_ setinj (nub (params ++ inj))

14321574 setNextName

14331575 (_, _, 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))

14351577 errAt "right hand side of " fname

14361578 (erun fc $ psolve lhs_tm)

14371579 hs <- get_holes

@@ -1442,14 +1584,16 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

14421584 probs <- get_probs

14431585 return (tm, ds, is, probs))

14441586

1445− when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_) -> (x,y)) probs)

1587+ when inf $ addTyInfConstraints fc (map (\(x,y,_,_,_,_) -> (x,y)) probs)

14461588

14471589 logLvl 5 "DONE CHECK"

14481590 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)

14501593 def' <- checkDef fc defer

14511594 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

14521595 addDeferred def''

1596+ mapM_ (\(n, _) -> addIBC (IBCDef n)) def''

14531597

14541598 when (not (null def')) $ do

14551599 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)

14571601 -- Now the remaining deferred (i.e. no type declarations) clauses

14581602 -- from the where block

14591603

1460− mapM_ (elabDecl' EAll info) wafter

1461− mapM_ (elabCaseBlock info opts) is

1604+ mapM_ (elabDecl' EAll winfo) wafter

1605+ mapM_ (elabCaseBlock winfo opts) is

14621606

14631607 ctxt <- getContext

14641608 logLvl 5 $ "Rechecking"

@@ -1478,7 +1622,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

14781622 rev <- case ret_fam of

14791623 P _ rfamn _ ->

14801624 case lookupCtxt rfamn (idris_datatypes i) of

1481− [TI _ _ dopts _] ->

1625+ [TI _ _ dopts _ _] ->

14821626 return (DataErrRev `elem` dopts)

14831627 _ -> return False

14841628 _ -> return False

@@ -1486,8 +1630,21 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

14861630 when (rev || ErrorReverse `elem` opts) $ do

14871631 addIBC (IBCErrRev (crhs, clhs))

14881632 addErrRev (crhs, clhs)

1489− return $ Right (clhs, crhs)

1633+ return $ (Right (clhs, crhs), lhs)

14901634 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+

14911648 mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t []

14921649 mkLHSapp t = t

14931650

@@ -1500,7 +1657,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

15001657-- = NS (UN ('#':show x)) [show cnum, show fname]

15011658

15021659 sepBlocks bs = sepBlocks' [] bs where

1503− sepBlocks' ns (d@(PTy _ _ _ _ n t) : bs)

1660+ sepBlocks' ns (d@(PTy _ _ _ _ _ n t) : bs)

15041661 = let (bf, af) = sepBlocks' (n : ns) bs in

15051662 (d : bf, af)

15061663 sepBlocks' ns (d@(PClauses _ _ n _) : bs)

@@ -1510,19 +1667,6 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

15101667 (b : bf, af)

15111668 sepBlocks' ns [] = ([], [])

15121669

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−

15261670

15271671 -- if a hole is just an argument/result of a case block, treat it as

15281672 -- 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)

15591703 _ -> []

15601704 let params = getParamsInType i [] fn_is fn_ty

15611705 let lhs = propagateParams params fn_ty (addImplPat i (stripLinear i lhs_in))

1562− logLvl 1 ("LHS: " ++ show lhs)

1706+ logLvl 2 ("LHS: " ++ show lhs)

15631707 ((lhs', dlhs, []), _) <-

15641708 tclift $ elaborate ctxt (sMN 0 "patLHS") infP []

15651709 (errAt "left hand side of with in " fname

@@ -1589,6 +1733,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

15891733 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, False))) def'

15901734 addDeferred def''

15911735 mapM_ (elabCaseBlock info opts) is

1736+ logLvl 5 ("Checked wval " ++ show wval')

15921737 (cwval, cwvalty) <- recheckC fc [] (getInferTerm wval')

15931738 let cwvaltyN = explicitNames cwvalty

15941739 let cwvalN = explicitNames cwval

@@ -1653,7 +1798,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

16531798 mapM_ (elabCaseBlock info opts) is

16541799 logLvl 5 ("Checked RHS " ++ show rhs')

16551800 (crhs, crhsty) <- recheckC fc [] rhs'

1656− return $ Right (clhs, crhs)

1801+ return $ (Right (clhs, crhs), lhs)

16571802 where

16581803 getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t

16591804 getImps _ = []

@@ -1687,7 +1832,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

16871832 do lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

16881833 return $ PWith fc wname lhs ws wval withs'

16891834 mkAux wname toplhs ns ns' c

1690− = ifail $ show fc ++ "badly formed with clause"

1835+ = ifail $ show fc ++ ":badly formed with clause"

16911836

16921837 addArg (PApp fc f args) w = PApp fc f (args ++ [pexp w])

16931838 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)

16981843 return $ substMatches mvars $

16991844 PApp fc (PRef fc' wname)

17001845 (map pexp ns ++ pexp w : (map pexp ns'))

1701− updateLHS n wname mvars ns ns' tm w

1702− = ifail $ "Not implemented match " ++ show tm

1846+ updateLHS n wname mvars ns_in ns_in' tm w

1847+ = updateLHS n wname mvars ns_in ns_in' (PApp fc tm []) w

17031848

17041849 keepMvar mvs fc v | v `elem` mvs = PRef fc v

17051850 | otherwise = Placeholder

@@ -1717,10 +1862,10 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

17171862

17181863data MArgTy = IA | EA | CA deriving Show

17191864

1720−elabClass :: ElabInfo -> SyntaxInfo -> String ->

1865+elabClass :: ElabInfo -> SyntaxInfo -> Docstring ->

17211866 FC -> [PTerm] ->

1722− Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

1723−elabClass info syn doc fc constraints tn ps ds

1867+ Name -> [(Name, PTerm)] -> [(Name, Docstring)] -> [PDecl] -> Idris ()

1868+elabClass info syn doc fc constraints tn ps pDocs ds

17241869 = do let cn = SN (InstanceCtorN tn) -- sUN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)

17251870 let tty = pibind ps PType

17261871 let constraint = PApp fc (PRef fc tn)

@@ -1744,10 +1889,10 @@ elabClass info syn doc fc constraints tn ps ds

17441889 let cty = impbind ps $ conbind constraints

17451890 $ pibind (map (\ (n, ty) -> (nsroot n, ty)) methods)

17461891 constraint

1747− let cons = [("", cn, cty, fc, [])]

1892+ let cons = [(emptyDocstring, [], cn, cty, fc, [])]

17481893 let ddecl = PDatadecl tn tty cons

1749− logLvl 5 $ "Class data " ++ show (showDImp True ddecl)

1750− elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc [] ddecl

1894+ logLvl 5 $ "Class data " ++ show (showDImp verbosePPOption ddecl)

1895+ elabData info (syn { no_imp = no_imp syn ++ mnames }) doc pDocs fc [] ddecl

17511896 -- for each constraint, build a top level function to chase it

17521897 logLvl 5 $ "Building functions"

17531898 let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps

@@ -1785,9 +1930,9 @@ elabClass info syn doc fc constraints tn ps ds

17851930 conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

17861931 conbind [] x = x

17871932

1788− getMName (PTy _ _ _ _ n _) = nsroot n

1789− tdecl allmeths (PTy doc syn _ o n t)

1790− = do t' <- implicit' syn allmeths n t

1933+ getMName (PTy _ _ _ _ _ n _) = nsroot n

1934+ tdecl allmeths (PTy doc _ syn _ o n t)

1935+ = do t' <- implicit' info syn allmeths n t

17911936 logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

17921937 return ( (n, (toExp (map fst ps) Exp t')),

17931938 (n, (doc, o, (toExp (map fst ps) Imp t'))),

@@ -1799,7 +1944,7 @@ elabClass info syn doc fc constraints tn ps ds

17991944 case lookup n mtys of

18001945 Just (syn, o, ty) -> do let ty' = insertConstraint c ty

18011946 let ds = map (decorateid defaultdec)

1802− [PTy "" syn fc [] n ty',

1947+ [PTy emptyDocstring [] syn fc [] n ty',

18031948 PClauses fc (o ++ opts) n cs]

18041949 iLOG (show ds)

18051950 return (n, ((defaultdec n, ds!!1), ds))

@@ -1809,7 +1954,7 @@ elabClass info syn doc fc constraints tn ps ds

18091954 defaultdec (UN n) = sUN ("default#" ++ str n)

18101955 defaultdec (NS n ns) = NS (defaultdec n) ns

18111956

1812− tydecl (PTy _ _ _ _ _ _) = True

1957+ tydecl (PTy _ _ _ _ _ _ _) = True

18131958 tydecl _ = False

18141959 instdecl (PInstance _ _ _ _ _ _ _ _) = True

18151960 instdecl _ = False

@@ -1837,7 +1982,7 @@ elabClass info syn doc fc constraints tn ps ds

18371982 addInstance False conn' cfn

18381983 addIBC (IBCInstance False conn' cfn)

18391984-- iputStrLn ("Added " ++ show (conn, cfn, ty))

1840− return [PTy "" syn fc [] cfn ty,

1985+ return [PTy emptyDocstring [] syn fc [] cfn ty,

18411986 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

18421987

18431988 -- 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

18531998 iLOG (showTmImpls ty)

18541999 iLOG (show (m, ty', capp, margs))

18552000 iLOG (showTmImpls lhs ++ " = " ++ showTmImpls rhs)

1856− return [PTy doc syn fc o m ty',

2001+ return [PTy doc [] syn fc o m ty',

18572002 PClauses fc [Inlinable] m [PClause fc m lhs [] rhs []]]

18582003

1859− getMArgs (PPi (Imp _ _ _ _) n ty sc) = IA : getMArgs sc

1860− getMArgs (PPi (Exp _ _ _ _) n ty sc) = EA : getMArgs sc

1861− getMArgs (PPi (Constraint _ _ _) n ty sc) = CA : getMArgs sc

2004+ getMArgs (PPi (Imp _ _ _) n ty sc) = IA : getMArgs sc

2005+ getMArgs (PPi (Exp _ _ _) n ty sc) = EA : getMArgs sc

2006+ getMArgs (PPi (Constraint _ _) n ty sc) = CA : getMArgs sc

18622007 getMArgs _ = []

18632008

18642009 getMeth (m:ms) (a:as) x | x == a = PRef fc m

18652010 | otherwise = getMeth ms as x

18662011

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

18682013 lhsArgs (IA : xs) ns = lhsArgs xs ns

18692014 lhsArgs (CA : xs) ns = lhsArgs xs ns

18702015 lhsArgs [] _ = []

18712016

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

18732018 rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns

18742019 rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns

18752020 rhsArgs [] _ = []

18762021

1877− insertConstraint c (PPi p@(Imp _ _ _ _) n ty sc)

2022+ insertConstraint c (PPi p@(Imp _ _ _) n ty sc)

18782023 = PPi p n ty (insertConstraint c sc)

18792024 insertConstraint c sc = PPi constraint (sMN 0 "class") c sc

18802025

18812026 -- 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)

18832028 | 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)

18852030 toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

18862031 toExp ns e sc = sc

18872032

@@ -1897,11 +2042,14 @@ elabInstance info syn what fc cs n ps t expn ds = do

18972042 i <- getIState

18982043 (n, ci) <- case lookupCtxtName n (idris_classes i) of

18992044 [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))

19012048 let constraint = PApp fc (PRef fc n) (map pexp ps)

19022049 let iname = mkiname n ps expn

1903− when (what /= EDefns) $ do

1904− nty <- elabType' True info syn "" fc [] iname t

2050+ let emptyclass = null (class_methods ci)

2051+ when (what /= EDefns || (null ds && not emptyclass)) $ do

2052+ nty <- elabType' True info syn emptyDocstring [] fc [] iname t

19052053 -- if the instance type matches any of the instances we have already,

19062054 -- and it's not a named instance, then it's overlapping, so report an error

19072055 case expn of

@@ -1909,7 +2057,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

19092057 (class_instances ci)

19102058 addInstance intInst n iname

19112059 Just _ -> addInstance intInst n iname

1912− when (what /= ETypes) $ do

2060+ when (what /= ETypes && (not (null ds && not emptyclass))) $ do

19132061 let ips = zip (class_params ci) ps

19142062 let ns = case n of

19152063 NS n ns' -> ns'

@@ -1917,7 +2065,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

19172065 -- get the implicit parameters that need passing through to the

19182066 -- where block

19192067 wparams <- mapM (\p -> case p of

1920− PApp _ _ args -> getWParams args

2068+ PApp _ _ args -> getWParams (map getTm args)

19212069 _ -> return []) ps

19222070 let pnames = map pname (concat (nub wparams))

19232071 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

19402088 let wbTys = map mkTyDecl mtys

19412089 let wbVals = map (decorateid (decorate ns iname)) ds'

19422090 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)

19442092 logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++

19452093 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)

19472106 let rhs = PApp fc (PRef fc (instanceName ci))

19482107 (map (pexp . mkMethApp) mtys)

2108+

2109+ logLvl 5 $ "Instance LHS " ++ show lhs ++ " " ++ show headVars

2110+ logLvl 5 $ "Instance RHS " ++ show rhs

2111+

19492112 let idecls = [PClauses fc [Dictionary] iname

19502113 [PClause fc iname lhs [] rhs wb]]

19512114 iLOG (show idecls)

19522115 mapM_ (elabDecl EAll info) idecls

19532116 addIBC (IBCInstance intInst n iname)

1954−-- -- for each constraint, build a top level function to chase it

1955−-- logLvl 5 $ "Building functions"

1956−-- fns <- mapM (cfun (instanceName ci) constraint syn idecls) cs

1957−-- mapM_ (elabDecl EAll info) (concat fns)

2117+

19582118 where

19592119 intInst = case ps of

19602120 [PConstant (AType (ATInt ITNative))] -> True

@@ -1979,7 +2139,8 @@ elabInstance info syn what fc cs n ps t expn ds = do

19792139 -- TODO: largely based upon elabType' - should try to abstract

19802140 elabFindOverlapping i ci iname syn t

19812141 = 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'

19832144 let ty = addImpl i ty'

19842145 ctxt <- getContext

19852146 ((tyT, _, _), _) <-

@@ -2009,17 +2170,17 @@ elabInstance info syn what fc cs n ps t expn ds = do

20092170

20102171 mkMethApp (n, _, _, ty)

20112172 = 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'

20132174 = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

20142175 lamBind i (PPi _ n ty sc) sc'

20152176 = PLam (sMN i "meth") Placeholder (lamBind (i+1) sc sc')

20162177 lamBind i _ sc = sc

2017− methArgs i (PPi (Imp _ _ _ _) n ty sc)

2018− = PImp 0 True [] n (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc

2019− methArgs i (PPi (Exp _ _ _ _) n ty sc)

2020− = PExp 0 [] (PRef fc (sMN i "meth")) "" : methArgs (i+1) sc

2021− methArgs i (PPi (Constraint _ _ _) n ty sc)

2022− = PConstraint 0 [] (PResolveTC fc) "" : methArgs (i+1) sc

2178+ methArgs i (PPi (Imp _ _ _) n ty sc)

2179+ = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc

2180+ methArgs i (PPi (Exp _ _ _) n ty sc)

2181+ = PExp 0 [] (sMN 0 "marg") (PRef fc (sMN i "meth")) : methArgs (i+1) sc

2182+ methArgs i (PPi (Constraint _ _) n ty sc)

2183+ = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc

20232184 methArgs i _ = []

20242185

20252186 papp fc f [] = f

@@ -2027,7 +2188,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

20272188

20282189 getWParams [] = return []

20292190 getWParams (p : ps)

2030− | PRef _ n <- getTm p

2191+ | PRef _ n <- p

20312192 = do ps' <- getWParams ps

20322193 ctxt <- getContext

20332194 case lookupP n ctxt of

@@ -2035,15 +2196,15 @@ elabInstance info syn what fc cs n ps t expn ds = do

20352196 _ -> return ps'

20362197 getWParams (_ : ps) = getWParams ps

20372198

2038− decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

2199+ decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

20392200 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

20402201

2041− mkTyDecl (n, op, t, _) = PTy "" syn fc op n t

2202+ mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t

20422203

20432204 conbind (ty : ns) x = PPi constraint (sMN 0 "class") ty (conbind ns x)

20442205 conbind [] x = x

20452206

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)

20472208 coninsert cs sc = conbind cs sc

20482209

20492210 insertDefaults :: IState -> Name ->

@@ -2101,7 +2262,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

21012262 PClauses fc [Dictionary] cfn [PClause fc cfn lhs [] rhs []]]

21022263-}

21032264

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

21052266decorateid decorate (PClauses f o n cs)

21062267 = PClauses f o (decorate n) (map dc cs)

21072268 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 _ _ _)

21552316 = return () -- nothing to elaborate

21562317elabDecl' _ info (PSyntax _ p)

21572318 = 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)

21592320 | what /= EDefns

21602321 = 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

21622323 return ()

21632324elabDecl' what info (PPostulate doc s f o n ty)

21642325 | what /= EDefns

21652326 = do iLOG $ "Elaborating postulate " ++ show n ++ show o

21662327 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)

21682329 | what /= ETypes

21692330 = do iLOG $ "Elaborating " ++ show (d_name d)

2170− elabData info s doc f co d

2331+ elabData info s doc argDocs f co d

21712332 | otherwise

21722333 = 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))

21742335elabDecl' what info d@(PClauses f o n ps)

21752336 | what /= ETypes

21762337 = do iLOG $ "Elaborating clause " ++ show n

@@ -2184,6 +2345,11 @@ elabDecl' what info (PMutual f ps)

21842345 [p] -> elabDecl what info p

21852346 _ -> do mapM_ (elabDecl ETypes info) ps

21862347 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

21872353 -- Do totality checking after entire mutual block

21882354 i <- get

21892355 mapM_ (\n -> do logLvl 5 $ "Simplifying " ++ show n

@@ -2192,6 +2358,16 @@ elabDecl' what info (PMutual f ps)

21922358 mapM_ buildSCG (idris_totcheck i)

21932359 mapM_ checkDeclTotality (idris_totcheck i)

21942360 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 ()

21952371

21962372elabDecl' what info (PParams f ns ps)

21972373 = do i <- getIState

@@ -2214,30 +2390,30 @@ elabDecl' what info (PNamespace n ps) = mapM_ (elabDecl' what ninfo) ps

22142390 ninfo = case namespace info of

22152391 Nothing -> info { namespace = Just [n] }

22162392 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)

22182394 | what /= EDefns

22192395 = 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

22212397elabDecl' what info (PInstance s f cs n ps t expn ds)

22222398 = do iLOG $ "Elaborating instance " ++ show n

22232399 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)

22252401 | what /= ETypes

22262402 = 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

22282404 | otherwise

22292405 = 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)

22312407elabDecl' _ info (PDSL n dsl)

22322408 = do i <- getIState

22332409 putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })

22342410 addIBC (IBCDSL n)

22352411elabDecl' what info (PDirective i)

22362412 | what /= EDefns = i

2237−elabDecl' what info (PProvider syn fc provWhat n tp tm)

2413+elabDecl' what info (PProvider syn fc provWhat n)

22382414 | what /= EDefns

22392415 = do iLOG $ "Elaborating type provider " ++ show n

2240− elabProvider info syn fc provWhat n tp tm

2416+ elabProvider info syn fc provWhat n

22412417elabDecl' what info (PTransform fc safety old new)

22422418 = elabTransform info fc safety old new

22432419elabDecl' _ _ _ = return () -- skipped this time

@@ -2282,3 +2458,14 @@ inferredDiff fc inf user =

22822458 Right vs -> return False

22832459 Left (x, y) -> return True

22842460

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 @@

33module Idris.ElabTerm where

44

55import Idris.AbsSyntax

6+import Idris.AbsSyntaxTree

67import Idris.DSL

78import Idris.Delaborate

89import Idris.Error

910import Idris.ProofSearch

11+import Idris.Output (pshow)

1012

1113import Idris.Core.Elaborate hiding (Tactic(..))

1214import Idris.Core.TT

1315import Idris.Core.Evaluate

1416import Idris.Core.Unify

1517import Idris.Core.Typecheck (check)

18+import Idris.ErrReverse (errReverse)

1619

1720import Control.Applicative ((<$>))

1821import Control.Monad

1922import Control.Monad.State.Strict

2023import Data.List

2124import qualified Data.Map as M

22−import Data.Maybe (mapMaybe)

25+import Data.Maybe (mapMaybe, fromMaybe)

2326import qualified Data.Set as S

2427import qualified Data.Text as T

2528

2629import Debug.Trace

2730

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−

3831-- Using the elaborator, convert a term in raw syntax to a fully

3932-- elaborated, typechecked term.

4033--

@@ -72,13 +65,20 @@ build ist info pattern opts fn tm

7265 tm <- get_term

7366 ctxt <- get_context

7467 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

7575

76− when (not pattern) $ do matchProblems True; unifyProblems

7776 probs <- get_probs

7877 case probs of

7978 [] -> return ()

80− ((_,_,_,e,_):es) -> if inf then return ()

81− else lift (Error e)

79+ ((_,_,_,e,_,_):es) -> traceWhen u ("Final problems:\n" ++ show probs) $

80+ if inf then return ()

81+ else lift (Error e)

8282 is <- getAux

8383 tt <- get_term

8484 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

@@ -105,8 +105,8 @@ buildTC ist info pattern opts fn tm

105105 tm <- get_term

106106 case probs of

107107 [] -> return ()

108− ((_,_,_,e,_):es) -> if inf then return ()

109− else lift (Error e)

108+ ((_,_,_,e,_,_):es) -> if inf then return ()

109+ else lift (Error e)

110110 is <- getAux

111111 tt <- get_term

112112 let (tm, ds) = runState (collectDeferred (Just fn) tt) []

@@ -127,6 +127,7 @@ elab ist info pattern opts fn tm

127127 end_unify

128128 when pattern -- convert remaining holes to pattern vars

129129 (do update_term orderPats

130+ unify_all

130131 matchProblems False -- only the ones we matched earlier

131132 unifyProblems

132133 mkPat)

@@ -154,39 +155,42 @@ elab ist info pattern opts fn tm

154155

155156 elabE :: (Bool, Bool, Bool) -> PTerm -> ElabD ()

156157 elabE ina t =

157−-- do g <- goal

158−-- trace ("Elaborating " ++ show t ++ " : " ++ show g) $

158+ --do g <- goal

159+ --trace ("Elaborating " ++ show t ++ " : " ++ show g) $

159160 do ct <- insertCoerce ina t

160161 t' <- insertLazy ct

161162 g <- goal

162163 tm <- get_term

163164 ps <- get_probs

164165 hs <- get_holes

165−-- trace ("Elaborating " ++ show t' ++ " in " ++ show g

166−-- -- ++ "\n" ++ show tm

167−-- ++ "\nholes " ++ show hs

168−-- ++ "\nproblems " ++ show ps

169−-- ++ "\n-----------\n") $

170−-- trace ("ELAB " ++ show t') $

166+ --trace ("Elaborating " ++ show t' ++ " in " ++ show g

167+ -- ++ "\n" ++ show tm

168+ -- ++ "\nholes " ++ show hs

169+ -- ++ "\nproblems " ++ show ps

170+ -- ++ "\n-----------\n") $

171+ --trace ("ELAB " ++ show t') $

171172 let fc = fileFC "Force"

172− handleError forceErr

173+ env <- get_env

174+ handleError (forceErr env)

173175 (elab' ina t')

174176 (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,

176179 pexp ct])) True

177180

178− forceErr (CantUnify _ t t' _ _ _)

179− | (P _ (UN ht) _, _) <- unApply t,

180− ht == txt "Lazy" = True

181− forceErr (CantUnify _ t t' _ _ _)

182− | (P _ (UN ht) _, _) <- unApply t',

183− ht == txt "Lazy" = True

184− forceErr (InfiniteUnify _ t _)

185− | (P _ (UN ht) _, _) <- unApply t,

186− ht == txt "Lazy" = True

187− forceErr (Elaborating _ _ t) = forceErr t

188− forceErr (At _ t) = forceErr t

189− forceErr t = False

181+ forceErr env (CantUnify _ t t' _ _ _)

182+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

183+ ht == txt "Lazy'" = True

184+ forceErr env (CantUnify _ t t' _ _ _)

185+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t'),

186+ ht == txt "Lazy'" = True

187+ forceErr env (InfiniteUnify _ t _)

188+ | (P _ (UN ht) _, _) <- unApply (normalise (tt_ctxt ist) env t),

189+ ht == txt "Lazy'" = True

190+ forceErr env (Elaborating _ _ t) = forceErr env t

191+ forceErr env (ElaboratingArg _ _ _ t) = forceErr env t

192+ forceErr env (At _ t) = forceErr env t

193+ forceErr env t = False

190194

191195 local f = do e <- get_env

192196 return (f `elem` map fst e)

@@ -263,13 +267,14 @@ elab ist info pattern opts fn tm

263267 ty <- goal

264268 ctxt <- get_context

265269 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

267272-- trace (show as ++ "\n ==> " ++ showSep ", " (map showTmImpls as')) $

268273 tryAll (zip (map (elab' ina) as') (map showHd as'))

269− where showHd (PApp _ (PRef _ n) _) = show n

270− showHd (PRef _ n) = show n

271− showHd (PApp _ h _) = show h

272− showHd x = show x

274+ where showHd (PApp _ (PRef _ n) _) = n

275+ showHd (PRef _ n) = n

276+ showHd (PApp _ h _) = showHd h

277+ showHd x = NErased -- We probably should do something better than this here

273278 elab' ina (PAlternative False as)

274279 = trySeq as

275280 where -- if none work, take the error from the first

@@ -458,13 +463,15 @@ elab ist info pattern opts fn tm

458463-- trace ("ns is " ++ show ns) $ return ()

459464 -- mark any type class arguments as injective

460465 mapM_ checkIfInjective (map snd ns)

466+ unifyProblems -- try again with the new information,

467+ -- to help with disambiguation

461468 -- Sort so that the implicit tactics and alternatives go last

462469 let (ns', eargs) = unzip $

463470 sortBy cmpArg (zip ns args)

464471 elabArgs ist (ina || not isinf, guarded, inty)

465472 [] fc False f ns'

466473 (f == sUN "Force")

467− (map (\x -> (lazyarg x, getTm x)) eargs)

474+ (map (\x -> (False, getTm x)) eargs) -- TODO: remove this False arg

468475 solve

469476 ivs' <- get_instances

470477 -- Attempt to resolve any type classes which have 'complete' types,

@@ -480,12 +487,22 @@ elab ist info pattern opts fn tm

480487 (movelast n)

481488 else movelast n)

482489 (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.

484497 cmpArg (_, x) (_, y)

485498 = compare (conDepth 0 (getTm x) + priority x + alt x)

486499 (conDepth 0 (getTm y) + priority y + alt y)

487500 where alt t = case getTm t of

488501 PAlternative False _ -> 5

502+ PAlternative True _ -> 1

503+ PTactics _ -> 150

504+ PLam _ _ _ -> 2

505+ PRewrite _ _ _ _ -> 3

489506 _ -> 0

490507

491508 -- Score a point for every level where there is a non-constructor

@@ -549,7 +566,7 @@ elab ist info pattern opts fn tm

549566 claim tyn RType

550567 valn <- getNameFrom (sMN 0 "rval")

551568 claim valn (Var tyn)

552− letn <- getNameFrom (sMN 0 "rewrite_rule")

569+ letn <- getNameFrom (sMN 0 "_rewrite_rule")

553570 letbind letn (Var tyn) (Var valn)

554571 focus valn

555572 elab' ina r

@@ -672,15 +689,18 @@ elab ist info pattern opts fn tm

672689 let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)

673690 let tries = if pattern then [t, mkDelay t] else [mkDelay t, t]

674691 case tyh of

675− P _ (UN l) _ | l == txt "Lazy"

692+ P _ (UN l) _ | l == txt "Lazy'"

676693 -> return (PAlternative False tries)

677694 _ -> return t

678695 where

679696 mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)

680697 mkDelay t = let fc = fileFC "Delay" in

681− addImpl ist (PApp fc (PRef fc (sUN "Delay")) [pexp t])

682−

698+ addImpl ist (PApp fc (PRef fc (sUN "Delay"))

699+ [pexp t])

683700

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

684704 insertCoerce ina t =

685705 do ty <- goal

686706 -- Check for possible coercions to get to the goal

@@ -709,67 +729,41 @@ elab ist info pattern opts fn tm

709729 -> Bool -- ^ under a 'force'

710730 -> [(Bool, PTerm)] -- ^ (Laziness, argument)

711731 -> ElabD ()

712− elabArgs ist ina failed fc retry f [] force _

713−-- | retry = let (ns, ts) = unzip (reverse failed) in

714−-- elabArgs ina [] False ns ts

715− | otherwise = return ()

732+ elabArgs ist ina failed fc retry f [] force _ = return ()

716733 elabArgs ist ina failed fc r f (n:ns) force ((_, Placeholder) : args)

717734 = elabArgs ist ina failed fc r f ns force args

718735 elabArgs ist ina failed fc r f ((argName, holeName):ns) force ((lazy, t) : args)

719736 | lazy && not pattern

720− = elabArg argName holeName (PApp bi (PRef bi (sUN "lazy"))

737+ = elabArg argName holeName (PApp bi (PRef bi (sUN "Delay"))

721738 [pimp (sUN "a") Placeholder True,

722739 pexp t])

723740 | otherwise = elabArg argName holeName t

724741 where elabArg argName holeName t =

725− reflectFunctionErrors ist f argName $

726− do hs <- get_holes

727− tm <- get_term

728− -- No coercing under an explicit Force (or it can Force/Delay

729− -- recursively!)

730− let elab = if force then elab' else elabE

731− failed' <- -- trace (show (n, t, hs, tm)) $

732− -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

733− case holeName `elem` hs of

734− True -> do focus holeName; elab ina t; return failed

735− False -> return failed

736− elabArgs ist ina failed fc r f ns force args

737−

738−-- | Perform error reflection for function applicaitons with specific error handlers

739−reflectFunctionErrors :: IState -> Name -> Name -> ElabD a -> ElabD a

740−reflectFunctionErrors ist f arg action =

741− do elabState <- get

742− (result, newState) <- case runStateT action elabState of

743− OK (res, newState) -> return (res, newState)

744− Error e@(ReflectionError _ _) -> (lift . tfail) e

745− Error e@(ReflectionFailed _ _) -> (lift . tfail) e

746− Error e -> handle e >>= lift . tfail

747− put newState

748− return result

749− where handle :: Err -> ElabD Err

750− handle e = do let funhandlers = (maybe M.empty id . lookupCtxtExact f . idris_function_errorhandlers) ist

751− handlers = (maybe [] S.toList . M.lookup arg) funhandlers

752− reports = map (\n -> RApp (Var n) (reflectErr e)) handlers

753−

754−

755− -- Typecheck error handlers - if this fails, then something else was wrong earlier!

756− handlers <- case mapM (check (tt_ctxt ist) []) reports of

757− Error e -> lift . tfail $

758− ReflectionFailed "Type error while constructing reflected error" e

759− OK hs -> return hs

760−

761− -- Normalize error handler terms to produce the new messages

762− let ctxt = tt_ctxt ist

763− results = map (normalise ctxt []) (map fst handlers)

764−

765− -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

766− let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

767− errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

768− Left err -> lift (tfail err)

769− Right ok -> return ok

770− return $ case errorparts of

771− [] -> e

772− parts -> ReflectionError errorparts e

742+ do now_elaborating fc f argName

743+ wrapErr f argName $ do

744+ hs <- get_holes

745+ tm <- get_term

746+ -- No coercing under an explicit Force (or it can Force/Delay

747+ -- recursively!)

748+ let elab = if force then elab' else elabE

749+ failed' <- -- trace (show (n, t, hs, tm)) $

750+ -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

751+ case holeName `elem` hs of

752+ True -> do focus holeName; elab ina t; return failed

753+ False -> return failed

754+ done_elaborating_arg f argName

755+ elabArgs ist ina failed fc r f ns force args

756+ wrapErr f argName action =

757+ do elabState <- get

758+ while <- elaborating_app

759+ let while' = map (\(x, y, z)-> (y, z)) while

760+ (result, newState) <- case runStateT action elabState of

761+ OK (res, newState) -> return (res, newState)

762+ Error e -> do done_elaborating_arg f argName

763+ lift (tfail (elaboratingArgErr while' e))

764+ put newState

765+ return result

766+

773767

774768-- For every alternative, look at the function at the head. Automatically resolve

775769-- any nested alternatives where that function is also at the head

@@ -787,6 +781,7 @@ pruneAlt xs = map prune xs

787781 case fs of

788782 [a] -> a

789783 _ -> PAlternative a as'

784+

790785 choose f (PApp fc f' as) = PApp fc (choose f f') (fmap (fmap (choose f)) as)

791786 choose f t = t

792787

@@ -796,8 +791,21 @@ pruneAlt xs = map prune xs

796791

797792-- Rule out alternatives that don't return the same type as the head of the goal

798793-- (If there are none left as a result, do nothing)

799−pruneByType :: Term -> Context -> [PTerm] -> [PTerm]

800−pruneByType (P _ n _) c as

794+pruneByType :: [Name] -> Term -> Context -> [PTerm] -> [PTerm]

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

801809-- if the goal type is polymorphic, keep e

802810 | [] <- lookupTy n c = as

803811 | otherwise

@@ -823,7 +831,7 @@ pruneByType (P _ n _) c as

823831 _ -> False

824832 _ -> False

825833

826−pruneByType t _ as = as

834+pruneByType _ t _ as = as

827835

828836findInstances :: IState -> Term -> [Name]

829837findInstances ist t

@@ -835,9 +843,10 @@ findInstances ist t

835843

836844trivial' ist

837845 = trivial (elab ist toplevel False [] (sMN 0 "tac")) ist

838−proofSearch' ist top n hints

839− = proofSearch (elab ist toplevel False [] (sMN 0 "tac")) top n hints ist

840−

846+proofSearch' ist rec depth prv top n hints

847+ = do unifyProblems

848+ proofSearch rec prv depth

849+ (elab ist toplevel False [] (sMN 0 "tac")) top n hints ist

841850

842851resolveTC :: Int -> Term -> Name -> IState -> ElabD ()

843852resolveTC = resTC' []

@@ -926,7 +935,7 @@ resTC' tcs depth topg fn ist

926935 ulog <- getUnifyLog

927936 solve

928937 traceWhen ulog ("Got " ++ show n) $ return ()

929− where isImp (PImp p _ _ _ _ _) = (True, p)

938+ where isImp (PImp p _ _ _ _) = (True, p)

930939 isImp arg = (False, priority arg)

931940

932941collectDeferred :: Maybe Name ->

@@ -982,7 +991,7 @@ runTac autoSolve ist fn tac

982991 ns -> return (map (\ (n, a) -> (n, map (const True) a)) ns)

983992 let tacs = map (\ (fn', imps) ->

984993 (match_apply (Var fn') (map (\x -> (x, 0)) imps),

985− show fn')) fnimps

994+ fn')) fnimps

986995 tryAll tacs

987996 when autoSolve solveAll

988997 where envArgs n = do e <- get_env

@@ -998,10 +1007,10 @@ runTac autoSolve ist fn tac

9981007 ns -> return (map (\ (n, a) -> (n, map isImp a)) ns)

9991008 let tacs = map (\ (fn', imps) ->

10001009 (apply (Var fn') (map (\x -> (x, 0)) imps),

1001− show fn')) fnimps

1010+ fn')) fnimps

10021011 tryAll tacs

10031012 when autoSolve solveAll

1004− where isImp (PImp _ _ _ _ _ _) = True

1013+ where isImp (PImp _ _ _ _ _) = True

10051014 isImp _ = False

10061015 envArgs n = do e <- get_env

10071016 case lookup n e of

@@ -1010,6 +1019,8 @@ runTac autoSolve ist fn tac

10101019 _ -> return []

10111020 runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps)

10121021 when autoSolve solveAll

1022+ runT DoUnify = do unify_all

1023+ when autoSolve solveAll

10131024 runT (Equiv tm) -- let bind tm, then

10141025 = do attack

10151026 tyn <- getNameFrom (sMN 0 "ety")

@@ -1065,8 +1076,9 @@ runTac autoSolve ist fn tac

10651076 runT Compute = compute

10661077 runT Trivial = do trivial' ist; when autoSolve solveAll

10671078 runT TCInstance = runT (Exact (PResolveTC emptyFC))

1068− runT (ProofSearch top hints)

1069− = do proofSearch' ist top fn hints; when autoSolve solveAll

1079+ runT (ProofSearch rec prover depth top hints)

1080+ = do proofSearch' ist rec depth prover top fn hints

1081+ when autoSolve solveAll

10701082 runT (Focus n) = focus n

10711083 runT Solve = solve

10721084 runT (Try l r) = do try' (runT l) (runT r) True

@@ -1098,9 +1110,9 @@ runTac autoSolve ist fn tac

10981110 runReflected tactic

10991111 where tacticTy = Var (reflm "Tactic")

11001112 listTy = Var (sNS (sUN "List") ["List", "Prelude"])

1101− scriptTy = (RBind (sUN "__pi_arg")

1113+ scriptTy = (RBind (sMN 0 "__pi_arg")

11021114 (Pi (RApp listTy envTupleType))

1103− (RBind (sUN "__pi_arg1")

1115+ (RBind (sMN 1 "__pi_arg")

11041116 (Pi (Var $ reflm "TT")) tacticTy))

11051117 runT (ByReflection tm) -- run the reflection function 'tm' on the

11061118 -- goal, then apply the resulting reflected Tactic

@@ -1193,18 +1205,22 @@ reify _ t = fail ("Unknown tactic " ++ show t)

11931205

11941206reifyApp :: IState -> Name -> [Term] -> ElabD PTactic

11951207reifyApp 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 [])

11961210reifyApp _ t [x]

11971211 | t == reflm "Refine" = do n <- reifyTTName x

11981212 return $ Refine n []

11991213reifyApp ist t [l, r] | t == reflm "Seq" = liftM2 TSeq (reify ist l) (reify ist r)

12001214reifyApp ist t [Constant (Str n), x]

12011215 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

1202−reifyApp _ t [Constant (Str n)]

1203− | t == reflm "Intro" = return $ Intro [sUN n]

1216+reifyApp _ t [n] | t == reflm "Intro" = liftM (Intro . (:[])) (reifyTTName n)

1217+reifyApp _ t [n] | t == reflm "Induction" = liftM Induction (reifyTTName n)

12041218reifyApp ist t [t']

12051219 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

12061220reifyApp ist t [t']

12071221 | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

1222+reifyApp ist t [t']

1223+ | t == reflm "ByReflection" = liftM (ByReflection . delab ist) (reifyTT t')

12081224reifyApp _ t [t']

12091225 | t == reflm "Fill" = liftM (Fill . PQuote) (reifyRaw t')

12101226reifyApp ist t [t']

@@ -1593,8 +1609,8 @@ reflectErr (NotInjective t1 t2 t3) =

15931609 ]

15941610reflectErr (CantResolve t) = raw_apply (Var $ reflErrName "CantResolve") [reflect t]

15951611reflectErr (CantResolveAlts ss) =

1596− raw_apply (Var $ reflErrName "CantResolve")

1597− [rawList (Var $ (sUN "String")) (map (RConstant . Str) ss)]

1612+ raw_apply (Var $ reflErrName "CantResolveAlts")

1613+ [rawList (Var $ (sUN "String")) (map Var ss)]

15981614reflectErr (IncompleteTerm t) = raw_apply (Var $ reflErrName "IncompleteTerm") [reflect t]

15991615reflectErr UniverseError = Var $ reflErrName "UniverseError"

16001616reflectErr ProgramLineComment = Var $ reflErrName "ProgramLineComment"

@@ -1603,24 +1619,20 @@ reflectErr (NonCollapsiblePostulate n) = raw_apply (Var $ reflErrName "NonCollab

16031619reflectErr (AlreadyDefined n) = raw_apply (Var $ reflErrName "AlreadyDefined") [reflectName n]

16041620reflectErr (ProofSearchFail e) = raw_apply (Var $ reflErrName "ProofSearchFail") [reflectErr e]

16051621reflectErr (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− ]

16181622reflectErr (ProviderError str) =

16191623 raw_apply (Var $ reflErrName "ProviderError") [RConstant (Str str)]

16201624reflectErr (LoadingFailed str err) =

16211625 raw_apply (Var $ reflErrName "LoadingFailed") [RConstant (Str str)]

16221626reflectErr x = raw_apply (Var (sNS (sUN "Msg") ["Errors", "Reflection", "Language"])) [RConstant . Str $ "Default reflection: " ++ show x]

16231627

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+

16241636

16251637withErrorReflection :: Idris a -> Idris a

16261638withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

@@ -1629,30 +1641,59 @@ withErrorReflection x = idrisCatch x (\ e -> handle e >>= ierror)

16291641 return e -- Don't do meta-reflection of errors

16301642 handle e@(ReflectionFailed _ _) = do logLvl 3 "Skipping reflection of reflection failure"

16311643 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

16321660 handle e = do ist <- getIState

16331661 logLvl 2 "Starting error reflection"

16341662 let handlers = idris_errorhandlers ist

1635− logLvl 3 $ "Using reflection handlers " ++ concat (intersperse ", " (map show handlers))

1636− let reports = map (\n -> RApp (Var n) (reflectErr e)) handlers

1637−

1638− -- Typecheck error handlers - if this fails, then something else was wrong earlier!

1639− handlers <- case mapM (check (tt_ctxt ist) []) reports of

1640− Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e

1641− OK hs -> return hs

1642−

1643− -- Normalize error handler terms to produce the new messages

1644− ctxt <- getContext

1645− let results = map (normalise ctxt []) (map fst handlers)

1646− logLvl 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

1647−

1648− -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent

1649− let errorpartsTT = mapMaybe unList (mapMaybe fromTTMaybe results)

1650− errorparts <- case mapM (mapM reifyReportPart) errorpartsTT of

1651− Left err -> ierror err

1652− Right ok -> return ok

1653− return $ case errorparts of

1654− [] -> e

1655− parts -> ReflectionError errorparts e

1663+ applyHandlers e handlers

1664+ getFnHandlers :: Name -> Name -> Idris [Name]

1665+ getFnHandlers f arg = do ist <- getIState

1666+ let funHandlers = maybe M.empty id .

1667+ lookupCtxtExact f .

1668+ idris_function_errorhandlers $ ist

1669+ return . maybe [] S.toList . M.lookup arg $ funHandlers

1670+

1671+

1672+ applyHandlers e handlers =

1673+ do ist <- getIState

1674+ let err = fmap (errReverse ist) e

1675+ logLvl 3 $ "Using reflection handlers " ++

1676+ concat (intersperse ", " (map show handlers))

1677+ let reports = map (\n -> RApp (Var n) (reflectErr err)) handlers

1678+

1679+ -- Typecheck error handlers - if this fails, then something else was wrong earlier!

1680+ handlers <- case mapM (check (tt_ctxt ist) []) reports of

1681+ Error e -> ierror $ ReflectionFailed "Type error while constructing reflected error" e

1682+ OK hs -> return hs

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

16561697

16571698fromTTMaybe :: Term -> Maybe Term -- WARNING: Assumes the term has type Maybe a

16581699fromTTMaybe (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

55import Prelude hiding (catch)

66import Idris.AbsSyntax

77import Idris.Delaborate

8+import Idris.Output

89

910import Idris.Core.TT

1011import Idris.Core.Typecheck

@@ -23,7 +24,7 @@ iucheck = do tit <- typeInType

2324 when (not tit) $

2425 do ist <- getIState

2526 (tclift $ ucheck (idris_constraints ist)) `idrisCatch`

26− (\e -> do setErrLine (getErrLine e)

27+ (\e -> do setErrSpan (getErrSpan e)

2728 iputStrLn (pshow ist e))

2829

2930showErr :: Err -> Idris String

@@ -42,11 +43,13 @@ idrisCatch = catchError

4243setAndReport :: Err -> Idris ()

4344setAndReport e = do ist <- getIState

4445 let h = idris_outh ist

45− case e of

46− At fc@(FC f l c) e -> do setErrLine l

47− ihWarn h fc $ pprintErr ist e

48− _ -> do setErrLine (getErrLine e)

49− ihputStrLn h $ pshow ist e

46+ case (unwrap e) of

47+ At fc e -> do setErrSpan fc

48+ ihWarn h fc $ pprintErr ist e

49+ _ -> do setErrSpan (getErrSpan e)

50+ ihWarn h emptyFC $ pprintErr ist e

51+ where unwrap (ProofSearchFail e) = e -- remove bookkeeping constructor

52+ unwrap e = e

5053

5154ifail :: String -> Idris a

5255ifail = throwError . Msg

@@ -56,7 +59,7 @@ ierror = throwError

5659

5760tclift :: TC a -> Idris a

5861tclift (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

6063tclift (Error err) = throwError err

6164

6265tctry :: TC a -> TC a -> Idris a

@@ -65,11 +68,6 @@ tctry tc1 tc2

6568 OK v -> return v

6669 Error err -> tclift tc2

6770

68−getErrLine :: Err -> Int

69−getErrLine (At (FC _ l _) _) = l

70−getErrLine _ = 0

71−

72−getErrColumn :: Err -> Int

73−getErrColumn (At (FC _ _ c) _) = c

74−getErrColumn _ = 0

75−

71+getErrSpan :: Err -> FC

72+getErrSpan (At fc _) = fc

73+getErrSpan _ = emptyFC

src/Idris/Help.hs+12−6

@@ -4,6 +4,7 @@ data CmdArg = ExprArg -- ^ The command takes an expression

44 | NameArg -- ^ The command takes a name

55 | FileArg -- ^ The command takes a file

66 | ModuleArg -- ^ The command takes a module name

7+ | NamespaceArg -- ^ The command takes a namespace name

78 | OptionArg -- ^ The command takes an option

89 | MetaVarArg -- ^ The command takes a metavariable

910 | ColourArg -- ^ The command is the colour-setting command

@@ -16,6 +17,7 @@ instance Show CmdArg where

1617 show NameArg = "<name>"

1718 show FileArg = "<filename>"

1819 show ModuleArg = "<module>"

20+ show NamespaceArg = "<namespace>"

1921 show OptionArg = "<option>"

2022 show MetaVarArg = "<metavar>"

2123 show ColourArg = "<option>"

@@ -29,22 +31,25 @@ help =

2931 ([":t"], ExprArg, "Check the type of an expression"),

3032 ([":miss", ":missing"], NameArg, "Show missing clauses"),

3133 ([":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"),

3339 ([":total"], NameArg, "Check the totality of a name"),

3440 ([":r",":reload"], NoArg, "Reload current file"),

3541 ([":l",":load"], FileArg, "Load a new file"),

3642 ([":cd"], FileArg, "Change working directory"),

37− ([":m",":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons

43+ ([":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons

3844 ([":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)"),

4046 ([":p",":prove"], MetaVarArg, "Prove a metavariable"),

4147 ([":a",":addproof"], NameArg, "Add proof to source file"),

4248 ([":rmproof"], NameArg, "Remove proof from proof stack"),

4349 ([":showproof"], NameArg, "Show proof"),

4450 ([":proofs"], NoArg, "Show available proofs"),

4551 ([":x"], ExprArg, "Execute IO actions resulting from an expression using the interpreter"),

46− ([":c",":compile"], FileArg, "Compile to an executable <filename>"),

47− ([":js", ":javascript"], FileArg, "Compile to JavaScript <filename>"),

52+ ([":c",":compile"], FileArg, "Compile to an executable [codegen] <filename>"),

4853 ([":exec",":execute"], NoArg, "Compile to an executable and run"),

4954 ([":dynamic"], FileArg, "Dynamically load a C library (similar to %dynamic)"),

5055 ([":dynamic"], NoArg, "List dynamically loaded C libraries"),

@@ -53,7 +58,8 @@ help =

5358 ([":unset"], OptionArg, "Unset an option"),

5459 ([":colour", ":color"], ColourArg, "Turn REPL colours on or off; set a specific colour"),

5560 ([":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")

5763 ]

5864

5965-- | Use these for completion, but don't show them in :help

src/Idris/IBC.hs+229−86

This diff is too big to show here.

src/Idris/IdeSlave.hs+92−24

This diff is too big to show here.

src/Idris/IdrisDoc.hsnew file+661

This diff is too big to show here.

src/Idris/Imports.hs+7−6

This diff is too big to show here.

src/Idris/Interactive.hsnew file+341

This diff is too big to show here.

src/Idris/Output.hsnew file+155

This diff is too big to show here.

src/Idris/ParseData.hs+31−26

This diff is too big to show here.

src/Idris/ParseExpr.hs+258−197

This diff is too big to show here.

src/Idris/ParseHelpers.hs+60−45

This diff is too big to show here.

src/Idris/ParseOps.hs+13−6

This diff is too big to show here.

src/Idris/Parser.hs+96−60

This diff is too big to show here.

src/Idris/PartialEval.hs+1−1

This diff is too big to show here.

src/Idris/Primitives.hs+63−9

This diff is too big to show here.

src/Idris/ProofSearch.hs+62−14

This diff is too big to show here.

src/Idris/Prover.hs+119−94

This diff is too big to show here.

src/Idris/Providers.hs+2−7

This diff is too big to show here.

src/Idris/REPL.hs+468−440

This diff is too big to show here.

src/Idris/REPLParser.hs+44−10

This diff is too big to show here.

src/Idris/TypeSearch.hsnew file+303

This diff is too big to show here.

src/Idris/Unlit.hs+2−2

This diff is too big to show here.

src/Idris/UnusedArgs.hsdeleted−65

This diff is too big to show here.

src/Idris/WhoCalls.hsnew file+93

This diff is too big to show here.

src/Pkg/PParser.hs+15−3

This diff is too big to show here.

src/Pkg/Package.hs+79−5

This diff is too big to show here.

src/Util/LLVMStubs.hs+2−9

This diff is too big to show here.

test/Makefile+3−3

This diff is too big to show here.

test/README+2

This diff is too big to show here.

test/basic001/reg005.idr+15−16

This diff is too big to show here.

test/basic002/test006.idr+2−2

This diff is too big to show here.

test/basic006/expected+8−7

This diff is too big to show here.

test/basic007/test033.idr+1−1

This diff is too big to show here.

test/basic009/expected+2−1

This diff is too big to show here.

test/basic010/Main.idrnew file+43

This diff is too big to show here.

test/basic010/expectednew file+3

This diff is too big to show here.

test/basic010/runnew file+35

This diff is too big to show here.

test/effects001/test021.idr+7−9

This diff is too big to show here.

test/effects001/test021a.idr+2−2

This diff is too big to show here.

test/effects002/test025.idr+4−4

This diff is too big to show here.

test/error003/ErrorReflection.idr−11

This diff is too big to show here.

test/error003/expected+2−3

This diff is too big to show here.

test/error004/FunErrTest.idr+2−2

This diff is too big to show here.

test/error004/expected+4−2

This diff is too big to show here.

test/ffi005/Postulate.idr+3−3

This diff is too big to show here.

test/ffi005/Postulate2.idrdeleted−13

This diff is too big to show here.

test/ffi005/Postulate3.idrdeleted−13

This diff is too big to show here.

test/ffi005/expected−2

This diff is too big to show here.

test/ffi005/run−7

This diff is too big to show here.

test/folding001/expectednew file+4

This diff is too big to show here.

test/folding001/folding001.idrnew file+23

This diff is too big to show here.

test/folding001/runnew file+4

This diff is too big to show here.

test/folding002/expectednew file+2

This diff is too big to show here.

test/folding002/folding002.idrnew file+23

This diff is too big to show here.

test/folding002/runnew file+4

This diff is too big to show here.

test/idrisdoc001/TestEmpty.idrnew file+1

This diff is too big to show here.

test/idrisdoc001/TestPrivate.idrnew file+5

This diff is too big to show here.

test/idrisdoc001/expectednew file+5

This diff is too big to show here.

test/idrisdoc001/runnew file+4

This diff is too big to show here.

test/idrisdoc001/test_empty.ipkgnew file+4

This diff is too big to show here.

test/idrisdoc002/TestFunctions.idrnew file+5

This diff is too big to show here.

test/idrisdoc002/expectednew file+2

This diff is too big to show here.

test/idrisdoc002/runnew file+5

This diff is too big to show here.

test/idrisdoc002/test_functions.ipkgnew file+4

This diff is too big to show here.

test/idrisdoc003/TestDatatypes.idrnew file+6

This diff is too big to show here.

test/idrisdoc003/expectednew file+2

This diff is too big to show here.

test/idrisdoc003/runnew file+5

This diff is too big to show here.

test/idrisdoc003/test_datatypes.ipkgnew file+4

This diff is too big to show here.

test/idrisdoc004/TestTypeclasses.idrnew file+8

This diff is too big to show here.

test/idrisdoc004/expectednew file+2

This diff is too big to show here.

test/idrisdoc004/runnew file+5

This diff is too big to show here.

test/idrisdoc004/test_typeclasses.ipkgnew file+4

This diff is too big to show here.

test/idrisdoc005/TestTracing.idrnew file+4

This diff is too big to show here.

test/idrisdoc005/expectednew file+3

This diff is too big to show here.

test/idrisdoc005/runnew file+6

This diff is too big to show here.

test/idrisdoc005/test_tracing.ipkgnew file+4

This diff is too big to show here.

test/idrisdoc006/A/fully/Qualified/NAME.idrnew file+6

This diff is too big to show here.

test/idrisdoc006/B.idrnew file+5

This diff is too big to show here.

test/idrisdoc006/expectednew file+7

This diff is too big to show here.

test/idrisdoc006/package_a.ipkgnew file+4

This diff is too big to show here.

test/idrisdoc006/package_b.ipkgnew file+4

This diff is too big to show here.

test/idrisdoc006/runnew file+17

This diff is too big to show here.

test/idrisdoc007/A.idrnew file+6

This diff is too big to show here.

test/idrisdoc007/expectednew file+1

This diff is too big to show here.

test/idrisdoc007/package.ipkgnew file+4

This diff is too big to show here.

test/idrisdoc007/runnew file+6

This diff is too big to show here.

test/idrisdoc008/Abstract.idrnew file+5

This diff is too big to show here.

test/idrisdoc008/Visible.idrnew file+5

This diff is too big to show here.

test/idrisdoc008/expectednew file+4

This diff is too big to show here.

test/idrisdoc008/runnew file+6

This diff is too big to show here.

test/idrisdoc008/visibility.ipkgnew file+4

This diff is too big to show here.

test/interactive001/expected+1−1

This diff is too big to show here.

test/interactive003/expected+2−2

This diff is too big to show here.

test/interactive004/expectednew file+3

This diff is too big to show here.

test/interactive004/inputnew file+2

This diff is too big to show here.

test/interactive004/interactive004.idrnew file+7

This diff is too big to show here.

test/interactive004/runnew file+3

This diff is too big to show here.

test/proof002/expected+10−9

This diff is too big to show here.

test/proof003/Parity.idr+2−2

This diff is too big to show here.

test/proof005/DefaultArgSubstitutionSuccess.idrnew file+44

This diff is too big to show here.

test/proof005/expectednew file

No changes to the content.

test/proof005/runnew file+3

This diff is too big to show here.

test/proof006/DefaultArgSubstitutionSyntax.idrnew file+49

This diff is too big to show here.

test/proof006/expectednew file

No changes to the content.

test/proof006/runnew file+3

This diff is too big to show here.

test/proof007/DefaultArgUnknownName.idrnew file+4

This diff is too big to show here.

test/proof007/expectednew file+1

This diff is too big to show here.

test/proof007/runnew file+3

This diff is too big to show here.

test/records002/expectednew file+2

This diff is too big to show here.

test/records002/record002.idrnew file+11

This diff is too big to show here.

test/records002/runnew file+4

This diff is too big to show here.

test/records003/expectednew file+6

This diff is too big to show here.

test/records003/records003.idrnew file+48

This diff is too big to show here.

test/records003/runnew file+4

This diff is too big to show here.

test/reg007/expected+1−1

This diff is too big to show here.

test/reg014/reg014.idr+6−6

This diff is too big to show here.

test/reg018/expected+3−2

This diff is too big to show here.

test/reg018/run+1

This diff is too big to show here.

test/reg025/reg025.idr+1−1

This diff is too big to show here.

test/reg029/run+1−1

This diff is too big to show here.

test/reg030/reg030.idr+1−1

This diff is too big to show here.

test/reg034/expected+18−16

This diff is too big to show here.

test/reg037/expectednew file

No changes to the content.

test/reg037/reg037.idrnew file+9

This diff is too big to show here.

test/reg037/runnew file+3

This diff is too big to show here.

test/reg038/expectednew file

No changes to the content.

test/reg038/reg038.idrnew file+17

This diff is too big to show here.

test/reg038/runnew file+3

This diff is too big to show here.

test/reg039/expectednew file+2

This diff is too big to show here.

test/reg039/reg039.idrnew file+12

This diff is too big to show here.

test/reg039/runnew file+32

This diff is too big to show here.

test/reg040/expectednew file+1

This diff is too big to show here.

test/reg040/reg040.idrnew file+7

This diff is too big to show here.

test/reg040/runnew file+6

This diff is too big to show here.

test/reg041/expectednew file+3

This diff is too big to show here.

test/reg041/ott.idrnew file+42

This diff is too big to show here.

test/reg041/runnew file+5

This diff is too big to show here.

test/reg041/showu.idrnew file+23

This diff is too big to show here.

test/reg042/expectednew file+1

This diff is too big to show here.

test/reg042/reg042.idrnew file+24

This diff is too big to show here.

test/reg042/runnew file+4

This diff is too big to show here.

test/reg043/expectednew file+1

This diff is too big to show here.

test/reg043/runnew file+3

This diff is too big to show here.

test/reg044/expectednew file+11

This diff is too big to show here.

test/reg044/reg044.idrnew file+6

This diff is too big to show here.

test/reg044/runnew file+3

This diff is too big to show here.

test/sugar004/expectednew file+3

This diff is too big to show here.

test/sugar004/runnew file+6

This diff is too big to show here.

test/sugar004/sugar004.idrnew file+36

This diff is too big to show here.

test/totality001/run+3−3

This diff is too big to show here.

test/totality004/expectednew file+3

This diff is too big to show here.

test/totality004/runnew file+5

This diff is too big to show here.

test/totality004/totality004.idrnew file+25

This diff is too big to show here.

test/totality004/totality004a.idrnew file+25

This diff is too big to show here.

test/totality005/expectednew file+1

This diff is too big to show here.

test/totality005/runnew file+5

This diff is too big to show here.

test/totality005/totality005.idrnew file+10

This diff is too big to show here.

test/totality006/expectednew file+2

This diff is too big to show here.

test/totality006/runnew file+4

This diff is too big to show here.

test/totality006/totality006.idrnew file+11

This diff is too big to show here.

test/totality006/totality006a.idrnew file+10

This diff is too big to show here.

test/totality007/expectednew file+3

This diff is too big to show here.

test/totality007/runnew file+3

This diff is too big to show here.

test/totality007/src/Totality.idrnew file+4

This diff is too big to show here.

test/totality007/totality.ipkgnew file+7

This diff is too big to show here.

test/totality008/expectednew file+1

This diff is too big to show here.

test/totality008/runnew file+3

This diff is too big to show here.

test/totality008/totality008.idrnew file+8

This diff is too big to show here.

test/tutorial001/expectednew file

No changes to the content.

test/tutorial001/runnew file+3

This diff is too big to show here.

test/tutorial001/tutorial001.idrnew file+9

This diff is too big to show here.

test/tutorial002/expectednew file

No changes to the content.

test/tutorial002/runnew file+3

This diff is too big to show here.

examples/binary.idr → test/tutorial002/tutorial002.idrrenamed+11−12

This diff is too big to show here.

test/tutorial003/expectednew file

No changes to the content.

test/tutorial003/runnew file+3

This diff is too big to show here.

examples/idiom.idr → test/tutorial003/tutorial003.idrrenamed

The content is the same.

test/tutorial004/expectednew file

No changes to the content.

test/tutorial004/runnew file+3

This diff is too big to show here.

examples/theorems.idr → test/tutorial004/tutorial004.idrrenamed

The content is the same.

test/tutorial005/expectednew file

No changes to the content.

test/tutorial005/runnew file+3

This diff is too big to show here.

examples/wheres.idr → test/tutorial005/tutorial005.idrrenamed

The content is the same.

test/tutorial006/expectednew file+23

This diff is too big to show here.

test/tutorial006/runnew file+4

This diff is too big to show here.

examples/vbroken.idr → test/tutorial006/tutorial006a.idrrenamed

The content is the same.

test/tutorial006/tutorial006b.idrnew file+12

This diff is too big to show here.