a3221e3 · Idris-dev · git.iko.soy

.travis.yml+2

@@ -6,6 +6,8 @@ before_install:

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

7 # trifecta dependencies

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

9+ # test dependency

10+ - sudo apt-get install -qq expect

9install:

11install:

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

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

11before_script:

13before_script:

CHANGELOG+7−3

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

1+New in 0.9.13:

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

3+* IDE support for retrieving structured information about metavariables

4+

1New in 0.9.12:

5New in 0.9.12:

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

6--------------

3

7

@@ -5,7 +9,7 @@ New in 0.9.12:

5 type inference.

9 type inference.

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

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

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

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

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

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

9* Lots of performance patches for generated JavaScript.

13* Lots of performance patches for generated JavaScript.

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

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

11 or show the type of expressions.

15 or show the type of expressions.

@@ -17,8 +21,8 @@ New in 0.9.12:

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

21 ||| @ n the first number (examined by the function)

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

22 ||| @ m the second number (not examined)

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

23 plus (n, m : Nat) -> Nat

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

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

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

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

22* Updated 'effects' library

26* Updated 'effects' library

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

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

24* Unification errors are now slightly more informative

28* Unification errors are now slightly more informative

README+1−1

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

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

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

2language with dependent types.

3

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

examples/binary.idrdeleted−62

@@ -1,62 +0,0 @@

1−module Main

2−

3−data Binary : Nat -> Type where

4− bEnd : Binary Z

5− bO : Binary n -> Binary (n + n)

6− bI : Binary n -> Binary (S (n + n))

7−

8−instance Show (Binary n) where

9− show (bO x) = show x ++ "0"

10− show (bI x) = show x ++ "1"

11− show bEnd = ""

12−

13−data Parity : Nat -> Type where

14− even : Parity (n + n)

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

16−

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

18−parity Z = even {n=Z}

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

20−parity (S (S k)) with (parity k)

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

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

23−

24−natToBin : (n:Nat) -> Binary n

25−natToBin Z = bEnd

26−natToBin (S k) with (parity k)

27− natToBin (S (j + j)) | even = bI (natToBin j)

28− natToBin (S (S (j + j))) | odd ?= bO (natToBin (S j))

29−

30−intToNat : Int -> Nat

31−intToNat 0 = Z

32−intToNat x = if (x>0) then (S (intToNat (x-1))) else Z

33−

34−main : IO ()

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

36− x <- getLine

37− print (natToBin (fromInteger (cast x)))

38−

39−---------- Proofs ----------

40−

41−parity_lemma_1 = proof {

42− intros;

43− rewrite sym (plusSuccRightSucc j j);

44− trivial;

45−}

46−

47−natToBin_lemma_1 = proof {

48− intro;

49− intro;

50− rewrite sym (plusSuccRightSucc j j);

51− trivial;

52−}

53−

54−parity_lemma_2 = proof {

55− intro;

56− intro;

57− rewrite sym (plusSuccRightSucc j j);

58− trivial;

59−}

60−

61−

62−

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/idiom.idrdeleted−38

@@ -1,38 +0,0 @@

1−module idiom

2−

3−data Expr = Var String

4− | Val Int

5− | Add Expr Expr

6−

7−data Eval : Type -> Type where

8− MkEval : (List (String, Int) -> Maybe a) -> Eval a

9−

10−fetch : String -> Eval Int

11−fetch x = MkEval (\e => fetchVal e) where

12− fetchVal : List (String, Int) -> Maybe Int

13− fetchVal [] = Nothing

14− fetchVal ((v, val) :: xs) = if (x == v) then (Just val) else (fetchVal xs)

15−

16−instance Functor Eval where

17− map f (MkEval g) = MkEval (\e => map f (g e))

18−

19−instance Applicative Eval where

20− pure x = MkEval (\e => Just x)

21−

22− (<$>) (MkEval f) (MkEval g) = MkEval (\x => app (f x) (g x)) where

23− app : Maybe (a -> b) -> Maybe a -> Maybe b

24− app (Just fx) (Just gx) = Just (fx gx)

25− app _ _ = Nothing

26−

27−eval : Expr -> Eval Int

28−eval (Var x) = fetch x

29−eval (Val x) = [| x |]

30−eval (Add x y) = [| eval x + eval y |]

31−

32−runEval : List (String, Int) -> Expr -> Maybe Int

33−runEval env e = case eval e of

34− MkEval envFn => envFn env

35−

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

37−m_add' x y = [| x + y |]

38−

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/theorems.idrdeleted−57

@@ -1,57 +0,0 @@

1−

2−fiveIsFive : 5 = 5

3−fiveIsFive = refl

4−

5−twoPlusTwo : 2 + 2 = 4

6−twoPlusTwo = refl

7−

8−total disjoint : (n : Nat) -> Z = S n -> _|_

9−disjoint n p = replace {P = disjointTy} p ()

10− where

11− disjointTy : Nat -> Type

12− disjointTy Z = ()

13− disjointTy (S k) = _|_

14−

15−total acyclic : (n : Nat) -> n = S n -> _|_

16−acyclic Z p = disjoint _ p

17−acyclic (S k) p = acyclic k (succInjective _ _ p)

18−

19−empty1 : _|_

20−empty1 = hd [] where

21− hd : List a -> a

22− hd (x :: xs) = x

23−

24−empty2 : _|_

25−empty2 = empty2

26−

27−plusReduces : (n:Nat) -> plus Z n = n

28−plusReduces n = refl

29−

30−plusReducesZ : (n:Nat) -> n = plus n Z

31−plusReducesZ Z = refl

32−plusReducesZ (S k) = cong (plusReducesZ k)

33−

34−plusReducesS : (n:Nat) -> (m:Nat) -> S (plus n m) = plus n (S m)

35−plusReducesS Z m = refl

36−plusReducesS (S k) m = cong (plusReducesS k m)

37−

38−plusReducesZ' : (n:Nat) -> n = plus n Z

39−plusReducesZ' Z = ?plusredZ_Z

40−plusReducesZ' (S k) = let ih = plusReducesZ' k in

41− ?plusredZ_S

42−

43−

44−---------- Proofs ----------

45−

46−plusredZ_S = proof {

47− intro;

48− intro;

49− rewrite ih;

50− trivial;

51−}

52−

53−plusredZ_Z = proof {

54− compute;

55− trivial;

56−}

57−

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/vbroken.idrdeleted−5

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

1−vapp : Vect n a -> Vect m a -> Vect (n + m) a

2−vapp Nil ys = ys

3−vapp (x :: xs) ys = x :: vapp xs xs -- BROKEN

4−

5−

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−

examples/wheres.idrdeleted−14

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

1−module wheres

2−

3−even : Nat -> Bool

4−even Z = True

5−even (S k) = odd k where

6− odd Z = False

7− odd (S k) = even k

8−

9−test : List Nat

10−test = [c (S 1), c Z, d (S Z)]

11− where c x = 42 + x

12− d y = c (y + 1 + z y)

13− where z w = y + w

14−

idris.cabal+3−2

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

1Name: idris

2−Version: 0.9.11.2

2+Version: 0.9.12

3License: BSD3

4License-file: LICENSE

5Author: Edwin Brady

@@ -469,6 +469,7 @@ Library

469 , Idris.Docstrings

470 , Idris.ElabDecls

471 , Idris.ElabTerm

472+ , Idris.Erasure

472 , Idris.Error

473 , Idris.Error

473 , Idris.ErrReverse

474 , Idris.ErrReverse

474 , Idris.Help

475 , Idris.Help

@@ -476,6 +477,7 @@ Library

476 , Idris.IdeSlave

477 , Idris.IdeSlave

477 , Idris.Imports

478 , Idris.Imports

478 , Idris.Inliner

479 , Idris.Inliner

480+ , Idris.Output

479 , Idris.Parser

481 , Idris.Parser

480 , Idris.ParseHelpers

482 , Idris.ParseHelpers

481 , Idris.ParseOps

483 , Idris.ParseOps

@@ -490,7 +492,6 @@ Library

490 , Idris.REPLParser

492 , Idris.REPLParser

491 , Idris.Transforms

493 , Idris.Transforms

492 , Idris.Unlit

494 , Idris.Unlit

493− , Idris.UnusedArgs

494

495

495 , IRTS.BCImp

496 , IRTS.BCImp

496 , IRTS.Bytecode

497 , IRTS.Bytecode

libs/Makefile−3

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

2 $(MAKE) -C prelude build

3 $(MAKE) -C base build

4 $(MAKE) -C effects build

5− $(MAKE) -C oldeffects build

6 $(MAKE) -C javascript build

5 $(MAKE) -C javascript build

7

6

8

7

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

10 $(MAKE) -C prelude install

9 $(MAKE) -C prelude install

11 $(MAKE) -C base install

10 $(MAKE) -C base install

12 $(MAKE) -C effects install

11 $(MAKE) -C effects install

13− $(MAKE) -C oldeffects install

14 $(MAKE) -C javascript install

12 $(MAKE) -C javascript install

15

13

16clean:

14clean:

17 $(MAKE) -C prelude clean

15 $(MAKE) -C prelude clean

18 $(MAKE) -C base clean

16 $(MAKE) -C base clean

19 $(MAKE) -C effects clean

17 $(MAKE) -C effects clean

20− $(MAKE) -C oldeffects clean

21 $(MAKE) -C javascript clean

18 $(MAKE) -C javascript clean

22

19

23.PHONY: build install clean

20.PHONY: build install clean

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

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

1−module Category.Arrow

1+module Control.Arrow

2

3import Data.Morphisms

4import Control.Category

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

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

38 y <- g a

39 return (x, y)

40−

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

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

1−module Prelude.Catchable

1+module Control.Catchable

2

3import Control.IOExcept

4

libs/base/Data/HVect.idr+1

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

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

20 deleteAt fZ (x::xs) = xs

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

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

22 deleteAt _ [] impossible

23 deleteAt _ [] impossible

23

24

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

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

libs/effects/Effect/File.idr+85−14

@@ -1,24 +1,78 @@

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

1module Effect.File

2module Effect.File

2

3

3import Effects

4import Effects

4import Control.IOExcept

5import Control.IOExcept

5

6

7+

8+||| A Dependent type to describe File Handles. File handles are

9+||| parameterised with the current state of the file: Closed; Open for

10+||| reading; and Open for writing.

11+|||

12+||| @ m The file mode.

6−data OpenFile : Mode -> Type where

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

7 FH : File -> OpenFile m

14 FH : File -> OpenFile m

8

15

9openOK : Mode -> Bool -> Type

16openOK : Mode -> Bool -> Type

10openOK m True = OpenFile m

17openOK m True = OpenFile m

11openOK m False = ()

18openOK m False = ()

12

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

13data FileIO : Effect where

39data FileIO : Effect where

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)

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

48+ -> (m : Mode)

49+ -> {() ==> {res} if res

50+ then OpenFile m

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

51+ else ()} FileIO Bool

52+

53+ ||| Close a file.

54+ |||

55+ ||| Closing a file moves the state from Open to closed.

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

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

17−

57+

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

59+ |||

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

18− ReadLine : {OpenFile Read} FileIO String

61+ ReadLine : {OpenFile Read} FileIO String

62+

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

64+ |||

65+ ||| Only file that are open for writing can be written to.

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

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

67+

68+ ||| End of file?

69+ |||

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

20− EOF : {OpenFile Read} FileIO Bool

71+ EOF : {OpenFile Read} FileIO Bool

21−

72+

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

74+

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

22instance Handler FileIO IO where

76instance Handler FileIO IO where

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

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

24 valid <- validFile h

78 valid <- validFile h

@@ -33,30 +87,47 @@ instance Handler FileIO IO where

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

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

34 k e (FH h)

88 k e (FH h)

35

89

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

36FILE_IO : Type -> EFFECT

91FILE_IO : Type -> EFFECT

37FILE_IO t = MkEff t FileIO

92FILE_IO t = MkEff t FileIO

38

93

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.

39open : Handler FileIO e =>

104open : Handler FileIO e =>

105+ (fname : String)

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

106+ -> (m : Mode)

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

107+ -> { [FILE_IO ()] ==> [FILE_IO (if result

108+ then OpenFile m

109+ else ())] } Eff e Bool

42open f m = Open f m

110open f m = Open f m

43

111

112+

113+||| Close a file.

44close : Handler FileIO e =>

114close : Handler FileIO e =>

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

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

46close = Close

116close = Close

47

117

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

48readLine : Handler FileIO e =>

119readLine : Handler FileIO e =>

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

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

50readLine = ReadLine

121readLine = ReadLine

51

122

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

52writeLine : Handler FileIO e =>

124writeLine : Handler FileIO e =>

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

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

54writeLine str = WriteLine str

126writeLine str = WriteLine str

55

127

128+||| End of file?

56eof : Handler FileIO e =>

129eof : Handler FileIO e =>

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

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

58eof = EOF

131eof = EOF

59

132

60−

133+-- --------------------------------------------------------------------- [ EOF ]

61−

62−

libs/effects/Effects.idr+3−1

@@ -93,9 +93,11 @@ updateWith [] (x :: xs) (Keep rest) = []

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

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

95rebuildEnv [] SubNil env = env

96+rebuildEnv (x :: xs) SubNil env = x :: xs

97+rebuildEnv [] (Keep rest) (y :: env) = []

96rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

98rebuildEnv (x :: xs) (Keep rest) (y :: env) = x :: rebuildEnv xs rest env

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

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

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

100+

99

101

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

102-- -------------------------------------------------- [ The Effect EDSL itself ]

101-- some proof automation

103-- some proof automation

libs/prelude/Decidable/Equality.idr+11−1

@@ -174,13 +174,23 @@ total

174vectInjective2 : {xs, ys : Vect n a} -> {x, y : a} -> x :: xs = y :: ys -> xs = ys

175vectInjective2 {x=x} {y=x} {xs=xs} {ys=xs} refl = refl

176

177+instance DecEq a => DecEq (Vect n a) where

178+ decEq [] [] = Yes refl

179+ decEq (x :: xs) (y :: ys) with (decEq x y)

180+ decEq (x :: xs) (x :: ys) | Yes refl with (decEq xs ys)

181+ decEq (x :: xs) (x :: xs) | Yes refl | Yes refl = Yes refl

182+ decEq (x :: xs) (x :: ys) | Yes refl | No neq = No (neq . vectInjective2)

183+ decEq (x :: xs) (y :: ys) | No neq = No (neq . vectInjective1)

184+

185+{- The following definition is elaborated in a wrong case-tree. Examination pending.

186+

177instance DecEq a => DecEq (Vect n a) where

187instance DecEq a => DecEq (Vect n a) where

178 decEq [] [] = Yes refl

188 decEq [] [] = Yes refl

179 decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)

189 decEq (x :: xs) (y :: ys) with (decEq x y, decEq xs ys)

180 decEq (x :: xs) (x :: xs) | (Yes refl, Yes refl) = Yes refl

190 decEq (x :: xs) (x :: xs) | (Yes refl, Yes refl) = Yes refl

181 decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))

191 decEq (x :: xs) (y :: ys) | (_, No nEqTl) = No (\p => nEqTl (vectInjective2 p))

182 decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))

192 decEq (x :: xs) (y :: ys) | (No nEqHd, _) = No (\p => nEqHd (vectInjective1 p))

183−

193+-}

184

194

185-- For the primitives, we have to cheat because we don't have access to their

195-- For the primitives, we have to cheat because we don't have access to their

186-- internal implementations.

196-- internal implementations.

libs/prelude/IO.idr+3−6

@@ -132,16 +132,13 @@ io_return : a -> IO a

132io_return x = MkIO (\w => prim_io_return x)

133

134liftPrimIO : (World -> PrimIO a) -> IO a

135−liftPrimIO f = MkIO (\w => prim_io_bind (f w)

135+liftPrimIO = MkIO

136− (\x => prim_io_return x))

137

136

138run__IO : IO () -> PrimIO ()

137run__IO : IO () -> PrimIO ()

139−run__IO (MkIO f) = prim_io_bind (f TheWorld)

138+run__IO (MkIO f) = f TheWorld

140− (\ b => prim_io_return b)

141

139

142run__provider : IO a -> PrimIO a

140run__provider : IO a -> PrimIO a

143−run__provider (MkIO f) = prim_io_bind (f TheWorld)

141+run__provider (MkIO f) = f TheWorld

144− (\ b => prim_io_return b)

145

142

146-- io_bind v (\v' => io_return v')

143-- io_bind v (\v' => io_return v')

147

144

libs/prelude/Prelude/Applicative.idr+2

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

1module Prelude.Applicative

2

3import Builtins

4+import Prelude.Basics

5+import Prelude.Classes

4import Prelude.Functor

6import Prelude.Functor

5

7

6---- Applicative functors/Idioms

8---- Applicative functors/Idioms

libs/prelude/Prelude/Chars.idr+3

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

1module Prelude.Char

2-- Functions operating over Chars

3

4+import Prelude.Bool

5+import Prelude.Classes

6+import Prelude.List

4import Builtins

7import Builtins

5

8

6||| Return the ASCII representation of the character.

9||| Return the ASCII representation of the character.

libs/prelude/Prelude/Fin.idr+11

@@ -2,6 +2,7 @@ module Prelude.Fin

2

3import Prelude.Nat

4import Prelude.Either

5+import Prelude.Uninhabited

5

6

6%default total

7%default total

7

8

@@ -11,6 +12,10 @@ data Fin : (n : Nat) -> Type where

11 fZ : Fin (S k)

12 fZ : Fin (S k)

12 fS : Fin k -> Fin (S k)

13 fS : Fin k -> Fin (S k)

13

14

15+instance Uninhabited (Fin Z) where

16+ uninhabited fZ impossible

17+ uninhabited (fS f) impossible

18+

14fSInjective : (m : Fin k) -> (n : Fin k) -> fS m = fS n -> m = n

19fSInjective : (m : Fin k) -> (n : Fin k) -> fS m = fS n -> m = n

15fSInjective left _ refl = refl

20fSInjective left _ refl = refl

16

21

@@ -93,6 +98,12 @@ instance MaxBound (Fin (S n)) where

93(+) {n=S n} {m=m} fZ f' = rewrite plusCommutative n m in weaken (weakenN n f')

98(+) {n=S n} {m=m} fZ f' = rewrite plusCommutative n m in weaken (weakenN n f')

94(+) (fS f) f' = fS (f + f')

99(+) (fS f) f' = fS (f + f')

95

100

101+||| Substract two Fins, keeping the bound of the minuend

102+(-) : Fin n -> Fin m -> Fin n

103+fZ - _ = fZ

104+f - fZ = f

105+(fS f) - (fS f') = weaken $ f - f'

106+

96||| Multiply two Fins, extending the bound

107||| Multiply two Fins, extending the bound

97(*) : Fin n -> Fin m -> Fin (n * m)

108(*) : Fin n -> Fin m -> Fin (n * m)

98(*) {n=Z} f f' = FinZElim f

109(*) {n=Z} f f' = FinZElim f

libs/prelude/Prelude/List.idr+8

@@ -422,6 +422,14 @@ split p xs =

422 (chunk, []) => [chunk]

423 (chunk, (c :: rest)) => chunk :: split p (assert_smaller xs rest)

424

425+||| A tuple where the first element is a List of the n first elements and

426+||| the second element is a List of the remaining elements of the list

427+||| It is equivalent to (take n xs, drop n xs)

428+||| @ n the index to split at

429+||| @ xs the list to split in two

430+splitAt : (n : Nat) -> (xs : List a) -> (List a, List a)

431+splitAt n xs = (take n xs, drop n xs)

432+

425partition : (a -> Bool) -> List a -> (List a, List a)

433partition : (a -> Bool) -> List a -> (List a, List a)

426partition p [] = ([], [])

434partition p [] = ([], [])

427partition p (x::xs) =

435partition p (x::xs) =

libs/prelude/Prelude/Nat.idr+4

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

6import Prelude.Bool

7import Prelude.Cast

8import Prelude.Classes

9+import Prelude.Uninhabited

9

10

10%access public

11%access public

11%default total

12%default total

@@ -20,6 +21,9 @@ import Prelude.Classes

20-- name hints for interactive editing

21-- name hints for interactive editing

21%name Nat k,j,i,n,m

22%name Nat k,j,i,n,m

22

23

24+instance Uninhabited (Z = S n) where

25+ uninhabited refl impossible

26+

23--------------------------------------------------------------------------------

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

24-- Syntactic tests

28-- Syntactic tests

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

29--------------------------------------------------------------------------------

libs/prelude/Prelude/Uninhabited.idr+2−7

@@ -1,18 +1,13 @@

1module Prelude.Uninhabited

2

3+import Builtins

4+

3||| A canonical proof that some type is empty

5||| A canonical proof that some type is empty

4class Uninhabited t where

6class Uninhabited t where

5 ||| If I have a t, I've had a contradiction

7 ||| If I have a t, I've had a contradiction

6 ||| @ t the uninhabited type

8 ||| @ t the uninhabited type

7 total uninhabited : t -> _|_

9 total uninhabited : t -> _|_

8

10

9−instance Uninhabited (Fin Z) where

10− uninhabited fZ impossible

11− uninhabited (fS f) impossible

12−

13−instance Uninhabited (Z = S n) where

14− uninhabited refl impossible

15−

16||| Use an absurd assumption to discharge a proof obligation

11||| Use an absurd assumption to discharge a proof obligation

17||| @ t some empty type

12||| @ t some empty type

18||| @ a the goal type

13||| @ a the goal type

libs/prelude/Prelude/Vect.idr+10

@@ -7,6 +7,7 @@ import Prelude.List

7import Prelude.Classes

8import Prelude.Nat

9import Prelude.Bool

10+import Prelude.Uninhabited

10

11

11%access public

12%access public

12%default total

13%default total

@@ -71,6 +72,7 @@ index fZ [] impossible

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

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

72deleteAt fZ (x::xs) = xs

73deleteAt fZ (x::xs) = xs

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

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

75+deleteAt {n = Z} (fS k) (x::xs) = absurd k

74deleteAt _ [] impossible

76deleteAt _ [] impossible

75

77

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

78||| Replace an element at a particlar index with another

@@ -379,6 +381,14 @@ nub = nubBy (==)

379-- Splitting and breaking lists

381-- Splitting and breaking lists

380--------------------------------------------------------------------------------

382--------------------------------------------------------------------------------

381

383

384+||| A tuple where the first element is a Vect of the n first elements and

385+||| the second element is a Vect of the remaining elements of the original Vect

386+||| It is equivalent to (take n xs, drop n xs)

387+||| @ m the index to split at

388+||| @ xs the Vect to split in two

389+splitAt : {n : Nat} -> (m : Fin (S n)) -> (xs : Vect n a) -> (Vect (cast m) a, Vect (n - cast m) a)

390+splitAt n xs = (take n xs, drop n xs)

391+

382--------------------------------------------------------------------------------

392--------------------------------------------------------------------------------

383-- Predicates

393-- Predicates

384--------------------------------------------------------------------------------

394--------------------------------------------------------------------------------

main/Main.hs+1

@@ -108,6 +108,7 @@ usagemsg = usagemsghdr ++ "\n" ++

108 "\t --check Undocumented\n" ++

109 "\t --total Require functions to be total by default\n" ++

110 "\t --partial Undocumented\n" ++

111+ "\t --warnreach Warn about reachable but inaccessible arguments\n" ++

111 "\t --warnpartial Warn about undeclared partial functions.\n" ++

112 "\t --warnpartial Warn about undeclared partial functions.\n" ++

112 "\t --warn Undocumented\n" ++

113 "\t --warn Undocumented\n" ++

113 "\t --typecase Undocumented\n" ++

114 "\t --typecase Undocumented\n" ++

rts/idris_rts.c+12−3

@@ -37,9 +37,18 @@ VM* init_vm(int stack_size, size_t heap_size,

37 vm->inbox_ptr = vm->inbox;

38 vm->inbox_write = vm->inbox;

39

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

41+ // no memory is allocated during the message sending process, but we also

42+ // check the lock in calls to allocate.

43+ // The problem comes when we use requireAlloc to guarantee a chunk of memory

44+ // first: this sets the lock, and since it is not reentrant, we get a deadlock.

45+ pthread_mutexattr_t rec_attr;

46+ pthread_mutexattr_init(&rec_attr);

47+ pthread_mutexattr_settype(&rec_attr, PTHREAD_MUTEX_RECURSIVE);

48+

40 pthread_mutex_init(&(vm->inbox_lock), NULL);

49 pthread_mutex_init(&(vm->inbox_lock), NULL);

41 pthread_mutex_init(&(vm->inbox_block), NULL);

50 pthread_mutex_init(&(vm->inbox_block), NULL);

42− pthread_mutex_init(&(vm->alloc_lock), NULL);

51+ pthread_mutex_init(&(vm->alloc_lock), &rec_attr);

43 pthread_cond_init(&(vm->inbox_waiting), NULL);

52 pthread_cond_init(&(vm->inbox_waiting), NULL);

44

53

45 vm->max_threads = max_threads;

54 vm->max_threads = max_threads;

@@ -72,14 +81,14 @@ void idris_requireAlloc(VM* vm, size_t size) {

72 }

81 }

73

82

74 int lock = vm->processes > 0;

83 int lock = vm->processes > 0;

75− if (lock) { // not message passing

84+ if (lock) { // We only need to lock if we're in concurrent mode

76 pthread_mutex_lock(&vm->alloc_lock);

85 pthread_mutex_lock(&vm->alloc_lock);

77 }

86 }

78}

87}

79

88

80void idris_doneAlloc(VM* vm) {

89void idris_doneAlloc(VM* vm) {

81 int lock = vm->processes > 0;

90 int lock = vm->processes > 0;

82− if (lock) { // not message passing

91+ if (lock) { // We only need to lock if we're in concurrent mode

83 pthread_mutex_unlock(&vm->alloc_lock);

92 pthread_mutex_unlock(&vm->alloc_lock);

84 }

93 }

85}

94}

src/IRTS/CodegenC.hs+26−10

@@ -20,16 +20,32 @@ import System.Directory

20import System.FilePath ((</>), (<.>))

21import Control.Monad

22

23+codegenC :: CodeGenerator

24+codegenC ci = codegenC' (simpleDecls ci)

25+ (outputFile ci)

26+ (outputType ci)

27+ (includes ci)

28+ (concatMap mkObj (compileObjs ci))

29+ (concatMap mkLib (compileLibs ci) ++

30+ concatMap incdir (importDirs ci))

31+ (concatMap mkFlag (compilerFlags ci))

32+ (debugLevel ci)

33+

34+ where mkObj f = f ++ " "

35+ mkLib l = "-l" ++ l ++ " "

36+ mkFlag l = l ++ " "

37+ incdir i = "-I" ++ i ++ " "

38+

23−codegenC :: [(Name, SDecl)] ->

39+codegenC' :: [(Name, SDecl)] ->

24− String -> -- output file name

40+ String -> -- output file name

25− OutputType -> -- generate executable if True, only .o if False

41+ OutputType -> -- generate executable if True, only .o if False

26− [FilePath] -> -- include files

42+ [FilePath] -> -- include files

27− String -> -- extra object files

43+ String -> -- extra object files

28− String -> -- extra compiler flags (libraries)

44+ String -> -- extra compiler flags (libraries)

29− String -> -- extra compiler flags (anything)

45+ String -> -- extra compiler flags (anything)

30− DbgLevel ->

46+ DbgLevel ->

31− IO ()

47+ IO ()

32−codegenC defs out exec incs objs libs flags dbg

48+codegenC' defs out exec incs objs libs flags dbg

33 = do -- print defs

49 = do -- print defs

34 let bc = map toBC defs

50 let bc = map toBC defs

35 let h = concatMap toDecl (map fst bc)

51 let h = concatMap toDecl (map fst bc)

src/IRTS/CodegenCommon.hs+25

@@ -2,8 +2,11 @@ module IRTS.CodegenCommon where

2

3import Idris.Core.TT

4import IRTS.Simplified

5+import IRTS.Defunctionalise

6+import IRTS.Lang

5

7

6import Control.Exception

8import Control.Exception

9+import Data.Word

7import System.Environment

10import System.Environment

8

11

9data DbgLevel = NONE | DEBUG | TRACE deriving Eq

12data DbgLevel = NONE | DEBUG | TRACE deriving Eq

@@ -13,3 +16,25 @@ environment :: String -> IO (Maybe String)

13environment x = Control.Exception.catch (do e <- getEnv x

16environment x = Control.Exception.catch (do e <- getEnv x

14 return (Just e))

17 return (Just e))

15 (\y-> do return (y::SomeException); return Nothing)

18 (\y-> do return (y::SomeException); return Nothing)

19+

20+-- Everything which might be needed in a code generator - a CG can choose which

21+-- level of Decls to generate code from (simplified, defunctionalised or merely

22+-- lambda lifted) and has access to the list of object files, libraries, etc.

23+

24+data CodegenInfo = CodegenInfo { outputFile :: String,

25+ outputType :: OutputType,

26+ targetTriple :: String,

27+ targetCPU :: String,

28+ optimisation :: Word,

29+ includes :: [FilePath],

30+ importDirs :: [FilePath],

31+ compileObjs :: [String],

32+ compileLibs :: [String],

33+ compilerFlags :: [String],

34+ debugLevel :: DbgLevel,

35+ simpleDecls :: [(Name, SDecl)],

36+ defunDecls :: [(Name, DDecl)],

37+ liftDecls :: [(Name, LDecl)]

38+ }

39+

40+type CodeGenerator = CodegenInfo -> IO ()

src/IRTS/CodegenJava.hs+13−8

@@ -34,14 +34,19 @@ import System.Process

34

35-----------------------------------------------------------------------

36-- Main function

37+codegenJava :: CodeGenerator

38+codegenJava cg = codegenJava' [] (simpleDecls cg) (outputFile cg)

39+ (includes cg) (compileLibs cg)

40+ (outputType cg)

41+

37−codegenJava :: [(Name, SExp)] -> -- initialization of globals

42+codegenJava' :: [(Name, SExp)] -> -- initialization of globals

38− [(Name, SDecl)] -> -- decls

43+ [(Name, SDecl)] -> -- decls

39− FilePath -> -- output file name

44+ FilePath -> -- output file name

40− [String] -> -- headers

45+ [String] -> -- headers

41− [String] -> -- libs

46+ [String] -> -- libs

42− OutputType ->

47+ OutputType ->

43− IO ()

48+ IO ()

44−codegenJava globalInit defs out hdrs libs exec =

49+codegenJava' globalInit defs out hdrs libs exec =

45 withTgtDir exec out (codegenJava' exec)

50 withTgtDir exec out (codegenJava' exec)

46 where

51 where

47 codegenJava' :: OutputType -> FilePath -> IO ()

52 codegenJava' :: OutputType -> FilePath -> IO ()

src/IRTS/CodegenJavaScript.hs+17−4

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

1{-# LANGUAGE PatternGuards #-}

2

3−module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where

3+module IRTS.CodegenJavaScript (codegenJavaScript, codegenNode, JSTarget(..)) where

4

5import Idris.AbsSyntax hiding (TypeCase)

6import IRTS.Bytecode

@@ -1154,7 +1154,7 @@ unfoldLookupTable input =

1154

1155removeInstanceChecks :: JS -> JS

1156removeInstanceChecks (JSCond conds) =

1157− JSCond $ eliminateDeadBranches $ map (

1157+ removeNoopConds $ JSCond $ eliminateDeadBranches $ map (

1158 removeHelper *** removeInstanceChecks

1159 ) conds

1160 where

@@ -1169,6 +1169,11 @@ removeInstanceChecks (JSCond conds) =

1169 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs

1170 eliminateDeadBranches [] = []

1171

1172+

1173+ removeNoopConds :: JS -> JS

1174+ removeNoopConds (JSCond [(JSNoop, js)]) = js

1175+ removeNoopConds js = js

1176+

1172removeInstanceChecks js = transformJS removeInstanceChecks js

1177removeInstanceChecks js = transformJS removeInstanceChecks js

1173

1178

1174

1179

@@ -1389,14 +1394,22 @@ getGlobalCons js = foldJS match (++) [] js

1389getIncludes :: [FilePath] -> IO [String]

1394getIncludes :: [FilePath] -> IO [String]

1390getIncludes = mapM readFile

1395getIncludes = mapM readFile

1391

1396

1392−codegenJavaScript

1397+codegenJavaScript :: CodeGenerator

1398+codegenJavaScript ci = codegenJS_all JavaScript (simpleDecls ci)

1399+ (includes ci) (outputFile ci) (outputType ci)

1400+

1401+codegenNode :: CodeGenerator

1402+codegenNode ci = codegenJS_all Node (simpleDecls ci)

1403+ (includes ci) (outputFile ci) (outputType ci)

1404+

1405+codegenJS_all

1393 :: JSTarget

1406 :: JSTarget

1394 -> [(Name, SDecl)]

1407 -> [(Name, SDecl)]

1395 -> [FilePath]

1408 -> [FilePath]

1396 -> FilePath

1409 -> FilePath

1397 -> OutputType

1410 -> OutputType

1398 -> IO ()

1411 -> IO ()

1399−codegenJavaScript target definitions includes filename outputType = do

1412+codegenJS_all target definitions includes filename outputType = do

1400 let (header, rt) = case target of

1413 let (header, rt) = case target of

1401 Node ->

1414 Node ->

1402 ("#!/usr/bin/env node\n", "-node")

1415 ("#!/usr/bin/env node\n", "-node")

src/IRTS/CodegenLLVM.hs+13−8

@@ -58,14 +58,19 @@ import Debug.Trace

58

59data Target = Target { triple :: String, dataLayout :: DataLayout }

60

61+codegenLLVM :: CodeGenerator

62+codegenLLVM ci = codegenLLVM' (simpleDecls ci) (targetTriple ci)

63+ (targetCPU ci) (optimisation ci)

64+ (outputFile ci) (outputType ci)

65+

61−codegenLLVM :: [(TT.Name, SDecl)] ->

66+codegenLLVM' :: [(TT.Name, SDecl)] ->

62− String -> -- target triple

67+ String -> -- target triple

63− String -> -- target CPU

68+ String -> -- target CPU

64− Word -> -- Optimization degree

69+ Word -> -- Optimization degree

65− FilePath -> -- output file name

70+ FilePath -> -- output file name

66− OutputType ->

71+ OutputType ->

67− IO ()

72+ IO ()

68−codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do

73+codegenLLVM' defs triple cpu optimize file outty = withContext $ \context -> do

69 initializeAllTargets

74 initializeAllTargets

70 (target, _) <- failInIO $ lookupTarget Nothing triple

75 (target, _) <- failInIO $ lookupTarget Nothing triple

71 withTargetOptions $ \options ->

76 withTargetOptions $ \options ->

src/IRTS/Compiler.hs+439−322

@@ -18,15 +18,25 @@ import Util.LLVMStubs

18import IRTS.Inliner

19

20import Idris.AbsSyntax

21−import Idris.UnusedArgs

21+import Idris.AbsSyntaxTree

22+import Idris.Erasure

22import Idris.Error

23import Idris.Error

23

24

25+import Debug.Trace

26+

24import Idris.Core.TT

27import Idris.Core.TT

25import Idris.Core.Evaluate

28import Idris.Core.Evaluate

26import Idris.Core.CaseTree

29import Idris.Core.CaseTree

27

30

31+import Control.Applicative

28import Control.Monad.State

32import Control.Monad.State

33+import Data.Maybe

29import Data.List

34import Data.List

35+import Data.Ord

36+import Data.IntSet (IntSet)

37+import qualified Data.IntSet as IS

38+import qualified Data.Map as M

39+import qualified Data.Set as S

30import System.Process

40import System.Process

31import System.IO

41import System.IO

32import System.Directory

42import System.Directory

@@ -37,18 +47,16 @@ import Paths_idris

37

47

38compile :: Codegen -> FilePath -> Term -> Idris ()

48compile :: Codegen -> FilePath -> Term -> Idris ()

39compile codegen f tm

49compile codegen f tm

40− = do checkMVs

50+ = do checkMVs -- check for undefined metavariables

41− let tmnames = namesUsed (STerm tm)

51+ reachableNames <- performUsageAnalysis

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)

46 maindef <- irMain tm

52 maindef <- irMain tm

53+ iLOG $ "MAIN: " ++ show maindef

47 objs <- getObjectFiles codegen

54 objs <- getObjectFiles codegen

48 libs <- getLibs codegen

55 libs <- getLibs codegen

49 flags <- getFlags codegen

56 flags <- getFlags codegen

50 hdrs <- getHdrs codegen

57 hdrs <- getHdrs codegen

51 impdirs <- allImportDirs

58 impdirs <- allImportDirs

59+ defsIn <- mkDecls tm reachableNames

52 let defs = defsIn ++ [(sMN 0 "runMain", maindef)]

60 let defs = defsIn ++ [(sMN 0 "runMain", maindef)]

53 -- iputStrLn $ showSep "\n" (map show defs)

61 -- iputStrLn $ showSep "\n" (map show defs)

54 let (nexttag, tagged) = addTags 65536 (liftAll defs)

62 let (nexttag, tagged) = addTags 65536 (liftAll defs)

@@ -71,25 +79,22 @@ compile codegen f tm

71 case dumpDefun of

79 case dumpDefun of

72 Nothing -> return ()

80 Nothing -> return ()

73 Just f -> runIO $ writeFile f (dumpDefuns defuns)

81 Just f -> runIO $ writeFile f (dumpDefuns defuns)

74− triple <- targetTriple

82+ triple <- Idris.AbsSyntax.targetTriple

75− cpu <- targetCPU

83+ cpu <- Idris.AbsSyntax.targetCPU

76− optimize <- optLevel

84+ optimise <- optLevel

77 iLOG "Building output"

85 iLOG "Building output"

86+

78 case checked of

87 case checked of

88+ OK c -> do let cginfo = CodegenInfo f outty triple cpu optimise

89+ hdrs impdirs objs libs flags

90+ NONE c (toAlist defuns)

91+ tagged

79− OK c -> runIO $ case codegen of

92+ runIO $ case codegen of

80− ViaC ->

81− codegenC c f outty hdrs

93+ ViaC -> codegenC cginfo

82− (concatMap mkObj objs)

83− (concatMap mkLib libs)

84− (concatMap mkFlag flags ++

85− concatMap incdir impdirs) NONE

86− ViaJava ->

94+ ViaJava -> codegenJava cginfo

87− codegenJava [] c f hdrs libs outty

88− ViaJavaScript ->

95+ ViaJavaScript -> codegenJavaScript cginfo

89− codegenJavaScript JavaScript c hdrs f outty

90− ViaNode ->

96+ ViaNode -> codegenNode cginfo

91− codegenJavaScript Node c hdrs f outty

92− ViaLLVM -> codegenLLVM c triple cpu optimize f outty

97+ ViaLLVM -> codegenLLVM cginfo

93 Bytecode -> dumpBC c f

98 Bytecode -> dumpBC c f

94 Error e -> ierror e

99 Error e -> ierror e

95 where checkMVs = do i <- getIState

100 where checkMVs = do i <- getIState

@@ -99,39 +104,50 @@ compile codegen f tm

99 inDir d h = do let f = d </> h

104 inDir d h = do let f = d </> h

100 ex <- doesFileExist f

105 ex <- doesFileExist f

101 if ex then return f else return h

106 if ex then return f else return h

102− mkObj f = f ++ " "

103− mkLib l = "-l" ++ l ++ " "

104− mkFlag l = l ++ " "

105−

106− incdir i = "-I" ++ i ++ " "

107−

108

107

109irMain :: TT Name -> Idris LDecl

108irMain :: TT Name -> Idris LDecl

110−irMain tm = do i <- ir tm

109+irMain tm = do

110+ i <- irTerm M.empty [] tm

111− return $ LFun [] (sMN 0 "runMain") [] (LForce i)

111+ return $ LFun [] (sMN 0 "runMain") [] (LForce i)

112

113mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]

114mkDecls t used

115 = do i <- getIState

116− let ds = filter (\ (n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)

116+ let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)

117− mapM traceUnused used

118 decls <- mapM build ds

117 decls <- mapM build ds

119 return decls

118 return decls

120

119

121showCaseTrees :: [(Name, LDecl)] -> String

120showCaseTrees :: [(Name, LDecl)] -> String

122−showCaseTrees ds = showSep "\n\n" (map showCT ds)

121+showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)

123 where

122 where

124 showCT (n, LFun _ f args lexp)

123 showCT (n, LFun _ f args lexp)

125− = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t "

124+ = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t"

126 ++ show lexp

125 ++ show lexp

127 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a

126 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a

128

127

128+ defnRank :: (Name, LDecl) -> String

129+ defnRank (n, LFun _ _ _ _) = "1" ++ nameRank n

130+ defnRank (n, LConstructor _ _ _) = "2" ++ nameRank n

131+

132+ nameRank :: Name -> String

133+ nameRank (UN s) = "1" ++ show s

134+ nameRank (MN i s) = "2" ++ show s ++ show i

135+ nameRank (NS n ns) = "3" ++ concatMap show (reverse ns) ++ nameRank n

136+ nameRank (SN sn) = "4" ++ snRank sn

137+ nameRank n = "5" ++ show n

138+

139+ snRank :: SpecialName -> String

140+ snRank (WhereN i n n') = "1" ++ nameRank n' ++ nameRank n ++ show i

141+ snRank (InstanceN n args) = "2" ++ nameRank n ++ concatMap show args

142+ snRank (ParentN n s) = "3" ++ nameRank n ++ show s

143+ snRank (MethodN n) = "4" ++ nameRank n

144+ snRank (CaseN n) = "5" ++ nameRank n

145+ snRank (ElimN n) = "6" ++ nameRank n

146+ snRank (InstanceCtorN n) = "7" ++ nameRank n

147+

129isCon (TyDecl _ _) = True

148isCon (TyDecl _ _) = True

130isCon _ = False

149isCon _ = False

131

150

132−class ToIR a where

133− ir :: a -> Idris LExp

134−

135build :: (Name, Def) -> Idris (Name, LDecl)

151build :: (Name, Def) -> Idris (Name, LDecl)

136build (n, d)

152build (n, d)

137 = do i <- getIState

153 = do i <- getIState

@@ -144,295 +160,396 @@ build (n, d)

144 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def

160 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def

145 return (n, def)

161 return (n, def)

146

162

147−getPrim :: IState -> Name -> [LExp] -> Maybe LExp

148−getPrim i n args = case lookup n (idris_scprims i) of

149− Just (ar, op) ->

150− if (ar == length args)

151− then return (LOp op args)

152− else Nothing

153− _ -> Nothing

154−

155declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x

163declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x

156declArgs args inl n x = LFun (if inl then [Inline] else []) n args x

164declArgs args inl n x = LFun (if inl then [Inline] else []) n args x

157

165

158−mkLDecl n (Function tm _) = do e <- ir tm

166+mkLDecl n (Function tm _)

159− return (declArgs [] True n e)

167+ = declArgs [] True n <$> irTerm M.empty [] tm

168+

160mkLDecl n (CaseOp ci _ _ _ pats cd)

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

170+ = declArgs [] (case_inlinable ci) n <$> irTree args sc

171+ where

172+ (args, sc) = cases_runtime cd

173+

164−mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a

174+mkLDecl n (TyDecl (DCon tag arity) _) =

175+ LConstructor n tag . erasedArity . lookup n <$> getIState

176+ where

177+ lookup n = lookupCtxtExact n . idris_callgraph

178+ erasedArity = maybe 0 (length . usedpos)

179+

165mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a

180mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a

166mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run

181mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run

167

182

168−instance ToIR (TT Name) where

183+data VarInfo = VI

169− ir tm = ir' [] tm where

184+ { viMethod :: Maybe Name

185+ }

186+ deriving Show

187+

188+type Vars = M.Map Name VarInfo

189+

190+irTerm :: Vars -> [Name] -> Term -> Idris LExp

170− ir' env tm@(App f a)

191+irTerm vs env tm@(App f a) = case unApply tm of

171− | (P _ (UN m) _, args) <- unApply tm,

192+ (P _ (UN m) _, args)

172− m == txt "mkForeignPrim"

193+ | m == txt "mkForeignPrim"

173− = doForeign env args

194+ -> doForeign vs env args

195+

174− | (P _ (UN u) _, [_, arg]) <- unApply tm,

196+ (P _ (UN u) _, [_, arg])

175− u == txt "unsafePerformPrimIO"

197+ | u == txt "unsafePerformPrimIO"

176− = ir' env arg

198+ -> irTerm vs env arg

199+

177− -- TMP HACK - until we get inlining.

200+ -- TMP HACK - until we get inlining.

178− | (P _ (UN r) _, [_, _, _, _, _, arg]) <- unApply tm,

201+ (P _ (UN r) _, [_, _, _, _, _, arg])

179− r == txt "replace"

202+ | r == txt "replace"

180− = ir' env arg

203+ -> irTerm vs env arg

204+

181− -- Laziness, the old way

205+ -- Laziness, the old way

182− | (P _ (UN l) _, [_, arg]) <- unApply tm,

206+ (P _ (UN l) _, [_, arg])

183− l == txt "lazy"

207+ | l == txt "lazy"

184− = do arg' <- ir' env arg

185− error "lazy has crept in somehow"

208+ -> error "lazy has crept in somehow"

186−-- return $ LLazyExp arg'

209+

187− | (P _ (UN l) _, [_, arg]) <- unApply tm,

210+ (P _ (UN l) _, [_, arg])

188− l == txt "force"

211+ | l == txt "force"

189− = do arg' <- ir' env arg

212+ -> LForce <$> irTerm vs env arg

190− return $ LForce arg'

213+

191− -- Laziness, the new way

214+ -- Laziness, the new way

192− | (P _ (UN l) _, [arg]) <- unApply tm,

215+ (P _ (UN l) _, [_, _, arg])

193− l == txt "Delay"

216+ | l == txt "Delay"

194− = do arg' <- ir' env arg

217+ -> LLazyExp <$> irTerm vs env arg

195− return $ LLazyExp arg'

218+

196− | (P _ (UN l) _, [_, _, arg]) <- unApply tm,

219+ (P _ (UN l) _, [_, _, arg])

197− l == txt "Force"

220+ | l == txt "Force"

198− = do arg' <- ir' env arg

221+ -> LForce <$> irTerm vs env arg

199− return $ LForce arg'

222+

200− | (P _ (UN a) _, [_, _, arg]) <- unApply tm,

223+ (P _ (UN a) _, [_, _, arg])

201− a == txt "assert_smaller"

224+ | a == txt "assert_smaller"

202− = ir' env arg

225+ -> irTerm vs env arg

226+

203− | (P _ (UN a) _, [_, arg]) <- unApply tm,

227+ (P _ (UN a) _, [_, arg])

204− a == txt "assert_total"

228+ | a == txt "assert_total"

205− = ir' env arg

229+ -> irTerm vs env arg

230+

206− | (P _ (UN p) _, [_, arg]) <- unApply tm,

231+ (P _ (UN p) _, [_, arg])

207− p == txt "par"

232+ | p == txt "par"

208− = do arg' <- ir' env arg

233+ -> do arg' <- irTerm vs env arg

209− return $ LOp LPar [LLazyExp arg']

234+ return $ LOp LPar [LLazyExp arg']

235+

210− | (P _ (UN pf) _, [arg]) <- unApply tm,

236+ (P _ (UN pf) _, [arg])

211− pf == txt "prim_fork"

237+ | pf == txt "prim_fork"

212− = do arg' <- ir' env arg

238+ -> do arg' <- irTerm vs env arg

213− return $ LOp LFork [LLazyExp arg']

239+ return $ LOp LFork [LLazyExp arg']

240+

214− | (P _ (UN m) _, [_,size,t]) <- unApply tm,

241+ (P _ (UN m) _, [_,size,t])

215− m == txt "malloc"

242+ | m == txt "malloc"

216− = do size' <- ir' env size

217− t' <- ir' env t

243+ -> irTerm vs env t

218− return t' -- TODO $ malloc_ size' t'

244+

219− | (P _ (UN tm) _, [_,t]) <- unApply tm,

245+ (P _ (UN tm) _, [_,t])

220− tm == txt "trace_malloc"

246+ | tm == txt "trace_malloc"

221− = do t' <- ir' env t

247+ -> irTerm vs env t -- TODO

222− return t' -- TODO

248+

223− -- This case is here until we get more general inlining. It's just

249+ -- This case is here until we get more general inlining. It's just

224− -- a really common case, and the laziness hurts...

250+ -- a really common case, and the laziness hurts...

225− | (P _ (NS (UN be) [b,p]) _, [_,x,(App (P _ (UN d) _) t),

251+ (P _ (NS (UN be) [b,p]) _, [_,x,(App (P _ (UN d) _) t),

226− (App (P _ (UN d') _) e)]) <- unApply tm,

252+ (App (P _ (UN d') _) e)])

227− be == txt "boolElim" && d == txt "Delay" && d' == txt "Delay"

253+ | be == txt "boolElim"

254+ , d == txt "Delay"

255+ , d' == txt "Delay"

256+ -> do

228− = do x' <- ir' env x

257+ x' <- irTerm vs env x

229− t' <- ir' env t

258+ t' <- irTerm vs env t

230− e' <- ir' env e

259+ e' <- irTerm vs env e

231− return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e',

260+ return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'

232− LConCase 1 (sNS (sUN "True") ["Bool","Prelude"]) [] t'])

261+ ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'

262+ ])

263+

233− | (P (DCon t a) n _, args) <- unApply tm

264+ (P (DCon t arity) n _, args) -> do

234− = irCon env t a n args

265+ ist <- getIState

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

266+ let detag = maybe False detaggable . lookupCtxtExact n $ idris_optimisation ist

246− Just oi -> collapsible oi

267+ used = maybe [] (map fst . usedpos) . lookupCtxtExact n $ idris_callgraph ist

247− _ -> False

268+ args' = [a | (i,a) <- zip [0..] args, i `elem` used]

248− let unused

269+

249− = case lookupCtxtExact n

270+ when (length args > arity) $

250− (idris_callgraph i) of

271+ ifail ("oversaturated data ctor: " ++ show tm)

251− Just (CGInfo _ _ _ _ unusedpos) ->

272+

252− unusedpos

273+ if length args' == 1 && detag -- detaggable

253− _ -> []

274+ then irTerm vs env (head args') -- newtype

254− if collapse

275+ else irCon vs env (length used) n args'

255− then return LNothing

276+

277+ (P (TCon t a) n _, args) -> return LNothing

278+

279+ (P _ n _, args) -> do

280+ ist <- getIState

281+ case lookup n (idris_scprims ist) of

282+ -- if it's a primitive that is already saturated,

283+ -- compile to the corresponding op here already to save work

284+ Just (arity, op) | length args == arity

285+ -> LOp op <$> mapM (irTerm vs env) args

286+

287+ -- otherwise, just apply the name

288+ _ -> applyName n ist args

289+

290+ -- turn de bruijn vars into regular named references and try again

291+ (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args

292+

293+ (f, args)

256− else return (LApp False (LV (Glob n))

294+ -> LApp False

257− (mkUnused unused 0 args'))

295+ <$> irTerm vs env f

258− | (f, args) <- unApply tm

296+ <*> mapM (irTerm vs env) args

259− = do f' <- ir' env f

297+

260− args' <- mapM (ir' env) args

298+ where

261− return (LApp False f' args')

299+ applyName :: Name -> IState -> [Term] -> Idris LExp

262− where mkUnused u i [] = []

300+ applyName n ist args =

263− mkUnused u i (x : xs) | i `elem` u = LNothing : mkUnused u (i + 1) xs

301+ LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)

302+ where

303+ erase (i, x)

304+ | i >= arity || i `elem` used = x

305+ | otherwise = Erased

306+

307+ arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of

308+ Just (CaseOp ci ty tys def tot cdefs) -> length tys

309+ Just (TyDecl (DCon tag ar) _) -> ar

310+ Just (TyDecl Ref ty) -> length $ getArgTys ty

311+ Just (Operator ty ar op) -> ar

312+ Just def -> error $ "unknown arity: " ++ show (n, def)

313+ Nothing -> 0 -- no definition, probably local name => can't erase anything

314+

315+ -- name for purposes of usage info lookup

316+ uName

317+ | Just n' <- viMethod =<< M.lookup n vs = n'

264− | otherwise = x : mkUnused u (i + 1) xs

318+ | otherwise = n

265−-- ir' env (P _ (NS (UN "Z") ["Nat", "Prelude"]) _)

319+

266−-- = return $ LConst (BI 0)

320+ used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)

321+ fst4 (x,_,_,_) = x

322+

267− ir' env (P _ n _) = return $ LV (Glob n)

323+irTerm vs env (P _ n _) = return $ LV (Glob n)

324+irTerm vs env (V i)

268− ir' env (V i) | i >= 0 && i < length env = return $ LV (Glob (env!!i))

325+ | i >= 0 && i < length env = return $ LV (Glob (env!!i))

269− | otherwise = ifail $ "IR fail " ++ show i ++ " " ++ show tm

326+ | otherwise = ifail $ "bad de bruijn index: " ++ show i

327+

270− ir' env (Bind n (Lam _) sc)

328+irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc

329+ where

271− = do let n' = uniqueName n env

330+ n' = uniqueName n env

272− sc' <- ir' (n' : env) sc

331+

273− return $ LLam [n'] sc'

274− ir' env (Bind n (Let _ v) sc)

332+irTerm vs env (Bind n (Let _ v) sc)

275− = do sc' <- ir' (n : env) sc

333+ = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc

276− v' <- ir' env v

334+

277− return $ LLet n v' sc'

278− ir' env (Bind _ _ _) = return $ LNothing

335+irTerm vs env (Bind _ _ _) = return $ LNothing

336+

279− ir' env (Proj t i) | i == -1

337+irTerm vs env (Proj t (-1)) = do

280− = do t' <- ir' env t

338+ t' <- irTerm vs env t

281− return $ LOp (LMinus (ATInt ITBig))

339+ return $ LOp (LMinus (ATInt ITBig))

282− [t', LConst (BI 1)]

340+ [t', LConst (BI 1)]

283− ir' env (Proj t i) = do t' <- ir' env t

341+

284− return $ LProj t' i

342+irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i

285− ir' env (Constant c) = return $ LConst c

343+irTerm vs env (Constant c) = return $ LConst c

286− ir' env (TType _) = return $ LNothing

344+irTerm vs env (TType _) = return $ LNothing

287− ir' env Erased = return $ LNothing

345+irTerm vs env Erased = return $ LNothing

288− ir' env Impossible = return $ LNothing

346+irTerm vs env Impossible = return $ LNothing

289−-- ir' env _ = return $ LError "Impossible"

347+

290−

348+irCon :: Vars -> [Name] -> Int -> Name -> [Term] -> Idris LExp

291− irCon env t arity n args

349+irCon vs env arity n args

292− | length args == arity = buildApp env (LV (Glob n)) args

350+ | length args > arity

293− | otherwise = let extra = satArgs (arity - length args) in

351+ = error $ "oversaturated data constructor: " ++ show (n, args)

294− do sc' <- irCon env t arity n

352+

295− (args ++ map (\n -> P Bound n undefined) extra)

353+ -- saturated

296− return $ LLam extra sc'

354+ | length args == arity

297−

355+ = buildApp (LV (Glob n)) args

298− satArgs n = map (\i -> sMN i "sat") [1..n]

356+

299−

357+ -- undersaturated, wrap in lambdas

358+ | otherwise

359+ = let extraNs = [sMN i "sat" | i <- [length args .. arity-1]]

360+ extraTs = [P Bound n undefined | n <- extraNs]

361+ in LLam extraNs <$> irCon vs env arity n (args ++ extraTs)

362+ where

300− buildApp env e [] = return e

363+ buildApp e [] = return e

301− buildApp env e xs = do xs' <- mapM (ir' env) xs

364+ buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs

302− return $ LApp False e xs'

365+

303−

304− doForeign :: [Name] -> [TT Name] -> Idris LExp

366+doForeign :: Vars -> [Name] -> [TT Name] -> Idris LExp

305− doForeign env (_ : fgn : args)

367+doForeign vs env (_ : fgn : args)

306− | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn

368+ | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn

307− = let maybeTys = getFTypes fgnArgTys

369+ = case getFTypes fgnArgTys of

308− rty = mkIty' ret in

309− case maybeTys of

310− Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)

370+ Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)

311− Just tys -> do

371+ Just tys -> do

312− args' <- mapM (ir' env) (init args)

372+ args' <- mapM (irTerm vs env) (init args)

313− -- wrap it in a prim__IO

314− -- return $ con_ 0 @@ impossible @@

315− return $ -- LLazyExp $

316− LForeign LANG_C rty fgnName (zip tys args')

373+ return $ LForeign LANG_C (mkIty' ret) fgnName (zip tys args')

374+

317− | otherwise = ifail "Badly formed foreign function call"

375+ | otherwise = ifail "Badly formed foreign function call"

318−

376+ where

319−getFTypes :: TT Name -> Maybe [FType]

377+ getFTypes :: TT Name -> Maybe [FType]

320−getFTypes tm = case unApply tm of

378+ getFTypes tm = case unApply tm of

379+ -- nil : {a : Type} -> List a

321− (nil, []) -> Just []

380+ (nil, [_]) -> Just []

322− (cons, [ty, xs]) ->

381+ -- cons : {a : Type} -> a -> List a -> List a

323− fmap (mkIty' ty :) (getFTypes xs)

382+ (cons, [_, ty, xs]) -> (mkIty' ty :) <$> getFTypes xs

324− _ -> Nothing

383+ _ -> Nothing

325−

384+

326−mkIty' (P _ (UN ty) _) = mkIty (str ty)

385+ mkIty' (P _ (UN ty) _) = mkIty (str ty)

327−mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))

386+ mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))

387+ | fi == txt "FIntT"

328− | fi == txt "FIntT" = mkIntIty (str intTy)

388+ = mkIntIty (str intTy)

389+

329−mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))

390+ mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))

330− | ff == txt "FFunction" && fa == txt "FAny" &&

391+ | ff == txt "FFunction"

392+ , fa == txt "FAny"

331− io == txt "IO"

393+ , io == txt "IO"

332 = FFunctionIO

394 = FFunctionIO

333−mkIty' (App (App (P _ (UN ff) _) _) _)

334− | ff == txt "FFunction" = FFunction

335−mkIty' _ = FAny

336−

337−-- would be better if these FInt types were evaluated at compile time

338−-- TODO: add %eval directive for such things

339−

340−mkIty "FFloat" = FArith ATFloat

341−mkIty "FInt" = mkIntIty "ITNative"

342−mkIty "FChar" = mkIntIty "ITChar"

343−mkIty "FByte" = mkIntIty "IT8"

344−mkIty "FShort" = mkIntIty "IT16"

345−mkIty "FLong" = mkIntIty "IT64"

346−mkIty "FBits8" = mkIntIty "IT8"

347−mkIty "FBits16" = mkIntIty "IT16"

348−mkIty "FBits32" = mkIntIty "IT32"

349−mkIty "FBits64" = mkIntIty "IT64"

350−mkIty "FString" = FString

351−mkIty "FPtr" = FPtr

352−mkIty "FManagedPtr" = FManagedPtr

353−mkIty "FUnit" = FUnit

354−mkIty "FFunction" = FFunction

355−mkIty "FFunctionIO" = FFunctionIO

356−mkIty "FBits8x16" = FArith (ATInt (ITVec IT8 16))

357−mkIty "FBits16x8" = FArith (ATInt (ITVec IT16 8))

358−mkIty "FBits32x4" = FArith (ATInt (ITVec IT32 4))

359−mkIty "FBits64x2" = FArith (ATInt (ITVec IT64 2))

360−mkIty x = error $ "Unknown type " ++ x

361−

362−mkIntIty "ITNative" = FArith (ATInt ITNative)

363−mkIntIty "ITChar" = FArith (ATInt ITChar)

364−mkIntIty "IT8" = FArith (ATInt (ITFixed IT8))

365−mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))

366−mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

367−mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

368−

369−zname = sNS (sUN "Z") ["Nat","Prelude"]

370−sname = sNS (sUN "S") ["Nat","Prelude"]

371−

372−instance ToIR ([Name], SC) where

373− ir (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

374− tree' <- ir tree

375− return $ LLam args tree'

376−

377−instance ToIR SC where

378− ir t = ir' t where

379−

380− ir' (STerm t) = ir t

381− ir' (UnmatchedCase str) = return $ LError str

382− ir' (ProjCase tm alts) = do tm' <- ir tm

383− alts' <- mapM (mkIRAlt tm') alts

384− return $ LCase tm' alts'

385− ir' (Case n alts) = do alts' <- mapM (mkIRAlt (LV (Glob n))) alts

386− return $ LCase (LV (Glob n)) alts'

387− ir' ImpossibleCase = return LNothing

388−

389− -- special cases for Z and S

390− -- Needs rethink: projections make this fail

391−-- mkIRAlt n (ConCase z _ [] rhs) | z == zname

392−-- = mkIRAlt n (ConstCase (BI 0) rhs)

393−-- mkIRAlt n (ConCase s _ [arg] rhs) | s == sname

394−-- = do n' <- ir n

395−-- rhs' <- ir rhs

396−-- return $ LDefaultCase

397−-- (LLet arg (LOp LBMinus [n', LConst (BI 1)])

398−-- rhs')

399− mkIRAlt _ (ConCase n t args rhs)

400− = do rhs' <- ir rhs

401− return $ LConCase (-1) n args rhs'

402− mkIRAlt _ (ConstCase x rhs)

403− | matchable x

404− = do rhs' <- ir rhs

405− return $ LConstCase x rhs'

406− | matchableTy x

407− = do rhs' <- ir rhs

408− return $ LDefaultCase rhs'

409− mkIRAlt tm (SucCase n rhs)

410− = do rhs' <- ir rhs

411− return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))

412− [tm,

413− LConst (BI 1)]) rhs')

414−-- return $ LSucCase n rhs'

415− mkIRAlt _ (ConstCase c rhs)

416− = ifail $ "Can't match on (" ++ show c ++ ")"

417− mkIRAlt _ (DefaultCase rhs)

418− = do rhs' <- ir rhs

419− return $ LDefaultCase rhs'

420−

421− matchable (I _) = True

422− matchable (BI _) = True

423− matchable (Ch _) = True

424− matchable (Str _) = True

425− matchable _ = False

426−

427− matchableTy (AType (ATInt ITNative)) = True

428− matchableTy (AType (ATInt ITBig)) = True

429− matchableTy (AType (ATInt ITChar)) = True

430− matchableTy StrType = True

431−

432− matchableTy (AType (ATInt (ITFixed IT8))) = True

433− matchableTy (AType (ATInt (ITFixed IT16))) = True

434− matchableTy (AType (ATInt (ITFixed IT32))) = True

435− matchableTy (AType (ATInt (ITFixed IT64))) = True

436−

437− matchableTy _ = False

438

395

396+ mkIty' (App (App (P _ (UN ff) _) _) _)

397+ | ff == txt "FFunction"

398+ = FFunction

399+

400+ mkIty' _ = FAny

401+

402+ -- would be better if these FInt types were evaluated at compile time

403+ -- TODO: add %eval directive for such things

404+

405+ mkIty "FFloat" = FArith ATFloat

406+ mkIty "FInt" = mkIntIty "ITNative"

407+ mkIty "FChar" = mkIntIty "ITChar"

408+ mkIty "FByte" = mkIntIty "IT8"

409+ mkIty "FShort" = mkIntIty "IT16"

410+ mkIty "FLong" = mkIntIty "IT64"

411+ mkIty "FBits8" = mkIntIty "IT8"

412+ mkIty "FBits16" = mkIntIty "IT16"

413+ mkIty "FBits32" = mkIntIty "IT32"

414+ mkIty "FBits64" = mkIntIty "IT64"

415+ mkIty "FString" = FString

416+ mkIty "FPtr" = FPtr

417+ mkIty "FManagedPtr" = FManagedPtr

418+ mkIty "FUnit" = FUnit

419+ mkIty "FFunction" = FFunction

420+ mkIty "FFunctionIO" = FFunctionIO

421+ mkIty "FBits8x16" = FArith (ATInt (ITVec IT8 16))

422+ mkIty "FBits16x8" = FArith (ATInt (ITVec IT16 8))

423+ mkIty "FBits32x4" = FArith (ATInt (ITVec IT32 4))

424+ mkIty "FBits64x2" = FArith (ATInt (ITVec IT64 2))

425+ mkIty x = error $ "Unknown type " ++ x

426+

427+ mkIntIty "ITNative" = FArith (ATInt ITNative)

428+ mkIntIty "ITChar" = FArith (ATInt ITChar)

429+ mkIntIty "IT8" = FArith (ATInt (ITFixed IT8))

430+ mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))

431+ mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

432+ mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

433+

434+irTree :: [Name] -> SC -> Idris LExp

435+irTree args tree = do

436+ logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree

437+ LLam args <$> irSC M.empty tree

438+

439+irSC :: Vars -> SC -> Idris LExp

440+irSC vs (STerm t) = irTerm vs [] t

441+irSC vs (UnmatchedCase str) = return $ LError str

442+irSC vs (ProjCase tm alts) = do

443+ tm' <- irTerm vs [] tm

444+ alts' <- mapM (irAlt vs tm') alts

445+ return $ LCase tm' alts'

446+

447+-- Transform matching on Delay to applications of Force.

448+irSC vs (Case n [ConCase (UN delay) i [_, _, n'] sc])

449+ | delay == txt "Delay"

450+ = irSC vs $ mkForce n n' sc

451+

452+-- There are two transformations in this case:

453+--

454+-- 1. Newtype-case elimination:

455+-- case {e0} of

456+-- wrap({e1}) -> P({e1}) ==> P({e0})

457+--

458+-- This is important because newtyped constructors are compiled away entirely

459+-- and we need to do that everywhere.

460+--

461+-- 2. Unused-case elimination (only valid for singleton branches):

462+-- case {e0} of ==> P

463+-- C(x,y) -> P[... x,y not used ...]

464+--

465+-- This is important for runtime because sometimes we case on irrelevant data:

466+--

467+-- In the example above, {e0} will most probably have been erased

468+-- so this vain projection would make the resulting program segfault

469+-- because the code generator still emits a PROJECT(...) G-machine instruction.

470+--

471+-- Hence, we check whether the variables are used at all

472+-- and erase the casesplit if they are not.

473+irSC vs (Case n [alt]) = do

474+ replacement <- case alt of

475+ ConCase cn a ns sc -> do

476+ detag <- maybe False detaggable . lookupCtxtExact cn . idris_optimisation <$> getIState

477+ used <- maybe [] (map fst . usedpos) . lookupCtxtExact cn . idris_callgraph <$> getIState

478+ if detag && length used == 1

479+ then return . Just $ substSC (ns !! head used) n sc

480+ else return Nothing

481+ _ -> return Nothing

482+

483+ case replacement of

484+ Just sc -> irSC vs sc

485+ _ -> do

486+ alt' <- irAlt vs (LV (Glob n)) alt

487+ return $ case namesBoundIn alt' `usedIn` subexpr alt' of

488+ [] -> subexpr alt' -- strip the unused top-most case

489+ _ -> LCase (LV (Glob n)) [alt']

490+ where

491+ namesBoundIn :: LAlt -> [Name]

492+ namesBoundIn (LConCase cn i ns sc) = ns

493+ namesBoundIn (LConstCase c sc) = []

494+ namesBoundIn (LDefaultCase sc) = []

495+

496+ subexpr :: LAlt -> LExp

497+ subexpr (LConCase _ _ _ e) = e

498+ subexpr (LConstCase _ e) = e

499+ subexpr (LDefaultCase e) = e

500+

501+irSC vs (Case n alts) = LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts

502+irSC vs ImpossibleCase = return LNothing

503+

504+irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt

505+

506+-- this leaves out all unused arguments of the constructor

507+irAlt vs _ (ConCase n t args sc) = do

508+ used <- getUsed . lookup n <$> getIState

509+ let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]

510+ LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc

511+ where

512+ lookup n = lookupCtxtExact n . idris_callgraph

513+ getUsed = maybe [] (map fst . usedpos)

514+

515+ methodVars = case n of

516+ SN (InstanceCtorN className)

517+ -> M.fromList [(v, VI

518+ { viMethod = Just $ mkFieldName n i

519+ }) | (v,i) <- zip args [0..]]

520+ _

521+ -> M.empty -- not an instance constructor

522+

523+irAlt vs _ (ConstCase x rhs)

524+ | matchable x = LConstCase x <$> irSC vs rhs

525+ | matchableTy x = LDefaultCase <$> irSC vs rhs

526+ where

527+ matchable (I _) = True

528+ matchable (BI _) = True

529+ matchable (Ch _) = True

530+ matchable (Str _) = True

531+ matchable _ = False

532+

533+ matchableTy (AType (ATInt ITNative)) = True

534+ matchableTy (AType (ATInt ITBig)) = True

535+ matchableTy (AType (ATInt ITChar)) = True

536+ matchableTy StrType = True

537+

538+ matchableTy (AType (ATInt (ITFixed IT8))) = True

539+ matchableTy (AType (ATInt (ITFixed IT16))) = True

540+ matchableTy (AType (ATInt (ITFixed IT32))) = True

541+ matchableTy (AType (ATInt (ITFixed IT64))) = True

542+

543+ matchableTy _ = False

544+

545+irAlt vs tm (SucCase n rhs) = do

546+ rhs' <- irSC vs rhs

547+ return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))

548+ [tm,

549+ LConst (BI 1)]) rhs')

550+

551+irAlt vs _ (ConstCase c rhs)

552+ = ifail $ "Can't match on (" ++ show c ++ ")"

553+

554+irAlt vs _ (DefaultCase rhs)

555+ = LDefaultCase <$> irSC vs rhs

src/IRTS/Lang.hs+56−31

@@ -213,36 +213,61 @@ usedIn env (LOp f args) = concatMap (usedIn env) args

213usedIn env _ = []

214

215instance Show LExp where

216− show e = show' [] e where

216+ show e = show' [] "" e where

217− show' env (LV (Loc i)) = env!!i

217+ show' env ind (LV (Loc i)) = env!!i

218− show' env (LV (Glob n)) = show n

218+ show' env ind (LV (Glob n)) = show n

219+

219− show' env (LLazyApp e args) = show e ++ "|(" ++

220+ show' env ind (LLazyApp e args)

220− showSep ", " (map (show' env) args) ++")"

221+ = show e ++ "|(" ++ showSep ", " (map (show' env ind) args) ++")"

222+

221− show' env (LApp _ e args) = show' env e ++ "(" ++

223+ show' env ind (LApp _ e args)

222− showSep ", " (map (show' env) args) ++")"

224+ = show' env ind e ++ "(" ++ showSep ", " (map (show' env ind) args) ++")"

225+

223− show' env (LLazyExp e) = "%lazy(" ++ show' env e ++ ")"

226+ show' env ind (LLazyExp e) = "lazy{ " ++ show' env ind e ++ " }"

224− show' env (LForce e) = "%force(" ++ show' env e ++ ")"

227+ show' env ind (LForce e) = "force{ " ++ show' env ind e ++ " }"

228+ show' env ind (LLet n v e)

225− show' env (LLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++

229+ = "let " ++ show n ++ " = " ++ show' env ind v

226− show' (env ++ [show n]) e

230+ ++ " in " ++ show' (env ++ [show n]) ind e

231+

232+ show' env ind (LLam args e)

227− show' env (LLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++

233+ = "\\ " ++ showSep "," (map show args)

228− show' (env ++ (map show args)) e

234+ ++ " => " ++ show' (env ++ (map show args)) ind e

235+

229− show' env (LProj t i) = show t ++ "!" ++ show i

236+ show' env ind (LProj t i) = show t ++ "!" ++ show i

237+

238+ show' env ind (LCon i n args)

230− show' env (LCon i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"

239+ = show n ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

240+

231− show' env (LCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++

241+ show' env ind (LCase e alts)

242+ = "case " ++ show' env ind e ++ " of \n" ++ fmt alts

243+ where

244+ fmt [] = ""

245+ fmt [alt]

246+ = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ " ") alt

247+ fmt (alt:as)

232− showSep "\n\t| " (map (showAlt env) alts)

248+ = "\t" ++ ind ++ "| " ++ showAlt env (ind ++ ". ") alt

249+ ++ "\n" ++ fmt as

250+

233− show' env (LConst c) = show c

251+ show' env ind (LConst c) = show c

252+

234− show' env (LForeign lang ty n args)

253+ show' env ind (LForeign lang ty n args) = concat

254+ [ "foreign{ "

255+ , n ++ "("

235− = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"

256+ , showSep ", " (map (\(ty,x) -> show' env ind x ++ " : " ++ show ty) args)

257+ , ") : "

258+ , show ty

259+ , " }"

260+ ]

261+

262+ show' env ind (LOp f args)

236− show' env (LOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"

263+ = show f ++ "(" ++ showSep ", " (map (show' env ind) args) ++ ")"

264+

237− show' env (LError str) = "error " ++ show str

265+ show' env ind (LError str) = "error " ++ show str

238− show' env LNothing = "____"

266+ show' env ind LNothing = "____"

239−

267+

240− showAlt env (LConCase _ n args e)

268+ showAlt env ind (LConCase _ n args e)

241 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "

269 = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "

242− ++ show' env e

270+ ++ show' env ind e

243− showAlt env (LConstCase c e) = show c ++ " => " ++ show' env e

244− showAlt env (LDefaultCase e) = "_ => " ++ show' env e

245−

246−

247−

248

271

272+ showAlt env ind (LConstCase c e) = show c ++ " => " ++ show' env ind e

273+ showAlt env ind (LDefaultCase e) = "_ => " ++ show' env ind e

src/Idris/AbsSyntax.hs+108−179

@@ -88,6 +88,10 @@ addDyLib libs = do i <- getIState

88addHdr :: Codegen -> String -> Idris ()

89addHdr tgt f = do i <- getIState; putIState $ i { idris_hdrs = nub $ (tgt, f) : idris_hdrs i }

90

91+addImported :: FilePath -> Idris ()

92+addImported f = do i <- getIState

93+ putIState $ i { idris_imported = nub $ f : idris_imported i }

94+

91addLangExt :: LanguageExt -> Idris ()

95addLangExt :: LanguageExt -> Idris ()

92addLangExt TypeProviders = do i <- getIState

96addLangExt TypeProviders = do i <- getIState

93 putIState $ i {

97 putIState $ i {

@@ -357,6 +361,9 @@ addNameIdx' i n

357getHdrs :: Codegen -> Idris [String]

361getHdrs :: Codegen -> Idris [String]

358getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

362getHdrs tgt = do i <- getIState; return (forCodegen tgt $ idris_hdrs i)

359

363

364+getImported :: Idris [FilePath]

365+getImported = do i <- getIState; return (idris_imported i)

366+

360setErrSpan :: FC -> Idris ()

367setErrSpan :: FC -> Idris ()

361setErrSpan x = do i <- getIState;

368setErrSpan x = do i <- getIState;

362 case (errSpan i) of

369 case (errSpan i) of

@@ -381,6 +388,16 @@ getIState = get

381putIState :: IState -> Idris ()

388putIState :: IState -> Idris ()

382putIState = put

389putIState = put

383

390

391+withContext :: (IState -> Ctxt a) -> Name -> b -> (a -> Idris b) -> Idris b

392+withContext ctx name dflt action = do

393+ ist <- getIState

394+ case lookupCtxt name (ctx ist) of

395+ [x] -> action x

396+ _ -> return dflt

397+

398+withContext_ :: (IState -> Ctxt a) -> Name -> (a -> Idris ()) -> Idris ()

399+withContext_ ctx name action = withContext ctx name () action

400+

384-- | A version of liftIO that puts errors into the exception type of the Idris monad

401-- | A version of liftIO that puts errors into the exception type of the Idris monad

385runIO :: IO a -> Idris a

402runIO :: IO a -> Idris a

386runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return

403runIO x = liftIO (tryIOError x) >>= either (throwError . Msg . show) return

@@ -490,6 +507,12 @@ getUndefined :: Idris [Name]

490getUndefined = do i <- getIState

507getUndefined = do i <- getIState

491 return (map fst (idris_metavars i) \\ primDefs)

508 return (map fst (idris_metavars i) \\ primDefs)

492

509

510+isMetavarName :: Name -> IState -> Bool

511+isMetavarName n ist

512+ = case lookupNames n (tt_ctxt ist) of

513+ (t:_) -> isJust $ lookup t (idris_metavars ist)

514+ _ -> False

515+

493getWidth :: Idris ConsoleWidth

516getWidth :: Idris ConsoleWidth

494getWidth = fmap idris_consolewidth getIState

517getWidth = fmap idris_consolewidth getIState

495

518

@@ -505,155 +528,16 @@ renderWidth = do iw <- getWidth

505 AutomaticWidth -> runIO getScreenWidth

528 AutomaticWidth -> runIO getScreenWidth

506

529

507

530

508−iRender :: Doc a -> Idris (SimpleDoc a)

509−iRender d = do w <- getWidth

510− ist <- getIState

511− let ideSlave = case idris_outputmode ist of

512− IdeSlave _ -> True

513− _ -> False

514− case w of

515− InfinitelyWide -> return $ renderPretty 1.0 1000000000 d

516− ColsWide n -> return $

517− if n < 1

518− then renderPretty 1.0 1000000000 d

519− else renderPretty 0.8 n d

520− AutomaticWidth | ideSlave -> return $ renderPretty 1.0 1000000000 d

521− | otherwise -> do width <- runIO getScreenWidth

522− return $ renderPretty 0.8 width d

523−

524−ihPrintResult :: Handle -> String -> Idris ()

525−ihPrintResult h s = do i <- getIState

526− case idris_outputmode i of

527− RawOutput -> case s of

528− "" -> return ()

529− s -> runIO $ hPutStrLn h s

530− IdeSlave n ->

531− let good = SexpList [SymbolAtom "ok", toSExp s] in

532− runIO $ hPutStrLn h $ convSExp "return" good n

533−

534−-- | Write a pretty-printed term to the console with semantic coloring

535−consoleDisplayAnnotated :: Handle -> Doc OutputAnnotation -> Idris ()

536−consoleDisplayAnnotated h output = do ist <- getIState

537− rendered <- iRender $ output

538− runIO . hPutStrLn h .

539− displayDecorated (consoleDecorate ist) $

540− rendered

541−

542−

543−-- | Write pretty-printed output to IDESlave with semantic annotations

544−ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()

545−ideSlaveReturnAnnotated n h out = do ist <- getIState

546− (str, spans) <- fmap displaySpans .

547− iRender .

548− fmap (fancifyAnnots ist) $

549− out

550− let good = [SymbolAtom "ok", toSExp str, toSExp spans]

551− runIO . hPutStrLn h $ convSExp "return" good n

552−

553−ihPrintTermWithType :: Handle -> Doc OutputAnnotation -> Doc OutputAnnotation -> Idris ()

554−ihPrintTermWithType h tm ty = do ist <- getIState

555− let output = tm <+> colon <+> ty

556− case idris_outputmode ist of

557− RawOutput -> consoleDisplayAnnotated h output

558− IdeSlave n -> ideSlaveReturnAnnotated n h output

559−

560−-- | Pretty-print a collection of overloadings to REPL or IDESlave - corresponds to :t name

561−ihPrintFunTypes :: Handle -> [(Name, Bool)] -> Name -> [(Name, PTerm)] -> Idris ()

562−ihPrintFunTypes h bnd n [] = ihPrintError h $ "No such variable " ++ show n

563−ihPrintFunTypes h bnd n overloads = do imp <- impShow

564− ist <- getIState

565− let output = vsep (map (uncurry (ppOverload imp)) overloads)

566− case idris_outputmode ist of

567− RawOutput -> consoleDisplayAnnotated h output

568− IdeSlave n -> ideSlaveReturnAnnotated n h output

569− where fullName n = prettyName True bnd n

570− ppOverload imp n tm = fullName n <+> colon <+> align (pprintPTerm imp bnd [] tm)

571−

572−ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris ()

573−ihRenderResult h d = do ist <- getIState

574− case idris_outputmode ist of

575− RawOutput -> consoleDisplayAnnotated h d

576− IdeSlave n -> ideSlaveReturnAnnotated n h d

577−

578−fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation

579−fancifyAnnots ist annot@(AnnName n _ _) =

580− do let ctxt = tt_ctxt ist

581− case () of

582− _ | isDConName n ctxt -> AnnName n (Just DataOutput) Nothing

583− _ | isFnName n ctxt -> AnnName n (Just FunOutput) Nothing

584− _ | isTConName n ctxt -> AnnName n (Just TypeOutput) Nothing

585− _ | otherwise -> annot

586−fancifyAnnots _ annot = annot

587

531

588type1Doc :: Doc OutputAnnotation

532type1Doc :: Doc OutputAnnotation

589type1Doc = (annotate AnnConstType $ text "Type 1")

533type1Doc = (annotate AnnConstType $ text "Type 1")

590

534

591−-- | Show an error with semantic highlighting

592−ihRenderError :: Handle -> Doc OutputAnnotation -> Idris ()

593−ihRenderError h e = do ist <- getIState

594− case idris_outputmode ist of

595− RawOutput -> consoleDisplayAnnotated h e

596− IdeSlave n -> do

597− (str, spans) <- fmap displaySpans .

598− iRender .

599− fmap (fancifyAnnots ist) $

600− e

601− let good = [SymbolAtom "error", toSExp str, toSExp spans]

602− runIO . hPutStrLn h $ convSExp "return" good n

603−

604−ihPrintError :: Handle -> String -> Idris ()

605−ihPrintError h s = do i <- getIState

606− case idris_outputmode i of

607− RawOutput -> case s of

608− "" -> return ()

609− s -> runIO $ hPutStrLn h s

610− IdeSlave n ->

611− let good = SexpList [SymbolAtom "error", toSExp s] in

612− runIO . hPutStrLn h $ convSExp "return" good n

613−

614−ihputStrLn :: Handle -> String -> Idris ()

615−ihputStrLn h s = do i <- getIState

616− case idris_outputmode i of

617− RawOutput -> runIO $ hPutStrLn h s

618− IdeSlave n -> runIO . hPutStrLn h $ convSExp "write-string" s n

619−

620−iputStrLn = ihputStrLn stdout

621−iPrintError = ihPrintError stdout

622−iPrintResult = ihPrintResult stdout

623−iWarn = ihWarn stdout

624−

625−ideslavePutSExp :: SExpable a => String -> a -> Idris ()

626−ideslavePutSExp cmd info = do i <- getIState

627− case idris_outputmode i of

628− IdeSlave n -> runIO . putStrLn $ convSExp cmd info n

629− _ -> return ()

630−

631−-- this needs some typing magic and more structured output towards emacs

632−iputGoal :: SimpleDoc OutputAnnotation -> Idris ()

633−iputGoal g = do i <- getIState

634− case idris_outputmode i of

635− RawOutput -> runIO $ putStrLn (displayDecorated (consoleDecorate i) g)

636− IdeSlave n -> runIO . putStrLn $

637− convSExp "write-goal" (displayS (fmap (fancifyAnnots i) g) "") n

638

535

639isetPrompt :: String -> Idris ()

536isetPrompt :: String -> Idris ()

640isetPrompt p = do i <- getIState

537isetPrompt p = do i <- getIState

641 case idris_outputmode i of

538 case idris_outputmode i of

642 IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n

539 IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n

643

540

644−ihWarn :: Handle -> FC -> Doc OutputAnnotation -> Idris ()

645−ihWarn h fc err = do i <- getIState

646− case idris_outputmode i of

647− RawOutput ->

648− do err' <- iRender . fmap (fancifyAnnots i) $

649− text (show fc) <> colon <//> err

650− runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'

651− IdeSlave n ->

652− do err' <- iRender . fmap (fancifyAnnots i) $ err

653− let (str, spans) = displaySpans err'

654− runIO . hPutStrLn h $

655− convSExp "warning" (fc_fname fc, fc_start fc, fc_end fc, str, spans) n

656−

657setLogLevel :: Int -> Idris ()

541setLogLevel :: Int -> Idris ()

658setLogLevel l = do i <- getIState

542setLogLevel l = do i <- getIState

659 let opts = idris_options i

543 let opts = idris_options i

@@ -945,9 +829,9 @@ expandParams dec ps ns infs tm = en tm

945 | otherwise = PLam n (en t) (en s)

829 | otherwise = PLam n (en t) (en s)

946 en (PPi p n t s)

830 en (PPi p n t s)

947 | n `elem` (map fst ps ++ ns)

831 | n `elem` (map fst ps ++ ns)

948− = let n' = mkShadow n in

832+ = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp?

949− PPi p n' (en t) (en (shadow n n' s))

833+ PPi (enTacImp p) n' (en t) (en (shadow n n' s))

950− | otherwise = PPi p n (en t) (en s)

834+ | otherwise = PPi (enTacImp p) n (en t) (en s)

951 en (PLet n ty v s)

835 en (PLet n ty v s)

952 | n `elem` (map fst ps ++ ns)

836 | n `elem` (map fst ps ++ ns)

953 = let n' = mkShadow n in

837 = let n' = mkShadow n in

@@ -1006,6 +890,9 @@ expandParams dec ps ns infs tm = en tm

1006

890

1007 nseq x y = nsroot x == nsroot y

891 nseq x y = nsroot x == nsroot y

1008

892

893+ enTacImp (TacImp aos st scr) = TacImp aos st (en scr)

894+ enTacImp other = other

895+

1009expandParamsD :: Bool -> -- True = RHS only

896expandParamsD :: Bool -> -- True = RHS only

1010 IState ->

897 IState ->

1011 (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl

898 (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl

@@ -1202,7 +1089,7 @@ addUsingConstraints syn fc t

1202 | otherwise = doAdd cs ns t

1089 | otherwise = doAdd cs ns t

1203

1090

1204 mkConst c args = PApp fc (PRef fc c)

1091 mkConst c args = PApp fc (PRef fc c)

1205− (map (\n -> PExp 0 [] (PRef fc n)) args)

1092+ (map (\n -> PExp 0 [] (sMN 0 "carg") (PRef fc n)) args)

1206

1093

1207 getConstraints (PPi (Constraint _ _) _ c sc)

1094 getConstraints (PPi (Constraint _ _) _ c sc)

1208 = getcapp c ++ getConstraints sc

1095 = getcapp c ++ getConstraints sc

@@ -1214,7 +1101,7 @@ addUsingConstraints syn fc t

1214 return (UConstraint c ns)

1101 return (UConstraint c ns)

1215 getcapp _ = []

1102 getcapp _ = []

1216

1103

1217− getName (PExp _ _ (PRef _ n)) = return n

1104+ getName (PExp _ _ _ (PRef _ n)) = return n

1218 getName _ = []

1105 getName _ = []

1219

1106

1220-- Add implicit Pi bindings for any names in the term which appear in an

1107-- Add implicit Pi bindings for any names in the term which appear in an

@@ -1222,13 +1109,14 @@ addUsingConstraints syn fc t

1222

1109

1223-- This has become a right mess already. Better redo it some time...

1110-- This has become a right mess already. Better redo it some time...

1224

1111

1225−implicit :: SyntaxInfo -> Name -> PTerm -> Idris PTerm

1112+implicit :: ElabInfo -> SyntaxInfo -> Name -> PTerm -> Idris PTerm

1226−implicit syn n ptm = implicit' syn [] n ptm

1113+implicit info syn n ptm = implicit' info syn [] n ptm

1227

1114

1228−implicit' :: SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1115+implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1229−implicit' syn ignore n ptm

1116+implicit' info syn ignore n ptm

1230 = do i <- getIState

1117 = do i <- getIState

1231 let (tm', impdata) = implicitise syn ignore i ptm

1118 let (tm', impdata) = implicitise syn ignore i ptm

1119+ defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

1232-- let (tm'', spos) = findStatics i tm'

1120-- let (tm'', spos) = findStatics i tm'

1233 putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1121 putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

1234 addIBC (IBCImp n)

1122 addIBC (IBCImp n)

@@ -1236,6 +1124,23 @@ implicit' syn ignore n ptm

1236-- i <- get

1124-- i <- get

1237-- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1125-- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

1238 return tm'

1126 return tm'

1127+ where

1128+ -- Detect unknown names in default arguments and throw error if found.

1129+ defaultArgCheck :: [Name] -> [PArg] -> Idris ()

1130+ defaultArgCheck knowns params = foldM_ notFoundInDefault knowns params

1131+

1132+ notFoundInDefault :: [Name] -> PArg -> Idris [Name]

1133+ notFoundInDefault kns (PTacImplicit _ _ n script _)

1134+ = do i <- getIState

1135+ case notFound kns (namesIn [] i script) of

1136+ Nothing -> return (n:kns)

1137+ Just name -> throwError (NoSuchVariable name)

1138+ notFoundInDefault kns p = return ((pname p):kns)

1139+

1140+ notFound :: [Name] -> [Name] -> Maybe Name

1141+ notFound kns [] = Nothing

1142+ notFound kns (SN (WhereN _ _ _) : ns) = notFound kns ns -- Known already

1143+ notFound kns (n:ns) = if elem n kns then notFound kns ns else Just n

1239

1144

1240implicitise :: SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg])

1145implicitise :: SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg])

1241implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1146implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

@@ -1281,7 +1186,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1281 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1186 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1282 _ -> [])

1187 _ -> [])

1283 (decls, ns) <- get -- ignore decls in HO types

1188 (decls, ns) <- get -- ignore decls in HO types

1284− put (PExp (getPriority ist ty) l Placeholder : decls,

1189+ put (PExp (getPriority ist ty) l n Placeholder : decls,

1285 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1190 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1286 imps True (n:env) sc

1191 imps True (n:env) sc

1287 imps top env (PPi (Constraint l _) n ty sc)

1192 imps top env (PPi (Constraint l _) n ty sc)

@@ -1289,7 +1194,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1289 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1194 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

1290 _ -> [])

1195 _ -> [])

1291 (decls, ns) <- get -- ignore decls in HO types

1196 (decls, ns) <- get -- ignore decls in HO types

1292− put (PConstraint 10 l Placeholder : decls,

1197+ put (PConstraint 10 l n Placeholder : decls,

1293 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1198 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1294 imps True (n:env) sc

1199 imps True (n:env) sc

1295 imps top env (PPi (TacImp l _ scr) n ty sc)

1200 imps top env (PPi (TacImp l _ scr) n ty sc)

@@ -1455,7 +1360,7 @@ aiFn inpat True ist fc f ds []

1455-- any constructor alts || any allImp ialts))

1360-- any constructor alts || any allImp ialts))

1456 then aiFn inpat False ist fc f ds [] -- use it as a constructor

1361 then aiFn inpat False ist fc f ds [] -- use it as a constructor

1457 else Right $ PPatvar fc f

1362 else Right $ PPatvar fc f

1458− where imp (PExp _ _ _) = False

1363+ where imp (PExp _ _ _ _) = False

1459 imp _ = True

1364 imp _ = True

1460-- allImp [] = False

1365-- allImp [] = False

1461 allImp xs = all imp xs

1366 allImp xs = all imp xs

@@ -1502,27 +1407,41 @@ aiFn inpat expat ist fc f ds as

1502 [(n,t)] -> t

1407 [(n,t)] -> t

1503 _ -> Public

1408 _ -> Public

1504

1409

1505−

1506 insertImpl :: [PArg] -> [PArg] -> [PArg]

1410 insertImpl :: [PArg] -> [PArg] -> [PArg]

1411+ insertImpl ps as = insImpAcc M.empty ps as

1412+

1413+ insImpAcc :: M.Map Name PTerm -- accumulated param names & arg terms

1414+ -> [PArg] -- parameters

1415+ -> [PArg] -- arguments

1416+ -> [PArg]

1507− insertImpl (PExp p l ty : ps) (PExp _ _ tm : given) =

1417+ insImpAcc pnas (PExp p l n ty : ps) (PExp _ _ _ tm : given) =

1508− PExp p l tm : insertImpl ps given

1418+ PExp p l n tm : insImpAcc (M.insert n tm pnas) ps given

1509− insertImpl (PConstraint p l ty : ps) (PConstraint _ _ tm : given) =

1419+ insImpAcc pnas (PConstraint p l n ty : ps) (PConstraint _ _ _ tm : given) =

1510− PConstraint p l tm : insertImpl ps given

1420+ PConstraint p l n tm : insImpAcc (M.insert n tm pnas) ps given

1511− insertImpl (PConstraint p l ty : ps) given =

1421+ insImpAcc pnas (PConstraint p l n ty : ps) given =

1512− PConstraint p l (PResolveTC fc) : insertImpl ps given

1422+ let rtc = PResolveTC fc in

1423+ PConstraint p l n rtc : insImpAcc (M.insert n rtc pnas) ps given

1513− insertImpl (PImp p _ l n ty : ps) given =

1424+ insImpAcc pnas (PImp p _ l n ty : ps) given =

1514 case find n given [] of

1425 case find n given [] of

1426+ Just (tm, given') ->

1515− Just (tm, given') -> PImp p False l n tm : insertImpl ps given'

1427+ PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given'

1428+ Nothing ->

1516− Nothing -> PImp p True l n Placeholder : insertImpl ps given

1429+ PImp p True l n Placeholder :

1430+ insImpAcc (M.insert n Placeholder pnas) ps given

1517− insertImpl (PTacImplicit p l n sc' ty : ps) given =

1431+ insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given =

1518− let sc = addImpl ist sc' in

1432+ let sc = addImpl ist (substMatches (M.toList pnas) sc') in

1519 case find n given [] of

1433 case find n given [] of

1434+ Just (tm, given') ->

1520− Just (tm, given') -> PTacImplicit p l n sc tm : insertImpl ps given'

1435+ PTacImplicit p l n sc tm :

1436+ insImpAcc (M.insert n tm pnas) ps given'

1521− Nothing -> if inpat

1437+ Nothing ->

1438+ if inpat

1522− then PTacImplicit p l n sc Placeholder : insertImpl ps given

1439+ then PTacImplicit p l n sc Placeholder :

1440+ insImpAcc (M.insert n Placeholder pnas) ps given

1523− else PTacImplicit p l n sc sc : insertImpl ps given

1441+ else PTacImplicit p l n sc sc :

1442+ insImpAcc (M.insert n sc pnas) ps given

1524− insertImpl expected [] = []

1443+ insImpAcc _ expected [] = []

1525− insertImpl _ given = given

1444+ insImpAcc _ _ given = given

1526

1445

1527 find n [] acc = Nothing

1446 find n [] acc = Nothing

1528 find n (PImp _ _ _ n' t : gs) acc

1447 find n (PImp _ _ _ n' t : gs) acc

@@ -1559,11 +1478,11 @@ stripLinear i tm = evalState (sl tm) [] where

1559 return $ PApp fc fn args'

1478 return $ PApp fc fn args'

1560 where slA (PImp p m l n t) = do t' <- sl t

1479 where slA (PImp p m l n t) = do t' <- sl t

1561 return $ PImp p m l n t'

1480 return $ PImp p m l n t'

1562− slA (PExp p l t) = do t' <- sl t

1481+ slA (PExp p l n t) = do t' <- sl t

1563− return $ PExp p l t'

1482+ return $ PExp p l n t'

1564− slA (PConstraint p l t)

1483+ slA (PConstraint p l n t)

1565 = do t' <- sl t

1484 = do t' <- sl t

1566− return $ PConstraint p l t'

1485+ return $ PConstraint p l n t'

1567 slA (PTacImplicit p l n sc t)

1486 slA (PTacImplicit p l n sc t)

1568 = do t' <- sl t

1487 = do t' <- sl t

1569 return $ PTacImplicit p l n sc t'

1488 return $ PTacImplicit p l n sc t'

@@ -1666,8 +1585,6 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

1666 = do mf <- match' f f'

1585 = do mf <- match' f f'

1667 ms <- zipWithM matchArg args args'

1586 ms <- zipWithM matchArg args args'

1668 return (mf ++ concat ms)

1587 return (mf ++ concat ms)

1669−-- match (PRef _ n) (PRef _ n') | n == n' = return []

1670−-- | otherwise = Nothing

1671 match (PRef f n) (PApp _ x []) = match (PRef f n) x

1588 match (PRef f n) (PApp _ x []) = match (PRef f n) x

1672 match (PPatvar f n) xr = match (PRef f n) xr

1589 match (PPatvar f n) xr = match (PRef f n) xr

1673 match xr (PPatvar f n) = match xr (PRef f n)

1590 match xr (PPatvar f n) = match xr (PRef f n)

@@ -1677,7 +1594,10 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

1677 (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i))

1594 (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i))

1678 || tm == Placeholder)

1595 || tm == Placeholder)

1679 = return [(n, tm)]

1596 = return [(n, tm)]

1597+ -- if one namespace is missing, drop the other

1680− | n == n' = return []

1598+ | n == n' || n == dropNS n' || dropNS n == n' = return []

1599+ where dropNS (NS n _) = n

1600+ dropNS n = n

1681 match (PRef _ n) tm

1601 match (PRef _ n) tm

1682 | not names && (not (isConName n (tt_ctxt i) ||

1602 | not names && (not (isConName n (tt_ctxt i) ||

1683 isFnName n (tt_ctxt i)) || tm == Placeholder)

1603 isFnName n (tt_ctxt i)) || tm == Placeholder)

@@ -1820,6 +1740,12 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

1820 mkUniqA arg = do t' <- mkUniq (getTm arg)

1740 mkUniqA arg = do t' <- mkUniq (getTm arg)

1821 return (arg { getTm = t' })

1741 return (arg { getTm = t' })

1822

1742

1743+ -- Initialise the unique name with the environment length (so we're not

1744+ -- looking for too long...)

1745+ initN (UN n) l = UN $ txt (str n ++ show l)

1746+ initN (MN i s) l = MN (i+l) s

1747+ initN n l = n

1748+

1823 -- FIXME: Probably ought to do this for completeness! It's fine as

1749 -- FIXME: Probably ought to do this for completeness! It's fine as

1824 -- long as there are no bindings inside tactics though.

1750 -- long as there are no bindings inside tactics though.

1825 mkUniqT tac = return tac

1751 mkUniqT tac = return tac

@@ -1829,7 +1755,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

1829 = do env <- get

1755 = do env <- get

1830 (n', sc') <-

1756 (n', sc') <-

1831 if n `elem` env

1757 if n `elem` env

1832− then do let n' = uniqueName n (env ++ inScope)

1758+ then do let n' = uniqueName (initN n (length env))

1759+ (env ++ inScope)

1833 return (n', shadow n n' sc)

1760 return (n', shadow n n' sc)

1834 else return (n, sc)

1761 else return (n, sc)

1835 put (n' : env)

1762 put (n' : env)

@@ -1840,7 +1767,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

1840 = do env <- get

1767 = do env <- get

1841 (n', sc') <-

1768 (n', sc') <-

1842 if n `elem` env

1769 if n `elem` env

1843− then do let n' = uniqueName n (env ++ inScope)

1770+ then do let n' = uniqueName (initN n (length env))

1771+ (env ++ inScope)

1844 return (n', shadow n n' sc)

1772 return (n', shadow n n' sc)

1845 else return (n, sc)

1773 else return (n, sc)

1846 put (n' : env)

1774 put (n' : env)

@@ -1851,7 +1779,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

1851 = do env <- get

1779 = do env <- get

1852 (n', sc') <-

1780 (n', sc') <-

1853 if n `elem` env

1781 if n `elem` env

1854− then do let n' = uniqueName n (env ++ inScope)

1782+ then do let n' = uniqueName (initN n (length env))

1783+ (env ++ inScope)

1855 return (n', shadow n n' sc)

1784 return (n', shadow n n' sc)

1856 else return (n, sc)

1785 else return (n, sc)

1857 put (n' : env)

1786 put (n' : env)

src/Idris/AbsSyntaxTree.hs+93−84

@@ -36,6 +36,19 @@ import Debug.Trace

36

37import Text.PrettyPrint.Annotated.Leijen

38

39+-- Data to pass to recursively called elaborators; e.g. for where blocks,

40+-- paramaterised declarations, etc.

41+

42+data ElabInfo = EInfo { params :: [(Name, PTerm)],

43+ inblock :: Ctxt [Name], -- names in the block, and their params

44+ liftname :: Name -> Name,

45+ namespace :: Maybe [String] }

46+

47+toplevel = EInfo [] emptyContext id Nothing

48+

49+eInfoNames :: ElabInfo -> [Name]

50+eInfoNames info = map fst (params info) ++ M.keys (inblock info)

51+

39data IOption = IOption { opt_logLevel :: Int,

52data IOption = IOption { opt_logLevel :: Int,

40 opt_typecase :: Bool,

53 opt_typecase :: Bool,

41 opt_typeintype :: Bool,

54 opt_typeintype :: Bool,

@@ -91,11 +104,6 @@ data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines sh

91 | ColsWide Int -- ^ Manually specified - must be positive

104 | ColsWide Int -- ^ Manually specified - must be positive

92 | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise

105 | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise

93

106

94−-- TODO: Add 'module data' to IState, which can be saved out and reloaded quickly (i.e

95−-- without typechecking).

96−-- This will include all the functions and data declarations, plus fixity declarations

97−-- and syntax macros.

98−

99-- | The global state used in the Idris monad

107-- | The global state used in the Idris monad

100data IState = IState {

108data IState = IState {

101 tt_ctxt :: Context, -- ^ All the currently defined names and their terms

109 tt_ctxt :: Context, -- ^ All the currently defined names and their terms

@@ -134,6 +142,7 @@ data IState = IState {

134 idris_libs :: [(Codegen, String)],

142 idris_libs :: [(Codegen, String)],

135 idris_cgflags :: [(Codegen, String)],

143 idris_cgflags :: [(Codegen, String)],

136 idris_hdrs :: [(Codegen, String)],

144 idris_hdrs :: [(Codegen, String)],

145+ idris_imported :: [FilePath], -- ^ Imported ibc file names

137 proof_list :: [(Name, [String])],

146 proof_list :: [(Name, [String])],

138 errSpan :: Maybe FC,

147 errSpan :: Maybe FC,

139 parserWarnings :: [(FC, Err)],

148 parserWarnings :: [(FC, Err)],

@@ -156,7 +165,8 @@ data IState = IState {

156 idris_nameIdx :: (Int, Ctxt (Int, Name)),

165 idris_nameIdx :: (Int, Ctxt (Int, Name)),

157 idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers

166 idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers

158 module_aliases :: M.Map [T.Text] [T.Text],

167 module_aliases :: M.Map [T.Text] [T.Text],

159− idris_consolewidth :: ConsoleWidth -- ^ How many chars wide is the console?

168+ idris_consolewidth :: ConsoleWidth, -- ^ How many chars wide is the console?

169+ idris_postulates :: S.Set Name

160 }

170 }

161

171

162data SizeChange = Smaller | Same | Bigger | Unknown

172data SizeChange = Smaller | Same | Bigger | Unknown

@@ -172,7 +182,7 @@ data CGInfo = CGInfo { argsdef :: [Name],

172 calls :: [(Name, [[Name]])],

182 calls :: [(Name, [[Name]])],

173 scg :: [SCGEntry],

183 scg :: [SCGEntry],

174 argsused :: [Name],

184 argsused :: [Name],

175− unusedpos :: [Int] }

185+ usedpos :: [(Int, [(Name, Int)])] } -- (used_arg#, [(using_fn, its_arg#)])

176 deriving Show

186 deriving Show

177{-!

187{-!

178deriving instance Binary CGInfo

188deriving instance Binary CGInfo

@@ -216,6 +226,7 @@ data IBCWrite = IBCFix FixDecl

216 | IBCLineApp FilePath Int PTerm

226 | IBCLineApp FilePath Int PTerm

217 | IBCErrorHandler Name

227 | IBCErrorHandler Name

218 | IBCFunctionErrorHandler Name Name Name

228 | IBCFunctionErrorHandler Name Name Name

229+ | IBCPostulate Name

219 deriving Show

230 deriving Show

220

231

221-- | The initial state for the compiler

232-- | The initial state for the compiler

@@ -225,9 +236,9 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

225 emptyContext emptyContext emptyContext emptyContext

236 emptyContext emptyContext emptyContext emptyContext

226 emptyContext emptyContext

237 emptyContext emptyContext

227 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

238 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

228− [] Nothing [] Nothing [] [] Nothing [] Hidden False [] Nothing [] [] RawOutput

239+ [] [] Nothing [] Nothing [] [] Nothing [] Hidden False [] Nothing [] [] RawOutput

229 True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty

240 True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty

230− AutomaticWidth

241+ AutomaticWidth S.empty

231

242

232-- | The monad for the main REPL - reading and processing files and updating

243-- | The monad for the main REPL - reading and processing files and updating

233-- global state (hence the IO inner monad).

244-- global state (hence the IO inner monad).

@@ -315,6 +326,7 @@ data Opt = Filename String

315 | DefaultTotal

326 | DefaultTotal

316 | DefaultPartial

327 | DefaultPartial

317 | WarnPartial

328 | WarnPartial

329+ | WarnReach

318 | NoCoverage

330 | NoCoverage

319 | ErrContext

331 | ErrContext

320 | ShowImpl

332 | ShowImpl

@@ -390,7 +402,7 @@ data Plicity = Imp { pargopts :: [ArgOpt],

390 pparam :: Bool }

402 pparam :: Bool }

391 | Exp { pargopts :: [ArgOpt],

403 | Exp { pargopts :: [ArgOpt],

392 pstatic :: Static,

404 pstatic :: Static,

393− pparam :: Bool }

405+ pparam :: Bool } -- this is a param (rather than index)

394 | Constraint { pargopts :: [ArgOpt],

406 | Constraint { pargopts :: [ArgOpt],

395 pstatic :: Static }

407 pstatic :: Static }

396 | TacImp { pargopts :: [ArgOpt],

408 | TacImp { pargopts :: [ArgOpt],

@@ -398,15 +410,12 @@ data Plicity = Imp { pargopts :: [ArgOpt],

398 pscript :: PTerm }

410 pscript :: PTerm }

399 deriving (Show, Eq)

411 deriving (Show, Eq)

400

412

401−plazy :: Plicity -> Bool

402−plazy tm = Lazy `elem` pargopts tm

403−

404{-!

413{-!

405deriving instance Binary Plicity

414deriving instance Binary Plicity

406deriving instance NFData Plicity

415deriving instance NFData Plicity

407!-}

416!-}

408

417

409−impl = Imp [Lazy] Dynamic False

418+impl = Imp [] Dynamic False

410expl = Exp [] Dynamic False

419expl = Exp [] Dynamic False

411expl_param = Exp [] Dynamic True

420expl_param = Exp [] Dynamic True

412constraint = Constraint [] Dynamic

421constraint = Constraint [] Dynamic

@@ -771,9 +780,11 @@ data PArg' t = PImp { priority :: Int,

771 pname :: Name, getTm :: t }

780 pname :: Name, getTm :: t }

772 | PExp { priority :: Int,

781 | PExp { priority :: Int,

773 argopts :: [ArgOpt],

782 argopts :: [ArgOpt],

783+ pname :: Name,

774 getTm :: t }

784 getTm :: t }

775 | PConstraint { priority :: Int,

785 | PConstraint { priority :: Int,

776 argopts :: [ArgOpt],

786 argopts :: [ArgOpt],

787+ pname :: Name,

777 getTm :: t }

788 getTm :: t }

778 | PTacImplicit { priority :: Int,

789 | PTacImplicit { priority :: Int,

779 argopts :: [ArgOpt],

790 argopts :: [ArgOpt],

@@ -782,16 +793,13 @@ data PArg' t = PImp { priority :: Int,

782 getTm :: t }

793 getTm :: t }

783 deriving (Show, Eq, Functor)

794 deriving (Show, Eq, Functor)

784

795

785−data ArgOpt = Lazy | HideDisplay

796+data ArgOpt = HideDisplay | InaccessibleArg

786 deriving (Show, Eq)

797 deriving (Show, Eq)

787

798

788−lazyarg :: PArg' t -> Bool

789−lazyarg tm = Lazy `elem` argopts tm

790−

791instance Sized a => Sized (PArg' a) where

799instance Sized a => Sized (PArg' a) where

792 size (PImp p _ l nm trm) = 1 + size nm + size trm

800 size (PImp p _ l nm trm) = 1 + size nm + size trm

793− size (PExp p l trm) = 1 + size trm

801+ size (PExp p l nm trm) = 1 + size nm + size trm

794− size (PConstraint p l trm) = 1 + size trm

802+ size (PConstraint p l nm trm) = 1 + size nm +size nm + size trm

795 size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

803 size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

796

804

797{-!

805{-!

@@ -799,10 +807,10 @@ deriving instance Binary PArg'

799deriving instance NFData PArg'

807deriving instance NFData PArg'

800!-}

808!-}

801

809

802−pimp n t mach = PImp 1 mach [Lazy] n t

810+pimp n t mach = PImp 1 mach [] n t

803−pexp t = PExp 1 [] t

811+pexp t = PExp 1 [] (sMN 0 "arg") t

804−pconst t = PConstraint 1 [] t

812+pconst t = PConstraint 1 [] (sMN 0 "carg") t

805−ptacimp n s t = PTacImplicit 2 [Lazy] n s t

813+ptacimp n s t = PTacImplicit 2 [] n s t

806

814

807type PArg = PArg' PTerm

815type PArg = PArg' PTerm

808

816

@@ -826,22 +834,8 @@ data TIData = TIPartial -- ^ a function with a partially defined type

826 | TISolution [Term] -- ^ possible solutions to a metavariable in a type

834 | TISolution [Term] -- ^ possible solutions to a metavariable in a type

827 deriving Show

835 deriving Show

828

836

829−-- An argument is conditionally forceable iff its forceability

837+data OptInfo = Optimise { inaccessible :: [(Int,Name)], -- includes names for error reporting

830−-- depends on the collapsibility of the whole type.

838+ detaggable :: Bool }

831−data Forceability = Conditional | Unconditional deriving (Show, Enum, Bounded, Eq, Ord)

832−

833−{-!

834−deriving instance Binary Forceability

835−deriving instance NFData Forceability

836−!-}

837−

838−data OptInfo = Optimise { collapsible :: Bool,

839− isnewtype :: Bool,

840− -- The following should actually be (IntMap Forceability)

841− -- but the corresponding Binary instance seems to be broken.

842− -- Let's store a list and convert it to IntMap whenever needed.

843− forceable :: [(Int, Forceability)],

844− recursive :: [Int] }

845 deriving Show

839 deriving Show

846{-!

840{-!

847deriving instance Binary OptInfo

841deriving instance Binary OptInfo

@@ -1068,13 +1062,13 @@ consoleDecorate ist AnnConstType = let theme = idris_colourTheme ist

1068consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist)

1062consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist)

1069consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)

1063consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)

1070consoleDecorate ist AnnKeyword = colouriseKeyword (idris_colourTheme ist)

1064consoleDecorate ist AnnKeyword = colouriseKeyword (idris_colourTheme ist)

1071−consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist

1065+consoleDecorate ist (AnnName n _ _ _) = let ctxt = tt_ctxt ist

1072− theme = idris_colourTheme ist

1066+ theme = idris_colourTheme ist

1073− in case () of

1067+ in case () of

1074− _ | isDConName n ctxt -> colouriseData theme

1068+ _ | isDConName n ctxt -> colouriseData theme

1075− _ | isFnName n ctxt -> colouriseFun theme

1069+ _ | isFnName n ctxt -> colouriseFun theme

1076− _ | isTConName n ctxt -> colouriseType theme

1070+ _ | isTConName n ctxt -> colouriseType theme

1077− _ | otherwise -> id -- don't colourise unknown names

1071+ _ | otherwise -> id -- don't colourise unknown names

1078consoleDecorate ist (AnnFC _) = id

1072consoleDecorate ist (AnnFC _) = id

1079consoleDecorate ist (AnnTextFmt fmt) = Idris.Colours.colourise (colour fmt)

1073consoleDecorate ist (AnnTextFmt fmt) = Idris.Colours.colourise (colour fmt)

1080 where colour BoldText = IdrisColour Nothing True False True False

1074 where colour BoldText = IdrisColour Nothing True False True False

@@ -1114,10 +1108,9 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

1114 prettySe 10 ((n, False):bnd) sc

1108 prettySe 10 ((n, False):bnd) sc

1115 prettySe p bnd (PPi (Exp l s _) n ty sc)

1109 prettySe p bnd (PPi (Exp l s _) n ty sc)

1116 | n `elem` allNamesIn sc || impl || n `elem` docArgs =

1110 | n `elem` allNamesIn sc || impl || n `elem` docArgs =

1117− let open = if Lazy `elem` l then text "|" <> lparen else lparen in

1118− bracket p 2 . group $

1111+ bracket p 2 . group $

1119− enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

1112+ enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

1120− st <> text "->" <$> prettySe 10 ((n, False):bnd) sc

1113+ st <> text "->" <$> prettySe 10 ((n, False):bnd) sc

1121 | otherwise =

1114 | otherwise =

1122 bracket p 2 . group $

1115 bracket p 2 . group $

1123 group (prettySe 0 bnd ty <+> st) <> text "->" <$> group (prettySe 10 ((n, False):bnd) sc)

1116 group (prettySe 0 bnd ty <+> st) <> text "->" <$> group (prettySe 10 ((n, False):bnd) sc)

@@ -1128,10 +1121,9 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

1128 _ -> empty

1121 _ -> empty

1129 prettySe p bnd (PPi (Imp l s _) n ty sc)

1122 prettySe p bnd (PPi (Imp l s _) n ty sc)

1130 | impl =

1123 | impl =

1131− let open = if Lazy `elem` l then text "|" <> lbrace else lbrace in

1132− bracket p 2 $

1124+ bracket p 2 $

1133− open <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>

1125+ lparen <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>

1134− st <> text "->" </> prettySe 10 ((n, True):bnd) sc

1126+ st <> text "->" </> prettySe 10 ((n, True):bnd) sc

1135 | otherwise = prettySe 10 ((n, True):bnd) sc

1127 | otherwise = prettySe 10 ((n, True):bnd) sc

1136 where

1128 where

1137 st =

1129 st =

@@ -1189,16 +1181,16 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

1189

1181

1190 sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r

1182 sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r

1191 prettySe p bnd (PHidden tm) = text "." <> prettySe 0 bnd tm

1183 prettySe p bnd (PHidden tm) = text "." <> prettySe 0 bnd tm

1192− prettySe p bnd (PRefl _ _) = annotate (AnnName eqCon Nothing Nothing) $ text "refl"

1184+ prettySe p bnd (PRefl _ _) = annName eqCon $ text "refl"

1193 prettySe p bnd (PResolveTC _) = text "resolvetc"

1185 prettySe p bnd (PResolveTC _) = text "resolvetc"

1194− prettySe p bnd (PTrue _ IsType) = annotate (AnnName unitTy Nothing Nothing) $ text "()"

1186+ prettySe p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1195− prettySe p bnd (PTrue _ IsTerm) = annotate (AnnName unitCon Nothing Nothing) $ text "()"

1187+ prettySe p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

1196 prettySe p bnd (PTrue _ TypeOrTerm) = text "()"

1188 prettySe p bnd (PTrue _ TypeOrTerm) = text "()"

1197− prettySe p bnd (PFalse _) = annotate (AnnName falseTy Nothing Nothing) $ text "_|_"

1189+ prettySe p bnd (PFalse _) = annName falseTy $ text "_|_"

1198 prettySe p bnd (PEq _ l r) =

1190 prettySe p bnd (PEq _ l r) =

1199 bracket p 2 . align . group $

1191 bracket p 2 . align . group $

1200 prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r)

1192 prettySe 10 bnd l <+> eq <$> group (prettySe 10 bnd r)

1201− where eq = annotate (AnnName eqTy Nothing Nothing) (text "=")

1193+ where eq = annName eqTy (text "=")

1202 prettySe p bnd (PRewrite _ l r _) =

1194 prettySe p bnd (PRewrite _ l r _) =

1203 bracket p 2 $

1195 bracket p 2 $

1204 text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r

1196 text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r

@@ -1210,28 +1202,28 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

1210 map (prettySe 10 bnd) elts

1202 map (prettySe 10 bnd) elts

1211 where ann = case pun of

1203 where ann = case pun of

1212 TypeOrTerm -> id

1204 TypeOrTerm -> id

1213− IsType -> annotate (AnnName pairTy Nothing Nothing)

1205+ IsType -> annName pairTy

1214− IsTerm -> annotate (AnnName pairCon Nothing Nothing)

1206+ IsTerm -> annName pairCon

1215 prettySe p bnd (PDPair _ TypeOrTerm l t r) =

1207 prettySe p bnd (PDPair _ TypeOrTerm l t r) =

1216 lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen

1208 lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen

1217 prettySe p bnd (PDPair _ IsType (PRef _ n) t r) =

1209 prettySe p bnd (PDPair _ IsType (PRef _ n) t r) =

1218− annotate (AnnName sigmaTy Nothing Nothing) lparen <>

1210+ annName sigmaTy lparen <>

1219 bindingOf n False <+>

1211 bindingOf n False <+>

1220− annotate (AnnName sigmaTy Nothing Nothing) (text "**") <+>

1212+ annName sigmaTy (text "**") <+>

1221 prettySe 10 ((n, False):bnd) r <>

1213 prettySe 10 ((n, False):bnd) r <>

1222− annotate (AnnName sigmaTy Nothing Nothing) rparen

1214+ annName sigmaTy rparen

1223 prettySe p bnd (PDPair _ IsType l t r) =

1215 prettySe p bnd (PDPair _ IsType l t r) =

1224− annotate (AnnName sigmaTy Nothing Nothing) lparen <>

1216+ annName sigmaTy lparen <>

1225 prettySe 10 bnd l <+>

1217 prettySe 10 bnd l <+>

1226− annotate (AnnName sigmaTy Nothing Nothing) (text "**") <+>

1218+ annName sigmaTy (text "**") <+>

1227 prettySe 10 bnd r <>

1219 prettySe 10 bnd r <>

1228− annotate (AnnName sigmaTy Nothing Nothing) rparen

1220+ annName sigmaTy rparen

1229 prettySe p bnd (PDPair _ IsTerm l t r) =

1221 prettySe p bnd (PDPair _ IsTerm l t r) =

1230− annotate (AnnName existsCon Nothing Nothing) lparen <>

1222+ annName existsCon lparen <>

1231 prettySe 10 bnd l <+>

1223 prettySe 10 bnd l <+>

1232− annotate (AnnName existsCon Nothing Nothing) (text "**") <+>

1224+ annName existsCon (text "**") <+>

1233 prettySe 10 bnd r <>

1225 prettySe 10 bnd r <>

1234− annotate (AnnName existsCon Nothing Nothing) rparen

1226+ annName existsCon rparen

1235 prettySe p bnd (PAlternative a as) =

1227 prettySe p bnd (PAlternative a as) =

1236 lparen <> text "|" <> prettyAs <> text "|" <> rparen

1228 lparen <> text "|" <> prettyAs <> text "|" <> rparen

1237 where

1229 where

@@ -1259,8 +1251,8 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

1259 prettySe p bnd _ = text "test"

1251 prettySe p bnd _ = text "test"

1260

1252

1261 prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)

1253 prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)

1262− prettyArgS bnd (PExp _ _ tm) = prettyArgSe bnd tm

1254+ prettyArgS bnd (PExp _ _ _ tm) = prettyArgSe bnd tm

1263− prettyArgS bnd (PConstraint _ _ tm) = prettyArgSc bnd tm

1255+ prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm

1264 prettyArgS bnd (PTacImplicit _ _ n _ tm) = prettyArgSti bnd (n, tm)

1256 prettyArgS bnd (PTacImplicit _ _ n _ tm) = prettyArgSti bnd (n, tm)

1265

1257

1266 prettyArgSe bnd arg = prettySe 0 bnd arg

1258 prettyArgSe bnd arg = prettySe 0 bnd arg

@@ -1268,6 +1260,9 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

1268 prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace

1260 prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace

1269 prettyArgSti bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1261 prettyArgSti bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

1270

1262

1263+ annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

1264+ annName n = annotate (AnnName n Nothing Nothing Nothing)

1265+

1271 basename :: Name -> Name

1266 basename :: Name -> Name

1272 basename (NS n _) = basename n

1267 basename (NS n _) = basename n

1273 basename n = n

1268 basename n = n

@@ -1333,7 +1328,7 @@ prettyName :: Bool -- ^^ whether to show namespaces

1333 -> Name -- ^^ the name to pprint

1328 -> Name -- ^^ the name to pprint

1334 -> Doc OutputAnnotation

1329 -> Doc OutputAnnotation

1335prettyName showNS bnd n | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) (text (strName n))

1330prettyName showNS bnd n | Just imp <- lookup n bnd = annotate (AnnBoundName n imp) (text (strName n))

1336− | otherwise = annotate (AnnName n Nothing Nothing) (text (strName n))

1331+ | otherwise = annotate (AnnName n Nothing Nothing Nothing) (text (strName n))

1337 where strName (UN n) = T.unpack n

1332 where strName (UN n) = T.unpack n

1338 strName (NS n ns) | showNS = (concatMap (++ ".") . map T.unpack . reverse) ns ++ strName n

1333 strName (NS n ns) | showNS = (concatMap (++ ".") . map T.unpack . reverse) ns ++ strName n

1339 | otherwise = strName n

1334 | otherwise = strName n

@@ -1389,12 +1384,12 @@ getImps (_ : xs) = getImps xs

1389

1384

1390getExps :: [PArg] -> [PTerm]

1385getExps :: [PArg] -> [PTerm]

1391getExps [] = []

1386getExps [] = []

1392−getExps (PExp _ _ tm : xs) = tm : getExps xs

1387+getExps (PExp _ _ _ tm : xs) = tm : getExps xs

1393getExps (_ : xs) = getExps xs

1388getExps (_ : xs) = getExps xs

1394

1389

1395getConsts :: [PArg] -> [PTerm]

1390getConsts :: [PArg] -> [PTerm]

1396getConsts [] = []

1391getConsts [] = []

1397−getConsts (PConstraint _ _ tm : xs) = tm : getConsts xs

1392+getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

1398getConsts (_ : xs) = getConsts xs

1393getConsts (_ : xs) = getConsts xs

1399

1394

1400getAll :: [PArg] -> [PTerm]

1395getAll :: [PArg] -> [PTerm]

@@ -1433,7 +1428,9 @@ showName ist bnd impl colour n = case ist of

1433showTm :: IState -- ^^ the Idris state, for information about identifiers and colours

1428showTm :: IState -- ^^ the Idris state, for information about identifiers and colours

1434 -> PTerm -- ^^ the term to show

1429 -> PTerm -- ^^ the term to show

1435 -> String

1430 -> String

1436−showTm ist = displayDecorated (consoleDecorate ist) . renderCompact . prettyImp (opt_showimp (idris_options ist))

1431+showTm ist = displayDecorated (consoleDecorate ist) .

1432+ renderPretty 0.8 100000 .

1433+ prettyImp (opt_showimp (idris_options ist))

1437

1434

1438-- | Show a term with implicits, no colours

1435-- | Show a term with implicits, no colours

1439showTmImpls :: PTerm -> String

1436showTmImpls :: PTerm -> String

@@ -1482,7 +1479,7 @@ getPArity _ = 0

1482

1479

1483allNamesIn :: PTerm -> [Name]

1480allNamesIn :: PTerm -> [Name]

1484allNamesIn tm = nub $ ni [] tm

1481allNamesIn tm = nub $ ni [] tm

1485− where

1482+ where -- TODO THINK added niTacImp, but is it right?

1486 ni env (PRef _ n)

1483 ni env (PRef _ n)

1487 | not (n `elem` env) = [n]

1484 | not (n `elem` env) = [n]

1488 ni env (PPatvar _ n) = [n]

1485 ni env (PPatvar _ n) = [n]

@@ -1490,7 +1487,7 @@ allNamesIn tm = nub $ ni [] tm

1490 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1487 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1491 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1488 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1492 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1489 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1493− ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc

1490+ ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

1494 ni env (PHidden tm) = ni env tm

1491 ni env (PHidden tm) = ni env tm

1495 ni env (PEq _ l r) = ni env l ++ ni env r

1492 ni env (PEq _ l r) = ni env l ++ ni env r

1496 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1493 ni env (PRewrite _ l r _) = ni env l ++ ni env r

@@ -1504,16 +1501,19 @@ allNamesIn tm = nub $ ni [] tm

1504 ni env (PNoImplicits tm) = ni env tm

1501 ni env (PNoImplicits tm) = ni env tm

1505 ni env _ = []

1502 ni env _ = []

1506

1503

1504+ niTacImp env (TacImp _ _ scr) = ni env scr

1505+ niTacImp _ _ = []

1506+

1507-- Return all names defined in binders in the given term

1508boundNamesIn :: PTerm -> [Name]

1509boundNamesIn tm = nub $ ni tm

1510− where

1510+ where -- TODO THINK Added niTacImp, but is it right?

1511 ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as)

1512 ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as)

1513 ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os)

1514 ni (PLam n ty sc) = n : (ni ty ++ ni sc)

1515 ni (PLet n ty val sc) = n : (ni ty ++ ni val ++ ni sc)

1516− ni (PPi _ n ty sc) = n : (ni ty ++ ni sc)

1516+ ni (PPi p n ty sc) = niTacImp p ++ (n : (ni ty ++ ni sc))

1517 ni (PEq _ l r) = ni l ++ ni r

1518 ni (PRewrite _ l r _) = ni l ++ ni r

1519 ni (PTyped l r) = ni l ++ ni r

@@ -1527,6 +1527,9 @@ boundNamesIn tm = nub $ ni tm

1527 ni (PNoImplicits tm) = ni tm

1528 ni _ = []

1529

1530+ niTacImp (TacImp _ _ scr) = ni scr

1531+ niTacImp _ = []

1532+

1530-- Return names which are free in the given term.

1533-- Return names which are free in the given term.

1531namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

1534namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

1532namesIn uvars ist tm = nub $ ni [] tm

1535namesIn uvars ist tm = nub $ ni [] tm

@@ -1540,7 +1543,7 @@ namesIn uvars ist tm = nub $ ni [] tm

1540 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1543 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1541 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1544 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1542 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1545 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1543− ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc

1546+ ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

1544 ni env (PEq _ l r) = ni env l ++ ni env r

1547 ni env (PEq _ l r) = ni env l ++ ni env r

1545 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1548 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1546 ni env (PTyped l r) = ni env l ++ ni env r

1549 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1554,11 +1557,14 @@ namesIn uvars ist tm = nub $ ni [] tm

1554 ni env (PNoImplicits tm) = ni env tm

1557 ni env (PNoImplicits tm) = ni env tm

1555 ni env _ = []

1558 ni env _ = []

1556

1559

1560+ niTacImp env (TacImp _ _ scr) = ni env scr

1561+ niTacImp _ _ = []

1562+

1557-- Return which of the given names are used in the given term.

1563-- Return which of the given names are used in the given term.

1558

1564

1559usedNamesIn :: [Name] -> IState -> PTerm -> [Name]

1565usedNamesIn :: [Name] -> IState -> PTerm -> [Name]

1560usedNamesIn vars ist tm = nub $ ni [] tm

1566usedNamesIn vars ist tm = nub $ ni [] tm

1561− where

1567+ where -- TODO THINK added niTacImp, but is it right?

1562 ni env (PRef _ n)

1568 ni env (PRef _ n)

1563 | n `elem` vars && not (n `elem` env)

1569 | n `elem` vars && not (n `elem` env)

1564 = case lookupTy n (tt_ctxt ist) of

1570 = case lookupTy n (tt_ctxt ist) of

@@ -1568,7 +1574,7 @@ usedNamesIn vars ist tm = nub $ ni [] tm

1568 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1574 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

1569 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1575 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

1570 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1576 ni env (PLam n ty sc) = ni env ty ++ ni (n:env) sc

1571− ni env (PPi _ n ty sc) = ni env ty ++ ni (n:env) sc

1577+ ni env (PPi p n ty sc) = niTacImp env p ++ ni env ty ++ ni (n:env) sc

1572 ni env (PEq _ l r) = ni env l ++ ni env r

1578 ni env (PEq _ l r) = ni env l ++ ni env r

1573 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1579 ni env (PRewrite _ l r _) = ni env l ++ ni env r

1574 ni env (PTyped l r) = ni env l ++ ni env r

1580 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1582,3 +1588,6 @@ usedNamesIn vars ist tm = nub $ ni [] tm

1582 ni env (PNoImplicits tm) = ni env tm

1588 ni env (PNoImplicits tm) = ni env tm

1583 ni env _ = []

1589 ni env _ = []

1584

1590

1591+ niTacImp env (TacImp _ _ scr) = ni env scr

1592+ niTacImp _ _ = []

1593+

src/Idris/CaseSplit.hs+1

@@ -14,6 +14,7 @@ import Idris.ElabTerm

14import Idris.Delaborate

15import Idris.Parser

16import Idris.Error

17+import Idris.Output

17

18

18import Idris.Core.TT

19import Idris.Core.TT

19import Idris.Core.Typecheck

20import Idris.Core.Typecheck

src/Idris/Core/CaseTree.hs+168−105

@@ -2,7 +2,8 @@

2

3module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..),

4 Phase(..), CaseTree,

5− simpleCase, small, namesUsed, findCalls, findUsedArgs) where

5+ simpleCase, small, namesUsed, findCalls, findUsedArgs,

6+ substSC, substAlt, mkForce) where

6

7

7import Idris.Core.TT

8import Idris.Core.TT

8

9

@@ -14,8 +15,20 @@ import Debug.Trace

14data CaseDef = CaseDef [Name] !SC [Term]

15data CaseDef = CaseDef [Name] !SC [Term]

15 deriving Show

16 deriving Show

16

17

18+-- Note: The case-tree elaborator only produces (Case n alts)-cases;

19+-- in other words, it never inspects anything else than variables.

20+--

21+-- ProjCase is a special powerful case construct that allows inspection

22+-- of compound terms. Occurrences of ProjCase arise no earlier than

23+-- in the function `prune` as a means of optimisation

24+-- of already built case trees.

25+--

26+-- While the intermediate representation (follows in the pipeline)

27+-- allows casing on arbitrary terms, here we choose to maintain the distinction

28+-- in order to allow for better optimisation opportunities.

29+--

17−data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

30+data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

18− | ProjCase t [CaseAlt' t] -- ^ special case for projections

31+ | ProjCase t [CaseAlt' t] -- ^ special case for projections/thunk-forcing before inspection

19 | STerm !t

32 | STerm !t

20 | UnmatchedCase String -- ^ error message

33 | UnmatchedCase String -- ^ error message

21 | ImpossibleCase -- ^ already checked to be impossible

34 | ImpossibleCase -- ^ already checked to be impossible

@@ -96,8 +109,7 @@ small n args t = let as = findAllUsedArgs t args in

96namesUsed :: SC -> [Name]

109namesUsed :: SC -> [Name]

97namesUsed sc = nub $ nu' [] sc where

110namesUsed sc = nub $ nu' [] sc where

98 nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n]

111 nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n]

99− nu' ps (ProjCase t alts) = nub $ (nut ps t ++

112+ nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts

100− (concatMap (nua ps) alts))

101 nu' ps (STerm t) = nub $ nut ps t

113 nu' ps (STerm t) = nub $ nut ps t

102 nu' ps _ = []

114 nu' ps _ = []

103

115

@@ -122,7 +134,7 @@ namesUsed sc = nub $ nu' [] sc where

122findCalls :: SC -> [Name] -> [(Name, [[Name]])]

134findCalls :: SC -> [Name] -> [(Name, [[Name]])]

123findCalls sc topargs = nub $ nu' topargs sc where

135findCalls sc topargs = nub $ nu' topargs sc where

124 nu' ps (Case n alts) = nub (concatMap (nua (n : ps)) alts)

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

137+ nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts

126 nu' ps (STerm t) = nub $ nut ps t

138 nu' ps (STerm t) = nub $ nut ps t

127 nu' ps _ = []

139 nu' ps _ = []

128

140

@@ -185,6 +197,22 @@ findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where

185 nua (SucCase _ sc) = nu' sc

197 nua (SucCase _ sc) = nu' sc

186 nua (DefaultCase sc) = nu' sc

198 nua (DefaultCase sc) = nu' sc

187

199

200+-- Return whether name is used anywhere in a case tree

201+isUsed :: SC -> Name -> Bool

202+isUsed sc n = used sc where

203+

204+ used (Case n' alts) = n == n' || or (map usedA alts)

205+ used (ProjCase t alts) = n `elem` freeNames t || or (map usedA alts)

206+ used (STerm t) = n `elem` freeNames t

207+ used _ = False

208+

209+ usedA (ConCase _ _ args sc) = used sc

210+ usedA (FnCase _ args sc) = used sc

211+ usedA (ConstCase _ sc) = used sc

212+ usedA (SucCase _ sc) = used sc

213+ usedA (DefaultCase sc) = used sc

214+

215+

188data Phase = CompileTime | RunTime

216data Phase = CompileTime | RunTime

189 deriving (Show, Eq)

217 deriving (Show, Eq)

190

218

@@ -192,10 +220,10 @@ data Phase = CompileTime | RunTime

192-- Work Right to Left

220-- Work Right to Left

193

221

194simpleCase :: Bool -> Bool -> Bool ->

222simpleCase :: Bool -> Bool -> Bool ->

195− Phase -> FC -> [Type] ->

223+ Phase -> FC -> [Int] -> [Type] ->

196 [([Name], Term, Term)] ->

224 [([Name], Term, Term)] ->

197 TC CaseDef

225 TC CaseDef

198−simpleCase tc cover reflect phase fc argtys cs

226+simpleCase tc cover reflect phase fc inacc argtys cs

199 = sc' tc cover phase fc (filter (\(_, _, r) ->

227 = sc' tc cover phase fc (filter (\(_, _, r) ->

200 case r of

228 case r of

201 Impossible -> False

229 Impossible -> False

@@ -213,7 +241,7 @@ simpleCase tc cover reflect phase fc argtys cs

213 OK pats ->

241 OK pats ->

214 let numargs = length (fst (head pats))

242 let numargs = length (fst (head pats))

215 ns = take numargs args

243 ns = take numargs args

216− (ns', ps') = order ns pats

244+ (ns', ps') = order [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats

217 (tree, st) = runState

245 (tree, st) = runState

218 (match ns' ps' (defaultCase cover))

246 (match ns' ps' (defaultCase cover))

219 ([], numargs, [])

247 ([], numargs, [])

@@ -382,21 +410,25 @@ partition xs = error $ "Partition " ++ show xs

382-- reorder the patterns so that the one with most distinct names

410-- reorder the patterns so that the one with most distinct names

383-- comes next. Take rightmost first, otherwise (i.e. pick value rather

411-- comes next. Take rightmost first, otherwise (i.e. pick value rather

384-- than dependency)

412-- than dependency)

385−

413+--

414+-- The first argument means [(Name, IsInaccessible)].

415+

386−order :: [Name] -> [Clause] -> ([Name], [Clause])

416+order :: [(Name, Bool)] -> [Clause] -> ([Name], [Clause])

387−order [] cs = ([], cs)

417+order [] cs = ([], cs)

388−order ns [] = (ns, [])

418+order ns' [] = (map fst ns', [])

389−order ns cs = let patnames = transpose (map (zip ns) (map fst cs))

419+order ns' cs = let patnames = transpose (map (zip ns') (map fst cs))

420+ -- note: sortBy . reverse is not nonsense because sortBy is stable

390− pats' = transpose (sortBy moreDistinct (reverse patnames)) in

421+ pats' = transpose (sortBy moreDistinct (reverse patnames)) in

391− (getNOrder pats', zipWith rebuild pats' cs)

422+ (getNOrder pats', zipWith rebuild pats' cs)

392 where

423 where

393− getNOrder [] = error $ "Failed order on " ++ show (ns, cs)

424+ getNOrder [] = error $ "Failed order on " ++ show (map fst ns', cs)

394− getNOrder (c : _) = map fst c

425+ getNOrder (c : _) = map (fst . fst) c

395

426

396 rebuild patnames clause = (map snd patnames, snd clause)

427 rebuild patnames clause = (map snd patnames, snd clause)

397

428

429+ -- this compares (+isInaccessible, -numberOfCases)

398− moreDistinct xs ys = compare (numNames [] (map snd ys))

430+ moreDistinct xs ys = compare (snd . fst . head $ xs, numNames [] (map snd ys))

399− (numNames [] (map snd xs))

431+ (snd . fst . head $ ys, numNames [] (map snd xs))

400

432

401 numNames xs (PCon n _ _ : ps)

433 numNames xs (PCon n _ _ : ps)

402 | not (Left n `elem` xs) = numNames (Left n : xs) ps

434 | not (Left n `elem` xs) = numNames (Left n : xs) ps

@@ -576,91 +608,79 @@ depatt ns tm = dp [] tm

576-- FIXME: Do this for SucCase too

608-- FIXME: Do this for SucCase too

577prune :: Bool -- ^ Convert single branches to projections (only useful at runtime)

609prune :: Bool -- ^ Convert single branches to projections (only useful at runtime)

578 -> SC -> SC

610 -> SC -> SC

579−prune proj (Case n alts)

611+prune proj (Case n alts) = case alts' of

580− = let alts' = filter notErased (map pruneAlt alts) in

612+ [] -> ImpossibleCase

581− case alts' of

613+

582− [] -> ImpossibleCase

614+ -- Projection transformations prevent us from seeing some uses of ctor fields

583− as@(ConCase (UN delay) i [arg] sc : _)

615+ -- because they delete information about which ctor is being used.

584− | delay == txt "Delay"

616+ -- Consider:

585− -> if proj then mkForce n arg sc

617+ -- f (X x) = ... x ...

586− else Case n as

618+ -- vs.

619+ -- f x = ... x!0 ...

620+ --

621+ -- Hence, we disable this step.

622+ -- TODO: re-enable this in toIR

623+ --

624+ -- as@[ConCase cn i args sc]

625+ -- | proj -> mkProj n 0 args (prune proj sc)

626+ -- mkProj n i xs sc = foldr (\x -> projRep x n i) sc xs

627+

628+ -- If none of the args are used in the sc, however, we can just replace it

629+ -- with sc

630+ as@[ConCase cn i args sc]

631+ | proj -> let sc' = prune proj sc in

632+ if any (isUsed sc') args

587− as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc

633+ then Case n [ConCase cn i args sc']

588− else Case n as

634+ else sc'

635+

589− as@[SucCase cn sc] -> if proj then mkProj n (-1) [cn] sc

636+ [SucCase cn sc]

590− else Case n as

637+ | proj

638+ -> projRep cn n (-1) $ prune proj sc

639+

591− as@[ConstCase _ sc] -> prune proj sc

640+ [ConstCase _ sc]

641+ -> prune proj sc

642+

592− -- Bit of a hack here! The default case will always be 0, make sure

643+ -- Bit of a hack here! The default case will always be 0, make sure

593− -- it gets caught first.

644+ -- it gets caught first.

594− [s@(SucCase _ _), DefaultCase dc]

645+ [s@(SucCase _ _), DefaultCase dc]

595− -> Case n [ConstCase (BI 0) dc, s]

646+ -> Case n [ConstCase (BI 0) dc, s]

647+

596− as -> Case n as

648+ as -> Case n as

649+ where

650+ alts' = filter (not . erased) $ map pruneAlt alts

651+

597− where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)

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

653+ pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)

599− pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

654+ pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

600− pruneAlt (SucCase n sc) = SucCase n (prune proj sc)

655+ pruneAlt (SucCase n sc) = SucCase n (prune proj sc)

601− pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

656+ pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

602−

657+

603− notErased (DefaultCase (STerm Erased)) = False

658+ erased (DefaultCase (STerm Erased)) = True

604− notErased (DefaultCase ImpossibleCase) = False

659+ erased (DefaultCase ImpossibleCase) = True

605− notErased _ = True

660+ erased _ = False

606−

661+

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 (App (P Ref (sUN "Force") Erased) 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

662+ projRep :: Name -> Name -> Int -> SC -> SC

643− projRep arg n i (Case x alts)

663+ projRep arg n i (Case x alts) | x == arg

644− | x == arg = ProjCase (Proj (P Bound n Erased) i)

664+ = ProjCase (Proj (P Bound n Erased) i) $ map (projRepAlt arg n i) alts

645− (map (projRepAlt arg n i) alts)

665+ projRep arg n i (Case x alts)

646− | otherwise = Case x (map (projRepAlt arg n i) alts)

666+ = Case x (map (projRepAlt arg n i) alts)

647− projRep arg n i (ProjCase t alts)

667+ projRep arg n i (ProjCase t alts)

648− = ProjCase (projRepTm arg n i t) (map (projRepAlt arg n i) alts)

668+ = 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)

669+ projRep arg n i (STerm t) = STerm (projRepTm arg n i t)

650− projRep arg n i c = c -- unmatched

670+ projRep arg n i c = c

651−

671+

652− projRepAlt arg n i (ConCase cn t args rhs)

672+ projRepAlt arg n i (ConCase cn t args rhs)

653− = ConCase cn t args (projRep arg n i rhs)

673+ = ConCase cn t args (projRep arg n i rhs)

654− projRepAlt arg n i (FnCase cn args rhs)

674+ projRepAlt arg n i (FnCase cn args rhs)

655− = FnCase cn args (projRep arg n i rhs)

675+ = FnCase cn args (projRep arg n i rhs)

656− projRepAlt arg n i (ConstCase t rhs)

676+ projRepAlt arg n i (ConstCase t rhs)

657− = ConstCase t (projRep arg n i rhs)

677+ = ConstCase t (projRep arg n i rhs)

658− projRepAlt arg n i (SucCase sn rhs)

678+ projRepAlt arg n i (SucCase sn rhs)

659− = SucCase sn (projRep arg n i rhs)

679+ = SucCase sn (projRep arg n i rhs)

660− projRepAlt arg n i (DefaultCase rhs)

680+ projRepAlt arg n i (DefaultCase rhs)

661− = DefaultCase (projRep arg n i rhs)

681+ = DefaultCase (projRep arg n i rhs)

662−

682+

663− projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

683+ projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

664

684

665prune _ t = t

685prune _ t = t

666

686

@@ -669,6 +689,49 @@ stripLambdas (CaseDef ns (STerm (Bind x (Lam _) sc)) tm)

669 = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm)

689 = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm)

670stripLambdas x = x

690stripLambdas x = x

671

691

692+substSC :: Name -> Name -> SC -> SC

693+substSC n repl (Case n' alts)

694+ | n == n' = Case repl (map (substAlt n repl) alts)

695+ | otherwise = Case n' (map (substAlt n repl) alts)

696+substSC n repl (STerm t) = STerm $ subst n (P Bound repl Erased) t

697+substSC n repl sc = error $ "unsupported in substSC: " ++ show sc

698+

699+substAlt :: Name -> Name -> CaseAlt -> CaseAlt

700+substAlt n repl (ConCase cn a ns sc) = ConCase cn a ns (substSC n repl sc)

701+substAlt n repl (FnCase fn ns sc) = FnCase fn ns (substSC n repl sc)

702+substAlt n repl (ConstCase c sc) = ConstCase c (substSC n repl sc)

703+substAlt n repl (SucCase n' sc)

704+ | n == n' = SucCase n (substSC n repl sc)

705+ | otherwise = SucCase n' (substSC n repl sc)

706+substAlt n repl (DefaultCase sc) = DefaultCase (substSC n repl sc)

707+

708+mkForce :: Name -> Name -> SC -> SC

709+mkForce = mkForceSC

710+ where

711+ mkForceSC n arg (Case x alts) | x == arg

712+ = ProjCase (forceArg n) $ map (mkForceAlt n arg) alts

713+

714+ mkForceSC n arg (Case x alts)

715+ = Case x (map (mkForceAlt n arg) alts)

716+

717+ mkForceSC n arg (ProjCase t alts)

718+ = ProjCase (forceTm n arg t) $ map (mkForceAlt n arg) alts

719+

720+ mkForceSC n arg (STerm t) = STerm (forceTm n arg t)

721+ mkForceSC n arg c = c

672

722

723+ mkForceAlt n arg (ConCase cn t args rhs)

724+ = ConCase cn t args (mkForceSC n arg rhs)

725+ mkForceAlt n arg (FnCase cn args rhs)

726+ = FnCase cn args (mkForceSC n arg rhs)

727+ mkForceAlt n arg (ConstCase t rhs)

728+ = ConstCase t (mkForceSC n arg rhs)

729+ mkForceAlt n arg (SucCase sn rhs)

730+ = SucCase sn (mkForceSC n arg rhs)

731+ mkForceAlt n arg (DefaultCase rhs)

732+ = DefaultCase (mkForceSC n arg rhs)

673

733

734+ forceTm n arg t = subst arg (forceArg n) t

674

735

736+ forceArg n = App (App (App (P Ref (sUN "Force") Erased) Erased) Erased)

737+ (P Bound n Erased)

src/Idris/Core/Evaluate.hs+14−9

@@ -8,12 +8,13 @@ module Idris.Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,

8 Context, initContext, ctxtAlist, uconstraints, next_tvar,

9 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,

10 addDatatype, addCasedef, simplifyCasedef, addOperator,

11− lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal,

11+ lookupNames, lookupTy, lookupP, lookupDef, lookupDefExact, lookupDefAcc, lookupVal,

12 mapDefCtxt,

13 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

14− Value(..), Quote(..), initEval, uniqueNameCtxt) where

14+ Value(..), Quote(..), initEval, uniqueNameCtxt, definitions) where

15

16import Debug.Trace

17+import Control.Applicative hiding (Const)

17import Control.Monad.State -- not Strict!

18import Control.Monad.State -- not Strict!

18import qualified Data.Binary as B

19import qualified Data.Binary as B

19import Data.Binary hiding (get, put)

20import Data.Binary hiding (get, put)

@@ -784,6 +785,7 @@ addDatatype (Data n tag ty cons) uctxt

784-- FIXME: Too many arguments! Refactor all these Bools.

785-- FIXME: Too many arguments! Refactor all these Bools.

785addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

786addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

786 [Type] -> -- argument types

787 [Type] -> -- argument types

788+ [Int] -> -- inaccessible arguments

787 [Either Term (Term, Term)] ->

789 [Either Term (Term, Term)] ->

788 [([Name], Term, Term)] -> -- totality

790 [([Name], Term, Term)] -> -- totality

789 [([Name], Term, Term)] -> -- compile time

791 [([Name], Term, Term)] -> -- compile time

@@ -791,16 +793,16 @@ addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

791 [([Name], Term, Term)] -> -- run time

793 [([Name], Term, Term)] -> -- run time

792 Type -> Context -> Context

794 Type -> Context -> Context

793addCasedef n ci@(CaseInfo alwaysInline tcdict)

795addCasedef n ci@(CaseInfo alwaysInline tcdict)

794− tcase covering reflect asserted argtys

796+ tcase covering reflect asserted argtys inacc

795 ps_in ps_tot ps_inl ps_ct ps_rt ty uctxt

797 ps_in ps_tot ps_inl ps_ct ps_rt ty uctxt

796 = let ctxt = definitions uctxt

798 = let ctxt = definitions uctxt

797 access = case lookupDefAcc n False uctxt of

799 access = case lookupDefAcc n False uctxt of

798 [(_, acc)] -> acc

800 [(_, acc)] -> acc

799 _ -> Public

801 _ -> Public

800− ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC argtys ps_tot,

802+ ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_tot,

801− simpleCase tcase covering reflect CompileTime emptyFC argtys ps_ct,

803+ simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_ct,

802− simpleCase tcase covering reflect CompileTime emptyFC argtys ps_inl,

804+ simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_inl,

803− simpleCase tcase covering reflect RunTime emptyFC argtys ps_rt) of

805+ simpleCase tcase covering reflect RunTime emptyFC inacc argtys ps_rt) of

804 (OK (CaseDef args_tot sc_tot _),

806 (OK (CaseDef args_tot sc_tot _),

805 OK (CaseDef args_ct sc_ct _),

807 OK (CaseDef args_ct sc_ct _),

806 OK (CaseDef args_inl sc_inl _),

808 OK (CaseDef args_inl sc_inl _),

@@ -827,7 +829,7 @@ simplifyCasedef n uctxt

827 [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] ->

829 [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] ->

828 let ps_in' = map simpl ps_in

830 let ps_in' = map simpl ps_in

829 pdef = map debind ps_in' in

831 pdef = map debind ps_in' in

830− case simpleCase False True False CompileTime emptyFC atys pdef of

832+ case simpleCase False True False CompileTime emptyFC [] atys pdef of

831 OK (CaseDef args sc _) ->

833 OK (CaseDef args sc _) ->

832 addDef n (CaseOp ci

834 addDef n (CaseOp ci

833 ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }),

835 ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }),

@@ -908,8 +910,11 @@ lookupP n ctxt

908 Hidden -> []

910 Hidden -> []

909 _ -> return (fst p)

911 _ -> return (fst p)

910

912

913+lookupDefExact :: Name -> Context -> Maybe Def

914+lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)

915+

911lookupDef :: Name -> Context -> [Def]

916lookupDef :: Name -> Context -> [Def]

912−lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt)

917+lookupDef n ctxt = tfst <$> lookupCtxt n (definitions ctxt)

913

918

914lookupDefAcc :: Name -> Bool -> Context ->

919lookupDefAcc :: Name -> Bool -> Context ->

915 [(Def, Accessibility)]

920 [(Def, Accessibility)]

src/Idris/Core/Execute.hs+96−135

@@ -47,11 +47,8 @@ readMay s = case reads s of

47

48data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show

49

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

50+newtype ExecState = ExecState { exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad

54− }

51+ }

55

52

56data ExecVal = EP NameType Name ExecVal

53data ExecVal = EP NameType Name ExecVal

57 | EV Int

54 | EV Int

@@ -61,20 +58,20 @@ data ExecVal = EP NameType Name ExecVal

61 | EErased

58 | EErased

62 | EConstant Const

59 | EConstant Const

63 | forall a. EPtr (Ptr a)

60 | forall a. EPtr (Ptr a)

64− | EThunk Int

61+ | EThunk Context ExecEnv Term

65 | EHandle Handle

62 | EHandle Handle

66

63

67instance Show ExecVal where

64instance Show ExecVal where

68− show (EP _ n _) = show n

65+ show (EP _ n _) = show n

69− show (EV i) = "!!V" ++ show i ++ "!!"

66+ show (EV i) = "!!V" ++ show i ++ "!!"

70− show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

67+ show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

71− show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

68+ show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

72− show (EType _) = "Type"

69+ show (EType _) = "Type"

73− show EErased = "[__]"

70+ show EErased = "[__]"

74− show (EConstant c) = show c

71+ show (EConstant c) = show c

75− show (EPtr p) = "<<ptr " ++ show p ++ ">>"

72+ show (EPtr p) = "<<ptr " ++ show p ++ ">>"

76− show (EThunk i) = "<<thunk " ++ show i ++ ">>"

73+ show (EThunk _ env tm) = "<<thunk " ++ show env ++ "||||" ++ show tm ++ ">>"

77− show (EHandle h) = "<<handle " ++ show h ++ ">>"

74+ show (EHandle h) = "<<handle " ++ show h ++ ">>"

78

75

79toTT :: ExecVal -> Exec Term

76toTT :: ExecVal -> Exec Term

80toTT (EP nt n ty) = (P nt n) <$> (toTT ty)

77toTT (EP nt n ty) = (P nt n) <$> (toTT ty)

@@ -82,22 +79,25 @@ toTT (EV i) = return $ V i

82toTT (EBind n b body) = do body' <- body $ EP Bound n EErased

79toTT (EBind n b body) = do body' <- body $ EP Bound n EErased

83 b' <- fixBinder b

80 b' <- fixBinder b

84 Bind n b' <$> toTT body'

81 Bind n b' <$> toTT body'

85− where fixBinder (Lam t) = Lam <$> toTT t

82+ where fixBinder (Lam t) = Lam <$> toTT t

86− fixBinder (Pi t) = Pi <$> toTT t

83+ fixBinder (Pi t) = Pi <$> toTT t

87− fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

84+ fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

88− fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

85+ fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

89− fixBinder (Hole t) = Hole <$> toTT t

86+ fixBinder (Hole t) = Hole <$> toTT t

90 fixBinder (GHole i t) = GHole i <$> toTT t

87 fixBinder (GHole i t) = GHole i <$> toTT t

91− fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2

88+ fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2

92− fixBinder (PVar t) = PVar <$> toTT t

89+ fixBinder (PVar t) = PVar <$> toTT t

93− fixBinder (PVTy t) = PVTy <$> toTT t

90+ fixBinder (PVTy t) = PVTy <$> toTT t

94toTT (EApp e1 e2) = do e1' <- toTT e1

91toTT (EApp e1 e2) = do e1' <- toTT e1

95 e2' <- toTT e2

92 e2' <- toTT e2

96 return $ App e1' e2'

93 return $ App e1' e2'

97toTT (EType u) = return $ TType u

94toTT (EType u) = return $ TType u

98toTT EErased = return Erased

95toTT EErased = return Erased

99toTT (EConstant c) = return (Constant c)

96toTT (EConstant c) = return (Constant c)

100−toTT (EThunk i) = return (P (DCon 0 0) (sMN i "THUNK") Erased) --(force i) >>= toTT

97+toTT (EThunk ctxt env tm) = do env' <- mapM toBinder env

98+ return $ normalise ctxt env' tm

99+ where toBinder (n, v) = do v' <- toTT v

100+ return (n, Let Erased v')

101toTT (EHandle _) = return Erased

102

103unApplyV :: ExecVal -> (ExecVal, [ExecVal])

@@ -111,7 +111,7 @@ mkEApp f (a:args) = mkEApp (EApp f a) args

111

112initState :: Idris ExecState

113initState = do ist <- getIState

114− return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)

114+ return $ ExecState (idris_dynamic_libs ist)

115

116type Exec = ErrorT String (StateT ExecState IO)

117

@@ -130,45 +130,13 @@ execFail = throwError

130execIO :: IO a -> Exec a

131execIO = lift . lift

132

133−delay :: ExecEnv -> Context -> Term -> Exec ExecVal

134−delay env ctxt tm =

135− do st <- getExecState

136− let i = exec_next_thunk st

137− putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)

138− , exec_next_thunk = exec_next_thunk st + 1

139− }

140− return $ EThunk i

141−

142−force :: Int -> Exec ExecVal

143−force i = do st <- getExecState

144− case M.lookup i (exec_thunks st) of

145− Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm

146− case tm' of

147− EThunk i ->

148− do res <- force i

149− update res i

150− return res

151− _ -> do update tm' i

152− return tm'

153− Just (Forced tm) -> return tm

154− Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"

155− where update :: ExecVal -> Int -> Exec ()

156− update tm i = do est <- getExecState

157− putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }

158−

159−tryForce :: ExecVal -> Exec ExecVal

160−tryForce (EThunk i) = force i

161−tryForce tm = return tm

162−

163−debugThunks :: Exec ()

164−debugThunks = do st <- getExecState

165− execIO $ putStrLn (take 4000 (show (exec_thunks st)))

166

133

167execute :: Term -> Idris Term

134execute :: Term -> Idris Term

168execute tm = do est <- initState

135execute tm = do est <- initState

169 ctxt <- getContext

136 ctxt <- getContext

170− res <- lift . lift $ flip runExec est $ do res <- doExec [] ctxt tm

137+ res <- lift . lift . flip runExec est $

138+ do res <- doExec [] ctxt tm

171− toTT res

139+ toTT res

172 case res of

140 case res of

173 Left err -> fail err

141 Left err -> fail err

174 Right tm' -> return tm'

142 Right tm' -> return tm'

@@ -208,7 +176,18 @@ doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined

208doExec env ctxt tm@(Bind n b body) = return $

176doExec env ctxt tm@(Bind n b body) = return $

209 EBind n (fmap (\_->EErased) b)

177 EBind n (fmap (\_->EErased) b)

210 (\arg -> doExec ((n, arg):env) ctxt body)

178 (\arg -> doExec ((n, arg):env) ctxt body)

211−doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)

179+doExec env ctxt a@(App _ _) =

180+ do let (f, args) = unApply a

181+ f' <- doExec env ctxt f

182+ args' <- case f' of

183+ (EP _ d _) | d == delay ->

184+ case args of

185+ [t,a,tm] -> do t' <- doExec env ctxt t

186+ a' <- doExec env ctxt a

187+ return [t', a', EThunk ctxt env tm]

188+ _ -> mapM (doExec env ctxt) args -- partial applications are fine to evaluate

189+ fun' -> do mapM (doExec env ctxt) args

190+ execApp env ctxt f' args'

212doExec env ctxt (Constant c) = return (EConstant c)

191doExec env ctxt (Constant c) = return (EConstant c)

213doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in

192doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in

214 doExec env ctxt ((x:xs) !! i)

193 doExec env ctxt ((x:xs) !! i)

@@ -216,55 +195,38 @@ doExec env ctxt Erased = return EErased

216doExec env ctxt Impossible = fail "Tried to execute an impossible case"

195doExec env ctxt Impossible = fail "Tried to execute an impossible case"

217doExec env ctxt (TType u) = return (EType u)

196doExec env ctxt (TType u) = return (EType u)

218

197

219−execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal

198+execApp :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

220−execApp env ctxt (f, args) = do newF <- doExec env ctxt f

221− laziness <- (++ repeat False) <$> (getLaziness newF)

222− newArgs <- mapM argExec (zip args laziness)

223− res <- execApp' env ctxt newF newArgs

224− return res

225− where getLaziness (EP _ l _) | l == sUN "lazy" = return [False, True]

226− getLaziness (EP _ n _) = do est <- getExecState

227− let argInfo = exec_implicits est

228− case lookupCtxtName n argInfo of

229− [] -> return (repeat False)

230− [ps] -> return $ map lazyarg (snd ps)

231− many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)

232− getLaziness _ = return (repeat False) -- ok due to zip above

233− argExec :: (Term, Bool) -> Exec ExecVal

234− argExec (tm, False) = doExec env ctxt tm

235− argExec (tm, True) = delay env ctxt tm

236−

237−

238−execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

239−execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls

199+execApp env ctxt v [] = return v -- no args is just a constant! can result from function calls

200+execApp env ctxt (EP _ f _) (t:a:delayed:rest)

201+ | f == force

202+ , (_, [_, _, EThunk tmCtxt tmEnv tm]) <- unApplyV delayed =

203+ do tm' <- doExec tmEnv tmCtxt tm

204+ execApp env ctxt tm' rest

240−execApp' env ctxt (EP _ fp _) (ty:action:rest)

205+execApp env ctxt (EP _ fp _) (ty:action:rest)

241 | fp == upio,

206 | fp == upio,

242 (prim__IO, [_, v]) <- unApplyV action

207 (prim__IO, [_, v]) <- unApplyV action

243− = execApp' env ctxt v rest

208+ = execApp env ctxt v rest

244

209

245−execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest)

210+execApp env ctxt (EP _ fp _) args@(_:_:v:k:rest)

246 | fp == piobind,

211 | fp == piobind,

247 (prim__IO, [_, v']) <- unApplyV v =

212 (prim__IO, [_, v']) <- unApplyV v =

248− do v'' <- tryForce v'

249− res <- execApp' env ctxt k [v''] >>= tryForce

213+ do res <- execApp env ctxt k [v']

250− execApp' env ctxt res rest

214+ execApp env ctxt res rest

251−execApp' env ctxt con@(EP _ fp _) args@(tp:v:rest)

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

216+ | fp == pioret = execApp env ctxt (mkEApp con [tp, v]) rest

255

217

256-- Special cases arising from not having access to the C RTS in the interpreter

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

219+execApp env ctxt (EP _ fp _) (_:fn:EConstant (Str arg):_:rest)

258 | fp == mkfprim,

220 | fp == mkfprim,

259 Just (FFun "putStr" _ _) <- foreignFromTT fn

221 Just (FFun "putStr" _ _) <- foreignFromTT fn

260 = do execIO (putStr arg)

222 = do execIO (putStr arg)

261− execApp' env ctxt ioUnit rest

223+ execApp env ctxt ioUnit rest

262−execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

224+execApp env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

263 | fp == mkfprim,

225 | fp == mkfprim,

264 Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

226 Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

265 = do contents <- execIO $ hGetLine h

227 = do contents <- execIO $ hGetLine h

266− execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

228+ execApp env ctxt (EConstant (Str (contents ++ "\n"))) rest

267−execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

229+execApp env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

268 | fp == mkfprim,

230 | fp == mkfprim,

269 Just (FFun "fileOpen" _ _) <- foreignFromTT fn

231 Just (FFun "fileOpen" _ _) <- foreignFromTT fn

270 = do f <- execIO $

232 = do f <- execIO $

@@ -283,53 +245,53 @@ execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

283 in return $ Right (ioWrap (EPtr nullPtr), tail rest))

245 in return $ Right (ioWrap (EPtr nullPtr), tail rest))

284 case f of

246 case f of

285 Left err -> execFail err

247 Left err -> execFail err

286− Right (res, rest) -> execApp' env ctxt res rest

248+ Right (res, rest) -> execApp env ctxt res rest

287

249

288−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

250+execApp env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

289 | fp == mkfprim,

251 | fp == mkfprim,

290 Just (FFun "fileEOF" _ _) <- foreignFromTT fn

252 Just (FFun "fileEOF" _ _) <- foreignFromTT fn

291 = do eofp <- execIO $ hIsEOF h

253 = do eofp <- execIO $ hIsEOF h

292 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

254 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

293− execApp' env ctxt res (tail rest)

255+ execApp env ctxt res (tail rest)

294

256

295−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

257+execApp env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

296 | fp == mkfprim,

258 | fp == mkfprim,

297 Just (FFun "fileClose" _ _) <- foreignFromTT fn

259 Just (FFun "fileClose" _ _) <- foreignFromTT fn

298 = do execIO $ hClose h

260 = do execIO $ hClose h

299− execApp' env ctxt ioUnit (tail rest)

261+ execApp env ctxt ioUnit (tail rest)

300

262

301−execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

263+execApp env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

302 | fp == mkfprim,

264 | fp == mkfprim,

303 Just (FFun "isNull" _ _) <- foreignFromTT fn

265 Just (FFun "isNull" _ _) <- foreignFromTT fn

304 = let res = ioWrap . EConstant . I $

266 = let res = ioWrap . EConstant . I $

305 if p == nullPtr then 1 else 0

267 if p == nullPtr then 1 else 0

306− in execApp' env ctxt res (tail rest)

268+ in execApp env ctxt res (tail rest)

307

269

308-- Handles will be checked as null pointers sometimes - but if we got a

270-- Handles will be checked as null pointers sometimes - but if we got a

309-- real Handle, then it's valid, so just return 1.

271-- real Handle, then it's valid, so just return 1.

310−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

272+execApp env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

311 | fp == mkfprim,

273 | fp == mkfprim,

312 Just (FFun "isNull" _ _) <- foreignFromTT fn

274 Just (FFun "isNull" _ _) <- foreignFromTT fn

313 = let res = ioWrap . EConstant . I $ 0

275 = let res = ioWrap . EConstant . I $ 0

314− in execApp' env ctxt res (tail rest)

276+ in execApp env ctxt res (tail rest)

315

277

316-- A foreign-returned char* has to be tested for NULL sometimes

278-- A foreign-returned char* has to be tested for NULL sometimes

317−execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)

279+execApp env ctxt (EP _ fp _) (_:fn:EConstant (Str s):rest)

318 | fp == mkfprim,

280 | fp == mkfprim,

319 Just (FFun "isNull" _ _) <- foreignFromTT fn

281 Just (FFun "isNull" _ _) <- foreignFromTT fn

320 = let res = ioWrap . EConstant . I $ 0

282 = let res = ioWrap . EConstant . I $ 0

321− in execApp' env ctxt res (tail rest)

283+ in execApp env ctxt res (tail rest)

322

284

323-- Right now, there's no way to send command-line arguments to the executor,

285-- Right now, there's no way to send command-line arguments to the executor,

324-- so just return 0.

286-- so just return 0.

325−execApp' env ctxt (EP _ fp _) (_:fn:rest)

287+execApp env ctxt (EP _ fp _) (_:fn:rest)

326 | fp == mkfprim,

288 | fp == mkfprim,

327 Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn

289 Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn

328 = let res = ioWrap . EConstant . I $ 0

290 = let res = ioWrap . EConstant . I $ 0

329− in execApp' env ctxt res (tail rest)

291+ in execApp env ctxt res (tail rest)

330-- Throw away the 'World' argument to the foreign function

292-- Throw away the 'World' argument to the foreign function

331

293

332−execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

294+execApp env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

333 = case foreignFromTT fn of

295 = case foreignFromTT fn of

334 Just (FFun f argTs retT) | length xs >= length argTs ->

296 Just (FFun f argTs retT) | length xs >= length argTs ->

335 do let (args', xs') = (take (length argTs) xs, -- foreign args

297 do let (args', xs') = (take (length argTs) xs, -- foreign args

@@ -341,43 +303,41 @@ execApp' env ctxt f@(EP _ fp _) args@(ty:fn:xs) | fp == mkfprim

341 Just r -> return (mkEApp r xs')

303 Just r -> return (mkEApp r xs')

342 Nothing -> return (mkEApp f args)

304 Nothing -> return (mkEApp f args)

343

305

344−execApp' env ctxt c@(EP (DCon _ arity) n _) args =

306+execApp env ctxt c@(EP (DCon _ arity) n _) args =

345− do args' <- mapM tryForce (take arity args)

307+ do let args' = take arity args

346 let restArgs = drop arity args

308 let restArgs = drop arity args

347− execApp' env ctxt (mkEApp c args') restArgs

309+ execApp env ctxt (mkEApp c args') restArgs

348

310

349−execApp' env ctxt c@(EP (TCon _ arity) n _) args =

311+execApp env ctxt c@(EP (TCon _ arity) n _) args =

350− do args' <- mapM tryForce (take arity args)

312+ do let args' = take arity args

351 let restArgs = drop arity args

313 let restArgs = drop arity args

352− execApp' env ctxt (mkEApp c args') restArgs

314+ execApp env ctxt (mkEApp c args') restArgs

353

315

354−execApp' env ctxt f@(EP _ n _) args =

316+execApp env ctxt f@(EP _ n _) args =

355 do let val = lookupDef n ctxt

317 do let val = lookupDef n ctxt

356 case val of

318 case val of

357 [Function _ tm] -> fail "should already have been eval'd"

319 [Function _ tm] -> fail "should already have been eval'd"

358 [TyDecl nt ty] -> return $ mkEApp f args

320 [TyDecl nt ty] -> return $ mkEApp f args

359 [Operator tp arity op] ->

321 [Operator tp arity op] ->

360 if length args >= arity

322 if length args >= arity

361− then do args' <- mapM tryForce $ take arity args

323+ then let args' = take arity args in

362− case getOp n args' of

324+ case getOp n args' of

363− Just res -> do r <- res

325+ Just res -> do r <- res

364− execApp' env ctxt r (drop arity args)

326+ execApp env ctxt r (drop arity args)

365− Nothing -> return (mkEApp f args)

327+ Nothing -> return (mkEApp f args)

366 else return (mkEApp f args)

328 else return (mkEApp f args)

367 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun

329 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun

368 do rhs <- doExec env ctxt tm

330 do rhs <- doExec env ctxt tm

369− execApp' env ctxt rhs args

331+ execApp env ctxt rhs args

370 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->

332 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->

371 do res <- execCase env ctxt ns sc args

333 do res <- execCase env ctxt ns sc args

372 return $ fromMaybe (mkEApp f args) res

334 return $ fromMaybe (mkEApp f args) res

373 thing -> return $ mkEApp f args

335 thing -> return $ mkEApp f args

374−execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg

336+execApp env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg

375− let (f', as) = unApplyV ret

337+ let (f', as) = unApplyV ret

376− execApp' env ctxt f' (as ++ args)

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

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

340+execApp env ctxt f args = return (mkEApp f args)

381

341

382prs = sUN "prim__readString"

342prs = sUN "prim__readString"

383pbm = sUN "prim__believe_me"

343pbm = sUN "prim__believe_me"

@@ -386,6 +346,8 @@ mkfprim = sUN "mkForeignPrim"

386pioret = sUN "prim_io_return"

346pioret = sUN "prim_io_return"

387piobind = sUN "prim_io_bind"

347piobind = sUN "prim_io_bind"

388upio = sUN "unsafePerformPrimIO"

348upio = sUN "unsafePerformPrimIO"

349+delay = sUN "Delay"

350+force = sUN "Force"

389

351

390-- | Look up primitive operations in the global table and transform them into ExecVal functions

352-- | Look up primitive operations in the global table and transform them into ExecVal functions

391getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

353getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

@@ -426,7 +388,7 @@ execCase env ctxt ns sc args =

426-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()

388-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()

427 caseRes <- execCase' env ctxt amap sc

389 caseRes <- execCase' env ctxt amap sc

428 case caseRes of

390 case caseRes of

429− Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)

391+ Just res -> Just <$> execApp (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)

430 Nothing -> return Nothing

392 Nothing -> return Nothing

431 else return Nothing

393 else return Nothing

432

394

@@ -436,8 +398,7 @@ execCase' env ctxt amap (UnmatchedCase _) = return Nothing

436execCase' env ctxt amap (STerm tm) =

398execCase' env ctxt amap (STerm tm) =

437 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm

399 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm

438execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =

400execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =

439− do tm' <- tryForce tm

440− case chooseAlt tm' alts of

401+ case chooseAlt tm alts of

441 Just (newCase, newBindings) ->

402 Just (newCase, newBindings) ->

442 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in

403 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in

443 execCase' env ctxt amap' newCase

404 execCase' env ctxt amap' newCase

src/Idris/Core/TT.hs+8−6

@@ -82,14 +82,16 @@ instance Show FC where

82 | otherwise = show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec

83

84-- | Output annotation for pretty-printed name - decides colour

85−data NameOutput = TypeOutput | FunOutput | DataOutput

85+data NameOutput = TypeOutput | FunOutput | DataOutput | MetavarOutput

86

87-- | Text formatting output

88data TextFormatting = BoldText | ItalicText | UnderlineText

89

90-- | Output annotations for pretty-printing

91−data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe Type)

91+data OutputAnnotation = AnnName Name (Maybe NameOutput) (Maybe String) (Maybe String)

92+ -- ^^ The name, classification, docs overview, and pretty-printed type

92 | AnnBoundName Name Bool

93 | AnnBoundName Name Bool

94+ -- ^^ The name and whether it is implicit

93 | AnnConstData

95 | AnnConstData

94 | AnnConstType

96 | AnnConstType

95 | AnnKeyword

97 | AnnKeyword

@@ -312,11 +314,11 @@ instance Sized Name where

312 size _ = 1

314 size _ = 1

313

315

314instance Pretty Name OutputAnnotation where

316instance Pretty Name OutputAnnotation where

315− pretty n@(UN n') = annotate (AnnName n Nothing Nothing) $ text (T.unpack n')

317+ pretty n@(UN n') = annotate (AnnName n Nothing Nothing Nothing) $ text (T.unpack n')

316− pretty n@(NS un s) = annotate (AnnName n Nothing Nothing) . noAnnotate $ pretty un

318+ pretty n@(NS un s) = annotate (AnnName n Nothing Nothing Nothing) . noAnnotate $ pretty un

317− pretty n@(MN i s) = annotate (AnnName n Nothing Nothing) $

319+ pretty n@(MN i s) = annotate (AnnName n Nothing Nothing Nothing) $

318 lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace

320 lbrace <+> text (T.unpack s) <+> (text . show $ i) <+> rbrace

319− pretty n@(SN s) = annotate (AnnName n Nothing Nothing) $ text (show s)

321+ pretty n@(SN s) = annotate (AnnName n Nothing Nothing Nothing) $ text (show s)

320

322

321instance Pretty [Name] OutputAnnotation where

323instance Pretty [Name] OutputAnnotation where

322 pretty = encloseSep empty empty comma . map pretty

324 pretty = encloseSep empty empty comma . map pretty

src/Idris/Coverage.hs+41−13

@@ -9,6 +9,7 @@ import Idris.Core.CaseTree

9import Idris.AbsSyntax

10import Idris.Delaborate

11import Idris.Error

12+import Idris.Output (iputStrLn)

12

13

13import Data.List

14import Data.List

14import Data.Either

15import Data.Either

@@ -17,10 +18,14 @@ import Debug.Trace

17

18

18import Control.Monad.State.Strict

19import Control.Monad.State.Strict

19

20

21+-- Generate a pattern from an 'impossible' LHS. (Need this to eliminate the

22+-- pattern clauses which have been provided explicitly from new clause

23+-- generation.)

24+

20mkPatTm :: PTerm -> Idris Term

25mkPatTm :: PTerm -> Idris Term

21mkPatTm t = do i <- getIState

26mkPatTm t = do i <- getIState

22 let timp = addImpl' True [] [] i t

27 let timp = addImpl' True [] [] i t

23− evalStateT (toTT timp) 0

28+ evalStateT (toTT (mapPT deNS timp)) 0

24 where

29 where

25 toTT (PRef _ n) = do i <- lift getIState

30 toTT (PRef _ n) = do i <- lift getIState

26 case lookupDef n (tt_ctxt i) of

31 case lookupDef n (tt_ctxt i) of

@@ -29,10 +34,16 @@ mkPatTm t = do i <- getIState

29 toTT (PApp _ t args) = do t' <- toTT t

34 toTT (PApp _ t args) = do t' <- toTT t

30 args' <- mapM (toTT . getTm) args

35 args' <- mapM (toTT . getTm) args

31 return $ mkApp t' args'

36 return $ mkApp t' args'

37+ -- For alternatives, pick the first and drop the namespaces. It doesn't

38+ -- really matter which is taken since matching will ignore the namespace.

39+ toTT (PAlternative _ (a : as)) = toTT a

32 toTT _ = do v <- get

40 toTT _ = do v <- get

33 put (v + 1)

41 put (v + 1)

34 return (P Bound (sMN v "imp") Erased)

42 return (P Bound (sMN v "imp") Erased)

35

43

44+ deNS (PRef f (NS n _)) = PRef f n

45+ deNS t = t

46+

36-- Given a list of LHSs, generate a extra clauses which cover the remaining

47-- Given a list of LHSs, generate a extra clauses which cover the remaining

37-- cases. The ones which haven't been provided are marked 'absurd' so that the

48-- cases. The ones which haven't been provided are marked 'absurd' so that the

38-- checker will make sure they can't happen.

49-- checker will make sure they can't happen.

@@ -40,30 +51,36 @@ mkPatTm t = do i <- getIState

40-- This will only work after the given clauses have been typechecked and the

51-- This will only work after the given clauses have been typechecked and the

41-- names are fully explicit!

52-- names are fully explicit!

42

53

43−genClauses :: FC -> Name -> [Term] -> [PClause] -> Idris [PTerm]

54+genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm]

44genClauses fc n xs given

55genClauses fc n xs given

45 = do i <- getIState

56 = do i <- getIState

46− let lhss = map (getLHS i) xs

57+ let lhs_tms = map (\x -> delab' i x True True) xs

58+ -- if a placeholder was given, don't bother generating cases for it

59+ let lhs_tms' = zipWith mergePlaceholders lhs_tms given

60+ let lhss = map pUnApply lhs_tms'

61+

47 let argss = transpose lhss

62 let argss = transpose lhss

48 let all_args = map (genAll i) argss

63 let all_args = map (genAll i) argss

49 logLvl 5 $ "COVERAGE of " ++ show n

64 logLvl 5 $ "COVERAGE of " ++ show n

65+ logLvl 5 $ show lhss

50 logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

66 logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

51 logLvl 10 $ show argss ++ "\n" ++ show all_args

67 logLvl 10 $ show argss ++ "\n" ++ show all_args

52− logLvl 10 $ "Original: \n" ++

68+ logLvl 1 $ "Original: \n" ++

53 showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)

69 showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)

54 -- add an infinite supply of explicit arguments to update the possible

70 -- add an infinite supply of explicit arguments to update the possible

55− -- cases for (the return type may be variadic, or function type, sp

71+ -- cases for (the return type may be variadic, or function type, so

56 -- there may be more case splitting that the idris_implicits record

72 -- there may be more case splitting that the idris_implicits record

57 -- suggests)

73 -- suggests)

58 let parg = case lookupCtxt n (idris_implicits i) of

74 let parg = case lookupCtxt n (idris_implicits i) of

75+ (p : _) ->

59− (p : _) -> p ++ repeat (PExp 0 [] Placeholder)

76+ p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder)

60− _ -> repeat (pexp Placeholder)

77+ _ -> repeat (pexp Placeholder)

61 let tryclauses = mkClauses parg all_args

78 let tryclauses = mkClauses parg all_args

62 logLvl 2 $ show (length tryclauses) ++ " initially to check"

79 logLvl 2 $ show (length tryclauses) ++ " initially to check"

63− logLvl 5 $ showSep "\n" (map (showTm i) tryclauses)

80+ logLvl 1 $ showSep "\n" (map (showTm i) tryclauses)

64 let new = filter (noMatch i) (nub tryclauses)

81 let new = filter (noMatch i) (nub tryclauses)

65 logLvl 1 $ show (length new) ++ " clauses to check for impossibility"

82 logLvl 1 $ show (length new) ++ " clauses to check for impossibility"

66− logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)

83+ logLvl 3 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)

67-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)

84-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)

68 return new

85 return new

69-- return (map (\t -> PClause n t [] PImpossible []) new)

86-- return (map (\t -> PClause n t [] PImpossible []) new)

@@ -71,13 +88,23 @@ genClauses fc n xs given

71 | (f, args) <- unApply term = map (\t -> delab' i t True True) args

88 | (f, args) <- unApply term = map (\t -> delab' i t True True) args

72 | otherwise = []

89 | otherwise = []

73

90

74− lhsApp (PClause _ _ l _ _ _) = l

91+ pUnApply (PApp _ _ args) = map getTm args

75− lhsApp (PWith _ _ l _ _ _) = l

92+ pUnApply _ = []

76

93

94+ -- Return whether the given clause matches none of the input clauses

95+ -- (xs)

77 noMatch i tm = all (\x -> case matchClause i (delab' i x True True) tm of

96 noMatch i tm = all (\x -> case matchClause i (delab' i x True True) tm of

78− Right _ -> False

97+ Right ms -> False

79− Left miss -> True) xs

98+ Left miss -> True) xs

99+

80

100

101+ mergePlaceholders :: PTerm -> PTerm -> PTerm

102+ mergePlaceholders x Placeholder = Placeholder

103+ mergePlaceholders (PApp fc f args) (PApp fc' f' args')

104+ = PApp fc' f' (zipWith mergePArg args args')

105+ where mergePArg x y = let xtm = mergePlaceholders (getTm x) (getTm y) in

106+ x { getTm = xtm}

107+ mergePlaceholders x _ = x

81

108

82 mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]

109 mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]

83 mkClauses parg args

110 mkClauses parg args

@@ -101,6 +128,7 @@ fnub' acc [] = acc

101

128

102-- quick check for constructor equality

129-- quick check for constructor equality

103quickEq :: PTerm -> PTerm -> Bool

130quickEq :: PTerm -> PTerm -> Bool

131+quickEq (PConstant n) (PConstant n') = n == n'

104quickEq (PRef _ n) (PRef _ n') = n == n'

132quickEq (PRef _ n) (PRef _ n') = n == n'

105quickEq (PApp _ t as) (PApp _ t' as')

133quickEq (PApp _ t as) (PApp _ t' as')

106 | length as == length as'

134 | length as == length as'

src/Idris/DataOpts.hs+14−231

@@ -9,224 +9,48 @@ import Idris.AbsSyntaxTree

9import Idris.Core.TT

10

11import Control.Applicative

12−import qualified Data.IntMap as M

13import Data.List

12import Data.List

14import Data.Maybe

13import Data.Maybe

15import Debug.Trace

14import Debug.Trace

16

15

17−type ForceMap = M.IntMap Forceability

18−

19−-- Calculate the forceable arguments to a constructor

20−-- and update the set of optimisations.

21−forceArgs :: Name -> Name -> [Int] -> Type -> Idris ()

22−forceArgs typeName n expforce t = do

23− ist <- getIState

24− let fargs = getForcedArgs ist typeName t

25− copt = case lookupCtxt n (idris_optimisation ist) of

26− [] -> Optimise False False [] []

27− op:_ -> op

28− opts = addDef n (copt { forceable = M.toList fargs ++

29− zip expforce (repeat Unconditional) })

30− (idris_optimisation ist)

31− putIState (ist { idris_optimisation = opts })

32− addIBC (IBCOpt n)

33− iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t

34−

35−getForcedArgs :: IState -> Name -> Type -> ForceMap

36−getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

37− where

38− maxUnion = M.unionWith max

39−

40− -- Label all occurrences of the variable bound in Pi in the rest of

41− -- the term with the number i so that we can recognize them anytime later.

42− label i = instantiate $ P Bound (sMN i "ctor_arg") Erased

43−

44− addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap

45− addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable

46− = addCollapsibleArgs (i+1) (label i rest) (forceable $ unApply ty)

47− where

48− -- forceable takes an un-applied type of a ctor argument

49− forceable (P _ tn _, args)

50− -- if `ty' is collapsible, the argument is unconditionally forceable

51− | isCollapsible tn

52− = M.insert i Unconditional alreadyForceable

53−

54− -- a recursive occurrence with known indices is conditionally forceable

55− | tn == typeName

56− = M.insertWith max i Conditional alreadyForceable

57−

58− forceable _ = alreadyForceable

59−

60− isCollapsible :: Name -> Bool

61− isCollapsible n = case lookupCtxt n (idris_optimisation ist) of

62− [oi] -> collapsible oi

63− _ -> False

64−

65− addCollapsibleArgs _ _ fs = fs

66−

67− forcedInTarget :: Int -> Type -> ForceMap

68− forcedInTarget i (Bind _ (Pi _) rest) = forcedInTarget (i+1) (label i rest)

69− forcedInTarget i t@(App f a) | (_, as) <- unApply t = unionMap guardedArgs as

70− forcedInTarget _ _ = M.empty

71−

72− guardedArgs :: Term -> ForceMap

73− guardedArgs t@(App f a) | (P (DCon _ _) _ _, args) <- unApply t

74− = unionMap bareArg args `maxUnion` unionMap guardedArgs args

75− guardedArgs t = bareArg t

76−

77− bareArg :: Term -> ForceMap

78− bareArg (P _ (MN i ctor_arg) _)

79− | ctor_arg == txt "ctor_arg" = M.singleton i Unconditional

80− bareArg _ = M.empty

81−

82− unionMap :: (a -> ForceMap) -> [a] -> ForceMap

83− unionMap f = M.unionsWith max . map f

84−

85−-- Calculate whether a collection of constructors is collapsible

86−-- and update the state accordingly.

87−collapseCons :: Name -> [(Name, Type)] -> Idris ()

88−collapseCons tn ctors = do

89− ist <- getIState

90− case ctors of

91− _

92− | all (ctorCollapsible ist) ctors

93− , disjointTerms ctorTargetArgs

94− -> mapM_ setCollapsible (tn : map fst ctors)

95−

96− [(cn, ct)]

97− -> checkNewType ist cn ct

98−

99− _ -> return () -- nothing can be done

100− where

101− ctorTargetArgs = map (snd . unApply . getRetTy . snd) ctors

102−

103− ctorArity :: Type -> Int

104− ctorArity = length . getArgTys

105−

106− ctorCollapsible :: IState -> (Name, Type) -> Bool

107− ctorCollapsible ist (n, t) = all (`M.member` forceMap) [0 .. ctorArity t - 1]

108− where

109− forceMap = case lookupCtxt n (idris_optimisation ist) of

110− oi:_ -> M.fromList $ forceable oi

111− _ -> M.empty

112−

113− -- one constructor; if one remaining argument, treat as newtype

114− checkNewType :: IState -> Name -> Type -> Idris ()

115− checkNewType ist cn ct

116− | oi:_ <- lookupCtxt cn opt

117− , length (getArgTys ct) == 1 + forcedCnt (M.fromList $ forceable oi)

118− = putIState ist{ idris_optimisation = opt' oi }

119− | otherwise = return ()

120− where

121− opt = idris_optimisation ist

122− opt' oi = addDef cn oi{ isnewtype = True } opt

123−

124− setCollapsible :: Name -> Idris ()

125− setCollapsible n

126− = do i <- getIState

127− iLOG $ show n ++ " collapsible"

128− case lookupCtxt n (idris_optimisation i) of

129− (oi:_) -> do let oi' = oi { collapsible = True }

130− let opts = addDef n oi' (idris_optimisation i)

131− putIState (i { idris_optimisation = opts })

132− [] -> do let oi = Optimise True False [] []

133− let opts = addDef n oi (idris_optimisation i)

134− putIState (i { idris_optimisation = opts })

135− addIBC (IBCOpt n)

136−

137− disjointTerms :: [[Term]] -> Bool

138− disjointTerms [] = True

139− disjointTerms [xs] = True

140− disjointTerms (xs : xss) =

141− -- xs is disjoint with every pattern from xss

142− all (or . zipWith disjoint xs) xss

143− -- and xss is pairwise disjoint, too

144− && disjointTerms xss

145−

146− -- Return True if the two patterns are provably disjoint.

147− -- Return False if they're not or if unsure.

148− disjoint :: Term -> Term -> Bool

149− disjoint x y = case (cx, cy) of

150− -- data constructors -> compare their names

151− (P (DCon _ _) nx _, P (DCon _ _) ny _)

152− | nx /= ny -> True

153− | otherwise -> or $ zipWith disjoint xargs yargs

154− _ -> False

155− where

156− (cx, xargs) = unApply x

157− (cy, yargs) = unApply y

158−

159class Optimisable term where

16class Optimisable term where

160 applyOpts :: term -> Idris term

17 applyOpts :: term -> Idris term

161− stripCollapsed :: term -> Idris term

162

18

163instance (Optimisable a, Optimisable b) => Optimisable (a, b) where

19instance (Optimisable a, Optimisable b) => Optimisable (a, b) where

164 applyOpts (x, y) = (,) <$> applyOpts x <*> applyOpts y

20 applyOpts (x, y) = (,) <$> applyOpts x <*> applyOpts y

165− stripCollapsed (x, y) = (,) <$> stripCollapsed x <*> stripCollapsed y

166

21

167instance (Optimisable a, Optimisable b) => Optimisable (vs, a, b) where

22instance (Optimisable a, Optimisable b) => Optimisable (vs, a, b) where

168 applyOpts (v, x, y) = (,,) v <$> applyOpts x <*> applyOpts y

23 applyOpts (v, x, y) = (,,) v <$> applyOpts x <*> applyOpts y

169− stripCollapsed (v, x, y) = (,,) v <$> stripCollapsed x <*> stripCollapsed y

170

24

171instance Optimisable a => Optimisable [a] where

25instance Optimisable a => Optimisable [a] where

172 applyOpts = mapM applyOpts

26 applyOpts = mapM applyOpts

173− stripCollapsed = mapM stripCollapsed

174

27

175instance Optimisable a => Optimisable (Either a (a, a)) where

28instance Optimisable a => Optimisable (Either a (a, a)) where

176 applyOpts (Left t) = Left <$> applyOpts t

29 applyOpts (Left t) = Left <$> applyOpts t

177 applyOpts (Right t) = Right <$> applyOpts t

30 applyOpts (Right t) = Right <$> applyOpts t

178− stripCollapsed (Left t) = Left <$> stripCollapsed t

179− stripCollapsed (Right t) = Right <$> stripCollapsed t

180

31

181-- Raw is for compile time optimisation (before type checking)

32-- Raw is for compile time optimisation (before type checking)

182-- Term is for run time optimisation (after type checking, collapsing allowed)

33-- Term is for run time optimisation (after type checking, collapsing allowed)

183−

184-- Compile time: no collapsing

34-- Compile time: no collapsing

185

35

186instance Optimisable Raw where

36instance Optimisable Raw where

187 applyOpts t@(RApp f a)

37 applyOpts t@(RApp f a)

188 | (Var n, args) <- raw_unapply t -- MAGIC HERE

38 | (Var n, args) <- raw_unapply t -- MAGIC HERE

189− = do args' <- mapM applyOpts args

39+ = raw_apply (Var n) <$> mapM applyOpts args

190− i <- getIState

191− return $ case lookupCtxt n (idris_optimisation i) of

192− oi:_ -> applyDataOpt oi n args'

193− _ -> raw_apply (Var n) args'

194 | otherwise = RApp <$> applyOpts f <*> applyOpts a

40 | otherwise = RApp <$> applyOpts f <*> applyOpts a

195

41

196 applyOpts (RBind n b t) = RBind n <$> applyOpts b <*> applyOpts t

42 applyOpts (RBind n b t) = RBind n <$> applyOpts b <*> applyOpts t

197 applyOpts (RForce t) = applyOpts t

43 applyOpts (RForce t) = applyOpts t

198 applyOpts t = return t

44 applyOpts t = return t

199

45

200− stripCollapsed t = return t

201−

202-- Erase types (makes ibc smaller, and we don't need them)

46-- Erase types (makes ibc smaller, and we don't need them)

203instance Optimisable (Binder (TT Name)) where

47instance Optimisable (Binder (TT Name)) where

204 applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v

48 applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v

205 applyOpts b = return (b { binderTy = Erased })

49 applyOpts b = return (b { binderTy = Erased })

206− stripCollapsed (Let t v) = Let <$> return Erased <*> stripCollapsed v

207− stripCollapsed b = return (b { binderTy = Erased })

208

50

209instance Optimisable (Binder Raw) where

51instance Optimisable (Binder Raw) where

210 applyOpts b = do t' <- applyOpts (binderTy b)

52 applyOpts b = do t' <- applyOpts (binderTy b)

211 return (b { binderTy = t' })

53 return (b { binderTy = t' })

212− stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v

213− stripCollapsed b = do t' <- stripCollapsed (binderTy b)

214− return (b { binderTy = t' })

215−

216−forcedArgSeq :: OptInfo -> [Maybe Forceability]

217−forcedArgSeq oi = map (\i -> M.lookup i forceMap) [0..]

218− where

219− forceMap = M.fromList $ forceable oi

220−

221−forcedCnt :: ForceMap -> Int

222−forcedCnt = length . filter (== Unconditional) . M.elems

223−

224−applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw

225−applyDataOpt oi n args

226− = raw_apply (Var n) $ zipWith doForce (forcedArgSeq oi) args

227− where

228− doForce (Just Unconditional) a = RForce a

229− doForce _ a = a

230

54

231-- Run-time: do everything

55-- Run-time: do everything

232

56

@@ -249,54 +73,22 @@ instance Optimisable (TT Name) where

249 | fn == txt "toIntegerNat" && mod == prel

73 | fn == txt "toIntegerNat" && mod == prel

250 = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

74 = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

251 applyOpts c@(P (DCon t arity) n _)

75 applyOpts c@(P (DCon t arity) n _)

252− = do i <- getIState

253− case lookupCtxt n (idris_optimisation i) of

254− (oi:_) -> return $ applyDataOptRT oi n t arity []

76+ = return $ applyDataOptRT n t arity []

255− _ -> return c

256 applyOpts t@(App f a)

77 applyOpts t@(App f a)

257 | (c@(P (DCon t arity) n _), args) <- unApply t

78 | (c@(P (DCon t arity) n _), args) <- unApply t

258− = do args' <- mapM applyOpts args

259− i <- getIState

260− case lookupCtxt n (idris_optimisation i) of

261− (oi:_) -> do return $ applyDataOptRT oi n t arity args'

79+ = applyDataOptRT n t arity <$> mapM applyOpts args

262− _ -> return (mkApp c args')

80+ | otherwise = App <$> applyOpts f <*> applyOpts a

263− | otherwise = do f' <- applyOpts f

264− a' <- applyOpts a

265− return (App f' a')

266− applyOpts (Bind n b t) = do b' <- applyOpts b

81+ applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t

267− t' <- applyOpts t

268− return (Bind n b' t')

269− applyOpts (Proj t i) = do t' <- applyOpts t

82+ applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i

270− return (Proj t' i)

271 applyOpts t = return t

83 applyOpts t = return t

272

84

273− stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x

274− = do i <- getIState

275− -- NOTE: This assumes that 'ty' is in normal form, which it

276− -- has to be before now because we're not keeping track of

277− -- an environment so we can't do it here.

278− case lookupCtxt ty (idris_optimisation i) of

279− [oi] -> if collapsible oi

280− then do t' <- stripCollapsed t

281− return (Bind n (PVar x) (instantiate Erased t'))

282− else do t' <- stripCollapsed t

283− return (Bind n (PVar x) t')

284− _ -> do t' <- stripCollapsed t

285− return (Bind n (PVar x) t')

286− stripCollapsed (Bind n (PVar x) t)

287− = do t' <- stripCollapsed t

288− return (Bind n (PVar x) t')

289− stripCollapsed t = return t

290−

291−-- Need to saturate arguments first to ensure that erasure happens uniformly

85+-- Need to saturate arguments first to ensure that optimisation happens uniformly

292−

293−applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term

86+applyDataOptRT :: Name -> Int -> Int -> [Term] -> Term

294−applyDataOptRT oi n tag arity args

87+applyDataOptRT n tag arity args

295− | length args == arity = doOpts n args (collapsible oi) (M.fromList $ forceable oi)

88+ | length args == arity = doOpts n args

296 | otherwise = let extra = satArgs (arity - length args)

89 | otherwise = let extra = satArgs (arity - length args)

297 tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra)

90 tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra)

298− (collapsible oi) (M.fromList $ forceable oi) in

299− bind extra tm

91+ in bind extra tm

300 where

92 where

301 satArgs n = map (\i -> sMN i "sat") [1..n]

93 satArgs n = map (\i -> sMN i "sat") [1..n]

302

94

@@ -305,20 +97,11 @@ applyDataOptRT oi n tag arity args

305

97

306 -- Nat special cases

98 -- Nat special cases

307 -- TODO: Would be nice if this was configurable in idris source!

99 -- TODO: Would be nice if this was configurable in idris source!

308− doOpts (NS (UN z) [nat, prelude]) [] _ _

100+ doOpts (NS (UN z) [nat, prelude]) []

309 | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

101 | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

310 = Constant (BI 0)

102 = Constant (BI 0)

311− doOpts (NS (UN s) [nat, prelude]) [k] _ _

103+ doOpts (NS (UN s) [nat, prelude]) [k]

312 | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

104 | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

313 = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

105 = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

314

106

315− doOpts n args True _ = Erased

316− doOpts n args _ forceMap

317− | isnewtype oi = case args' of

318− [val] -> val

319− _ -> error $ "Can't happen (newtype not a singleton): " ++ show args'

320− | otherwise = mkApp ctor' args'

321− where

322− ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)

107+ doOpts n args = mkApp (P (DCon tag arity) n Erased) args

323− args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]

324−

src/Idris/DeepSeq.hs+6−10

@@ -50,10 +50,6 @@ instance NFData CT.NumWrapper where

50

51-- All generated by 'derive'

52

53−instance NFData Forceability where

54− rnf Conditional = ()

55− rnf Unconditional = ()

56−

57instance NFData IntTy where

53instance NFData IntTy where

58 rnf (ITFixed x1) = rnf x1 `seq` ()

54 rnf (ITFixed x1) = rnf x1 `seq` ()

59 rnf ITNative = ()

55 rnf ITNative = ()

@@ -276,10 +272,10 @@ instance (NFData t) => NFData (PDo' t) where

276instance (NFData t) => NFData (PArg' t) where

272instance (NFData t) => NFData (PArg' t) where

277 rnf (PImp x1 x2 x3 x4 x5)

273 rnf (PImp x1 x2 x3 x4 x5)

278 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

274 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

279− rnf (PExp x1 x2 x3)

275+ rnf (PExp x1 x2 x3 x4)

280− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

276+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

281− rnf (PConstraint x1 x2 x3)

277+ rnf (PConstraint x1 x2 x3 x4)

282− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

278+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

283 rnf (PTacImplicit x1 x2 x3 x4 x5)

279 rnf (PTacImplicit x1 x2 x3 x4 x5)

284 = rnf x1 `seq`

280 = rnf x1 `seq`

285 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

281 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

@@ -290,8 +286,8 @@ instance NFData ClassInfo where

290 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

286 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

291

287

292instance NFData OptInfo where

288instance NFData OptInfo where

293− rnf (Optimise x1 x2 x3 x4)

289+ rnf (Optimise x1 x2)

294− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

290+ = rnf x1 `seq` rnf x2 `seq` ()

295

291

296instance NFData TypeInfo where

292instance NFData TypeInfo where

297 rnf (TI x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

293 rnf (TI x1 x2 x3 x4) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

src/Idris/Delaborate.hs+5−10

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

1{-# LANGUAGE PatternGuards #-}

2−module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', pshow, pprintErr) where

2+module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', pprintErr) where

3

4-- Convert core TT back into high level syntax, primarily for display

5-- purposes.

@@ -58,7 +58,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

58 = PLam n (de env [] ty) (de ((n,n):env) [] sc)

59 de env ((PImp { argopts = opts }):is) (Bind n (Pi ty) sc)

60 = PPi (Imp opts Dynamic False) n (de env [] ty) (de ((n,n):env) is sc)

61− de env (PConstraint _ _ _:is) (Bind n (Pi ty) sc)

61+ de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc)

62 = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)

63 de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi ty) sc)

64 = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)

@@ -121,8 +121,8 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

121 | otherwise = PApp un (PRef un n) (map pexp args)

122

123 imp (PImp p m l n _) arg = PImp p m l n arg

124− imp (PExp p l _) arg = PExp p l arg

124+ imp (PExp p l n _) arg = PExp p l n arg

125− imp (PConstraint p l _) arg = PConstraint p l arg

125+ imp (PConstraint p l n _) arg = PConstraint p l n arg

126 imp (PTacImplicit p l n sc _) arg = PTacImplicit p l n sc arg

127

128-- | How far to indent sub-errors

@@ -140,11 +140,6 @@ pprintTerm ist = pprintTerm' ist []

140pprintTerm' :: IState -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

141pprintTerm' ist bnd tm = pprintPTerm (opt_showimp (idris_options ist)) bnd [] tm

142

143−pshow :: IState -> Err -> String

144−pshow ist err = displayDecorated (consoleDecorate ist) .

145− renderPretty 1.0 80 .

146− fmap (fancifyAnnots ist) $ pprintErr ist err

147−

148pprintErr :: IState -> Err -> Doc OutputAnnotation

143pprintErr :: IState -> Err -> Doc OutputAnnotation

149pprintErr i err = pprintErr' i (fmap (errReverse i) err)

144pprintErr i err = pprintErr' i (fmap (errReverse i) err)

150

145

@@ -261,7 +256,7 @@ annName :: Name -> Doc OutputAnnotation

261annName n = annName' n (showbasic n)

256annName n = annName' n (showbasic n)

262

257

263annName' :: Name -> String -> Doc OutputAnnotation

258annName' :: Name -> String -> Doc OutputAnnotation

264−annName' n str = annotate (AnnName n Nothing Nothing) (text str)

259+annName' n str = annotate (AnnName n Nothing Nothing Nothing) (text str)

265

260

266showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation

261showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation

267showSc i [] = empty

262showSc i [] = empty

src/Idris/ElabDecls.hs+151−109

@@ -16,6 +16,7 @@ import Idris.Primitives

16import Idris.Inliner

17import Idris.PartialEval

18import Idris.DeepSeq

19+import Idris.Output (iputStrLn, pshow, iWarn)

19import IRTS.Lang

20import IRTS.Lang

20import Paths_idris

21import Paths_idris

21

22

@@ -36,6 +37,7 @@ import Data.Maybe

36import Debug.Trace

37import Debug.Trace

37

38

38import qualified Data.Map as Map

39import qualified Data.Map as Map

40+import qualified Data.Set as S

39import qualified Data.Text as T

41import qualified Data.Text as T

40import Data.Char(isLetter, toLower)

42import Data.Char(isLetter, toLower)

41import Data.List.Split (splitOn)

43import Data.List.Split (splitOn)

@@ -58,7 +60,8 @@ checkAddDef add toplvl fc [] = return []

58checkAddDef add toplvl fc ((n, (i, top, t)) : ns)

60checkAddDef add toplvl fc ((n, (i, top, t)) : ns)

59 = do ctxt <- getContext

61 = do ctxt <- getContext

60 (t', _) <- recheckC fc [] t

62 (t', _) <- recheckC fc [] t

61− when add $ addDeferred [(n, (i, top, t, toplvl))]

63+ when add $ do addDeferred [(n, (i, top, t, toplvl))]

64+ addIBC (IBCDef n)

62 ns' <- checkAddDef add toplvl fc ns

65 ns' <- checkAddDef add toplvl fc ns

63 return ((n, (i, top, t')) : ns')

66 return ((n, (i, top, t')) : ns')

64-- mapM (\(n, (i, top, t)) -> do (t', _) <- recheckC fc [] t

67-- mapM (\(n, (i, top, t)) -> do (t', _) <- recheckC fc [] t

@@ -80,10 +83,13 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

80

83

81 logLvl 3 $ show n ++ " pre-type " ++ showTmImpls ty'

84 logLvl 3 $ show n ++ " pre-type " ++ showTmImpls ty'

82 ty' <- addUsingConstraints syn fc ty'

85 ty' <- addUsingConstraints syn fc ty'

83− ty' <- implicit syn n ty'

86+ ty' <- implicit info syn n ty'

84

87

85− let ty = addImpl i ty'

88+ let ty = addImpl i ty'

89+ inacc = inaccessibleArgs 0 ty

86 logLvl 3 $ show n ++ " type " ++ showTmImpls ty

90 logLvl 3 $ show n ++ " type " ++ showTmImpls ty

91+ logLvl 5 $ "Inaccessible arguments: " ++ show inacc

92+

87 ((tyT, defer, is), log) <-

93 ((tyT, defer, is), log) <-

88 tclift $ elaborate ctxt n (TType (UVal 0)) []

94 tclift $ elaborate ctxt n (TType (UVal 0)) []

89 (errAt "type of " n (erun fc (build i info False [] n ty)))

95 (errAt "type of " n (erun fc (build i info False [] n ty)))

@@ -128,8 +134,10 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

128 addDocStr n doc argDocs

134 addDocStr n doc argDocs

129 addIBC (IBCDoc n)

135 addIBC (IBCDoc n)

130 addIBC (IBCFlags n opts')

136 addIBC (IBCFlags n opts')

137+ saveInaccArgs n inacc

131 when (Implicit `elem` opts') $ do addCoercion n

138 when (Implicit `elem` opts') $ do addCoercion n

132 addIBC (IBCCoercion n)

139 addIBC (IBCCoercion n)

140+

133 -- If the function is declared as an error handler and the language

141 -- If the function is declared as an error handler and the language

134 -- extension is enabled, then add it to the list of error handlers.

142 -- extension is enabled, then add it to the list of error handlers.

135 errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState

143 errorReflection <- fmap (elem ErrorReflection . idris_language_extensions) getIState

@@ -170,30 +178,40 @@ elabType' norm info syn doc argDocs fc opts n ty' = {- let ty' = piBind (params

170 , ns4 == map txt ["Errors","Reflection","Language"] = True

178 , ns4 == map txt ["Errors","Reflection","Language"] = True

171 tyIsHandler _ = False

179 tyIsHandler _ = False

172

180

181+-- Store the list of inaccessible arguments in the internal state.

182+saveInaccArgs :: Name -> [(Int,Name)] -> Idris ()

183+saveInaccArgs n is = do

184+ ist <- getIState

185+ case lookupCtxt n (idris_optimisation ist) of

186+ [oi] -> do

187+ putIState ist{ idris_optimisation =

188+ addDef n oi{ inaccessible = is } (idris_optimisation ist) }

189+

190+ _ -> do

191+ putIState ist{ idris_optimisation =

192+ addDef n (Optimise is False) (idris_optimisation ist) }

193+ addIBC (IBCOpt n)

194+

195+-- Get the list of (index, name) of inaccessible arguments from the type.

196+inaccessibleArgs :: Int -> PTerm -> [(Int, Name)]

197+inaccessibleArgs i (PPi (Imp _ _ _) n Placeholder t)

198+ = (i,n) : inaccessibleArgs (i+1) t -- unbound implicit

199+inaccessibleArgs i (PPi plicity n ty t)

200+ | InaccessibleArg `elem` pargopts plicity

201+ = (i,n) : inaccessibleArgs (i+1) t -- an .{erased : Implicit}

202+ | otherwise

203+ = inaccessibleArgs (i+1) t -- a {regular : Implicit}

204+inaccessibleArgs _ _ = []

173

205

174elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring ->

206elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring ->

175 FC -> FnOpts -> Name -> PTerm -> Idris ()

207 FC -> FnOpts -> Name -> PTerm -> Idris ()

176−elabPostulate info syn doc fc opts n ty

208+elabPostulate info syn doc fc opts n ty = do

177− = do elabType info syn doc [] fc opts n ty

209+ elabType info syn doc [] fc opts n ty

178− -- make sure it's collapsible, so it is never needed at run time

210+ putIState . (\ist -> ist{ idris_postulates = S.insert n (idris_postulates ist) }) =<< getIState

179− -- start by getting the elaborated type

211+ addIBC (IBCPostulate n)

180− ctxt <- getContext

212+

181− fty <- case lookupTy n ctxt of

182− [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen!

183− [ty] -> return ty

184− ist <- getIState

185− let (ap, _) = unApply (getRetTy (normalise ctxt [] fty))

186− logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

187− let postOK = case ap of

188− P _ tn _ -> case lookupCtxt tn

189− (idris_optimisation ist) of

190− [oi] -> collapsible oi

191− _ -> False

192− _ -> False

193− when (not postOK)

194− $ tclift $ tfail (At fc (NonCollapsiblePostulate n))

195− -- remove it from the deferred definitions list

213+ -- remove it from the deferred definitions list

196− solveDeferred n

214+ solveDeferred n

197

215

198elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris ()

216elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris ()

199elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

217elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

@@ -202,13 +220,15 @@ elabData info syn doc argDocs fc opts (PLaterdecl n t_in)

202 checkUndefined fc n

220 checkUndefined fc n

203 ctxt <- getContext

221 ctxt <- getContext

204 i <- getIState

222 i <- getIState

223+ -- TODO think: something more in info?

205− t_in <- implicit syn n t_in

224+ t_in <- implicit info syn n t_in

206 let t = addImpl i t_in

225 let t = addImpl i t_in

207 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

226 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

208 (erun fc (build i info False [] n t))

227 (erun fc (build i info False [] n t))

209 def' <- checkDef fc defer

228 def' <- checkDef fc defer

210 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def'

229 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def'

211 addDeferredTyCon def''

230 addDeferredTyCon def''

231+ addIBC (IBCDef n)

212 mapM_ (elabCaseBlock info []) is

232 mapM_ (elabCaseBlock info []) is

213 (cty, _) <- recheckC fc [] t'

233 (cty, _) <- recheckC fc [] t'

214 logLvl 2 $ "---> " ++ show cty

234 logLvl 2 $ "---> " ++ show cty

@@ -220,7 +240,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

220 undef <- isUndefined fc n

240 undef <- isUndefined fc n

221 ctxt <- getContext

241 ctxt <- getContext

222 i <- getIState

242 i <- getIState

223− t_in <- implicit syn n t_in

243+ t_in <- implicit info syn n t_in

224 let t = addImpl i t_in

244 let t = addImpl i t_in

225 ((t', defer, is), log) <-

245 ((t', defer, is), log) <-

226 tclift $ elaborate ctxt n (TType (UVal 0)) []

246 tclift $ elaborate ctxt n (TType (UVal 0)) []

@@ -236,7 +256,8 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

236 logLvl 2 $ "---> " ++ show cty

256 logLvl 2 $ "---> " ++ show cty

237 -- temporary, to check cons

257 -- temporary, to check cons

238 when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

258 when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

259+ let cnameinfo = cinfo info (map cname dcons)

239− cons <- mapM (elabCon info syn n codata) dcons

260+ cons <- mapM (elabCon cnameinfo syn n codata) dcons

240 ttag <- getName

261 ttag <- getName

241 i <- getIState

262 i <- getIState

242 let as = map (const Nothing) (getArgTys cty)

263 let as = map (const Nothing) (getArgTys cty)

@@ -253,15 +274,30 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

253 let metainf = DataMI params

274 let metainf = DataMI params

254 addIBC (IBCMetaInformation n metainf)

275 addIBC (IBCMetaInformation n metainf)

255 -- TMP HACK! Make this a data option

276 -- TMP HACK! Make this a data option

256− when (n /= sUN "Lazy'") $ collapseCons n cons

257 updateContext (addDatatype (Data n ttag cty cons))

277 updateContext (addDatatype (Data n ttag cty cons))

258 updateContext (setMetaInformation n metainf)

278 updateContext (setMetaInformation n metainf)

259 mapM_ (checkPositive n) cons

279 mapM_ (checkPositive n) cons

280+

281+ -- if there's exactly one constructor,

282+ -- mark both the type and the constructor as detaggable

283+ case cons of

284+ [(cn,ct)] -> setDetaggable cn >> setDetaggable n

285+ >> addIBC (IBCOpt cn) >> addIBC (IBCOpt n)

286+ _ -> return ()

287+

288+ -- create an eliminator

260− if DefaultEliminator `elem` opts

289+ when (DefaultEliminator `elem` opts) $

261− then evalStateT (elabEliminator params n t dcons info) Map.empty

290+ evalStateT (elabEliminator params n t dcons info) Map.empty

262− else return ()

263 where

291 where

292+ setDetaggable :: Name -> Idris ()

293+ setDetaggable n = do

294+ ist <- getIState

295+ let opt = idris_optimisation ist

296+ case lookupCtxt n opt of

297+ [oi] -> putIState ist{ idris_optimisation = addDef n oi{ detaggable = True } opt }

298+ _ -> putIState ist{ idris_optimisation = addDef n (Optimise [] True) opt }

299+

264− checkDefinedAs fc n t ctxt

300+ checkDefinedAs fc n t ctxt

265 = case lookupDef n ctxt of

301 = case lookupDef n ctxt of

266 [] -> return ()

302 [] -> return ()

267 [TyDecl _ ty] ->

303 [TyDecl _ ty] ->

@@ -319,6 +355,21 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

319 | otherwise = count n ts

355 | otherwise = count n ts

320 mParam args (_ : rest) = Nothing : mParam args rest

356 mParam args (_ : rest) = Nothing : mParam args rest

321

357

358+ cname (_, _, n, _, _, _) = n

359+

360+ -- Abuse of ElabInfo.

361+ -- TODO Contemplate whether the ElabInfo type needs modification.

362+ cinfo :: ElabInfo -> [Name] -> ElabInfo

363+ cinfo info ds

364+ = let newps = params info

365+ dsParams = map (\n -> (n, [])) ds

366+ newb = addAlist dsParams (inblock info)

367+ l = liftname info in

368+ info { params = newps,

369+ inblock = newb,

370+ liftname = id -- Is this appropriate?

371+ }

372+

322type EliminatorState = StateT (Map.Map String Int) Idris

373type EliminatorState = StateT (Map.Map String Int) Idris

323

374

324-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

375-- TODO: Use uniqueName for generating names, rewrite everything to use idris_implicits instead of manual splitting, generally just rewrite

@@ -728,7 +779,8 @@ elabRecord :: ElabInfo -> SyntaxInfo -> Docstring -> FC -> Name ->

728 PTerm -> Docstring -> Name -> PTerm -> Idris ()

779 PTerm -> Docstring -> Name -> PTerm -> Idris ()

729elabRecord info syn doc fc tyn ty cdoc cn cty

780elabRecord info syn doc fc tyn ty cdoc cn cty

730 = do elabData info syn doc [] fc [] (PDatadecl tyn ty [(cdoc, [], cn, cty, fc, [])])

781 = do elabData info syn doc [] fc [] (PDatadecl tyn ty [(cdoc, [], cn, cty, fc, [])])

782+ -- TODO think: something more in info?

731− cty' <- implicit syn cn cty

783+ cty' <- implicit info syn cn cty

732 i <- getIState

784 i <- getIState

733 cty <- case lookupTy cn (tt_ctxt i) of

785 cty <- case lookupTy cn (tt_ctxt i) of

734 [t] -> return (delab i t)

786 [t] -> return (delab i t)

@@ -750,7 +802,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

750 where

802 where

751-- syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in }

803-- syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in }

752

804

753− isNonImp (PExp _ _ _, a) = Just a

805+ isNonImp (PExp _ _ _ _, a) = Just a

754 isNonImp _ = Nothing

806 isNonImp _ = Nothing

755

807

756 tryElabDecl info (fn, ty, val)

808 tryElabDecl info (fn, ty, val)

@@ -833,15 +885,22 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

833 (map pexp rhsArgs)) []

885 (map pexp rhsArgs)) []

834 return (pn, pfnTy, PClauses fc [] setname [pclause])

886 return (pn, pfnTy, PClauses fc [] setname [pclause])

835

887

888+-- FIXME: 'forcenames' is an almighty hack! Need a better way of

889+-- erasing non-forceable things

890+-- ^^^

891+-- TODO: the above is a comment from the past;

892+-- forcenames is probably no longer needed

836elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

893elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

837 (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)

894 (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)

838elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

895elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

839 = do checkUndefined fc n

896 = do checkUndefined fc n

840 ctxt <- getContext

897 ctxt <- getContext

841 i <- getIState

898 i <- getIState

842− t_in <- implicit syn n (if codata then mkLazy t_in else t_in)

899+ t_in <- implicit info syn n (if codata then mkLazy t_in else t_in)

843 let t = addImpl i t_in

900 let t = addImpl i t_in

844 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t

901 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t

902+ let inacc = inaccessibleArgs 0 t

903+ logLvl 5 $ "Inaccessible args: " ++ show inacc

845 ((t', defer, is), log) <-

904 ((t', defer, is), log) <-

846 tclift $ elaborate ctxt n (TType (UVal 0)) []

905 tclift $ elaborate ctxt n (TType (UVal 0)) []

847 (errAt "constructor " n (erun fc (build i info False [] n t)))

906 (errAt "constructor " n (erun fc (build i info False [] n t)))

@@ -859,10 +918,8 @@ elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

859 checkDocs fc argDocs t_in

918 checkDocs fc argDocs t_in

860 addDocStr n doc argDocs

919 addDocStr n doc argDocs

861 addIBC (IBCDoc n)

920 addIBC (IBCDoc n)

862− let fs = map (getNamePos 0 t) forcenames

921+ saveInaccArgs n inacc

863− -- FIXME: 'forcenames' is an almighty hack! Need a better way of

922+ addIBC (IBCOpt n)

864− -- erasing non-forceable things

865− forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty'

866 return (n, cty')

923 return (n, cty')

867 where

924 where

868 tyIs (Bind n b sc) = tyIs sc

925 tyIs (Bind n b sc) = tyIs sc

@@ -873,7 +930,7 @@ elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

873

930

874 mkLazy (PPi pl n ty sc)

931 mkLazy (PPi pl n ty sc)

875 = let ty' = if getTyName ty

932 = let ty' = if getTyName ty

876− then PApp fc (PRef fc (sUN "Lazy'"))

933+ then PApp fc (PRef fc (sUN "Lazy'"))

877 [pexp (PRef fc (sUN "LazyCodata")),

934 [pexp (PRef fc (sUN "LazyCodata")),

878 pexp ty]

935 pexp ty]

879 else ty in

936 else ty in

@@ -895,6 +952,10 @@ elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

895elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

952elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

896elabClauses info fc opts n_in cs = let n = liftname info n_in in

953elabClauses info fc opts n_in cs = let n = liftname info n_in in

897 do ctxt <- getContext

954 do ctxt <- getContext

955+ ist <- getIState

956+ let inacc = case lookupCtxt n (idris_optimisation ist) of

957+ [Optimise inacc _] -> map fst inacc

958+ _ -> []

898 -- Check n actually exists, with no definition yet

959 -- Check n actually exists, with no definition yet

899 let tys = lookupTy n ctxt

960 let tys = lookupTy n ctxt

900 let reflect = Reflection `elem` opts

961 let reflect = Reflection `elem` opts

@@ -906,33 +967,19 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

906 tclift $ tfail $ At fc (NoTypeDecl n)

967 tclift $ tfail $ At fc (NoTypeDecl n)

907 [ty] -> return ty

968 [ty] -> return ty

908 let atys = map snd (getArgTys fty)

969 let atys = map snd (getArgTys fty)

909− pats_in <- mapM (elabClause info opts)

970+ cs_elab <- mapM (elabClause info opts)

910 (zip [0..] cs)

971 (zip [0..] cs)

972+ let (pats_in, cs_full) = unzip cs_elab

973+

911 logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in

974 logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in

912

975

913− -- if the return type of 'ty' is collapsible, the optimised version should

914− -- just do nothing

915− ist <- getIState

916− let (ap, _) = unApply (getRetTy fty)

917− logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

918− -- FIXME: Really ought to only do this for total functions!

919− let doNothing = case ap of

920− P _ tn _ -> case lookupCtxt tn

921− (idris_optimisation ist) of

922− [oi] -> collapsible oi

923− _ -> False

924− _ -> False

925 solveDeferred n

976 solveDeferred n

977+

926 ist <- getIState

978 ist <- getIState

927− when doNothing $

928− case lookupCtxt n (idris_optimisation ist) of

929− [oi] -> do let opts = addDef n (oi { collapsible = True })

930− (idris_optimisation ist)

931− putIState (ist { idris_optimisation = opts })

932− _ -> do let opts = addDef n (Optimise True False [] [])

979+ let opts = addDef n (Optimise [] False) (idris_optimisation ist)

933− (idris_optimisation ist)

934− putIState (ist { idris_optimisation = opts })

980+ in putIState (ist { idris_optimisation = opts })

935− addIBC (IBCOpt n)

981+ addIBC (IBCOpt n)

982+

936 ist <- getIState

983 ist <- getIState

937 let pats = map (simple_lhs (tt_ctxt ist)) $ doTransforms ist pats_in

984 let pats = map (simple_lhs (tt_ctxt ist)) $ doTransforms ist pats_in

938

985

@@ -942,11 +989,8 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

942 let tcase = opt_typecase (idris_options ist)

989 let tcase = opt_typecase (idris_options ist)

943

990

944 -- Summary of what's about to happen: Definitions go:

991 -- Summary of what's about to happen: Definitions go:

945−

992+ --

946− -- pats_in -> pats -> optpats

993+ -- pats_in -> pats -> pdef -> pdef'

947− -- pdef comes from pats,

948− -- optpdef comes from optpats

949− -- Then pdef' is optpdef with forcing/collapsing applied everywhere

950

994

951 -- addCaseDef builds case trees from <pdef> and <pdef'>

995 -- addCaseDef builds case trees from <pdef> and <pdef'>

952

996

@@ -975,24 +1019,16 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

975

1019

976 numArgs <- tclift $ sameLength pdef

1020 numArgs <- tclift $ sameLength pdef

977

1021

978− -- patterns after collapsing optimisation applied

979− -- (i.e. check if the function should do nothing at run time)

980− optpats <- if doNothing

981− then return $ [Right (mkApp (P Bound n Erased)

982− (take numArgs (repeat Erased)), Erased)]

983− else stripCollapsed pats

984−

985 case specNames opts of

1022 case specNames opts of

986 Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats

1023 Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats

987 _ -> return ()

1024 _ -> return ()

988

1025

989− let optpdef = map debind optpats -- \$ map (simple_lhs (tt_ctxt ist)) optpats

990 tree@(CaseDef scargs sc _) <- tclift $

1026 tree@(CaseDef scargs sc _) <- tclift $

991− simpleCase tcase False reflect CompileTime fc atys pdef

1027+ simpleCase tcase False reflect CompileTime fc inacc atys pdef

992 cov <- coverage

1028 cov <- coverage

993 pmissing <-

1029 pmissing <-

994 if cov && not (hasDefault cs)

1030 if cov && not (hasDefault cs)

995− then do missing <- genClauses fc n (map getLHS pdef) cs

1031+ then do missing <- genClauses fc n (map getLHS pdef) cs_full

996 -- missing <- genMissing n scargs sc

1032 -- missing <- genMissing n scargs sc

997 missing' <- filterM (checkPossible info fc True n) missing

1033 missing' <- filterM (checkPossible info fc True n) missing

998 let clhs = map getLHS pdef

1034 let clhs = map getLHS pdef

@@ -1010,7 +1046,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1010 let pcover = null pmissing

1046 let pcover = null pmissing

1011

1047

1012 -- pdef' is the version that gets compiled for run-time

1048 -- pdef' is the version that gets compiled for run-time

1013− pdef_in' <- applyOpts optpdef

1049+ pdef_in' <- applyOpts pdef

1014 let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'

1050 let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'

1015

1051

1016 logLvl 5 $ "After data structure transformations:\n" ++ show pdef'

1052 logLvl 5 $ "After data structure transformations:\n" ++ show pdef'

@@ -1037,11 +1073,12 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1037 let knowncovering = (pcover && cov) || AssertTotal `elem` opts

1073 let knowncovering = (pcover && cov) || AssertTotal `elem` opts

1038

1074

1039 tree' <- tclift $ simpleCase tcase knowncovering reflect

1075 tree' <- tclift $ simpleCase tcase knowncovering reflect

1040− RunTime fc atys pdef'

1076+ RunTime fc inacc atys pdef'

1041− logLvl 3 (show tree)

1077+ logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree

1042 logLvl 3 $ "Optimised: " ++ show tree'

1078 logLvl 3 $ "Optimised: " ++ show tree'

1043 ctxt <- getContext

1079 ctxt <- getContext

1044 ist <- getIState

1080 ist <- getIState

1081+ let opt = idris_optimisation ist

1045 putIState (ist { idris_patdefs = addDef n (force pdef', force pmissing)

1082 putIState (ist { idris_patdefs = addDef n (force pdef', force pmissing)

1046 (idris_patdefs ist) })

1083 (idris_patdefs ist) })

1047 let caseInfo = CaseInfo (inlinable opts) (dictionary opts)

1084 let caseInfo = CaseInfo (inlinable opts) (dictionary opts)

@@ -1051,6 +1088,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1051 reflect

1088 reflect

1052 (AssertTotal `elem` opts)

1089 (AssertTotal `elem` opts)

1053 atys

1090 atys

1091+ inacc

1054 pats

1092 pats

1055 pdef pdef pdef_inl pdef' ty)

1093 pdef pdef pdef_inl pdef' ty)

1056 addIBC (IBCDef n)

1094 addIBC (IBCDef n)

@@ -1067,7 +1105,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

1067 let used = findUsedArgs sc' scargs'

1105 let used = findUsedArgs sc' scargs'

1068 -- let scg = buildSCG i sc scargs

1106 -- let scg = buildSCG i sc scargs

1069 -- add SCG later, when checking totality

1107 -- add SCG later, when checking totality

1070− let cg = CGInfo scargs' calls [] used []

1108+ let cg = CGInfo scargs' calls [] used [] -- TODO: remove this, not needed anymore

1071 logLvl 2 $ "Called names: " ++ show cg

1109 logLvl 2 $ "Called names: " ++ show cg

1072 addToCG n cg

1110 addToCG n cg

1073 addToCalledG n (nub (map fst calls)) -- plus names in type!

1111 addToCalledG n (nub (map fst calls)) -- plus names in type!

@@ -1288,7 +1326,7 @@ checkPossible info fc tcgen fname lhs_in

1288 ((P _ x _, _), (P _ y _, _)) -> x == y

1326 ((P _ x _, _), (P _ y _, _)) -> x == y

1289 _ -> False

1327 _ -> False

1290

1328

1291−getFixedInType i env (PExp _ _ _ : is) (Bind n (Pi t) sc)

1329+getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)

1292 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

1330 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

1293getFixedInType i env (_ : is) (Bind n (Pi t) sc)

1331getFixedInType i env (_ : is) (Bind n (Pi t) sc)

1294 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

1332 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

@@ -1350,16 +1388,19 @@ propagateParams ps t (PRef fc n)

1350 = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)

1388 = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)

1351propagateParams ps t x = x

1389propagateParams ps t x = x

1352

1390

1391+-- Return the elaborated LHS/RHS, and the original LHS with implicits added

1353elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

1392elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

1354− Idris (Either Term (Term, Term))

1393+ Idris (Either Term (Term, Term), PTerm)

1355elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

1394elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

1356 = do let tcgen = Dictionary `elem` opts

1395 = do let tcgen = Dictionary `elem` opts

1396+ i <- get

1397+ let lhs = addImpl i lhs_in

1357 b <- checkPossible info fc tcgen fname lhs_in

1398 b <- checkPossible info fc tcgen fname lhs_in

1358 case b of

1399 case b of

1359 True -> tclift $ tfail (At fc

1400 True -> tclift $ tfail (At fc

1360 (Msg $ show lhs_in ++ " is a valid case"))

1401 (Msg $ show lhs_in ++ " is a valid case"))

1361 False -> do ptm <- mkPatTm lhs_in

1402 False -> do ptm <- mkPatTm lhs_in

1362− return (Left ptm)

1403+ return (Left ptm, lhs)

1363elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1404elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1364 = do let tcgen = Dictionary `elem` opts

1405 = do let tcgen = Dictionary `elem` opts

1365 ctxt <- getContext

1406 ctxt <- getContext

@@ -1416,10 +1457,10 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1416 -- Elaborate where block

1457 -- Elaborate where block

1417 ist <- getIState

1458 ist <- getIState

1418 windex <- getName

1459 windex <- getName

1419− let winfo = pinfo (pvars ist lhs_tm) whereblock windex

1420 let decls = nub (concatMap declared whereblock)

1460 let decls = nub (concatMap declared whereblock)

1421 let defs = nub (decls ++ concatMap defined whereblock)

1461 let defs = nub (decls ++ concatMap defined whereblock)

1422 let newargs = pvars ist lhs_tm

1462 let newargs = pvars ist lhs_tm

1463+ let winfo = pinfo info newargs defs windex

1423 let wb = map (expandParamsD False ist decorate newargs defs) whereblock

1464 let wb = map (expandParamsD False ist decorate newargs defs) whereblock

1424

1465

1425 -- Split the where block into declarations with a type, and those

1466 -- Split the where block into declarations with a type, and those

@@ -1428,7 +1469,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1428 let (wbefore, wafter) = sepBlocks wb

1469 let (wbefore, wafter) = sepBlocks wb

1429

1470

1430 logLvl 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter

1471 logLvl 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter

1431− mapM_ (elabDecl' EAll info) wbefore

1472+ mapM_ (elabDecl' EAll winfo) wbefore

1432 -- Now build the RHS, using the type of the LHS as the goal.

1473 -- Now build the RHS, using the type of the LHS as the goal.

1433 i <- getIState -- new implicits from where block

1474 i <- getIState -- new implicits from where block

1434 logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))

1475 logLvl 5 (showTmImpls (expandParams decorate newargs defs (defs \\ decls) rhs_in))

@@ -1443,7 +1484,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1443 mapM_ setinj (nub (params ++ inj))

1484 mapM_ setinj (nub (params ++ inj))

1444 setNextName

1485 setNextName

1445 (_, _, is) <- errAt "right hand side of " fname

1486 (_, _, is) <- errAt "right hand side of " fname

1446− (erun fc (build i info False opts fname rhs))

1487+ (erun fc (build i winfo False opts fname rhs))

1447 errAt "right hand side of " fname

1488 errAt "right hand side of " fname

1448 (erun fc $ psolve lhs_tm)

1489 (erun fc $ psolve lhs_tm)

1449 hs <- get_holes

1490 hs <- get_holes

@@ -1471,8 +1512,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1471 -- Now the remaining deferred (i.e. no type declarations) clauses

1512 -- Now the remaining deferred (i.e. no type declarations) clauses

1472 -- from the where block

1513 -- from the where block

1473

1514

1474− mapM_ (elabDecl' EAll info) wafter

1515+ mapM_ (elabDecl' EAll winfo) wafter

1475− mapM_ (elabCaseBlock info opts) is

1516+ mapM_ (elabCaseBlock winfo opts) is

1476

1517

1477 ctxt <- getContext

1518 ctxt <- getContext

1478 logLvl 5 $ "Rechecking"

1519 logLvl 5 $ "Rechecking"

@@ -1500,8 +1541,21 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1500 when (rev || ErrorReverse `elem` opts) $ do

1541 when (rev || ErrorReverse `elem` opts) $ do

1501 addIBC (IBCErrRev (crhs, clhs))

1542 addIBC (IBCErrRev (crhs, clhs))

1502 addErrRev (crhs, clhs)

1543 addErrRev (crhs, clhs)

1503− return $ Right (clhs, crhs)

1544+ return $ (Right (clhs, crhs), lhs)

1504 where

1545 where

1546+ pinfo :: ElabInfo -> [(Name, PTerm)] -> [Name] -> Int -> ElabInfo

1547+ pinfo info ns ds i

1548+ = let newps = params info ++ ns

1549+ dsParams = map (\n -> (n, map fst newps)) ds

1550+ newb = addAlist dsParams (inblock info)

1551+ l = liftname info in

1552+ info { params = newps,

1553+ inblock = newb,

1554+ liftname = id -- (\n -> case lookupCtxt n newb of

1555+ -- Nothing -> n

1556+ -- _ -> MN i (show n)) . l

1557+ }

1558+

1505 mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t []

1559 mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t []

1506 mkLHSapp t = t

1560 mkLHSapp t = t

1507

1561

@@ -1524,19 +1578,6 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

1524 (b : bf, af)

1578 (b : bf, af)

1525 sepBlocks' ns [] = ([], [])

1579 sepBlocks' ns [] = ([], [])

1526

1580

1527− pinfo ns ps i

1528− = let ds = concatMap declared ps

1529− newps = params info ++ ns

1530− dsParams = map (\n -> (n, map fst newps)) ds

1531− newb = addAlist dsParams (inblock info)

1532− l = liftname info in

1533− info { params = newps,

1534− inblock = newb,

1535− liftname = id -- (\n -> case lookupCtxt n newb of

1536− -- Nothing -> n

1537− -- _ -> MN i (show n)) . l

1538− }

1539−

1540

1581

1541 -- if a hole is just an argument/result of a case block, treat it as

1582 -- if a hole is just an argument/result of a case block, treat it as

1542 -- the unit type. Hack to help elaborate case in do blocks.

1583 -- the unit type. Hack to help elaborate case in do blocks.

@@ -1667,7 +1708,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1667 mapM_ (elabCaseBlock info opts) is

1708 mapM_ (elabCaseBlock info opts) is

1668 logLvl 5 ("Checked RHS " ++ show rhs')

1709 logLvl 5 ("Checked RHS " ++ show rhs')

1669 (crhs, crhsty) <- recheckC fc [] rhs'

1710 (crhs, crhsty) <- recheckC fc [] rhs'

1670− return $ Right (clhs, crhs)

1711+ return $ (Right (clhs, crhs), lhs)

1671 where

1712 where

1672 getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t

1713 getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t

1673 getImps _ = []

1714 getImps _ = []

@@ -1801,7 +1842,7 @@ elabClass info syn doc fc constraints tn ps ds

1801

1842

1802 getMName (PTy _ _ _ _ _ n _) = nsroot n

1843 getMName (PTy _ _ _ _ _ n _) = nsroot n

1803 tdecl allmeths (PTy doc _ syn _ o n t)

1844 tdecl allmeths (PTy doc _ syn _ o n t)

1804− = do t' <- implicit' syn allmeths n t

1845+ = do t' <- implicit' info syn allmeths n t

1805 logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

1846 logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

1806 return ( (n, (toExp (map fst ps) Exp t')),

1847 return ( (n, (toExp (map fst ps) Exp t')),

1807 (n, (doc, o, (toExp (map fst ps) Imp t'))),

1848 (n, (doc, o, (toExp (map fst ps) Imp t'))),

@@ -2005,7 +2046,8 @@ elabInstance info syn what fc cs n ps t expn ds = do

2005 -- TODO: largely based upon elabType' - should try to abstract

2046 -- TODO: largely based upon elabType' - should try to abstract

2006 elabFindOverlapping i ci iname syn t

2047 elabFindOverlapping i ci iname syn t

2007 = do ty' <- addUsingConstraints syn fc t

2048 = do ty' <- addUsingConstraints syn fc t

2049+ -- TODO think: something more in info?

2008− ty' <- implicit syn iname ty'

2050+ ty' <- implicit info syn iname ty'

2009 let ty = addImpl i ty'

2051 let ty = addImpl i ty'

2010 ctxt <- getContext

2052 ctxt <- getContext

2011 ((tyT, _, _), _) <-

2053 ((tyT, _, _), _) <-

@@ -2043,9 +2085,9 @@ elabInstance info syn what fc cs n ps t expn ds = do

2043 methArgs i (PPi (Imp _ _ _) n ty sc)

2085 methArgs i (PPi (Imp _ _ _) n ty sc)

2044 = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc

2086 = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc

2045 methArgs i (PPi (Exp _ _ _) n ty sc)

2087 methArgs i (PPi (Exp _ _ _) n ty sc)

2046− = PExp 0 [] (PRef fc (sMN i "meth")) : methArgs (i+1) sc

2088+ = PExp 0 [] (sMN 0 "marg") (PRef fc (sMN i "meth")) : methArgs (i+1) sc

2047 methArgs i (PPi (Constraint _ _) n ty sc)

2089 methArgs i (PPi (Constraint _ _) n ty sc)

2048− = PConstraint 0 [] (PResolveTC fc) : methArgs (i+1) sc

2090+ = PConstraint 0 [] (sMN 0 "marg") (PResolveTC fc) : methArgs (i+1) sc

2049 methArgs i _ = []

2091 methArgs i _ = []

2050

2092

2051 papp fc f [] = f

2093 papp fc f [] = f

@@ -2061,7 +2103,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

2061 _ -> return ps'

2103 _ -> return ps'

2062 getWParams (_ : ps) = getWParams ps

2104 getWParams (_ : ps) = getWParams ps

2063

2105

2064− decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

2106+ decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

2065 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

2107 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

2066

2108

2067 mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t

2109 mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t

src/Idris/ElabTerm.hs+5−13

@@ -3,10 +3,12 @@

3module Idris.ElabTerm where

4

5import Idris.AbsSyntax

6+import Idris.AbsSyntaxTree

6import Idris.DSL

7import Idris.DSL

7import Idris.Delaborate

8import Idris.Delaborate

8import Idris.Error

9import Idris.Error

9import Idris.ProofSearch

10import Idris.ProofSearch

11+import Idris.Output (pshow)

10

12

11import Idris.Core.Elaborate hiding (Tactic(..))

13import Idris.Core.Elaborate hiding (Tactic(..))

12import Idris.Core.TT

14import Idris.Core.TT

@@ -26,16 +28,6 @@ import qualified Data.Text as T

26

28

27import Debug.Trace

29import Debug.Trace

28

30

29−-- Data to pass to recursively called elaborators; e.g. for where blocks,

30−-- paramaterised declarations, etc.

31−

32−data ElabInfo = EInfo { params :: [(Name, PTerm)],

33− inblock :: Ctxt [Name], -- names in the block, and their params

34− liftname :: Name -> Name,

35− namespace :: Maybe [String] }

36−

37−toplevel = EInfo [] emptyContext id Nothing

38−

39-- Using the elaborator, convert a term in raw syntax to a fully

31-- Using the elaborator, convert a term in raw syntax to a fully

40-- elaborated, typechecked term.

32-- elaborated, typechecked term.

41--

33--

@@ -473,7 +465,7 @@ elab ist info pattern opts fn tm

473 elabArgs ist (ina || not isinf, guarded, inty)

465 elabArgs ist (ina || not isinf, guarded, inty)

474 [] fc False f ns'

466 [] fc False f ns'

475 (f == sUN "Force")

467 (f == sUN "Force")

476− (map (\x -> (lazyarg x, getTm x)) eargs)

468+ (map (\x -> (False, getTm x)) eargs) -- TODO: remove this False arg

477 solve

469 solve

478 ivs' <- get_instances

470 ivs' <- get_instances

479 -- Attempt to resolve any type classes which have 'complete' types,

471 -- Attempt to resolve any type classes which have 'complete' types,

@@ -696,7 +688,7 @@ elab ist info pattern opts fn tm

696 where

688 where

697 mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)

689 mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)

698 mkDelay t = let fc = fileFC "Delay" in

690 mkDelay t = let fc = fileFC "Delay" in

699− addImpl ist (PApp fc (PRef fc (sUN "Delay"))

691+ addImpl ist (PApp fc (PRef fc (sUN "Delay"))

700 [pexp t])

692 [pexp t])

701

693

702 insertCoerce ina t =

694 insertCoerce ina t =

@@ -732,7 +724,7 @@ elab ist info pattern opts fn tm

732 = elabArgs ist ina failed fc r f ns force args

724 = elabArgs ist ina failed fc r f ns force args

733 elabArgs ist ina failed fc r f ((argName, holeName):ns) force ((lazy, t) : args)

725 elabArgs ist ina failed fc r f ((argName, holeName):ns) force ((lazy, t) : args)

734 | lazy && not pattern

726 | lazy && not pattern

735− = elabArg argName holeName (PApp bi (PRef bi (sUN "lazy"))

727+ = elabArg argName holeName (PApp bi (PRef bi (sUN "Delay"))

736 [pimp (sUN "a") Placeholder True,

728 [pimp (sUN "a") Placeholder True,

737 pexp t])

729 pexp t])

738 | otherwise = elabArg argName holeName t

730 | otherwise = elabArg argName holeName t

src/Idris/Erasure.hsnew file+505

@@ -0,0 +1,505 @@

1+{-# LANGUAGE PatternGuards #-}

2+

3+module Idris.Erasure (performUsageAnalysis, mkFieldName) where

4+

5+import Idris.AbsSyntax

6+import Idris.Core.CaseTree

7+import Idris.Core.TT

8+import Idris.Core.Evaluate

9+import Idris.Primitives

10+import Idris.Error

11+

12+import Debug.Trace

13+import System.IO.Unsafe

14+

15+import Control.Arrow

16+import Control.Applicative

17+import Control.Monad.State

18+import Data.Maybe

19+import Data.List

20+import qualified Data.Set as S

21+import qualified Data.IntSet as IS

22+import qualified Data.Map as M

23+import qualified Data.IntMap as IM

24+import Data.Set (Set)

25+import Data.IntSet (IntSet)

26+import Data.Map (Map)

27+import Data.IntMap (IntMap)

28+import Data.Text (pack)

29+import qualified Data.Text as T

30+

31+-- UseMap maps names to the set of used (reachable) argument positions.

32+type UseMap = Map Name (IntMap (Set Reason))

33+

34+data Arg = Arg Int | Result deriving (Eq, Ord)

35+

36+instance Show Arg where

37+ show (Arg i) = show i

38+ show Result = "*"

39+

40+type Node = (Name, Arg)

41+type Deps = Map Cond DepSet

42+type Reason = (Name, Int) -- function name, argument index

43+

44+-- Nodes along with sets of reasons for every one.

45+type DepSet = Map Node (Set Reason)

46+

47+-- "Condition" is the conjunction

48+-- of elementary assumptions along the path from the root.

49+-- Elementary assumption (f, i) means that "function f uses the argument i".

50+type Cond = Set Node

51+

52+-- Variables carry certain information with them.

53+data VarInfo = VI

54+ { viDeps :: DepSet -- dependencies drawn in by the variable

55+ , viFunArg :: Maybe Int -- which function argument this variable came from (defined only for patvars)

56+ , viMethod :: Maybe Name -- name of the metamethod represented by the var, if any

57+ }

58+ deriving Show

59+

60+type Vars = Map Name VarInfo

61+

62+-- Perform usage analysis, write the relevant information in the internal

63+-- structures, returning the list of reachable names.

64+performUsageAnalysis :: Idris [Name]

65+performUsageAnalysis = do

66+ ctx <- tt_ctxt <$> getIState

67+ mainName <- getMainName <$> getIState

68+

69+ case mainName of

70+ Left reason -> return [] -- no main -> not compiling -> reachability irrelevant

71+ Right main -> do

72+ ci <- idris_classes <$> getIState

73+ cg <- idris_callgraph <$> getIState

74+ opt <- idris_optimisation <$> getIState

75+

76+ -- Build the dependency graph.

77+ let depMap = buildDepMap ci ctx main

78+

79+ -- Search for reachable nodes in the graph.

80+ let (residDeps, (reachableNames, minUse)) = minimalUsage depMap

81+ usage = M.toList minUse

82+

83+ -- Print some debug info.

84+ logLvl 5 $ "Original deps:\n" ++ unlines (map fmtItem . M.toList $ depMap)

85+ logLvl 3 $ "Reachable names:\n" ++ unlines (map (indent . show) . S.toList $ reachableNames)

86+ logLvl 4 $ "Minimal usage:\n" ++ fmtUseMap usage

87+ logLvl 5 $ "Residual deps:\n" ++ unlines (map fmtItem . M.toList $ residDeps)

88+

89+ -- Check that everything reachable is accessible.

90+ checkEnabled <- (WarnReach `elem`) . opt_cmdline . idris_options <$> getIState

91+ when checkEnabled $

92+ mapM_ (checkAccessibility opt) usage

93+

94+ -- Check that no postulates are reachable.

95+ reachablePostulates <- S.intersection reachableNames . idris_postulates <$> getIState

96+ when (not . S.null $ reachablePostulates)

97+ $ ifail ("reachable postulates:\n" ++ intercalate "\n" [" " ++ show n | n <- S.toList reachablePostulates])

98+

99+ -- Store the usage info in the internal state.

100+ mapM_ (storeUsage cg) usage

101+

102+ return $ S.toList reachableNames

103+ where

104+ getMainName :: IState -> Either Err Name

105+ getMainName ist = case lookupCtxtName n (idris_implicits ist) of

106+ [(n', _)] -> Right n'

107+ [] -> Left (NoSuchVariable n)

108+ more -> Left (CantResolveAlts (map (show . fst) more))

109+ where

110+ n = sNS (sUN "main") ["Main"]

111+

112+ indent = (" " ++)

113+

114+ fmtItem :: (Cond, DepSet) -> String

115+ fmtItem (cond, deps) = indent $ show (S.toList cond) ++ " -> " ++ show (M.toList deps)

116+

117+ fmtUseMap :: [(Name, IntMap (Set Reason))] -> String

118+ fmtUseMap = unlines . map (\(n,is) -> indent $ show n ++ " -> " ++ fmtIxs is)

119+

120+ fmtIxs :: IntMap (Set Reason) -> String

121+ fmtIxs = intercalate ", " . map fmtArg . IM.toList

122+ where

123+ fmtArg (i, rs)

124+ | S.null rs = show i

125+ | otherwise = show i ++ " from " ++ intercalate ", " (map show $ S.toList rs)

126+

127+ storeUsage :: Ctxt CGInfo -> (Name, IntMap (Set Reason)) -> Idris ()

128+ storeUsage cg (n, args)

129+ | Just x <- lookupCtxtExact n cg

130+ = addToCG n x{ usedpos = flat } -- functions

131+

132+ | otherwise

133+ = addToCG n (CGInfo [] [] [] [] flat) -- data ctors

134+ where

135+ flat = [(i, S.toList rs) | (i,rs) <- IM.toList args]

136+

137+ checkAccessibility :: Ctxt OptInfo -> (Name, IntMap (Set Reason)) -> Idris ()

138+ checkAccessibility opt (n, reachable)

139+ | Just (Optimise inaccessible dt) <- lookupCtxtExact n opt

140+ , eargs@(_:_) <- [fmt n (S.toList rs) | (i,n) <- inaccessible, rs <- maybeToList $ IM.lookup i reachable]

141+ = warn $ show n ++ ": inaccessible arguments reachable:\n " ++ intercalate "\n " eargs

142+

143+ | otherwise = return ()

144+ where

145+ fmt n [] = show n ++ " (no more information available)"

146+ fmt n rs = show n ++ " from " ++ intercalate ", " [show rn ++ " arg# " ++ show ri | (rn,ri) <- rs]

147+ warn = logLvl 0

148+

149+-- Find the minimal consistent usage by forward chaining.

150+minimalUsage :: Deps -> (Deps, (Set Name, UseMap))

151+minimalUsage = second gather . forwardChain

152+ where

153+ gather :: DepSet -> (Set Name, UseMap)

154+ gather = foldr ins (S.empty, M.empty) . M.toList

155+ where

156+ ins :: (Node, Set Reason) -> (Set Name, UseMap) -> (Set Name, UseMap)

157+ ins ((n, Result), rs) (ns, umap) = (S.insert n ns, umap)

158+ ins ((n, Arg i ), rs) (ns, umap) = (ns, M.insertWith (IM.unionWith S.union) n (IM.singleton i rs) umap)

159+

160+forwardChain :: Deps -> (Deps, DepSet)

161+forwardChain deps

162+ | Just trivials <- M.lookup S.empty deps

163+ = (M.unionWith S.union trivials)

164+ `second` forwardChain (remove trivials . M.delete S.empty $ deps)

165+ | otherwise = (deps, M.empty)

166+ where

167+ -- Remove the given nodes from the Deps entirely,

168+ -- possibly creating new empty Conds.

169+ remove :: DepSet -> Deps -> Deps

170+ remove ds = M.mapKeysWith (M.unionWith S.union) (S.\\ M.keysSet ds)

171+

172+-- Build the dependency graph,

173+-- starting the depth-first search from a list of Names.

174+buildDepMap :: Ctxt ClassInfo -> Context -> Name -> Deps

175+buildDepMap ci ctx mainName = addPostulates $ dfs S.empty M.empty [mainName]

176+ where

177+ -- mark the result of Main.main as used with the empty assumption

178+ addPostulates :: Deps -> Deps

179+ addPostulates deps = foldr (\(ds, rs) -> M.insertWith (M.unionWith S.union) ds rs) deps postulates

180+ where

181+ -- mini-DSL for postulates

182+ (==>) ds rs = (S.fromList ds, M.fromList [(r, S.empty) | r <- rs])

183+ it n is = [(sUN n, Arg i) | i <- is]

184+ mn n is = [(MN 0 $ pack n, Arg i) | i <- is]

185+

186+ -- believe_me is special because it does not use all its arguments

187+ specialPrims = S.fromList [sUN "prim__believe_me"]

188+ usedNames = allNames deps S.\\ specialPrims

189+ usedPrims = [(p_name p, p_arity p) | p <- primitives, p_name p `S.member` usedNames]

190+

191+ postulates =

192+ [ [] ==> concat

193+ -- These two, Main.main and run__IO, are always evaluated

194+ -- but they elude analysis since they come from the seed term.

195+ [ [(mainName, Result)]

196+ , [(sUN "run__IO", Result), (sUN "run__IO", Arg 0)]

197+

198+ -- MkIO is read by run__IO,

199+ -- but this cannot be observed in the source code of programs.

200+ , it "MkIO" [1]

201+ , it "prim__IO" [1]

202+

203+ -- these have been discovered as builtins but are not listed

204+ -- among Idris.Primitives.primitives

205+ , mn "__MkPair" [2,3]

206+ , it "prim_fork" [0]

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+

298+ addTagDep = case alts of

299+ [_] -> id -- single branch, tag not used

300+ _ -> M.insertWith (M.unionWith S.union) (S.singleton (fn, Result)) (viDeps casedVar)

301+ casedVar = fromMaybe (error $ "nonpatvar in case: " ++ show n) (M.lookup n vs)

302+

303+ getDepsAlt :: Name -> [Name] -> Vars -> VarInfo -> CaseAlt -> Deps

304+ getDepsAlt fn es vs var (FnCase n ns sc) = error "an FnCase encountered" -- TODO: what's this?

305+ getDepsAlt fn es vs var (ConstCase c sc) = getDepsSC fn es vs sc

306+ getDepsAlt fn es vs var (DefaultCase sc) = getDepsSC fn es vs sc

307+ getDepsAlt fn es vs var (SucCase n sc)

308+ = getDepsSC fn es (M.insert n var vs) sc -- we're not inserting the S-dependency here because it's special-cased

309+

310+ -- data constructors

311+ getDepsAlt fn es vs var (ConCase n cnt ns sc)

312+ = getDepsSC fn es (vs' `M.union` vs) sc -- left-biased union

313+ where

314+ -- Here we insert dependencies that arose from pattern matching on a constructor.

315+ -- n = ctor name, j = ctor arg#, i = fun arg# of the cased var, cs = ctors of the cased var

316+ vs' = M.fromList [(v, VI

317+ { viDeps = M.insertWith S.union (n, Arg j) (S.singleton (fn, varIdx)) (viDeps var)

318+ , viFunArg = viFunArg var

319+ , viMethod = meth j

320+ })

321+ | (v, j) <- zip ns [0..]]

322+

323+ -- this is safe because it's certainly a patvar

324+ varIdx = fromJust (viFunArg var)

325+

326+ -- generate metamethod names, "n" is the instance ctor

327+ meth :: Int -> Maybe Name

328+ meth | SN (InstanceCtorN className) <- n = \j -> Just (mkFieldName n j)

329+ | otherwise = \j -> Nothing

330+

331+ -- Named variables -> DeBruijn variables -> Conds/guards -> Term -> Deps

332+ getDepsTerm :: Vars -> [Cond -> Deps] -> Cond -> Term -> Deps

333+

334+ -- named variables introduce dependencies as described in `vs'

335+ getDepsTerm vs bs cd (P _ n _)

336+ -- local variables

337+ | Just var <- M.lookup n vs

338+ = M.singleton cd (viDeps var)

339+

340+ -- sanity check: machine-generated names shouldn't occur at top-level

341+ | MN _ _ <- n

342+ , n `notElem` specialMNs

343+ = error $ "erasure analysis: variable " ++ show n ++ " unbound in " ++ show (S.toList cd)

344+

345+ -- assumed to be a global reference

346+ | otherwise = M.singleton cd (M.singleton (n, Result) S.empty)

347+ where

348+ specialMNs = map (sMN 0 . ("__" ++)) $ words "Unit True False II"

349+

350+ -- dependencies of de bruijn variables are described in `bs'

351+ getDepsTerm vs bs cd (V i) = (bs !! i) cd

352+

353+ getDepsTerm vs bs cd (Bind n bdr t)

354+ -- here we just push IM.empty on the de bruijn stack

355+ -- the args will be marked as used at the usage site

356+ | Lam ty <- bdr = getDepsTerm vs (const M.empty : bs) cd t

357+ | Pi ty <- bdr = getDepsTerm vs (const M.empty : bs) cd t

358+

359+ -- let-bound variables can get partially evaluated

360+ -- it is sufficient just to plug the Cond in when the bound names are used

361+ | Let ty t <- bdr = getDepsTerm vs (var t : bs) cd t

362+ | NLet ty t <- bdr = getDepsTerm vs (var t : bs) cd t

363+ where

364+ var t cd = getDepsTerm vs bs cd t

365+

366+ -- applications may add items to Cond

367+ getDepsTerm vs bs cd app@(App _ _)

368+ | (fun, args) <- unApply app = case fun of

369+ -- instance constructors -> create metamethod deps

370+ P (DCon _ _) ctorName@(SN (InstanceCtorN className)) _

371+ -> conditionalDeps ctorName args -- regular data ctor stuff

372+ `union` unionMap (methodDeps ctorName) (zip [0..] args) -- method-specific stuff

373+

374+ -- ordinary constructors

375+ P (TCon _ _) n _ -> unconditionalDeps args -- does not depend on anything

376+ P (DCon _ _) n _ -> conditionalDeps n args -- depends on whether (n,#) is used

377+

378+ -- mkForeign* calls must be special-cased because they are variadic

379+ -- All arguments must be marked as used, except for the first one,

380+ -- which is the (Foreign a) spec that defines the type

381+ -- and is not needed at runtime.

382+ P _ (UN n) _

383+ | n `elem` map T.pack ["mkForeign", "mkForeignPrim", "mkLazyForeignPrim"]

384+ -> unconditionalDeps (drop 1 args)

385+

386+ -- a bound variable might draw in additional dependencies,

387+ -- think: f x = x 0 <-- here, `x' _is_ used

388+ P _ n _

389+ -- local name that refers to a method

390+ | Just var <- M.lookup n vs

391+ , Just meth <- viMethod var

392+ -> viDeps var `ins` conditionalDeps meth args -- use the method instead

393+

394+ -- local name

395+ | Just var <- M.lookup n vs

396+ -- unconditional use

397+ -> viDeps var `ins` unconditionalDeps args

398+

399+ -- global name

400+ | otherwise

401+ -- depends on whether the referred thing uses its argument

402+ -> conditionalDeps n args

403+

404+ -- TODO: could we somehow infer how bound variables use their arguments?

405+ V i -> M.unionWith (M.unionWith S.union) ((bs !! i) cd) (unconditionalDeps args)

406+

407+ -- we interpret applied lambdas as lets in order to reuse code here

408+ Bind n (Lam ty) t -> getDepsTerm vs bs cd (lamToLet [] app)

409+

410+ -- and we interpret applied lets as lambdas

411+ Bind n ( Let ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')

412+ Bind n (NLet ty t') t -> getDepsTerm vs bs cd (App (Bind n (Lam ty) t) t')

413+

414+ Proj t i

415+ -> error $ "cannot[0] analyse projection !" ++ show i ++ " of " ++ show t

416+

417+ Erased -> M.empty

418+

419+ _ -> error $ "cannot analyse application of " ++ show fun ++ " to " ++ show args

420+ where

421+ ins = M.insertWith (M.unionWith S.union) cd

422+

423+ unconditionalDeps :: [Term] -> Deps

424+ unconditionalDeps = unionMap (getDepsTerm vs bs cd)

425+

426+ conditionalDeps :: Name -> [Term] -> Deps

427+ conditionalDeps n

428+ = ins (M.singleton (n, Result) S.empty) . unionMap (getDepsArgs n) . zip indices

429+ where

430+ indices = map Just [0 .. getArity n - 1] ++ repeat Nothing

431+ getDepsArgs n (Just i, t) = getDepsTerm vs bs (S.insert (n, Arg i) cd) t -- conditional

432+ getDepsArgs n (Nothing, t) = getDepsTerm vs bs cd t -- unconditional

433+

434+ methodDeps :: Name -> (Int, Term) -> Deps

435+ methodDeps ctorName (methNo, t)

436+ = getDepsTerm (vars `M.union` vs) (bruijns ++ bs) cond body

437+ where

438+ vars = M.fromList [(v, VI

439+ { viDeps = deps i

440+ , viFunArg = Just i

441+ , viMethod = Nothing

442+ }) | (v, i) <- zip args [0..]]

443+ deps i = M.singleton (metameth, Arg i) S.empty

444+ bruijns = reverse [\cd -> M.singleton cd (deps i) | i <- [0 .. length args - 1]]

445+ cond = S.singleton (metameth, Result)

446+ metameth = mkFieldName ctorName methNo

447+ (args, body) = unfoldLams t

448+

449+ -- projections

450+ getDepsTerm vs bs cd (Proj t (-1)) = getDepsTerm vs bs cd t -- naturals, (S n) -> n

451+ getDepsTerm vs bs cd (Proj t i) = error $ "cannot[1] analyse projection !" ++ show i ++ " of " ++ show t

452+

453+ -- the easy cases

454+ getDepsTerm vs bs cd (Constant _) = M.empty

455+ getDepsTerm vs bs cd (TType _) = M.empty

456+ getDepsTerm vs bs cd Erased = M.empty

457+ getDepsTerm vs bs cd Impossible = M.empty

458+

459+ getDepsTerm vs bs cd t = error $ "cannot get deps of: " ++ show t

460+

461+ -- Get the number of arguments that might be considered for erasure.

462+ getArity :: Name -> Int

463+ getArity (SN (WhereN i' ctorName (MN i field)))

464+ | Just (TyDecl (DCon _ _) ty) <- lookupDefExact ctorName ctx

465+ = let argTys = map snd $ getArgTys ty

466+ in if i <= length argTys

467+ then length $ getArgTys (argTys !! i)

468+ else error $ "invalid field number " ++ show i ++ " for " ++ show ctorName

469+

470+ | otherwise = error $ "unknown instance constructor: " ++ show ctorName

471+

472+ getArity n = case lookupDefExact n ctx of

473+ Just (CaseOp ci ty tys def tot cdefs) -> length tys

474+ Just (TyDecl (DCon tag arity) _) -> arity

475+ Just (TyDecl (Ref) ty) -> length $ getArgTys ty

476+ Just (Operator ty arity op) -> arity

477+ Just df -> error $ "Erasure/getArity: unrecognised entity '"

478+ ++ show n ++ "' with definition: " ++ show df

479+ Nothing -> error $ "Erasure/getArity: definition not found for " ++ show n

480+

481+ -- convert applications of lambdas to lets

482+ -- Note that this transformation preserves de bruijn numbering

483+ lamToLet :: [Term] -> Term -> Term

484+ lamToLet xs (App f x) = lamToLet (x:xs) f

485+ lamToLet (x:xs) (Bind n (Lam ty) t) = Bind n (Let ty x) (lamToLet xs t)

486+ lamToLet (x:xs) t = App (lamToLet xs t) x

487+ lamToLet [] t = t

488+

489+ -- split "\x_i -> T(x_i)" into [x_i] and T

490+ unfoldLams :: Term -> ([Name], Term)

491+ unfoldLams (Bind n (Lam ty) t) = let (ns,t') = unfoldLams t in (n:ns, t')

492+ unfoldLams t = ([], t)

493+

494+ union :: Deps -> Deps -> Deps

495+ union = M.unionWith (M.unionWith S.union)

496+

497+ unions :: [Deps] -> Deps

498+ unions = M.unionsWith (M.unionWith S.union)

499+

500+ unionMap :: (a -> Deps) -> [a] -> Deps

501+ unionMap f = M.unionsWith (M.unionWith S.union) . map f

502+

503+-- Make a field name out of a data constructor name and field number.

504+mkFieldName :: Name -> Int -> Name

505+mkFieldName ctorName fieldNo = SN (WhereN fieldNo ctorName $ sMN fieldNo "field")

src/Idris/Error.hs+1

@@ -5,6 +5,7 @@ module Idris.Error where

5import Prelude hiding (catch)

6import Idris.AbsSyntax

7import Idris.Delaborate

8+import Idris.Output

8

9

9import Idris.Core.TT

10import Idris.Core.TT

10import Idris.Core.Typecheck

11import Idris.Core.Typecheck

src/Idris/IBC.hs+42−28

@@ -10,6 +10,7 @@ import Idris.Imports

10import Idris.Error

11import Idris.Delaborate

12import Idris.Docstrings

13+import Idris.Output

13

14

14import qualified Cheapskate.Types as CT

15import qualified Cheapskate.Types as CT

15

16

@@ -18,6 +19,7 @@ import Data.Vector.Binary

18import Data.List

19import Data.List

19import Data.ByteString.Lazy as B hiding (length, elem, map)

20import Data.ByteString.Lazy as B hiding (length, elem, map)

20import qualified Data.Text as T

21import qualified Data.Text as T

22+import qualified Data.Set as S

21

23

22import Control.Monad

24import Control.Monad

23import Control.Monad.State.Strict hiding (get, put)

25import Control.Monad.State.Strict hiding (get, put)

@@ -28,7 +30,7 @@ import Codec.Compression.Zlib (compress)

28import Util.Zlib (decompressEither)

30import Util.Zlib (decompressEither)

29

31

30ibcVersion :: Word8

32ibcVersion :: Word8

31−ibcVersion = 65

33+ibcVersion = 67

32

34

33data IBCFile = IBCFile { ver :: Word8,

35data IBCFile = IBCFile { ver :: Word8,

34 sourcefile :: FilePath,

36 sourcefile :: FilePath,

@@ -64,7 +66,8 @@ data IBCFile = IBCFile { ver :: Word8,

64 ibc_errorhandlers :: [Name],

66 ibc_errorhandlers :: [Name],

65 ibc_function_errorhandlers :: [(Name, Name, Name)], -- fn, arg, handler

67 ibc_function_errorhandlers :: [(Name, Name, Name)], -- fn, arg, handler

66 ibc_metavars :: [(Name, (Maybe Name, Int, Bool))],

68 ibc_metavars :: [(Name, (Maybe Name, Int, Bool))],

67− ibc_patdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))]

69+ ibc_patdefs :: [(Name, ([([Name], Term, Term)], [PTerm]))],

70+ ibc_postulates :: [Name]

68 }

71 }

69 deriving Show

72 deriving Show

70{-!

73{-!

@@ -72,12 +75,15 @@ deriving instance Binary IBCFile

72!-}

75!-}

73

76

74initIBC :: IBCFile

77initIBC :: IBCFile

75−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

78+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

76

79

77loadIBC :: FilePath -> Idris ()

80loadIBC :: FilePath -> Idris ()

81+loadIBC fp = do imps <- getImported

82+ when (not (fp `elem` imps)) $

78−loadIBC fp = do iLOG $ "Loading ibc " ++ fp

83+ do iLOG $ "Loading ibc " ++ fp

79− ibcf <- runIO $ (bdecode fp :: IO IBCFile)

84+ ibcf <- runIO $ (bdecode fp :: IO IBCFile)

80− process ibcf fp

85+ process ibcf fp

86+ addImported fp

81

87

82bencode :: Binary a => FilePath -> a -> IO ()

88bencode :: Binary a => FilePath -> a -> IO ()

83bencode f d = B.writeFile f (compress (encode d))

89bencode f d = B.writeFile f (compress (encode d))

@@ -232,6 +238,7 @@ ibc i (IBCMetavar n) f =

232 case lookup n (idris_metavars i) of

238 case lookup n (idris_metavars i) of

233 Nothing -> return f

239 Nothing -> return f

234 Just t -> return f { ibc_metavars = (n, t) : ibc_metavars f }

240 Just t -> return f { ibc_metavars = (n, t) : ibc_metavars f }

241+ibc i (IBCPostulate n) f = return f { ibc_postulates = n : ibc_postulates f }

235

242

236process :: IBCFile -> FilePath -> Idris ()

243process :: IBCFile -> FilePath -> Idris ()

237process i fn

244process i fn

@@ -274,6 +281,7 @@ process i fn

274 pErrorHandlers (ibc_errorhandlers i)

281 pErrorHandlers (ibc_errorhandlers i)

275 pFunctionErrorHandlers (ibc_function_errorhandlers i)

282 pFunctionErrorHandlers (ibc_function_errorhandlers i)

276 pMetavars (ibc_metavars i)

283 pMetavars (ibc_metavars i)

284+ pPostulates (ibc_postulates i)

277

285

278timestampOlder :: FilePath -> FilePath -> IO ()

286timestampOlder :: FilePath -> FilePath -> IO ()

279timestampOlder src ibc = do srct <- getModificationTime src

287timestampOlder src ibc = do srct <- getModificationTime src

@@ -282,6 +290,11 @@ timestampOlder src ibc = do srct <- getModificationTime src

282 then fail "Needs reloading"

290 then fail "Needs reloading"

283 else return ()

291 else return ()

284

292

293+pPostulates :: [Name] -> Idris ()

294+pPostulates ns = do

295+ i <- getIState

296+ putIState i{ idris_postulates = idris_postulates i `S.union` S.fromList ns }

297+

285pImports :: [FilePath] -> Idris ()

298pImports :: [FilePath] -> Idris ()

286pImports fs

299pImports fs

287 = do mapM_ (\f -> do i <- getIState

300 = do mapM_ (\f -> do i <- getIState

@@ -396,8 +409,11 @@ pPatdefs ds

396pDefs :: [Name] -> [(Name, Def)] -> Idris ()

409pDefs :: [Name] -> [(Name, Def)] -> Idris ()

397pDefs syms ds

410pDefs syms ds

398 = mapM_ (\ (n, d) ->

411 = mapM_ (\ (n, d) ->

399− do i <- getIState

400− let d' = updateDef d

412+ do let d' = updateDef d

413+ case d' of

414+ TyDecl _ _ -> return ()

415+ _ -> solveDeferred n

416+ i <- getIState

401 logLvl 5 $ "Added " ++ show (n, d')

417 logLvl 5 $ "Added " ++ show (n, d')

402 putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) ds

418 putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) ds

403 where

419 where

@@ -1086,10 +1102,6 @@ safeToEnum label x' = result

1086 = error $ label ++ ": corrupted binary representation in IBC"

1102 = error $ label ++ ": corrupted binary representation in IBC"

1087 | otherwise = toEnum x

1103 | otherwise = toEnum x

1088

1104

1089−instance Binary Forceability where

1090− put = putWord8 . fromIntegral . fromEnum

1091− get = safeToEnum "Forceability" `fmap` getWord8

1092−

1093instance Binary PReason where

1105instance Binary PReason where

1094 put x

1106 put x

1095 = case x of

1107 = case x of

@@ -1149,7 +1161,7 @@ instance Binary MetaInformation where

1149 return (DataMI x1)

1161 return (DataMI x1)

1150

1162

1151instance Binary IBCFile where

1163instance Binary IBCFile where

1152− put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35)

1164+ put x@(IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36)

1153 = {-# SCC "putIBCFile" #-}

1165 = {-# SCC "putIBCFile" #-}

1154 do put x1

1166 do put x1

1155 put x2

1167 put x2

@@ -1186,6 +1198,7 @@ instance Binary IBCFile where

1186 put x33

1198 put x33

1187 put x34

1199 put x34

1188 put x35

1200 put x35

1201+ put x36

1189

1202

1190 get

1203 get

1191 = do x1 <- get

1204 = do x1 <- get

@@ -1224,7 +1237,8 @@ instance Binary IBCFile where

1224 x33 <- get

1237 x33 <- get

1225 x34 <- get

1238 x34 <- get

1226 x35 <- get

1239 x35 <- get

1240+ x36 <- get

1227− return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35)

1241+ return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36)

1228 else return (initIBC { ver = x1 })

1242 else return (initIBC { ver = x1 })

1229

1243

1230instance Binary DataOpt where

1244instance Binary DataOpt where

@@ -1310,13 +1324,13 @@ instance Binary FixDecl where

1310instance Binary ArgOpt where

1324instance Binary ArgOpt where

1311 put x

1325 put x

1312 = case x of

1326 = case x of

1313− Lazy -> putWord8 0

1327+ HideDisplay -> putWord8 0

1314− HideDisplay -> putWord8 1

1328+ InaccessibleArg -> putWord8 1

1315 get

1329 get

1316 = do i <- getWord8

1330 = do i <- getWord8

1317 case i of

1331 case i of

1318− 0 -> return Lazy

1332+ 0 -> return HideDisplay

1319− 1 -> return HideDisplay

1333+ 1 -> return InaccessibleArg

1320 _ -> error "Corrupted binary data for Static"

1334 _ -> error "Corrupted binary data for Static"

1321

1335

1322instance Binary Static where

1336instance Binary Static where

@@ -2030,16 +2044,18 @@ instance (Binary t) => Binary (PArg' t) where

2030 put x3

2044 put x3

2031 put x4

2045 put x4

2032 put x5

2046 put x5

2033− PExp x1 x2 x3 ->

2047+ PExp x1 x2 x3 x4 ->

2034 do putWord8 1

2048 do putWord8 1

2035 put x1

2049 put x1

2036 put x2

2050 put x2

2037 put x3

2051 put x3

2052+ put x4

2038− PConstraint x1 x2 x3 ->

2053+ PConstraint x1 x2 x3 x4 ->

2039 do putWord8 2

2054 do putWord8 2

2040 put x1

2055 put x1

2041 put x2

2056 put x2

2042 put x3

2057 put x3

2058+ put x4

2043 PTacImplicit x1 x2 x3 x4 x5 ->

2059 PTacImplicit x1 x2 x3 x4 x5 ->

2044 do putWord8 3

2060 do putWord8 3

2045 put x1

2061 put x1

@@ -2059,11 +2075,13 @@ instance (Binary t) => Binary (PArg' t) where

2059 1 -> do x1 <- get

2075 1 -> do x1 <- get

2060 x2 <- get

2076 x2 <- get

2061 x3 <- get

2077 x3 <- get

2078+ x4 <- get

2062− return (PExp x1 x2 x3)

2079+ return (PExp x1 x2 x3 x4)

2063 2 -> do x1 <- get

2080 2 -> do x1 <- get

2064 x2 <- get

2081 x2 <- get

2065 x3 <- get

2082 x3 <- get

2083+ x4 <- get

2066− return (PConstraint x1 x2 x3)

2084+ return (PConstraint x1 x2 x3 x4)

2067 3 -> do x1 <- get

2085 3 -> do x1 <- get

2068 x2 <- get

2086 x2 <- get

2069 x3 <- get

2087 x3 <- get

@@ -2089,17 +2107,13 @@ instance Binary ClassInfo where

2089 return (CI x1 x2 x3 x4 x5 [])

2107 return (CI x1 x2 x3 x4 x5 [])

2090

2108

2091instance Binary OptInfo where

2109instance Binary OptInfo where

2092− put (Optimise x1 x2 x3 x4)

2110+ put (Optimise x1 x2)

2093 = do put x1

2111 = do put x1

2094 put x2

2112 put x2

2095− put x3

2096− put x4

2097 get

2113 get

2098 = do x1 <- get

2114 = do x1 <- get

2099 x2 <- get

2115 x2 <- get

2100− x3 <- get

2101− x4 <- get

2102− return (Optimise x1 x2 x3 x4)

2116+ return (Optimise x1 x2)

2103

2117

2104instance Binary TypeInfo where

2118instance Binary TypeInfo where

2105 put (TI x1 x2 x3 x4) = do put x1

2119 put (TI x1 x2 x3 x4) = do put x1

src/Idris/IdeSlave.hs+15−8

@@ -74,16 +74,21 @@ instance (SExpable a, SExpable b, SExpable c, SExpable d, SExpable e) =>

74 toSExp (l, m, n, o, p) = SexpList [toSExp l, toSExp m, toSExp n, toSExp o, toSExp p]

75

76instance SExpable NameOutput where

77− toSExp TypeOutput = SymbolAtom "type"

77+ toSExp TypeOutput = SymbolAtom "type"

78− toSExp FunOutput = SymbolAtom "function"

78+ toSExp FunOutput = SymbolAtom "function"

79− toSExp DataOutput = SymbolAtom "data"

79+ toSExp DataOutput = SymbolAtom "data"

80+ toSExp MetavarOutput = SymbolAtom "metavar"

81+

82+maybeProps :: SExpable a => [(String, Maybe a)] -> [(SExp, SExp)]

83+maybeProps [] = []

84+maybeProps ((n, Just p):ps) = (SymbolAtom n, toSExp p) : maybeProps ps

85+maybeProps ((n, Nothing):ps) = maybeProps ps

80

86

81instance SExpable OutputAnnotation where

87instance SExpable OutputAnnotation where

82− toSExp (AnnName n Nothing _) = toSExp [(SymbolAtom "name", StringAtom (show n)),

88+ toSExp (AnnName n ty d t) = toSExp $ [(SymbolAtom "name", StringAtom (show n)),

83− (SymbolAtom "implicit", BoolAtom False)]

89+ (SymbolAtom "implicit", BoolAtom False)] ++

84− toSExp (AnnName n (Just ty) _) = toSExp [(SymbolAtom "name", StringAtom (show n)),

90+ maybeProps [("decor", ty)] ++

85− (SymbolAtom "decor", toSExp ty),

91+ maybeProps [("doc-overview", d), ("type", t)]

86− (SymbolAtom "implicit", BoolAtom False)]

87 toSExp (AnnBoundName n imp) = toSExp [(SymbolAtom "name", StringAtom (show n)),

92 toSExp (AnnBoundName n imp) = toSExp [(SymbolAtom "name", StringAtom (show n)),

88 (SymbolAtom "decor", SymbolAtom "bound"),

93 (SymbolAtom "decor", SymbolAtom "bound"),

89 (SymbolAtom "implicit", BoolAtom imp)]

94 (SymbolAtom "implicit", BoolAtom imp)]

@@ -146,6 +151,7 @@ data IdeSlaveCommand = REPLCompletions String

146 | Apropos String

151 | Apropos String

147 | GetOpts

152 | GetOpts

148 | SetOpt Opt Bool

153 | SetOpt Opt Bool

154+ | Metavariables Int -- ^^ the Int is the column count for pretty-printing

149 deriving Show

155 deriving Show

150

156

151sexpToCommand :: SExp -> Maybe IdeSlaveCommand

157sexpToCommand :: SExp -> Maybe IdeSlaveCommand

@@ -169,6 +175,7 @@ sexpToCommand (SymbolAtom "get-options")

169sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])

175sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])

170 | Just opt <- lookup s opts = Just (SetOpt opt b)

176 | Just opt <- lookup s opts = Just (SetOpt opt b)

171 where opts = [("show-implicits", ShowImpl), ("error-context", ErrContext)] --TODO support more

177 where opts = [("show-implicits", ShowImpl), ("error-context", ErrContext)] --TODO support more

178+sexpToCommand (SexpList [SymbolAtom "metavariables", IntegerAtom cols]) = Just (Metavariables (fromIntegral cols))

172sexpToCommand _ = Nothing

179sexpToCommand _ = Nothing

173

180

174parseMessage :: String -> Either Err (SExp, Integer)

181parseMessage :: String -> Either Err (SExp, Integer)

src/Idris/Output.hsnew file+173

@@ -0,0 +1,173 @@

1+module Idris.Output where

2+

3+import Idris.Core.TT

4+import Idris.Core.Evaluate (isDConName, isTConName, isFnName)

5+

6+import Idris.AbsSyntax

7+import Idris.Delaborate

8+import Idris.Docstrings

9+import Idris.IdeSlave

10+

11+import Util.Pretty

12+import Util.ScreenSize (getScreenWidth)

13+

14+import System.IO (stdout, Handle, hPutStrLn)

15+

16+pshow :: IState -> Err -> String

17+pshow ist err = displayDecorated (consoleDecorate ist) .

18+ renderPretty 1.0 80 .

19+ fmap (fancifyAnnots ist) $ pprintErr ist err

20+

21+ihWarn :: Handle -> FC -> Doc OutputAnnotation -> Idris ()

22+ihWarn h fc err = do i <- getIState

23+ case idris_outputmode i of

24+ RawOutput ->

25+ do err' <- iRender . fmap (fancifyAnnots i) $

26+ text (show fc) <> colon <//> err

27+ runIO . hPutStrLn h $ displayDecorated (consoleDecorate i) err'

28+ IdeSlave n ->

29+ do err' <- iRender . fmap (fancifyAnnots i) $ err

30+ let (str, spans) = displaySpans err'

31+ runIO . hPutStrLn h $

32+ convSExp "warning" (fc_fname fc, fc_start fc, fc_end fc, str, spans) n

33+

34+iRender :: Doc a -> Idris (SimpleDoc a)

35+iRender d = do w <- getWidth

36+ ist <- getIState

37+ let ideSlave = case idris_outputmode ist of

38+ IdeSlave _ -> True

39+ _ -> False

40+ case w of

41+ InfinitelyWide -> return $ renderPretty 1.0 1000000000 d

42+ ColsWide n -> return $

43+ if n < 1

44+ then renderPretty 1.0 1000000000 d

45+ else renderPretty 0.8 n d

46+ AutomaticWidth | ideSlave -> return $ renderPretty 1.0 1000000000 d

47+ | otherwise -> do width <- runIO getScreenWidth

48+ return $ renderPretty 0.8 width d

49+

50+ihPrintResult :: Handle -> String -> Idris ()

51+ihPrintResult h s = do i <- getIState

52+ case idris_outputmode i of

53+ RawOutput -> case s of

54+ "" -> return ()

55+ s -> runIO $ hPutStrLn h s

56+ IdeSlave n ->

57+ let good = SexpList [SymbolAtom "ok", toSExp s] in

58+ runIO $ hPutStrLn h $ convSExp "return" good n

59+

60+-- | Write a pretty-printed term to the console with semantic coloring

61+consoleDisplayAnnotated :: Handle -> Doc OutputAnnotation -> Idris ()

62+consoleDisplayAnnotated h output = do ist <- getIState

63+ rendered <- iRender $ output

64+ runIO . hPutStrLn h .

65+ displayDecorated (consoleDecorate ist) $

66+ rendered

67+

68+

69+-- | Write pretty-printed output to IDESlave with semantic annotations

70+ideSlaveReturnAnnotated :: Integer -> Handle -> Doc OutputAnnotation -> Idris ()

71+ideSlaveReturnAnnotated n h out = do ist <- getIState

72+ (str, spans) <- fmap displaySpans .

73+ iRender .

74+ fmap (fancifyAnnots ist) $

75+ out

76+ let good = [SymbolAtom "ok", toSExp str, toSExp spans]

77+ runIO . hPutStrLn h $ convSExp "return" good n

78+

79+ihPrintTermWithType :: Handle -> Doc OutputAnnotation -> Doc OutputAnnotation -> Idris ()

80+ihPrintTermWithType h tm ty = do ist <- getIState

81+ let output = tm <+> colon <+> ty

82+ case idris_outputmode ist of

83+ RawOutput -> consoleDisplayAnnotated h output

84+ IdeSlave n -> ideSlaveReturnAnnotated n h output

85+

86+-- | Pretty-print a collection of overloadings to REPL or IDESlave - corresponds to :t name

87+ihPrintFunTypes :: Handle -> [(Name, Bool)] -> Name -> [(Name, PTerm)] -> Idris ()

88+ihPrintFunTypes h bnd n [] = ihPrintError h $ "No such variable " ++ show n

89+ihPrintFunTypes h bnd n overloads = do imp <- impShow

90+ ist <- getIState

91+ let output = vsep (map (uncurry (ppOverload imp)) overloads)

92+ case idris_outputmode ist of

93+ RawOutput -> consoleDisplayAnnotated h output

94+ IdeSlave n -> ideSlaveReturnAnnotated n h output

95+ where fullName n = prettyName True bnd n

96+ ppOverload imp n tm = fullName n <+> colon <+> align (pprintPTerm imp bnd [] tm)

97+

98+ihRenderResult :: Handle -> Doc OutputAnnotation -> Idris ()

99+ihRenderResult h d = do ist <- getIState

100+ case idris_outputmode ist of

101+ RawOutput -> consoleDisplayAnnotated h d

102+ IdeSlave n -> ideSlaveReturnAnnotated n h d

103+

104+fancifyAnnots :: IState -> OutputAnnotation -> OutputAnnotation

105+fancifyAnnots ist annot@(AnnName n _ _ _) =

106+ do let ctxt = tt_ctxt ist

107+ docs = docOverview ist n

108+ ty = Just (getTy ist n)

109+ case () of

110+ _ | isDConName n ctxt -> AnnName n (Just DataOutput) docs ty

111+ _ | isFnName n ctxt -> AnnName n (Just FunOutput) docs ty

112+ _ | isTConName n ctxt -> AnnName n (Just TypeOutput) docs ty

113+ _ | isMetavarName n ist -> AnnName n (Just MetavarOutput) docs ty

114+ _ | otherwise -> annot

115+ where docOverview :: IState -> Name -> Maybe String -- pretty-print first paragraph of docs

116+ docOverview ist n = do docs <- lookupCtxtExact n (idris_docstrings ist)

117+ let o = overview (fst docs)

118+ -- TODO make width configurable

119+ out = displayS . renderPretty 1.0 50 $ renderDocstring o

120+ return (out "")

121+ getTy :: IState -> Name -> String -- fails if name not already extant!

122+ getTy ist n = let theTy = pprintPTerm (opt_showimp (idris_options ist)) [] [] $

123+ delabTy ist n

124+ in (displayS . renderPretty 1.0 50 $ theTy) ""

125+fancifyAnnots _ annot = annot

126+

127+-- | Show an error with semantic highlighting

128+ihRenderError :: Handle -> Doc OutputAnnotation -> Idris ()

129+ihRenderError h e = do ist <- getIState

130+ case idris_outputmode ist of

131+ RawOutput -> consoleDisplayAnnotated h e

132+ IdeSlave n -> do

133+ (str, spans) <- fmap displaySpans .

134+ iRender .

135+ fmap (fancifyAnnots ist) $

136+ e

137+ let good = [SymbolAtom "error", toSExp str, toSExp spans]

138+ runIO . hPutStrLn h $ convSExp "return" good n

139+

140+ihPrintError :: Handle -> String -> Idris ()

141+ihPrintError h s = do i <- getIState

142+ case idris_outputmode i of

143+ RawOutput -> case s of

144+ "" -> return ()

145+ s -> runIO $ hPutStrLn h s

146+ IdeSlave n ->

147+ let good = SexpList [SymbolAtom "error", toSExp s] in

148+ runIO . hPutStrLn h $ convSExp "return" good n

149+

150+ihputStrLn :: Handle -> String -> Idris ()

151+ihputStrLn h s = do i <- getIState

152+ case idris_outputmode i of

153+ RawOutput -> runIO $ hPutStrLn h s

154+ IdeSlave n -> runIO . hPutStrLn h $ convSExp "write-string" s n

155+

156+iputStrLn = ihputStrLn stdout

157+iPrintError = ihPrintError stdout

158+iPrintResult = ihPrintResult stdout

159+iWarn = ihWarn stdout

160+

161+ideslavePutSExp :: SExpable a => String -> a -> Idris ()

162+ideslavePutSExp cmd info = do i <- getIState

163+ case idris_outputmode i of

164+ IdeSlave n -> runIO . putStrLn $ convSExp cmd info n

165+ _ -> return ()

166+

167+-- this needs some typing magic and more structured output towards emacs

168+iputGoal :: SimpleDoc OutputAnnotation -> Idris ()

169+iputGoal g = do i <- getIState

170+ case idris_outputmode i of

171+ RawOutput -> runIO $ putStrLn (displayDecorated (consoleDecorate i) g)

172+ IdeSlave n -> runIO . putStrLn $

173+ convSExp "write-goal" (displayS (fmap (fancifyAnnots i) g) "") n

src/Idris/ParseExpr.hs+29−15

@@ -150,15 +150,23 @@ extension syn (Rule ssym ptm _)

150 update ns (PRef fc n) = case lookup n ns of

151 Just (SynTm t) -> t

152 _ -> PRef fc n

153+ update ns (PLam n ty sc)

153− update ns (PLam n ty sc) = PLam (updateB ns n) (update ns ty) (update (dropn n ns) sc)

154+ = PLam (updateB ns n) (update ns ty) (update (dropn n ns) sc)

155+ update ns (PPi p n ty sc)

156+ = PPi (updTacImp ns p) (updateB ns n)

154− update ns (PPi p n ty sc) = PPi p (updateB ns n) (update ns ty) (update (dropn n ns) sc)

157+ (update ns ty) (update (dropn n ns) sc)

158+ update ns (PLet n ty val sc)

155− update ns (PLet n ty val sc) = PLet (updateB ns n) (update ns ty) (update ns val)

159+ = PLet (updateB ns n) (update ns ty)

156− (update (dropn n ns) sc)

160+ (update ns val) (update (dropn n ns) sc)

161+ update ns (PApp fc t args)

157− update ns (PApp fc t args) = PApp fc (update ns t) (map (fmap (update ns)) args)

162+ = PApp fc (update ns t) (map (fmap (update ns)) args)

163+ update ns (PAppBind fc t args)

158− update ns (PAppBind fc t args) = PAppBind fc (update ns t) (map (fmap (update ns)) args)

164+ = PAppBind fc (update ns t) (map (fmap (update ns)) args)

165+ update ns (PCase fc c opts)

159− update ns (PCase fc c opts) = PCase fc (update ns c) (map (pmap (update ns)) opts)

166+ = PCase fc (update ns c) (map (pmap (update ns)) opts)

160 update ns (PPair fc p l r) = PPair fc p (update ns l) (update ns r)

167 update ns (PPair fc p l r) = PPair fc p (update ns l) (update ns r)

168+ update ns (PDPair fc p l t r)

161− update ns (PDPair fc p l t r) = PDPair fc p (update ns l) (update ns t) (update ns r)

169+ = PDPair fc p (update ns l) (update ns t) (update ns r)

162 update ns (PAlternative a as) = PAlternative a (map (update ns) as)

170 update ns (PAlternative a as) = PAlternative a (map (update ns) as)

163 update ns (PHidden t) = PHidden (update ns t)

171 update ns (PHidden t) = PHidden (update ns t)

164 update ns (PDoBlock ds) = PDoBlock $ upd ns ds

172 update ns (PDoBlock ds) = PDoBlock $ upd ns ds

@@ -176,6 +184,9 @@ extension syn (Rule ssym ptm _)

176 update ns (PGoal fc r n sc) = PGoal fc (update ns r) n (update ns sc)

184 update ns (PGoal fc r n sc) = PGoal fc (update ns r) n (update ns sc)

177 update ns t = t

185 update ns t = t

178

186

187+ updTacImp ns (TacImp o st scr) = TacImp o st (update ns scr)

188+ updTacImp _ x = x

189+

179{- | Parses a (normal) built-in expression

190{- | Parses a (normal) built-in expression

180@

191@

181InternalExpr ::=

192InternalExpr ::=

@@ -788,18 +799,15 @@ Pi ::=

788

799

789pi :: SyntaxInfo -> IdrisParser PTerm

800pi :: SyntaxInfo -> IdrisParser PTerm

790pi syn =

801pi syn =

791− do opts <- -- if implicitAllowed syn -- laziness is top level only

802+ do opts <- piOpts syn

792− -- then option [] (do lchar '|'; return [Lazy])

793− -- else return []

794− return []

795− st <- static

803+ st <- static

796 (do try (lchar '('); xt <- typeDeclList syn; lchar ')'

804 (do try (lchar '('); xt <- typeDeclList syn; lchar ')'

797 symbol "->"

805 symbol "->"

798 sc <- expr syn

806 sc <- expr syn

799 return (bindList (PPi (Exp opts st False)) xt sc)) <|> (do

807 return (bindList (PPi (Exp opts st False)) xt sc)) <|> (do

800 lchar '{'

808 lchar '{'

801 (do reserved "auto"

809 (do reserved "auto"

802− when (Lazy `elem` opts || (st == Static)) $ fail "auto type constraints can not be lazy or static"

810+ when (st == Static) $ fail "auto type constraints can not be lazy or static"

803 xt <- typeDeclList syn

811 xt <- typeDeclList syn

804 lchar '}'

812 lchar '}'

805 symbol "->"

813 symbol "->"

@@ -808,7 +816,7 @@ pi syn =

808 (TacImp [] Dynamic (PTactics [Trivial]))) xt sc))

816 (TacImp [] Dynamic (PTactics [Trivial]))) xt sc))

809 <|> (do

817 <|> (do

810 reserved "default"

818 reserved "default"

811− when (Lazy `elem` opts || (st == Static)) $ fail "default tactic constraints can not be lazy or static"

819+ when (st == Static) $ fail "default tactic constraints can not be lazy or static"

812 script <- simpleExpr syn

820 script <- simpleExpr syn

813 xt <- typeDeclList syn

821 xt <- typeDeclList syn

814 lchar '}'

822 lchar '}'

@@ -824,6 +832,12 @@ pi syn =

824 else do fail "no implicit arguments allowed here"))

832 else do fail "no implicit arguments allowed here"))

825 <?> "dependent type signature"

833 <?> "dependent type signature"

826

834

835+piOpts :: SyntaxInfo -> IdrisParser [ArgOpt]

836+piOpts syn | implicitAllowed syn =

837+ lchar '.' *> return [InaccessibleArg]

838+ <|> return []

839+piOpts syn = return []

840+

827{- | Parses a type constraint list

841{- | Parses a type constraint list

828

842

829@

843@

src/Idris/ParseHelpers.hs+1

@@ -17,6 +17,7 @@ import Idris.Core.TT

17import Idris.Core.Evaluate

18import Idris.Delaborate (pprintErr)

19import Idris.Docstrings

20+import Idris.Output (ihWarn)

20

21

21import qualified Util.Pretty as Pretty (text)

22import qualified Util.Pretty as Pretty (text)

22

23

src/Idris/ParseOps.hs+6−1

@@ -37,9 +37,14 @@ table fixes

37 [pexp (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

38 ++ toTable (reverse fixes) ++

39 [[backtick],

40− [binary "$" (\fc x y -> PApp fc x [pexp y]) AssocRight],

40+ [binary "$" (\fc x y -> flatten $ PApp fc x [pexp y]) AssocRight],

41 [binary "=" PEq AssocLeft],

42 [binary "->" (\fc x y -> PPi expl (sUN "__pi_arg") x y) AssocRight]]

43+ where

44+ flatten :: PTerm -> PTerm -- flatten application

45+ flatten (PApp fc (PApp _ f as) bs) = flatten (PApp fc f (as ++ bs))

46+ flatten t = t

47+

43

48

44-- | Calculates table for fixtiy declarations

49-- | Calculates table for fixtiy declarations

45toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

50toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

src/Idris/Parser.hs+18−3

@@ -17,18 +17,20 @@ import qualified Text.Parser.Char as Chr

17import qualified Text.Parser.Token.Highlight as Hi

18

19import Text.PrettyPrint.ANSI.Leijen (Doc, plain)

20+import qualified Text.PrettyPrint.ANSI.Leijen as ANSI

20

21

21−import Idris.AbsSyntax

22+import Idris.AbsSyntax hiding (namespace, params)

22import Idris.DSL

23import Idris.DSL

23import Idris.Imports

24import Idris.Imports

24import Idris.Delaborate

25import Idris.Delaborate

25import Idris.Error

26import Idris.Error

26import Idris.ElabDecls

27import Idris.ElabDecls

27−import Idris.ElabTerm hiding (namespace, params)

28+import Idris.ElabTerm

28import Idris.Coverage

29import Idris.Coverage

29import Idris.IBC

30import Idris.IBC

30import Idris.Unlit

31import Idris.Unlit

31import Idris.Providers

32import Idris.Providers

33+import Idris.Output

32

34

33import Idris.ParseHelpers

35import Idris.ParseHelpers

34import Idris.ParseOps

36import Idris.ParseOps

@@ -1119,6 +1121,11 @@ findFC x = let s = show (plain x) in

1119 (col, ':':msg) -> let pos = (read line, read col) in

1121 (col, ':':msg) -> let pos = (read line, read col) in

1120 (FC failname pos pos, msg)

1122 (FC failname pos pos, msg)

1121

1123

1124+-- | Check if the coloring matches the options and corrects if necessary

1125+fixColour :: Bool -> ANSI.Doc -> ANSI.Doc

1126+fixColour False doc = ANSI.plain doc

1127+fixColour True doc = doc

1128+

1122-- | A program is a list of declarations, possibly with associated

1129-- | A program is a list of declarations, possibly with associated

1123-- documentation strings.

1130-- documentation strings.

1124parseProg :: SyntaxInfo -> FilePath -> String -> Maybe Delta ->

1131parseProg :: SyntaxInfo -> FilePath -> String -> Maybe Delta ->

@@ -1131,7 +1138,7 @@ parseProg syn fname input mrk

1131 let (fc, msg) = findFC doc

1138 let (fc, msg) = findFC doc

1132 i <- getIState

1139 i <- getIState

1133 case idris_outputmode i of

1140 case idris_outputmode i of

1134− RawOutput -> ihputStrLn (idris_outh i) (show doc)

1141+ RawOutput -> ihputStrLn (idris_outh i) (show $ fixColour (idris_colourRepl i) doc)

1135 IdeSlave n -> ihWarn (idris_outh i) fc (P.text msg)

1142 IdeSlave n -> ihWarn (idris_outh i) fc (P.text msg)

1136 putIState (i { errSpan = Just fc })

1143 putIState (i { errSpan = Just fc })

1137 return []

1144 return []

@@ -1212,6 +1219,14 @@ loadSource h lidr f

1212 file_in <- runIO $ readFile f

1219 file_in <- runIO $ readFile f

1213 file <- if lidr then tclift $ unlit f file_in else return file_in

1220 file <- if lidr then tclift $ unlit f file_in else return file_in

1214 (mname, imports, pos) <- parseImports f file

1221 (mname, imports, pos) <- parseImports f file

1222+ ids <- allImportDirs

1223+ ibcsd <- valIBCSubDir i

1224+ mapM_ (\f -> do fp <- runIO $ findImport ids ibcsd f

1225+ case fp of

1226+ LIDR fn -> ifail $ "No ibc for " ++ f

1227+ IDR fn -> ifail $ "No ibc for " ++ f

1228+ IBC fn src -> loadIBC fn)

1229+ [fn | (fn, _, _) <- imports]

1215 reportParserWarnings

1230 reportParserWarnings

1216

1231

1217 -- process and check module aliases

1232 -- process and check module aliases

src/Idris/PartialEval.hs+1−1

@@ -124,7 +124,7 @@ getSpecApps ist env tm = ga env (explicitNames tm) where

124 | imparg imp = (ImplicitD, tm)

125 | otherwise = (ExplicitD, (P Ref (sUN (show n ++ "arg")) Erased))

126

127− imparg (PExp _ _ _) = False

127+ imparg (PExp _ _ _ _) = False

128 imparg _ = True

129

130 buildApp env [] [] _ _ = []

src/Idris/Prover.hs+7−5

@@ -7,6 +7,7 @@ import Idris.Core.CaseTree

7import Idris.Core.Typecheck

8

9import Idris.AbsSyntax

10+import Idris.AbsSyntaxTree

10import Idris.Delaborate

11import Idris.Delaborate

11import Idris.ElabDecls

12import Idris.ElabDecls

12import Idris.ElabTerm

13import Idris.ElabTerm

@@ -15,6 +16,7 @@ import Idris.Error

15import Idris.DataOpts

16import Idris.DataOpts

16import Idris.Completion

17import Idris.Completion

17import Idris.IdeSlave

18import Idris.IdeSlave

19+import Idris.Output

18

20

19import Text.Trifecta.Result(Result(..))

21import Text.Trifecta.Result(Result(..))

20

22

@@ -32,7 +34,7 @@ prover lit x =

32 i <- getIState

34 i <- getIState

33 case lookupTy x ctxt of

35 case lookupTy x ctxt of

34 [t] -> if elem x (map fst (idris_metavars i))

36 [t] -> if elem x (map fst (idris_metavars i))

35− then prove ctxt lit x t

37+ then prove (idris_optimisation i) ctxt lit x t

36 else ifail $ show x ++ " is not a metavariable"

38 else ifail $ show x ++ " is not a metavariable"

37 _ -> fail "No such metavariable"

39 _ -> fail "No such metavariable"

38

40

@@ -55,8 +57,8 @@ assumptionNames e

55 names ((MN _ _, _) : bs) = names bs

57 names ((MN _ _, _) : bs) = names bs

56 names ((n, _) : bs) = show n : names bs

58 names ((n, _) : bs) = show n : names bs

57

59

58−prove :: Context -> Bool -> Name -> Type -> Idris ()

60+prove :: Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()

59−prove ctxt lit n ty

61+prove opt ctxt lit n ty

60 = do let ps = initElaborator n ctxt ty

62 = do let ps = initElaborator n ctxt ty

61 ideslavePutSExp "start-proof-mode" n

63 ideslavePutSExp "start-proof-mode" n

62 (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, []) "" Nothing) Nothing

64 (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, []) "" Nothing) Nothing

@@ -66,7 +68,7 @@ prove ctxt lit n ty

66 ideslavePutSExp "end-proof-mode" n

68 ideslavePutSExp "end-proof-mode" n

67 let proofs = proof_list i

69 let proofs = proof_list i

68 putIState (i { proof_list = (n, prf) : proofs })

70 putIState (i { proof_list = (n, prf) : proofs })

69− let tree = simpleCase False True False CompileTime (fileFC "proof") [] [([], P Ref n ty, tm)]

71+ let tree = simpleCase False True False CompileTime (fileFC "proof") [] [] [([], P Ref n ty, tm)]

70 logLvl 3 (show tree)

72 logLvl 3 (show tree)

71 (ptm, pty) <- recheckC (fileFC "proof") [] tm

73 (ptm, pty) <- recheckC (fileFC "proof") [] tm

72 logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++

74 logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++

@@ -76,7 +78,7 @@ prove ctxt lit n ty

76 Error e -> ierror (CantUnify False ty pty e [] 0)

78 Error e -> ierror (CantUnify False ty pty e [] 0)

77 ptm' <- applyOpts ptm

79 ptm' <- applyOpts ptm

78 updateContext (addCasedef n (CaseInfo True False) False False True False

80 updateContext (addCasedef n (CaseInfo True False) False False True False

79− []

81+ [] [] -- argtys, inaccArgs

80 [Right (P Ref n ty, ptm)]

82 [Right (P Ref n ty, ptm)]

81 [([], P Ref n ty, ptm)]

83 [([], P Ref n ty, ptm)]

82 [([], P Ref n ty, ptm)]

84 [([], P Ref n ty, ptm)]

src/Idris/Providers.hs+2−1

@@ -11,7 +11,8 @@ import Debug.Trace

11

12-- | Wrap a type provider in the type of type providers

13providerTy :: FC -> PTerm -> PTerm

14+providerTy fc tm

14−providerTy fc tm = PApp fc (PRef fc $ sUN "Provider") [PExp 0 [] tm]

15+ = PApp fc (PRef fc $ sUN "Provider") [PExp 0 [] (sMN 0 "pvarg") tm]

15

16

16ioret = sUN "prim_io_return"

17ioret = sUN "prim_io_return"

17ermod = sNS (sUN "Error") ["Providers"]

18ermod = sNS (sUN "Error") ["Providers"]

src/Idris/REPL.hs+208−127

@@ -8,15 +8,15 @@ import Idris.Apropos (apropos)

8import Idris.REPLParser

9import Idris.ElabDecls

10import Idris.ElabTerm

11+import Idris.Erasure

11import Idris.Error

12import Idris.Error

12import Idris.ErrReverse

13import Idris.ErrReverse

13import Idris.Delaborate

14import Idris.Delaborate

14import Idris.Docstrings (Docstring, overview, renderDocstring)

15import Idris.Docstrings (Docstring, overview, renderDocstring)

15import Idris.Prover

16import Idris.Prover

16−import Idris.Parser

17+import Idris.Parser hiding (indent)

17import Idris.Primitives

18import Idris.Primitives

18import Idris.Coverage

19import Idris.Coverage

19−import Idris.UnusedArgs

20import Idris.Docs hiding (Doc)

21import Idris.Help

22import Idris.Completion

@@ -27,6 +27,7 @@ import Idris.Colours hiding (colourise)

27import Idris.Inliner

28import Idris.CaseSplit

29import Idris.DeepSeq

30+import Idris.Output

30

31

31import Paths_idris

32import Paths_idris

32import Version_idris (gitHash)

33import Version_idris (gitHash)

@@ -78,8 +79,6 @@ import Data.Version

78import Data.Word (Word)

79import Data.Word (Word)

79import Control.DeepSeq

80import Control.DeepSeq

80

81

81−import qualified Text.PrettyPrint.ANSI.Leijen as ANSI

82−

83import Debug.Trace

82import Debug.Trace

84

83

85-- | Run the REPL

84-- | Run the REPL

@@ -217,83 +216,133 @@ ideslave orig mods

217 (f:_) -> f

216 (f:_) -> f

218 _ -> ""

217 _ -> ""

219 case IdeSlave.sexpToCommand sexp of

218 case IdeSlave.sexpToCommand sexp of

220− Just (IdeSlave.Interpret cmd) ->

219+ Just cmd -> runIdeSlaveCommand id orig fn mods cmd

221− do c <- colourise

222− case parseCmd i "(input)" cmd of

223− Failure err -> iPrintError $ show (fixColour c err)

224− Success (Prove n') -> do iPrintResult ""

225− idrisCatch

226− (process stdout fn (Prove n'))

227− (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)

228− isetPrompt (mkPrompt mods)

229− Success cmd -> idrisCatch

230− (ideslaveProcess fn cmd)

231− (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)

232− Just (IdeSlave.REPLCompletions str) ->

233− do (unused, compls) <- replCompletion (reverse str, "")

234− let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok", IdeSlave.toSExp (map replacement compls, reverse unused)]

235− runIO $ putStrLn $ IdeSlave.convSExp "return" good id

236− Just (IdeSlave.LoadFile filename) ->

237− do clearErr

238− putIState (orig { idris_options = idris_options i,

239− idris_outputmode = (IdeSlave id) })

240− loadInputs stdout [filename]

241− isetPrompt (mkPrompt [filename])

242− -- Report either success or failure

243− i <- getIState

244− case (errSpan i) of

245− Nothing -> iPrintResult $ "loaded " ++ filename

246− Just x -> iPrintError $ "didn't load " ++ filename

247− ideslave orig [filename]

248− Just (IdeSlave.TypeOf name) ->

249− case splitName name of

250− Left err -> iPrintError err

251− Right n -> process stdout "(ideslave)"

252− (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))

253− Just (IdeSlave.DocsFor name) ->

254− case splitName name of

255− Left err -> iPrintError err

256− Right n -> process stdout "(ideslave)" (DocStr n)

257− Just (IdeSlave.CaseSplit line name) ->

258− process stdout fn (CaseSplitAt False line (sUN name))

259− Just (IdeSlave.AddClause line name) ->

260− process stdout fn (AddClauseFrom False line (sUN name))

261− Just (IdeSlave.AddProofClause line name) ->

262− process stdout fn (AddProofClauseFrom False line (sUN name))

263− Just (IdeSlave.AddMissing line name) ->

264− process stdout fn (AddMissing False line (sUN name))

265− Just (IdeSlave.MakeWithBlock line name) ->

266− process stdout fn (MakeWith False line (sUN name))

267− Just (IdeSlave.ProofSearch line name hints) ->

268− process stdout fn (DoProofSearch False line (sUN name) (map sUN hints))

269− Just (IdeSlave.Apropos a) ->

270− process stdout fn (Apropos a)

271− Just (IdeSlave.GetOpts) ->

272− do ist <- getIState

273− let opts = idris_options ist

274− let impshow = opt_showimp opts

275− let errCtxt = opt_errContext opts

276− let options = (IdeSlave.SymbolAtom "ok",

277− [(IdeSlave.SymbolAtom "show-implicits", impshow),

278− (IdeSlave.SymbolAtom "error-context", errCtxt)])

279− runIO . putStrLn $ IdeSlave.convSExp "return" options id

280− Just (IdeSlave.SetOpt IdeSlave.ShowImpl b) ->

281− do setImpShow b

282− let msg = (IdeSlave.SymbolAtom "ok", b)

283− runIO . putStrLn $ IdeSlave.convSExp "return" msg id

284− Just (IdeSlave.SetOpt IdeSlave.ErrContext b) ->

285− do setErrContext b

286− let msg = (IdeSlave.SymbolAtom "ok", b)

287− runIO . putStrLn $ IdeSlave.convSExp "return" msg id

288− Nothing -> do iPrintError "did not understand")

220+ Nothing -> iPrintError "did not understand" )

289 (\e -> do iPrintError $ show e))

221 (\e -> do iPrintError $ show e))

290 (\e -> do iPrintError $ show e)

222 (\e -> do iPrintError $ show e)

291 ideslave orig mods

223 ideslave orig mods

224+

225+-- | Run IDESlave commands

226+runIdeSlaveCommand :: Integer -- ^^ The continuation ID for the client

227+ -> IState -- ^^ The original IState

228+ -> FilePath -- ^^ The current open file

229+ -> [FilePath] -- ^^ The currently loaded modules

230+ -> IdeSlave.IdeSlaveCommand -- ^^ The command to process

231+ -> Idris ()

232+runIdeSlaveCommand id orig fn mods (IdeSlave.Interpret cmd) =

233+ do c <- colourise

234+ i <- getIState

235+ case parseCmd i "(input)" cmd of

236+ Failure err -> iPrintError $ show (fixColour c err)

237+ Success (Prove n') -> do iPrintResult ""

238+ idrisCatch

239+ (process stdout fn (Prove n'))

240+ (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)

241+ isetPrompt (mkPrompt mods)

242+ Success cmd -> idrisCatch

243+ (ideslaveProcess fn cmd)

244+ (\e -> getIState >>= ihRenderError stdout . flip pprintErr e)

245+runIdeSlaveCommand id orig fn mods (IdeSlave.REPLCompletions str) =

246+ do (unused, compls) <- replCompletion (reverse str, "")

247+ let good = IdeSlave.SexpList [IdeSlave.SymbolAtom "ok",

248+ IdeSlave.toSExp (map replacement compls,

249+ reverse unused)]

250+ runIO $ putStrLn $ IdeSlave.convSExp "return" good id

251+runIdeSlaveCommand id orig fn mods (IdeSlave.LoadFile filename) =

252+ do i <- getIState

253+ clearErr

254+ putIState (orig { idris_options = idris_options i,

255+ idris_outputmode = (IdeSlave id) })

256+ loadInputs stdout [filename]

257+ isetPrompt (mkPrompt [filename])

258+ -- Report either success or failure

259+ i <- getIState

260+ case (errSpan i) of

261+ Nothing -> iPrintResult $ "loaded " ++ filename

262+ Just x -> iPrintError $ "didn't load " ++ filename

263+ ideslave orig [filename]

264+runIdeSlaveCommand id orig fn mods (IdeSlave.TypeOf name) =

265+ case splitName name of

266+ Left err -> iPrintError err

267+ Right n -> process stdout "(ideslave)"

268+ (Check (PRef (FC "(ideslave)" (0,0) (0,0)) n))

292 where splitName :: String -> Either String Name

269 where splitName :: String -> Either String Name

293 splitName s = case reverse $ splitOn "." s of

270 splitName s = case reverse $ splitOn "." s of

294 [] -> Left ("Didn't understand name '" ++ s ++ "'")

271 [] -> Left ("Didn't understand name '" ++ s ++ "'")

295 [n] -> Right $ sUN n

272 [n] -> Right $ sUN n

296 (n:ns) -> Right $ sNS (sUN n) ns

273 (n:ns) -> Right $ sNS (sUN n) ns

274+runIdeSlaveCommand id orig fn mods (IdeSlave.DocsFor name) =

275+ case splitName name of

276+ Left err -> iPrintError err

277+ Right n -> process stdout "(ideslave)" (DocStr n)

278+ where splitName :: String -> Either String Name

279+ splitName s = case reverse $ splitOn "." s of

280+ [] -> Left ("Didn't understand name '" ++ s ++ "'")

281+ [n] -> Right $ sUN n

282+ (n:ns) -> Right $ sNS (sUN n) ns

283+runIdeSlaveCommand id orig fn mods (IdeSlave.CaseSplit line name) =

284+ process stdout fn (CaseSplitAt False line (sUN name))

285+runIdeSlaveCommand id orig fn mods (IdeSlave.AddClause line name) =

286+ process stdout fn (AddClauseFrom False line (sUN name))

287+runIdeSlaveCommand id orig fn mods (IdeSlave.AddProofClause line name) =

288+ process stdout fn (AddProofClauseFrom False line (sUN name))

289+runIdeSlaveCommand id orig fn mods (IdeSlave.AddMissing line name) =

290+ process stdout fn (AddMissing False line (sUN name))

291+runIdeSlaveCommand id orig fn mods (IdeSlave.MakeWithBlock line name) =

292+ process stdout fn (MakeWith False line (sUN name))

293+runIdeSlaveCommand id orig fn mods (IdeSlave.ProofSearch line name hints) =

294+ process stdout fn (DoProofSearch False line (sUN name) (map sUN hints))

295+runIdeSlaveCommand id orig fn mods (IdeSlave.Apropos a) =

296+ process stdout fn (Apropos a)

297+runIdeSlaveCommand id orig fn mods (IdeSlave.GetOpts) =

298+ do ist <- getIState

299+ let opts = idris_options ist

300+ let impshow = opt_showimp opts

301+ let errCtxt = opt_errContext opts

302+ let options = (IdeSlave.SymbolAtom "ok",

303+ [(IdeSlave.SymbolAtom "show-implicits", impshow),

304+ (IdeSlave.SymbolAtom "error-context", errCtxt)])

305+ runIO . putStrLn $ IdeSlave.convSExp "return" options id

306+runIdeSlaveCommand id orig fn mods (IdeSlave.SetOpt IdeSlave.ShowImpl b) =

307+ do setImpShow b

308+ let msg = (IdeSlave.SymbolAtom "ok", b)

309+ runIO . putStrLn $ IdeSlave.convSExp "return" msg id

310+runIdeSlaveCommand id orig fn mods (IdeSlave.SetOpt IdeSlave.ErrContext b) =

311+ do setErrContext b

312+ let msg = (IdeSlave.SymbolAtom "ok", b)

313+ runIO . putStrLn $ IdeSlave.convSExp "return" msg id

314+runIdeSlaveCommand id orig fn mods (IdeSlave.Metavariables cols) =

315+ do ist <- getIState

316+ let mvs = reverse $ map fst (idris_metavars ist) \\ primDefs

317+ imp <- impShow

318+ let mvarTys = map (delabTy ist) mvs

319+ let res = (IdeSlave.SymbolAtom "ok",

320+ zipWith (\ n (prems, concl) -> (n, prems, concl))

321+ (map (IdeSlave.StringAtom . show) mvs)

322+ (map (sexpGoal ist cols imp [] . getGoal) mvarTys))

323+ runIO . putStrLn $ IdeSlave.convSExp "return" res id

324+ where getGoal :: PTerm -> ([(Name, PTerm)], PTerm)

325+ getGoal (PPi _ n t sc) = let (prems, conc) = getGoal sc

326+ in ((n, t):prems, conc)

327+ getGoal tm = ([], tm)

328+ sexpGoal :: IState -> Int -> Bool -> [Name] -> ([(Name, PTerm)], PTerm)

329+ -> ([(String, String, SpanList OutputAnnotation)],

330+ (String, SpanList OutputAnnotation))

331+ sexpGoal ist cols imp ns ([], concl) =

332+ let concl' = displaySpans . renderPretty 0.9 cols . fmap (fancifyAnnots ist) $

333+ pprintPTerm imp (zip ns (repeat False)) [] concl

334+ in ([], concl')

335+ sexpGoal ist cols imp ns ((n, t):ps, concl) =

336+ let n' = case n of

337+ NS (UN nm) ns -> str nm

338+ UN nm | ('_':'_':_) <- str nm -> "_"

339+ | otherwise -> str nm

340+ _ -> "_"

341+ (t', spans) = displaySpans . renderPretty 0.9 cols . fmap (fancifyAnnots ist) $

342+ pprintPTerm imp (zip ns (repeat False)) [] t

343+ rest = sexpGoal ist cols imp (n:ns) (ps, concl)

344+ in ((n', t', spans) : fst rest, snd rest)

345+

297

346

298ideslaveProcess :: FilePath -> Command -> Idris ()

347ideslaveProcess :: FilePath -> Command -> Idris ()

299ideslaveProcess fn Help = process stdout fn Help

348ideslaveProcess fn Help = process stdout fn Help

@@ -319,8 +368,6 @@ ideslaveProcess fn (HNF t) = process stdout fn (HNF t)

319--ideslaveProcess fn TTShell = process stdout fn TTShell -- need some prove mode!

368--ideslaveProcess fn TTShell = process stdout fn TTShell -- need some prove mode!

320ideslaveProcess fn (TestInline t) = process stdout fn (TestInline t)

369ideslaveProcess fn (TestInline t) = process stdout fn (TestInline t)

321

370

322−--that most likely does not work, since we need to wrap

323−--input/output of the executed binary...

324ideslaveProcess fn Execute = do process stdout fn Execute

371ideslaveProcess fn Execute = do process stdout fn Execute

325 iPrintResult ""

372 iPrintResult ""

326ideslaveProcess fn (Compile codegen f) = do process stdout fn (Compile codegen f)

373ideslaveProcess fn (Compile codegen f) = do process stdout fn (Compile codegen f)

@@ -532,7 +579,7 @@ process h fn (Check (PRef _ n))

532 putTy imp ist _ bnd sc = putGoal imp ist ((n,False):bnd) sc

579 putTy imp ist _ bnd sc = putGoal imp ist ((n,False):bnd) sc

533 putGoal imp ist bnd g

580 putGoal imp ist bnd g

534 = text "--------------------------------------" <$>

581 = text "--------------------------------------" <$>

535− annotate (AnnName n Nothing Nothing) (text $ show n) <+> colon <+>

582+ annotate (AnnName n Nothing Nothing Nothing) (text $ show n) <+> colon <+>

536 align (tPretty bnd ist g)

583 align (tPretty bnd ist g)

537

584

538 tPretty bnd ist t = pprintPTerm (opt_showimp (idris_options ist)) bnd [] t

585 tPretty bnd ist t = pprintPTerm (opt_showimp (idris_options ist)) bnd [] t

@@ -608,7 +655,6 @@ process h fn (DebugInfo n)

608 let d = lookupDef n (tt_ctxt i)

655 let d = lookupDef n (tt_ctxt i)

609 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

656 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

610 let cg = lookupCtxtName n (idris_callgraph i)

657 let cg = lookupCtxtName n (idris_callgraph i)

611− findUnusedArgs (map fst cg)

612 i <- getIState

658 i <- getIState

613 let cg' = lookupCtxtName n (idris_callgraph i)

659 let cg' = lookupCtxtName n (idris_callgraph i)

614 sc <- checkSizeChange n

660 sc <- checkSizeChange n

@@ -618,7 +664,8 @@ process h fn (DebugInfo n)

618process h fn (Info n)

664process h fn (Info n)

619 = do i <- getIState

665 = do i <- getIState

620 case lookupCtxt n (idris_classes i) of

666 case lookupCtxt n (idris_classes i) of

621− [c] -> classInfo c

667+ [c] -> do info <- classInfo c

668+ ihRenderResult h info

622 _ -> iPrintError "Not a class"

669 _ -> iPrintError "Not a class"

623process h fn (Search t) = iPrintError "Not implemented"

670process h fn (Search t) = iPrintError "Not implemented"

624-- FIXME: There is far too much repetition in the cases below!

671-- FIXME: There is far too much repetition in the cases below!

@@ -891,17 +938,19 @@ process h fn (TestInline t)

891 c <- colourise

938 c <- colourise

892 iPrintResult (showTm ist (delab ist tm'))

939 iPrintResult (showTm ist (delab ist tm'))

893process h fn Execute

940process h fn Execute

941+ = do ist <- getIState

894− = do (m, _) <- elabVal toplevel False

942+ (m, _) <- elabVal toplevel False

895 (PApp fc

943 (PApp fc

896 (PRef fc (sUN "run__IO"))

944 (PRef fc (sUN "run__IO"))

897 [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

945 [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

898−-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

899 (tmpn, tmph) <- runIO tempfile

946 (tmpn, tmph) <- runIO tempfile

900 runIO $ hClose tmph

947 runIO $ hClose tmph

901 t <- codegen

948 t <- codegen

902 compile t tmpn m

949 compile t tmpn m

950+ case idris_outputmode ist of

903− runIO $ system tmpn

951+ RawOutput -> do runIO $ system tmpn

904− return ()

952+ return ()

953+ IdeSlave n -> do runIO . hPutStrLn h $ IdeSlave.convSExp "run-program" tmpn n

905 where fc = fileFC "main"

954 where fc = fileFC "main"

906process h fn (Compile codegen f)

955process h fn (Compile codegen f)

907 = do (m, _) <- elabVal toplevel False

956 = do (m, _) <- elabVal toplevel False

@@ -992,28 +1041,30 @@ process h fn (Apropos a) =

992 isUN (NS n _) = isUN n

1041 isUN (NS n _) = isUN n

993 isUN _ = False

1042 isUN _ = False

994

1043

995−classInfo :: ClassInfo -> Idris ()

1044+classInfo :: ClassInfo -> Idris (Doc OutputAnnotation)

996−classInfo ci = do iputStrLn "Methods:\n"

1045+classInfo ci = do ist <- getIState

1046+ ctxt <- getContext

1047+ return $

1048+ text "Parameters:" <+>

1049+ hsep (punctuate comma (map (prettyName False params') params)) <>

1050+ line <> line <>

1051+ text "Methods:" <> line <>

997− mapM_ dumpMethod (class_methods ci)

1052+ indent 2 (vsep (map (dumpMethod ist) (class_methods ci))) <> line <> line <>

998− iputStrLn ""

999− iputStrLn "Default superclass instances:\n"

1053+ text "Default superclass instances:" <>

1054+ line <>

1000− mapM_ dumpDefaultInstance (class_default_superclasses ci)

1055+ indent 2 (vsep (map (dumpDefaultInstance ist) (class_default_superclasses ci))) <>

1001− iputStrLn ""

1056+ line <>

1002− iputStrLn "Instances:\n"

1057+ text "Instances:" <> line <>

1003− mapM_ dumpInstance (class_instances ci)

1058+ indent 2 (vsep (map (dumpInstance ist ctxt) (class_instances ci)))

1004− iPrintResult ""

1005−

1006−dumpMethod :: (Name, (FnOpts, PTerm)) -> Idris ()

1059+ where dumpMethod :: IState -> (Name, (FnOpts, PTerm)) -> Doc OutputAnnotation

1007−dumpMethod (n, (_, t)) = iputStrLn $ show n ++ " : " ++ show t

1060+ dumpMethod ist (n, (_, t)) = prettyName False [] n <+> colon <+> pp ist t

1008−

1009−dumpDefaultInstance :: PDecl -> Idris ()

1061+ dumpDefaultInstance :: IState -> PDecl -> Doc OutputAnnotation

1010−dumpDefaultInstance (PInstance _ _ _ _ _ t _ _) = iputStrLn $ show t

1062+ dumpDefaultInstance ist (PInstance _ _ _ _ _ t _ _) = pp ist t

1011−

1012−dumpInstance :: Name -> Idris ()

1063+ dumpInstance :: IState -> Context -> Name -> Doc OutputAnnotation

1013−dumpInstance n = do i <- getIState

1064+ dumpInstance ist ctxt n = pp ist $ delabTy ist n

1014− ctxt <- getContext

1065+ params = class_params ci

1015− case lookupTy n ctxt of

1066+ params' = zip params (repeat False)

1016− ts -> mapM_ (\t -> iputStrLn $ showTm i (delab i t)) ts

1067+ pp ist = pprintPTerm (opt_showimp (idris_options ist)) params' []

1017

1068

1018showTotal :: Totality -> IState -> String

1069showTotal :: Totality -> IState -> String

1019showTotal t@(Partial (Other ns)) i

1070showTotal t@(Partial (Other ns)) i

@@ -1059,6 +1110,7 @@ parseArgs ("--typeintype":ns) = TypeInType : (parseArgs ns)

1059parseArgs ("--total":ns) = DefaultTotal : (parseArgs ns)

1110parseArgs ("--total":ns) = DefaultTotal : (parseArgs ns)

1060parseArgs ("--partial":ns) = DefaultPartial : (parseArgs ns)

1111parseArgs ("--partial":ns) = DefaultPartial : (parseArgs ns)

1061parseArgs ("--warnpartial":ns) = WarnPartial : (parseArgs ns)

1112parseArgs ("--warnpartial":ns) = WarnPartial : (parseArgs ns)

1113+parseArgs ("--warnreach":ns) = WarnReach : (parseArgs ns)

1062parseArgs ("--nocoverage":ns) = NoCoverage : (parseArgs ns)

1114parseArgs ("--nocoverage":ns) = NoCoverage : (parseArgs ns)

1063parseArgs ("--errorcontext":ns) = ErrContext : (parseArgs ns)

1115parseArgs ("--errorcontext":ns) = ErrContext : (parseArgs ns)

1064parseArgs ("--help":ns) = Usage : (parseArgs ns)

1116parseArgs ("--help":ns) = Usage : (parseArgs ns)

@@ -1146,30 +1198,32 @@ loadInputs h inputs

1146 let ninputs = zip [1..] inputs

1198 let ninputs = zip [1..] inputs

1147 ifiles <- mapWhileOK (\(num, input) ->

1199 ifiles <- mapWhileOK (\(num, input) ->

1148 do putIState ist

1200 do putIState ist

1149− v <- verbose

1150− -- when v $ iputStrLn $ "(" ++ show num ++ "/" ++

1151− -- show (length inputs) ++

1152− -- ") " ++ input

1153 modTree <- buildTree

1201 modTree <- buildTree

1154 (map snd (take (num-1) ninputs))

1202 (map snd (take (num-1) ninputs))

1155 input

1203 input

1156 let ifiles = getModuleFiles modTree

1204 let ifiles = getModuleFiles modTree

1157 iLOG ("MODULE TREE : " ++ show modTree)

1205 iLOG ("MODULE TREE : " ++ show modTree)

1158 iLOG ("RELOAD: " ++ show ifiles)

1206 iLOG ("RELOAD: " ++ show ifiles)

1159− when (not (all ibc ifiles) || loadCode) $ tryLoad ifiles

1207+ when (not (all ibc ifiles) || loadCode) $

1208+ tryLoad False (filter (not . ibc) ifiles)

1160 -- return the files that need rechecking

1209 -- return the files that need rechecking

1161− return (if (all ibc ifiles) then ifiles else []))

1210+ return ifiles)

1162 ninputs

1211 ninputs

1163 inew <- getIState

1212 inew <- getIState

1164− -- to check everything worked consistently (in particular, will catch

1213+ let tidata = idris_tyinfodata inew

1165− -- if the ibc version is out of date) if we weren't loading per

1214+ let lineapps = idris_lineapps inew

1166− -- module

1215+ let patdefs = idris_patdefs inew

1216+ -- If it worked, load the whole thing from all the ibcs together

1167 case errSpan inew of

1217 case errSpan inew of

1168 Nothing ->

1218 Nothing ->

1169− do putIState ist

1219+ do putIState (ist { idris_tyinfodata = tidata })

1170− when (not loadCode) $ tryLoad $ nub (concat ifiles)

1220+ ibcfiles <- mapM findNewIBC (nub (concat ifiles))

1221+ tryLoad True (mapMaybe id ibcfiles)

1171 _ -> return ()

1222 _ -> return ()

1172− putIState inew)

1223+ ist <- getIState

1224+ putIState (ist { idris_tyinfodata = tidata,

1225+ idris_lineapps = lineapps,

1226+ idris_patdefs = patdefs }))

1173 (\e -> do i <- getIState

1227 (\e -> do i <- getIState

1174 case e of

1228 case e of

1175 At f _ -> do setErrSpan f

1229 At f _ -> do setErrSpan f

@@ -1178,15 +1232,43 @@ loadInputs h inputs

1178 _ -> do setErrSpan emptyFC -- FIXME! Propagate it

1232 _ -> do setErrSpan emptyFC -- FIXME! Propagate it

1179 iputStrLn (pshow i e))

1233 iputStrLn (pshow i e))

1180 where -- load all files, stop if any fail

1234 where -- load all files, stop if any fail

1181− tryLoad :: [IFileType] -> Idris ()

1235+ tryLoad :: Bool -> [IFileType] -> Idris ()

1182− tryLoad [] = return ()

1236+ tryLoad keepstate [] = return ()

1237+ tryLoad keepstate (f : fs)

1238+ = do ist <- getIState

1183− tryLoad (f : fs) = do loadFromIFile h f

1239+ loadFromIFile h f

1240+ inew <- getIState

1241+ -- FIXME: Save these in IBC to avoid this hack! Need to

1242+ -- preserve it all from source inputs

1243+ let tidata = idris_tyinfodata inew

1244+ let lineapps = idris_lineapps inew

1245+ let patdefs = idris_patdefs inew

1184− ok <- noErrors

1246+ ok <- noErrors

1247+ when ok $ do when (not keepstate) $ putIState ist

1248+ ist <- getIState

1249+ putIState (ist { idris_tyinfodata = tidata,

1250+ idris_lineapps = lineapps,

1251+ idris_patdefs = patdefs })

1185− when ok $ tryLoad fs

1252+ tryLoad keepstate fs

1186

1253

1187 ibc (IBC _ _) = True

1254 ibc (IBC _ _) = True

1188 ibc _ = False

1255 ibc _ = False

1189

1256

1257+ findNewIBC :: IFileType -> Idris (Maybe IFileType)

1258+ findNewIBC i@(IBC _ _) = return (Just i)

1259+ findNewIBC s@(IDR f) = do ist <- get

1260+ ibcsd <- valIBCSubDir ist

1261+ let ibc = ibcPathNoFallback ibcsd f

1262+ ok <- runIO $ doesFileExist ibc

1263+ if ok then return (Just (IBC ibc s))

1264+ else return Nothing

1265+ findNewIBC s@(LIDR f) = do ist <- get

1266+ ibcsd <- valIBCSubDir ist

1267+ let ibc = ibcPathNoFallback ibcsd f

1268+ ok <- runIO $ doesFileExist ibc

1269+ if ok then return (Just (IBC ibc s))

1270+ else return Nothing

1271+

1190 -- Like mapM, but give up when there's an error

1272 -- Like mapM, but give up when there's an error

1191 mapWhileOK f [] = return []

1273 mapWhileOK f [] = return []

1192 mapWhileOK f (x : xs) = do x' <- f x

1274 mapWhileOK f (x : xs) = do x' <- f x

@@ -1271,9 +1353,13 @@ idrisMain opts =

1271

1353

1272 ok <- noErrors

1354 ok <- noErrors

1273 when ok $ case output of

1355 when ok $ case output of

1274− [] -> return ()

1356+ -- just do the checks

1357+ [] -> performUsageAnalysis >> return ()

1358+

1359+ -- the compiler will run usage analysis itself

1275 (o:_) -> idrisCatch (process stdout "" (Compile cgn o))

1360 (o:_) -> idrisCatch (process stdout "" (Compile cgn o))

1276 (\e -> do ist <- getIState ; iputStrLn $ pshow ist e)

1361 (\e -> do ist <- getIState ; iputStrLn $ pshow ist e)

1362+

1277 case script of

1363 case script of

1278 Nothing -> return ()

1364 Nothing -> return ()

1279 Just expr -> execScript expr

1365 Just expr -> execScript expr

@@ -1318,11 +1404,6 @@ execScript expr = do i <- getIState

1318 res <- execute tm

1404 res <- execute tm

1319 runIO $ exitWith ExitSuccess

1405 runIO $ exitWith ExitSuccess

1320

1406

1321−-- | Check if the coloring matches the options and corrects if necessary

1322−fixColour :: Bool -> ANSI.Doc -> ANSI.Doc

1323−fixColour False doc = ANSI.plain doc

1324−fixColour True doc = doc

1325−

1326-- | Get the platform-specific, user-specific Idris dir

1407-- | Get the platform-specific, user-specific Idris dir

1327getIdrisUserDataDir :: Idris FilePath

1408getIdrisUserDataDir :: Idris FilePath

1328getIdrisUserDataDir = runIO $ getAppUserDataDirectory "idris"

1409getIdrisUserDataDir = runIO $ getAppUserDataDirectory "idris"

src/Idris/UnusedArgs.hsdeleted−65

@@ -1,65 +0,0 @@

1−module Idris.UnusedArgs where

2−

3−import Idris.AbsSyntax

4−

5−import Idris.Core.CaseTree

6−import Idris.Core.TT

7−

8−import Control.Monad.State

9−import Data.Maybe

10−import Data.List

11−

12−findUnusedArgs :: [Name] -> Idris ()

13−findUnusedArgs ns = mapM_ traceUnused ns

14−

15−traceUnused :: Name -> Idris ()

16−traceUnused n

17− = do i <- getIState

18− case lookupCtxt n (idris_callgraph i) of

19− [CGInfo args calls scg usedns _] ->

20− do let argpos = zip args [0..]

21− let fargs = concatMap (getFargpos calls) argpos

22− logLvl 3 $ show n ++ " used TRACE: " ++ show fargs

23− recused <- mapM (\ (argn, i, (g, j)) ->

24− do u <- used [(n, i)] g j

25− return (argn, u)) fargs

26− logLvl 4 $ show n ++ " recused TRACE: " ++ show recused

27− let fused = nub $ usedns ++ map fst (filter snd recused)

28− logLvl 1 $ show n ++ " used args: " ++ show fused

29− let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)

30− logLvl 1 $ show n ++ " unused args: " ++ show (args, unusedpos)

31− addToCG n (CGInfo args calls scg usedns unusedpos) -- updates

32− _ -> return ()

33− where

34− getUnused fused (i,n) | n `elem` fused = Nothing

35− | otherwise = Just i

36−

37−used :: [(Name, Int)] -> Name -> Int -> Idris Bool

38−used path g j

39− | (g, j) `elem` path = return False -- cycle, never used on the way

40− | otherwise

41− = do logLvl 5 $ (show ((g, j) : path))

42− i <- getIState

43− case lookupCtxt g (idris_callgraph i) of

44− [CGInfo args calls scg usedns unused] ->

45− if (j >= length args)

46− then -- overapplied, assume used

47− return True

48− else do let directuse = args!!j `elem` usedns

49− let garg = getFargpos calls (args!!j, j)

50− logLvl 5 $ show (g, j, garg)

51− recused <- mapM (\ (argn, j, (g', j')) ->

52− used ((g,j):path) g' j') garg

53− -- used on any route from here, or not used recursively

54− return (directuse || or recused)

55− _ -> return True -- no definition, assume used

56−

57−getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]

58−getFargpos calls (n, i) = concatMap (getCallArgpos n i) calls

59− where getCallArgpos :: Name -> Int -> (Name, [[Name]]) ->

60− [(Name, Int, (Name, Int))]

61− getCallArgpos n i (g, args)

62− = let argpos = zip [0..] args in

63− mapMaybe (\ (j, xs) -> if n `elem` xs then Just (n, i, (g, j))

64− else Nothing) argpos

65−

src/Pkg/Package.hs+1

@@ -17,6 +17,7 @@ import Data.List.Split(splitOn)

17import Idris.Core.TT

18import Idris.REPL

19import Idris.AbsSyntax

20+import Idris.Output

20

21

21import IRTS.System

22import IRTS.System

22

23

src/Util/LLVMStubs.hs+2−9

@@ -20,12 +20,5 @@ getHostCPUName :: IO String

20getHostCPUName = return ""

21

22

23−codegenLLVM :: [(TT.Name, SDecl)] ->

23+codegenLLVM :: CodeGenerator

24− String -> -- target triple

25− String -> -- target CPU

26− Word -> -- Optimization degree

27− FilePath -> -- output file name

28− OutputType ->

29− IO ()

30−

31−codegenLLVM _ _ _ _ _ _ = fail "This Idris was compiled without the LLVM backend."

24+codegenLLVM _ = fail "This Idris was compiled without the LLVM backend."

test/basic001/reg005.idr+15−16

@@ -1,17 +1,22 @@

1module Main

2

3+%flag C "-g3 -ggdb -O0"

4+

3rep : (n : Nat) -> Char -> Vect n Char

5rep : (n : Nat) -> Char -> Vect n Char

4rep Z x = []

6rep Z x = []

5rep (S k) x = x :: rep k x

7rep (S k) x = x :: rep k x

6

8

7data RLE : Vect n Char -> Type where

9data RLE : Vect n Char -> Type where

8 REnd : RLE []

10 REnd : RLE []

11+ RChar : .{k : Nat}

9− RChar : {xs : Vect k Char} ->

12+ -> {xs : Vect k Char}

13+ -> (n : Nat)

10− (n : Nat) -> (x : Char) -> RLE xs ->

14+ -> (x : Char)

15+ -> RLE xs

11− RLE (rep (S n) x ++ xs)

16+ -> RLE (rep (S n) x ++ xs)

12

17

13eq : (x : Char) -> (y : Char) -> Maybe (x = y)

18eq : (x : Char) -> (y : Char) -> Maybe (x = y)

14−eq x y = if x == y then Just ?eqCharOK else Nothing

19+eq x y = if x == y then Just (believe_me (refl {x})) else Nothing

15

20

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

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

17

22

@@ -32,20 +37,14 @@ compress xs with (rle xs)

32 = let ni : Integer = cast (S n) in

37 = let ni : Integer = cast (S n) in

33 show ni ++ strCons x (compress xs)

38 show ni ++ strCons x (compress xs)

34

39

40+{-

41+fmt : {xs : Vect n Char} -> RLE xs -> String

42+fmt REnd = ""

43+fmt (RChar n c xs) = show n ++ show c ++ fmt xs

44+-}

45+

35compressString : String -> String

46compressString : String -> String

36compressString xs = compress (fromList (unpack xs))

47compressString xs = compress (fromList (unpack xs))

37

48

38main : IO ()

49main : IO ()

39main = putStrLn (compressString "foooobaaaarbaaaz")

50main = putStrLn (compressString "foooobaaaarbaaaz")

40−

41−

42−

43−---------- Proofs ----------

44−

45−Main.eqCharOK = proof {

46− intros;

47− refine believe_me;

48− exact x = x;

49−}

50−

51−

test/basic002/test006.idr+2−2

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

1module Main

2

3data Parity : Nat -> Type where

4− even : Parity (n + n)

4+ even : {n : Nat} -> Parity (n + n)

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

5+ odd : {n : Nat} -> Parity (S (n + n))

6

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

8parity Z = even {n=Z}

test/basic007/test033.idr+1−1

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

1module Main

2

3main : IO ()

4−main = nullPtr null >>= (putStrLn . show)

4+main = nullPtr null >>= print

test/error004/FunErrTest.idr+1−1

@@ -6,7 +6,6 @@ import Language.Reflection.Utils

6

7%language ErrorReflection

8

9−

10total

9total

11cadr : (xs : List a)

10cadr : (xs : List a)

12 -> {auto cons1 : isCons xs = True}

11 -> {auto cons1 : isCons xs = True}

@@ -14,6 +13,7 @@ cadr : (xs : List a)

14 -> a

13 -> a

15cadr (x :: (y :: _)) {cons1=refl} {cons2=refl} = y

14cadr (x :: (y :: _)) {cons1=refl} {cons2=refl} = y

16cadr (x :: []) {cons1=refl} {cons2=refl} impossible

15cadr (x :: []) {cons1=refl} {cons2=refl} impossible

16+cadr [] {cons1=refl} {cons2=refl} impossible

17

18extractList : TT -> Maybe TT

19extractList (App (App reflCon (App isCons lst)) _) = Just lst

test/proof003/Parity.idr+2−2

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

1module Parity

2

3data Parity : Nat -> Type where

4− even : Parity (n + n)

4+ even : {n : Nat} -> Parity (n + n)

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

5+ odd : {n : Nat} -> Parity (S (n + n))

6

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

8parity Z = even {n=Z}

test/proof005/DefaultArgSubstitutionSuccess.idrnew file+44

@@ -0,0 +1,44 @@

1+module DefaultArgSubstitutionSuccess

2+

3+DecProofType : {a:Type} -> Dec a -> Type

4+DecProofType {a} (Yes _) = a

5+DecProofType {a} (No _) = a -> _|_

6+

7+decProof : {a:Type} -> (dec : Dec a) -> DecProofType dec

8+decProof (Yes x) = x

9+decProof (No x) = x

10+

11+DecType : {a:Type} -> Dec a -> Type

12+DecType {a} _ = a

13+

14+

15+argsAreSame : (n:Nat) -> (m:Nat)

16+ -> { default (decProof (decEq m n)) same : (m=n) } -> ()

17+argsAreSame _ _ = ()

18+

19+

20+argsAreDiff : (n:Nat) -> (m:Nat)

21+ -> { default (decProof (decEq m n)) same : (m=n) -> _|_ } -> ()

22+argsAreDiff _ _ = ()

23+

24+

25+data SameNats : Type where

26+ same : (n:Nat) -> (m:Nat) ->

27+ { default (decProof (decEq m n)) same : (m=n) } -> SameNats

28+

29+data DiffNats : Type where

30+ diff : (n:Nat) -> (m:Nat) ->

31+ { default (decProof (decEq m n)) same : (m=n) -> _|_ } -> DiffNats

32+

33+

34+zArgsAreSame : ()

35+zArgsAreSame = argsAreSame Z Z

36+

37+zszArgsAreDiff : ()

38+zszArgsAreDiff = argsAreDiff Z (S Z)

39+

40+sameNatZs : SameNats

41+sameNatZs = same Z Z

42+

43+diffNatsZSZ : DiffNats

44+diffNatsZSZ = diff Z (S Z)

test/proof005/expectednew file

No changes to the content.

test/proof005/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris --check $@ DefaultArgSubstitutionSuccess.idr

3+rm -f *.ibc

test/proof006/DefaultArgSubstitutionSyntax.idrnew file+49

@@ -0,0 +1,49 @@

1+module DefaultArgSubstitutionSyntax

2+

3+DecProofType : {a:Type} -> Dec a -> Type

4+DecProofType {a} (Yes _) = a

5+DecProofType {a} (No _) = a -> _|_

6+

7+decProof : {a:Type} -> (dec : Dec a) -> DecProofType dec

8+decProof (Yes x) = x

9+decProof (No x) = x

10+

11+DecType : {a:Type} -> Dec a -> Type

12+DecType {a} _ = a

13+

14+

15+syntax "{{" [prfname] ":" "accept" [dec] "}}" "->" [ret]

16+ = { default (decProof dec) prfname : DecType dec } -> ret

17+

18+syntax "{{" [prfname] ":" "reject" [dec] "}}" "->" [ret]

19+ = { default (decProof dec) prfname : DecType dec -> _|_ } -> ret

20+

21+

22+argsAreSame : (n:Nat) -> (m:Nat)

23+ -> {{ same : accept (decEq n m) }} -> ()

24+argsAreSame _ _ = ()

25+

26+

27+argsAreDiff : (n:Nat) -> (m:Nat)

28+ -> {{ diff : reject (decEq m n) }} -> ()

29+argsAreDiff _ _ = ()

30+

31+

32+data SameNats : Type where

33+ same : (n:Nat) -> (m:Nat) -> {{ same : accept (decEq m n) }} -> SameNats

34+

35+data DiffNats : Type where

36+ diff : (n:Nat) -> (m:Nat) -> {{ diff : reject (decEq m n) }} -> DiffNats

37+

38+

39+zArgsAreSame : ()

40+zArgsAreSame = argsAreSame Z Z

41+

42+zszArgsAreDiff : ()

43+zszArgsAreDiff = argsAreDiff Z (S Z)

44+

45+sameNatZs : SameNats

46+sameNatZs = same Z Z

47+

48+diffNatsZSZ : DiffNats

49+diffNatsZSZ = diff Z (S Z)

test/proof006/expectednew file

No changes to the content.

test/proof006/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris --check $@ DefaultArgSubstitutionSyntax.idr

3+rm -f *.ibc

test/proof007/DefaultArgUnknownName.idrnew file+4

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

1+module DefaultArgUnknownName

2+

3+funWithBadDefArg : { default sadgjhsag arg : () } -> ()

4+funWithBadDefArg : _ = ()

test/proof007/expectednew file+1

@@ -0,0 +1 @@

1+No such variable sadgjhsag

test/proof007/runnew file+3

@@ -0,0 +1,3 @@

1+#!/usr/bin/env bash

2+idris --check $@ DefaultArgUnknownName.idr

3+rm -f *.ibc

test/reg025/reg025.idr+1−1

@@ -9,7 +9,7 @@ Cell n = Maybe (Fin n)

9data Board : Nat -> Type where

10 MkBoard : {n : Nat} -> Vect n (Vect n (Cell n)) -> Board n

11

12−emptyBoard : Board n

12+emptyBoard : {n : Nat} -> Board n

13emptyBoard {n=n} = MkBoard (replicate n (replicate n Nothing))

14

15Empty : Cell n -> Type

test/reg039/expectednew file+2

@@ -0,0 +1,2 @@

1+Type checking ./reg039.idr

2+[3, 2, 1]

test/reg039/reg039.idrnew file+12

@@ -0,0 +1,12 @@

1+module LazyExec

2+

3+-- The regression that this tests for is broken laziness in the executor.

4+

5+covering

6+countdown : Int -> Lazy (List Int)

7+countdown n = if n > 0

8+ then (n :: countdown (n-1))

9+ else []

10+

11+go : IO ()

12+go = putStrLn $ show (Force (countdown 3))

test/reg039/runnew file+26

@@ -0,0 +1,26 @@

1+#!/usr/bin/env bash

2+

3+# From http://unix.stackexchange.com/questions/43340/how-to-introduce-timeout-for-shell-scripting

4+# Executes command with a timeout

5+# Params:

6+# $1 timeout in seconds

7+# $2 command

8+# Returns 1 if timed out 0 otherwise

9+timeout() {

10+

11+ time=$1

12+

13+ # start the command in a subshell to avoid problem with pipes

14+ # (spawn accepts one command)

15+ command="/bin/sh -c \"$2\""

16+

17+ expect -c "set echo \"-noecho\"; set timeout $time; spawn -noecho $command; expect timeout { exit 1 } eof { exit 0 }"

18+

19+ if [ $? = 1 ] ; then

20+ echo "Timeout after ${time} seconds"

21+ fi

22+

23+}

24+

25+timeout 60 "idris $@ --nocolour reg039.idr --exec go"

26+rm -f reg039 *.ibc