a3221e3 · Idris-dev · git.iko.soy

.travis.yml+2

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

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

77 # trifecta dependencies

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

9+ # test dependency

10+ - sudo apt-get install -qq expect

911install:

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

1113before_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+

15New in 0.9.12:

26--------------

37

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

59 type inference.

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

711* 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.

913* Lots of performance patches for generated JavaScript.

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

1115 or show the type of expressions.

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

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

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

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

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

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

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

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

2226* Updated 'effects' library

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

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

22language with dependent types.

33

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

11Name: idris

2−Version: 0.9.11.2

2+Version: 0.9.12

33License: BSD3

44License-file: LICENSE

55Author: Edwin Brady

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

469469 , Idris.Docstrings

470470 , Idris.ElabDecls

471471 , Idris.ElabTerm

472+ , Idris.Erasure

472473 , Idris.Error

473474 , Idris.ErrReverse

474475 , Idris.Help

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

476477 , Idris.IdeSlave

477478 , Idris.Imports

478479 , Idris.Inliner

480+ , Idris.Output

479481 , Idris.Parser

480482 , Idris.ParseHelpers

481483 , Idris.ParseOps

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

490492 , Idris.REPLParser

491493 , Idris.Transforms

492494 , Idris.Unlit

493− , Idris.UnusedArgs

494495

495496 , IRTS.BCImp

496497 , IRTS.Bytecode

libs/Makefile−3

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

22 $(MAKE) -C prelude build

33 $(MAKE) -C base build

44 $(MAKE) -C effects build

5− $(MAKE) -C oldeffects build

65 $(MAKE) -C javascript build

76

87

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

109 $(MAKE) -C prelude install

1110 $(MAKE) -C base install

1211 $(MAKE) -C effects install

13− $(MAKE) -C oldeffects install

1412 $(MAKE) -C javascript install

1513

1614clean:

1715 $(MAKE) -C prelude clean

1816 $(MAKE) -C base clean

1917 $(MAKE) -C effects clean

20− $(MAKE) -C oldeffects clean

2118 $(MAKE) -C javascript clean

2219

2320.PHONY: build install clean

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

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

1−module Category.Arrow

1+module Control.Arrow

22

33import Data.Morphisms

44import Control.Category

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

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

3838 y <- g a

3939 return (x, y)

40−

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

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

1−module Prelude.Catchable

1+module Control.Catchable

22

33import Control.IOExcept

44

libs/base/Data/HVect.idr+1

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

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

2020 deleteAt fZ (x::xs) = xs

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

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

2223 deleteAt _ [] impossible

2324

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

12module Effect.File

23

34import Effects

45import Control.IOExcept

56

6−data OpenFile : Mode -> Type where

7+

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

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

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

11+|||

12+||| @ m The file mode.

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

714 FH : File -> OpenFile m

815

916openOK : Mode -> Bool -> Type

1017openOK m True = OpenFile m

1118openOK m False = ()

1219

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

1339data FileIO : Effect where

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

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

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

17−

18− ReadLine : {OpenFile Read} FileIO String

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

20− EOF : {OpenFile Read} FileIO Bool

21−

40+ ||| Open a file with the specified mode.

41+ |||

42+ ||| Opening a file successful moves the state from 'empty' to the

43+ ||| specified mode. If not successful the state is still 'empty'.

44+ |||

45+ ||| @ fname The file name to be opened.

46+ ||| @ m The file mode.

47+ Open : (fname: String)

48+ -> (m : Mode)

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

50+ then OpenFile m

51+ else ()} FileIO Bool

52+

53+ ||| Close a file.

54+ |||

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

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

57+

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

59+ |||

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

61+ ReadLine : {OpenFile Read} FileIO String

62+

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

64+ |||

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

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

67+

68+ ||| End of file?

69+ |||

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

71+ EOF : {OpenFile Read} FileIO Bool

72+

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

74+

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

2276instance Handler FileIO IO where

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

2478 valid <- validFile h

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

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

3488 k e (FH h)

3589

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

3691FILE_IO : Type -> EFFECT

3792FILE_IO t = MkEff t FileIO

3893

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.

39104open : Handler FileIO e =>

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

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

105+ (fname : String)

106+ -> (m : Mode)

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

108+ then OpenFile m

109+ else ())] } Eff e Bool

42110open f m = Open f m

43111

112+

113+||| Close a file.

44114close : Handler FileIO e =>

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

46116close = Close

47117

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

48119readLine : Handler FileIO e =>

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

50121readLine = ReadLine

51122

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

52124writeLine : Handler FileIO e =>

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

54126writeLine str = WriteLine str

55127

128+||| End of file?

56129eof : Handler FileIO e =>

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

58131eof = EOF

59132

60−

61−

62−

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

libs/effects/Effects.idr+3−1

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

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

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

9595rebuildEnv [] SubNil env = env

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

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

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

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

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

100+

99101

100102-- -------------------------------------------------- [ The Effect EDSL itself ]

101103-- some proof automation

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

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

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

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

176176

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+

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

178188 decEq [] [] = Yes refl

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

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

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

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

183−

193+-}

184194

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

186196-- internal implementations.

libs/prelude/IO.idr+3−6

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

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

133133

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

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

136− (\x => prim_io_return x))

135+liftPrimIO = MkIO

137136

138137run__IO : IO () -> PrimIO ()

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

140− (\ b => prim_io_return b)

138+run__IO (MkIO f) = f TheWorld

141139

142140run__provider : IO a -> PrimIO a

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

144− (\ b => prim_io_return b)

141+run__provider (MkIO f) = f TheWorld

145142

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

147144

libs/prelude/Prelude/Applicative.idr+2

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

11module Prelude.Applicative

22

33import Builtins

4+import Prelude.Basics

5+import Prelude.Classes

46import Prelude.Functor

57

68---- Applicative functors/Idioms

libs/prelude/Prelude/Chars.idr+3

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

11module Prelude.Char

22-- Functions operating over Chars

33

4+import Prelude.Bool

5+import Prelude.Classes

6+import Prelude.List

47import Builtins

58

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

libs/prelude/Prelude/Fin.idr+11

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

22

33import Prelude.Nat

44import Prelude.Either

5+import Prelude.Uninhabited

56

67%default total

78

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

1112 fZ : Fin (S k)

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

1314

15+instance Uninhabited (Fin Z) where

16+ uninhabited fZ impossible

17+ uninhabited (fS f) impossible

18+

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

1520fSInjective left _ refl = refl

1621

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

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

9499(+) (fS f) f' = fS (f + f')

95100

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+

96107||| Multiply two Fins, extending the bound

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

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

libs/prelude/Prelude/List.idr+8

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

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

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

424424

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+

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

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

427435partition p (x::xs) =

libs/prelude/Prelude/Nat.idr+4

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

66import Prelude.Bool

77import Prelude.Cast

88import Prelude.Classes

9+import Prelude.Uninhabited

910

1011%access public

1112%default total

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

2021-- name hints for interactive editing

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

2223

24+instance Uninhabited (Z = S n) where

25+ uninhabited refl impossible

26+

2327--------------------------------------------------------------------------------

2428-- Syntactic tests

2529--------------------------------------------------------------------------------

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

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

11module Prelude.Uninhabited

22

3+import Builtins

4+

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

46class Uninhabited t where

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

68 ||| @ t the uninhabited type

79 total uninhabited : t -> _|_

810

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−

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

1712||| @ t some empty type

1813||| @ a the goal type

libs/prelude/Prelude/Vect.idr+10

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

77import Prelude.Classes

88import Prelude.Nat

99import Prelude.Bool

10+import Prelude.Uninhabited

1011

1112%access public

1213%default total

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

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

7273deleteAt fZ (x::xs) = xs

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

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

7476deleteAt _ [] impossible

7577

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

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

379381-- Splitting and breaking lists

380382--------------------------------------------------------------------------------

381383

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+

382392--------------------------------------------------------------------------------

383393-- Predicates

384394--------------------------------------------------------------------------------

main/Main.hs+1

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

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

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

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

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

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

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

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

rts/idris_rts.c+12−3

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

3737 vm->inbox_ptr = vm->inbox;

3838 vm->inbox_write = vm->inbox;

3939

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+

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

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

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

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

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

4453

4554 vm->max_threads = max_threads;

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

7281 }

7382

7483 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

7685 pthread_mutex_lock(&vm->alloc_lock);

7786 }

7887}

7988

8089void idris_doneAlloc(VM* vm) {

8190 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

8392 pthread_mutex_unlock(&vm->alloc_lock);

8493 }

8594}

src/IRTS/CodegenC.hs+26−10

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

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

2121import Control.Monad

2222

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

24− String -> -- output file name

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

26− [FilePath] -> -- include files

27− String -> -- extra object files

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

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

30− DbgLevel ->

31− IO ()

32−codegenC defs out exec incs objs libs flags dbg

23+codegenC :: CodeGenerator

24+codegenC ci = codegenC' (simpleDecls ci)

25+ (outputFile ci)

26+ (outputType ci)

27+ (includes ci)

28+ (concatMap mkObj (compileObjs ci))

29+ (concatMap mkLib (compileLibs ci) ++

30+ concatMap incdir (importDirs ci))

31+ (concatMap mkFlag (compilerFlags ci))

32+ (debugLevel ci)

33+

34+ where mkObj f = f ++ " "

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

36+ mkFlag l = l ++ " "

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

38+

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

40+ String -> -- output file name

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

42+ [FilePath] -> -- include files

43+ String -> -- extra object files

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

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

46+ DbgLevel ->

47+ IO ()

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

3349 = do -- print defs

3450 let bc = map toBC defs

3551 let h = concatMap toDecl (map fst bc)

src/IRTS/CodegenCommon.hs+25

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

22

33import Idris.Core.TT

44import IRTS.Simplified

5+import IRTS.Defunctionalise

6+import IRTS.Lang

57

68import Control.Exception

9+import Data.Word

710import System.Environment

811

912data DbgLevel = NONE | DEBUG | TRACE deriving Eq

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

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

1417 return (Just e))

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

19+

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

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

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

23+

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

25+ outputType :: OutputType,

26+ targetTriple :: String,

27+ targetCPU :: String,

28+ optimisation :: Word,

29+ includes :: [FilePath],

30+ importDirs :: [FilePath],

31+ compileObjs :: [String],

32+ compileLibs :: [String],

33+ compilerFlags :: [String],

34+ debugLevel :: DbgLevel,

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

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

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

38+ }

39+

40+type CodeGenerator = CodegenInfo -> IO ()

src/IRTS/CodegenJava.hs+13−8

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

3434

3535-----------------------------------------------------------------------

3636-- Main function

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

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

39− FilePath -> -- output file name

40− [String] -> -- headers

41− [String] -> -- libs

42− OutputType ->

43− IO ()

44−codegenJava globalInit defs out hdrs libs exec =

37+codegenJava :: CodeGenerator

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

39+ (includes cg) (compileLibs cg)

40+ (outputType cg)

41+

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

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

44+ FilePath -> -- output file name

45+ [String] -> -- headers

46+ [String] -> -- libs

47+ OutputType ->

48+ IO ()

49+codegenJava' globalInit defs out hdrs libs exec =

4550 withTgtDir exec out (codegenJava' exec)

4651 where

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

src/IRTS/CodegenJavaScript.hs+17−4

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

11{-# LANGUAGE PatternGuards #-}

22

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

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

44

55import Idris.AbsSyntax hiding (TypeCase)

66import IRTS.Bytecode

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

11541154

11551155removeInstanceChecks :: JS -> JS

11561156removeInstanceChecks (JSCond conds) =

1157− JSCond $ eliminateDeadBranches $ map (

1157+ removeNoopConds $ JSCond $ eliminateDeadBranches $ map (

11581158 removeHelper *** removeInstanceChecks

11591159 ) conds

11601160 where

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

11691169 eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs

11701170 eliminateDeadBranches [] = []

11711171

1172+

1173+ removeNoopConds :: JS -> JS

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

1175+ removeNoopConds js = js

1176+

11721177removeInstanceChecks js = transformJS removeInstanceChecks js

11731178

11741179

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

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

13901395getIncludes = mapM readFile

13911396

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

13931406 :: JSTarget

13941407 -> [(Name, SDecl)]

13951408 -> [FilePath]

13961409 -> FilePath

13971410 -> OutputType

13981411 -> IO ()

1399−codegenJavaScript target definitions includes filename outputType = do

1412+codegenJS_all target definitions includes filename outputType = do

14001413 let (header, rt) = case target of

14011414 Node ->

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

src/IRTS/CodegenLLVM.hs+13−8

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

5858

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

6060

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

62− String -> -- target triple

63− String -> -- target CPU

64− Word -> -- Optimization degree

65− FilePath -> -- output file name

66− OutputType ->

67− IO ()

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

61+codegenLLVM :: CodeGenerator

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

63+ (targetCPU ci) (optimisation ci)

64+ (outputFile ci) (outputType ci)

65+

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

67+ String -> -- target triple

68+ String -> -- target CPU

69+ Word -> -- Optimization degree

70+ FilePath -> -- output file name

71+ OutputType ->

72+ IO ()

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

6974 initializeAllTargets

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

7176 withTargetOptions $ \options ->

src/IRTS/Compiler.hs+439−322

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

1818import IRTS.Inliner

1919

2020import Idris.AbsSyntax

21−import Idris.UnusedArgs

21+import Idris.AbsSyntaxTree

22+import Idris.Erasure

2223import Idris.Error

2324

25+import Debug.Trace

26+

2427import Idris.Core.TT

2528import Idris.Core.Evaluate

2629import Idris.Core.CaseTree

2730

31+import Control.Applicative

2832import Control.Monad.State

33+import Data.Maybe

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

3040import System.Process

3141import System.IO

3242import System.Directory

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

3747

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

3949compile codegen f tm

40− = do checkMVs

41− let tmnames = namesUsed (STerm tm)

42− usedIn <- mapM (allNames []) tmnames

43− let used = [sUN "prim__subBigInt", sUN "prim__addBigInt"] : usedIn

44− defsIn <- mkDecls tm (concat used)

45− findUnusedArgs (concat used)

50+ = do checkMVs -- check for undefined metavariables

51+ reachableNames <- performUsageAnalysis

4652 maindef <- irMain tm

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

4754 objs <- getObjectFiles codegen

4855 libs <- getLibs codegen

4956 flags <- getFlags codegen

5057 hdrs <- getHdrs codegen

5158 impdirs <- allImportDirs

59+ defsIn <- mkDecls tm reachableNames

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

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

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

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

7179 case dumpDefun of

7280 Nothing -> return ()

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

74− triple <- targetTriple

75− cpu <- targetCPU

76− optimize <- optLevel

82+ triple <- Idris.AbsSyntax.targetTriple

83+ cpu <- Idris.AbsSyntax.targetCPU

84+ optimise <- optLevel

7785 iLOG "Building output"

86+

7887 case checked of

79− OK c -> runIO $ case codegen of

80− ViaC ->

81− codegenC c f outty hdrs

82− (concatMap mkObj objs)

83− (concatMap mkLib libs)

84− (concatMap mkFlag flags ++

85− concatMap incdir impdirs) NONE

86− ViaJava ->

87− codegenJava [] c f hdrs libs outty

88− ViaJavaScript ->

89− codegenJavaScript JavaScript c hdrs f outty

90− ViaNode ->

91− codegenJavaScript Node c hdrs f outty

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

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

92+ runIO $ case codegen of

93+ ViaC -> codegenC cginfo

94+ ViaJava -> codegenJava cginfo

95+ ViaJavaScript -> codegenJavaScript cginfo

96+ ViaNode -> codegenNode cginfo

97+ ViaLLVM -> codegenLLVM cginfo

9398 Bytecode -> dumpBC c f

9499 Error e -> ierror e

95100 where checkMVs = do i <- getIState

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

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

100105 ex <- doesFileExist f

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

108107

109108irMain :: TT Name -> Idris LDecl

110−irMain tm = do i <- ir tm

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

109+irMain tm = do

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

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

112112

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

114114mkDecls t used

115115 = do i <- getIState

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

117− mapM traceUnused used

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

118117 decls <- mapM build ds

119118 return decls

120119

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

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

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

123122 where

124123 showCT (n, LFun _ f args lexp)

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

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

126125 ++ show lexp

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

128127

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+

129148isCon (TyDecl _ _) = True

130149isCon _ = False

131150

132−class ToIR a where

133− ir :: a -> Idris LExp

134−

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

136152build (n, d)

137153 = do i <- getIState

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

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

145161 return (n, def)

146162

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−

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

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

157165

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

159− return (declArgs [] True n e)

166+mkLDecl n (Function tm _)

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

168+

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

161− = let (args, sc) = cases_runtime cd in

162− do e <- ir (args, sc)

163− return (declArgs [] (case_inlinable ci) n e)

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

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

171+ where

172+ (args, sc) = cases_runtime cd

173+

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+

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

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

167182

168−instance ToIR (TT Name) where

169− ir tm = ir' [] tm where

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

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

172− m == txt "mkForeignPrim"

173− = doForeign env args

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

175− u == txt "unsafePerformPrimIO"

176− = ir' env arg

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

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

179− r == txt "replace"

180− = ir' env arg

181− -- Laziness, the old way

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

183− l == txt "lazy"

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

185− error "lazy has crept in somehow"

186−-- return $ LLazyExp arg'

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

188− l == txt "force"

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

190− return $ LForce arg'

191− -- Laziness, the new way

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

193− l == txt "Delay"

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

195− return $ LLazyExp arg'

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

197− l == txt "Force"

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

199− return $ LForce arg'

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

201− a == txt "assert_smaller"

202− = ir' env arg

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

204− a == txt "assert_total"

205− = ir' env arg

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

207− p == txt "par"

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

209− return $ LOp LPar [LLazyExp arg']

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

211− pf == txt "prim_fork"

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

213− return $ LOp LFork [LLazyExp arg']

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

215− m == txt "malloc"

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

217− t' <- ir' env t

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

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

220− tm == txt "trace_malloc"

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

222− return t' -- TODO

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

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

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

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

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

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

229− t' <- ir' env t

230− e' <- ir' env e

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

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

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

234− = irCon env t a n args

235− | (P (TCon t a) n _, args) <- unApply tm

236− = return LNothing

237− | (P _ n _, args) <- unApply tm

238− = do i <- getIState

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

240− case getPrim i n args' of

241− Just tm -> return tm

242− _ -> do

243− let collapse

244− = case lookupCtxtExact n

245− (idris_optimisation i) of

246− Just oi -> collapsible oi

247− _ -> False

248− let unused

249− = case lookupCtxtExact n

250− (idris_callgraph i) of

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

252− unusedpos

253− _ -> []

254− if collapse

255− then return LNothing

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

257− (mkUnused unused 0 args'))

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

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

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

261− return (LApp False f' args')

262− where mkUnused u i [] = []

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

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

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

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

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

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

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

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

271− = do let n' = uniqueName n env

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

273− return $ LLam [n'] sc'

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

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

276− v' <- ir' env v

277− return $ LLet n v' sc'

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

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

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

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

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

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

284− return $ LProj t' i

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

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

287− ir' env Erased = return $ LNothing

288− ir' env Impossible = return $ LNothing

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

290−

291− irCon env t arity n args

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

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

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

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

296− return $ LLam extra sc'

297−

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

299−

300− buildApp env e [] = return e

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

302− return $ LApp False e xs'

303−

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

305− doForeign env (_ : fgn : args)

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

307− = let maybeTys = getFTypes fgnArgTys

308− rty = mkIty' ret in

309− case maybeTys of

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

311− Just tys -> do

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

313− -- wrap it in a prim__IO

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

315− return $ -- LLazyExp $

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

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

318−

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

320−getFTypes tm = case unApply tm of

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

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

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

324− _ -> Nothing

325−

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

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

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

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

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

331− io == txt "IO"

183+data VarInfo = VI

184+ { viMethod :: Maybe Name

185+ }

186+ deriving Show

187+

188+type Vars = M.Map Name VarInfo

189+

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

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

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

193+ | m == txt "mkForeignPrim"

194+ -> doForeign vs env args

195+

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

197+ | u == txt "unsafePerformPrimIO"

198+ -> irTerm vs env arg

199+

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

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

202+ | r == txt "replace"

203+ -> irTerm vs env arg

204+

205+ -- Laziness, the old way

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

207+ | l == txt "lazy"

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

209+

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

211+ | l == txt "force"

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

213+

214+ -- Laziness, the new way

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

216+ | l == txt "Delay"

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

218+

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

220+ | l == txt "Force"

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

222+

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

224+ | a == txt "assert_smaller"

225+ -> irTerm vs env arg

226+

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

228+ | a == txt "assert_total"

229+ -> irTerm vs env arg

230+

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

232+ | p == txt "par"

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

234+ return $ LOp LPar [LLazyExp arg']

235+

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

237+ | pf == txt "prim_fork"

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

239+ return $ LOp LFork [LLazyExp arg']

240+

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

242+ | m == txt "malloc"

243+ -> irTerm vs env t

244+

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

246+ | tm == txt "trace_malloc"

247+ -> irTerm vs env t -- TODO

248+

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

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

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

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

253+ | be == txt "boolElim"

254+ , d == txt "Delay"

255+ , d' == txt "Delay"

256+ -> do

257+ x' <- irTerm vs env x

258+ t' <- irTerm vs env t

259+ e' <- irTerm vs env e

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

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

262+ ])

263+

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

265+ ist <- getIState

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

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

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

269+

270+ when (length args > arity) $

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

272+

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

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

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

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)

294+ -> LApp False

295+ <$> irTerm vs env f

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

297+

298+ where

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

300+ applyName n ist args =

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'

318+ | otherwise = n

319+

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

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

322+

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

324+irTerm vs env (V i)

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

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

327+

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

329+ where

330+ n' = uniqueName n env

331+

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

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

334+

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

336+

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

338+ t' <- irTerm vs env t

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

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

341+

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

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

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

345+irTerm vs env Erased = return $ LNothing

346+irTerm vs env Impossible = return $ LNothing

347+

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

349+irCon vs env arity n args

350+ | length args > arity

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

352+

353+ -- saturated

354+ | length args == arity

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

356+

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

363+ buildApp e [] = return e

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

365+

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

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

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

369+ = case getFTypes fgnArgTys of

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

371+ Just tys -> do

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

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

374+

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

376+ where

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

378+ getFTypes tm = case unApply tm of

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

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

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

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

383+ _ -> Nothing

384+

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

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

387+ | fi == txt "FIntT"

388+ = mkIntIty (str intTy)

389+

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

391+ | ff == txt "FFunction"

392+ , fa == txt "FAny"

393+ , io == txt "IO"

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

438395

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

213213usedIn env _ = []

214214

215215instance Show LExp where

216− show e = show' [] e where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

238− show' env LNothing = "____"

239−

240− showAlt env (LConCase _ n args e)

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

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

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

219+

220+ show' env ind (LLazyApp e args)

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

222+

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

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

225+

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

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

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

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

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

231+

232+ show' env ind (LLam args e)

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

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

235+

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

237+

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

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

240+

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)

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

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

250+

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

252+

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

254+ [ "foreign{ "

255+ , n ++ "("

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)

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

264+

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

266+ show' env ind LNothing = "____"

267+

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

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

242− ++ show' env e

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

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

245−

246−

247−

270+ ++ show' env ind e

248271

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

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

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

9090

91+addImported :: FilePath -> Idris ()

92+addImported f = do i <- getIState

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

94+

9195addLangExt :: LanguageExt -> Idris ()

9296addLangExt TypeProviders = do i <- getIState

9397 putIState $ i {

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

357361getHdrs :: Codegen -> Idris [String]

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

359363

364+getImported :: Idris [FilePath]

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

366+

360367setErrSpan :: FC -> Idris ()

361368setErrSpan x = do i <- getIState;

362369 case (errSpan i) of

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

381388putIState :: IState -> Idris ()

382389putIState = put

383390

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+

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

385402runIO :: IO a -> Idris a

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

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

490507getUndefined = do i <- getIState

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

492509

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+

493516getWidth :: Idris ConsoleWidth

494517getWidth = fmap idris_consolewidth getIState

495518

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

505528 AutomaticWidth -> runIO getScreenWidth

506529

507530

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

587531

588532type1Doc :: Doc OutputAnnotation

589533type1Doc = (annotate AnnConstType $ text "Type 1")

590534

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

638535

639536isetPrompt :: String -> Idris ()

640537isetPrompt p = do i <- getIState

641538 case idris_outputmode i of

642539 IdeSlave n -> runIO . putStrLn $ convSExp "set-prompt" p n

643540

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−

657541setLogLevel :: Int -> Idris ()

658542setLogLevel l = do i <- getIState

659543 let opts = idris_options i

@@ -945,9 +829,9 @@ expandParams dec ps ns infs tm = en tm

945829 | otherwise = PLam n (en t) (en s)

946830 en (PPi p n t s)

947831 | n `elem` (map fst ps ++ ns)

948− = let n' = mkShadow n in

949− PPi p n' (en t) (en (shadow n n' s))

950− | otherwise = PPi p n (en t) (en s)

832+ = let n' = mkShadow n in -- TODO THINK SHADOWING TacImp?

833+ PPi (enTacImp p) n' (en t) (en (shadow n n' s))

834+ | otherwise = PPi (enTacImp p) n (en t) (en s)

951835 en (PLet n ty v s)

952836 | n `elem` (map fst ps ++ ns)

953837 = let n' = mkShadow n in

@@ -1006,6 +890,9 @@ expandParams dec ps ns infs tm = en tm

1006890

1007891 nseq x y = nsroot x == nsroot y

1008892

893+ enTacImp (TacImp aos st scr) = TacImp aos st (en scr)

894+ enTacImp other = other

895+

1009896expandParamsD :: Bool -> -- True = RHS only

1010897 IState ->

1011898 (Name -> Name) -> [(Name, PTerm)] -> [Name] -> PDecl -> PDecl

@@ -1202,7 +1089,7 @@ addUsingConstraints syn fc t

12021089 | otherwise = doAdd cs ns t

12031090

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

12061093

12071094 getConstraints (PPi (Constraint _ _) _ c sc)

12081095 = getcapp c ++ getConstraints sc

@@ -1214,7 +1101,7 @@ addUsingConstraints syn fc t

12141101 return (UConstraint c ns)

12151102 getcapp _ = []

12161103

1217− getName (PExp _ _ (PRef _ n)) = return n

1104+ getName (PExp _ _ _ (PRef _ n)) = return n

12181105 getName _ = []

12191106

12201107-- Add implicit Pi bindings for any names in the term which appear in an

@@ -1222,13 +1109,14 @@ addUsingConstraints syn fc t

12221109

12231110-- This has become a right mess already. Better redo it some time...

12241111

1225−implicit :: SyntaxInfo -> Name -> PTerm -> Idris PTerm

1226−implicit syn n ptm = implicit' syn [] n ptm

1112+implicit :: ElabInfo -> SyntaxInfo -> Name -> PTerm -> Idris PTerm

1113+implicit info syn n ptm = implicit' info syn [] n ptm

12271114

1228−implicit' :: SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1229−implicit' syn ignore n ptm

1115+implicit' :: ElabInfo -> SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

1116+implicit' info syn ignore n ptm

12301117 = do i <- getIState

12311118 let (tm', impdata) = implicitise syn ignore i ptm

1119+ defaultArgCheck (eInfoNames info ++ M.keys (idris_implicits i)) impdata

12321120-- let (tm'', spos) = findStatics i tm'

12331121 putIState $ i { idris_implicits = addDef n impdata (idris_implicits i) }

12341122 addIBC (IBCImp n)

@@ -1236,6 +1124,23 @@ implicit' syn ignore n ptm

12361124-- i <- get

12371125-- putIState $ i { idris_statics = addDef n spos (idris_statics i) }

12381126 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

12391144

12401145implicitise :: SyntaxInfo -> [Name] -> IState -> PTerm -> (PTerm, [PArg])

12411146implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

@@ -1281,7 +1186,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

12811186 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

12821187 _ -> [])

12831188 (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,

12851190 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

12861191 imps True (n:env) sc

12871192 imps top env (PPi (Constraint l _) n ty sc)

@@ -1289,7 +1194,7 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

12891194 (PRef _ x) -> namesIn uvars ist sc `dropAll` [n]

12901195 _ -> [])

12911196 (decls, ns) <- get -- ignore decls in HO types

1292− put (PConstraint 10 l Placeholder : decls,

1197+ put (PConstraint 10 l n Placeholder : decls,

12931198 nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

12941199 imps True (n:env) sc

12951200 imps top env (PPi (TacImp l _ scr) n ty sc)

@@ -1455,7 +1360,7 @@ aiFn inpat True ist fc f ds []

14551360-- any constructor alts || any allImp ialts))

14561361 then aiFn inpat False ist fc f ds [] -- use it as a constructor

14571362 else Right $ PPatvar fc f

1458− where imp (PExp _ _ _) = False

1363+ where imp (PExp _ _ _ _) = False

14591364 imp _ = True

14601365-- allImp [] = False

14611366 allImp xs = all imp xs

@@ -1502,27 +1407,41 @@ aiFn inpat expat ist fc f ds as

15021407 [(n,t)] -> t

15031408 _ -> Public

15041409

1505−

15061410 insertImpl :: [PArg] -> [PArg] -> [PArg]

1507− insertImpl (PExp p l ty : ps) (PExp _ _ tm : given) =

1508− PExp p l tm : insertImpl ps given

1509− insertImpl (PConstraint p l ty : ps) (PConstraint _ _ tm : given) =

1510− PConstraint p l tm : insertImpl ps given

1511− insertImpl (PConstraint p l ty : ps) given =

1512− PConstraint p l (PResolveTC fc) : insertImpl ps given

1513− insertImpl (PImp p _ l n ty : ps) given =

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]

1417+ insImpAcc pnas (PExp p l n ty : ps) (PExp _ _ _ tm : given) =

1418+ PExp p l n tm : insImpAcc (M.insert n tm pnas) ps given

1419+ insImpAcc pnas (PConstraint p l n ty : ps) (PConstraint _ _ _ tm : given) =

1420+ PConstraint p l n tm : insImpAcc (M.insert n tm pnas) ps given

1421+ insImpAcc pnas (PConstraint p l n ty : ps) given =

1422+ let rtc = PResolveTC fc in

1423+ PConstraint p l n rtc : insImpAcc (M.insert n rtc pnas) ps given

1424+ insImpAcc pnas (PImp p _ l n ty : ps) given =

15141425 case find n given [] of

1515− Just (tm, given') -> PImp p False l n tm : insertImpl ps given'

1516− Nothing -> PImp p True l n Placeholder : insertImpl ps given

1517− insertImpl (PTacImplicit p l n sc' ty : ps) given =

1518− let sc = addImpl ist sc' in

1426+ Just (tm, given') ->

1427+ PImp p False l n tm : insImpAcc (M.insert n tm pnas) ps given'

1428+ Nothing ->

1429+ PImp p True l n Placeholder :

1430+ insImpAcc (M.insert n Placeholder pnas) ps given

1431+ insImpAcc pnas (PTacImplicit p l n sc' ty : ps) given =

1432+ let sc = addImpl ist (substMatches (M.toList pnas) sc') in

15191433 case find n given [] of

1520− Just (tm, given') -> PTacImplicit p l n sc tm : insertImpl ps given'

1521− Nothing -> if inpat

1522− then PTacImplicit p l n sc Placeholder : insertImpl ps given

1523− else PTacImplicit p l n sc sc : insertImpl ps given

1524− insertImpl expected [] = []

1525− insertImpl _ given = given

1434+ Just (tm, given') ->

1435+ PTacImplicit p l n sc tm :

1436+ insImpAcc (M.insert n tm pnas) ps given'

1437+ Nothing ->

1438+ if inpat

1439+ then PTacImplicit p l n sc Placeholder :

1440+ insImpAcc (M.insert n Placeholder pnas) ps given

1441+ else PTacImplicit p l n sc sc :

1442+ insImpAcc (M.insert n sc pnas) ps given

1443+ insImpAcc _ expected [] = []

1444+ insImpAcc _ _ given = given

15261445

15271446 find n [] acc = Nothing

15281447 find n (PImp _ _ _ n' t : gs) acc

@@ -1559,11 +1478,11 @@ stripLinear i tm = evalState (sl tm) [] where

15591478 return $ PApp fc fn args'

15601479 where slA (PImp p m l n t) = do t' <- sl t

15611480 return $ PImp p m l n t'

1562− slA (PExp p l t) = do t' <- sl t

1563− return $ PExp p l t'

1564− slA (PConstraint p l t)

1481+ slA (PExp p l n t) = do t' <- sl t

1482+ return $ PExp p l n t'

1483+ slA (PConstraint p l n t)

15651484 = do t' <- sl t

1566− return $ PConstraint p l t'

1485+ return $ PConstraint p l n t'

15671486 slA (PTacImplicit p l n sc t)

15681487 = do t' <- sl t

15691488 return $ PTacImplicit p l n sc t'

@@ -1666,8 +1585,6 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

16661585 = do mf <- match' f f'

16671586 ms <- zipWithM matchArg args args'

16681587 return (mf ++ concat ms)

1669−-- match (PRef _ n) (PRef _ n') | n == n' = return []

1670−-- | otherwise = Nothing

16711588 match (PRef f n) (PApp _ x []) = match (PRef f n) x

16721589 match (PPatvar f n) xr = match (PRef f n) xr

16731590 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

16771594 (not (isConName n (tt_ctxt i) || isFnName n (tt_ctxt i))

16781595 || tm == Placeholder)

16791596 = return [(n, tm)]

1680− | n == n' = return []

1597+ -- if one namespace is missing, drop the other

1598+ | n == n' || n == dropNS n' || dropNS n == n' = return []

1599+ where dropNS (NS n _) = n

1600+ dropNS n = n

16811601 match (PRef _ n) tm

16821602 | not names && (not (isConName n (tt_ctxt i) ||

16831603 isFnName n (tt_ctxt i)) || tm == Placeholder)

@@ -1820,6 +1740,12 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

18201740 mkUniqA arg = do t' <- mkUniq (getTm arg)

18211741 return (arg { getTm = t' })

18221742

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+

18231749 -- FIXME: Probably ought to do this for completeness! It's fine as

18241750 -- long as there are no bindings inside tactics though.

18251751 mkUniqT tac = return tac

@@ -1829,7 +1755,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

18291755 = do env <- get

18301756 (n', sc') <-

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

18331760 return (n', shadow n n' sc)

18341761 else return (n, sc)

18351762 put (n' : env)

@@ -1840,7 +1767,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

18401767 = do env <- get

18411768 (n', sc') <-

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

18441772 return (n', shadow n n' sc)

18451773 else return (n, sc)

18461774 put (n' : env)

@@ -1851,7 +1779,8 @@ mkUniqueNames env tm = evalState (mkUniq tm) env where

18511779 = do env <- get

18521780 (n', sc') <-

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

18551784 return (n', shadow n n' sc)

18561785 else return (n, sc)

18571786 put (n' : env)

src/Idris/AbsSyntaxTree.hs+93−84

@@ -36,6 +36,19 @@ import Debug.Trace

3636

3737import Text.PrettyPrint.Annotated.Leijen

3838

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+

3952data IOption = IOption { opt_logLevel :: Int,

4053 opt_typecase :: Bool,

4154 opt_typeintype :: Bool,

@@ -91,11 +104,6 @@ data ConsoleWidth = InfinitelyWide -- ^ Have pretty-printer assume that lines sh

91104 | ColsWide Int -- ^ Manually specified - must be positive

92105 | AutomaticWidth -- ^ Attempt to determine width, or 80 otherwise

93106

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−

99107-- | The global state used in the Idris monad

100108data IState = IState {

101109 tt_ctxt :: Context, -- ^ All the currently defined names and their terms

@@ -134,6 +142,7 @@ data IState = IState {

134142 idris_libs :: [(Codegen, String)],

135143 idris_cgflags :: [(Codegen, String)],

136144 idris_hdrs :: [(Codegen, String)],

145+ idris_imported :: [FilePath], -- ^ Imported ibc file names

137146 proof_list :: [(Name, [String])],

138147 errSpan :: Maybe FC,

139148 parserWarnings :: [(FC, Err)],

@@ -156,7 +165,8 @@ data IState = IState {

156165 idris_nameIdx :: (Int, Ctxt (Int, Name)),

157166 idris_function_errorhandlers :: Ctxt (M.Map Name (S.Set Name)), -- ^ Specific error handlers

158167 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

160170 }

161171

162172data SizeChange = Smaller | Same | Bigger | Unknown

@@ -172,7 +182,7 @@ data CGInfo = CGInfo { argsdef :: [Name],

172182 calls :: [(Name, [[Name]])],

173183 scg :: [SCGEntry],

174184 argsused :: [Name],

175− unusedpos :: [Int] }

185+ usedpos :: [(Int, [(Name, Int)])] } -- (used_arg#, [(using_fn, its_arg#)])

176186 deriving Show

177187{-!

178188deriving instance Binary CGInfo

@@ -216,6 +226,7 @@ data IBCWrite = IBCFix FixDecl

216226 | IBCLineApp FilePath Int PTerm

217227 | IBCErrorHandler Name

218228 | IBCFunctionErrorHandler Name Name Name

229+ | IBCPostulate Name

219230 deriving Show

220231

221232-- | The initial state for the compiler

@@ -225,9 +236,9 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

225236 emptyContext emptyContext emptyContext emptyContext

226237 emptyContext emptyContext

227238 [] [] defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] [] []

228− [] Nothing [] Nothing [] [] Nothing [] Hidden False [] Nothing [] [] RawOutput

239+ [] [] Nothing [] Nothing [] [] Nothing [] Hidden False [] Nothing [] [] RawOutput

229240 True defaultTheme stdout [] (0, emptyContext) emptyContext M.empty

230− AutomaticWidth

241+ AutomaticWidth S.empty

231242

232243-- | The monad for the main REPL - reading and processing files and updating

233244-- global state (hence the IO inner monad).

@@ -315,6 +326,7 @@ data Opt = Filename String

315326 | DefaultTotal

316327 | DefaultPartial

317328 | WarnPartial

329+ | WarnReach

318330 | NoCoverage

319331 | ErrContext

320332 | ShowImpl

@@ -390,7 +402,7 @@ data Plicity = Imp { pargopts :: [ArgOpt],

390402 pparam :: Bool }

391403 | Exp { pargopts :: [ArgOpt],

392404 pstatic :: Static,

393− pparam :: Bool }

405+ pparam :: Bool } -- this is a param (rather than index)

394406 | Constraint { pargopts :: [ArgOpt],

395407 pstatic :: Static }

396408 | TacImp { pargopts :: [ArgOpt],

@@ -398,15 +410,12 @@ data Plicity = Imp { pargopts :: [ArgOpt],

398410 pscript :: PTerm }

399411 deriving (Show, Eq)

400412

401−plazy :: Plicity -> Bool

402−plazy tm = Lazy `elem` pargopts tm

403−

404413{-!

405414deriving instance Binary Plicity

406415deriving instance NFData Plicity

407416!-}

408417

409−impl = Imp [Lazy] Dynamic False

418+impl = Imp [] Dynamic False

410419expl = Exp [] Dynamic False

411420expl_param = Exp [] Dynamic True

412421constraint = Constraint [] Dynamic

@@ -771,9 +780,11 @@ data PArg' t = PImp { priority :: Int,

771780 pname :: Name, getTm :: t }

772781 | PExp { priority :: Int,

773782 argopts :: [ArgOpt],

783+ pname :: Name,

774784 getTm :: t }

775785 | PConstraint { priority :: Int,

776786 argopts :: [ArgOpt],

787+ pname :: Name,

777788 getTm :: t }

778789 | PTacImplicit { priority :: Int,

779790 argopts :: [ArgOpt],

@@ -782,16 +793,13 @@ data PArg' t = PImp { priority :: Int,

782793 getTm :: t }

783794 deriving (Show, Eq, Functor)

784795

785−data ArgOpt = Lazy | HideDisplay

796+data ArgOpt = HideDisplay | InaccessibleArg

786797 deriving (Show, Eq)

787798

788−lazyarg :: PArg' t -> Bool

789−lazyarg tm = Lazy `elem` argopts tm

790−

791799instance Sized a => Sized (PArg' a) where

792800 size (PImp p _ l nm trm) = 1 + size nm + size trm

793− size (PExp p l trm) = 1 + size trm

794− size (PConstraint p l trm) = 1 + size trm

801+ size (PExp p l nm trm) = 1 + size nm + size trm

802+ size (PConstraint p l nm trm) = 1 + size nm +size nm + size trm

795803 size (PTacImplicit p l nm scr trm) = 1 + size nm + size scr + size trm

796804

797805{-!

@@ -799,10 +807,10 @@ deriving instance Binary PArg'

799807deriving instance NFData PArg'

800808!-}

801809

802−pimp n t mach = PImp 1 mach [Lazy] n t

803−pexp t = PExp 1 [] t

804−pconst t = PConstraint 1 [] t

805−ptacimp n s t = PTacImplicit 2 [Lazy] n s t

810+pimp n t mach = PImp 1 mach [] n t

811+pexp t = PExp 1 [] (sMN 0 "arg") t

812+pconst t = PConstraint 1 [] (sMN 0 "carg") t

813+ptacimp n s t = PTacImplicit 2 [] n s t

806814

807815type PArg = PArg' PTerm

808816

@@ -826,22 +834,8 @@ data TIData = TIPartial -- ^ a function with a partially defined type

826834 | TISolution [Term] -- ^ possible solutions to a metavariable in a type

827835 deriving Show

828836

829−-- An argument is conditionally forceable iff its forceability

830−-- depends on the collapsibility of the whole type.

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

837+data OptInfo = Optimise { inaccessible :: [(Int,Name)], -- includes names for error reporting

838+ detaggable :: Bool }

845839 deriving Show

846840{-!

847841deriving instance Binary OptInfo

@@ -1068,13 +1062,13 @@ consoleDecorate ist AnnConstType = let theme = idris_colourTheme ist

10681062consoleDecorate ist (AnnBoundName _ True) = colouriseImplicit (idris_colourTheme ist)

10691063consoleDecorate ist (AnnBoundName _ False) = colouriseBound (idris_colourTheme ist)

10701064consoleDecorate ist AnnKeyword = colouriseKeyword (idris_colourTheme ist)

1071−consoleDecorate ist (AnnName n _ _) = let ctxt = tt_ctxt ist

1072− theme = idris_colourTheme ist

1073− in case () of

1074− _ | isDConName n ctxt -> colouriseData theme

1075− _ | isFnName n ctxt -> colouriseFun theme

1076− _ | isTConName n ctxt -> colouriseType theme

1077− _ | otherwise -> id -- don't colourise unknown names

1065+consoleDecorate ist (AnnName n _ _ _) = let ctxt = tt_ctxt ist

1066+ theme = idris_colourTheme ist

1067+ in case () of

1068+ _ | isDConName n ctxt -> colouriseData theme

1069+ _ | isFnName n ctxt -> colouriseFun theme

1070+ _ | isTConName n ctxt -> colouriseType theme

1071+ _ | otherwise -> id -- don't colourise unknown names

10781072consoleDecorate ist (AnnFC _) = id

10791073consoleDecorate ist (AnnTextFmt fmt) = Idris.Colours.colourise (colour fmt)

10801074 where colour BoldText = IdrisColour Nothing True False True False

@@ -1114,10 +1108,9 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

11141108 prettySe 10 ((n, False):bnd) sc

11151109 prettySe p bnd (PPi (Exp l s _) n ty sc)

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

1119− enclose open rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

1120− st <> text "->" <$> prettySe 10 ((n, False):bnd) sc

1111+ bracket p 2 . group $

1112+ enclose lparen rparen (group . align $ bindingOf n False <+> colon <+> prettySe 10 bnd ty) <+>

1113+ st <> text "->" <$> prettySe 10 ((n, False):bnd) sc

11211114 | otherwise =

11221115 bracket p 2 . group $

11231116 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

11281121 _ -> empty

11291122 prettySe p bnd (PPi (Imp l s _) n ty sc)

11301123 | impl =

1131− let open = if Lazy `elem` l then text "|" <> lbrace else lbrace in

1132− bracket p 2 $

1133− open <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>

1134− st <> text "->" </> prettySe 10 ((n, True):bnd) sc

1124+ bracket p 2 $

1125+ lparen <> bindingOf n True <+> colon <+> prettySe 10 bnd ty <> rbrace <+>

1126+ st <> text "->" </> prettySe 10 ((n, True):bnd) sc

11351127 | otherwise = prettySe 10 ((n, True):bnd) sc

11361128 where

11371129 st =

@@ -1189,16 +1181,16 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

11891181

11901182 sc (l, r) = nest nestingSize $ prettySe 10 bnd l <+> text "=>" <+> prettySe 10 bnd r

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

11931185 prettySe p bnd (PResolveTC _) = text "resolvetc"

1194− prettySe p bnd (PTrue _ IsType) = annotate (AnnName unitTy Nothing Nothing) $ text "()"

1195− prettySe p bnd (PTrue _ IsTerm) = annotate (AnnName unitCon Nothing Nothing) $ text "()"

1186+ prettySe p bnd (PTrue _ IsType) = annName unitTy $ text "()"

1187+ prettySe p bnd (PTrue _ IsTerm) = annName unitCon $ text "()"

11961188 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 "_|_"

11981190 prettySe p bnd (PEq _ l r) =

11991191 bracket p 2 . align . group $

12001192 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 "=")

12021194 prettySe p bnd (PRewrite _ l r _) =

12031195 bracket p 2 $

12041196 text "rewrite" <+> prettySe 10 bnd l <+> text "in" <+> prettySe 10 bnd r

@@ -1210,28 +1202,28 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

12101202 map (prettySe 10 bnd) elts

12111203 where ann = case pun of

12121204 TypeOrTerm -> id

1213− IsType -> annotate (AnnName pairTy Nothing Nothing)

1214− IsTerm -> annotate (AnnName pairCon Nothing Nothing)

1205+ IsType -> annName pairTy

1206+ IsTerm -> annName pairCon

12151207 prettySe p bnd (PDPair _ TypeOrTerm l t r) =

12161208 lparen <> prettySe 10 bnd l <+> text "**" <+> prettySe 10 bnd r <> rparen

12171209 prettySe p bnd (PDPair _ IsType (PRef _ n) t r) =

1218− annotate (AnnName sigmaTy Nothing Nothing) lparen <>

1210+ annName sigmaTy lparen <>

12191211 bindingOf n False <+>

1220− annotate (AnnName sigmaTy Nothing Nothing) (text "**") <+>

1212+ annName sigmaTy (text "**") <+>

12211213 prettySe 10 ((n, False):bnd) r <>

1222− annotate (AnnName sigmaTy Nothing Nothing) rparen

1214+ annName sigmaTy rparen

12231215 prettySe p bnd (PDPair _ IsType l t r) =

1224− annotate (AnnName sigmaTy Nothing Nothing) lparen <>

1216+ annName sigmaTy lparen <>

12251217 prettySe 10 bnd l <+>

1226− annotate (AnnName sigmaTy Nothing Nothing) (text "**") <+>

1218+ annName sigmaTy (text "**") <+>

12271219 prettySe 10 bnd r <>

1228− annotate (AnnName sigmaTy Nothing Nothing) rparen

1220+ annName sigmaTy rparen

12291221 prettySe p bnd (PDPair _ IsTerm l t r) =

1230− annotate (AnnName existsCon Nothing Nothing) lparen <>

1222+ annName existsCon lparen <>

12311223 prettySe 10 bnd l <+>

1232− annotate (AnnName existsCon Nothing Nothing) (text "**") <+>

1224+ annName existsCon (text "**") <+>

12331225 prettySe 10 bnd r <>

1234− annotate (AnnName existsCon Nothing Nothing) rparen

1226+ annName existsCon rparen

12351227 prettySe p bnd (PAlternative a as) =

12361228 lparen <> text "|" <> prettyAs <> text "|" <> rparen

12371229 where

@@ -1259,8 +1251,8 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

12591251 prettySe p bnd _ = text "test"

12601252

12611253 prettyArgS bnd (PImp _ _ _ n tm) = prettyArgSi bnd (n, tm)

1262− prettyArgS bnd (PExp _ _ tm) = prettyArgSe bnd tm

1263− prettyArgS bnd (PConstraint _ _ tm) = prettyArgSc bnd tm

1254+ prettyArgS bnd (PExp _ _ _ tm) = prettyArgSe bnd tm

1255+ prettyArgS bnd (PConstraint _ _ _ tm) = prettyArgSc bnd tm

12641256 prettyArgS bnd (PTacImplicit _ _ n _ tm) = prettyArgSti bnd (n, tm)

12651257

12661258 prettyArgSe bnd arg = prettySe 0 bnd arg

@@ -1268,6 +1260,9 @@ pprintPTerm impl bnd docArgs = prettySe 10 bnd

12681260 prettyArgSc bnd val = lbrace <> lbrace <> prettySe 10 bnd val <> rbrace <> rbrace

12691261 prettyArgSti bnd (n, val) = lbrace <> kwd "auto" <+> pretty n <+> text "=" <+> prettySe 10 bnd val <> rbrace

12701262

1263+ annName :: Name -> Doc OutputAnnotation -> Doc OutputAnnotation

1264+ annName n = annotate (AnnName n Nothing Nothing Nothing)

1265+

12711266 basename :: Name -> Name

12721267 basename (NS n _) = basename n

12731268 basename n = n

@@ -1333,7 +1328,7 @@ prettyName :: Bool -- ^^ whether to show namespaces

13331328 -> Name -- ^^ the name to pprint

13341329 -> Doc OutputAnnotation

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

13371332 where strName (UN n) = T.unpack n

13381333 strName (NS n ns) | showNS = (concatMap (++ ".") . map T.unpack . reverse) ns ++ strName n

13391334 | otherwise = strName n

@@ -1389,12 +1384,12 @@ getImps (_ : xs) = getImps xs

13891384

13901385getExps :: [PArg] -> [PTerm]

13911386getExps [] = []

1392−getExps (PExp _ _ tm : xs) = tm : getExps xs

1387+getExps (PExp _ _ _ tm : xs) = tm : getExps xs

13931388getExps (_ : xs) = getExps xs

13941389

13951390getConsts :: [PArg] -> [PTerm]

13961391getConsts [] = []

1397−getConsts (PConstraint _ _ tm : xs) = tm : getConsts xs

1392+getConsts (PConstraint _ _ _ tm : xs) = tm : getConsts xs

13981393getConsts (_ : xs) = getConsts xs

13991394

14001395getAll :: [PArg] -> [PTerm]

@@ -1433,7 +1428,9 @@ showName ist bnd impl colour n = case ist of

14331428showTm :: IState -- ^^ the Idris state, for information about identifiers and colours

14341429 -> PTerm -- ^^ the term to show

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

14371434

14381435-- | Show a term with implicits, no colours

14391436showTmImpls :: PTerm -> String

@@ -1482,7 +1479,7 @@ getPArity _ = 0

14821479

14831480allNamesIn :: PTerm -> [Name]

14841481allNamesIn tm = nub $ ni [] tm

1485− where

1482+ where -- TODO THINK added niTacImp, but is it right?

14861483 ni env (PRef _ n)

14871484 | not (n `elem` env) = [n]

14881485 ni env (PPatvar _ n) = [n]

@@ -1490,7 +1487,7 @@ allNamesIn tm = nub $ ni [] tm

14901487 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

14911488 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

14921489 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

14941491 ni env (PHidden tm) = ni env tm

14951492 ni env (PEq _ l r) = ni env l ++ ni env r

14961493 ni env (PRewrite _ l r _) = ni env l ++ ni env r

@@ -1504,16 +1501,19 @@ allNamesIn tm = nub $ ni [] tm

15041501 ni env (PNoImplicits tm) = ni env tm

15051502 ni env _ = []

15061503

1504+ niTacImp env (TacImp _ _ scr) = ni env scr

1505+ niTacImp _ _ = []

1506+

15071507-- Return all names defined in binders in the given term

15081508boundNamesIn :: PTerm -> [Name]

15091509boundNamesIn tm = nub $ ni tm

1510− where

1510+ where -- TODO THINK Added niTacImp, but is it right?

15111511 ni (PApp _ f as) = ni f ++ concatMap (ni) (map getTm as)

15121512 ni (PAppBind _ f as) = ni f ++ concatMap (ni) (map getTm as)

15131513 ni (PCase _ c os) = ni c ++ concatMap (ni) (map snd os)

15141514 ni (PLam n ty sc) = n : (ni ty ++ ni sc)

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

15171517 ni (PEq _ l r) = ni l ++ ni r

15181518 ni (PRewrite _ l r _) = ni l ++ ni r

15191519 ni (PTyped l r) = ni l ++ ni r

@@ -1527,6 +1527,9 @@ boundNamesIn tm = nub $ ni tm

15271527 ni (PNoImplicits tm) = ni tm

15281528 ni _ = []

15291529

1530+ niTacImp (TacImp _ _ scr) = ni scr

1531+ niTacImp _ = []

1532+

15301533-- Return names which are free in the given term.

15311534namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

15321535namesIn uvars ist tm = nub $ ni [] tm

@@ -1540,7 +1543,7 @@ namesIn uvars ist tm = nub $ ni [] tm

15401543 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

15411544 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

15421545 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

15441547 ni env (PEq _ l r) = ni env l ++ ni env r

15451548 ni env (PRewrite _ l r _) = ni env l ++ ni env r

15461549 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1554,11 +1557,14 @@ namesIn uvars ist tm = nub $ ni [] tm

15541557 ni env (PNoImplicits tm) = ni env tm

15551558 ni env _ = []

15561559

1560+ niTacImp env (TacImp _ _ scr) = ni env scr

1561+ niTacImp _ _ = []

1562+

15571563-- Return which of the given names are used in the given term.

15581564

15591565usedNamesIn :: [Name] -> IState -> PTerm -> [Name]

15601566usedNamesIn vars ist tm = nub $ ni [] tm

1561− where

1567+ where -- TODO THINK added niTacImp, but is it right?

15621568 ni env (PRef _ n)

15631569 | n `elem` vars && not (n `elem` env)

15641570 = case lookupTy n (tt_ctxt ist) of

@@ -1568,7 +1574,7 @@ usedNamesIn vars ist tm = nub $ ni [] tm

15681574 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

15691575 ni env (PCase _ c os) = ni env c ++ concatMap (ni env) (map snd os)

15701576 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

15721578 ni env (PEq _ l r) = ni env l ++ ni env r

15731579 ni env (PRewrite _ l r _) = ni env l ++ ni env r

15741580 ni env (PTyped l r) = ni env l ++ ni env r

@@ -1582,3 +1588,6 @@ usedNamesIn vars ist tm = nub $ ni [] tm

15821588 ni env (PNoImplicits tm) = ni env tm

15831589 ni env _ = []

15841590

1591+ niTacImp env (TacImp _ _ scr) = ni env scr

1592+ niTacImp _ _ = []

1593+

src/Idris/CaseSplit.hs+1

@@ -14,6 +14,7 @@ import Idris.ElabTerm

1414import Idris.Delaborate

1515import Idris.Parser

1616import Idris.Error

17+import Idris.Output

1718

1819import Idris.Core.TT

1920import Idris.Core.Typecheck

src/Idris/Core/CaseTree.hs+168−105

@@ -2,7 +2,8 @@

22

33module Idris.Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..),

44 Phase(..), CaseTree,

5− simpleCase, small, namesUsed, findCalls, findUsedArgs) where

5+ simpleCase, small, namesUsed, findCalls, findUsedArgs,

6+ substSC, substAlt, mkForce) where

67

78import Idris.Core.TT

89

@@ -14,8 +15,20 @@ import Debug.Trace

1415data CaseDef = CaseDef [Name] !SC [Term]

1516 deriving Show

1617

17−data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

18− | ProjCase t [CaseAlt' t] -- ^ special case for projections

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

30+data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

31+ | ProjCase t [CaseAlt' t] -- ^ special case for projections/thunk-forcing before inspection

1932 | STerm !t

2033 | UnmatchedCase String -- ^ error message

2134 | ImpossibleCase -- ^ already checked to be impossible

@@ -96,8 +109,7 @@ small n args t = let as = findAllUsedArgs t args in

96109namesUsed :: SC -> [Name]

97110namesUsed sc = nub $ nu' [] sc where

98111 nu' ps (Case n alts) = nub (concatMap (nua ps) alts) \\ [n]

99− nu' ps (ProjCase t alts) = nub $ (nut ps t ++

100− (concatMap (nua ps) alts))

112+ nu' ps (ProjCase t alts) = nub $ nut ps t ++ concatMap (nua ps) alts

101113 nu' ps (STerm t) = nub $ nut ps t

102114 nu' ps _ = []

103115

@@ -122,7 +134,7 @@ namesUsed sc = nub $ nu' [] sc where

122134findCalls :: SC -> [Name] -> [(Name, [[Name]])]

123135findCalls sc topargs = nub $ nu' topargs sc where

124136 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

126138 nu' ps (STerm t) = nub $ nut ps t

127139 nu' ps _ = []

128140

@@ -185,6 +197,22 @@ findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where

185197 nua (SucCase _ sc) = nu' sc

186198 nua (DefaultCase sc) = nu' sc

187199

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+

188216data Phase = CompileTime | RunTime

189217 deriving (Show, Eq)

190218

@@ -192,10 +220,10 @@ data Phase = CompileTime | RunTime

192220-- Work Right to Left

193221

194222simpleCase :: Bool -> Bool -> Bool ->

195− Phase -> FC -> [Type] ->

223+ Phase -> FC -> [Int] -> [Type] ->

196224 [([Name], Term, Term)] ->

197225 TC CaseDef

198−simpleCase tc cover reflect phase fc argtys cs

226+simpleCase tc cover reflect phase fc inacc argtys cs

199227 = sc' tc cover phase fc (filter (\(_, _, r) ->

200228 case r of

201229 Impossible -> False

@@ -213,7 +241,7 @@ simpleCase tc cover reflect phase fc argtys cs

213241 OK pats ->

214242 let numargs = length (fst (head pats))

215243 ns = take numargs args

216− (ns', ps') = order ns pats

244+ (ns', ps') = order [(n, i `elem` inacc) | (i,n) <- zip [0..] ns] pats

217245 (tree, st) = runState

218246 (match ns' ps' (defaultCase cover))

219247 ([], numargs, [])

@@ -382,21 +410,25 @@ partition xs = error $ "Partition " ++ show xs

382410-- reorder the patterns so that the one with most distinct names

383411-- comes next. Take rightmost first, otherwise (i.e. pick value rather

384412-- than dependency)

385−

386−order :: [Name] -> [Clause] -> ([Name], [Clause])

387−order [] cs = ([], cs)

388−order ns [] = (ns, [])

389−order ns cs = let patnames = transpose (map (zip ns) (map fst cs))

390− pats' = transpose (sortBy moreDistinct (reverse patnames)) in

391− (getNOrder pats', zipWith rebuild pats' cs)

413+--

414+-- The first argument means [(Name, IsInaccessible)].

415+

416+order :: [(Name, Bool)] -> [Clause] -> ([Name], [Clause])

417+order [] cs = ([], cs)

418+order ns' [] = (map fst ns', [])

419+order ns' cs = let patnames = transpose (map (zip ns') (map fst cs))

420+ -- note: sortBy . reverse is not nonsense because sortBy is stable

421+ pats' = transpose (sortBy moreDistinct (reverse patnames)) in

422+ (getNOrder pats', zipWith rebuild pats' cs)

392423 where

393− getNOrder [] = error $ "Failed order on " ++ show (ns, cs)

394− getNOrder (c : _) = map fst c

424+ getNOrder [] = error $ "Failed order on " ++ show (map fst ns', cs)

425+ getNOrder (c : _) = map (fst . fst) c

395426

396427 rebuild patnames clause = (map snd patnames, snd clause)

397428

398− moreDistinct xs ys = compare (numNames [] (map snd ys))

399− (numNames [] (map snd xs))

429+ -- this compares (+isInaccessible, -numberOfCases)

430+ moreDistinct xs ys = compare (snd . fst . head $ xs, numNames [] (map snd ys))

431+ (snd . fst . head $ ys, numNames [] (map snd xs))

400432

401433 numNames xs (PCon n _ _ : ps)

402434 | not (Left n `elem` xs) = numNames (Left n : xs) ps

@@ -576,91 +608,79 @@ depatt ns tm = dp [] tm

576608-- FIXME: Do this for SucCase too

577609prune :: Bool -- ^ Convert single branches to projections (only useful at runtime)

578610 -> SC -> SC

579−prune proj (Case n alts)

580− = let alts' = filter notErased (map pruneAlt alts) in

581− case alts' of

582− [] -> ImpossibleCase

583− as@(ConCase (UN delay) i [arg] sc : _)

584− | delay == txt "Delay"

585− -> if proj then mkForce n arg sc

586− else Case n as

587− as@[ConCase cn i args sc] -> if proj then mkProj n 0 args sc

588− else Case n as

589− as@[SucCase cn sc] -> if proj then mkProj n (-1) [cn] sc

590− else Case n as

591− as@[ConstCase _ sc] -> prune proj sc

592− -- Bit of a hack here! The default case will always be 0, make sure

593− -- it gets caught first.

594− [s@(SucCase _ _), DefaultCase dc]

595− -> Case n [ConstCase (BI 0) dc, s]

596− as -> Case n as

597− where pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)

598− pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)

599− pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

600− pruneAlt (SucCase n sc) = SucCase n (prune proj sc)

601− pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

602−

603− notErased (DefaultCase (STerm Erased)) = False

604− notErased (DefaultCase ImpossibleCase) = False

605− notErased _ = True

606−

607− mkForce n arg (Case x alts)

608− | x == arg = ProjCase (forceArg n)

609− (map (mkForceAlt n arg) alts)

610− | otherwise = Case x (map (mkForceAlt n arg) alts)

611− mkForce n arg (ProjCase t alts)

612− = ProjCase (forceTm n arg t) (map (mkForceAlt n arg) alts)

613− mkForce n arg (STerm t) = STerm (forceTm n arg t)

614− mkForce n arg c = c

615−

616− mkForceAlt n arg (ConCase cn t args rhs)

617− = ConCase cn t args (mkForce n arg rhs)

618− mkForceAlt n arg (FnCase cn args rhs)

619− = FnCase cn args (mkForce n arg rhs)

620− mkForceAlt n arg (ConstCase t rhs)

621− = ConstCase t (mkForce n arg rhs)

622− mkForceAlt n arg (SucCase sn rhs)

623− = SucCase sn (mkForce n arg rhs)

624− mkForceAlt n arg (DefaultCase rhs)

625− = DefaultCase (mkForce n arg rhs)

626−

627− forceTm n arg t = subst arg (forceArg n) t

628−

629− forceArg n = App (App (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

643− projRep arg n i (Case x alts)

644− | x == arg = ProjCase (Proj (P Bound n Erased) i)

645− (map (projRepAlt arg n i) alts)

646− | otherwise = Case x (map (projRepAlt arg n i) alts)

647− projRep arg n i (ProjCase t alts)

648− = ProjCase (projRepTm arg n i t) (map (projRepAlt arg n i) alts)

649− projRep arg n i (STerm t) = STerm (projRepTm arg n i t)

650− projRep arg n i c = c -- unmatched

651−

652− projRepAlt arg n i (ConCase cn t args rhs)

653− = ConCase cn t args (projRep arg n i rhs)

654− projRepAlt arg n i (FnCase cn args rhs)

655− = FnCase cn args (projRep arg n i rhs)

656− projRepAlt arg n i (ConstCase t rhs)

657− = ConstCase t (projRep arg n i rhs)

658− projRepAlt arg n i (SucCase sn rhs)

659− = SucCase sn (projRep arg n i rhs)

660− projRepAlt arg n i (DefaultCase rhs)

661− = DefaultCase (projRep arg n i rhs)

662−

663− projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

611+prune proj (Case n alts) = case alts' of

612+ [] -> ImpossibleCase

613+

614+ -- Projection transformations prevent us from seeing some uses of ctor fields

615+ -- because they delete information about which ctor is being used.

616+ -- Consider:

617+ -- f (X x) = ... x ...

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

633+ then Case n [ConCase cn i args sc']

634+ else sc'

635+

636+ [SucCase cn sc]

637+ | proj

638+ -> projRep cn n (-1) $ prune proj sc

639+

640+ [ConstCase _ sc]

641+ -> prune proj sc

642+

643+ -- Bit of a hack here! The default case will always be 0, make sure

644+ -- it gets caught first.

645+ [s@(SucCase _ _), DefaultCase dc]

646+ -> Case n [ConstCase (BI 0) dc, s]

647+

648+ as -> Case n as

649+ where

650+ alts' = filter (not . erased) $ map pruneAlt alts

651+

652+ pruneAlt (ConCase cn i ns sc) = ConCase cn i ns (prune proj sc)

653+ pruneAlt (FnCase cn ns sc) = FnCase cn ns (prune proj sc)

654+ pruneAlt (ConstCase c sc) = ConstCase c (prune proj sc)

655+ pruneAlt (SucCase n sc) = SucCase n (prune proj sc)

656+ pruneAlt (DefaultCase sc) = DefaultCase (prune proj sc)

657+

658+ erased (DefaultCase (STerm Erased)) = True

659+ erased (DefaultCase ImpossibleCase) = True

660+ erased _ = False

661+

662+ projRep :: Name -> Name -> Int -> SC -> SC

663+ projRep arg n i (Case x alts) | x == arg

664+ = ProjCase (Proj (P Bound n Erased) i) $ map (projRepAlt arg n i) alts

665+ projRep arg n i (Case x alts)

666+ = Case x (map (projRepAlt arg n i) alts)

667+ projRep arg n i (ProjCase t alts)

668+ = ProjCase (projRepTm arg n i t) $ map (projRepAlt arg n i) alts

669+ projRep arg n i (STerm t) = STerm (projRepTm arg n i t)

670+ projRep arg n i c = c

671+

672+ projRepAlt arg n i (ConCase cn t args rhs)

673+ = ConCase cn t args (projRep arg n i rhs)

674+ projRepAlt arg n i (FnCase cn args rhs)

675+ = FnCase cn args (projRep arg n i rhs)

676+ projRepAlt arg n i (ConstCase t rhs)

677+ = ConstCase t (projRep arg n i rhs)

678+ projRepAlt arg n i (SucCase sn rhs)

679+ = SucCase sn (projRep arg n i rhs)

680+ projRepAlt arg n i (DefaultCase rhs)

681+ = DefaultCase (projRep arg n i rhs)

682+

683+ projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

664684

665685prune _ t = t

666686

@@ -669,6 +689,49 @@ stripLambdas (CaseDef ns (STerm (Bind x (Lam _) sc)) tm)

669689 = stripLambdas (CaseDef (ns ++ [x]) (STerm (instantiate (P Bound x Erased) sc)) tm)

670690stripLambdas x = x

671691

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

672722

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)

673733

734+ forceTm n arg t = subst arg (forceArg n) t

674735

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,

88 Context, initContext, ctxtAlist, uconstraints, next_tvar,

99 addToCtxt, setAccess, setTotal, setMetaInformation, addCtxtDef, addTyDecl,

1010 addDatatype, addCasedef, simplifyCasedef, addOperator,

11− lookupNames, lookupTy, lookupP, lookupDef, lookupDefAcc, lookupVal,

11+ lookupNames, lookupTy, lookupP, lookupDef, lookupDefExact, lookupDefAcc, lookupVal,

1212 mapDefCtxt,

1313 lookupTotal, lookupNameTotal, lookupMetaInformation, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

14− Value(..), Quote(..), initEval, uniqueNameCtxt) where

14+ Value(..), Quote(..), initEval, uniqueNameCtxt, definitions) where

1515

1616import Debug.Trace

17+import Control.Applicative hiding (Const)

1718import Control.Monad.State -- not Strict!

1819import qualified Data.Binary as B

1920import Data.Binary hiding (get, put)

@@ -784,6 +785,7 @@ addDatatype (Data n tag ty cons) uctxt

784785-- FIXME: Too many arguments! Refactor all these Bools.

785786addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

786787 [Type] -> -- argument types

788+ [Int] -> -- inaccessible arguments

787789 [Either Term (Term, Term)] ->

788790 [([Name], Term, Term)] -> -- totality

789791 [([Name], Term, Term)] -> -- compile time

@@ -791,16 +793,16 @@ addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

791793 [([Name], Term, Term)] -> -- run time

792794 Type -> Context -> Context

793795addCasedef n ci@(CaseInfo alwaysInline tcdict)

794− tcase covering reflect asserted argtys

796+ tcase covering reflect asserted argtys inacc

795797 ps_in ps_tot ps_inl ps_ct ps_rt ty uctxt

796798 = let ctxt = definitions uctxt

797799 access = case lookupDefAcc n False uctxt of

798800 [(_, acc)] -> acc

799801 _ -> Public

800− ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC argtys ps_tot,

801− simpleCase tcase covering reflect CompileTime emptyFC argtys ps_ct,

802− simpleCase tcase covering reflect CompileTime emptyFC argtys ps_inl,

803− simpleCase tcase covering reflect RunTime emptyFC argtys ps_rt) of

802+ ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_tot,

803+ simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_ct,

804+ simpleCase tcase covering reflect CompileTime emptyFC inacc argtys ps_inl,

805+ simpleCase tcase covering reflect RunTime emptyFC inacc argtys ps_rt) of

804806 (OK (CaseDef args_tot sc_tot _),

805807 OK (CaseDef args_ct sc_ct _),

806808 OK (CaseDef args_inl sc_inl _),

@@ -827,7 +829,7 @@ simplifyCasedef n uctxt

827829 [(CaseOp ci ty atys ps_in ps cd, acc, tot, metainf)] ->

828830 let ps_in' = map simpl ps_in

829831 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

831833 OK (CaseDef args sc _) ->

832834 addDef n (CaseOp ci

833835 ty atys ps_in' ps (cd { cases_totcheck = (args, sc) }),

@@ -908,8 +910,11 @@ lookupP n ctxt

908910 Hidden -> []

909911 _ -> return (fst p)

910912

913+lookupDefExact :: Name -> Context -> Maybe Def

914+lookupDefExact n ctxt = tfst <$> lookupCtxtExact n (definitions ctxt)

915+

911916lookupDef :: Name -> Context -> [Def]

912−lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt)

917+lookupDef n ctxt = tfst <$> lookupCtxt n (definitions ctxt)

913918

914919lookupDefAcc :: Name -> Bool -> Context ->

915920 [(Def, Accessibility)]

src/Idris/Core/Execute.hs+96−135

@@ -47,11 +47,8 @@ readMay s = case reads s of

4747

4848data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show

4949

50−data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs

51− , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness

52− , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad

53− , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad

54− }

50+newtype ExecState = ExecState { exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad

51+ }

5552

5653data ExecVal = EP NameType Name ExecVal

5754 | EV Int

@@ -61,20 +58,20 @@ data ExecVal = EP NameType Name ExecVal

6158 | EErased

6259 | EConstant Const

6360 | forall a. EPtr (Ptr a)

64− | EThunk Int

61+ | EThunk Context ExecEnv Term

6562 | EHandle Handle

6663

6764instance Show ExecVal where

68− show (EP _ n _) = show n

69− show (EV i) = "!!V" ++ show i ++ "!!"

70− show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

71− show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

72− show (EType _) = "Type"

73− show EErased = "[__]"

74− show (EConstant c) = show c

75− show (EPtr p) = "<<ptr " ++ show p ++ ">>"

76− show (EThunk i) = "<<thunk " ++ show i ++ ">>"

77− show (EHandle h) = "<<handle " ++ show h ++ ">>"

65+ show (EP _ n _) = show n

66+ show (EV i) = "!!V" ++ show i ++ "!!"

67+ show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

68+ show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

69+ show (EType _) = "Type"

70+ show EErased = "[__]"

71+ show (EConstant c) = show c

72+ show (EPtr p) = "<<ptr " ++ show p ++ ">>"

73+ show (EThunk _ env tm) = "<<thunk " ++ show env ++ "||||" ++ show tm ++ ">>"

74+ show (EHandle h) = "<<handle " ++ show h ++ ">>"

7875

7976toTT :: ExecVal -> Exec Term

8077toTT (EP nt n ty) = (P nt n) <$> (toTT ty)

@@ -82,22 +79,25 @@ toTT (EV i) = return $ V i

8279toTT (EBind n b body) = do body' <- body $ EP Bound n EErased

8380 b' <- fixBinder b

8481 Bind n b' <$> toTT body'

85− where fixBinder (Lam t) = Lam <$> toTT t

86− fixBinder (Pi t) = Pi <$> toTT t

87− fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

88− fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

89− fixBinder (Hole t) = Hole <$> toTT t

82+ where fixBinder (Lam t) = Lam <$> toTT t

83+ fixBinder (Pi t) = Pi <$> toTT t

84+ fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

85+ fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

86+ fixBinder (Hole t) = Hole <$> toTT t

9087 fixBinder (GHole i t) = GHole i <$> toTT t

91− fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2

92− fixBinder (PVar t) = PVar <$> toTT t

93− fixBinder (PVTy t) = PVTy <$> toTT t

88+ fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2

89+ fixBinder (PVar t) = PVar <$> toTT t

90+ fixBinder (PVTy t) = PVTy <$> toTT t

9491toTT (EApp e1 e2) = do e1' <- toTT e1

9592 e2' <- toTT e2

9693 return $ App e1' e2'

9794toTT (EType u) = return $ TType u

9895toTT EErased = return Erased

9996toTT (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')

101101toTT (EHandle _) = return Erased

102102

103103unApplyV :: ExecVal -> (ExecVal, [ExecVal])

@@ -111,7 +111,7 @@ mkEApp f (a:args) = mkEApp (EApp f a) args

111111

112112initState :: Idris ExecState

113113initState = do ist <- getIState

114− return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)

114+ return $ ExecState (idris_dynamic_libs ist)

115115

116116type Exec = ErrorT String (StateT ExecState IO)

117117

@@ -130,45 +130,13 @@ execFail = throwError

130130execIO :: IO a -> Exec a

131131execIO = lift . lift

132132

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

166133

167134execute :: Term -> Idris Term

168135execute tm = do est <- initState

169136 ctxt <- getContext

170− res <- lift . lift $ flip runExec est $ do res <- doExec [] ctxt tm

171− toTT res

137+ res <- lift . lift . flip runExec est $

138+ do res <- doExec [] ctxt tm

139+ toTT res

172140 case res of

173141 Left err -> fail err

174142 Right tm' -> return tm'

@@ -208,7 +176,18 @@ doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined

208176doExec env ctxt tm@(Bind n b body) = return $

209177 EBind n (fmap (\_->EErased) b)

210178 (\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'

212191doExec env ctxt (Constant c) = return (EConstant c)

213192doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in

214193 doExec env ctxt ((x:xs) !! i)

@@ -216,55 +195,38 @@ doExec env ctxt Erased = return EErased

216195doExec env ctxt Impossible = fail "Tried to execute an impossible case"

217196doExec env ctxt (TType u) = return (EType u)

218197

219−execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal

220−execApp env ctxt (f, args) = do newF <- doExec env ctxt f

221− laziness <- (++ repeat False) <$> (getLaziness newF)

222− newArgs <- mapM argExec (zip args laziness)

223− res <- execApp' env ctxt newF newArgs

224− return res

225− where getLaziness (EP _ l _) | l == sUN "lazy" = return [False, True]

226− getLaziness (EP _ n _) = do est <- getExecState

227− let argInfo = exec_implicits est

228− case lookupCtxtName n argInfo of

229− [] -> return (repeat False)

230− [ps] -> return $ map lazyarg (snd ps)

231− many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)

232− getLaziness _ = return (repeat False) -- ok due to zip above

233− argExec :: (Term, Bool) -> Exec ExecVal

234− argExec (tm, False) = doExec env ctxt tm

235− argExec (tm, True) = delay env ctxt tm

236−

237−

238−execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

239−execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls

240−execApp' env ctxt (EP _ fp _) (ty:action:rest)

198+execApp :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

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

205+execApp env ctxt (EP _ fp _) (ty:action:rest)

241206 | fp == upio,

242207 (prim__IO, [_, v]) <- unApplyV action

243− = execApp' env ctxt v rest

208+ = execApp env ctxt v rest

244209

245−execApp' env ctxt (EP _ fp _) args@(_:_:v:k:rest)

210+execApp env ctxt (EP _ fp _) args@(_:_:v:k:rest)

246211 | fp == piobind,

247212 (prim__IO, [_, v']) <- unApplyV v =

248− do v'' <- tryForce v'

249− res <- execApp' env ctxt k [v''] >>= tryForce

250− execApp' env ctxt res rest

251−execApp' env ctxt con@(EP _ fp _) args@(tp:v:rest)

252− | fp == pioret =

253− do v' <- tryForce v

254− execApp' env ctxt (mkEApp con [tp, v']) rest

213+ do res <- execApp env ctxt k [v']

214+ execApp env ctxt res rest

215+execApp env ctxt con@(EP _ fp _) args@(tp:v:rest)

216+ | fp == pioret = execApp env ctxt (mkEApp con [tp, v]) rest

255217

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

258220 | fp == mkfprim,

259221 Just (FFun "putStr" _ _) <- foreignFromTT fn

260222 = do execIO (putStr arg)

261− execApp' env ctxt ioUnit rest

262−execApp' env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

223+ execApp env ctxt ioUnit rest

224+execApp env ctxt (EP _ fp _) (_:fn:_:EHandle h:_:rest)

263225 | fp == mkfprim,

264226 Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

265227 = do contents <- execIO $ hGetLine h

266− execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

267−execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

228+ execApp env ctxt (EConstant (Str (contents ++ "\n"))) rest

229+execApp env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

268230 | fp == mkfprim,

269231 Just (FFun "fileOpen" _ _) <- foreignFromTT fn

270232 = do f <- execIO $

@@ -283,53 +245,53 @@ execApp' env ctxt (EP _ fp _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

283245 in return $ Right (ioWrap (EPtr nullPtr), tail rest))

284246 case f of

285247 Left err -> execFail err

286− Right (res, rest) -> execApp' env ctxt res rest

248+ Right (res, rest) -> execApp env ctxt res rest

287249

288−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

250+execApp env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

289251 | fp == mkfprim,

290252 Just (FFun "fileEOF" _ _) <- foreignFromTT fn

291253 = do eofp <- execIO $ hIsEOF h

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

294256

295−execApp' env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

257+execApp env ctxt (EP _ fp _) (_:fn:(EHandle h):rest)

296258 | fp == mkfprim,

297259 Just (FFun "fileClose" _ _) <- foreignFromTT fn

298260 = do execIO $ hClose h

299− execApp' env ctxt ioUnit (tail rest)

261+ execApp env ctxt ioUnit (tail rest)

300262

301−execApp' env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

263+execApp env ctxt (EP _ fp _) (_:fn:(EPtr p):rest)

302264 | fp == mkfprim,

303265 Just (FFun "isNull" _ _) <- foreignFromTT fn

304266 = let res = ioWrap . EConstant . I $

305267 if p == nullPtr then 1 else 0

306− in execApp' env ctxt res (tail rest)

268+ in execApp env ctxt res (tail rest)

307269

308270-- Handles will be checked as null pointers sometimes - but if we got a

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

311273 | fp == mkfprim,

312274 Just (FFun "isNull" _ _) <- foreignFromTT fn

313275 = let res = ioWrap . EConstant . I $ 0

314− in execApp' env ctxt res (tail rest)

276+ in execApp env ctxt res (tail rest)

315277

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

318280 | fp == mkfprim,

319281 Just (FFun "isNull" _ _) <- foreignFromTT fn

320282 = let res = ioWrap . EConstant . I $ 0

321− in execApp' env ctxt res (tail rest)

283+ in execApp env ctxt res (tail rest)

322284

323285-- Right now, there's no way to send command-line arguments to the executor,

324286-- so just return 0.

325−execApp' env ctxt (EP _ fp _) (_:fn:rest)

287+execApp env ctxt (EP _ fp _) (_:fn:rest)

326288 | fp == mkfprim,

327289 Just (FFun "idris_numArgs" _ _) <- foreignFromTT fn

328290 = let res = ioWrap . EConstant . I $ 0

329− in execApp' env ctxt res (tail rest)

291+ in execApp env ctxt res (tail rest)

330292-- Throw away the 'World' argument to the foreign function

331293

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

333295 = case foreignFromTT fn of

334296 Just (FFun f argTs retT) | length xs >= length argTs ->

335297 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

341303 Just r -> return (mkEApp r xs')

342304 Nothing -> return (mkEApp f args)

343305

344−execApp' env ctxt c@(EP (DCon _ arity) n _) args =

345− do args' <- mapM tryForce (take arity args)

306+execApp env ctxt c@(EP (DCon _ arity) n _) args =

307+ do let args' = take arity args

346308 let restArgs = drop arity args

347− execApp' env ctxt (mkEApp c args') restArgs

309+ execApp env ctxt (mkEApp c args') restArgs

348310

349−execApp' env ctxt c@(EP (TCon _ arity) n _) args =

350− do args' <- mapM tryForce (take arity args)

311+execApp env ctxt c@(EP (TCon _ arity) n _) args =

312+ do let args' = take arity args

351313 let restArgs = drop arity args

352− execApp' env ctxt (mkEApp c args') restArgs

314+ execApp env ctxt (mkEApp c args') restArgs

353315

354−execApp' env ctxt f@(EP _ n _) args =

316+execApp env ctxt f@(EP _ n _) args =

355317 do let val = lookupDef n ctxt

356318 case val of

357319 [Function _ tm] -> fail "should already have been eval'd"

358320 [TyDecl nt ty] -> return $ mkEApp f args

359321 [Operator tp arity op] ->

360322 if length args >= arity

361− then do args' <- mapM tryForce $ take arity args

362− case getOp n args' of

363− Just res -> do r <- res

364− execApp' env ctxt r (drop arity args)

365− Nothing -> return (mkEApp f args)

323+ then let args' = take arity args in

324+ case getOp n args' of

325+ Just res -> do r <- res

326+ execApp env ctxt r (drop arity args)

327+ Nothing -> return (mkEApp f args)

366328 else return (mkEApp f args)

367329 [CaseOp _ _ _ _ _ (CaseDefs _ ([], STerm tm) _ _)] -> -- nullary fun

368330 do rhs <- doExec env ctxt tm

369− execApp' env ctxt rhs args

331+ execApp env ctxt rhs args

370332 [CaseOp _ _ _ _ _ (CaseDefs _ (ns, sc) _ _)] ->

371333 do res <- execCase env ctxt ns sc args

372334 return $ fromMaybe (mkEApp f args) res

373335 thing -> return $ mkEApp f args

374−execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg

375− let (f', as) = unApplyV ret

376− execApp' env ctxt f' (as ++ args)

377−execApp' env ctxt (EThunk i) args = do f <- force i

378− execApp' env ctxt f args

379−execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)

380−execApp' env ctxt f args = return (mkEApp f args)

336+execApp env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg

337+ let (f', as) = unApplyV ret

338+ execApp env ctxt f' (as ++ args)

339+execApp env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp env ctxt f (args1 ++ args2)

340+execApp env ctxt f args = return (mkEApp f args)

381341

382342prs = sUN "prim__readString"

383343pbm = sUN "prim__believe_me"

@@ -386,6 +346,8 @@ mkfprim = sUN "mkForeignPrim"

386346pioret = sUN "prim_io_return"

387347piobind = sUN "prim_io_bind"

388348upio = sUN "unsafePerformPrimIO"

349+delay = sUN "Delay"

350+force = sUN "Force"

389351

390352-- | Look up primitive operations in the global table and transform them into ExecVal functions

391353getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

@@ -426,7 +388,7 @@ execCase env ctxt ns sc args =

426388-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()

427389 caseRes <- execCase' env ctxt amap sc

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

430392 Nothing -> return Nothing

431393 else return Nothing

432394

@@ -436,8 +398,7 @@ execCase' env ctxt amap (UnmatchedCase _) = return Nothing

436398execCase' env ctxt amap (STerm tm) =

437399 Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm

438400execCase' 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

441402 Just (newCase, newBindings) ->

442403 let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in

443404 execCase' env ctxt amap' newCase

src/Idris/Core/TT.hs+8−6

@@ -82,14 +82,16 @@ instance Show FC where

8282 | otherwise = show sl ++ ":" ++ show sc ++ "-" ++ show el ++ ":" ++ show ec

8383

8484-- | Output annotation for pretty-printed name - decides colour

85−data NameOutput = TypeOutput | FunOutput | DataOutput

85+data NameOutput = TypeOutput | FunOutput | DataOutput | MetavarOutput

8686

8787-- | Text formatting output

8888data TextFormatting = BoldText | ItalicText | UnderlineText

8989

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

9293 | AnnBoundName Name Bool

94+ -- ^^ The name and whether it is implicit

9395 | AnnConstData

9496 | AnnConstType

9597 | AnnKeyword

@@ -312,11 +314,11 @@ instance Sized Name where

312314 size _ = 1

313315

314316instance Pretty Name OutputAnnotation where

315− pretty n@(UN n') = annotate (AnnName n Nothing Nothing) $ text (T.unpack n')

316− pretty n@(NS un s) = annotate (AnnName n Nothing Nothing) . noAnnotate $ pretty un

317− pretty n@(MN i s) = annotate (AnnName n Nothing Nothing) $

317+ pretty n@(UN n') = annotate (AnnName n Nothing Nothing Nothing) $ text (T.unpack n')

318+ pretty n@(NS un s) = annotate (AnnName n Nothing Nothing Nothing) . noAnnotate $ pretty un

319+ pretty n@(MN i s) = annotate (AnnName n Nothing Nothing Nothing) $

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

320322

321323instance Pretty [Name] OutputAnnotation where

322324 pretty = encloseSep empty empty comma . map pretty

src/Idris/Coverage.hs+41−13

@@ -9,6 +9,7 @@ import Idris.Core.CaseTree

99import Idris.AbsSyntax

1010import Idris.Delaborate

1111import Idris.Error

12+import Idris.Output (iputStrLn)

1213

1314import Data.List

1415import Data.Either

@@ -17,10 +18,14 @@ import Debug.Trace

1718

1819import Control.Monad.State.Strict

1920

21+-- Generate a pattern from an 'impossible' LHS. (Need this to eliminate the

22+-- pattern clauses which have been provided explicitly from new clause

23+-- generation.)

24+

2025mkPatTm :: PTerm -> Idris Term

2126mkPatTm t = do i <- getIState

2227 let timp = addImpl' True [] [] i t

23− evalStateT (toTT timp) 0

28+ evalStateT (toTT (mapPT deNS timp)) 0

2429 where

2530 toTT (PRef _ n) = do i <- lift getIState

2631 case lookupDef n (tt_ctxt i) of

@@ -29,10 +34,16 @@ mkPatTm t = do i <- getIState

2934 toTT (PApp _ t args) = do t' <- toTT t

3035 args' <- mapM (toTT . getTm) args

3136 return $ mkApp t' args'

37+ -- For alternatives, pick the first and drop the namespaces. It doesn't

38+ -- really matter which is taken since matching will ignore the namespace.

39+ toTT (PAlternative _ (a : as)) = toTT a

3240 toTT _ = do v <- get

3341 put (v + 1)

3442 return (P Bound (sMN v "imp") Erased)

3543

44+ deNS (PRef f (NS n _)) = PRef f n

45+ deNS t = t

46+

3647-- Given a list of LHSs, generate a extra clauses which cover the remaining

3748-- cases. The ones which haven't been provided are marked 'absurd' so that the

3849-- checker will make sure they can't happen.

@@ -40,30 +51,36 @@ mkPatTm t = do i <- getIState

4051-- This will only work after the given clauses have been typechecked and the

4152-- names are fully explicit!

4253

43−genClauses :: FC -> Name -> [Term] -> [PClause] -> Idris [PTerm]

54+genClauses :: FC -> Name -> [Term] -> [PTerm] -> Idris [PTerm]

4455genClauses fc n xs given

4556 = do i <- getIState

46− let lhss = map (getLHS i) xs

57+ let lhs_tms = map (\x -> delab' i x True True) xs

58+ -- if a placeholder was given, don't bother generating cases for it

59+ let lhs_tms' = zipWith mergePlaceholders lhs_tms given

60+ let lhss = map pUnApply lhs_tms'

61+

4762 let argss = transpose lhss

4863 let all_args = map (genAll i) argss

4964 logLvl 5 $ "COVERAGE of " ++ show n

65+ logLvl 5 $ show lhss

5066 logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

5167 logLvl 10 $ show argss ++ "\n" ++ show all_args

52− logLvl 10 $ "Original: \n" ++

68+ logLvl 1 $ "Original: \n" ++

5369 showSep "\n" (map (\t -> showTm i (delab' i t True True)) xs)

5470 -- add an infinite supply of explicit arguments to update the possible

55− -- cases for (the return type may be variadic, or function type, sp

71+ -- cases for (the return type may be variadic, or function type, so

5672 -- there may be more case splitting that the idris_implicits record

5773 -- suggests)

5874 let parg = case lookupCtxt n (idris_implicits i) of

59− (p : _) -> p ++ repeat (PExp 0 [] Placeholder)

60− _ -> repeat (pexp Placeholder)

75+ (p : _) ->

76+ p ++ repeat (PExp 0 [] (sMN 0 "gcarg") Placeholder)

77+ _ -> repeat (pexp Placeholder)

6178 let tryclauses = mkClauses parg all_args

6279 logLvl 2 $ show (length tryclauses) ++ " initially to check"

63− logLvl 5 $ showSep "\n" (map (showTm i) tryclauses)

80+ logLvl 1 $ showSep "\n" (map (showTm i) tryclauses)

6481 let new = filter (noMatch i) (nub tryclauses)

6582 logLvl 1 $ show (length new) ++ " clauses to check for impossibility"

66− logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)

83+ logLvl 3 $ "New clauses: \n" ++ showSep "\n" (map (showTm i) new)

6784-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)

6885 return new

6986-- return (map (\t -> PClause n t [] PImpossible []) new)

@@ -71,13 +88,23 @@ genClauses fc n xs given

7188 | (f, args) <- unApply term = map (\t -> delab' i t True True) args

7289 | otherwise = []

7390

74− lhsApp (PClause _ _ l _ _ _) = l

75− lhsApp (PWith _ _ l _ _ _) = l

91+ pUnApply (PApp _ _ args) = map getTm args

92+ pUnApply _ = []

7693

94+ -- Return whether the given clause matches none of the input clauses

95+ -- (xs)

7796 noMatch i tm = all (\x -> case matchClause i (delab' i x True True) tm of

78− Right _ -> False

79− Left miss -> True) xs

97+ Right ms -> False

98+ Left miss -> True) xs

99+

80100

101+ mergePlaceholders :: PTerm -> PTerm -> PTerm

102+ mergePlaceholders x Placeholder = Placeholder

103+ mergePlaceholders (PApp fc f args) (PApp fc' f' args')

104+ = PApp fc' f' (zipWith mergePArg args args')

105+ where mergePArg x y = let xtm = mergePlaceholders (getTm x) (getTm y) in

106+ x { getTm = xtm}

107+ mergePlaceholders x _ = x

81108

82109 mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]

83110 mkClauses parg args

@@ -101,6 +128,7 @@ fnub' acc [] = acc

101128

102129-- quick check for constructor equality

103130quickEq :: PTerm -> PTerm -> Bool

131+quickEq (PConstant n) (PConstant n') = n == n'

104132quickEq (PRef _ n) (PRef _ n') = n == n'

105133quickEq (PApp _ t as) (PApp _ t' as')

106134 | length as == length as'

src/Idris/DataOpts.hs+14−231

@@ -9,224 +9,48 @@ import Idris.AbsSyntaxTree

99import Idris.Core.TT

1010

1111import Control.Applicative

12−import qualified Data.IntMap as M

1312import Data.List

1413import Data.Maybe

1514import Debug.Trace

1615

17−type ForceMap = M.IntMap Forceability

18−

19−-- Calculate the forceable arguments to a constructor

20−-- and update the set of optimisations.

21−forceArgs :: Name -> Name -> [Int] -> Type -> Idris ()

22−forceArgs typeName n expforce t = do

23− ist <- getIState

24− let fargs = getForcedArgs ist typeName t

25− copt = case lookupCtxt n (idris_optimisation ist) of

26− [] -> Optimise False False [] []

27− op:_ -> op

28− opts = addDef n (copt { forceable = M.toList fargs ++

29− zip expforce (repeat Unconditional) })

30− (idris_optimisation ist)

31− putIState (ist { idris_optimisation = opts })

32− addIBC (IBCOpt n)

33− iLOG $ "Forced: " ++ show n ++ " " ++ show fargs ++ "\n from " ++ show t

34−

35−getForcedArgs :: IState -> Name -> Type -> ForceMap

36−getForcedArgs ist typeName t = addCollapsibleArgs 0 t $ forcedInTarget 0 t

37− where

38− maxUnion = M.unionWith max

39−

40− -- Label all occurrences of the variable bound in Pi in the rest of

41− -- the term with the number i so that we can recognize them anytime later.

42− label i = instantiate $ P Bound (sMN i "ctor_arg") Erased

43−

44− addCollapsibleArgs :: Int -> Type -> ForceMap -> ForceMap

45− addCollapsibleArgs i (Bind vn (Pi ty) rest) alreadyForceable

46− = addCollapsibleArgs (i+1) (label i rest) (forceable $ unApply ty)

47− where

48− -- forceable takes an un-applied type of a ctor argument

49− forceable (P _ tn _, args)

50− -- if `ty' is collapsible, the argument is unconditionally forceable

51− | isCollapsible tn

52− = M.insert i Unconditional alreadyForceable

53−

54− -- a recursive occurrence with known indices is conditionally forceable

55− | tn == typeName

56− = M.insertWith max i Conditional alreadyForceable

57−

58− forceable _ = alreadyForceable

59−

60− isCollapsible :: Name -> Bool

61− isCollapsible n = case lookupCtxt n (idris_optimisation ist) of

62− [oi] -> collapsible oi

63− _ -> False

64−

65− addCollapsibleArgs _ _ fs = fs

66−

67− forcedInTarget :: Int -> Type -> ForceMap

68− forcedInTarget i (Bind _ (Pi _) rest) = forcedInTarget (i+1) (label i rest)

69− forcedInTarget i t@(App f a) | (_, as) <- unApply t = unionMap guardedArgs as

70− forcedInTarget _ _ = M.empty

71−

72− guardedArgs :: Term -> ForceMap

73− guardedArgs t@(App f a) | (P (DCon _ _) _ _, args) <- unApply t

74− = unionMap bareArg args `maxUnion` unionMap guardedArgs args

75− guardedArgs t = bareArg t

76−

77− bareArg :: Term -> ForceMap

78− bareArg (P _ (MN i ctor_arg) _)

79− | ctor_arg == txt "ctor_arg" = M.singleton i Unconditional

80− bareArg _ = M.empty

81−

82− unionMap :: (a -> ForceMap) -> [a] -> ForceMap

83− unionMap f = M.unionsWith max . map f

84−

85−-- Calculate whether a collection of constructors is collapsible

86−-- and update the state accordingly.

87−collapseCons :: Name -> [(Name, Type)] -> Idris ()

88−collapseCons tn ctors = do

89− ist <- getIState

90− case ctors of

91− _

92− | all (ctorCollapsible ist) ctors

93− , disjointTerms ctorTargetArgs

94− -> mapM_ setCollapsible (tn : map fst ctors)

95−

96− [(cn, ct)]

97− -> checkNewType ist cn ct

98−

99− _ -> return () -- nothing can be done

100− where

101− ctorTargetArgs = map (snd . unApply . getRetTy . snd) ctors

102−

103− ctorArity :: Type -> Int

104− ctorArity = length . getArgTys

105−

106− ctorCollapsible :: IState -> (Name, Type) -> Bool

107− ctorCollapsible ist (n, t) = all (`M.member` forceMap) [0 .. ctorArity t - 1]

108− where

109− forceMap = case lookupCtxt n (idris_optimisation ist) of

110− oi:_ -> M.fromList $ forceable oi

111− _ -> M.empty

112−

113− -- one constructor; if one remaining argument, treat as newtype

114− checkNewType :: IState -> Name -> Type -> Idris ()

115− checkNewType ist cn ct

116− | oi:_ <- lookupCtxt cn opt

117− , length (getArgTys ct) == 1 + forcedCnt (M.fromList $ forceable oi)

118− = putIState ist{ idris_optimisation = opt' oi }

119− | otherwise = return ()

120− where

121− opt = idris_optimisation ist

122− opt' oi = addDef cn oi{ isnewtype = True } opt

123−

124− setCollapsible :: Name -> Idris ()

125− setCollapsible n

126− = do i <- getIState

127− iLOG $ show n ++ " collapsible"

128− case lookupCtxt n (idris_optimisation i) of

129− (oi:_) -> do let oi' = oi { collapsible = True }

130− let opts = addDef n oi' (idris_optimisation i)

131− putIState (i { idris_optimisation = opts })

132− [] -> do let oi = Optimise True False [] []

133− let opts = addDef n oi (idris_optimisation i)

134− putIState (i { idris_optimisation = opts })

135− addIBC (IBCOpt n)

136−

137− disjointTerms :: [[Term]] -> Bool

138− disjointTerms [] = True

139− disjointTerms [xs] = True

140− disjointTerms (xs : xss) =

141− -- xs is disjoint with every pattern from xss

142− all (or . zipWith disjoint xs) xss

143− -- and xss is pairwise disjoint, too

144− && disjointTerms xss

145−

146− -- Return True if the two patterns are provably disjoint.

147− -- Return False if they're not or if unsure.

148− disjoint :: Term -> Term -> Bool

149− disjoint x y = case (cx, cy) of

150− -- data constructors -> compare their names

151− (P (DCon _ _) nx _, P (DCon _ _) ny _)

152− | nx /= ny -> True

153− | otherwise -> or $ zipWith disjoint xargs yargs

154− _ -> False

155− where

156− (cx, xargs) = unApply x

157− (cy, yargs) = unApply y

158−

15916class Optimisable term where

16017 applyOpts :: term -> Idris term

161− stripCollapsed :: term -> Idris term

16218

16319instance (Optimisable a, Optimisable b) => Optimisable (a, b) where

16420 applyOpts (x, y) = (,) <$> applyOpts x <*> applyOpts y

165− stripCollapsed (x, y) = (,) <$> stripCollapsed x <*> stripCollapsed y

16621

16722instance (Optimisable a, Optimisable b) => Optimisable (vs, a, b) where

16823 applyOpts (v, x, y) = (,,) v <$> applyOpts x <*> applyOpts y

169− stripCollapsed (v, x, y) = (,,) v <$> stripCollapsed x <*> stripCollapsed y

17024

17125instance Optimisable a => Optimisable [a] where

17226 applyOpts = mapM applyOpts

173− stripCollapsed = mapM stripCollapsed

17427

17528instance Optimisable a => Optimisable (Either a (a, a)) where

17629 applyOpts (Left t) = Left <$> applyOpts t

17730 applyOpts (Right t) = Right <$> applyOpts t

178− stripCollapsed (Left t) = Left <$> stripCollapsed t

179− stripCollapsed (Right t) = Right <$> stripCollapsed t

18031

18132-- Raw is for compile time optimisation (before type checking)

18233-- Term is for run time optimisation (after type checking, collapsing allowed)

183−

18434-- Compile time: no collapsing

18535

18636instance Optimisable Raw where

18737 applyOpts t@(RApp f a)

18838 | (Var n, args) <- raw_unapply t -- MAGIC HERE

189− = do args' <- mapM applyOpts args

190− i <- getIState

191− return $ case lookupCtxt n (idris_optimisation i) of

192− oi:_ -> applyDataOpt oi n args'

193− _ -> raw_apply (Var n) args'

39+ = raw_apply (Var n) <$> mapM applyOpts args

19440 | otherwise = RApp <$> applyOpts f <*> applyOpts a

19541

19642 applyOpts (RBind n b t) = RBind n <$> applyOpts b <*> applyOpts t

19743 applyOpts (RForce t) = applyOpts t

19844 applyOpts t = return t

19945

200− stripCollapsed t = return t

201−

20246-- Erase types (makes ibc smaller, and we don't need them)

20347instance Optimisable (Binder (TT Name)) where

20448 applyOpts (Let t v) = Let <$> return Erased <*> applyOpts v

20549 applyOpts b = return (b { binderTy = Erased })

206− stripCollapsed (Let t v) = Let <$> return Erased <*> stripCollapsed v

207− stripCollapsed b = return (b { binderTy = Erased })

20850

20951instance Optimisable (Binder Raw) where

21052 applyOpts b = do t' <- applyOpts (binderTy b)

21153 return (b { binderTy = t' })

212− stripCollapsed (Let t v) = Let <$> stripCollapsed t <*> stripCollapsed v

213− stripCollapsed b = do t' <- stripCollapsed (binderTy b)

214− return (b { binderTy = t' })

215−

216−forcedArgSeq :: OptInfo -> [Maybe Forceability]

217−forcedArgSeq oi = map (\i -> M.lookup i forceMap) [0..]

218− where

219− forceMap = M.fromList $ forceable oi

220−

221−forcedCnt :: ForceMap -> Int

222−forcedCnt = length . filter (== Unconditional) . M.elems

223−

224−applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw

225−applyDataOpt oi n args

226− = raw_apply (Var n) $ zipWith doForce (forcedArgSeq oi) args

227− where

228− doForce (Just Unconditional) a = RForce a

229− doForce _ a = a

23054

23155-- Run-time: do everything

23256

@@ -249,54 +73,22 @@ instance Optimisable (TT Name) where

24973 | fn == txt "toIntegerNat" && mod == prel

25074 = return (App (P Ref (sNS (sUN "id") ["Basics","Prelude"]) Erased) Erased)

25175 applyOpts c@(P (DCon t arity) n _)

252− = do i <- getIState

253− case lookupCtxt n (idris_optimisation i) of

254− (oi:_) -> return $ applyDataOptRT oi n t arity []

255− _ -> return c

76+ = return $ applyDataOptRT n t arity []

25677 applyOpts t@(App f a)

25778 | (c@(P (DCon t arity) n _), args) <- unApply t

258− = do args' <- mapM applyOpts args

259− i <- getIState

260− case lookupCtxt n (idris_optimisation i) of

261− (oi:_) -> do return $ applyDataOptRT oi n t arity args'

262− _ -> return (mkApp c args')

263− | otherwise = do f' <- applyOpts f

264− a' <- applyOpts a

265− return (App f' a')

266− applyOpts (Bind n b t) = do b' <- applyOpts b

267− t' <- applyOpts t

268− return (Bind n b' t')

269− applyOpts (Proj t i) = do t' <- applyOpts t

270− return (Proj t' i)

79+ = applyDataOptRT n t arity <$> mapM applyOpts args

80+ | otherwise = App <$> applyOpts f <*> applyOpts a

81+ applyOpts (Bind n b t) = Bind n <$> applyOpts b <*> applyOpts t

82+ applyOpts (Proj t i) = Proj <$> applyOpts t <*> pure i

27183 applyOpts t = return t

27284

273− stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x

274− = do i <- getIState

275− -- NOTE: This assumes that 'ty' is in normal form, which it

276− -- has to be before now because we're not keeping track of

277− -- an environment so we can't do it here.

278− case lookupCtxt ty (idris_optimisation i) of

279− [oi] -> if collapsible oi

280− then do t' <- stripCollapsed t

281− return (Bind n (PVar x) (instantiate Erased t'))

282− else do t' <- stripCollapsed t

283− return (Bind n (PVar x) t')

284− _ -> do t' <- stripCollapsed t

285− return (Bind n (PVar x) t')

286− stripCollapsed (Bind n (PVar x) t)

287− = do t' <- stripCollapsed t

288− return (Bind n (PVar x) t')

289− stripCollapsed t = return t

290−

291−-- Need to saturate arguments first to ensure that erasure happens uniformly

292−

293−applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term

294−applyDataOptRT oi n tag arity args

295− | length args == arity = doOpts n args (collapsible oi) (M.fromList $ forceable oi)

85+-- Need to saturate arguments first to ensure that optimisation happens uniformly

86+applyDataOptRT :: Name -> Int -> Int -> [Term] -> Term

87+applyDataOptRT n tag arity args

88+ | length args == arity = doOpts n args

29689 | otherwise = let extra = satArgs (arity - length args)

29790 tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra)

298− (collapsible oi) (M.fromList $ forceable oi) in

299− bind extra tm

91+ in bind extra tm

30092 where

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

30294

@@ -305,20 +97,11 @@ applyDataOptRT oi n tag arity args

30597

30698 -- Nat special cases

30799 -- TODO: Would be nice if this was configurable in idris source!

308− doOpts (NS (UN z) [nat, prelude]) [] _ _

100+ doOpts (NS (UN z) [nat, prelude]) []

309101 | z == txt "Z" && nat == txt "Nat" && prelude == txt "Prelude"

310102 = Constant (BI 0)

311− doOpts (NS (UN s) [nat, prelude]) [k] _ _

103+ doOpts (NS (UN s) [nat, prelude]) [k]

312104 | s == txt "S" && nat == txt "Nat" && prelude == txt "Prelude"

313105 = App (App (P Ref (sUN "prim__addBigInt") Erased) k) (Constant (BI 1))

314106

315− doOpts n args True _ = Erased

316− doOpts n args _ forceMap

317− | isnewtype oi = case args' of

318− [val] -> val

319− _ -> error $ "Can't happen (newtype not a singleton): " ++ show args'

320− | otherwise = mkApp ctor' args'

321− where

322− ctor' = (P (DCon tag (arity - forcedCnt forceMap)) n Erased)

323− args' = [t | (f, t) <- zip (forcedArgSeq oi) args, f /= Just Unconditional]

324−

107+ doOpts n args = mkApp (P (DCon tag arity) n Erased) args

src/Idris/DeepSeq.hs+6−10

@@ -50,10 +50,6 @@ instance NFData CT.NumWrapper where

5050

5151-- All generated by 'derive'

5252

53−instance NFData Forceability where

54− rnf Conditional = ()

55− rnf Unconditional = ()

56−

5753instance NFData IntTy where

5854 rnf (ITFixed x1) = rnf x1 `seq` ()

5955 rnf ITNative = ()

@@ -276,10 +272,10 @@ instance (NFData t) => NFData (PDo' t) where

276272instance (NFData t) => NFData (PArg' t) where

277273 rnf (PImp x1 x2 x3 x4 x5)

278274 = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

279− rnf (PExp x1 x2 x3)

280− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

281− rnf (PConstraint x1 x2 x3)

282− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()

275+ rnf (PExp x1 x2 x3 x4)

276+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

277+ rnf (PConstraint x1 x2 x3 x4)

278+ = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

283279 rnf (PTacImplicit x1 x2 x3 x4 x5)

284280 = rnf x1 `seq`

285281 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` ()

@@ -290,8 +286,8 @@ instance NFData ClassInfo where

290286 rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` ()

291287

292288instance NFData OptInfo where

293− rnf (Optimise x1 x2 x3 x4)

294− = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` ()

289+ rnf (Optimise x1 x2)

290+ = rnf x1 `seq` rnf x2 `seq` ()

295291

296292instance NFData TypeInfo where

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

11{-# 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

33

44-- Convert core TT back into high level syntax, primarily for display

55-- purposes.

@@ -58,7 +58,7 @@ delabTy' ist imps tm fullname mvs = de [] imps tm

5858 = PLam n (de env [] ty) (de ((n,n):env) [] sc)

5959 de env ((PImp { argopts = opts }):is) (Bind n (Pi ty) sc)

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

6262 = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)

6363 de env (PTacImplicit _ _ _ tac _:is) (Bind n (Pi ty) sc)

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

121121 | otherwise = PApp un (PRef un n) (map pexp args)

122122

123123 imp (PImp p m l n _) arg = PImp p m l n arg

124− imp (PExp p l _) arg = PExp p l arg

125− imp (PConstraint p l _) arg = PConstraint p l arg

124+ imp (PExp p l n _) arg = PExp p l n arg

125+ imp (PConstraint p l n _) arg = PConstraint p l n arg

126126 imp (PTacImplicit p l n sc _) arg = PTacImplicit p l n sc arg

127127

128128-- | How far to indent sub-errors

@@ -140,11 +140,6 @@ pprintTerm ist = pprintTerm' ist []

140140pprintTerm' :: IState -> [(Name, Bool)] -> PTerm -> Doc OutputAnnotation

141141pprintTerm' ist bnd tm = pprintPTerm (opt_showimp (idris_options ist)) bnd [] tm

142142

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−

148143pprintErr :: IState -> Err -> Doc OutputAnnotation

149144pprintErr i err = pprintErr' i (fmap (errReverse i) err)

150145

@@ -261,7 +256,7 @@ annName :: Name -> Doc OutputAnnotation

261256annName n = annName' n (showbasic n)

262257

263258annName' :: 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)

265260

266261showSc :: IState -> [(Name, Term)] -> Doc OutputAnnotation

267262showSc i [] = empty

src/Idris/ElabDecls.hs+151−109

@@ -16,6 +16,7 @@ import Idris.Primitives

1616import Idris.Inliner

1717import Idris.PartialEval

1818import Idris.DeepSeq

19+import Idris.Output (iputStrLn, pshow, iWarn)

1920import IRTS.Lang

2021import Paths_idris

2122

@@ -36,6 +37,7 @@ import Data.Maybe

3637import Debug.Trace

3738

3839import qualified Data.Map as Map

40+import qualified Data.Set as S

3941import qualified Data.Text as T

4042import Data.Char(isLetter, toLower)

4143import Data.List.Split (splitOn)

@@ -58,7 +60,8 @@ checkAddDef add toplvl fc [] = return []

5860checkAddDef add toplvl fc ((n, (i, top, t)) : ns)

5961 = do ctxt <- getContext

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

6265 ns' <- checkAddDef add toplvl fc ns

6366 return ((n, (i, top, t')) : ns')

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

8083

8184 logLvl 3 $ show n ++ " pre-type " ++ showTmImpls ty'

8285 ty' <- addUsingConstraints syn fc ty'

83− ty' <- implicit syn n ty'

86+ ty' <- implicit info syn n ty'

8487

85− let ty = addImpl i ty'

88+ let ty = addImpl i ty'

89+ inacc = inaccessibleArgs 0 ty

8690 logLvl 3 $ show n ++ " type " ++ showTmImpls ty

91+ logLvl 5 $ "Inaccessible arguments: " ++ show inacc

92+

8793 ((tyT, defer, is), log) <-

8894 tclift $ elaborate ctxt n (TType (UVal 0)) []

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

128134 addDocStr n doc argDocs

129135 addIBC (IBCDoc n)

130136 addIBC (IBCFlags n opts')

137+ saveInaccArgs n inacc

131138 when (Implicit `elem` opts') $ do addCoercion n

132139 addIBC (IBCCoercion n)

140+

133141 -- If the function is declared as an error handler and the language

134142 -- extension is enabled, then add it to the list of error handlers.

135143 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

170178 , ns4 == map txt ["Errors","Reflection","Language"] = True

171179 tyIsHandler _ = False

172180

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 _ _ = []

173205

174206elabPostulate :: ElabInfo -> SyntaxInfo -> Docstring ->

175207 FC -> FnOpts -> Name -> PTerm -> Idris ()

176−elabPostulate info syn doc fc opts n ty

177− = do elabType info syn doc [] fc opts n ty

178− -- make sure it's collapsible, so it is never needed at run time

179− -- start by getting the elaborated type

180− ctxt <- getContext

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

196− solveDeferred n

208+elabPostulate info syn doc fc opts n ty = do

209+ elabType info syn doc [] fc opts n ty

210+ putIState . (\ist -> ist{ idris_postulates = S.insert n (idris_postulates ist) }) =<< getIState

211+ addIBC (IBCPostulate n)

212+

213+ -- remove it from the deferred definitions list

214+ solveDeferred n

197215

198216elabData :: ElabInfo -> SyntaxInfo -> Docstring -> [(Name, Docstring)] -> FC -> DataOpts -> PData -> Idris ()

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

202220 checkUndefined fc n

203221 ctxt <- getContext

204222 i <- getIState

205− t_in <- implicit syn n t_in

223+ -- TODO think: something more in info?

224+ t_in <- implicit info syn n t_in

206225 let t = addImpl i t_in

207226 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

208227 (erun fc (build i info False [] n t))

209228 def' <- checkDef fc defer

210229 let def'' = map (\(n, (i, top, t)) -> (n, (i, top, t, True))) def'

211230 addDeferredTyCon def''

231+ addIBC (IBCDef n)

212232 mapM_ (elabCaseBlock info []) is

213233 (cty, _) <- recheckC fc [] t'

214234 logLvl 2 $ "---> " ++ show cty

@@ -220,7 +240,7 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

220240 undef <- isUndefined fc n

221241 ctxt <- getContext

222242 i <- getIState

223− t_in <- implicit syn n t_in

243+ t_in <- implicit info syn n t_in

224244 let t = addImpl i t_in

225245 ((t', defer, is), log) <-

226246 tclift $ elaborate ctxt n (TType (UVal 0)) []

@@ -236,7 +256,8 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

236256 logLvl 2 $ "---> " ++ show cty

237257 -- temporary, to check cons

238258 when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

239− cons <- mapM (elabCon info syn n codata) dcons

259+ let cnameinfo = cinfo info (map cname dcons)

260+ cons <- mapM (elabCon cnameinfo syn n codata) dcons

240261 ttag <- getName

241262 i <- getIState

242263 let as = map (const Nothing) (getArgTys cty)

@@ -253,15 +274,30 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

253274 let metainf = DataMI params

254275 addIBC (IBCMetaInformation n metainf)

255276 -- TMP HACK! Make this a data option

256− when (n /= sUN "Lazy'") $ collapseCons n cons

257277 updateContext (addDatatype (Data n ttag cty cons))

258278 updateContext (setMetaInformation n metainf)

259279 mapM_ (checkPositive n) cons

260− if DefaultEliminator `elem` opts

261− then evalStateT (elabEliminator params n t dcons info) Map.empty

262− else return ()

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

289+ when (DefaultEliminator `elem` opts) $

290+ evalStateT (elabEliminator params n t dcons info) Map.empty

263291 where

264− checkDefinedAs fc n t ctxt

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+

300+ checkDefinedAs fc n t ctxt

265301 = case lookupDef n ctxt of

266302 [] -> return ()

267303 [TyDecl _ ty] ->

@@ -319,6 +355,21 @@ elabData info syn doc argDocs fc opts (PDatadecl n t_in dcons)

319355 | otherwise = count n ts

320356 mParam args (_ : rest) = Nothing : mParam args rest

321357

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+

322373type EliminatorState = StateT (Map.Map String Int) Idris

323374

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

728779 PTerm -> Docstring -> Name -> PTerm -> Idris ()

729780elabRecord info syn doc fc tyn ty cdoc cn cty

730781 = do elabData info syn doc [] fc [] (PDatadecl tyn ty [(cdoc, [], cn, cty, fc, [])])

731− cty' <- implicit syn cn cty

782+ -- TODO think: something more in info?

783+ cty' <- implicit info syn cn cty

732784 i <- getIState

733785 cty <- case lookupTy cn (tt_ctxt i) of

734786 [t] -> return (delab i t)

@@ -750,7 +802,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

750802 where

751803-- syn = syn_in { syn_namespace = show (nsroot tyn) : syn_namespace syn_in }

752804

753− isNonImp (PExp _ _ _, a) = Just a

805+ isNonImp (PExp _ _ _ _, a) = Just a

754806 isNonImp _ = Nothing

755807

756808 tryElabDecl info (fn, ty, val)

@@ -833,15 +885,22 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

833885 (map pexp rhsArgs)) []

834886 return (pn, pfnTy, PClauses fc [] setname [pclause])

835887

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

836893elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

837894 (Docstring, [(Name, Docstring)], Name, PTerm, FC, [Name]) -> Idris (Name, Type)

838895elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

839896 = do checkUndefined fc n

840897 ctxt <- getContext

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

843900 let t = addImpl i t_in

844901 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ show t

902+ let inacc = inaccessibleArgs 0 t

903+ logLvl 5 $ "Inaccessible args: " ++ show inacc

845904 ((t', defer, is), log) <-

846905 tclift $ elaborate ctxt n (TType (UVal 0)) []

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

859918 checkDocs fc argDocs t_in

860919 addDocStr n doc argDocs

861920 addIBC (IBCDoc n)

862− let fs = map (getNamePos 0 t) forcenames

863− -- FIXME: 'forcenames' is an almighty hack! Need a better way of

864− -- erasing non-forceable things

865− forceArgs tn n (mapMaybe (getNamePos 0 t) forcenames) cty'

921+ saveInaccArgs n inacc

922+ addIBC (IBCOpt n)

866923 return (n, cty')

867924 where

868925 tyIs (Bind n b sc) = tyIs sc

@@ -873,7 +930,7 @@ elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

873930

874931 mkLazy (PPi pl n ty sc)

875932 = let ty' = if getTyName ty

876− then PApp fc (PRef fc (sUN "Lazy'"))

933+ then PApp fc (PRef fc (sUN "Lazy'"))

877934 [pexp (PRef fc (sUN "LazyCodata")),

878935 pexp ty]

879936 else ty in

@@ -895,6 +952,10 @@ elabCon info syn tn codata (doc, argDocs, n, t_in, fc, forcenames)

895952elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

896953elabClauses info fc opts n_in cs = let n = liftname info n_in in

897954 do ctxt <- getContext

955+ ist <- getIState

956+ let inacc = case lookupCtxt n (idris_optimisation ist) of

957+ [Optimise inacc _] -> map fst inacc

958+ _ -> []

898959 -- Check n actually exists, with no definition yet

899960 let tys = lookupTy n ctxt

900961 let reflect = Reflection `elem` opts

@@ -906,33 +967,19 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

906967 tclift $ tfail $ At fc (NoTypeDecl n)

907968 [ty] -> return ty

908969 let atys = map snd (getArgTys fty)

909− pats_in <- mapM (elabClause info opts)

970+ cs_elab <- mapM (elabClause info opts)

910971 (zip [0..] cs)

972+ let (pats_in, cs_full) = unzip cs_elab

973+

911974 logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in

912975

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

925976 solveDeferred n

977+

926978 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 [] [])

933− (idris_optimisation ist)

934− putIState (ist { idris_optimisation = opts })

935− addIBC (IBCOpt n)

979+ let opts = addDef n (Optimise [] False) (idris_optimisation ist)

980+ in putIState (ist { idris_optimisation = opts })

981+ addIBC (IBCOpt n)

982+

936983 ist <- getIState

937984 let pats = map (simple_lhs (tt_ctxt ist)) $ doTransforms ist pats_in

938985

@@ -942,11 +989,8 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

942989 let tcase = opt_typecase (idris_options ist)

943990

944991 -- Summary of what's about to happen: Definitions go:

945−

946− -- pats_in -> pats -> optpats

947− -- pdef comes from pats,

948− -- optpdef comes from optpats

949− -- Then pdef' is optpdef with forcing/collapsing applied everywhere

992+ --

993+ -- pats_in -> pats -> pdef -> pdef'

950994

951995 -- addCaseDef builds case trees from <pdef> and <pdef'>

952996

@@ -975,24 +1019,16 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

9751019

9761020 numArgs <- tclift $ sameLength pdef

9771021

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−

9851022 case specNames opts of

9861023 Just _ -> logLvl 5 $ "Partially evaluated:\n" ++ show pats

9871024 _ -> return ()

9881025

989− let optpdef = map debind optpats -- \$ map (simple_lhs (tt_ctxt ist)) optpats

9901026 tree@(CaseDef scargs sc _) <- tclift $

991− simpleCase tcase False reflect CompileTime fc atys pdef

1027+ simpleCase tcase False reflect CompileTime fc inacc atys pdef

9921028 cov <- coverage

9931029 pmissing <-

9941030 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

9961032 -- missing <- genMissing n scargs sc

9971033 missing' <- filterM (checkPossible info fc True n) missing

9981034 let clhs = map getLHS pdef

@@ -1010,7 +1046,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

10101046 let pcover = null pmissing

10111047

10121048 -- pdef' is the version that gets compiled for run-time

1013− pdef_in' <- applyOpts optpdef

1049+ pdef_in' <- applyOpts pdef

10141050 let pdef' = map (simple_rt (tt_ctxt ist)) pdef_in'

10151051

10161052 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

10371073 let knowncovering = (pcover && cov) || AssertTotal `elem` opts

10381074

10391075 tree' <- tclift $ simpleCase tcase knowncovering reflect

1040− RunTime fc atys pdef'

1041− logLvl 3 (show tree)

1076+ RunTime fc inacc atys pdef'

1077+ logLvl 3 $ "Unoptimised " ++ show n ++ ": " ++ show tree

10421078 logLvl 3 $ "Optimised: " ++ show tree'

10431079 ctxt <- getContext

10441080 ist <- getIState

1081+ let opt = idris_optimisation ist

10451082 putIState (ist { idris_patdefs = addDef n (force pdef', force pmissing)

10461083 (idris_patdefs ist) })

10471084 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

10511088 reflect

10521089 (AssertTotal `elem` opts)

10531090 atys

1091+ inacc

10541092 pats

10551093 pdef pdef pdef_inl pdef' ty)

10561094 addIBC (IBCDef n)

@@ -1067,7 +1105,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

10671105 let used = findUsedArgs sc' scargs'

10681106 -- let scg = buildSCG i sc scargs

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

10711109 logLvl 2 $ "Called names: " ++ show cg

10721110 addToCG n cg

10731111 addToCalledG n (nub (map fst calls)) -- plus names in type!

@@ -1288,7 +1326,7 @@ checkPossible info fc tcgen fname lhs_in

12881326 ((P _ x _, _), (P _ y _, _)) -> x == y

12891327 _ -> False

12901328

1291−getFixedInType i env (PExp _ _ _ : is) (Bind n (Pi t) sc)

1329+getFixedInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)

12921330 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

12931331getFixedInType i env (_ : is) (Bind n (Pi t) sc)

12941332 = getFixedInType i (n : env) is (instantiate (P Bound n t) sc)

@@ -1350,16 +1388,19 @@ propagateParams ps t (PRef fc n)

13501388 = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)

13511389propagateParams ps t x = x

13521390

1391+-- Return the elaborated LHS/RHS, and the original LHS with implicits added

13531392elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

1354− Idris (Either Term (Term, Term))

1393+ Idris (Either Term (Term, Term), PTerm)

13551394elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

13561395 = do let tcgen = Dictionary `elem` opts

1396+ i <- get

1397+ let lhs = addImpl i lhs_in

13571398 b <- checkPossible info fc tcgen fname lhs_in

13581399 case b of

13591400 True -> tclift $ tfail (At fc

13601401 (Msg $ show lhs_in ++ " is a valid case"))

13611402 False -> do ptm <- mkPatTm lhs_in

1362− return (Left ptm)

1403+ return (Left ptm, lhs)

13631404elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

13641405 = do let tcgen = Dictionary `elem` opts

13651406 ctxt <- getContext

@@ -1416,10 +1457,10 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

14161457 -- Elaborate where block

14171458 ist <- getIState

14181459 windex <- getName

1419− let winfo = pinfo (pvars ist lhs_tm) whereblock windex

14201460 let decls = nub (concatMap declared whereblock)

14211461 let defs = nub (decls ++ concatMap defined whereblock)

14221462 let newargs = pvars ist lhs_tm

1463+ let winfo = pinfo info newargs defs windex

14231464 let wb = map (expandParamsD False ist decorate newargs defs) whereblock

14241465

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

14281469 let (wbefore, wafter) = sepBlocks wb

14291470

14301471 logLvl 2 $ "Where block:\n " ++ show wbefore ++ "\n" ++ show wafter

1431− mapM_ (elabDecl' EAll info) wbefore

1472+ mapM_ (elabDecl' EAll winfo) wbefore

14321473 -- Now build the RHS, using the type of the LHS as the goal.

14331474 i <- getIState -- new implicits from where block

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

14431484 mapM_ setinj (nub (params ++ inj))

14441485 setNextName

14451486 (_, _, 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))

14471488 errAt "right hand side of " fname

14481489 (erun fc $ psolve lhs_tm)

14491490 hs <- get_holes

@@ -1471,8 +1512,8 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

14711512 -- Now the remaining deferred (i.e. no type declarations) clauses

14721513 -- from the where block

14731514

1474− mapM_ (elabDecl' EAll info) wafter

1475− mapM_ (elabCaseBlock info opts) is

1515+ mapM_ (elabDecl' EAll winfo) wafter

1516+ mapM_ (elabCaseBlock winfo opts) is

14761517

14771518 ctxt <- getContext

14781519 logLvl 5 $ "Rechecking"

@@ -1500,8 +1541,21 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

15001541 when (rev || ErrorReverse `elem` opts) $ do

15011542 addIBC (IBCErrRev (crhs, clhs))

15021543 addErrRev (crhs, clhs)

1503− return $ Right (clhs, crhs)

1544+ return $ (Right (clhs, crhs), lhs)

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

15051559 mkLHSapp t@(PRef _ _) = trace ("APP " ++ show t) $ PApp fc t []

15061560 mkLHSapp t = t

15071561

@@ -1524,19 +1578,6 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

15241578 (b : bf, af)

15251579 sepBlocks' ns [] = ([], [])

15261580

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−

15401581

15411582 -- if a hole is just an argument/result of a case block, treat it as

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

16671708 mapM_ (elabCaseBlock info opts) is

16681709 logLvl 5 ("Checked RHS " ++ show rhs')

16691710 (crhs, crhsty) <- recheckC fc [] rhs'

1670− return $ Right (clhs, crhs)

1711+ return $ (Right (clhs, crhs), lhs)

16711712 where

16721713 getImps (Bind n (Pi _) t) = pexp Placeholder : getImps t

16731714 getImps _ = []

@@ -1801,7 +1842,7 @@ elabClass info syn doc fc constraints tn ps ds

18011842

18021843 getMName (PTy _ _ _ _ _ n _) = nsroot n

18031844 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

18051846 logLvl 5 $ "Method " ++ show n ++ " : " ++ showTmImpls t'

18061847 return ( (n, (toExp (map fst ps) Exp t')),

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

20052046 -- TODO: largely based upon elabType' - should try to abstract

20062047 elabFindOverlapping i ci iname syn t

20072048 = do ty' <- addUsingConstraints syn fc t

2008− ty' <- implicit syn iname ty'

2049+ -- TODO think: something more in info?

2050+ ty' <- implicit info syn iname ty'

20092051 let ty = addImpl i ty'

20102052 ctxt <- getContext

20112053 ((tyT, _, _), _) <-

@@ -2043,9 +2085,9 @@ elabInstance info syn what fc cs n ps t expn ds = do

20432085 methArgs i (PPi (Imp _ _ _) n ty sc)

20442086 = PImp 0 True [] n (PRef fc (sMN i "meth")) : methArgs (i+1) sc

20452087 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

20472089 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

20492091 methArgs i _ = []

20502092

20512093 papp fc f [] = f

@@ -2061,7 +2103,7 @@ elabInstance info syn what fc cs n ps t expn ds = do

20612103 _ -> return ps'

20622104 getWParams (_ : ps) = getWParams ps

20632105

2064− decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

2106+ decorate ns iname (UN n) = NS (SN (MethodN (UN n))) ns

20652107 decorate ns iname (NS (UN n) s) = NS (SN (MethodN (UN n))) ns

20662108

20672109 mkTyDecl (n, op, t, _) = PTy emptyDocstring [] syn fc op n t

src/Idris/ElabTerm.hs+5−13

@@ -3,10 +3,12 @@

33module Idris.ElabTerm where

44

55import Idris.AbsSyntax

6+import Idris.AbsSyntaxTree

67import Idris.DSL

78import Idris.Delaborate

89import Idris.Error

910import Idris.ProofSearch

11+import Idris.Output (pshow)

1012

1113import Idris.Core.Elaborate hiding (Tactic(..))

1214import Idris.Core.TT

@@ -26,16 +28,6 @@ import qualified Data.Text as T

2628

2729import Debug.Trace

2830

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−

3931-- Using the elaborator, convert a term in raw syntax to a fully

4032-- elaborated, typechecked term.

4133--

@@ -473,7 +465,7 @@ elab ist info pattern opts fn tm

473465 elabArgs ist (ina || not isinf, guarded, inty)

474466 [] fc False f ns'

475467 (f == sUN "Force")

476− (map (\x -> (lazyarg x, getTm x)) eargs)

468+ (map (\x -> (False, getTm x)) eargs) -- TODO: remove this False arg

477469 solve

478470 ivs' <- get_instances

479471 -- Attempt to resolve any type classes which have 'complete' types,

@@ -696,7 +688,7 @@ elab ist info pattern opts fn tm

696688 where

697689 mkDelay (PAlternative b xs) = PAlternative b (map mkDelay xs)

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

700692 [pexp t])

701693

702694 insertCoerce ina t =

@@ -732,7 +724,7 @@ elab ist info pattern opts fn tm

732724 = elabArgs ist ina failed fc r f ns force args

733725 elabArgs ist ina failed fc r f ((argName, holeName):ns) force ((lazy, t) : args)

734726 | lazy && not pattern

735− = elabArg argName holeName (PApp bi (PRef bi (sUN "lazy"))

727+ = elabArg argName holeName (PApp bi (PRef bi (sUN "Delay"))

736728 [pimp (sUN "a") Placeholder True,

737729 pexp t])

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

55import Prelude hiding (catch)

66import Idris.AbsSyntax

77import Idris.Delaborate

8+import Idris.Output

89

910import Idris.Core.TT

1011import Idris.Core.Typecheck

src/Idris/IBC.hs+42−28

@@ -10,6 +10,7 @@ import Idris.Imports

1010import Idris.Error

1111import Idris.Delaborate

1212import Idris.Docstrings

13+import Idris.Output

1314

1415import qualified Cheapskate.Types as CT

1516

@@ -18,6 +19,7 @@ import Data.Vector.Binary

1819import Data.List

1920import Data.ByteString.Lazy as B hiding (length, elem, map)

2021import qualified Data.Text as T

22+import qualified Data.Set as S

2123

2224import Control.Monad

2325import Control.Monad.State.Strict hiding (get, put)

@@ -28,7 +30,7 @@ import Codec.Compression.Zlib (compress)

2830import Util.Zlib (decompressEither)

2931

3032ibcVersion :: Word8

31−ibcVersion = 65

33+ibcVersion = 67

3234

3335data IBCFile = IBCFile { ver :: Word8,

3436 sourcefile :: FilePath,

@@ -64,7 +66,8 @@ data IBCFile = IBCFile { ver :: Word8,

6466 ibc_errorhandlers :: [Name],

6567 ibc_function_errorhandlers :: [(Name, Name, Name)], -- fn, arg, handler

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

6871 }

6972 deriving Show

7073{-!

@@ -72,12 +75,15 @@ deriving instance Binary IBCFile

7275!-}

7376

7477initIBC :: IBCFile

75−initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

78+initIBC = IBCFile ibcVersion "" [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] [] []

7679

7780loadIBC :: FilePath -> Idris ()

78−loadIBC fp = do iLOG $ "Loading ibc " ++ fp

79− ibcf <- runIO $ (bdecode fp :: IO IBCFile)

80− process ibcf fp

81+loadIBC fp = do imps <- getImported

82+ when (not (fp `elem` imps)) $

83+ do iLOG $ "Loading ibc " ++ fp

84+ ibcf <- runIO $ (bdecode fp :: IO IBCFile)

85+ process ibcf fp

86+ addImported fp

8187

8288bencode :: Binary a => FilePath -> a -> IO ()

8389bencode f d = B.writeFile f (compress (encode d))

@@ -232,6 +238,7 @@ ibc i (IBCMetavar n) f =

232238 case lookup n (idris_metavars i) of

233239 Nothing -> return f

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

235242

236243process :: IBCFile -> FilePath -> Idris ()

237244process i fn

@@ -274,6 +281,7 @@ process i fn

274281 pErrorHandlers (ibc_errorhandlers i)

275282 pFunctionErrorHandlers (ibc_function_errorhandlers i)

276283 pMetavars (ibc_metavars i)

284+ pPostulates (ibc_postulates i)

277285

278286timestampOlder :: FilePath -> FilePath -> IO ()

279287timestampOlder src ibc = do srct <- getModificationTime src

@@ -282,6 +290,11 @@ timestampOlder src ibc = do srct <- getModificationTime src

282290 then fail "Needs reloading"

283291 else return ()

284292

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+

285298pImports :: [FilePath] -> Idris ()

286299pImports fs

287300 = do mapM_ (\f -> do i <- getIState

@@ -396,8 +409,11 @@ pPatdefs ds

396409pDefs :: [Name] -> [(Name, Def)] -> Idris ()

397410pDefs syms ds

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

401417 logLvl 5 $ "Added " ++ show (n, d')

402418 putIState (i { tt_ctxt = addCtxtDef n d' (tt_ctxt i) })) ds

403419 where

@@ -1086,10 +1102,6 @@ safeToEnum label x' = result

10861102 = error $ label ++ ": corrupted binary representation in IBC"

10871103 | otherwise = toEnum x

10881104

1089−instance Binary Forceability where

1090− put = putWord8 . fromIntegral . fromEnum

1091− get = safeToEnum "Forceability" `fmap` getWord8

1092−

10931105instance Binary PReason where

10941106 put x

10951107 = case x of

@@ -1149,7 +1161,7 @@ instance Binary MetaInformation where

11491161 return (DataMI x1)

11501162

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

11531165 = {-# SCC "putIBCFile" #-}

11541166 do put x1

11551167 put x2

@@ -1186,6 +1198,7 @@ instance Binary IBCFile where

11861198 put x33

11871199 put x34

11881200 put x35

1201+ put x36

11891202

11901203 get

11911204 = do x1 <- get

@@ -1224,7 +1237,8 @@ instance Binary IBCFile where

12241237 x33 <- get

12251238 x34 <- get

12261239 x35 <- get

1227− return (IBCFile x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35)

1240+ x36 <- get

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)

12281242 else return (initIBC { ver = x1 })

12291243

12301244instance Binary DataOpt where

@@ -1310,13 +1324,13 @@ instance Binary FixDecl where

13101324instance Binary ArgOpt where

13111325 put x

13121326 = case x of

1313− Lazy -> putWord8 0

1314− HideDisplay -> putWord8 1

1327+ HideDisplay -> putWord8 0

1328+ InaccessibleArg -> putWord8 1

13151329 get

13161330 = do i <- getWord8

13171331 case i of

1318− 0 -> return Lazy

1319− 1 -> return HideDisplay

1332+ 0 -> return HideDisplay

1333+ 1 -> return InaccessibleArg

13201334 _ -> error "Corrupted binary data for Static"

13211335

13221336instance Binary Static where

@@ -2030,16 +2044,18 @@ instance (Binary t) => Binary (PArg' t) where

20302044 put x3

20312045 put x4

20322046 put x5

2033− PExp x1 x2 x3 ->

2047+ PExp x1 x2 x3 x4 ->

20342048 do putWord8 1

20352049 put x1

20362050 put x2

20372051 put x3

2038− PConstraint x1 x2 x3 ->

2052+ put x4

2053+ PConstraint x1 x2 x3 x4 ->

20392054 do putWord8 2

20402055 put x1

20412056 put x2

20422057 put x3

2058+ put x4

20432059 PTacImplicit x1 x2 x3 x4 x5 ->

20442060 do putWord8 3

20452061 put x1

@@ -2059,11 +2075,13 @@ instance (Binary t) => Binary (PArg' t) where

20592075 1 -> do x1 <- get

20602076 x2 <- get

20612077 x3 <- get

2062− return (PExp x1 x2 x3)

2078+ x4 <- get

2079+ return (PExp x1 x2 x3 x4)

20632080 2 -> do x1 <- get

20642081 x2 <- get

20652082 x3 <- get

2066− return (PConstraint x1 x2 x3)

2083+ x4 <- get

2084+ return (PConstraint x1 x2 x3 x4)

20672085 3 -> do x1 <- get

20682086 x2 <- get

20692087 x3 <- get

@@ -2089,17 +2107,13 @@ instance Binary ClassInfo where

20892107 return (CI x1 x2 x3 x4 x5 [])

20902108

20912109instance Binary OptInfo where

2092− put (Optimise x1 x2 x3 x4)

2110+ put (Optimise x1 x2)

20932111 = do put x1

20942112 put x2

2095− put x3

2096− put x4

20972113 get

20982114 = do x1 <- get

20992115 x2 <- get

2100− x3 <- get

2101− x4 <- get

2102− return (Optimise x1 x2 x3 x4)

2116+ return (Optimise x1 x2)

21032117

21042118instance Binary TypeInfo where

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

7474 toSExp (l, m, n, o, p) = SexpList [toSExp l, toSExp m, toSExp n, toSExp o, toSExp p]

7575

7676instance SExpable NameOutput where

77− toSExp TypeOutput = SymbolAtom "type"

78− toSExp FunOutput = SymbolAtom "function"

79− toSExp DataOutput = SymbolAtom "data"

77+ toSExp TypeOutput = SymbolAtom "type"

78+ toSExp FunOutput = SymbolAtom "function"

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

8086

8187instance SExpable OutputAnnotation where

82− toSExp (AnnName n Nothing _) = toSExp [(SymbolAtom "name", StringAtom (show n)),

83− (SymbolAtom "implicit", BoolAtom False)]

84− toSExp (AnnName n (Just ty) _) = toSExp [(SymbolAtom "name", StringAtom (show n)),

85− (SymbolAtom "decor", toSExp ty),

86− (SymbolAtom "implicit", BoolAtom False)]

88+ toSExp (AnnName n ty d t) = toSExp $ [(SymbolAtom "name", StringAtom (show n)),

89+ (SymbolAtom "implicit", BoolAtom False)] ++

90+ maybeProps [("decor", ty)] ++

91+ maybeProps [("doc-overview", d), ("type", t)]

8792 toSExp (AnnBoundName n imp) = toSExp [(SymbolAtom "name", StringAtom (show n)),

8893 (SymbolAtom "decor", SymbolAtom "bound"),

8994 (SymbolAtom "implicit", BoolAtom imp)]

@@ -146,6 +151,7 @@ data IdeSlaveCommand = REPLCompletions String

146151 | Apropos String

147152 | GetOpts

148153 | SetOpt Opt Bool

154+ | Metavariables Int -- ^^ the Int is the column count for pretty-printing

149155 deriving Show

150156

151157sexpToCommand :: SExp -> Maybe IdeSlaveCommand

@@ -169,6 +175,7 @@ sexpToCommand (SymbolAtom "get-options")

169175sexpToCommand (SexpList [SymbolAtom "set-option", SymbolAtom s, BoolAtom b])

170176 | Just opt <- lookup s opts = Just (SetOpt opt b)

171177 where opts = [("show-implicits", ShowImpl), ("error-context", ErrContext)] --TODO support more

178+sexpToCommand (SexpList [SymbolAtom "metavariables", IntegerAtom cols]) = Just (Metavariables (fromIntegral cols))

172179sexpToCommand _ = Nothing

173180

174181parseMessage :: 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 _)

150150 update ns (PRef fc n) = case lookup n ns of

151151 Just (SynTm t) -> t

152152 _ -> PRef fc n

153− update ns (PLam n ty sc) = PLam (updateB ns n) (update ns ty) (update (dropn n ns) sc)

154− update ns (PPi p n ty sc) = PPi p (updateB ns n) (update ns ty) (update (dropn n ns) sc)

155− update ns (PLet n ty val sc) = PLet (updateB ns n) (update ns ty) (update ns val)

156− (update (dropn n ns) sc)

157− update ns (PApp fc t args) = PApp fc (update ns t) (map (fmap (update ns)) args)

158− update ns (PAppBind fc t args) = PAppBind fc (update ns t) (map (fmap (update ns)) args)

159− update ns (PCase fc c opts) = PCase fc (update ns c) (map (pmap (update ns)) opts)

153+ update ns (PLam n ty 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)

157+ (update ns ty) (update (dropn n ns) sc)

158+ update ns (PLet n ty val sc)

159+ = PLet (updateB ns n) (update ns ty)

160+ (update ns val) (update (dropn n ns) sc)

161+ update ns (PApp fc t args)

162+ = PApp fc (update ns t) (map (fmap (update ns)) args)

163+ update ns (PAppBind fc t args)

164+ = PAppBind fc (update ns t) (map (fmap (update ns)) args)

165+ update ns (PCase fc c opts)

166+ = PCase fc (update ns c) (map (pmap (update ns)) opts)

160167 update ns (PPair fc p l r) = PPair fc p (update ns l) (update ns r)

161− update ns (PDPair fc p l t r) = PDPair fc p (update ns l) (update ns t) (update ns r)

168+ update ns (PDPair fc p l t r)

169+ = PDPair fc p (update ns l) (update ns t) (update ns r)

162170 update ns (PAlternative a as) = PAlternative a (map (update ns) as)

163171 update ns (PHidden t) = PHidden (update ns t)

164172 update ns (PDoBlock ds) = PDoBlock $ upd ns ds

@@ -176,6 +184,9 @@ extension syn (Rule ssym ptm _)

176184 update ns (PGoal fc r n sc) = PGoal fc (update ns r) n (update ns sc)

177185 update ns t = t

178186

187+ updTacImp ns (TacImp o st scr) = TacImp o st (update ns scr)

188+ updTacImp _ x = x

189+

179190{- | Parses a (normal) built-in expression

180191@

181192InternalExpr ::=

@@ -788,18 +799,15 @@ Pi ::=

788799

789800pi :: SyntaxInfo -> IdrisParser PTerm

790801pi syn =

791− do opts <- -- if implicitAllowed syn -- laziness is top level only

792− -- then option [] (do lchar '|'; return [Lazy])

793− -- else return []

794− return []

795− st <- static

802+ do opts <- piOpts syn

803+ st <- static

796804 (do try (lchar '('); xt <- typeDeclList syn; lchar ')'

797805 symbol "->"

798806 sc <- expr syn

799807 return (bindList (PPi (Exp opts st False)) xt sc)) <|> (do

800808 lchar '{'

801809 (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"

803811 xt <- typeDeclList syn

804812 lchar '}'

805813 symbol "->"

@@ -808,7 +816,7 @@ pi syn =

808816 (TacImp [] Dynamic (PTactics [Trivial]))) xt sc))

809817 <|> (do

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

812820 script <- simpleExpr syn

813821 xt <- typeDeclList syn

814822 lchar '}'

@@ -824,6 +832,12 @@ pi syn =

824832 else do fail "no implicit arguments allowed here"))

825833 <?> "dependent type signature"

826834

835+piOpts :: SyntaxInfo -> IdrisParser [ArgOpt]

836+piOpts syn | implicitAllowed syn =

837+ lchar '.' *> return [InaccessibleArg]

838+ <|> return []

839+piOpts syn = return []

840+

827841{- | Parses a type constraint list

828842

829843@

src/Idris/ParseHelpers.hs+1

@@ -17,6 +17,7 @@ import Idris.Core.TT

1717import Idris.Core.Evaluate

1818import Idris.Delaborate (pprintErr)

1919import Idris.Docstrings

20+import Idris.Output (ihWarn)

2021

2122import qualified Util.Pretty as Pretty (text)

2223

src/Idris/ParseOps.hs+6−1

@@ -37,9 +37,14 @@ table fixes

3737 [pexp (PApp fc (PRef fc (sUN "fromInteger")) [pexp (PConstant (BI 0))]), pexp x])]]

3838 ++ toTable (reverse fixes) ++

3939 [[backtick],

40− [binary "$" (\fc x y -> PApp fc x [pexp y]) AssocRight],

40+ [binary "$" (\fc x y -> flatten $ PApp fc x [pexp y]) AssocRight],

4141 [binary "=" PEq AssocLeft],

4242 [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+

4348

4449-- | Calculates table for fixtiy declarations

4550toTable :: [FixDecl] -> OperatorTable IdrisParser PTerm

src/Idris/Parser.hs+18−3

@@ -17,18 +17,20 @@ import qualified Text.Parser.Char as Chr

1717import qualified Text.Parser.Token.Highlight as Hi

1818

1919import Text.PrettyPrint.ANSI.Leijen (Doc, plain)

20+import qualified Text.PrettyPrint.ANSI.Leijen as ANSI

2021

21−import Idris.AbsSyntax

22+import Idris.AbsSyntax hiding (namespace, params)

2223import Idris.DSL

2324import Idris.Imports

2425import Idris.Delaborate

2526import Idris.Error

2627import Idris.ElabDecls

27−import Idris.ElabTerm hiding (namespace, params)

28+import Idris.ElabTerm

2829import Idris.Coverage

2930import Idris.IBC

3031import Idris.Unlit

3132import Idris.Providers

33+import Idris.Output

3234

3335import Idris.ParseHelpers

3436import Idris.ParseOps

@@ -1119,6 +1121,11 @@ findFC x = let s = show (plain x) in

11191121 (col, ':':msg) -> let pos = (read line, read col) in

11201122 (FC failname pos pos, msg)

11211123

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+

11221129-- | A program is a list of declarations, possibly with associated

11231130-- documentation strings.

11241131parseProg :: SyntaxInfo -> FilePath -> String -> Maybe Delta ->

@@ -1131,7 +1138,7 @@ parseProg syn fname input mrk

11311138 let (fc, msg) = findFC doc

11321139 i <- getIState

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

11351142 IdeSlave n -> ihWarn (idris_outh i) fc (P.text msg)

11361143 putIState (i { errSpan = Just fc })

11371144 return []

@@ -1212,6 +1219,14 @@ loadSource h lidr f

12121219 file_in <- runIO $ readFile f

12131220 file <- if lidr then tclift $ unlit f file_in else return file_in

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

12151230 reportParserWarnings

12161231

12171232 -- process and check module aliases

src/Idris/PartialEval.hs+1−1

@@ -124,7 +124,7 @@ getSpecApps ist env tm = ga env (explicitNames tm) where

124124 | imparg imp = (ImplicitD, tm)

125125 | otherwise = (ExplicitD, (P Ref (sUN (show n ++ "arg")) Erased))

126126

127− imparg (PExp _ _ _) = False

127+ imparg (PExp _ _ _ _) = False

128128 imparg _ = True

129129

130130 buildApp env [] [] _ _ = []

src/Idris/Prover.hs+7−5

@@ -7,6 +7,7 @@ import Idris.Core.CaseTree

77import Idris.Core.Typecheck

88

99import Idris.AbsSyntax

10+import Idris.AbsSyntaxTree

1011import Idris.Delaborate

1112import Idris.ElabDecls

1213import Idris.ElabTerm

@@ -15,6 +16,7 @@ import Idris.Error

1516import Idris.DataOpts

1617import Idris.Completion

1718import Idris.IdeSlave

19+import Idris.Output

1820

1921import Text.Trifecta.Result(Result(..))

2022

@@ -32,7 +34,7 @@ prover lit x =

3234 i <- getIState

3335 case lookupTy x ctxt of

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

3638 else ifail $ show x ++ " is not a metavariable"

3739 _ -> fail "No such metavariable"

3840

@@ -55,8 +57,8 @@ assumptionNames e

5557 names ((MN _ _, _) : bs) = names bs

5658 names ((n, _) : bs) = show n : names bs

5759

58−prove :: Context -> Bool -> Name -> Type -> Idris ()

59−prove ctxt lit n ty

60+prove :: Ctxt OptInfo -> Context -> Bool -> Name -> Type -> Idris ()

61+prove opt ctxt lit n ty

6062 = do let ps = initElaborator n ctxt ty

6163 ideslavePutSExp "start-proof-mode" n

6264 (tm, prf) <- ploop n True ("-" ++ show n) [] (ES (ps, []) "" Nothing) Nothing

@@ -66,7 +68,7 @@ prove ctxt lit n ty

6668 ideslavePutSExp "end-proof-mode" n

6769 let proofs = proof_list i

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

7072 logLvl 3 (show tree)

7173 (ptm, pty) <- recheckC (fileFC "proof") [] tm

7274 logLvl 5 ("Proof type: " ++ show pty ++ "\n" ++

@@ -76,7 +78,7 @@ prove ctxt lit n ty

7678 Error e -> ierror (CantUnify False ty pty e [] 0)

7779 ptm' <- applyOpts ptm

7880 updateContext (addCasedef n (CaseInfo True False) False False True False

79− []

81+ [] [] -- argtys, inaccArgs

8082 [Right (P Ref n ty, ptm)]

8183 [([], P Ref n ty, ptm)]

8284 [([], P Ref n ty, ptm)]

src/Idris/Providers.hs+2−1

@@ -11,7 +11,8 @@ import Debug.Trace

1111

1212-- | Wrap a type provider in the type of type providers

1313providerTy :: FC -> PTerm -> PTerm

14−providerTy fc tm = PApp fc (PRef fc $ sUN "Provider") [PExp 0 [] tm]

14+providerTy fc tm

15+ = PApp fc (PRef fc $ sUN "Provider") [PExp 0 [] (sMN 0 "pvarg") tm]

1516

1617ioret = sUN "prim_io_return"

1718ermod = sNS (sUN "Error") ["Providers"]

src/Idris/REPL.hs+208−127

@@ -8,15 +8,15 @@ import Idris.Apropos (apropos)

88import Idris.REPLParser

99import Idris.ElabDecls

1010import Idris.ElabTerm

11+import Idris.Erasure

1112import Idris.Error

1213import Idris.ErrReverse

1314import Idris.Delaborate

1415import Idris.Docstrings (Docstring, overview, renderDocstring)

1516import Idris.Prover

16−import Idris.Parser

17+import Idris.Parser hiding (indent)

1718import Idris.Primitives

1819import Idris.Coverage

19−import Idris.UnusedArgs

2020import Idris.Docs hiding (Doc)

2121import Idris.Help

2222import Idris.Completion

@@ -27,6 +27,7 @@ import Idris.Colours hiding (colourise)

2727import Idris.Inliner

2828import Idris.CaseSplit

2929import Idris.DeepSeq

30+import Idris.Output

3031

3132import Paths_idris

3233import Version_idris (gitHash)

@@ -78,8 +79,6 @@ import Data.Version

7879import Data.Word (Word)

7980import Control.DeepSeq

8081

81−import qualified Text.PrettyPrint.ANSI.Leijen as ANSI

82−

8382import Debug.Trace

8483

8584-- | Run the REPL

@@ -217,83 +216,133 @@ ideslave orig mods

217216 (f:_) -> f

218217 _ -> ""

219218 case IdeSlave.sexpToCommand sexp of

220− Just (IdeSlave.Interpret 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")

219+ Just cmd -> runIdeSlaveCommand id orig fn mods cmd

220+ Nothing -> iPrintError "did not understand" )

289221 (\e -> do iPrintError $ show e))

290222 (\e -> do iPrintError $ show e)

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

292269 where splitName :: String -> Either String Name

293270 splitName s = case reverse $ splitOn "." s of

294271 [] -> Left ("Didn't understand name '" ++ s ++ "'")

295272 [n] -> Right $ sUN n

296273 (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+

297346

298347ideslaveProcess :: FilePath -> Command -> Idris ()

299348ideslaveProcess fn Help = process stdout fn Help

@@ -319,8 +368,6 @@ ideslaveProcess fn (HNF t) = process stdout fn (HNF t)

319368--ideslaveProcess fn TTShell = process stdout fn TTShell -- need some prove mode!

320369ideslaveProcess fn (TestInline t) = process stdout fn (TestInline t)

321370

322−--that most likely does not work, since we need to wrap

323−--input/output of the executed binary...

324371ideslaveProcess fn Execute = do process stdout fn Execute

325372 iPrintResult ""

326373ideslaveProcess fn (Compile codegen f) = do process stdout fn (Compile codegen f)

@@ -532,7 +579,7 @@ process h fn (Check (PRef _ n))

532579 putTy imp ist _ bnd sc = putGoal imp ist ((n,False):bnd) sc

533580 putGoal imp ist bnd g

534581 = text "--------------------------------------" <$>

535− annotate (AnnName n Nothing Nothing) (text $ show n) <+> colon <+>

582+ annotate (AnnName n Nothing Nothing Nothing) (text $ show n) <+> colon <+>

536583 align (tPretty bnd ist g)

537584

538585 tPretty bnd ist t = pprintPTerm (opt_showimp (idris_options ist)) bnd [] t

@@ -608,7 +655,6 @@ process h fn (DebugInfo n)

608655 let d = lookupDef n (tt_ctxt i)

609656 when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

610657 let cg = lookupCtxtName n (idris_callgraph i)

611− findUnusedArgs (map fst cg)

612658 i <- getIState

613659 let cg' = lookupCtxtName n (idris_callgraph i)

614660 sc <- checkSizeChange n

@@ -618,7 +664,8 @@ process h fn (DebugInfo n)

618664process h fn (Info n)

619665 = do i <- getIState

620666 case lookupCtxt n (idris_classes i) of

621− [c] -> classInfo c

667+ [c] -> do info <- classInfo c

668+ ihRenderResult h info

622669 _ -> iPrintError "Not a class"

623670process h fn (Search t) = iPrintError "Not implemented"

624671-- FIXME: There is far too much repetition in the cases below!

@@ -891,17 +938,19 @@ process h fn (TestInline t)

891938 c <- colourise

892939 iPrintResult (showTm ist (delab ist tm'))

893940process h fn Execute

894− = do (m, _) <- elabVal toplevel False

941+ = do ist <- getIState

942+ (m, _) <- elabVal toplevel False

895943 (PApp fc

896944 (PRef fc (sUN "run__IO"))

897945 [pexp $ PRef fc (sNS (sUN "main") ["Main"])])

898−-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

899946 (tmpn, tmph) <- runIO tempfile

900947 runIO $ hClose tmph

901948 t <- codegen

902949 compile t tmpn m

903− runIO $ system tmpn

904− return ()

950+ case idris_outputmode ist of

951+ RawOutput -> do runIO $ system tmpn

952+ return ()

953+ IdeSlave n -> do runIO . hPutStrLn h $ IdeSlave.convSExp "run-program" tmpn n

905954 where fc = fileFC "main"

906955process h fn (Compile codegen f)

907956 = do (m, _) <- elabVal toplevel False

@@ -992,28 +1041,30 @@ process h fn (Apropos a) =

9921041 isUN (NS n _) = isUN n

9931042 isUN _ = False

9941043

995−classInfo :: ClassInfo -> Idris ()

996−classInfo ci = do iputStrLn "Methods:\n"

997− mapM_ dumpMethod (class_methods ci)

998− iputStrLn ""

999− iputStrLn "Default superclass instances:\n"

1000− mapM_ dumpDefaultInstance (class_default_superclasses ci)

1001− iputStrLn ""

1002− iputStrLn "Instances:\n"

1003− mapM_ dumpInstance (class_instances ci)

1004− iPrintResult ""

1005−

1006−dumpMethod :: (Name, (FnOpts, PTerm)) -> Idris ()

1007−dumpMethod (n, (_, t)) = iputStrLn $ show n ++ " : " ++ show t

1008−

1009−dumpDefaultInstance :: PDecl -> Idris ()

1010−dumpDefaultInstance (PInstance _ _ _ _ _ t _ _) = iputStrLn $ show t

1011−

1012−dumpInstance :: Name -> Idris ()

1013−dumpInstance n = do i <- getIState

1014− ctxt <- getContext

1015− case lookupTy n ctxt of

1016− ts -> mapM_ (\t -> iputStrLn $ showTm i (delab i t)) ts

1044+classInfo :: ClassInfo -> Idris (Doc OutputAnnotation)

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

1052+ indent 2 (vsep (map (dumpMethod ist) (class_methods ci))) <> line <> line <>

1053+ text "Default superclass instances:" <>

1054+ line <>

1055+ indent 2 (vsep (map (dumpDefaultInstance ist) (class_default_superclasses ci))) <>

1056+ line <>

1057+ text "Instances:" <> line <>

1058+ indent 2 (vsep (map (dumpInstance ist ctxt) (class_instances ci)))

1059+ where dumpMethod :: IState -> (Name, (FnOpts, PTerm)) -> Doc OutputAnnotation

1060+ dumpMethod ist (n, (_, t)) = prettyName False [] n <+> colon <+> pp ist t

1061+ dumpDefaultInstance :: IState -> PDecl -> Doc OutputAnnotation

1062+ dumpDefaultInstance ist (PInstance _ _ _ _ _ t _ _) = pp ist t

1063+ dumpInstance :: IState -> Context -> Name -> Doc OutputAnnotation

1064+ dumpInstance ist ctxt n = pp ist $ delabTy ist n

1065+ params = class_params ci

1066+ params' = zip params (repeat False)

1067+ pp ist = pprintPTerm (opt_showimp (idris_options ist)) params' []

10171068

10181069showTotal :: Totality -> IState -> String

10191070showTotal t@(Partial (Other ns)) i

@@ -1059,6 +1110,7 @@ parseArgs ("--typeintype":ns) = TypeInType : (parseArgs ns)

10591110parseArgs ("--total":ns) = DefaultTotal : (parseArgs ns)

10601111parseArgs ("--partial":ns) = DefaultPartial : (parseArgs ns)

10611112parseArgs ("--warnpartial":ns) = WarnPartial : (parseArgs ns)

1113+parseArgs ("--warnreach":ns) = WarnReach : (parseArgs ns)

10621114parseArgs ("--nocoverage":ns) = NoCoverage : (parseArgs ns)

10631115parseArgs ("--errorcontext":ns) = ErrContext : (parseArgs ns)

10641116parseArgs ("--help":ns) = Usage : (parseArgs ns)

@@ -1146,30 +1198,32 @@ loadInputs h inputs

11461198 let ninputs = zip [1..] inputs

11471199 ifiles <- mapWhileOK (\(num, input) ->

11481200 do putIState ist

1149− v <- verbose

1150− -- when v $ iputStrLn $ "(" ++ show num ++ "/" ++

1151− -- show (length inputs) ++

1152− -- ") " ++ input

11531201 modTree <- buildTree

11541202 (map snd (take (num-1) ninputs))

11551203 input

11561204 let ifiles = getModuleFiles modTree

11571205 iLOG ("MODULE TREE : " ++ show modTree)

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

11601209 -- return the files that need rechecking

1161− return (if (all ibc ifiles) then ifiles else []))

1210+ return ifiles)

11621211 ninputs

11631212 inew <- getIState

1164− -- to check everything worked consistently (in particular, will catch

1165− -- if the ibc version is out of date) if we weren't loading per

1166− -- module

1213+ let tidata = idris_tyinfodata inew

1214+ let lineapps = idris_lineapps inew

1215+ let patdefs = idris_patdefs inew

1216+ -- If it worked, load the whole thing from all the ibcs together

11671217 case errSpan inew of

11681218 Nothing ->

1169− do putIState ist

1170− when (not loadCode) $ tryLoad $ nub (concat ifiles)

1219+ do putIState (ist { idris_tyinfodata = tidata })

1220+ ibcfiles <- mapM findNewIBC (nub (concat ifiles))

1221+ tryLoad True (mapMaybe id ibcfiles)

11711222 _ -> return ()

1172− putIState inew)

1223+ ist <- getIState

1224+ putIState (ist { idris_tyinfodata = tidata,

1225+ idris_lineapps = lineapps,

1226+ idris_patdefs = patdefs }))

11731227 (\e -> do i <- getIState

11741228 case e of

11751229 At f _ -> do setErrSpan f

@@ -1178,15 +1232,43 @@ loadInputs h inputs

11781232 _ -> do setErrSpan emptyFC -- FIXME! Propagate it

11791233 iputStrLn (pshow i e))

11801234 where -- load all files, stop if any fail

1181− tryLoad :: [IFileType] -> Idris ()

1182− tryLoad [] = return ()

1183− tryLoad (f : fs) = do loadFromIFile h f

1184− ok <- noErrors

1185− when ok $ tryLoad fs

1235+ tryLoad :: Bool -> [IFileType] -> Idris ()

1236+ tryLoad keepstate [] = return ()

1237+ tryLoad keepstate (f : fs)

1238+ = do ist <- getIState

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

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

1252+ tryLoad keepstate fs

11861253

11871254 ibc (IBC _ _) = True

11881255 ibc _ = False

11891256

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+

11901272 -- Like mapM, but give up when there's an error

11911273 mapWhileOK f [] = return []

11921274 mapWhileOK f (x : xs) = do x' <- f x

@@ -1271,9 +1353,13 @@ idrisMain opts =

12711353

12721354 ok <- noErrors

12731355 when ok $ case output of

1274− [] -> return ()

1356+ -- just do the checks

1357+ [] -> performUsageAnalysis >> return ()

1358+

1359+ -- the compiler will run usage analysis itself

12751360 (o:_) -> idrisCatch (process stdout "" (Compile cgn o))

12761361 (\e -> do ist <- getIState ; iputStrLn $ pshow ist e)

1362+

12771363 case script of

12781364 Nothing -> return ()

12791365 Just expr -> execScript expr

@@ -1318,11 +1404,6 @@ execScript expr = do i <- getIState

13181404 res <- execute tm

13191405 runIO $ exitWith ExitSuccess

13201406

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−

13261407-- | Get the platform-specific, user-specific Idris dir

13271408getIdrisUserDataDir :: Idris FilePath

13281409getIdrisUserDataDir = 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)

1717import Idris.Core.TT

1818import Idris.REPL

1919import Idris.AbsSyntax

20+import Idris.Output

2021

2122import IRTS.System

2223

src/Util/LLVMStubs.hs+2−9

@@ -20,12 +20,5 @@ getHostCPUName :: IO String

2020getHostCPUName = return ""

2121

2222

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

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

23+codegenLLVM :: CodeGenerator

24+codegenLLVM _ = fail "This Idris was compiled without the LLVM backend."

test/basic001/reg005.idr+15−16

@@ -1,17 +1,22 @@

11module Main

22

3+%flag C "-g3 -ggdb -O0"

4+

35rep : (n : Nat) -> Char -> Vect n Char

46rep Z x = []

57rep (S k) x = x :: rep k x

68

79data RLE : Vect n Char -> Type where

810 REnd : RLE []

9− RChar : {xs : Vect k Char} ->

10− (n : Nat) -> (x : Char) -> RLE xs ->

11− RLE (rep (S n) x ++ xs)

11+ RChar : .{k : Nat}

12+ -> {xs : Vect k Char}

13+ -> (n : Nat)

14+ -> (x : Char)

15+ -> RLE xs

16+ -> RLE (rep (S n) x ++ xs)

1217

1318eq : (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

1520

1621------------

1722

@@ -32,20 +37,14 @@ compress xs with (rle xs)

3237 = let ni : Integer = cast (S n) in

3338 show ni ++ strCons x (compress xs)

3439

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+

3546compressString : String -> String

3647compressString xs = compress (fromList (unpack xs))

3748

3849main : IO ()

3950main = 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 @@

11module Main

22

33data Parity : Nat -> Type where

4− even : Parity (n + n)

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

4+ even : {n : Nat} -> Parity (n + n)

5+ odd : {n : Nat} -> Parity (S (n + n))

66

77parity : (n:Nat) -> Parity n

88parity Z = even {n=Z}

test/basic007/test033.idr+1−1

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

11module Main

22

33main : 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

66

77%language ErrorReflection

88

9−

109total

1110cadr : (xs : List a)

1211 -> {auto cons1 : isCons xs = True}

@@ -14,6 +13,7 @@ cadr : (xs : List a)

1413 -> a

1514cadr (x :: (y :: _)) {cons1=refl} {cons2=refl} = y

1615cadr (x :: []) {cons1=refl} {cons2=refl} impossible

16+cadr [] {cons1=refl} {cons2=refl} impossible

1717

1818extractList : TT -> Maybe TT

1919extractList (App (App reflCon (App isCons lst)) _) = Just lst

test/proof003/Parity.idr+2−2

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

11module Parity

22

33data Parity : Nat -> Type where

4− even : Parity (n + n)

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

4+ even : {n : Nat} -> Parity (n + n)

5+ odd : {n : Nat} -> Parity (S (n + n))

66

77parity : (n:Nat) -> Parity n

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

99data Board : Nat -> Type where

1010 MkBoard : {n : Nat} -> Vect n (Vect n (Cell n)) -> Board n

1111

12−emptyBoard : Board n

12+emptyBoard : {n : Nat} -> Board n

1313emptyBoard {n=n} = MkBoard (replicate n (replicate n Nothing))

1414

1515Empty : 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