3c32b65 · Idris-dev · git.iko.soy

contribs/lib/SQLite3/testunit.idr+32−32

compare with master

unifiedsplit

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

1module Main

2import Sqlite3

3

4−

4+

5testexpr : DB()

6testexpr = do db <- open_db "somedb.db"

7 let sql = (evalSQL [] ((SELECT ALL)(TBL ["tbl1"]) (OR (AND (MkCond (Equals (VCol "data")(VStr "data0"))) (MkCond (Equals (VCol "num")(VInt 1))) ) (MkCond (Equals (VCol "num")(VInt 2))))))

8− let x = (fst sql) -- get the string

8+ let x = (fst sql) -- get the string

9 let list = (snd sql) -- list of vals

10 liftIO(print x) -- use liftIO to turn this into DB type

11 stmt <- (prepare_db db x) -- prepare the statement

12 bindMulti stmt list -- bind the values in the list

13 exec_db_v2 stmt -- execute the prepared query

14 res <- toList_v1 db -- toList_v1 to get the result

15− liftIO(print res) -- print the result

15+ liftIO(print res) -- print the result

16 finalize_db stmt -- Statment pointer must be finalized in the end

17 close_db db -- close the datbase

18 return ()

@@ -24,8 +24,8 @@ testupdate = do db <- open_db "somedb.db"

24 let list = (snd sql)

25 liftIO(print x)

26 stmt <- (prepare_db db x)

27− bindMulti stmt list

27+ bindMulti stmt list

28− exec_db_v2 stmt

28+ exec_db_v2 stmt

29 finalize_db stmt

30 close_db db

31 return ()

@@ -37,12 +37,12 @@ testInsert = do db <- open_db "somedb.db"

37 let list = (snd sql)

38 liftIO(print x)

39 stmt <- (prepare_db db x)

40− bindMulti stmt list

40+ bindMulti stmt list

41− exec_db_v2 stmt

41+ exec_db_v2 stmt

42 finalize_db stmt

43 close_db db

44− return ()

44+ return ()

45−

45+

46testNull : DB()

47testNull = do db <- open_db "somedb.db"

48 let sql = (evalSQL [] ((SELECT ALL)(TBL ["tbl1"]) (MkCond (MkNULL (VCol "data")))))

@@ -50,15 +50,15 @@ testNull = do db <- open_db "somedb.db"

50 let list = (snd sql)

51 liftIO(print x)

52 stmt <- (prepare_db db x)

53− bindMulti stmt list

53+ bindMulti stmt list

54 exec_db_v2 stmt

55 res <- toList_v1 db

56− liftIO(print res)

56+ liftIO(print res)

57 finalize_db stmt

58 close_db db

59− return ()

59+ return ()

60+

60

61

61−

62testInsertWithCond : DB()

63testInsertWithCond = do db <- open_db "somedb.db"

64 let sql = (evalSQL [] (INSERTC (TBL ["tbl1"]) [(VCol "data"),(VCol "num")] [(VInt 30),(VStr "inserthere")]))

@@ -66,12 +66,12 @@ testInsertWithCond = do db <- open_db "somedb.db"

66 let list = (snd sql)

67 liftIO(print x)

68 stmt <- (prepare_db db x)

69− bindMulti stmt list

69+ bindMulti stmt list

70− exec_db_v2 stmt

70+ exec_db_v2 stmt

71 finalize_db stmt

72 close_db db

73− return ()

73+ return ()

74−

74+

75-- Nested queries need to have the same column as the outer queries.

76testNestedSel1 : DB()

77testNestedSel1 = do db <- open_db "somedb.db"

@@ -80,13 +80,13 @@ testNestedSel1 = do db <- open_db "somedb.db"

80 let list = (snd sql)

81 liftIO(print x)

82 stmt <- (prepare_db db x)

83− bindMulti stmt list

83+ bindMulti stmt list

84− exec_db_v2 stmt

84+ exec_db_v2 stmt

85 res <- toList_v1 db

86− liftIO(print res)

86+ liftIO(print res)

87 finalize_db stmt

88 close_db db

89− return ()

89+ return ()

90

91-- Testing Create Table

92testCreateTable : DB ()

@@ -96,11 +96,11 @@ testCreateTable = do db <- open_db "somedb.db"

96 let list = (snd sql)

97 liftIO(print x)

98 stmt <- (prepare_db db x)

99− bindMulti stmt list

99+ bindMulti stmt list

100− exec_db_v2 stmt

100+ exec_db_v2 stmt

101 finalize_db stmt

102 close_db db

103− return ()

103+ return ()

104

105-- This may be a bit slow

106testMultiTable : DB ()

@@ -110,14 +110,14 @@ testMultiTable = do db <- open_db "somedb.db"

110 let list = (snd sql)

111 liftIO(print x)

112 stmt <- (prepare_db db x)

113− bindMulti stmt list

113+ bindMulti stmt list

114− exec_db_v2 stmt

114+ exec_db_v2 stmt

115 res <- toList_v1 db

116− liftIO(print res)

116+ liftIO(print res)

117 finalize_db stmt

118 close_db db

119 return ()

120−

120+

121testSelAll : DB ()

122testSelAll = do db <- open_db "somedb.db"

123 let sql = (evalSQL [] ((SELECT ALL )(TBL ["tbl1"]) (Empty) ) )

@@ -125,15 +125,15 @@ testSelAll = do db <- open_db "somedb.db"

125 let list = (snd sql)

126 liftIO(print x)

127 stmt <- (prepare_db db x)

128− bindMulti stmt list

128+ bindMulti stmt list

129− exec_db_v2 stmt

129+ exec_db_v2 stmt

130 res <- toList_v1 db

131− liftIO(print res)

131+ liftIO(print res)

132 finalize_db stmt

133 close_db db

134 return ()

135

136−

136+

137main : IO ()

138main = do x <- runDB (testMultiTable) -- runDB : DB a -> IO a

139 --y <- runDB (testNestedSel1)

effects/Effect/Exception.idr+2−2

@@ -5,7 +5,7 @@ import System

5import Control.IOExcept

6

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

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

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

9

10instance Handler (Exception a) Maybe where

11 handle _ (Raise e) k = Nothing

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

21 handle _ (Raise e) k = Left e

22

23EXCEPTION : Type -> EFFECT

24−EXCEPTION t = MkEff () (Exception t)

24+EXCEPTION t = MkEff () (Exception t)

25

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

27raise err = Raise err

effects/Effect/File.idr+5−5

@@ -9,11 +9,11 @@ data OpenFile : Mode -> Type where

9data FileIO : Effect where

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

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

12−

12+

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

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

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

16−

16+

17

18instance Handler FileIO IO where

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

@@ -30,7 +30,7 @@ instance Handler FileIO IO where

30 k (FH h) e

31

32instance Handler FileIO (IOExcept String) where

33− handle () (Open fname m) k

33+ handle () (Open fname m) k

34 = do h <- ioe_lift (openFile fname m)

35 valid <- ioe_lift (validFile h)

36 if valid then k (Right (FH h)) True

@@ -44,10 +44,10 @@ instance Handler FileIO (IOExcept String) where

44 k (FH h) e

45

46FILE_IO : Type -> EFFECT

47−FILE_IO t = MkEff t FileIO

47+FILE_IO t = MkEff t FileIO

48

49open : Handler FileIO e =>

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

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

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

52open f m = Open f m

53

effects/Effect/Select.idr+1−1

@@ -14,7 +14,7 @@ instance Handler Selection Maybe where

14

15instance Handler Selection List where

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

17−

17+

18SELECT : EFFECT

19SELECT = MkEff () Selection

20

effects/Effect/State.idr+2−2

@@ -17,7 +17,7 @@ STATE : Type -> EFFECT

17STATE t = MkEff t State

18

19get : Eff m [STATE x] x

20−get = Get

20+get = Get

21

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

23put val = Put val

@@ -26,7 +26,7 @@ putM : y -> EffM m [STATE x] [STATE y] ()

26putM val = Put val

27

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

29−update f = put (f !get)

29+update f = put (f !get)

30

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

32updateM f = putM (f !get)

effects/Effect/StdIO.idr+7−7

@@ -9,16 +9,16 @@ data StdIO : Effect where

9

10instance Handler StdIO IO where

11 handle () (PutStr s) k = do putStr s; k () ()

12− handle () GetStr k = do x <- getLine; k () x

12+ handle () GetStr k = do x <- getLine; k () x

13

14instance Handler StdIO (IOExcept a) where

15 handle () (PutStr s) k = do ioe_lift (putStr s); k () ()

16− handle () GetStr k = do x <- ioe_lift getLine; k () x

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

17

18-- Handle effects in a pure way, for simulating IO for unit testing/proof

19

20data IOStream a = MkStream (List String -> (a, List String))

21−

21+

22instance Handler StdIO IOStream where

23 handle () (PutStr s) k

24 = MkStream (\x => case k () () of

@@ -31,7 +31,7 @@ instance Handler StdIO IOStream where

31 where

32 cont : String -> List String -> (a, List String)

33 cont t ts = case k () t of

34− MkStream f => f ts

34+ MkStream f => f ts

35

36--- The Effect and associated functions

37

@@ -47,8 +47,8 @@ putStrLn s = putStr (s ++ "\n")

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

48getStr = GetStr

49

50−mkStrFn : Env IOStream xs ->

50+mkStrFn : Env IOStream xs ->

51− Eff IOStream xs a ->

51+ Eff IOStream xs a ->

52 List String -> (a, List String)

53mkStrFn {a} env p input = case mkStrFn' of

54 MkStream f => f input

@@ -57,4 +57,4 @@ mkStrFn {a} env p input = case mkStrFn' of

57 mkStrFn' : IOStream a

58 mkStrFn' = runWith injStream env p

59

60−

60+

effects/Effects.idr+30−30

@@ -52,36 +52,36 @@ updateWith (y :: ys) [] SubNil = y :: ys

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

53

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

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

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

56− Env m xs -> Env m (updateWith ys' xs prf)

56+ Env m xs -> Env m (updateWith ys' xs prf)

57rebuildEnv [] SubNil env = env

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

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

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

60+rebuildEnv (x :: xs) SubNil [] = x :: xs

61

62---- The Effect EDSL itself ----

63

64-- some proof automation

65findEffElem : Nat -> List (TTName, Binder TT) -> TT -> Tactic -- Nat is maximum search depth

66findEffElem Z ctxt goal = Refine "Here" `Seq` Solve

67−findEffElem (S n) ctxt goal = GoalType "EffElem"

67+findEffElem (S n) ctxt goal = GoalType "EffElem"

68 (Try (Refine "Here" `Seq` Solve)

69 (Refine "There" `Seq` (Solve `Seq` findEffElem n ctxt goal)))

70

71findSubList : Nat -> List (TTName, Binder TT) -> TT -> Tactic

72findSubList Z ctxt goal = Refine "SubNil" `Seq` Solve

73findSubList (S n) ctxt goal

74− = GoalType "SubList"

74+ = GoalType "SubList"

75 (Try (Refine "subListId" `Seq` Solve)

76 ((Try (Refine "Keep" `Seq` Solve)

77 (Refine "Drop" `Seq` Solve)) `Seq` findSubList n ctxt goal))

78

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

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

80 List EFFECT

81updateResTy {b} (MkEff a e :: xs) Here n = (MkEff b e) :: xs

82updateResTy (x :: xs) (There p) n = x :: updateResTy xs p n

83

84−updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->

84+updateResTyImm : (xs : List EFFECT) -> EffElem e a xs -> Type ->

85 List EFFECT

86updateResTyImm (MkEff a e :: xs) Here b = (MkEff b e) :: xs

87updateResTyImm (x :: xs) (There p) b = x :: updateResTyImm xs p b

@@ -91,7 +91,7 @@ infix 5 :::, :-, :=

91data LRes : lbl -> Type -> Type where

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

93

94−(:::) : lbl -> EFFECT -> EFFECT

94+(:::) : lbl -> EFFECT -> EFFECT

95(:::) {lbl} x (MkEff r eff) = MkEff (LRes x r) eff

96

97private

@@ -108,8 +108,8 @@ data EffM : (m : Type -> Type) ->

108 List EFFECT -> List EFFECT -> Type -> Type where

109 value : a -> EffM m xs xs a

110 ebind : EffM m xs xs' a -> (a -> EffM m xs' xs'' b) -> EffM m xs xs'' b

111− effect : (prf : EffElem e a xs) ->

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

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

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

113 EffM m xs (updateResTy xs prf eff) t

114 lift : (prf : SubList ys xs) ->

115 EffM m ys ys' t -> EffM m xs (updateWith ys' xs prf) t

@@ -142,9 +142,9 @@ lift' {prf} e = lift prf e

142

143implicit

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

145− {default tactics { applyTactic findEffElem 20; solve; }

145+ {default tactics { applyTactic findEffElem 20; solve; }

146− prf : EffElem e a xs} ->

146+ prf : EffElem e a xs} ->

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

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

148 EffM m xs (updateResTy xs prf eff) t

149effect' {prf} e = effect prf e

150

@@ -152,13 +152,13 @@ effect' {prf} e = effect prf e

152

153syntax if_valid then [e] else [t] =

154 test (tactics { applyTactic findEffElem 20; solve; }) t e

155−

155+

156syntax if_valid [lbl] then [e] else [t] =

157 test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e

158−

158+

159syntax if_error then [t] else [e] =

160 test (tactics { applyTactic findEffElem 20; solve; }) t e

161−

161+

162syntax if_error [lbl] then [t] else [e] =

163 test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e

164

@@ -166,16 +166,16 @@ syntax if_error [lbl] then [t] else [e] =

166

167syntax if_right then [e] else [t] =

168 test (tactics { applyTactic findEffElem 20; solve; }) t e

169−

169+

170syntax if_right [lbl] then [e] else [t] =

171 test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e

172−

172+

173syntax if_left then [t] else [e] =

174 test (tactics { applyTactic findEffElem 20; solve; }) t e

175−

175+

176syntax if_left [lbl] then [t] else [e] =

177 test_lbl {x=lbl} (tactics { applyTactic findEffElem 20; solve; }) t e

178−

178+

179

180-- for 'do' notation

181

@@ -200,12 +200,12 @@ pure = value

200-- an interpreter

201

202private

203−execEff : Env m xs -> (p : EffElem e res xs) ->

203+execEff : Env m xs -> (p : EffElem e res xs) ->

204 (eff : e res b a) ->

205 (Env m (updateResTy xs p eff) -> a -> m t) -> m t

206−execEff (val :: env) Here eff' k

206+execEff (val :: env) Here eff' k

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

208−execEff (val :: env) (There p) eff k

208+execEff (val :: env) (There p) eff k

209 = execEff env p eff (\env', v => k (val :: env') v)

210

211private

@@ -217,7 +217,7 @@ testEff (Left err :: env) Here lk rk = lk (err :: env)

217testEff (Right ok :: env) Here lk rk = rk (ok :: env)

218testEff (val :: env) (There p) lk rk

219 = testEff env p (\envk => lk (val :: envk))

220− (\envk => rk (val :: envk))

220+ (\envk => rk (val :: envk))

221

222private

223testEffLbl : {x : lbl} ->

@@ -229,21 +229,21 @@ testEffLbl ((lbl := Left err) :: env) Here lk rk = lk ((lbl := err) :: env)

229testEffLbl ((lbl := Right ok) :: env) Here lk rk = rk ((lbl := ok) :: env)

230testEffLbl (val :: env) (There p) lk rk

231 = testEffLbl env p (\envk => lk (val :: envk))

232− (\envk => rk (val :: envk))

232+ (\envk => rk (val :: envk))

233

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

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

236

237eff : Env m xs -> EffM m xs xs' a -> (Env m xs' -> a -> m b) -> m b

238eff env (value x) k = k env x

239−eff env (prog `ebind` c) k

239+eff env (prog `ebind` c) k

240 = eff env prog (\env', p' => eff env' (c p') k)

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

242−eff env (lift prf effP) k

242+eff env (lift prf effP) k

243− = let env' = dropEnv env prf in

243+ = let env' = dropEnv env prf in

244 eff env' effP (\envk, p' => k (rebuildEnv envk prf env) p')

245eff env (new r prog) k

246− = let env' = r :: env in

246+ = let env' = r :: env in

247 eff env' prog (\(v :: envk), p' => k envk p')

248eff env (test prf l r) k

249 = testEff env prf (\envk => eff envk l k) (\envk => eff envk r k)

@@ -281,7 +281,7 @@ Eff m xs t = EffM m xs xs t

281-- some higher order things

282

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

284−mapE f [] = pure []

284+mapE f [] = pure []

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

286

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

lib/Builtins.idr+15−15

@@ -39,7 +39,7 @@ believe_me : a -> b -- compiled specially as id, use with care!

39believe_me x = prim__believe_me _ _ x

40

41public %assert_total -- reduces at compile time, use with extreme care!

42−really_believe_me : a -> b

42+really_believe_me : a -> b

43really_believe_me x = prim__believe_me _ _ x

44

45namespace Builtins {

@@ -84,7 +84,7 @@ data Dec : Type -> Type where

84

85data Bool = False | True

86

87−boolElim : Bool -> |(t : a) -> |(f : a) -> a

87+boolElim : Bool -> |(t : a) -> |(f : a) -> a

88boolElim True t e = t

89boolElim False t e = e

90

@@ -120,7 +120,7 @@ intToBool 0 = False

120intToBool x = True

121

122boolOp : (a -> a -> Int) -> a -> a -> Bool

123−boolOp op x y = intToBool (op x y)

123+boolOp op x y = intToBool (op x y)

124

125class Eq a where

126 (==) : a -> a -> Bool

@@ -129,7 +129,7 @@ class Eq a where

129 x /= y = not (x == y)

130 x == y = not (x /= y)

131

132−instance Eq Int where

132+instance Eq Int where

133 (==) = boolOp prim__eqInt

134

135instance Eq Integer where

@@ -162,11 +162,11 @@ instance Eq Ordering where

162 GT == GT = True

163 _ == _ = False

164

165−class Eq a => Ord a where

165+class Eq a => Ord a where

166 compare : a -> a -> Ordering

167

168 (<) : a -> a -> Bool

169− (<) x y with (compare x y)

169+ (<) x y with (compare x y)

170 (<) x y | LT = True

171 (<) x y | _ = False

172

@@ -188,31 +188,31 @@ class Eq a => Ord a where

188 min x y = if (x < y) then x else y

189

190

191−instance Ord Int where

191+instance Ord Int where

192 compare x y = if (x == y) then EQ else

193 if (boolOp prim__sltInt x y) then LT else

194 GT

195

196

197−instance Ord Integer where

197+instance Ord Integer where

198 compare x y = if (x == y) then EQ else

199 if (boolOp prim__sltBigInt x y) then LT else

200 GT

201

202

203−instance Ord Float where

203+instance Ord Float where

204 compare x y = if (x == y) then EQ else

205 if (boolOp prim__sltFloat x y) then LT else

206 GT

207

208

209−instance Ord Char where

209+instance Ord Char where

210 compare x y = if (x == y) then EQ else

211 if (boolOp prim__sltChar x y) then LT else

212 GT

213

214

215−instance Ord String where

215+instance Ord String where

216 compare x y = if (x == y) then EQ else

217 if (boolOp prim__ltString x y) then LT else

218 GT

@@ -225,7 +225,7 @@ instance (Ord a, Ord b) => Ord (a, b) where

225 else compare xr yr

226

227

228−class Num a where

228+class Num a where

229 (+) : a -> a -> a

230 (-) : a -> a -> a

231 (*) : a -> a -> a

@@ -233,7 +233,7 @@ class Num a where

233 abs : a -> a

234 fromInteger : Integer -> a

235

236−instance Num Integer where

236+instance Num Integer where

237 (+) = prim__addBigInt

238 (-) = prim__subBigInt

239 (*) = prim__mulBigInt

@@ -241,7 +241,7 @@ instance Num Integer where

241 abs x = if x < 0 then -x else x

242 fromInteger = id

243

244−instance Num Int where

244+instance Num Int where

245 (+) = prim__addInt

246 (-) = prim__subInt

247 (*) = prim__mulInt

@@ -250,7 +250,7 @@ instance Num Int where

250 abs x = if x < (prim__truncBigInt_Int 0) then -x else x

251

252

253−instance Num Float where

253+instance Num Float where

254 (+) = prim__addFloat

255 (-) = prim__subFloat

256 (*) = prim__mulFloat

lib/Control/Monad/Identity.idr+2−2

@@ -2,7 +2,7 @@ module Control.Monad.Identity

2

3import Prelude.Functor

4import Prelude.Applicative

5−import Prelude.Monad

5+import Prelude.Monad

6

7public record Identity : Type -> Type where

8 Id : (runIdentity : a) -> Identity a

@@ -12,7 +12,7 @@ instance Functor Identity where

12

13instance Applicative Identity where

14 pure x = Id x

15−

15+

16 (Id f) <$> (Id g) = Id (f g)

17

18instance Monad Identity where

lib/Control/Monad/State.idr+1−1

@@ -33,7 +33,7 @@ instance Monad m => Monad (StateT s m) where

33

34instance Monad m => MonadState s (StateT s m) where

35 get = ST (\x => return (x, x))

36− put x = ST (\y => return ((), x))

36+ put x = ST (\y => return ((), x))

37

38modify : MonadState s m => (s -> s) -> m ()

39modify f = do s <- get

lib/Data/Bits.idr+2−2

@@ -33,7 +33,7 @@ bitsUsed n = 8 * (2 `power` n)

33natToBits' : machineTy n -> Nat -> machineTy n

34natToBits' a Z = a

35natToBits' {n=n} a x with (n)

36− -- it seems I have to manually recover the value of n here, instead of being able to reference it

36+ -- it seems I have to manually recover the value of n here, instead of being able to reference it

37 natToBits' a (S x') | Z = natToBits' {n=0} (prim__addB8 a (prim__truncInt_B8 1)) x'

38 natToBits' a (S x') | S Z = natToBits' {n=1} (prim__addB16 a (prim__truncInt_B16 1)) x'

39 natToBits' a (S x') | S (S Z) = natToBits' {n=2} (prim__addB32 a (prim__truncInt_B32 1)) x'

@@ -114,7 +114,7 @@ shiftRightLogical' {n=n} x c with (n)

114

115public

116shiftRightLogical : Bits n -> Bits n -> Bits n

117−shiftRightLogical {n} (MkBits x) (MkBits y)

117+shiftRightLogical {n} (MkBits x) (MkBits y)

118 = MkBits {n} (shiftRightLogical' {n=nextBytes n} x y)

119

120shiftRightArithmetic' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

lib/Data/Morphisms.idr+1−1

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

1module Data.Morphisms

2

3−import Prelude

3+import Prelude

4

5%access public

6

lib/Debug/Trace.idr+1−1

@@ -4,6 +4,6 @@ import Prelude

4import IO

5

6trace : String -> a -> a

7−trace x val = unsafePerformIO (do putStrLn x; return val)

7+trace x val = unsafePerformIO (do putStrLn x; return val)

8

9

lib/Decidable/Equality.idr+4−4

@@ -109,9 +109,9 @@ lemma_both_neq p_x_not_x' p_y_not_y' refl = p_x_not_x' refl

109lemma_snd_neq : {x : a, y : b, y' : d} -> (x = x) -> (y = y' -> _|_) -> ((x, y) = (x, y') -> _|_)

110lemma_snd_neq refl p refl = p refl

111

112−lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} ->

112+lemma_fst_neq_snd_eq : {x : a, x' : b, y : c, y' : d} ->

113− (x = x' -> _|_) ->

113+ (x = x' -> _|_) ->

114− (y = y') ->

114+ (y = y') ->

115 ((x, y) = (x', y) -> _|_)

116lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl

117

@@ -133,7 +133,7 @@ lemma_val_not_nil : {x : t, xs : List t} -> ((x :: xs) = Prelude.List.Nil {a = t

133lemma_val_not_nil refl impossible

134

135lemma_x_eq_xs_neq : {x : t, xs : List t, y : t, ys : List t} -> (x = y) -> (xs = ys -> _|_) -> ((x :: xs) = (y :: ys) -> _|_)

136−lemma_x_eq_xs_neq refl p refl = p refl

136+lemma_x_eq_xs_neq refl p refl = p refl

137

138lemma_x_neq_xs_eq : {x : t, xs : List t, y : t, ys : List t} -> (x = y -> _|_) -> (xs = ys) -> ((x :: xs) = (y :: ys) -> _|_)

139lemma_x_neq_xs_eq p refl refl = p refl

lib/Decidable/Order.idr+1−1

@@ -45,7 +45,7 @@ instance Preorder Nat NatLTE where

45 transitive = NatLTEIsTransitive

46 reflexive = NatLTEIsReflexive

47

48−total NatLTEIsAntisymmetric : (m : Nat) -> (n : Nat) ->

48+total NatLTEIsAntisymmetric : (m : Nat) -> (n : Nat) ->

49 NatLTE m n -> NatLTE n m -> m = n

50NatLTEIsAntisymmetric n n nEqn nEqn = refl

51NatLTEIsAntisymmetric n m nEqn (nLTESm _) impossible

lib/IO.idr+7−7

@@ -97,34 +97,34 @@ ForeignTy (t::ts) rt = interpFTy t -> ForeignTy ts rt

97

98

99data Foreign : Type -> Type where

100− FFun : String -> (xs:List FTy) -> (t:FTy) ->

100+ FFun : String -> (xs:List FTy) -> (t:FTy) ->

101 Foreign (ForeignTy xs t)

102

103mkForeignPrim : Foreign x -> x

104mkLazyForeignPrim : Foreign x -> x

105-- mkForeign and mkLazyForeign compiled as primitives

106

107−abstract

107+abstract

108io_bind : IO a -> (a -> IO b) -> IO b

109io_bind (MkIO fn) k

110 = MkIO (\w => prim_io_bind (fn w)

111 (\ b => case k b of

112 MkIO fkb => fkb w))

113

114−abstract

114+abstract

115io_return : a -> IO a

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

117

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

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

119+liftPrimIO f = MkIO (\w => prim_io_bind (f w)

120 (\x => prim_io_return x))

121

122run__IO : IO () -> PrimIO ()

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

123+run__IO (MkIO f) = prim_io_bind (f TheWorld)

124 (\ b => prim_io_return b)

125

126run__provider : IO a -> PrimIO a

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

127+run__provider (MkIO f) = prim_io_bind (f TheWorld)

128 (\ b => prim_io_return b)

129

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

@@ -143,7 +143,7 @@ prim_fread : Ptr -> IO String

143prim_fread h = MkIO (\w => prim_io_return (prim__readString h))

144

145unsafePerformIO : IO a -> a

146−unsafePerformIO (MkIO f) = unsafePerformPrimIO

146+unsafePerformIO (MkIO f) = unsafePerformPrimIO

147 (prim_io_bind (f TheWorld) (\ b => prim_io_return b))

148

149

lib/Language/Reflection.idr+1−1

@@ -172,7 +172,7 @@ data Tactic = Try Tactic Tactic

172 | Reflect TT

173 -- ^ turn a value into its reflected representation

174 | Fill Raw

175− -- ^ turn a raw value back into a term

175+ -- ^ turn a raw value back into a term

176 | Exact TT

177 -- ^ use the given value to conclude the proof

178 | Focus TTName

lib/Network/Cgi.idr+9−9

@@ -33,7 +33,7 @@ instance Functor CGI where

33

34instance Applicative CGI where

35 pure v = MkCGI (\s => return (v, s))

36−

36+

37 (MkCGI a) <$> (MkCGI b) = MkCGI (\s => do (f, i) <- a s

38 (c, j) <- b i

39 return (f c, j))

@@ -50,9 +50,9 @@ getInfo : CGI CGIInfo

50getInfo = MkCGI (\s => return (s, s))

51

52abstract

53−lift : IO a -> CGI a

53+lift : IO a -> CGI a

54lift op = MkCGI (\st => do { x <- op

55− return (x, st) } )

55+ return (x, st) } )

56

57abstract

58output : String -> CGI ()

@@ -95,10 +95,10 @@ flushHeaders = do o <- getHeaders

95abstract

96flush : CGI ()

97flush = do o <- getOutput

98− lift (putStr o)

98+ lift (putStr o)

99

100getVars : List Char -> String -> List (String, String)

101−getVars seps query = mapMaybe readVar (split (\x => elem x seps) query)

101+getVars seps query = mapMaybe readVar (split (\x => elem x seps) query)

102 where

103 readVar : String -> Maybe (String, String)

104 readVar xs with (split (\x => x == '=') xs)

@@ -118,11 +118,11 @@ getContent x = getC x "" where

118getCgiEnv : String -> IO String

119getCgiEnv key = do

120 val <- getEnv key

121− return $ maybe "" id val

121+ return $ maybe "" id val

122

123abstract

124runCGI : CGI a -> IO a

125−runCGI prog = do

125+runCGI prog = do

126 clen_in <- getCgiEnv "CONTENT_LENGTH"

127 let clen = prim__fromStrInt clen_in

128 content <- getContent clen

@@ -134,8 +134,8 @@ runCGI prog = do

134 let post_vars = getVars ['&'] content

135 let cookies = getVars [';'] cookie

136

137− (v, st) <- getAction prog (CGISt get_vars post_vars cookies agent

137+ (v, st) <- getAction prog (CGISt get_vars post_vars cookies agent

138− "Content-type: text/html\n"

138+ "Content-type: text/html\n"

139 "")

140 putStrLn (Headers st)

141 putStr (Output st)

lib/Prelude.idr+36−36

@@ -23,28 +23,28 @@ import Prelude.Bits

23

24-- Show and instances

25

26−class Show a where

26+class Show a where

27 partial show : a -> String

28

29−instance Show Int where

29+instance Show Int where

30 show = prim__toStrInt

31

32−instance Show Integer where

32+instance Show Integer where

33 show = prim__toStrBigInt

34

35−instance Show Float where

35+instance Show Float where

36 show = prim__floatToStr

37

38−instance Show Char where

38+instance Show Char where

39− show x = strCons x ""

39+ show x = strCons x ""

40

41−instance Show String where

41+instance Show String where

42 show = id

43

44−instance Show Nat where

44+instance Show Nat where

45 show n = show (the Integer (cast n))

46

47−instance Show Bool where

47+instance Show Bool where

48 show True = "True"

49 show False = "False"

50

@@ -163,23 +163,23 @@ instance Show Bits64x2 where

163 ++ ", " ++ prim__toStrB64 b

164 ++ ">"

165

166−instance (Show a, Show b) => Show (a, b) where

166+instance (Show a, Show b) => Show (a, b) where

167 show (x, y) = "(" ++ show x ++ ", " ++ show y ++ ")"

168

169−instance Show a => Show (List a) where

169+instance Show a => Show (List a) where

170− show xs = "[" ++ show' "" xs ++ "]" where

170+ show xs = "[" ++ show' "" xs ++ "]" where

171 show' acc [] = acc

172 show' acc [x] = acc ++ show x

173 show' acc (x :: xs) = show' (acc ++ show x ++ ", ") xs

174

175−instance Show a => Show (Vect n a) where

175+instance Show a => Show (Vect n a) where

176− show xs = "[" ++ show' xs ++ "]" where

176+ show xs = "[" ++ show' xs ++ "]" where

177 show' : Vect n a -> String

178 show' [] = ""

179 show' [x] = show x

180 show' (x :: xs) = show x ++ ", " ++ show' xs

181

182−instance Show a => Show (Maybe a) where

182+instance Show a => Show (Maybe a) where

183 show Nothing = "Nothing"

184 show (Just x) = "Just " ++ show x

185

@@ -191,7 +191,7 @@ instance Functor PrimIO where

191instance Functor IO where

192 map f io = io_bind io (\b => io_return (f b))

193

194−instance Functor Maybe where

194+instance Functor Maybe where

195 map f (Just x) = Just (f x)

196 map f Nothing = Nothing

197

@@ -203,7 +203,7 @@ instance Functor (Either e) where

203

204instance Applicative PrimIO where

205 pure = prim_io_return

206−

206+

207 am <$> bm = prim_io_bind am (\f => prim_io_bind bm (prim_io_return . f))

208

209instance Applicative IO where

@@ -245,18 +245,18 @@ instance Alternative Maybe where

245

246instance Alternative List where

247 empty = []

248−

248+

249 (<|>) = (++)

250

251---- Monad instances

252

253−instance Monad PrimIO where

253+instance Monad PrimIO where

254 b >>= k = prim_io_bind b k

255

256instance Monad IO where

257 b >>= k = io_bind b k

258

259−instance Monad Maybe where

259+instance Monad Maybe where

260 Nothing >>= k = Nothing

261 (Just x) >>= k = k x

262

@@ -264,7 +264,7 @@ instance Monad (Either e) where

264 (Left n) >>= _ = Left n

265 (Right r) >>= f = f r

266

267−instance Monad List where

267+instance Monad List where

268 m >>= f = concatMap f m

269

270instance Monad (Vect n) where

@@ -347,19 +347,19 @@ partial abstract

347count : (Ord a, Num a) => a -> a -> a -> List a

348count a inc b = if a <= b then a :: count (a + inc) inc b

349 else []

350−

350+

351partial abstract

352countFrom : (Ord a, Num a) => a -> a -> List a

353countFrom a inc = a :: lazy (countFrom (a + inc) inc)

354−

355−syntax "[" [start] ".." [end] "]"

356− = count start 1 end

357−syntax "[" [start] "," [next] ".." [end] "]"

358− = count start (next - start) end

359

354

360−syntax "[" [start] "..]"

355+syntax "[" [start] ".." [end] "]"

356+ = count start 1 end

357+syntax "[" [start] "," [next] ".." [end] "]"

358+ = count start (next - start) end

359+

360+syntax "[" [start] "..]"

361 = countFrom start 1

362−syntax "[" [start] "," [next] "..]"

362+syntax "[" [start] "," [next] "..]"

363 = countFrom start (next - start)

364

365---- More utilities

@@ -410,25 +410,25 @@ getChar = map cast $ mkForeign (FFun "getchar" [] FInt)

410

411---- some basic file handling

412

413−abstract

413+abstract

414data File = FHandle Ptr

415

416partial stdin : File

417stdin = FHandle prim__stdin

418

419do_fopen : String -> String -> IO Ptr

420−do_fopen f m

420+do_fopen f m

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

422

423fopen : String -> String -> IO File

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

425− return (FHandle h)

425+ return (FHandle h)

426

427data Mode = Read | Write | ReadWrite

428

429partial

430openFile : String -> Mode -> IO File

431−openFile f m = fopen f (modeStr m) where

431+openFile f m = fopen f (modeStr m) where

432 modeStr Read = "r"

433 modeStr Write = "w"

434 modeStr ReadWrite = "r+"

@@ -454,7 +454,7 @@ fread (FHandle h) = do_fread h

454

455partial

456do_fwrite : Ptr -> String -> IO ()

457−do_fwrite h s

457+do_fwrite h s

458 = mkForeign (FFun "fputStr" [FPtr, FString] FUnit) h s

459

460partial

@@ -498,7 +498,7 @@ while t b = do v <- t

498 if v then do b

499 while t b

500 else return ()

501−

501+

502partial -- no error checking!

503readFile : String -> IO String

504readFile fn = do h <- openFile fn Read

@@ -508,7 +508,7 @@ readFile fn = do h <- openFile fn Read

508 where

509 partial

510 readFile' : File -> String -> IO String

511− readFile' h contents =

511+ readFile' h contents =

512 do x <- feof h

513 if not x then do l <- fread h

514 readFile' h (contents ++ l)

lib/Prelude/Algebra.idr+2−2

@@ -248,8 +248,8 @@ class (VerifiedJoinSemilattice a, VerifiedMeetSemilattice a) => VerifiedLattice

248class (BoundedJoinSemilattice a, BoundedMeetSemilattice a) => BoundedLattice a where { }

249

250class (VerifiedBoundedJoinSemilattice a, VerifiedBoundedMeetSemilattice a, VerifiedLattice a) => VerifiedBoundedLattice a where { }

251−

251+

252−

252+

253-- XXX todo:

254-- Fields and vector spaces.

255-- Structures where "abs" make sense.

lib/Prelude/Applicative.idr+2−2

@@ -5,9 +5,9 @@ import Prelude.Functor

5

6---- Applicative functors/Idioms

7

8−infixl 2 <$>

8+infixl 2 <$>

9

10−class Functor f => Applicative (f : Type -> Type) where

10+class Functor f => Applicative (f : Type -> Type) where

11 pure : a -> f a

12 (<$>) : f (a -> b) -> f a -> f b

13

lib/Prelude/Chars.idr+3−3

@@ -9,7 +9,7 @@ isLower : Char -> Bool

9isLower x = x >= 'a' && x <= 'z'

10

11isAlpha : Char -> Bool

12−isAlpha x = isUpper x || isLower x

12+isAlpha x = isUpper x || isLower x

13

14isDigit : Char -> Bool

15isDigit x = (x >= '0' && x <= '9')

@@ -23,10 +23,10 @@ isSpace x = x == ' ' || x == '\t' || x == '\r' ||

23 x == '\xa0'

24

25isNL : Char -> Bool

26−isNL x = x == '\r' || x == '\n'

26+isNL x = x == '\r' || x == '\n'

27

28toUpper : Char -> Char

29−toUpper x = if (isLower x)

29+toUpper x = if (isLower x)

30 then (prim__intToChar (prim__charToInt x - 32))

31 else x

32

lib/Prelude/Complex.idr+1−1

@@ -8,7 +8,7 @@ module Prelude.Complex

8import Builtins

9import Prelude

10

11−------------------------------ Rectangular form

11+------------------------------ Rectangular form

12

13infix 6 :+

14data Complex a = (:+) a a

lib/Prelude/Either.idr+1−1

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

49

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

51partitionEithers l = (lefts l, rights l)

52−

52+

53fromEither : Either a a -> a

54fromEither (Left l) = l

55fromEither (Right r) = r

lib/Prelude/Fin.idr+3−3

@@ -58,10 +58,10 @@ integerToFin : Integer -> (n : Nat) -> Maybe (Fin n)

58integerToFin x = natToFin (cast x)

59

60data IsJust : Maybe a -> Type where

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

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

62

63−fromInteger : (x : Integer) ->

63+fromInteger : (x : Integer) ->

64− {default (ItIsJust _ _)

64+ {default (ItIsJust _ _)

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

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

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

lib/Prelude/Functor.idr+1−1

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

1module Prelude.Functor

2

3−class Functor (f : Type -> Type) where

3+class Functor (f : Type -> Type) where

4 map : (a -> b) -> f a -> f b

lib/Prelude/Heap.idr+1−1

@@ -127,7 +127,7 @@ instance Eq a => Eq (MaxiphobicHeap a) where

127 (Node ls ll le lr) == (Node rs rl re rr) =

128 ls == rs && ll == rl && le == re && lr == rr

129 _ == _ = False

130−

130+

131instance Ord a => Semigroup (MaxiphobicHeap a) where

132 (<+>) = merge

133

lib/Prelude/List.idr+1−1

@@ -537,7 +537,7 @@ hasAnyByNilFalse p (x::xs) =

537

538hasAnyNilFalse : Eq a => (l : List a) -> hasAny [] l = False

539hasAnyNilFalse l = ?hasAnyNilFalseBody

540−

540+

541--------------------------------------------------------------------------------

542-- Proofs

543--------------------------------------------------------------------------------

lib/Prelude/Monad.idr+1−1

@@ -10,7 +10,7 @@ import Prelude.Applicative

10

11infixl 5 >>=

12

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

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

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

15

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

lib/Prelude/Vect.idr+2−2

@@ -9,7 +9,7 @@ import Prelude.Nat

9%access public

10%default total

11

12−infixr 7 ::

12+infixr 7 ::

13

14data Vect : Nat -> Type -> Type where

15 Nil : Vect Z a

@@ -109,7 +109,7 @@ instance Functor (Vect n) where

109-- XXX: causes Idris to enter an infinite loop when type checking in the REPL

110--mapMaybe : (a -> Maybe b) -> Vect n a -> (p ** Vect b p)

111--mapMaybe f [] = (_ ** [])

112−--mapMaybe f (x::xs) = mapMaybe' (f x)

112+--mapMaybe f (x::xs) = mapMaybe' (f x)

113-- XXX: working around the type restrictions on case statements

114-- where

115-- mapMaybe' : (Maybe b) -> (n ** Vect b n) -> (p ** Vect b p)

lib/System.idr+2−2

@@ -7,7 +7,7 @@ import Prelude

7

8getArgs : IO (List String)

9getArgs = do n <- numArgs

10− ga' [] 0 n

10+ ga' [] 0 n

11 where

12 numArgs : IO Int

13 numArgs = mkForeign (FFun "idris_numArgs" [FPtr] FInt) prim__vm

@@ -23,7 +23,7 @@ getArgs = do n <- numArgs

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

24-- otherwise it returns Nothing.

25getEnv : String -> IO (Maybe String)

26−getEnv key = do

26+getEnv key = do

27 str_ptr <- getEnv'

28 is_nil <- nullStr str_ptr

29 if is_nil

lib/System/Concurrency/Process.idr+4−4

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

1−-- WARNING: No guarantees that this works properly yet!

1+-- WARNING: No guarantees that this works properly yet!

2

3module System.Concurrency.Process

4

@@ -6,7 +6,7 @@ import System.Concurrency.Raw

6

7%access public

8

9−abstract

9+abstract

10data ProcID msg = MkPID Ptr

11

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

@@ -43,7 +43,7 @@ send (MkPID p) m = lift (sendToThread p (prim__vm, m))

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

44

45msgWaiting : Process msg Bool

46−msgWaiting = lift checkMsgs

46+msgWaiting = lift checkMsgs

47

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

49

@@ -56,7 +56,7 @@ recv {msg} = do (senderid, m) <- lift get

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

57

58recvWithSender : Process msg (ProcID msg, msg)

59−recvWithSender {msg}

59+recvWithSender {msg}

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

61 return (MkPID senderid, m)

62 where get : IO (Ptr, msg)

lib/System/Concurrency/Raw.idr+4−4

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

1−-- WARNING: No guarantees that this works properly yet!

1+-- WARNING: No guarantees that this works properly yet!

2

3module System.Concurrency.Raw

4

@@ -9,8 +9,8 @@ import System

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

10

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

12−sendToThread {a} dest val

12+sendToThread {a} dest val

13− = mkForeign (FFun "idris_sendMessage"

13+ = mkForeign (FFun "idris_sendMessage"

14 [FPtr, FPtr, FAny a] FUnit) prim__vm dest val

15

16checkMsgs : IO Bool

@@ -22,6 +22,6 @@ checkMsgs = do msgs <- mkForeign (FFun "idris_checkMessage"

22-- arrives.

23

24getMsg : IO a

25−getMsg {a} = mkForeign (FFun "idris_recvMessage"

25+getMsg {a} = mkForeign (FFun "idris_recvMessage"

26 [FPtr] (FAny a)) prim__vm

27

samples/binary.idr+8−8

@@ -21,21 +21,21 @@ instance Show (Binary w k) where

21pattern syntax bitpair [x] [y] = (_ ** (_ ** (x, y, _)))

22term syntax bitpair [x] [y] = (_ ** (_ ** (x, y, refl)))

23

24−addBit : Bit x -> Bit y -> Bit c ->

24+addBit : Bit x -> Bit y -> Bit c ->

25 (bx ** (by ** (Bit bx, Bit by, c + x + y = by + 2 * bx)))

26addBit b0 b0 b0 = bitpair b0 b0

27−addBit b0 b0 b1 = bitpair b0 b1

27+addBit b0 b0 b1 = bitpair b0 b1

28addBit b0 b1 b0 = bitpair b0 b1

29addBit b0 b1 b1 = bitpair b1 b0

30−addBit b1 b0 b0 = bitpair b0 b1

30+addBit b1 b0 b0 = bitpair b0 b1

31−addBit b1 b0 b1 = bitpair b1 b0

31+addBit b1 b0 b1 = bitpair b1 b0

32−addBit b1 b1 b0 = bitpair b1 b0

32+addBit b1 b1 b0 = bitpair b1 b0

33−addBit b1 b1 b1 = bitpair b1 b1

33+addBit b1 b1 b1 = bitpair b1 b1

34

35−adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y)

35+adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y)

36adc zero zero carry ?= zero # carry

37adc (numx # bx) (numy # by) carry

38− ?= let (bitpair carry0 lsb) = addBit bx by carry in

38+ ?= let (bitpair carry0 lsb) = addBit bx by carry in

39 adc numx numy carry0 # lsb

40

41main : IO ()

samples/interp-alt.idr+7−7

@@ -26,11 +26,11 @@ using (G : Vect n Ty)

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

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 Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b

33−

33+

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

35 interp env (Var i) = lookup i env

36 interp env (Val x) = x

@@ -39,7 +39,7 @@ using (G : Vect n Ty)

39 interp env (Op op x y) = op (interp env x) (interp env y)

40 interp env (If x t e) = if (interp env x) then (interp env t) else (interp env e)

41 interp env (Bind v f) = interp env (f (interp env v))

42−

42+

43 eId : Expr G (TyFun TyInt TyInt)

44 eId = Lam (Var fZ)

45

@@ -48,13 +48,13 @@ using (G : Vect n Ty)

48

49 eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt))

50 eAdd = Lam (Lam (Op prim__addInt (Var fZ) (Var (fS fZ))))

51−

51+

52-- eDouble : Expr G (TyFun TyInt TyInt)

53-- eDouble = Lam (App (App (Lam (Lam (Op' (+) (Var fZ) (Var (fS fZ))))) (Var fZ)) (Var fZ))

54−

54+

55 eDouble : Expr G (TyFun TyInt TyInt)

56 eDouble = Lam (App (App eAdd (Var fZ)) (Var fZ))

57−

57+

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

59 app = \f, a => App f a

60

@@ -63,7 +63,7 @@ using (G : Vect n Ty)

63 (Val 1) (Op (*) (app eFac (Op (-) (Var fZ) (Val 1))) (Var fZ)))

64

65 -- Exercise elaborator: Complicated way of doing \x y => x*4 + y*2

66−

66+

67 eProg : Expr G (TyFun TyInt (TyFun TyInt TyInt))

68 eProg = Lam (Lam (Bind (App eDouble (Var (fS fZ)))

69 (\x => Bind (App eDouble (Var fZ))

samples/interp.idr+5−5

@@ -26,17 +26,17 @@ using (G : Vect n Ty)

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

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 Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b

33−

33+

34 dsl expr

35 lambda = Lam

36 variable = Var

37 index_first = stop

38 index_next = pop

39−

39+

40 (<$>) : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t

41 (<$>) = \f, a => App f a

42

@@ -59,7 +59,7 @@ using (G : Vect n Ty)

59 abs x = IF (x < 0) THEN (-x) ELSE x

60

61 fromInteger = Val . fromInteger

62−

62+

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

64 interp env (Var i) = lookup i env

65 interp env (Val x) = x

@@ -77,7 +77,7 @@ using (G : Vect n Ty)

77

78 eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt))

79 eAdd = expr (\x, y => Op (+) x y)

80−

80+

81 eDouble : Expr G (TyFun TyInt TyInt)

82 eDouble = expr (\x => App (App eAdd x) (Var stop))

83

samples/named_instance.lidr+2−2

@@ -21,7 +21,7 @@ instance --- they must not overlap.

21Sort foo using the default comparison operator:

22

23> test1 : List Nat

24−> test1 = sort foo

24+> test1 = sort foo

25

26-- which gives [1,2,3,4,5,6,7,8]

27

@@ -29,7 +29,7 @@ Sort foo using the alternative instance. No need for 'sortBy' and other

29such functions. Hoorah!

30

31> test2 : List Nat

32−> test2 = sort @{myord} foo

32+> test2 = sort @{myord} foo

33

34-- which gives [8,7,6,5,4,3,2,1]

35

samples/reflection.idr+1−1

@@ -66,7 +66,7 @@ firstEq ((y, Lam yt)::(x, Lam xt)::(_, Let _ f)::Nil) _ = Exact (App (App f (P (

66firstEq xs _ = Exact (TConst (I 0))

67

68-- | Skip 1 argument of the proof context and return the second one which

69−-- has to be introduced. Used for the tactical dispatch example, which

69+-- has to be introduced. Used for the tactical dispatch example, which

70-- will push dispatch, as first env agrument.

71innerTac : List (TTName, Binder TT) -> TT -> Tactic

72innerTac (_::(x, Lam xt)::_) _ = Exact (P Bound x xt)

src/Core/CaseTree.hs+52−52

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

1{-# LANGUAGE PatternGuards, DeriveFunctor, TypeSynonymInstances #-}

2

3−module Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..),

3+module Core.CaseTree(CaseDef(..), SC, SC'(..), CaseAlt, CaseAlt'(..),

4 Phase(..), CaseTree,

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

6

@@ -20,8 +20,8 @@ data SC' t = Case Name [CaseAlt' t] -- ^ invariant: lowest tags first

20 | UnmatchedCase String -- ^ error message

21 | ImpossibleCase -- ^ already checked to be impossible

22 deriving (Eq, Ord, Functor)

23−{-!

23+{-!

24−deriving instance Binary SC

24+deriving instance Binary SC

25!-}

26

27type SC = SC' Term

@@ -32,8 +32,8 @@ data CaseAlt' t = ConCase Name Int [Name] (SC' t)

32 | SucCase Name (SC' t)

33 | DefaultCase (SC' t)

34 deriving (Show, Eq, Ord, Functor)

35−{-!

35+{-!

36−deriving instance Binary CaseAlt

36+deriving instance Binary CaseAlt

37!-}

38

39type CaseAlt = CaseAlt' Term

@@ -41,7 +41,7 @@ type CaseAlt = CaseAlt' Term

41instance Show t => Show (SC' t) where

42 show sc = show' 1 sc

43 where

44− show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i ++

44+ show' i (Case n alts) = "case " ++ show n ++ " of\n" ++ indent i ++

45 showSep ("\n" ++ indent i) (map (showA i) alts)

46 show' i (ProjCase tm alts) = "case " ++ show tm ++ " of " ++

47 showSep ("\n" ++ indent i) (map (showA i) alts)

@@ -51,19 +51,19 @@ instance Show t => Show (SC' t) where

51

52 indent i = concat $ take i (repeat " ")

53

54− showA i (ConCase n t args sc)

54+ showA i (ConCase n t args sc)

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

56 ++ show' (i+1) sc

57− showA i (FnCase n args sc)

57+ showA i (FnCase n args sc)

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

59 ++ show' (i+1) sc

60− showA i (ConstCase t sc)

60+ showA i (ConstCase t sc)

61 = show t ++ " => " ++ show' (i+1) sc

62− showA i (SucCase n sc)

62+ showA i (SucCase n sc)

63 = show n ++ "+1 => " ++ show' (i+1) sc

64− showA i (DefaultCase sc)

64+ showA i (DefaultCase sc)

65 = "_ => " ++ show' (i+1) sc

66−

66+

67

68type CaseTree = SC

69type Clause = ([Pat], (Term, Term))

@@ -88,13 +88,13 @@ instance TermSize CaseAlt where

88

89small :: Name -> [Name] -> SC -> Bool

90small n args t = let as = findAllUsedArgs t args in

91− length as == length (nub as) &&

91+ length as == length (nub as) &&

92 termsize n t < 10

93

94namesUsed :: SC -> [Name]

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

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

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

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

98 (concatMap (nua ps) alts))

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

100 nu' ps _ = []

@@ -124,15 +124,15 @@ findCalls sc topargs = nub $ nu' topargs sc where

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

125 nu' ps _ = []

126

127− nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc)

127+ nua ps (ConCase n i args sc) = nub (nu' (ps ++ args) sc)

128− nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc)

128+ nua ps (FnCase n args sc) = nub (nu' (ps ++ args) sc)

129 nua ps (ConstCase _ sc) = nu' ps sc

130 nua ps (SucCase _ sc) = nu' ps sc

131 nua ps (DefaultCase sc) = nu' ps sc

132

133 nut ps (P Ref n _) | n `elem` ps = []

134 | otherwise = [(n, [])] -- tmp

135− nut ps fn@(App f a)

135+ nut ps fn@(App f a)

136 | (P Ref n _, args) <- unApply fn

137 = if n `elem` ps then nut ps f ++ nut ps a

138 else [(n, map argNames args)] ++ concatMap (nut ps) args

@@ -152,7 +152,7 @@ directUse (P _ n _) = [n]

152directUse (Bind n (Let t v) sc) = nub $ directUse v ++ (directUse sc \\ [n])

153 ++ directUse t

154directUse (Bind n b sc) = nub $ directUse (binderTy b) ++ (directUse sc \\ [n])

155−directUse fn@(App f a)

155+directUse fn@(App f a)

156 | (P Ref n _, args) <- unApply fn = [] -- need to know what n does with them

157 | otherwise = nub $ directUse f ++ directUse a

158directUse (Proj x i) = nub $ directUse x

@@ -169,8 +169,8 @@ findAllUsedArgs sc topargs = filter (\x -> x `elem` topargs) (nu' sc) where

169 nu' (STerm t) = directUse t

170 nu' _ = []

171

172− nua (ConCase n i args sc) = nu' sc

172+ nua (ConCase n i args sc) = nu' sc

173− nua (FnCase n args sc) = nu' sc

173+ nua (FnCase n args sc) = nu' sc

174 nua (ConstCase _ sc) = nu' sc

175 nua (SucCase _ sc) = nu' sc

176 nua (DefaultCase sc) = nu' sc

@@ -182,27 +182,27 @@ data Phase = CompileTime | RunTime

182-- Work Right to Left

183

184simpleCase :: Bool -> Bool -> Bool ->

185− Phase -> FC -> [([Name], Term, Term)] ->

185+ Phase -> FC -> [([Name], Term, Term)] ->

186 TC CaseDef

187simpleCase tc cover reflect phase fc cs

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

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

189 case r of

190 Impossible -> False

191− _ -> True) cs)

191+ _ -> True) cs)

192 where

193− sc' tc cover phase fc []

193+ sc' tc cover phase fc []

194 = return $ CaseDef [] (UnmatchedCase "No pattern clauses") []

195− sc' tc cover phase fc cs

195+ sc' tc cover phase fc cs

196 = let proj = phase == RunTime

197− pats = map (\ (avs, l, r) ->

197+ pats = map (\ (avs, l, r) ->

198 (avs, toPats reflect tc l, (l, r))) cs

199 chkPats = mapM chkAccessible pats in

200 case chkPats of

201 OK pats ->

202− let numargs = length (fst (head pats))

202+ let numargs = length (fst (head pats))

203 ns = take numargs args

204 (ns', ps') = order ns pats

205− (tree, st) = runState

205+ (tree, st) = runState

206 (match ns' ps' (defaultCase cover)) ([], numargs)

207 t = CaseDef ns (prune proj (depatt ns' tree)) (fst st) in

208 if proj then return (stripLambdas t) else return t

@@ -211,12 +211,12 @@ simpleCase tc cover reflect phase fc cs

211 defaultCase True = STerm Erased

212 defaultCase False = UnmatchedCase "Error"

213

214− chkAccessible (avs, l, c)

214+ chkAccessible (avs, l, c)

215 | phase == RunTime || reflect = return (l, c)

216 | otherwise = do mapM_ (acc l) avs

217 return (l, c)

218

219− acc [] n = Error (Inaccessible n)

219+ acc [] n = Error (Inaccessible n)

220 acc (PV x : xs) n | x == n = OK ()

221 acc (PCon _ _ ps : xs) n = acc (ps ++ xs) n

222 acc (PSuc p : xs) n = acc (p : xs) n

@@ -244,31 +244,31 @@ toPat reflect tc tms = evalState (mapM (\x -> toPat' x []) tms) []

244 toPat' (P (DCon t a) n _) args = do args' <- mapM (\x -> toPat' x []) args

245 return $ PCon n t args'

246 -- n + 1

247− toPat' (P _ (UN "prim__addBigInt") _)

247+ toPat' (P _ (UN "prim__addBigInt") _)

248 [p, Constant (BI 1)]

249 = do p' <- toPat' p []

250 return $ PSuc p'

251 -- Typecase

252− toPat' (P (TCon t a) n _) args | tc

252+ toPat' (P (TCon t a) n _) args | tc

253 = do args' <- mapM (\x -> toPat' x []) args

254 return $ PCon n t args'

255 toPat' (Constant (AType (ATInt ITNative))) []

256− | tc = return $ PCon (UN "Int") 1 []

256+ | tc = return $ PCon (UN "Int") 1 []

257− toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 []

257+ toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 []

258− toPat' (Constant (AType (ATInt ITChar))) [] | tc = return $ PCon (UN "Char") 3 []

258+ toPat' (Constant (AType (ATInt ITChar))) [] | tc = return $ PCon (UN "Char") 3 []

259− toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 []

259+ toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 []

260− toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 []

260+ toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 []

261 toPat' (Constant (AType (ATInt ITBig))) []

262 | tc = return $ PCon (UN "Integer") 6 []

263 toPat' (Constant (AType (ATInt (ITFixed n)))) []

264 | tc = return $ PCon (UN (fixedN n)) (7 + fromEnum n) [] -- 7-10 inclusive

265 toPat' (P Bound n _) [] = do ns <- get

266− if n `elem` ns

266+ if n `elem` ns

267− then return PAny

267+ then return PAny

268 else do put (n : ns)

269 return (PV n)

270 toPat' (App f a) args = toPat' f (a : args)

271− toPat' (Constant x) [] = return $ PConst x

271+ toPat' (Constant x) [] = return $ PConst x

272 toPat' (Bind n (Pi t) sc) [] | reflect && noOccurrence n sc

273 = do t' <- toPat' t []

274 sc' <- toPat' sc []

@@ -323,10 +323,10 @@ order ns cs = let patnames = transpose (map (zip ns) (map fst cs))

323

324 rebuild patnames clause = (map snd patnames, snd clause)

325

326− moreDistinct xs ys = compare (numNames [] (map snd ys))

326+ moreDistinct xs ys = compare (numNames [] (map snd ys))

327 (numNames [] (map snd xs))

328

329− numNames xs (PCon n _ _ : ps)

329+ numNames xs (PCon n _ _ : ps)

330 | not (Left n `elem` xs) = numNames (Left n : xs) ps

331 numNames xs (PConst c : ps)

332 | not (Right c `elem` xs) = numNames (Right c : xs) ps

@@ -335,7 +335,7 @@ order ns cs = let patnames = transpose (map (zip ns) (map fst cs))

335

336match :: [Name] -> [Clause] -> SC -- error case

337 -> State CS SC

338−match [] (([], ret) : xs) err

338+match [] (([], ret) : xs) err

339 = do (ts, v) <- get

340 put (ts ++ (map (fst.snd) xs), v)

341 case snd ret of

@@ -382,7 +382,7 @@ caseGroups (v:vs) gs err = do g <- altGroups gs

382 = do g <- altSucGroup args

383 rest <- altGroups cs

384 return (g : rest)

385− altGroups (ConGroup (CConst c) args : cs)

385+ altGroups (ConGroup (CConst c) args : cs)

386 = do g <- altConstGroup c args

387 rest <- altGroups cs

388 return (g : rest)

@@ -405,7 +405,7 @@ argsToAlt [] = return ([], [])

405argsToAlt rs@((r, m) : rest)

406 = do newArgs <- getNewVars r

407 return (newArgs, addRs rs)

408− where

408+ where

409 getNewVars [] = return []

410 getNewVars ((PV n) : ns) = do v <- getVar "e"

411 nsv <- getNewVars ns

@@ -429,7 +429,7 @@ groupCons :: [Clause] -> State CS [Group]

429groupCons cs = gc [] cs

430 where

431 gc acc [] = return acc

432− gc acc ((p : ps, res) : cs) =

432+ gc acc ((p : ps, res) : cs) =

433 do acc' <- addGroup p ps res acc

434 gc acc' cs

435 addGroup p ps res acc = case p of

@@ -439,7 +439,7 @@ groupCons cs = gc [] cs

439 PReflected fn args -> return $ addg (CFn fn) args (ps, res) acc

440 pat -> fail $ show pat ++ " is not a constructor or constant (can't happen)"

441

442− addg c conargs res []

442+ addg c conargs res []

443 = [ConGroup c [(conargs, res)]]

444 addg c conargs res (g@(ConGroup c' cs):gs)

445 | c == c' = ConGroup c (cs ++ [(conargs, res)]) : gs

@@ -456,7 +456,7 @@ varRule (v : vs) alts err =

456 do let alts' = map (repVar v) alts

457 match vs alts' err

458 where

459− repVar v (PV p : ps , (lhs, res))

459+ repVar v (PV p : ps , (lhs, res))

460 = (ps, (lhs, subst p (P Bound v Erased) res))

461 repVar v (PAny : ps , res) = (ps, res)

462

@@ -487,7 +487,7 @@ depatt ns tm = dp [] tm

487 | and ((length args == length args') :

488 (n == cn) : zipWith same args args') = P Ref x Erased

489 | otherwise = applyMap ms nt cn pty args'

490− same n (P _ n' _) = n == n'

490+ same n (P _ n' _) = n == n'

491 same _ _ = False

492

493 applyMaps ms (App f a) = App (applyMaps ms f) (applyMaps ms a)

@@ -495,7 +495,7 @@ depatt ns tm = dp [] tm

495

496prune :: Bool -- ^ Convert single branches to projections (only useful at runtime)

497 -> SC -> SC

498−prune proj (Case n alts)

498+prune proj (Case n alts)

499 = let alts' = filter notErased (map pruneAlt alts) in

500 case alts' of

501 [] -> ImpossibleCase

@@ -521,7 +521,7 @@ prune proj (Case n alts)

521

522 projRep :: Name -> Name -> Int -> SC -> SC

523 projRep arg n i (Case x alts)

524− | x == arg = ProjCase (Proj (P Bound n Erased) i)

524+ | x == arg = ProjCase (Proj (P Bound n Erased) i)

525 (map (projRepAlt arg n i) alts)

526 | otherwise = Case x (map (projRepAlt arg n i) alts)

527 projRep arg n i (ProjCase t alts)

@@ -540,7 +540,7 @@ prune proj (Case n alts)

540 projRepAlt arg n i (DefaultCase rhs)

541 = DefaultCase (projRep arg n i rhs)

542

543− projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

543+ projRepTm arg n i t = subst arg (Proj (P Bound n Erased) i) t

544

545prune _ t = t

546

src/Core/Constraints.hs+5−5

@@ -25,7 +25,7 @@ type Relations = M.Map UExp [(UConstraint, FC)]

25

26mkRels :: [(UConstraint, FC)] -> Relations -> Relations

27mkRels [] acc = acc

28−mkRels ((c, f) : cs) acc

28+mkRels ((c, f) : cs) acc

29 | not (ignore c)

30 = case M.lookup (lhs c) acc of

31 Nothing -> mkRels cs (M.insert (lhs c) [(c,f)] acc)

@@ -38,7 +38,7 @@ mkRels ((c, f) : cs) acc

38

39

40acyclic :: Relations -> [UExp] -> TC ()

41−acyclic r cvs = checkCycle (fileFC "root") r [] 0 cvs

41+acyclic r cvs = checkCycle (fileFC "root") r [] 0 cvs

42 where

43 checkCycle :: FC -> Relations -> [(UExp, FC)] -> Int -> [UExp] -> TC ()

44 checkCycle fc r path inc [] = return ()

@@ -50,18 +50,18 @@ acyclic r cvs = checkCycle (fileFC "root") r [] 0 cvs

50

51 check fc path inc (UVar x) | x < 0 = return ()

52 check fc path inc cv

53− | inc > 0 && cv `elem` map fst path

53+ | inc > 0 && cv `elem` map fst path

54 = Error $ At fc UniverseError

55 -- FIXME: Make informative

56 -- e.g. (Msg ("Cycle: " ++ show cv ++ ", " ++ show path))

57 -- if we reach a cycle but we're at the same universe level, it's

58 -- fine, because they must all be equal, so stop.

59 | inc == 0 && cv `elem` map fst path

60− = return ()

60+ = return ()

61 | otherwise = case M.lookup cv r of

62 Nothing -> return ()

63 Just cs -> mapM_ (next ((cv, fc):path) inc) cs

64−

64+

65 next path inc (ULT l r, fc) = check fc path (inc + 1) r

66 next path inc (ULE l r, fc) = check fc path inc r

67

src/Core/CoreParser.hs+16−16

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

1{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

2

3−module Core.CoreParser(parseTerm, parseFile, parseDef, pTerm, iName,

3+module Core.CoreParser(parseTerm, parseFile, parseDef, pTerm, iName,

4 idrisLexer, maybeWithNS, pDocComment, opChars) where

5

6import Core.TT

@@ -21,22 +21,22 @@ import Debug.Trace

21

22type TokenParser a = PTok.TokenParser a

23

24−idrisDef = haskellDef {

24+idrisDef = haskellDef {

25 opStart = iOpStart,

26 opLetter = iOpLetter,

27 identLetter = identLetter haskellDef <|> lchar '.',

28− reservedOpNames

28+ reservedOpNames

29 = [":", "..", "=", "\\", "|", "<-", "->", "=>", "**"],

30− reservedNames

30+ reservedNames

31− = ["let", "in", "data", "codata", "record", "Type",

31+ = ["let", "in", "data", "codata", "record", "Type",

32− "do", "dsl", "import", "impossible",

32+ "do", "dsl", "import", "impossible",

33 "case", "of", "total", "partial", "mutual",

34 "infix", "infixl", "infixr", "rewrite",

35 "where", "with", "syntax", "proof", "postulate",

36 "using", "namespace", "class", "instance",

37 "public", "private", "abstract", "implicit",

38 "quoteGoal"]

39− }

39+ }

40

41-- | The characters allowed in operator names

42opChars = ":!#$%&*+./<=>?@\\^|-~"

@@ -46,7 +46,7 @@ iOpLetter = oneOf opChars

46-- <|> letter

47

48idrisLexer :: TokenParser a

49−idrisLexer = idrisMakeTokenParser idrisDef

49+idrisLexer = idrisMakeTokenParser idrisDef

50

51lexer = idrisLexer

52

@@ -130,14 +130,14 @@ initsEndAt p (x:xs) | p x = [] : x_inits_xs

130-- Create a `Name' from a pair of strings representing a base name and its

131-- namespace.

132mkName :: (String, String) -> Name

133−mkName (n, "") = UN n

133+mkName (n, "") = UN n

134mkName (n, ns) = NS (UN n) (reverse (parseNS ns))

135 where parseNS x = case span (/= '.') x of

136 (x, "") -> [x]

137 (x, '.':y) -> x : parseNS y

138

139pDocComment :: Char -> CParser a String

140−pDocComment c

140+pDocComment c

141 = try (do string ("--")

142 char c

143 skipMany simpleSpace

@@ -193,13 +193,13 @@ pExp = do lchar '\\'; x <- iName []; lchar ':'; ty <- pTerm

193 lchar '.';

194 sc <- pTerm

195 return (RBind x (Hole ty) sc))

196− <|> try (do lchar '(';

196+ <|> try (do lchar '(';

197 x <- iName []; lchar ':'; ty <- pTerm

198 lchar ')';

199 symbol "->";

200 sc <- pTerm

201 return (RBind x (Pi ty) sc))

202− <|> try (do lchar '(';

202+ <|> try (do lchar '(';

203 t <- pTerm

204 lchar ')'

205 return t)

@@ -209,14 +209,14 @@ pExp = do lchar '\\'; x <- iName []; lchar ':'; ty <- pTerm

209 val <- pTerm

210 sc <- pTerm

211 return (RBind x (Guess ty val) sc))

212− <|> try (do reserved "let";

212+ <|> try (do reserved "let";

213 x <- iName []; lchar ':'; ty <- pTerm

214 lchar '=';

215 val <- pTerm

216 reserved "in";

217 sc <- pTerm

218 return (RBind x (Let ty val) sc))

219− <|> try (do lchar '_';

219+ <|> try (do lchar '_';

220 x <- iName []; lchar ':'; ty <- pTerm

221 lchar '.';

222 sc <- pTerm

@@ -236,11 +236,11 @@ pConstructor = do lchar '|'

236 c <- iName []; lchar ':'; ty <- pTerm

237 return (c, ty)

238

239−------ borrowed from Parsec

239+------ borrowed from Parsec

240-- (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007

241

242idrisMakeTokenParser languageDef

243− = PTok.TokenParser{

243+ = PTok.TokenParser{

244 PTok.identifier = identifier

245 , PTok.reserved = reserved

246 , PTok.operator = operator

src/Core/Elaborate.hs+37−37

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

8 tactics out of the primitives.

9-}

10

11−module Core.Elaborate(module Core.Elaborate,

11+module Core.Elaborate(module Core.Elaborate,

12 module Core.ProofState) where

13

14import Core.ProofState

@@ -64,7 +64,7 @@ errAt thing n elab = do s <- get

64 case runStateT elab s of

65 OK (a, s') -> do put s'

66 return a

67− Error (At f e) ->

67+ Error (At f e) ->

68 lift $ Error (At f (Elaborating thing n e))

69 Error e -> lift $ Error (Elaborating thing n e)

70

@@ -182,8 +182,8 @@ get_deferred = do ES p _ _ <- get

182checkInjective :: (Term, Term, Term) -> Elab' aux ()

183checkInjective (tm, l, r) = do ctxt <- get_context

184 if isInj ctxt tm then return ()

185− else lift $ tfail (NotInjective tm l r)

185+ else lift $ tfail (NotInjective tm l r)

186− where isInj ctxt (P _ n _)

186+ where isInj ctxt (P _ n _)

187 | isConName n ctxt = True

188 isInj ctxt (App f a) = isInj ctxt f

189 isInj ctxt (Constant _) = True

@@ -200,15 +200,15 @@ get_instances = do ES p _ _ <- get

200unique_hole = unique_hole' False

201

202unique_hole' :: Bool -> Name -> Elab' aux Name

203−unique_hole' reusable n

203+unique_hole' reusable n

204 = do ES p _ _ <- get

205− let bs = bound_in (pterm (fst p)) ++

205+ let bs = bound_in (pterm (fst p)) ++

206 bound_in (ptype (fst p))

207− n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p)

207+ n' <- uniqueNameCtxt (context (fst p)) n (holes (fst p)

208 ++ bs ++ dontunify (fst p) ++ usedns (fst p))

209 ES (p, a) s u <- get

210 -- Hmm: Do we need this level of uniqueness?

211− let p' = p -- if reusable then p else p { usedns = n' : usedns p }

211+ let p' = p -- if reusable then p else p { usedns = n' : usedns p }

212 put (ES (p', a) s u)

213 return n'

214 where

@@ -221,7 +221,7 @@ unique_hole' reusable n

221 bound_in _ = []

222

223uniqueNameCtxt :: Context -> Name -> [Name] -> Elab' aux Name

224−uniqueNameCtxt ctxt n hs

224+uniqueNameCtxt ctxt n hs

225 | n `elem` hs = uniqueNameCtxt ctxt (nextName n) hs

226 | [_] <- lookupTy n ctxt = uniqueNameCtxt ctxt (nextName n) hs

227 | otherwise = return n

@@ -272,7 +272,7 @@ regret = processTactic' Regret

272compute :: Elab' aux ()

273compute = processTactic' Compute

274

275−computeLet :: Name -> Elab' aux ()

275+computeLet :: Name -> Elab' aux ()

276computeLet n = processTactic' (ComputeLet n)

277

278simplify :: Elab' aux ()

@@ -391,7 +391,7 @@ prepare_apply fn imps =

391 | Var n <- fn

392 = do ctxt <- get_context

393 case lookupTy n ctxt of

394− [] -> lift $ tfail $ NoSuchVariable n

394+ [] -> lift $ tfail $ NoSuchVariable n

395 _ -> fail $ "Too many arguments for " ++ show fn

396 | otherwise = fail $ "Too many arguments for " ++ show fn

397

@@ -415,7 +415,7 @@ apply = apply' fill

415match_apply = apply' match_fill

416

417apply' :: (Raw -> Elab' aux ()) -> Raw -> [(Bool, Int)] -> Elab' aux [Name]

418−apply' fillt fn imps =

418+apply' fillt fn imps =

419 do args <- prepare_apply fn (map fst imps)

420 env <- get_env

421 g <- goal

@@ -428,20 +428,20 @@ apply' fillt fn imps =

428 hs <- get_holes

429 ES (p, a) s prev <- get

430 let dont = nub $ head hs : dontunify p ++

431− if null imps then [] -- do all we can

431+ if null imps then [] -- do all we can

432 else

433 map fst (filter (not.snd) (zip args (map fst imps)))

434− let (n, hunis) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $

434+ let (n, hunis) = -- trace ("AVOID UNIFY: " ++ show (fn, dont) ++ "\n" ++ show ptm) $

435 unified p

436− let unify = -- trace ("Not done " ++ show hs) $

436+ let unify = -- trace ("Not done " ++ show hs) $

437 dropGiven dont hunis hs

438− let notunify = -- trace ("Not done " ++ show hs) $

438+ let notunify = -- trace ("Not done " ++ show hs) $

439 keepGiven dont hunis hs

440 put (ES (p { dontunify = dont, unified = (n, unify),

441 notunified = notunify ++ notunified p }, a) s prev)

442 ptm <- get_term

443 g <- goal

444−-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $

444+-- trace ("Goal " ++ show g ++ "\n" ++ show (fn, imps, unify) ++ "\n" ++ show ptm) $

445 end_unify

446 ptm <- get_term

447 return (map (updateUnify unify) args)

@@ -449,8 +449,8 @@ apply' fillt fn imps =

449 Just (P _ t _) -> t

450 _ -> n

451

452−apply2 :: Raw -> [Maybe (Elab' aux ())] -> Elab' aux ()

452+apply2 :: Raw -> [Maybe (Elab' aux ())] -> Elab' aux ()

453−apply2 fn elabs =

453+apply2 fn elabs =

454 do args <- prepare_apply fn (map isJust elabs)

455 fill (raw_apply fn (map Var args))

456 elabArgs args elabs

@@ -463,11 +463,11 @@ apply2 fn elabs =

463 elabArgs ns es

464 elabArgs (n:ns) (_:es) = elabArgs ns es

465

466− isJust (Just _) = False

466+ isJust (Just _) = False

467 isJust _ = True

468

469apply_elab :: Name -> [Maybe (Int, Elab' aux ())] -> Elab' aux ()

470−apply_elab n args =

470+apply_elab n args =

471 do ty <- get_type (Var n)

472 ctxt <- get_context

473 env <- get_env

@@ -497,7 +497,7 @@ apply_elab n args =

497 doClaims t [] claims = return (reverse claims)

498 doClaims _ _ _ = fail $ "Wrong number of arguments for " ++ show n

499

500− elabClaims failed r []

500+ elabClaims failed r []

501 | null failed = return ()

502 | otherwise = if r then elabClaims [] False failed

503 else return ()

@@ -515,7 +515,7 @@ apply_elab n args =

515

516-- If the goal is not a Pi-type, invent some names and make it a pi type

517checkPiGoal :: Name -> Elab' aux ()

518−checkPiGoal n

518+checkPiGoal n

519 = do g <- goal

520 case g of

521 Bind _ (Pi _) _ -> return ()

@@ -551,8 +551,8 @@ simple_app fun arg appstr =

551 complete_fill

552 hs <- get_holes

553 env <- get_env

554− -- We don't need a and b in the hole queue any more since they were

554+ -- We don't need a and b in the hole queue any more since they were

555− -- just for checking f, so discard them if they are still there.

555+ -- just for checking f, so discard them if they are still there.

556 -- If they haven't been solved, regret will fail

557 when (a `elem` hs) $ do focus a; regretWith (CantInferType appstr)

558 when (b `elem` hs) $ do focus b; regretWith (CantInferType appstr)

@@ -569,7 +569,7 @@ arg n tyhole = do ty <- unique_hole tyhole

569

570-- try a tactic, if it adds any unification problem, return an error

571no_errors :: Elab' aux () -> Elab' aux ()

572−no_errors tac

572+no_errors tac

573 = do ps <- get_probs

574 tac

575 ps' <- get_probs

@@ -594,11 +594,11 @@ try' t1 t2 proofSearch

594 Error e1 -> if recoverableErr e1 then

595 do case runStateT t2 s of

596 OK (v, s') -> do put s'; return v

597− Error e2 -> if score e1 >= score e2

597+ Error e2 -> if score e1 >= score e2

598− then lift (tfail e1)

598+ then lift (tfail e1)

599 else lift (tfail e2)

600 else lift (tfail e1)

601− where recoverableErr err@(CantUnify r _ _ _ _ _)

601+ where recoverableErr err@(CantUnify r _ _ _ _ _)

602 = -- traceWhen r (show err) $

603 r || proofSearch

604 recoverableErr (ProofSearchFail _) = False

@@ -614,7 +614,7 @@ tryAll :: [(Elab' aux a, String)] -> Elab' aux a

614tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

615 where

616 cantResolve :: Elab' aux a

617− cantResolve = lift $ tfail $ CantResolveAlts (map snd xs)

617+ cantResolve = lift $ tfail $ CantResolveAlts (map snd xs)

618

619 tryAll' :: [Elab' aux a] -> -- successes

620 Int -> -- most problems

@@ -624,12 +624,12 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

624 tryAll' [res] pmax _ [] = res

625 tryAll' (_:_) pmax _ [] = cantResolve

626 tryAll' [] pmax (f, _) [] = f

627− tryAll' cs pmax f (x:xs)

627+ tryAll' cs pmax f (x:xs)

628 = do s <- get

629 ps <- get_probs

630 case prunStateT pmax True ps x s of

631− OK ((v, newps), s') ->

631+ OK ((v, newps), s') ->

632− do let cs' = if (newps < pmax)

632+ do let cs' = if (newps < pmax)

633 then [do put s'; return v]

634 else (do put s'; return v) : cs

635 tryAll' cs' newps f xs

@@ -643,10 +643,10 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

643 if (s >= i) then (lift (tfail err), s)

644 else (f, i)

645

646−prunStateT pmax zok ps x s

646+prunStateT pmax zok ps x s

647 = case runStateT x s of

648− OK (v, s'@(ES (p, _) _ _)) ->

648+ OK (v, s'@(ES (p, _) _ _)) ->

649− let newps = length (problems p) - length ps

649+ let newps = length (problems p) - length ps

650 newpmax = if newps < 0 then 0 else newps in

651 if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))

652 then case reverse (problems p) of

@@ -655,7 +655,7 @@ prunStateT pmax zok ps x s

655 Error e -> Error e

656

657qshow :: Fails -> String

658−qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

658+qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

659

660dumpprobs [] = ""

661dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es

src/Core/Evaluate.hs+114−114

@@ -6,9 +6,9 @@ module Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,

6 Def(..), CaseInfo(..), CaseDefs(..),

7 Accessibility(..), Totality(..), PReason(..),

8 Context, initContext, ctxtAlist, uconstraints, next_tvar,

9− addToCtxt, setAccess, setTotal, addCtxtDef, addTyDecl,

9+ addToCtxt, setAccess, setTotal, addCtxtDef, addTyDecl,

10 addDatatype, addCasedef, simplifyCasedef, addOperator,

11− lookupNames, lookupTy, lookupP, lookupDef, lookupVal,

11+ lookupNames, lookupTy, lookupP, lookupDef, lookupVal,

12 lookupTotal, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

13 Value(..), Quote(..), initEval) where

14

@@ -25,9 +25,9 @@ data EvalState = ES { limited :: [(Name, Int)],

25

26type Eval a = State EvalState a

27

28−data EvalOpt = Spec

28+data EvalOpt = Spec

29− | HNF

29+ | HNF

30− | Simplify

30+ | Simplify

31 | AtREPL

32 deriving (Show, Eq)

33

@@ -56,19 +56,19 @@ instance Show (a -> b) where

56

57-- THE EVALUATOR ------------------------------------------------------------

58

59−-- The environment is assumed to be "locally named" - i.e., not de Bruijn

59+-- The environment is assumed to be "locally named" - i.e., not de Bruijn

60-- indexed.

61-- i.e. it's an intermediate environment that we have while type checking or

62-- while building a proof.

63

64-- | Normalise fully type checked terms (so, assume all names/let bindings resolved)

65normaliseC :: Context -> Env -> TT Name -> TT Name

66−normaliseC ctxt env t

66+normaliseC ctxt env t

67 = evalState (do val <- eval False ctxt [] env t []

68 quote 0 val) initEval

69

70normaliseAll :: Context -> Env -> TT Name -> TT Name

71−normaliseAll ctxt env t

71+normaliseAll ctxt env t

72 = evalState (do val <- eval False ctxt [] env t [AtREPL]

73 quote 0 val) initEval

74

@@ -76,38 +76,38 @@ normalise :: Context -> Env -> TT Name -> TT Name

76normalise = normaliseTrace False

77

78normaliseTrace :: Bool -> Context -> Env -> TT Name -> TT Name

79−normaliseTrace tr ctxt env t

79+normaliseTrace tr ctxt env t

80 = evalState (do val <- eval tr ctxt [] (map finalEntry env) (finalise t) []

81 quote 0 val) initEval

82

83specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> TT Name

84−specialise ctxt env limits t

84+specialise ctxt env limits t

85− = evalState (do val <- eval False ctxt []

85+ = evalState (do val <- eval False ctxt []

86− (map finalEntry env) (finalise t)

86+ (map finalEntry env) (finalise t)

87 [Spec]

88 quote 0 val) (initEval { limited = limits })

89

90−-- | Like normalise, but we only reduce functions that are marked as okay to

90+-- | Like normalise, but we only reduce functions that are marked as okay to

91-- inline (and probably shouldn't reduce lets?)

92-- 20130908: now only used to reduce for totality checking. Inlining should

93-- be done elsewhere.

94

95simplify :: Context -> Env -> TT Name -> TT Name

96−simplify ctxt env t

96+simplify ctxt env t

97 = evalState (do val <- eval False ctxt [(UN "lazy", 0),

98 (UN "assert_smaller", 0),

99 (UN "par", 0),

100 (UN "prim__syntactic_eq", 0),

101− (UN "fork", 0)]

101+ (UN "fork", 0)]

102− (map finalEntry env) (finalise t)

102+ (map finalEntry env) (finalise t)

103 [Simplify]

104 quote 0 val) initEval

105

106-- | Reduce a term to head normal form

107hnf :: Context -> Env -> TT Name -> TT Name

108−hnf ctxt env t

108+hnf ctxt env t

109− = evalState (do val <- eval False ctxt []

109+ = evalState (do val <- eval False ctxt []

110− (map finalEntry env)

110+ (map finalEntry env)

111 (finalise t) [HNF]

112 quote 0 val) initEval

113

@@ -136,7 +136,7 @@ usable True n ns

136 Just 0 -> return (False, ns)

137 Just i -> return (True, ns)

138 _ -> return (False, ns)

139−usable False n ns

139+usable False n ns

140 = case lookup n ns of

141 Just 0 -> return (False, ns)

142 Just i -> return $ (True, (n, abs (i-1)) : filter (\ (n', _) -> n/=n') ns)

@@ -157,58 +157,58 @@ deduct n = do ES ls num <- get

157-- a name. The corresponding pair in the state is the maximum number of

158-- unfoldings overall.

159

160−eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name ->

160+eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name ->

161 [EvalOpt] -> Eval Value

162eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

163 spec = Spec `elem` opts

164− simpl = Simplify `elem` opts

164+ simpl = Simplify `elem` opts

165 atRepl = AtREPL `elem` opts

166 hnf = HNF `elem` opts

167

168 -- returns 'True' if the function should block

169 -- normal evaluation should return false

170− blockSimplify (CaseInfo inl dict) n stk

170+ blockSimplify (CaseInfo inl dict) n stk

171− | Simplify `elem` opts

171+ | Simplify `elem` opts

172 = (not (inl || dict) || elem n stk)

173 || (n == UN "prim__syntactic_eq")

174 | otherwise = False

175

176 ev ntimes stk top env (P _ n ty)

177− | Just (Let t v) <- lookup n genv = ev ntimes stk top env v

177+ | Just (Let t v) <- lookup n genv = ev ntimes stk top env v

178− ev ntimes_in stk top env (P Ref n ty)

178+ ev ntimes_in stk top env (P Ref n ty)

179 | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty)

180− | otherwise

180+ | otherwise

181 = do (u, ntimes) <- usable spec n ntimes_in

182 if u then

183− do let val = lookupDefAcc n atRepl ctxt

183+ do let val = lookupDefAcc n atRepl ctxt

184 case val of

185− [(Function _ tm, Public)] ->

185+ [(Function _ tm, Public)] ->

186 ev ntimes (n:stk) True env tm

187 [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty

188 return $ VP nt n vty

189− [(CaseOp ci _ _ _ cd, acc)]

189+ [(CaseOp ci _ _ _ cd, acc)]

190 | acc == Public &&

191 null (fst (cases_totcheck cd)) -> -- unoptimised version

192 let (_, tree) = if simpl then cases_totcheck cd

193 else cases_compiletime cd in

194 if blockSimplify ci n stk

195 then liftM (VP Ref n) (ev ntimes stk top env ty)

196− else do c <- evCase ntimes n (n:stk) top env [] [] tree

196+ else do c <- evCase ntimes n (n:stk) top env [] [] tree

197 case c of

198 (Nothing, _) -> liftM (VP Ref n) (ev ntimes stk top env ty)

199 (Just v, _) -> return v

200 _ -> liftM (VP Ref n) (ev ntimes stk top env ty)

201 else liftM (VP Ref n) (ev ntimes stk top env ty)

202− ev ntimes stk top env (P nt n ty)

202+ ev ntimes stk top env (P nt n ty)

203 = liftM (VP nt n) (ev ntimes stk top env ty)

204− ev ntimes stk top env (V i)

204+ ev ntimes stk top env (V i)

205 | i < length env && i >= 0 = return $ env !! i

206− | otherwise = return $ VV i

206+ | otherwise = return $ VV i

207 ev ntimes stk top env (Bind n (Let t v) sc)

208 = do v' <- ev ntimes stk top env v --(finalise v)

209 sc' <- ev ntimes stk top (v' : env) sc

210 wknV (-1) sc'

211−-- | otherwise

211+-- | otherwise

212-- = do t' <- ev ntimes stk top env t

213-- v' <- ev ntimes stk top env v --(finalise v)

214-- -- use Tmp as a placeholder, then make it a variable reference

@@ -223,40 +223,40 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

223 v' <- ev ntimes stk top env (finalise v)

224 sc' <- ev ntimes stk top (v' : env) sc

225 return $ VBind True n (Let t' v') (\x -> return sc')

226− ev ntimes stk top env (Bind n b sc)

226+ ev ntimes stk top env (Bind n b sc)

227 = do b' <- vbind env b

228 return $ VBind True -- (vinstances 0 sc < 2)

229 n b' (\x -> ev ntimes stk False (x:env) sc)

230− where vbind env t

230+ where vbind env t

231−-- | simpl

231+-- | simpl

232−-- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

232+-- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

233−-- stk top env (finalise tm)) t

233+-- stk top env (finalise tm)) t

234−-- | otherwise

234+-- | otherwise

235 = fmapMB (\tm -> ev ntimes stk top env (finalise tm)) t

236− ev ntimes stk top env (App f a)

236+ ev ntimes stk top env (App f a)

237 = do f' <- ev ntimes stk False env f

238 a' <- ev ntimes stk False env a

239 evApply ntimes stk top env [a'] f'

240 ev ntimes stk top env (Constant c) = return $ VConstant c

241 ev ntimes stk top env Erased = return VErased

242 ev ntimes stk top env (TType i) = return $ VType i

243−

243+

244 evApply ntimes stk top env args (VApp f a)

245 = evApply ntimes stk top env (a:args) f

246− evApply ntimes stk top env args f

246+ evApply ntimes stk top env args f

247 = apply ntimes stk top env f args

248

249− apply ntimes stk top env (VBind True n (Lam t) sc) (a:as)

249+ apply ntimes stk top env (VBind True n (Lam t) sc) (a:as)

250 = do a' <- sc a

251− app <- apply ntimes stk top env a' as

251+ app <- apply ntimes stk top env a' as

252 wknV (-1) app

253 apply ntimes_in stk top env f@(VP Ref n ty) args

254 | not top && hnf = case args of

255 [] -> return f

256 _ -> return $ unload env f args

257− | otherwise

257+ | otherwise

258 = do (u, ntimes) <- usable spec n ntimes_in

259− if u then

259+ if u then

260 do let val = lookupDefAcc n atRepl ctxt

261 case val of

262 [(CaseOp ci _ _ _ cd, acc)]

@@ -286,19 +286,19 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

286

287-- specApply stk env f@(VP Ref n ty) args

288-- = case lookupCtxt n statics of

289−-- [as] -> if or as

289+-- [as] -> if or as

290−-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $

290+-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $

291-- return $ unload env f args

292-- else return $ unload env f args

293-- _ -> return $ unload env f args

294-- specApply stk env f args = return $ unload env f args

295

296− unload :: [Value] -> Value -> [Value] -> Value

296+ unload :: [Value] -> Value -> [Value] -> Value

297 unload env f [] = f

298 unload env f (a:as) = unload env (VApp f a) as

299

300 evCase ntimes n stk top env ns args tree

301− | length ns <= length args

301+ | length ns <= length args

302 = do let args' = take (length ns) args

303 let rest = drop (length ns) args

304 when spec $ deduct n -- successful, so deduct usages

@@ -307,12 +307,12 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

307 return (t, rest)

308 | otherwise = return (Nothing, args)

309

310− evTree :: [(Name, Int)] -> [Name] -> Bool ->

310+ evTree :: [(Name, Int)] -> [Name] -> Bool ->

311 [Value] -> [(Name, Value)] -> SC -> Eval (Maybe Value)

312 evTree ntimes stk top env amap (UnmatchedCase str) = return Nothing

313− evTree ntimes stk top env amap (STerm tm)

313+ evTree ntimes stk top env amap (STerm tm)

314 = do let etm = pToVs (map fst amap) tm

315− etm' <- ev ntimes stk (not (conHeaded tm))

315+ etm' <- ev ntimes stk (not (conHeaded tm))

316 (map snd amap ++ env) etm

317 return $ Just etm'

318 evTree ntimes stk top env amap (Case n alts)

@@ -327,7 +327,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

327 _ -> return Nothing

328 evTree ntimes stk top env amap ImpossibleCase = return Nothing

329

330− conHeaded tm@(App _ _)

330+ conHeaded tm@(App _ _)

331 | (P (DCon _ _) _ _, args) <- unApply tm = True

332 conHeaded t = False

333

@@ -336,14 +336,14 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

336 chooseAlt env f' (getValArgs f')

337 alts amap

338

339− chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] ->

339+ chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] ->

340 [(Name, Value)] ->

341 Eval (Maybe ([(Name, Value)], SC))

342 chooseAlt env _ (VP (DCon i a) _ _, args) alts amap

343 | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc)

344 | Just v <- findDefault alts = return $ Just (amap, v)

345 chooseAlt env _ (VP (TCon i a) _ _, args) alts amap

346− | Just (ns, sc) <- findTag i alts

346+ | Just (ns, sc) <- findTag i alts

347 = return $ Just (updateAmap (zip ns args) amap, sc)

348 | Just v <- findDefault alts = return $ Just (amap, v)

349 chooseAlt env _ (VConstant c, []) alts amap

@@ -358,7 +358,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

358 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern

359 return $ Just (updateAmap (zip ns [s, t']) amap, sc)

360 chooseAlt _ _ _ alts amap

361− | Just v <- findDefault alts

361+ | Just v <- findDefault alts

362 = if (any fnCase alts)

363 then return $ Just (amap, v)

364 else return Nothing

@@ -370,7 +370,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

370 -- Replace old variable names in the map with new matches

371 -- (This is possibly unnecessary since we make unique names and don't

372 -- allow repeated variables...?)

373− updateAmap newm amap

373+ updateAmap newm amap

374 = newm ++ filter (\ (x, _) -> not (elem x (map fst newm))) amap

375 findTag i [] = Nothing

376 findTag i (ConCase n j ns sc : xs) | i == j = Just (ns, sc)

@@ -382,7 +382,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

382

383 findDefault [] = Nothing

384 findDefault (DefaultCase sc : xs) = Just sc

385− findDefault (_ : xs) = findDefault xs

385+ findDefault (_ : xs) = findDefault xs

386

387 findSuc c [] = Nothing

388 findSuc (BI val) (SucCase n sc : _)

@@ -393,10 +393,10 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

393 findConst c (ConstCase c' v : xs) | c == c' = Just v

394 findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v

395 findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v

396− findConst (AType (ATInt ITChar)) (ConCase n 3 [] v : xs) = Just v

396+ findConst (AType (ATInt ITChar)) (ConCase n 3 [] v : xs) = Just v

397− findConst StrType (ConCase n 4 [] v : xs) = Just v

397+ findConst StrType (ConCase n 4 [] v : xs) = Just v

398 findConst PtrType (ConCase n 5 [] v : xs) = Just v

399− findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v

399+ findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v

400 findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs)

401 | tag == 7 + fromEnum ity = Just v

402 findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs)

@@ -430,7 +430,7 @@ instance Quote Value where

430 b' <- quoteB b

431 liftM (Bind n b') (quote (i+1) sc')

432 where quoteB t = fmapMB (quote i) t

433− quote i (VBLet vd n t v sc)

433+ quote i (VBLet vd n t v sc)

434 = do sc' <- quote i sc

435 t' <- quote i t

436 v' <- quote i v

@@ -455,7 +455,7 @@ convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, [])

455convEq :: Context -> TT Name -> TT Name -> StateT UCs TC Bool

456convEq ctxt = ceq [] where

457 ceq :: [(Name, Name)] -> TT Name -> TT Name -> StateT UCs TC Bool

458− ceq ps (P xt x _) (P yt y _)

458+ ceq ps (P xt x _) (P yt y _)

459 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

460 | otherwise = sameDefs ps x y

461 ceq ps x (Bind n (Lam t) (App y (V 0))) = ceq ps x y

@@ -465,9 +465,9 @@ convEq ctxt = ceq [] where

465 ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y

466 | n == n' = ceq ps x y

467 ceq ps (V x) (V y) = return (x == y)

468− ceq ps (Bind _ xb xs) (Bind _ yb ys)

468+ ceq ps (Bind _ xb xs) (Bind _ yb ys)

469 = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys)

470− where

470+ where

471 ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

472 ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

473 ceqB ps b b' = ceq ps (binderTy b) (binderTy b')

@@ -501,7 +501,7 @@ convEq ctxt = ceq [] where

501 sameDefs ps x y = case (lookupDef x ctxt, lookupDef y ctxt) of

502 ([Function _ xdef], [Function _ ydef])

503 -> ceq ((x,y):ps) xdef ydef

504− ([CaseOp _ _ _ _ xd],

504+ ([CaseOp _ _ _ _ xd],

505 [CaseOp _ _ _ _ yd])

506 -> let (_, xdef) = cases_compiletime xd

507 (_, ydef) = cases_compiletime yd in

@@ -509,25 +509,25 @@ convEq ctxt = ceq [] where

509 _ -> return False

510

511-- SPECIALISATION -----------------------------------------------------------

512−-- We need too much control to be able to do this by tweaking the main

512+-- We need too much control to be able to do this by tweaking the main

513-- evaluator

514

515spec :: Context -> Ctxt [Bool] -> Env -> TT Name -> Eval (TT Name)

516−spec ctxt statics genv tm = error "spec undefined"

516+spec ctxt statics genv tm = error "spec undefined"

517

518-- CONTEXTS -----------------------------------------------------------------

519

520{-| A definition is either a simple function (just an expression with a type),

521 a constant, which could be a data or type constructor, an axiom or as an

522 yet undefined function, or an Operator.

523− An Operator is a function which explains how to reduce.

523+ An Operator is a function which explains how to reduce.

524 A CaseOp is a function defined by a simple case tree -}

525−

525+

526data Def = Function Type Term

527− | TyDecl NameType Type

527+ | TyDecl NameType Type

528 | Operator Type Int ([Value] -> Maybe Value)

529− | CaseOp CaseInfo

529+ | CaseOp CaseInfo

530− Type

530+ Type

531 [Either Term (Term, Term)] -- original definition

532 [([Name], Term, Term)] -- simplified for totality check definition

533 CaseDefs

@@ -546,13 +546,13 @@ data CaseInfo = CaseInfo {

546 tc_dictionary :: Bool

547 }

548

549−{-!

549+{-!

550−deriving instance Binary Def

550+deriving instance Binary Def

551!-}

552−{-!

552+{-!

553deriving instance Binary CaseInfo

554!-}

555−{-!

555+{-!

556deriving instance Binary CaseDefs

557!-}

558

@@ -560,11 +560,11 @@ instance Show Def where

560 show (Function ty tm) = "Function: " ++ show (ty, tm)

561 show (TyDecl nt ty) = "TyDecl: " ++ show nt ++ " " ++ show ty

562 show (Operator ty _ _) = "Operator: " ++ show ty

563− show (CaseOp (CaseInfo inlc inlr) ty ps_in ps cd)

563+ show (CaseOp (CaseInfo inlc inlr) ty ps_in ps cd)

564 = let (ns, sc) = cases_compiletime cd

565− (ns_t, sc_t) = cases_totcheck cd

565+ (ns_t, sc_t) = cases_totcheck cd

566 (ns', sc') = cases_runtime cd in

567− "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++

567+ "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++

568 "TOTALITY CHECK TIME:\n\n" ++

569 show ns_t ++ " " ++ show sc_t ++ "\n\n" ++

570 "COMPILE TIME:\n\n" ++

@@ -580,7 +580,7 @@ instance Binary (a -> b) where

580 put x = return ()

581 get = error "Getting a function"

582

583−-------

583+-------

584

585-- Frozen => doesn't reduce

586-- Hidden => doesn't reduce and invisible to type checker

@@ -610,7 +610,7 @@ instance Show Totality where

610 show (Partial NotProductive) = "not productive"

611 show (Partial BelieveMe) = "not total due to use of believe_me in proof"

612 show (Partial (Other ns)) = "possibly not total due to: " ++ showSep ", " (map show ns)

613− show (Partial (Mutual ns)) = "possibly not total due to recursive path " ++

613+ show (Partial (Mutual ns)) = "possibly not total due to recursive path " ++

614 showSep " --> " (map show ns)

615

616{-!

@@ -627,10 +627,10 @@ deriving instance Binary PReason

627

628-- | Contexts used for global definitions and for proof state. They contain

629-- universe constraints and existing definitions.

630−data Context = MkContext {

630+data Context = MkContext {

631 uconstraints :: [UConstraint],

632 next_tvar :: Int,

633− definitions :: Ctxt (Def, Accessibility, Totality)

633+ definitions :: Ctxt (Def, Accessibility, Totality)

634 } deriving Show

635

636-- | The initial empty context

@@ -643,10 +643,10 @@ ctxtAlist ctxt = map (\(n, (d, a, t)) -> (n, d)) $ toAlist (definitions ctxt)

643veval ctxt env t = evalState (eval False ctxt [] env t []) initEval

644

645addToCtxt :: Name -> Term -> Type -> Context -> Context

646−addToCtxt n tm ty uctxt

646+addToCtxt n tm ty uctxt

647− = let ctxt = definitions uctxt

647+ = let ctxt = definitions uctxt

648 ctxt' = addDef n (Function ty tm, Public, Unchecked) ctxt in

649− uctxt { definitions = ctxt' }

649+ uctxt { definitions = ctxt' }

650

651setAccess :: Name -> Accessibility -> Context -> Context

652setAccess n a uctxt

@@ -666,54 +666,54 @@ addCtxtDef n d c = let ctxt = definitions c

666 c { definitions = ctxt' }

667

668addTyDecl :: Name -> NameType -> Type -> Context -> Context

669−addTyDecl n nt ty uctxt

669+addTyDecl n nt ty uctxt

670 = let ctxt = definitions uctxt

671 ctxt' = addDef n (TyDecl nt ty, Public, Unchecked) ctxt in

672 uctxt { definitions = ctxt' }

673

674addDatatype :: Datatype Name -> Context -> Context

675addDatatype (Data n tag ty cons) uctxt

676− = let ctxt = definitions uctxt

676+ = let ctxt = definitions uctxt

677 ty' = normalise uctxt [] ty

678− ctxt' = addCons 0 cons (addDef n

678+ ctxt' = addCons 0 cons (addDef n

679 (TyDecl (TCon tag (arity ty')) ty, Public, Unchecked) ctxt) in

680 uctxt { definitions = ctxt' }

681 where

682 addCons tag [] ctxt = ctxt

683− addCons tag ((n, ty) : cons) ctxt

683+ addCons tag ((n, ty) : cons) ctxt

684 = let ty' = normalise uctxt [] ty in

685 addCons (tag+1) cons (addDef n

686 (TyDecl (DCon tag (arity ty')) ty, Public, Unchecked) ctxt)

687

688-- FIXME: Too many arguments! Refactor all these Bools.

689addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

690− [Either Term (Term, Term)] ->

690+ [Either Term (Term, Term)] ->

691 [([Name], Term, Term)] -> -- totality

692 [([Name], Term, Term)] -> -- compile time

693− [([Name], Term, Term)] -> -- inlined

693+ [([Name], Term, Term)] -> -- inlined

694 [([Name], Term, Term)] -> -- run time

695 Type -> Context -> Context

696addCasedef n ci@(CaseInfo alwaysInline tcdict)

697− tcase covering reflect asserted ps_in

697+ tcase covering reflect asserted ps_in

698− ps_tot ps_inl ps_ct ps_rt ty uctxt

698+ ps_tot ps_inl ps_ct ps_rt ty uctxt

699 = let ctxt = definitions uctxt

700 access = case lookupDefAcc n False uctxt of

701 [(_, acc)] -> acc

702 _ -> Public

703 ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC ps_tot,

704− simpleCase tcase covering reflect CompileTime emptyFC ps_ct,

704+ simpleCase tcase covering reflect CompileTime emptyFC ps_ct,

705− simpleCase tcase covering reflect CompileTime emptyFC ps_inl,

705+ simpleCase tcase covering reflect CompileTime emptyFC ps_inl,

706 simpleCase tcase covering reflect RunTime emptyFC ps_rt) of

707− (OK (CaseDef args_tot sc_tot _),

707+ (OK (CaseDef args_tot sc_tot _),

708 OK (CaseDef args_ct sc_ct _),

709 OK (CaseDef args_inl sc_inl _),

710− OK (CaseDef args_rt sc_rt _)) ->

710+ OK (CaseDef args_rt sc_rt _)) ->

711 let inl = alwaysInline -- || tcdict

712− inlc = (inl || small n args_ct sc_ct) && (not asserted)

712+ inlc = (inl || small n args_ct sc_ct) && (not asserted)

713 inlr = inl || small n args_rt sc_rt

714− cdef = CaseDefs (args_tot, sc_tot)

714+ cdef = CaseDefs (args_tot, sc_tot)

715− (args_ct, sc_ct)

715+ (args_ct, sc_ct)

716− (args_inl, sc_inl)

716+ (args_inl, sc_inl)

717 (args_rt, sc_rt) in

718 addDef n (CaseOp (ci { case_inlinable = inlc })

719 ty ps_in ps_tot cdef,

@@ -732,17 +732,17 @@ simplifyCasedef n uctxt

732 pdef = map debind ps_in' in

733 case simpleCase False True False CompileTime emptyFC pdef of

734 OK (CaseDef args sc _) ->

735− addDef n (CaseOp ci

735+ addDef n (CaseOp ci

736 ty ps_in' ps (cd { cases_totcheck = (args, sc) }),

737− acc, tot) ctxt

737+ acc, tot) ctxt

738 Error err -> error (show err)

739 _ -> ctxt in

740 uctxt { definitions = ctxt' }

741− where

741+ where

742− depat acc (Bind n (PVar t) sc)

742+ depat acc (Bind n (PVar t) sc)

743 = depat (n : acc) (instantiate (P Bound n t) sc)

744 depat acc x = (acc, x)

745− debind (Right (x, y)) = let (vs, x') = depat [] x

745+ debind (Right (x, y)) = let (vs, x') = depat [] x

746 (_, y') = depat [] y in

747 (vs, x', y')

748 debind (Left x) = let (vs, x') = depat [] x in

@@ -750,10 +750,10 @@ simplifyCasedef n uctxt

750 simpl (Right (x, y)) = Right (x, simplify uctxt [] y)

751 simpl t = t

752

753−addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) ->

753+addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) ->

754 Context -> Context

755addOperator n ty a op uctxt

756− = let ctxt = definitions uctxt

756+ = let ctxt = definitions uctxt

757 ctxt' = addDef n (Operator ty a op, Public, Unchecked) ctxt in

758 uctxt { definitions = ctxt' }

759

@@ -836,7 +836,7 @@ lookupVal n ctxt

836lookupTyEnv :: Name -> Env -> Maybe (Int, Type)

837lookupTyEnv n env = li n 0 env where

838 li n i [] = Nothing

839− li n i ((x, b): xs)

839+ li n i ((x, b): xs)

840 | n == x = Just (i, binderTy b)

841 | otherwise = li n (i+1) xs

842

src/Core/Execute.hs+7−7

@@ -247,15 +247,15 @@ execApp' env ctxt con@(EP _ (UN "prim_io_return") _) args@(tp:v:rest) =

247

248-- Special cases arising from not having access to the C RTS in the interpreter

249execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str arg):_:rest)

250− | Just (FFun "putStr" _ _) <- foreignFromTT fn

250+ | Just (FFun "putStr" _ _) <- foreignFromTT fn

251 = do execIO (putStr arg)

252 execApp' env ctxt ioUnit rest

253execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:_:EHandle h:_:rest)

254− | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

254+ | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

255 = do contents <- execIO $ hGetLine h

256 execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

257execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

258− | Just (FFun "fileOpen" _ _) <- foreignFromTT fn

258+ | Just (FFun "fileOpen" _ _) <- foreignFromTT fn

259 = do m <- case mode of

260 "r" -> return ReadMode

261 "w" -> return WriteMode

@@ -268,25 +268,25 @@ execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstan

268 execApp' env ctxt (ioWrap (EHandle h)) (tail rest)

269

270execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

271− | Just (FFun "fileEOF" _ _) <- foreignFromTT fn

271+ | Just (FFun "fileEOF" _ _) <- foreignFromTT fn

272 = do eofp <- execIO $ hIsEOF h

273 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

274 execApp' env ctxt res (tail rest)

275

276execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

277− | Just (FFun "fileClose" _ _) <- foreignFromTT fn

277+ | Just (FFun "fileClose" _ _) <- foreignFromTT fn

278 = do execIO $ hClose h

279 execApp' env ctxt ioUnit (tail rest)

280

281execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EPtr p):rest)

282− | Just (FFun "isNull" _ _) <- foreignFromTT fn

282+ | Just (FFun "isNull" _ _) <- foreignFromTT fn

283 = let res = ioWrap . EConstant . I $

284 if p == nullPtr then 1 else 0

285 in execApp' env ctxt res (tail rest)

286

287-- Throw away the 'World' argument to the foreign function

288

289−execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs)

289+execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs)

290 | Just (FFun f argTs retT) <- foreignFromTT fn

291 , length xs >= length argTs =

292 do let (args', xs') = (take (length argTs) xs, -- foreign args

src/Core/ProofShell.hs+11−11

@@ -15,7 +15,7 @@ import Idris.AbsSyntaxTree (Idris)

15

16import Util.Pretty

17

18−data ShellState = ShellState

18+data ShellState = ShellState

19 { ctxt :: Context,

20 prf :: Maybe ProofState,

21 deferred :: [(Name, ProofState)],

@@ -25,18 +25,18 @@ data ShellState = ShellState

25initState c = ShellState c Nothing [] False

26

27processCommand :: Command -> ShellState -> (ShellState, String)

28−processCommand (Theorem n ty) state

28+processCommand (Theorem n ty) state

29 = case check (ctxt state) [] ty of

30− OK (gl, t) ->

30+ OK (gl, t) ->

31 case isType (ctxt state) [] t of

32 OK _ -> (state { prf = Just (newProof n (ctxt state) gl) }, "")

33 _ -> (state, "Goal is not a type")

34 err -> (state, show err)

35processCommand Quit state = (state { exitNow = True }, "Bye bye")

36−processCommand (Eval t) state =

36+processCommand (Eval t) state =

37 case check (ctxt state) [] t of

38 OK (val, ty) ->

39− let nf = normalise (ctxt state) [] val

39+ let nf = normalise (ctxt state) [] val

40 tnf = normalise (ctxt state) [] ty in

41 (state, show nf ++ " : " ++ show ty)

42 err -> (state, show err)

@@ -44,10 +44,10 @@ processCommand (Print n) state =

44 case lookupDef n (ctxt state) of

45 [tm] -> (state, show tm)

46 _ -> (state, "No such name")

47−processCommand (Tac e) state

47+processCommand (Tac e) state

48 | Just ps <- prf state = case execElab () e ps of

49− OK (ES (ps', _) resp _) ->

49+ OK (ES (ps', _) resp _) ->

50− if (not (done ps'))

50+ if (not (done ps'))

51 then (state { prf = Just ps' }, resp)

52 else (state { prf = Nothing,

53 ctxt = addToCtxt (thname ps')

@@ -60,10 +60,10 @@ processCommand (Tac e) state

60runShell :: ShellState -> Idris ShellState

61runShell st = runInputT defaultSettings $ runShell' st

62 where

63− runShell' st = do (prompt, parser) <-

63+ runShell' st = do (prompt, parser) <-

64− maybe (return ("TT# ", parseCommand))

64+ maybe (return ("TT# ", parseCommand))

65 (\st -> do outputStrLn . render . pretty $ st

66− return (show (thname st) ++ "# ", parseTactic))

66+ return (show (thname st) ++ "# ", parseTactic))

67 (prf st)

68 x <- getInputLine prompt

69 cmd <- case x of

src/Core/ProofState.hs+104−104

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

5 evaluation/checking inside the proof system, etc. --}

6

7module Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,

8− Tactic(..), Goal(..), processTactic,

8+ Tactic(..), Goal(..), processTactic,

9 dropGiven, keepGiven) where

10

11import Core.Typecheck

@@ -31,7 +31,7 @@ data ProofState = PS { thname :: Name,

31 notunified :: [(Name, Term)],

32 solved :: Maybe (Name, Term),

33 problems :: Fails,

34− injective :: [Name],

34+ injective :: [Name],

35 deferred :: [Name], -- names we'll need to define

36 instances :: [Name], -- instance arguments (for type classes)

37 previous :: Maybe ProofState, -- for undo

@@ -40,7 +40,7 @@ data ProofState = PS { thname :: Name,

40 unifylog :: Bool,

41 done :: Bool

42 }

43−

43+

44data Goal = GD { premises :: Env,

45 goalType :: Binder Term

46 }

@@ -88,27 +88,27 @@ data Tactic = Attack

88-- Some utilites on proof and tactic states

89

90instance Show ProofState where

91− show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _)

91+ show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _)

92 = show nm ++ ": no more goals"

93− show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _)

93+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _)

94 = let OK g = goal (Just h) tm

95 wkenv = premises g in

96 "Other goals: " ++ show hs ++ "\n" ++

97 showPs wkenv (reverse wkenv) ++ "\n" ++

98− "-------------------------------- (" ++ show nm ++

98+ "-------------------------------- (" ++ show nm ++

99 ") -------\n " ++

100 show h ++ " : " ++ showG wkenv (goalType g) ++ "\n"

101 where showPs env [] = ""

102− showPs env ((n, Let t v):bs)

102+ showPs env ((n, Let t v):bs)

103− = " " ++ show n ++ " : " ++

103+ = " " ++ show n ++ " : " ++

104 showEnv env ({- normalise ctxt env -} t) ++ " = " ++

105 showEnv env ({- normalise ctxt env -} v) ++

106 "\n" ++ showPs env bs

107− showPs env ((n, b):bs)

107+ showPs env ((n, b):bs)

108− = " " ++ show n ++ " : " ++

108+ = " " ++ show n ++ " : " ++

109− showEnv env ({- normalise ctxt env -} (binderTy b)) ++

109+ showEnv env ({- normalise ctxt env -} (binderTy b)) ++

110 "\n" ++ showPs env bs

111− showG ps (Guess t v) = showEnv ps ({- normalise ctxt ps -} t) ++

111+ showG ps (Guess t v) = showEnv ps ({- normalise ctxt ps -} t) ++

112 " =?= " ++ showEnv ps v

113 showG ps b = showEnv ps (binderTy b)

114

@@ -130,7 +130,7 @@ instance Pretty ProofState where

130 if size v > breakingSize then

131 prettyEnv ps t <+> text "=?=" $$

132 nest nestingSize (prettyEnv ps v)

133− else

133+ else

134 prettyEnv ps t <+> text "=?=" <+> prettyEnv ps v

135 prettyGoal ps b = prettyEnv ps $ binderTy b

136

@@ -158,14 +158,14 @@ hole (Hole _) = True

158hole (Guess _ _) = True

159hole _ = False

160

161−holeName i = MN i "hole"

161+holeName i = MN i "hole"

162

163qshow :: Fails -> String

164−qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

164+qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

165

166−match_unify' :: Context -> Env -> TT Name -> TT Name ->

166+match_unify' :: Context -> Env -> TT Name -> TT Name ->

167 StateT TState TC [(Name, TT Name)]

168−match_unify' ctxt env topx topy =

168+match_unify' ctxt env topx topy =

169 do ps <- get

170 let dont = dontunify ps

171 u <- lift $ match_unify ctxt env topx topy dont (holes ps)

@@ -173,34 +173,34 @@ match_unify' ctxt env topx topy =

173 put (ps { unified = (h, u ++ ns) })

174 return u

175

176−unify' :: Context -> Env -> TT Name -> TT Name ->

176+unify' :: Context -> Env -> TT Name -> TT Name ->

177 StateT TState TC [(Name, TT Name)]

178−unify' ctxt env topx topy =

178+unify' ctxt env topx topy =

179 do ps <- get

180 let dont = dontunify ps

181− (u, fails) <- traceWhen (unifylog ps)

181+ (u, fails) <- traceWhen (unifylog ps)

182 ("Trying " ++ show (topx, topy) ++

183− " in " ++ show env ++

183+ " in " ++ show env ++

184− "\nHoles: " ++ show (holes ps) ++ "\n") $

184+ "\nHoles: " ++ show (holes ps) ++ "\n") $

185 lift $ unify ctxt env topx topy dont (holes ps)

186 traceWhen (unifylog ps)

187 ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

188− "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

188+ "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

189 ++ "\nCurrent problems:\n" ++ qshow (problems ps)

190−-- ++ show (pterm ps)

190+-- ++ show (pterm ps)

191 ++ "\n----------") $

192 case fails of

193-- [] -> return u

194− err ->

194+ err ->

195 do ps <- get

196 let (h, ns) = unified ps

197− let (ns', probs') = updateProblems (context ps) (u ++ ns)

197+ let (ns', probs') = updateProblems (context ps) (u ++ ns)

198 (err ++ problems ps)

199 (injective ps)

200 (holes ps)

201 put (ps { problems = probs',

202 unified = (h, ns') })

203− return u

203+ return u

204

205getName :: Monad m => String -> StateT TState m Name

206getName tag = do ps <- get

@@ -216,9 +216,9 @@ addLog :: Monad m => String -> StateT TState m ()

216addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

217

218newProof :: Name -> Context -> Type -> ProofState

219−newProof n ctxt ty = let h = holeName 0

219+newProof n ctxt ty = let h = holeName 0

220 ty' = vToP ty in

221− PS n [h] [] 1 (Bind h (Hole ty')

221+ PS n [h] [] 1 (Bind h (Hole ty')

222 (P Bound h ty')) ty [] (h, []) []

223 Nothing [] []

224 [] []

@@ -229,7 +229,7 @@ type RunTactic = Context -> Env -> Term -> StateT TState TC Term

229type Hole = Maybe Name -- Nothing = default hole, first in list in proof state

230

231envAtFocus :: ProofState -> TC Env

232−envAtFocus ps

232+envAtFocus ps

233 | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps)

234 return (premises g)

235 | otherwise = fail "No holes"

@@ -242,12 +242,12 @@ goalAtFocus ps

242

243goal :: Hole -> Term -> TC Goal

244goal h tm = g [] tm where

245− g env (Bind n b@(Guess _ _) sc)

245+ g env (Bind n b@(Guess _ _) sc)

246− | same h n = return $ GD env b

246+ | same h n = return $ GD env b

247− | otherwise

247+ | otherwise

248− = gb env b `mplus` g ((n, b):env) sc

248+ = gb env b `mplus` g ((n, b):env) sc

249− g env (Bind n b sc) | hole b && same h n = return $ GD env b

249+ g env (Bind n b sc) | hole b && same h n = return $ GD env b

250− | otherwise

250+ | otherwise

251 = g ((n, b):env) sc `mplus` gb env b

252 g env (App f a) = g env f `mplus` g env a

253 g env t = fail "Can't find hole"

@@ -265,7 +265,7 @@ tactic h f = do ps <- get

265 updated o = do o' <- o

266 return (o', True)

267

268− ulift2 c env op a b

268+ ulift2 c env op a b

269 = do (b', u) <- atH c env b

270 if u then return (op a b', True)

271 else do (a', u) <- atH c env a

@@ -274,15 +274,15 @@ tactic h f = do ps <- get

274 -- Search the things most likely to contain the binding first!

275

276 atH :: Context -> Env -> Term -> StateT TState TC (Term, Bool)

277− atH c env binder@(Bind n b@(Guess t v) sc)

277+ atH c env binder@(Bind n b@(Guess t v) sc)

278 | same h n = updated (f c env binder)

279− | otherwise

279+ | otherwise

280 = do -- binder first

281 (b', u) <- ulift2 c env Guess t v

282 if u then return (Bind n b' sc, True)

283 else do (sc', u) <- atH c ((n, b) : env) sc

284 return (Bind n b' sc', u)

285− atH c env binder@(Bind n b sc)

285+ atH c env binder@(Bind n b sc)

286 | hole b && same h n = updated (f c env binder)

287 | otherwise -- scope first

288 = do (sc', u) <- atH c ((n, b) : env) sc

@@ -291,8 +291,8 @@ tactic h f = do ps <- get

291 return (Bind n b' sc', u)

292 atH c env (App f a) = ulift2 c env App f a

293 atH c env t = return (t, False)

294−

294+

295− atHb c env (Let t v) = ulift2 c env Let t v

295+ atHb c env (Let t v) = ulift2 c env Let t v

296 atHb c env (Guess t v) = ulift2 c env Guess t v

297 atHb c env t = do (ty', u) <- atH c env (binderTy t)

298 return (t { binderTy = ty' }, u)

@@ -307,12 +307,12 @@ computeLet ctxt n tm = cl [] tm where

307 cl env t = t

308

309attack :: RunTactic

310−attack ctxt env (Bind x (Hole t) sc)

310+attack ctxt env (Bind x (Hole t) sc)

311 = do h <- getName "hole"

312 action (\ps -> ps { holes = h : holes ps })

313 return $ Bind x (Guess t (newtm h)) sc

314 where

315− newtm h = Bind h (Hole t) (P Bound h t)

315+ newtm h = Bind h (Hole t) (P Bound h t)

316attack ctxt env _ = fail "Not an attackable hole"

317

318claim :: Name -> Raw -> RunTactic

@@ -325,7 +325,7 @@ claim n ty ctxt env t =

325

326reorder_claims :: RunTactic

327reorder_claims ctxt env t

328− = -- trace (showSep "\n" (map show (scvs t))) $

328+ = -- trace (showSep "\n" (map show (scvs t))) $

329 let (bs, sc) = scvs t []

330 newbs = reverse (sortB (reverse bs)) in

331 traceWhen (bs /= newbs) (show bs ++ "\n ==> \n" ++ show newbs) $

@@ -352,14 +352,14 @@ focus n ctxt env t = do action (\ps -> let hs = holes ps in

352 then ps { holes = n : (hs \\ [n]) }

353 else ps)

354 ps <- get

355− return t

355+ return t

356

357movelast :: Name -> RunTactic

358movelast n ctxt env t = do action (\ps -> let hs = holes ps in

359 if n `elem` hs

360 then ps { holes = (hs \\ [n]) ++ [n] }

361 else ps)

362− return t

362+ return t

363

364instanceArg :: Name -> RunTactic

365instanceArg n ctxt env (Bind x (Hole t) sc)

@@ -376,10 +376,10 @@ setinj n ctxt env (Bind x (Hole t) sc)

376 return (Bind x (Hole t) sc)

377

378defer :: Name -> RunTactic

379−defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =

379+defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =

380 do action (\ps -> let hs = holes ps in

381 ps { holes = hs \\ [x] })

382− return (Bind n (GHole (length env) (mkTy (reverse env) t))

382+ return (Bind n (GHole (length env) (mkTy (reverse env) t))

383 (mkApp (P Ref n ty) (map getP (reverse env))))

384 where

385 mkTy [] t = t

@@ -389,13 +389,13 @@ defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =

389

390-- as defer, but build the type and application explicitly

391deferType :: Name -> Raw -> [Name] -> RunTactic

392−deferType n fty_in args ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =

392+deferType n fty_in args ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =

393 do (fty, _) <- lift $ check ctxt env fty_in

394− action (\ps -> let hs = holes ps

394+ action (\ps -> let hs = holes ps

395 ds = deferred ps in

396 ps { holes = hs \\ [x],

397 deferred = n : ds })

398− return (Bind n (GHole 0 fty)

398+ return (Bind n (GHole 0 fty)

399 (mkApp (P Ref n ty) (map getP args)))

400 where

401 getP n = case lookup n env of

@@ -407,12 +407,12 @@ regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc =

407 do action (\ps -> let hs = holes ps in

408 ps { holes = hs \\ [x] })

409 return sc

410−regret ctxt env (Bind x (Hole t) _)

410+regret ctxt env (Bind x (Hole t) _)

411 = fail $ show x ++ " : " ++ show t ++ " is not solved..."

412

413exact :: Raw -> RunTactic

414−exact guess ctxt env (Bind x (Hole ty) sc) =

414+exact guess ctxt env (Bind x (Hole ty) sc) =

415− do (val, valty) <- lift $ check ctxt env guess

415+ do (val, valty) <- lift $ check ctxt env guess

416 lift $ converts ctxt env valty ty

417 return $ Bind x (Guess ty val) sc

418exact _ _ _ _ = fail "Can't fill here."

@@ -420,7 +420,7 @@ exact _ _ _ _ = fail "Can't fill here."

420-- As exact, but attempts to solve other goals by unification

421

422fill :: Raw -> RunTactic

423−fill guess ctxt env (Bind x (Hole ty) sc) =

423+fill guess ctxt env (Bind x (Hole ty) sc) =

424 do (val, valty) <- lift $ check ctxt env guess

425-- let valtyn = normalise ctxt env valty

426-- let tyn = normalise ctxt env ty

@@ -435,7 +435,7 @@ fill _ _ _ _ = fail "Can't fill here."

435-- As fill, but attempts to solve other goals by matching

436

437match_fill :: Raw -> RunTactic

438−match_fill guess ctxt env (Bind x (Hole ty) sc) =

438+match_fill guess ctxt env (Bind x (Hole ty) sc) =

439 do (val, valty) <- lift $ check ctxt env guess

440-- let valtyn = normalise ctxt env valty

441-- let tyn = normalise ctxt env ty

@@ -456,7 +456,7 @@ prep_fill f as ctxt env t = fail $ "Can't prepare fill at " ++ show t

456complete_fill :: RunTactic

457complete_fill ctxt env (Bind x (Guess ty val) sc) =

458 do let guess = forget val

459− (val', valty) <- lift $ check ctxt env guess

459+ (val', valty) <- lift $ check ctxt env guess

460 ns <- unify' ctxt env valty ty

461 ps <- get

462 let (uh, uns) = unified ps

@@ -473,13 +473,13 @@ solve ctxt env (Bind x (Guess ty val) sc)

473 | True = do ps <- get

474 let (uh, uns) = unified ps

475 case lookup x (notunified ps) of

476− Just tm -> do -- trace ("AVOIDED " ++ show (x, tm, val)) $

476+ Just tm -> do -- trace ("AVOIDED " ++ show (x, tm, val)) $

477 -- return []

478 unify' ctxt env tm val

479 _ -> return []

480 action (\ps -> ps { holes = holes ps \\ [x],

481 solved = Just (x, val),

482−-- problems = solveInProblems

482+-- problems = solveInProblems

483-- x val (problems ps),

484 -- dontunify = dontunify ps \\ [x],

485 -- unified = (uh, uns ++ [(x, val)]),

@@ -487,13 +487,13 @@ solve ctxt env (Bind x (Guess ty val) sc)

487 let tm' = instantiate val (pToV x sc) in

488 return tm'

489 | otherwise = lift $ tfail $ IncompleteTerm val

490−solve _ _ h@(Bind x t sc)

490+solve _ _ h@(Bind x t sc)

491 = do ps <- get

492 fail $ "Not a guess " ++ show h ++ "\n" ++ show (holes ps, pterm ps)

493

494introTy :: Raw -> Maybe Name -> RunTactic

495introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

496− do let n = case mn of

496+ do let n = case mn of

497 Just name -> name

498 Nothing -> x

499 let t' = case t of

@@ -513,7 +513,7 @@ introTy ty n ctxt env _ = fail "Can't introduce here."

513

514intro :: Maybe Name -> RunTactic

515intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

516− do let n = case mn of

516+ do let n = case mn of

517 Just name -> name

518 Nothing -> x

519 let t' = case t of

@@ -521,7 +521,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

521 _ -> hnf ctxt env t

522 case t' of

523 Bind y (Pi s) t -> -- trace ("in type " ++ show t') $

524− let t' = instantiate (P Bound n s) (pToV y t) in

524+ let t' = instantiate (P Bound n s) (pToV y t) in

525 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

526 _ -> lift $ tfail $ CantIntroduce t'

527intro n ctxt env _ = fail "Can't introduce here."

@@ -529,7 +529,7 @@ intro n ctxt env _ = fail "Can't introduce here."

529forall :: Name -> Raw -> RunTactic

530forall n ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

531 do (tyv, tyt) <- lift $ check ctxt env ty

532− unify' ctxt env tyt (TType (UVar 0))

532+ unify' ctxt env tyt (TType (UVar 0))

533 return $ Bind n (Pi tyv) (Bind x (Hole t) (P Bound x t))

534forall n ty ctxt env _ = fail "Can't pi bind here"

535

@@ -548,7 +548,7 @@ letbind n ty val ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

548letbind n ty val ctxt env _ = fail "Can't let bind here"

549

550expandLet :: Name -> Term -> RunTactic

551−expandLet n v ctxt env tm =

551+expandLet n v ctxt env tm =

552 return $ subst n v tm

553

554rewrite :: Raw -> RunTactic

@@ -558,8 +558,8 @@ rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

558 case unApply tmt' of

559 (P _ (UN "=") _, [lt,rt,l,r]) ->

560 do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t)

561− let newt = mkP l r l t

561+ let newt = mkP l r l t

562− let sc = forget $ (Bind x (Hole newt)

562+ let sc = forget $ (Bind x (Hole newt)

563 (mkApp (P Ref (UN "replace") (TType (UVal 0)))

564 [lt, l, r, p, tmv, xp]))

565 (scv, sct) <- lift $ check ctxt env sc

@@ -572,14 +572,14 @@ rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

572 mkP lt l r (App f a) = let f' = if (r /= f) then mkP lt l r f else f

573 a' = if (r /= a) then mkP lt l r a else a in

574 App f' a'

575− mkP lt l r (Bind n b sc)

575+ mkP lt l r (Bind n b sc)

576− = let b' = mkPB b

576+ = let b' = mkPB b

577 sc' = if (r /= sc) then mkP lt l r sc else sc in

578 Bind n b' sc'

579 where mkPB (Let t v) = let t' = if (r /= t) then mkP lt l r t else t

580 v' = if (r /= v) then mkP lt l r v else v in

581 Let t' v'

582− mkPB b = let ty = binderTy b

582+ mkPB b = let ty = binderTy b

583 ty' = if (r /= ty) then mkP lt l r ty else ty in

584 b { binderTy = ty' }

585 mkP lt l r x = x

@@ -609,11 +609,11 @@ compute :: RunTactic

609compute ctxt env (Bind x (Hole ty) sc) =

610 do return $ Bind x (Hole (normalise ctxt env ty)) sc

611compute ctxt env t = return t

612−

612+

613hnf_compute :: RunTactic

614−hnf_compute ctxt env (Bind x (Hole ty) sc) =

614+hnf_compute ctxt env (Bind x (Hole ty) sc) =

615 do let ty' = hnf ctxt env ty in

616−-- trace ("HNF " ++ show (ty, ty')) $

616+-- trace ("HNF " ++ show (ty, ty')) $

617 return $ Bind x (Hole ty') sc

618hnf_compute ctxt env t = return t

619

@@ -622,23 +622,23 @@ simplify :: RunTactic

622simplify ctxt env (Bind x (Hole ty) sc) =

623 do return $ Bind x (Hole (specialise ctxt env [] ty)) sc

624simplify ctxt env t = return t

625−

625+

626check_in :: Raw -> RunTactic

627−check_in t ctxt env tm =

627+check_in t ctxt env tm =

628 do (val, valty) <- lift $ check ctxt env t

629 addLog (showEnv env val ++ " : " ++ showEnv env valty)

630 return tm

631

632eval_in :: Raw -> RunTactic

633−eval_in t ctxt env tm =

633+eval_in t ctxt env tm =

634 do (val, valty) <- lift $ check ctxt env t

635 let val' = normalise ctxt env val

636 let valty' = normalise ctxt env valty

637− addLog (showEnv env val ++ " : " ++

637+ addLog (showEnv env val ++ " : " ++

638− showEnv env valty ++

638+ showEnv env valty ++

639−-- " in " ++ show env ++

639+-- " in " ++ show env ++

640 " ==>\n " ++

641− showEnv env val' ++ " : " ++

641+ showEnv env val' ++ " : " ++

642 showEnv env valty')

643 return tm

644

@@ -649,7 +649,7 @@ start_unify n ctxt env tm = do -- action (\ps -> ps { unified = (n, []) })

649tmap f (a, b, c) = (f a, b, c)

650

651solve_unified :: RunTactic

652−solve_unified ctxt env tm =

652+solve_unified ctxt env tm =

653 do ps <- get

654 let (_, ns) = unified ps

655 let unify = dropGiven (dontunify ps) ns (holes ps)

@@ -663,7 +663,7 @@ dropGiven du ((n, P Bound t ty) : us) hs

663 | n `elem` du && not (t `elem` du)

664 && n `elem` hs && t `elem` hs

665 = (t, P Bound n ty) : dropGiven du us hs

666−dropGiven du (u@(n, _) : us) hs

666+dropGiven du (u@(n, _) : us) hs

667 | n `elem` du = dropGiven du us hs

668-- dropGiven du (u@(_, P a n ty) : us) | n `elem` du = dropGiven du us

669dropGiven du (u : us) hs = u : dropGiven du us hs

@@ -673,15 +673,15 @@ keepGiven du ((n, P Bound t ty) : us) hs

673 | n `elem` du && not (t `elem` du)

674 && n `elem` hs && t `elem` hs

675 = keepGiven du us hs

676−keepGiven du (u@(n, _) : us) hs

676+keepGiven du (u@(n, _) : us) hs

677 | n `elem` du = u : keepGiven du us hs

678keepGiven du (u : us) hs = keepGiven du us hs

679

680−updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

680+updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

681 updateSolved' xs x

682updateSolved' xs (Bind n (Hole ty) t)

683 | Just v <- lookup n xs = instantiate v (pToV n (updateSolved' xs t))

684−updateSolved' xs (Bind n b t)

684+updateSolved' xs (Bind n b t)

685 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

686updateSolved' xs (App f a) = App (updateSolved' xs f) (updateSolved' xs a)

687updateSolved' xs (P _ n _)

@@ -704,11 +704,11 @@ updateProblems ctxt ns ps inj holes = up ns ps where

704 up ns [] = (ns, [])

705 up ns ((x, y, env, err) : ps) =

706 let x' = updateSolved ns x

707− y' = updateSolved ns y

707+ y' = updateSolved ns y

708 err' = updateError ns err

709 env' = updateEnv ns env in

710 case unify ctxt env' x' y' inj holes of

711− OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

711+ OK (v, []) -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

712 up (ns ++ v) ps

713 _ -> let (ns', ps') = up ns ps in

714 (ns', (x',y',env',err') : ps')

@@ -718,11 +718,11 @@ matchProblems ctxt ps inj holes = up [] ps where

718 up ns [] = (ns, [])

719 up ns ((x, y, env, err) : ps) =

720 let x' = updateSolved ns x

721− y' = updateSolved ns y

721+ y' = updateSolved ns y

722 err' = updateError ns err

723 env' = updateEnv ns env in

724 case match_unify ctxt env' x' y' inj holes of

725− OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

725+ OK v -> -- trace ("Added " ++ show v ++ " from " ++ show (x', y')) $

726 up (ns ++ v) ps

727 _ -> let (ns', ps') = up ns ps in

728 (ns', (x',y',env',err') : ps')

@@ -731,60 +731,60 @@ processTactic :: Tactic -> ProofState -> TC (ProofState, String)

731processTactic QED ps = case holes ps of

732 [] -> do let tm = {- normalise (context ps) [] -} (pterm ps)

733 (tm', ty', _) <- recheck (context ps) [] (forget tm) tm

734− return (ps { done = True, pterm = tm' },

734+ return (ps { done = True, pterm = tm' },

735 "Proof complete: " ++ showEnv [] tm')

736 _ -> fail "Still holes to fill."

737processTactic ProofState ps = return (ps, showEnv [] (pterm ps))

738processTactic Undo ps = case previous ps of

739 Nothing -> fail "Nothing to undo."

740 Just pold -> return (pold, "")

741−processTactic EndUnify ps

741+processTactic EndUnify ps

742 = let (h, ns_in) = unified ps

743 ns = dropGiven (dontunify ps) ns_in (holes ps)

744− ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

744+ ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

745 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

746 (injective ps) (holes ps)

747 tm' = -- trace ("Updating " ++ show ns_in ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $

748 updateSolved ns'' (pterm ps) in

749− return (ps { pterm = tm',

749+ return (ps { pterm = tm',

750 unified = (h, []),

751 problems = probs',

752 holes = holes ps \\ map fst ns'' }, "")

753−processTactic (Reorder n) ps

753+processTactic (Reorder n) ps

754 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

755 return (ps' { previous = Just ps, plog = "" }, plog ps')

756processTactic (ComputeLet n) ps

757 = return (ps { pterm = computeLet (context ps) n (pterm ps) }, "")

758−processTactic UnifyProblems ps

758+processTactic UnifyProblems ps

759 = let (ns', probs') = updateProblems (context ps) []

760 (problems ps)

761 (injective ps)

762− (holes ps)

762+ (holes ps)

763 pterm' = updateSolved ns' (pterm ps) in

764 return (ps { pterm = pterm', solved = Nothing, problems = probs',

765 previous = Just ps, plog = "",

766 holes = holes ps \\ (map fst ns') }, plog ps)

767−processTactic MatchProblems ps

767+processTactic MatchProblems ps

768 = let (ns', probs') = matchProblems (context ps)

769 (problems ps)

770 (injective ps)

771− (holes ps)

771+ (holes ps)

772 pterm' = updateSolved ns' (pterm ps) in

773 return (ps { pterm = pterm', solved = Nothing, problems = probs',

774 previous = Just ps, plog = "",

775 holes = holes ps \\ (map fst ns') }, plog ps)

776−processTactic t ps

776+processTactic t ps

777 = case holes ps of

778 [] -> fail "Nothing to fill in."

779 (h:_) -> do ps' <- execStateT (process t h) ps

780− let (ns', probs')

780+ let (ns', probs')

781 = case solved ps' of

782 Just s -> updateProblems (context ps')

783− [s] (problems ps')

783+ [s] (problems ps')

784 (injective ps')

785 (holes ps')

786 _ -> ([], problems ps')

787− -- rechecking problems may find more solutions, so

787+ -- rechecking problems may find more solutions, so

788 -- apply them here

789 let pterm'' = updateSolved ns' (pterm ps')

790 return (ps' { pterm = pterm'',

@@ -794,7 +794,7 @@ processTactic t ps

794 holes = holes ps' \\ (map fst ns')}, plog ps')

795

796process :: Tactic -> Name -> StateT TState TC ()

797−process EndUnify _

797+process EndUnify _

798 = do ps <- get

799 let (h, _) = unified ps

800 tactic (Just h) solve_unified

src/Core/ShellParser.hs+1−1

@@ -50,7 +50,7 @@ pTactic = do reserved "attack"; return attack

50 <|> do reserved "regret"; return regret

51 <|> do reserved "exact"; tm <- pTerm; return (exact tm)

52 <|> do reserved "fill"; tm <- pTerm; return (fill tm)

53− <|> do reserved "apply"; tm <- pTerm; args <- many pArgType;

53+ <|> do reserved "apply"; tm <- pTerm; args <- many pArgType;

54 return (discard (apply tm (map (\x -> (x,0)) args)))

55 <|> do reserved "solve"; return solve

56 <|> do reserved "compute"; return compute

src/Core/TT.hs+48−48

@@ -63,8 +63,8 @@ emptyFC = fileFC ""

63fileFC :: String -> FC

64fileFC s = FC s 0 0

65

66−{-!

66+{-!

67−deriving instance Binary FC

67+deriving instance Binary FC

68!-}

69

70instance Sized FC where

@@ -75,7 +75,7 @@ instance Show FC where

75

76data Err = Msg String

77 | InternalMsg String

78− | CantUnify Bool Term Term Err [(Name, Type)] Int

78+ | CantUnify Bool Term Term Err [(Name, Type)] Int

79 -- Int is 'score' - how much we did unify

80 -- Bool indicates recoverability, True indicates more info may make

81 -- unification succeed

@@ -181,8 +181,8 @@ instance Show a => Show (TC a) where

181-- (e.g. Type:Type)

182

183instance Monad TC where

184− return = OK

184+ return = OK

185− x >>= k = case x of

185+ x >>= k = case x of

186 OK v -> k v

187 Error e -> Error e

188 fail e = Error (InternalMsg e)

@@ -192,7 +192,7 @@ tfail e = Error e

192

193trun :: FC -> TC a -> TC a

194trun fc (OK a) = OK a

195−trun fc (Error e) = Error (At fc e)

195+trun fc (Error e) = Error (At fc e)

196

197instance MonadPlus TC where

198 mzero = fail "Unknown error"

@@ -218,23 +218,23 @@ traceWhen False _ a = a

218-- | Names are hierarchies of strings, describing scope (so no danger of

219-- duplicate names, but need to be careful on lookup).

220data Name = UN String -- ^ User-provided name

221− | NS Name [String] -- ^ Root, namespaces

221+ | NS Name [String] -- ^ Root, namespaces

222 | MN Int String -- ^ Machine chosen names

223 | NErased -- ^ Name of somethng which is never used in scope

224 | SN SpecialName -- ^ Decorated function names

225 deriving (Eq, Ord)

226−{-!

226+{-!

227−deriving instance Binary Name

227+deriving instance Binary Name

228!-}

229

230data SpecialName = WhereN Int Name Name

231 | InstanceN Name [String]

232 | ParentN Name String

233− | MethodN Name

233+ | MethodN Name

234 | CaseN Name

235 deriving (Eq, Ord)

236−{-!

236+{-!

237−deriving instance Binary SpecialName

237+deriving instance Binary SpecialName

238!-}

239

240instance Sized Name where

@@ -300,9 +300,9 @@ nsroot n = n

300

301addDef :: Name -> a -> Ctxt a -> Ctxt a

302addDef n v ctxt = case Map.lookup (nsroot n) ctxt of

303− Nothing -> Map.insert (nsroot n)

303+ Nothing -> Map.insert (nsroot n)

304 (Map.insert n v Map.empty) ctxt

305− Just xs -> Map.insert (nsroot n)

305+ Just xs -> Map.insert (nsroot n)

306 (Map.insert n v xs) ctxt

307

308{-| Look up a name in the context, given an optional namespace.

@@ -326,7 +326,7 @@ lookupCtxtName n ctxt = case Map.lookup (nsroot n) ctxt of

326 Nothing -> []

327 where

328 filterNS [] = []

329− filterNS ((found, v) : xs)

329+ filterNS ((found, v) : xs)

330 | nsmatch n found = (found, v) : filterNS xs

331 | otherwise = filterNS xs

332

@@ -341,9 +341,9 @@ lookupCtxtExact :: Name -> Ctxt a -> [a]

341lookupCtxtExact n ctxt = [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n]

342

343updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a

344−updateDef n f ctxt

344+updateDef n f ctxt

345 = let ds = lookupCtxtName n ctxt in

346− foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds

346+ foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds

347

348toAlist :: Ctxt a -> [(Name, a)]

349toAlist ctxt = let allns = map snd (Map.toList ctxt) in

@@ -390,15 +390,15 @@ intTyWidth ITNative = 8 * sizeOf (0 :: Int)

390intTyWidth ITChar = error "IRTS.Lang.intTyWidth: Characters have platform and backend dependent width"

391intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width"

392

393−data Const = I Int | BI Integer | Fl Double | Ch Char | Str String

393+data Const = I Int | BI Integer | Fl Double | Ch Char | Str String

394 | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64

395 | B8V (Vector Word8) | B16V (Vector Word16)

396 | B32V (Vector Word32) | B64V (Vector Word64)

397 | AType ArithTy | StrType

398 | PtrType | VoidType | Forgot

399 deriving (Eq, Ord)

400−{-!

400+{-!

401−deriving instance Binary Const

401+deriving instance Binary Const

402!-}

403

404instance Sized Const where

@@ -439,8 +439,8 @@ instance Sized Raw where

439instance Pretty Raw where

440 pretty = text . show

441

442−{-!

442+{-!

443−deriving instance Binary Raw

443+deriving instance Binary Raw

444!-}

445

446-- | All binding forms are represented in a unform fashion.

@@ -458,8 +458,8 @@ data Binder b = Lam { binderTy :: b {-^ type annotation for bound variable-}}

458 | PVar { binderTy :: b }

459 | PVTy { binderTy :: b }

460 deriving (Show, Eq, Ord, Functor)

461−{-!

461+{-!

462−deriving instance Binary Binder

462+deriving instance Binary Binder

463!-}

464

465instance Sized a => Sized (Binder a) where

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

548 | DCon Int Int -- ^ Data constructor; Ints are tag and arity

549 | TCon Int Int -- ^ Type constructor; Ints are tag and arity

550 deriving (Show, Ord)

551−{-!

551+{-!

552−deriving instance Binary NameType

552+deriving instance Binary NameType

553!-}

554

555instance Sized NameType where

@@ -576,8 +576,8 @@ data TT n = P NameType n (TT n) -- ^ named references

576 | Impossible -- ^ special case for totality checking

577 | TType UExp -- ^ the type of types at some level

578 deriving (Ord, Functor)

579−{-!

579+{-!

580−deriving instance Binary TT

580+deriving instance Binary TT

581!-}

582

583class TermSize a where

@@ -588,14 +588,14 @@ instance TermSize a => TermSize [a] where

588 termsize n (x : xs) = termsize n x + termsize n xs

589

590instance TermSize (TT Name) where

591− termsize n (P _ x _)

591+ termsize n (P _ x _)

592 | x == n = 1000000 -- recursive => really big

593 | otherwise = 1

594 termsize n (V _) = 1

595− termsize n (Bind n' (Let t v) sc)

595+ termsize n (Bind n' (Let t v) sc)

596 = let rn = if n == n' then MN 0 "noname" else n in

597 termsize rn v + termsize rn sc

598− termsize n (Bind n' b sc)

598+ termsize n (Bind n' b sc)

599 = let rn = if n == n' then MN 0 "noname" else n in

600 termsize rn sc

601 termsize n (App f a) = termsize n f + termsize n a

@@ -652,7 +652,7 @@ isInjective _ = False

652vinstances :: Int -> TT n -> Int

653vinstances i (V x) | i == x = 1

654vinstances i (App f a) = vinstances i f + vinstances i a

655−vinstances i (Bind x b sc) = instancesB b + vinstances (i + 1) sc

655+vinstances i (Bind x b sc) = instancesB b + vinstances (i + 1) sc

656 where instancesB (Let t v) = vinstances i v

657 instancesB _ = 0

658vinstances i t = 0

@@ -662,7 +662,7 @@ instantiate e = subst 0 where

662 subst i (V x) | i == x = e

663 subst i (Bind x b sc) = Bind x (fmap (subst i) b) (subst (i+1) sc)

664 subst i (App f a) = App (subst i f) (subst i a)

665− subst i (Proj x idx) = Proj (subst i x) idx

665+ subst i (Proj x idx) = Proj (subst i x) idx

666 subst i t = t

667

668substV :: TT n -> TT n -> TT n

@@ -677,7 +677,7 @@ substV x tm = dropV 0 (instantiate x tm) where

677explicitNames :: TT n -> TT n

678explicitNames (Bind x b sc) = let b' = fmap explicitNames b in

679 Bind x b'

680− (explicitNames (instantiate

680+ (explicitNames (instantiate

681 (P Bound x (binderTy b')) sc))

682explicitNames (App f a) = App (explicitNames f) (explicitNames a)

683explicitNames (Proj x idx) = Proj (explicitNames x) idx

@@ -785,15 +785,15 @@ forget tm = fe [] tm

785 where

786 fe env (P _ n _) = Var n

787 fe env (V i) = Var (env !! i)

788− fe env (Bind n b sc) = RBind n (fmap (fe env) b)

788+ fe env (Bind n b sc) = RBind n (fmap (fe env) b)

789 (fe (n:env) sc)

790 fe env (App f a) = RApp (fe env f) (fe env a)

791− fe env (Constant c)

791+ fe env (Constant c)

792 = RConstant c

793 fe env (TType i) = RType

794− fe env Erased = RConstant Forgot

794+ fe env Erased = RConstant Forgot

795−

795+

796−bindAll :: [(n, Binder (TT n))] -> TT n -> TT n

796+bindAll :: [(n, Binder (TT n))] -> TT n -> TT n

797bindAll [] t =t

798bindAll ((n, b) : bs) t = Bind n b (bindAll bs t)

799

@@ -820,7 +820,7 @@ uniqueBinders ns (Bind n b sc)

820 Bind n' (fmap (uniqueBinders (n':ns)) b) (uniqueBinders ns sc)

821uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a)

822uniqueBinders ns t = t

823−

823+

824

825nextName (NS x s) = NS (nextName x) s

826nextName (MN i n) = MN (i+1) n

@@ -892,7 +892,7 @@ prettyEnv env t = prettyEnv' env t False

892 | otherwise = p

893

894 prettySe p env (P nt n t) debug =

895− pretty n <+>

895+ pretty n <+>

896 if debug then

897 lbrack <+> pretty nt <+> colon <+> prettySe 10 env t debug <+> rbrack

898 else

@@ -931,16 +931,16 @@ prettyEnv env t = prettyEnv' env t False

931 prettyBv env op sc n t v debug =

932 text op <> pretty n <+> colon <+> prettySe 10 env t debug <+> text "=" <+>

933 prettySe 10 env v debug <> text sc

934−

934+

935

936showEnv' env t dbg = se 10 env t where

937− se p env (P nt n t) = show n

937+ se p env (P nt n t) = show n

938 ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else ""

939 se p env (V i) | i < length env && i >= 0

940 = (show $ fst $ env!!i) ++

941 if dbg then "{" ++ show i ++ "}" else ""

942 | otherwise = "!!V " ++ show i ++ "!!"

943− se p env (Bind n b@(Pi t) sc)

943+ se p env (Bind n b@(Pi t) sc)

944 | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ " -> " ++ se 10 ((n,b):env) sc

945 se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc

946 se p env (App f a) = bracket p 1 $ se 1 env f ++ " " ++ se 0 env a

@@ -960,8 +960,8 @@ showEnv' env t dbg = se 10 env t where

960 sb env n (Guess t v) = showbv env "?? " " in " n t v

961

962 showb env op sc n t = op ++ show n ++ " : " ++ se 10 env t ++ sc

963− showbv env op sc n t v = op ++ show n ++ " : " ++ se 10 env t ++ " = " ++

963+ showbv env op sc n t v = op ++ show n ++ " : " ++ se 10 env t ++ " = " ++

964− se 10 env v ++ sc

964+ se 10 env v ++ sc

965

966 bracket outer inner str | inner > outer = "(" ++ str ++ ")"

967 | otherwise = str

@@ -1008,7 +1008,7 @@ orderPats tm = op [] tm

1008 where

1009 op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc

1010 op ps (Bind n (Hole t) sc) = op ((n, Hole t) : ps) sc

1011− op ps sc = bindAll (map (\ (n, t) -> (n, t)) (sortP ps)) sc

1011+ op ps sc = bindAll (map (\ (n, t) -> (n, t)) (sortP ps)) sc

1012

1013 sortP ps = pick [] (reverse ps)

1014

@@ -1025,7 +1025,7 @@ orderPats tm = op [] tm

1025

1026 insert n t [] = [(n, t)]

1027 insert n t ((n',t') : ps)

1028− | n `elem` (namesIn (binderTy t') ++

1028+ | n `elem` (namesIn (binderTy t') ++

1029 concatMap namesIn (map (binderTy . snd) ps))

1030 = (n', t') : insert n t ps

1031 | otherwise = (n,t):(n',t'):ps

src/Core/Typecheck.hs+17−17

@@ -16,10 +16,10 @@ import Core.Evaluate

16-- indexed with 'finalise'

17

18convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC ()

19−convertsC ctxt env x y

19+convertsC ctxt env x y

20 = do c1 <- convEq ctxt x y

21 if c1 then return ()

22− else

22+ else

23 do c2 <- convEq ctxt (finalise (normalise ctxt env x))

24 (finalise (normalise ctxt env y))

25 if c2 then return ()

@@ -28,10 +28,10 @@ convertsC ctxt env x y

28 (finalise (normalise ctxt env y)) (errEnv env))

29

30converts :: Context -> Env -> Term -> Term -> TC ()

31−converts ctxt env x y

31+converts ctxt env x y

32− = case convEq' ctxt x y of

32+ = case convEq' ctxt x y of

33 OK True -> return ()

34− _ -> case convEq' ctxt (finalise (normalise ctxt env x))

34+ _ -> case convEq' ctxt (finalise (normalise ctxt env x))

35 (finalise (normalise ctxt env y)) of

36 OK True -> return ()

37 _ -> tfail (CantConvert

@@ -51,7 +51,7 @@ recheck ctxt env tm orig

51 case runStateT (check' False ctxt env tm) (v, []) of -- holes banned

52 Error (IncompleteTerm _) -> Error $ IncompleteTerm orig

53 Error e -> Error e

54− OK ((tm, ty), constraints) ->

54+ OK ((tm, ty), constraints) ->

55 return (tm, ty, constraints)

56

57check :: Context -> Env -> Raw -> TC (Term, Type)

@@ -68,7 +68,7 @@ check' holes ctxt env top = chk env top where

68 (av, aty) <- chk env a

69 let fty' = case uniqueBinders (map fst env) (finalise fty) of

70 ty@(Bind x (Pi s) t) -> ty

71− _ -> uniqueBinders (map fst env)

71+ _ -> uniqueBinders (map fst env)

72 $ case hnf ctxt env fty of

73 ty@(Bind x (Pi s) t) -> ty

74 _ -> normalise ctxt env fty

@@ -77,21 +77,21 @@ check' holes ctxt env top = chk env top where

77-- trace ("Converting " ++ show aty ++ " and " ++ show s ++

78-- " from " ++ show fv ++ " : " ++ show fty) $

79 do convertsC ctxt env aty s

80− -- let apty = normalise initContext env

80+ -- let apty = normalise initContext env

81 -- (Bind x (Let aty av) t)

82− let apty = simplify initContext env

82+ let apty = simplify initContext env

83 (Bind x (Let aty av) t)

84 return (App fv av, apty)

85 t -> lift $ tfail $ NonFunctionType fv fty -- "Can't apply a non-function type"

86− -- This rather unpleasant hack is needed because during incomplete

86+ -- This rather unpleasant hack is needed because during incomplete

87− -- proofs, variables are locally bound with an explicit name. If we just

87+ -- proofs, variables are locally bound with an explicit name. If we just

88 -- make sure bound names in function types are locally unique, machine

89 -- generated names, we'll be fine.

90 -- NOTE: now replaced with 'uniqueBinders' above

91− where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s)

91+ where renameBinders i (Bind x (Pi s) t) = Bind (MN i "binder") (Pi s)

92 (renameBinders (i+1) t)

93 renameBinders i sc = sc

94− chk env RType

94+ chk env RType

95 | holes = return (TType (UVal 0), TType (UVal 0))

96 | otherwise = do (v, cs) <- get

97 let c = ULT (UVar v) (UVar (v+1))

@@ -123,8 +123,8 @@ check' holes ctxt env top = chk env top where

123 let TType su = normalise ctxt env st

124 let TType tu = normalise ctxt env tt

125 when (not holes) $ put (v+1, ULE su (UVar v):ULE tu (UVar v):cs)

126− return (Bind n (Pi (uniqueBinders (map fst env) sv))

126+ return (Bind n (Pi (uniqueBinders (map fst env) sv))

127− (pToV n tv), TType (UVar v))

127+ (pToV n tv), TType (UVar v))

128 chk env (RBind n b sc)

129 = do b' <- checkBinder b

130 (scv, sct) <- chk ((n, b'):env) sc

@@ -193,7 +193,7 @@ check' holes ctxt env top = chk env top where

193 let tt' = normalise ctxt env tt

194 lift $ isType ctxt env tt'

195 return (PVTy tv)

196−

196+

197 discharge n (Lam t) scv sct

198 = return (Bind n (Lam t) scv, Bind n (Pi t) sct)

199 discharge n (Pi t) scv sct

@@ -216,7 +216,7 @@ check' holes ctxt env top = chk env top where

216

217checkProgram :: Context -> RProgram -> TC Context

218checkProgram ctxt [] = return ctxt

219−checkProgram ctxt ((n, RConst t) : xs)

219+checkProgram ctxt ((n, RConst t) : xs)

220 = do (t', tt') <- trace (show n) $ check ctxt [] t

221 isType ctxt [] tt'

222 checkProgram (addTyDecl n Ref t' ctxt) xs

src/Core/Unify.hs+46−46

@@ -36,18 +36,18 @@ match_unify :: Context -> Env -> TT Name -> TT Name -> [Name] -> [Name] ->

36match_unify ctxt env topx topy dont holes =

37 case runStateT (un [] topx topy) (UI 0 []) of

38 OK (v, UI _ []) -> return (filter notTrivial v)

39− res ->

39+ res ->

40 let topxn = normalise ctxt env topx

41 topyn = normalise ctxt env topy in

42 case runStateT (un [] topxn topyn)

43 (UI 0 []) of

44− OK (v, UI _ fails) ->

44+ OK (v, UI _ fails) ->

45 return (filter notTrivial v)

46− Error e ->

46+ Error e ->

47 -- just normalise the term we're matching against

48 case runStateT (un [] topxn topy)

49 (UI 0 []) of

50− OK (v, UI _ fails) ->

50+ OK (v, UI _ fails) ->

51 return (filter notTrivial v)

52 _ -> tfail e

53 where

@@ -66,7 +66,7 @@ match_unify ctxt env topx topy dont holes =

66 h2 <- un ((x, y) : bnames) sx sy

67 combine bnames h1 h2

68 un names (App fx ax) (App fy ay)

69− = do hf <- un names fx fy

69+ = do hf <- un names fx fy

70 ha <- un names ax ay

71 combine names hf ha

72 un names x y

@@ -87,7 +87,7 @@ match_unify ctxt env topx topy dont holes =

87 uB bnames (Pi tx) (Pi ty) = un bnames tx ty

88 uB bnames x y = do UI s f <- get

89 let r = recoverable (binderTy x) (binderTy y)

90− let err = CantUnify r topx topy

90+ let err = CantUnify r topx topy

91 (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s)

92 (errEnv env) s

93 put (UI s ((binderTy x, binderTy y, env, err) : f))

@@ -107,7 +107,7 @@ match_unify ctxt env topx topy dont holes =

107 lift $ tfail err

108 combine bnames as [] = return as

109 combine bnames as ((n, t) : bs)

110− = case lookup n as of

110+ = case lookup n as of

111 Nothing -> combine bnames (as ++ [(n,t)]) bs

112 Just t' -> do ns <- un bnames t t'

113 -- make sure there's n mapping from n in ns

@@ -115,15 +115,15 @@ match_unify ctxt env topx topy dont holes =

115 sc 1

116 combine bnames as (ns' ++ bs)

117

118− checkCycle ns p@(x, P _ _ _) = return [p]

118+ checkCycle ns p@(x, P _ _ _) = return [p]

119− checkCycle ns (x, tm)

119+ checkCycle ns (x, tm)

120 | not (x `elem` freeNames tm) = checkScope ns (x, tm)

121− | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env))

121+ | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env))

122

123 checkScope ns (x, tm) =

124 case boundVs (envPos x 0 env) tm of

125 [] -> return [(x, tm)]

126− (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))

126+ (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))

127 (inst ns tm) (errEnv env))

128 where inst [] tm = tm

129 inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm)

@@ -146,15 +146,15 @@ unify ctxt env topx topy dont holes =

146-- trace ("Unifying " ++ show (topx, topy)) $

147 -- don't bother if topx and topy are different at the head

148 case runStateT (un False [] topx topy) (UI 0 []) of

149− OK (v, UI _ []) -> return (filter notTrivial v,

149+ OK (v, UI _ []) -> return (filter notTrivial v,

150 [])

151− res ->

151+ res ->

152 let topxn = normalise ctxt env topx

153 topyn = normalise ctxt env topy in

154-- trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $

155 case runStateT (un False [] topxn topyn)

156 (UI 0 []) of

157− OK (v, UI _ fails) ->

157+ OK (v, UI _ fails) ->

158 return (filter notTrivial v, reverse fails)

159-- Error e@(CantUnify False _ _ _ _ _) -> tfail e

160 Error e -> tfail e

@@ -165,8 +165,8 @@ unify ctxt env topx topy dont holes =

165

166 injective (P (DCon _ _) _ _) = True

167 injective (P (TCon _ _) _ _) = True

168−-- injective (App f (P _ _ _)) = injective f

168+-- injective (App f (P _ _ _)) = injective f

169−-- injective (App f (Constant _)) = injective f

169+-- injective (App f (Constant _)) = injective f

170 injective (App f a) = injective f -- && injective a

171 injective _ = False

172

@@ -182,15 +182,15 @@ unify ctxt env topx topy dont holes =

182 uplus u1 u2 = do UI s f <- get

183 r <- u1

184 UI s f' <- get

185− if (length f == length f')

185+ if (length f == length f')

186 then return r

187 else do put (UI s f); u2

188

189 un :: Bool -> [(Name, Name)] -> TT Name -> TT Name ->

190− StateT UInfo

190+ StateT UInfo

191 TC [(Name, TT Name)]

192 un = un'

193−-- un fn names x y

193+-- un fn names x y

194-- = let (xf, _) = unApply x

195-- (yf, _) = unApply y in

196-- if headDiff xf yf then unifyFail x y else

@@ -198,7 +198,7 @@ unify ctxt env topx topy dont holes =

198-- (un' fn names (hnf ctxt env x) (hnf ctxt env y))

199

200 un' :: Bool -> [(Name, Name)] -> TT Name -> TT Name ->

201− StateT UInfo

201+ StateT UInfo

202 TC [(Name, TT Name)]

203 un' fn names x y | x == y = return [] -- shortcut

204 un' fn names topx@(P (DCon _ _) x _) topy@(P (DCon _ _) y _)

@@ -213,7 +213,7 @@ unify ctxt env topx topy dont holes =

213 = unifyFail topx topy

214 un' fn names topx@(P (TCon _ _) x _) topy@(Constant _)

215 = unifyFail topx topy

216− un' fn bnames tx@(P _ x _) ty@(P _ y _)

216+ un' fn bnames tx@(P _ x _) ty@(P _ y _)

217 | (x,y) `elem` bnames || x == y = do sc 1; return []

218 | injective tx && not (holeIn env y || y `elem` holes)

219 = unifyTmpFail tx ty

@@ -223,10 +223,10 @@ unify ctxt env topx topy dont holes =

223 | holeIn env x || x `elem` holes

224 = do UI s f <- get

225 -- injectivity check

226− if (notP tm && fn)

226+ if (notP tm && fn)

227-- trace (show (x, tm, normalise ctxt env tm)) $

228-- put (UI s ((tm, topx, topy) : i) f)

229− then unifyTmpFail xtm tm

229+ then unifyTmpFail xtm tm

230 else do sc 1

231 checkCycle bnames (x, tm)

232 | not (injective xtm) && injective tm = unifyFail xtm tm

@@ -246,7 +246,7 @@ unify ctxt env topx topy dont holes =

246 un' fn bnames (P _ x _) (V i)

247 | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []

248

249− un' fn bnames appx@(App _ _) appy@(App _ _)

249+ un' fn bnames appx@(App _ _) appy@(App _ _)

250 = unApp fn bnames appx appy

251-- = uplus (unApp fn bnames appx appy)

252-- (unifyTmpFail appx appy) -- take the whole lot

@@ -259,15 +259,15 @@ unify ctxt env topx topy dont holes =

259 = un' False bnames x y

260 un' fn bnames (Bind n (Lam t) (App x (V 0))) y

261 = un' False bnames x y

262−-- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy)

262+-- un' fn bnames (Bind x (PVar _) sx) (Bind y (PVar _) sy)

263-- = un' False ((x,y):bnames) sx sy

264−-- un' fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy)

264+-- un' fn bnames (Bind x (PVTy _) sx) (Bind y (PVTy _) sy)

265-- = un' False ((x,y):bnames) sx sy

266− un' fn bnames (Bind x bx sx) (Bind y by sy)

266+ un' fn bnames (Bind x bx sx) (Bind y by sy)

267 = do h1 <- uB bnames bx by

268 h2 <- un' False ((x,y):bnames) sx sy

269 combine bnames h1 h2

270− un' fn bnames x y

270+ un' fn bnames x y

271 | OK True <- convEq' ctxt x y = do sc 1; return []

272 | otherwise = do UI s f <- get

273 let r = recoverable x y

@@ -277,7 +277,7 @@ unify ctxt env topx topy dont holes =

277 else do put (UI s ((x, y, env, err) : f))

278 return [] -- lift $ tfail err

279

280− unApp fn bnames appx@(App fx ax) appy@(App fy ay)

280+ unApp fn bnames appx@(App fx ax) appy@(App fy ay)

281 | (injective fx && injective fy)

282 || (injective fx && rigid appx && metavarApp appy)

283 || (injective fy && rigid appy && metavarApp appx)

@@ -288,11 +288,11 @@ unify ctxt env topx topy dont holes =

288 -- fail quickly if the heads are disjoint

289 checkHeads headx heady

290-- if True then -- (injective fx || injective fy || fx == fy) then

291−-- if (injective fx && metavarApp appy) ||

291+-- if (injective fx && metavarApp appy) ||

292-- (injective fy && metavarApp appx) ||

293-- (injective fx && injective fy) || fx == fy

294 uplus

295− (do hf <- un' True bnames fx fy

295+ (do hf <- un' True bnames fx fy

296 let ax' = hnormalise hf ctxt env (substNames hf ax)

297 let ay' = hnormalise hf ctxt env (substNames hf ay)

298 ha <- un' False bnames ax' ay'

@@ -309,7 +309,7 @@ unify ctxt env topx topy dont holes =

309 let (heady, argsy) = unApply appy

310 -- traceWhen (headx == heady) (show (appx, appy)) $

311 uplus (

312− if (length argsx == length argsy &&

312+ if (length argsx == length argsy &&

313 ((headx == heady && inenv headx) || (argsx == argsy) ||

314 (and (zipWith sameStruct (headx:argsx) (heady:argsy)))))

315 then

@@ -318,7 +318,7 @@ unify ctxt env topx topy dont holes =

318 failed <- errors

319 if (not failed) then unArgs uf argsx argsy

320 else return []

321− else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $

321+ else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $

322 unifyTmpFail appx appy)

323 (unifyTmpFail appx appy) -- whole application fails

324 where hnormalise [] _ _ t = t

@@ -334,9 +334,9 @@ unify ctxt env topx topy dont holes =

334 checkHeads _ _ = return []

335

336 unArgs as [] [] = return as

337− unArgs as (x : xs) (y : ys)

337+ unArgs as (x : xs) (y : ys)

338 = do let x' = hnormalise as ctxt env (substNames as x)

339− let y' = hnormalise as ctxt env (substNames as y)

339+ let y' = hnormalise as ctxt env (substNames as y)

340 as' <- un' False bnames x' y'

341 vs <- combine bnames as as'

342 unArgs vs xs ys

@@ -352,13 +352,13 @@ unify ctxt env topx topy dont holes =

352 all (\x -> pat x || metavar x) (f : args)

353 && nub args == args

354

355− sameArgStruct appx appy

355+ sameArgStruct appx appy

356 = let (_, ax) = unApply appx

357 (_, ay) = unApply appy in

358 length ax == length ay &&

359 and (zipWith sameStruct ax ay)

360

361− sameStruct fapp@(App f x) gapp@(App g y)

361+ sameStruct fapp@(App f x) gapp@(App g y)

362 = let (f',a') = unApply fapp

363 (g',b') = unApply gapp in

364 (f' == g' && length a' == length b' &&

@@ -389,13 +389,13 @@ unify ctxt env topx topy dont holes =

389 P _ x _ -> x `elem` holes || patIn env x

390 _ -> False

391 inenv t = case t of

392− P _ x _ -> x `elem` (map fst env)

392+ P _ x _ -> x `elem` (map fst env)

393 _ -> False

394

395− notFn t = injective t || metavar t || inenv t

395+ notFn t = injective t || metavar t || inenv t

396

397

398− unifyTmpFail x y

398+ unifyTmpFail x y

399 = do UI s f <- get

400 let r = recoverable x y

401 let err = CantUnify r

@@ -434,15 +434,15 @@ unify ctxt env topx topy dont holes =

434 put (UI s ((binderTy x, binderTy y, env, err) : f))

435 return [] -- lift $ tfail err

436

437− checkCycle ns p@(x, P _ _ _) = return [p]

437+ checkCycle ns p@(x, P _ _ _) = return [p]

438− checkCycle ns (x, tm)

438+ checkCycle ns (x, tm)

439 | not (x `elem` freeNames tm) = checkScope ns (x, tm)

440− | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env))

440+ | otherwise = lift $ tfail (InfiniteUnify x tm (errEnv env))

441

442 checkScope ns (x, tm) =

443 case boundVs (envPos x 0 env) tm of

444 [] -> return [(x, tm)]

445− (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))

445+ (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))

446 (inst ns tm) (errEnv env))

447 where inst [] tm = tm

448 inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm)

@@ -454,7 +454,7 @@ unify ctxt env topx topy dont holes =

454

455 combine bnames as [] = return as

456 combine bnames as ((n, t) : bs)

457− = case lookup n as of

457+ = case lookup n as of

458 Nothing -> combine bnames (as ++ [(n,t)]) bs

459 Just t' -> do ns <- un' False bnames t t'

460 -- make sure there's n mapping from n in ns

@@ -466,7 +466,7 @@ boundVs :: Int -> Term -> [Int]

466boundVs i (V j) | j <= i = []

467 | otherwise = [j]

468boundVs i (Bind n b sc) = boundVs (i + 1) sc

469−boundVs i (App f x) = let fs = boundVs i f

469+boundVs i (App f x) = let fs = boundVs i f

470 xs = boundVs i x in

471 nub (fs ++ xs)

472boundVs i _ = []

src/IRTS/BCImp.hs+1−1

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

1module IRTS.BCImp where

2

3−-- Bytecode for a register/variable based VM (e.g. for generating code in an

3+-- Bytecode for a register/variable based VM (e.g. for generating code in an

4-- imperative language where we let the language deal with GC)

5

6import IRTS.Lang

src/IRTS/CodegenC.hs+40−40

@@ -20,9 +20,9 @@ import Control.Monad

20

21codegenC :: [(Name, SDecl)] ->

22 String -> -- output file name

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

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

24 [FilePath] -> -- include files

25− String -> -- extra object files

25+ String -> -- extra object files

26 String -> -- extra compiler flags (libraries)

27 String -> -- extra compiler flags (anything)

28 DbgLevel ->

@@ -34,7 +34,7 @@ codegenC defs out exec incs objs libs flags dbg

34 let cc = concatMap (uncurry toC) bc

35 d <- getDataDir

36 mprog <- readFile (d </> "rts" </> "idris_main" <.> "c")

37− let cout = headers incs ++ debug dbg ++ h ++ cc ++

37+ let cout = headers incs ++ debug dbg ++ h ++ cc ++

38 (if (exec == Executable) then mprog else "")

39 case exec of

40 MavenProject -> putStrLn ("FAILURE: output type not supported")

@@ -94,18 +94,18 @@ creg (T i) = "TOP(" ++ show i ++ ")"

94creg Tmp = "REG1"

95

96toDecl :: Name -> String

97−toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"

97+toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"

98

99toC :: Name -> [BC] -> String

100−toC f code

100+toC f code

101− = -- "/* " ++ show code ++ "*/\n\n" ++

101+ = -- "/* " ++ show code ++ "*/\n\n" ++

102 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++

103− indent 1 ++ "INITFRAME;\n" ++

103+ indent 1 ++ "INITFRAME;\n" ++

104 concatMap (bcc 1) code ++ "}\n\n"

105

106bcc :: Int -> BC -> String

107bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

108−bcc i (ASSIGNCONST l c)

108+bcc i (ASSIGNCONST l c)

109 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"

110 where

111 mkConst (I i) = "MKINT(" ++ show i ++ ")"

@@ -123,9 +123,9 @@ bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

123bcc i (MKCON l tag args)

124 = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," ++

125 show (length args) ++ ", 0);\n" ++

126− indent i ++ setArgs 0 args ++ "\n" ++

126+ indent i ++ setArgs 0 args ++ "\n" ++

127 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"

128−

128+

129-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++

130-- show (length args) ++ concatMap showArg args ++ ");\n"

131 where showArg r = ", " ++ creg r

@@ -133,15 +133,15 @@ bcc i (MKCON l tag args)

133 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++

134 "); " ++ setArgs (i + 1) xs

135

136−bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++

136+bcc i (PROJECT l loc a) = indent i ++ "PROJECT(vm, " ++ creg l ++ ", " ++ show loc ++

137 ", " ++ show a ++ ");\n"

138bcc i (PROJECTINTO r t idx)

139− = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"

139+ = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"

140−bcc i (CASE True r code def)

140+bcc i (CASE True r code def)

141 | length code < 4 = showCase i def code

142 where

143 showCode :: Int -> [BC] -> String

144− showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc ++

144+ showCode i bc = "{\n" ++ indent i ++ concatMap (bcc (i + 1)) bc ++

145 indent i ++ "}\n"

146

147 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String

@@ -151,7 +151,7 @@ bcc i (CASE True r code def)

151 = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c

152 ++ "else " ++ showCase i def cs

153

154−bcc i (CASE safe r code def)

154+bcc i (CASE safe r code def)

155 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++

156 concatMap (showCase i) code ++

157 showDef i def ++

@@ -163,9 +163,9 @@ bcc i (CASE safe r code def)

163 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"

164 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"

165 showDef i Nothing = ""

166− showDef i (Just c) = indent i ++ "default:\n"

166+ showDef i (Just c) = indent i ++ "default:\n"

167 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"

168−bcc i (CONSTCASE r code def)

168+bcc i (CONSTCASE r code def)

169 | intConsts code

170-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++

171-- concatMap (showCase i) code ++

@@ -205,11 +205,11 @@ bcc i (CONSTCASE r code def)

205 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

206

207 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"

208− ++ concatMap (bcc (i+1)) bc ++

208+ ++ concatMap (bcc (i+1)) bc ++

209 indent (i + 1) ++ "break;\n"

210 showDef i Nothing = ""

211− showDef i (Just c) = indent i ++ "default:\n"

211+ showDef i (Just c) = indent i ++ "default:\n"

212− ++ concatMap (bcc (i+1)) c ++

212+ ++ concatMap (bcc (i+1)) c ++

213 indent (i + 1) ++ "break;\n"

214 showDefS i Nothing = ""

215 showDefS i (Just c) = concatMap (bcc (i+1)) c

@@ -227,8 +227,8 @@ bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

227bcc i STOREOLD = indent i ++ "STOREOLD;\n"

228bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

229bcc i (FOREIGNCALL l LANG_C rty fn args)

230− = indent i ++

230+ = indent i ++

231− c_irts rty (creg l ++ " = ")

231+ c_irts rty (creg l ++ " = ")

232 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

233 where fcall (t, arg) = irts_c t (creg arg)

234bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

@@ -289,27 +289,27 @@ doOp v (LLe ITNative) [l, r] = v ++ "UINTOP(<=," ++ creg l ++ ", " ++ creg r ++

289doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

290doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

291

292−doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]

292+doOp v (LPlus (ATInt ITChar)) [l, r] = doOp v (LPlus (ATInt ITNative)) [l, r]

293−doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]

293+doOp v (LMinus (ATInt ITChar)) [l, r] = doOp v (LMinus (ATInt ITNative)) [l, r]

294doOp v (LTimes (ATInt ITChar)) [l, r] = doOp v (LTimes (ATInt ITNative)) [l, r]

295−doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]

295+doOp v (LUDiv ITChar) [l, r] = doOp v (LUDiv ITNative) [l, r]

296−doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]

296+doOp v (LSDiv (ATInt ITChar)) [l, r] = doOp v (LSDiv (ATInt ITNative)) [l, r]

297−doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]

297+doOp v (LURem ITChar) [l, r] = doOp v (LURem ITNative) [l, r]

298−doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]

298+doOp v (LSRem (ATInt ITChar)) [l, r] = doOp v (LSRem (ATInt ITNative)) [l, r]

299−doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]

299+doOp v (LAnd ITChar) [l, r] = doOp v (LAnd ITNative) [l, r]

300−doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]

300+doOp v (LOr ITChar) [l, r] = doOp v (LOr ITNative) [l, r]

301−doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]

301+doOp v (LXOr ITChar) [l, r] = doOp v (LXOr ITNative) [l, r]

302−doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]

302+doOp v (LSHL ITChar) [l, r] = doOp v (LSHL ITNative) [l, r]

303−doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]

303+doOp v (LLSHR ITChar) [l, r] = doOp v (LLSHR ITNative) [l, r]

304−doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]

304+doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]

305−doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]

305+doOp v (LCompl ITChar) [x] = doOp v (LCompl ITNative) [x]

306−doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]

306+doOp v (LEq (ATInt ITChar)) [l, r] = doOp v (LEq (ATInt ITNative)) [l, r]

307−doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]

307+doOp v (LSLt (ATInt ITChar)) [l, r] = doOp v (LSLt (ATInt ITNative)) [l, r]

308−doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]

308+doOp v (LSLe (ATInt ITChar)) [l, r] = doOp v (LSLe (ATInt ITNative)) [l, r]

309doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]

310doOp v (LSGe (ATInt ITChar)) [l, r] = doOp v (LSGe (ATInt ITNative)) [l, r]

311−doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]

311+doOp v (LLt ITChar) [l, r] = doOp v (LLt ITNative) [l, r]

312−doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]

312+doOp v (LLe ITChar) [l, r] = doOp v (LLe ITNative) [l, r]

313doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]

314doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]

315

src/IRTS/CodegenLLVM.hs+4−4

@@ -216,7 +216,7 @@ initDefs tgt =

216 , G.name = Name $ "__idris_" ++ name

217 , G.basicBlocks = def

218 }

219−

219+

220 exfun :: String -> Type -> [Type] -> Bool -> Definition

221 exfun name rty argtys vari =

222 GlobalDefinition $ functionDefaults

@@ -562,7 +562,7 @@ cgCase val alts =

562 defExp = getDefExp =<< find isDefCase alts

563 constAlts = filter isConstCase alts

564 conAlts = filter isConCase alts

565−

565+

566 isConstCase (SConstCase {}) = True

567 isConstCase _ = False

568

@@ -806,7 +806,7 @@ addGlobal' ty val = do

806 , G.initializer = Just val

807 }

808 return . C.GlobalReference $ name

809−

809+

810

811ensureCDecl :: String -> FType -> [FType] -> Codegen Operand

812ensureCDecl name rty argtys = do

@@ -1110,7 +1110,7 @@ cgStrCat x y = do

1110 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []

1111 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []

1112 box FString mem

1113−

1113+

1114ibin :: IntTy -> Operand -> Operand

1115 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

1116ibin ity x y instCon = do

src/IRTS/Compiler.hs+30−30

@@ -80,7 +80,7 @@ compile codegen f tm

80 ViaC ->

81 codegenC c f outty hdrs

82 (concatMap mkObj objs)

83− (concatMap mkLib libs)

83+ (concatMap mkLib libs)

84 (concatMap mkFlag flags ++

85 concatMap incdir impdirs) NONE

86 ViaJava ->

@@ -114,12 +114,12 @@ allNames :: [Name] -> Name -> Idris [Name]

114allNames ns n | n `elem` ns = return []

115allNames ns n = do i <- getIState

116 case lookupCtxtExact n (idris_callgraph i) of

117− [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))

117+ [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))

118 return (nub (n : concat more))

119 _ -> return [n]

120

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

122−mkDecls t used

122+mkDecls t used

123 = do i <- getIState

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

125 mapM traceUnused used

@@ -129,10 +129,10 @@ mkDecls t used

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

130showCaseTrees ds = showSep "\n\n" (map showCT ds)

131 where

132− showCT (n, LFun _ f args lexp)

132+ showCT (n, LFun _ f args lexp)

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

134− ++ show lexp

134+ ++ show lexp

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

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

136

137isCon (TyDecl _ _) = True

138isCon _ = False

@@ -144,9 +144,9 @@ build :: (Name, Def) -> Idris (Name, LDecl)

144build (n, d)

145 = do i <- getIState

146 case lookup n (idris_scprims i) of

147− Just (ar, op) ->

147+ Just (ar, op) ->

148 let args = map (\x -> MN x "op") [0..] in

149− return (n, (LFun [] n (take ar args)

149+ return (n, (LFun [] n (take ar args)

150 (LOp op (map (LV . Glob) (take ar args)))))

151 _ -> do def <- mkLDecl n d

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

@@ -154,18 +154,18 @@ build (n, d)

154

155getPrim :: IState -> Name -> [LExp] -> Maybe LExp

156getPrim i n args = case lookup n (idris_scprims i) of

157− Just (ar, op) ->

157+ Just (ar, op) ->

158− if (ar == length args)

158+ if (ar == length args)

159 then return (LOp op args)

160 else Nothing

161 _ -> Nothing

162

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

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

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

165

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

167 return (declArgs [] True n e)

168−mkLDecl n (CaseOp ci _ _ pats cd)

168+mkLDecl n (CaseOp ci _ _ pats cd)

169 = let (args, sc) = cases_runtime cd in

170 do e <- ir (args, sc)

171 return (declArgs [] (case_inlinable ci) n e)

@@ -173,14 +173,14 @@ mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a

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

174mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n)))

175

176−instance ToIR (TT Name) where

176+instance ToIR (TT Name) where

177 ir tm = ir' [] tm where

178 ir' env tm@(App f a)

179 | (P _ (UN "mkForeignPrim") _, args) <- unApply tm

180 = doForeign env args

181 | (P _ (UN "unsafePerformPrimIO") _, [_, arg]) <- unApply tm

182 = ir' env arg

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

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

184 | (P _ (UN "replace") _, [_, _, _, _, _, arg]) <- unApply tm

185 = ir' env arg

186 | (P _ (UN "lazy") _, [_, arg]) <- unApply tm

@@ -198,11 +198,11 @@ instance ToIR (TT Name) where

198-- = do v' <- ir' env v

199-- return v'

200-- | (P _ (UN "prim_io_bind") _, [_,_,v,Bind n (Lam _) sc]) <- unApply tm

201−-- = do v' <- ir' env v

201+-- = do v' <- ir' env v

202-- sc' <- ir' (n:env) sc

203-- return (LLet n (LForce v') sc')

204-- | (P _ (UN "prim_io_bind") _, [_,_,v,k]) <- unApply tm

205−-- = do v' <- ir' env v

205+-- = do v' <- ir' env v

206-- k' <- ir' env k

207-- return (LApp False k' [LForce v'])

208 | (P _ (UN "malloc") _, [_,size,t]) <- unApply tm

@@ -223,20 +223,20 @@ instance ToIR (TT Name) where

223 case getPrim i n args' of

224 Just tm -> return tm

225 _ -> do

226− let collapse

226+ let collapse

227 = case lookupCtxtExact n

228 (idris_optimisation i) of

229 [oi] -> collapsible oi

230 _ -> False

231− let unused

231+ let unused

232 = case lookupCtxtExact n

233 (idris_callgraph i) of

234− [CGInfo _ _ _ _ unusedpos] ->

234+ [CGInfo _ _ _ _ unusedpos] ->

235 unusedpos

236 _ -> []

237− if collapse

237+ if collapse

238 then return LNothing

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

239+ else return (LApp False (LV (Glob n))

240 (mkUnused unused 0 args'))

241 | (f, args) <- unApply tm

242 = do f' <- ir' env f

@@ -270,10 +270,10 @@ instance ToIR (TT Name) where

270 irCon env t arity n args

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

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

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

273+ do sc' <- irCon env t arity n

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

275 return $ LLam extra sc'

276−

276+

277 satArgs n = map (\i -> MN i "sat") [1..n]

278

279 buildApp env e [] = return e

@@ -298,7 +298,7 @@ instance ToIR (TT Name) where

298getFTypes :: TT Name -> Maybe [FType]

299getFTypes tm = case unApply tm of

300 (nil, []) -> Just []

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

301+ (cons, [ty, xs]) ->

302 fmap (mkIty' ty :) (getFTypes xs)

303 _ -> Nothing

304

@@ -340,7 +340,7 @@ mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

340mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

341

342zname = NS (UN "Z") ["Nat","Prelude"]

343−sname = NS (UN "S") ["Nat","Prelude"]

343+sname = NS (UN "S") ["Nat","Prelude"]

344

345instance ToIR ([Name], SC) where

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

@@ -367,9 +367,9 @@ instance ToIR SC where

367-- = do n' <- ir n

368-- rhs' <- ir rhs

369-- return $ LDefaultCase

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

370+-- (LLet arg (LOp LBMinus [n', LConst (BI 1)])

371-- rhs')

372− mkIRAlt _ (ConCase n t args rhs)

372+ mkIRAlt _ (ConCase n t args rhs)

373 = do rhs' <- ir rhs

374 return $ LConCase (-1) n args rhs'

375 mkIRAlt _ (ConstCase x rhs)

@@ -377,15 +377,15 @@ instance ToIR SC where

377 = do rhs' <- ir rhs

378 return $ LConstCase x rhs'

379 | matchableTy x

380− = do rhs' <- ir rhs

380+ = do rhs' <- ir rhs

381 return $ LDefaultCase rhs'

382− mkIRAlt tm (SucCase n rhs)

382+ mkIRAlt tm (SucCase n rhs)

383 = do rhs' <- ir rhs

384 return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))

385 [tm,

386 LConst (BI 1)]) rhs')

387-- return $ LSucCase n rhs'

388− mkIRAlt _ (ConstCase c rhs)

388+ mkIRAlt _ (ConstCase c rhs)

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

390 mkIRAlt _ (DefaultCase rhs)

391 = do rhs' <- ir rhs

src/IRTS/Defunctionalise.hs+31−31

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

1−module IRTS.Defunctionalise(module IRTS.Defunctionalise,

1+module IRTS.Defunctionalise(module IRTS.Defunctionalise,

2 module IRTS.Lang) where

3

4import IRTS.Lang

@@ -37,8 +37,8 @@ data DDecl = DFun Name [Name] DExp -- name, arg names, definition

37

38type DDefs = Ctxt DDecl

39

40−defunctionalise :: Int -> LDefs -> DDefs

40+defunctionalise :: Int -> LDefs -> DDefs

41−defunctionalise nexttag defs

41+defunctionalise nexttag defs

42 = let all = toAlist defs

43 -- sort newcons so that EVAL and APPLY cons get sequential tags

44 (allD, enames) = runState (mapM (addApps defs) all) []

@@ -51,7 +51,7 @@ defunctionalise nexttag defs

51

52getFn :: [(Name, LDecl)] -> [(Name, Int)]

53getFn xs = mapMaybe fnData xs

54− where fnData (n, LFun _ _ args _) = Just (n, length args)

54+ where fnData (n, LFun _ _ args _) = Just (n, length args)

55 fnData _ = Nothing

56

57-- To defunctionalise:

@@ -68,9 +68,9 @@ getFn xs = mapMaybe fnData xs

68-- 8 Add explicit EVAL to case, primitives, and foreign calls

69

70addApps :: LDefs -> (Name, LDecl) -> State [Name] (Name, DDecl)

71−addApps defs o@(n, LConstructor _ t a)

71+addApps defs o@(n, LConstructor _ t a)

72− = return (n, DConstructor n t a)

72+ = return (n, DConstructor n t a)

73−addApps defs (n, LFun _ _ args e)

73+addApps defs (n, LFun _ _ args e)

74 = do e' <- aa args e

75 return (n, DFun n args e')

76 where

@@ -79,7 +79,7 @@ addApps defs (n, LFun _ _ args e)

79 | otherwise = aa env (LApp False (LV (Glob n)) [])

80-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e

81 aa env (LApp tc (LV (Glob n)) args)

82− = do args' <- mapM (aa env) args

82+ = do args' <- mapM (aa env) args

83 case lookupCtxtExact n defs of

84 [LConstructor _ i ar] -> return $ DApp tc n args'

85 [LFun _ _ as _] -> let arity = length as in

@@ -96,7 +96,7 @@ addApps defs (n, LFun _ _ args e)

96 aa env (LForce e) = liftM eEVAL (aa env e)

97 aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc)

98 aa env (LCon i n args) = liftM (DC i n) (mapM (aa env) args)

99− aa env (LProj t@(LV (Glob n)) i)

99+ aa env (LProj t@(LV (Glob n)) i)

100 = do t' <- aa env t

101 return $ DProj (DUpdate n (eEVAL t')) i

102 aa env (LProj t i) = do t' <- aa env t

@@ -115,33 +115,33 @@ addApps defs (n, LFun _ _ args e)

115 aaF env (t, e) = do e' <- aa env e

116 return (t, eEVAL e')

117

118− aaAlt env (LConCase i n args e)

118+ aaAlt env (LConCase i n args e)

119 = liftM (DConCase i n args) (aa (args ++ env) e)

120 aaAlt env (LConstCase c e) = liftM (DConstCase c) (aa env e)

121 aaAlt env (LDefaultCase e) = liftM DDefaultCase (aa env e)

122

123− fixApply tc n args ar

123+ fixApply tc n args ar

124− | length args == ar

124+ | length args == ar

125 = return $ DApp tc n args

126− | length args < ar

126+ | length args < ar

127 = do ns <- get

128 put $ nub (n : ns)

129 return $ DApp tc (mkUnderCon n (ar - length args)) args

130− | length args > ar

130+ | length args > ar

131 = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)

132

133− fixLazyApply n args ar

133+ fixLazyApply n args ar

134− | length args == ar

134+ | length args == ar

135 = do ns <- get

136 put $ nub (n : ns)

137 return $ DApp False (mkFnCon n) args

138− | length args < ar

138+ | length args < ar

139 = do ns <- get

140 put $ nub (n : ns)

141 return $ DApp False (mkUnderCon n (ar - length args)) args

142− | length args > ar

142+ | length args > ar

143 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)

144−

144+

145 chainAPPLY f [] = f

146 chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as

147

@@ -149,7 +149,7 @@ addApps defs (n, LFun _ _ args e)

149 -- but we only want to do it once, rather than every time we project.

150

151 preEval [] t = t

152− preEval (x : xs) t

152+ preEval (x : xs) t

153 | needsEval x t = DLet x (eEVAL (DV (Glob x))) (preEval xs t)

154 | otherwise = preEval xs t

155

@@ -163,7 +163,7 @@ addApps defs (n, LFun _ _ args e)

163 where nec (DConCase _ _ _ e) = needsEval x e

164 nec (DConstCase _ e) = needsEval x e

165 nec (DDefaultCase e) = needsEval x e

166− needsEval x (DLet n v e)

166+ needsEval x (DLet n v e)

167 | x == n = needsEval x v

168 | otherwise = needsEval x v || needsEval x e

169 needsEval x (DForeign _ _ _ args) = or (map (needsEval x) (map snd args))

@@ -181,9 +181,9 @@ data EvalApply a = EvalCase (Name -> a)

181-- data constuctors, and whether to handle them in EVAL or APPLY

182

183toCons :: [Name] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]

184−toCons ns (n, i)

184+toCons ns (n, i)

185 | n `elem` ns

186− = (mkFnCon n, i,

186+ = (mkFnCon n, i,

187 EvalCase (\tlarg ->

188 (DConCase (-1) (mkFnCon n) (take i (genArgs 0))

189 (dupdate tlarg

@@ -193,11 +193,11 @@ toCons ns (n, i)

193 where dupdate tlarg x = x

194

195mkApplyCase fname n ar | n == ar = []

196−mkApplyCase fname n ar

196+mkApplyCase fname n ar

197 = let nm = mkUnderCon fname (ar - n) in

198 (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))

199− (DApp False (mkUnderCon fname (ar - (n + 1)))

199+ (DApp False (mkUnderCon fname (ar - (n + 1)))

200− (map (DV . Glob) (take n (genArgs 0) ++

200+ (map (DV . Glob) (take n (genArgs 0) ++

201 [MN 0 "arg"])))))

202 : mkApplyCase fname (n + 1) ar

203

@@ -207,7 +207,7 @@ mkEval xs = (MN 0 "EVAL", DFun (MN 0 "EVAL") [MN 0 "arg"]

207 (mapMaybe evalCase xs ++

208 [DDefaultCase (DV (Glob (MN 0 "arg")))])))

209 where

210− evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg"))

210+ evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg"))

211 evalCase _ = Nothing

212

213mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

@@ -259,7 +259,7 @@ instance Show DExp where

259 show' env (DError str) = "error " ++ show str

260 show' env DNothing = "____"

261

262− showAlt env (DConCase _ n args e)

262+ showAlt env (DConCase _ n args e)

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

264 ++ show' env e

265 showAlt env (DConstCase c e) = show c ++ " => " ++ show' env e

@@ -268,7 +268,7 @@ instance Show DExp where

268-- Divide up a large case expression so that each has a maximum of

269-- 'max' branches

270

271−mkBigCase cn max arg branches

271+mkBigCase cn max arg branches

272 | length branches <= max = DChkCase arg branches

273 | otherwise = -- DChkCase arg branches -- until I think of something...

274 -- divide the branches into groups of at most max (by tag),

@@ -281,7 +281,7 @@ mkBigCase cn max arg branches

281 cs = map mkCase bss in

282 DChkCase arg branches

283

284− where mkCase bs = DChkCase arg bs

284+ where mkCase bs = DChkCase arg bs

285

286 tagOrd (DConCase t _ _ _) (DConCase t' _ _ _) = compare t t'

287 tagOrd (DConstCase c _) (DConstCase c' _) = compare c c'

@@ -309,7 +309,7 @@ groupsOf x xs = let (batch, rest) = span (tagLT (x + tagHead xs)) xs in

309

310dumpDefuns :: DDefs -> String

311dumpDefuns ds = showSep "\n" $ map showDef (toAlist ds)

312− where showDef (x, DFun fn args exp)

312+ where showDef (x, DFun fn args exp)

313 = show fn ++ "(" ++ showSep ", " (map show args) ++ ") = \n\t" ++

314 show exp ++ "\n"

315 showDef (x, DConstructor n t a) = "Constructor " ++ show n ++ " " ++ show t

src/IRTS/DumpBC.hs+1−1

@@ -50,7 +50,7 @@ serializeBC n bc = indent n ++

50 CALL x -> "CALL " ++ show x

51 TAILCALL x -> "TAILCALL " ++ show x

52 FOREIGNCALL r _ ret name args ->

53− "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret ++

53+ "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret ++

54 " [" ++ interMap args ", " (\(ty, r) -> serializeReg r ++ " : " ++ show ty) ++ "]"

55 SLIDE n -> "SLIDE " ++ show n

56 REBASE -> "REBASE"

src/IRTS/Inliner.hs+2−2

@@ -4,13 +4,13 @@ import Core.TT

4

5import IRTS.Defunctionalise

6

7−inline :: DDefs -> DDefs

7+inline :: DDefs -> DDefs

8inline xs = let sep = toAlist xs

9 inls = map (inl xs) sep in

10 addAlist inls emptyContext

11

12inl :: DDefs -> (Name, DDecl) -> (Name, DDecl)

13−inl ds d@(n, DFun n' args exp)

13+inl ds d@(n, DFun n' args exp)

14 = case evalD ds exp of

15 Just exp' -> (n, DFun n' args exp')

16 _ -> d

src/IRTS/LParser.hs+13−13

@@ -31,7 +31,7 @@ type TokenParser a = PTok.TokenParser a

31type LParser = GenParser Char ()

32

33lexer :: TokenParser ()

34−lexer = idrisLexer

34+lexer = idrisLexer

35

36whiteSpace= PTok.whiteSpace lexer

37lexeme = PTok.lexeme lexer

@@ -75,7 +75,7 @@ parseFOVM fname = do -- putStrLn $ "Reading " ++ fname

75pProgram :: LParser [(Name, LDecl)]

76pProgram = do fs <- many1 pLDecl

77 eof

78− return fs

78+ return fs

79

80pLDecl :: LParser (Name, LDecl)

81pLDecl = do reserved "data"

@@ -91,7 +91,7 @@ pLDecl = do reserved "data"

91 def <- pLExp

92 return (n, LFun [] n args def)

93

94−pLExp = buildExpressionParser optable pLExp'

94+pLExp = buildExpressionParser optable pLExp'

95

96optable = [[binary "*" (\x y -> LOp (LTimes (ATInt ITNative)) [x,y]) AssocLeft,

97 binary "/" (\x y -> LOp (LSDiv (ATInt ITNative)) [x,y]) AssocLeft,

@@ -149,9 +149,9 @@ pLExp' = try (do lchar '%'; pCast)

149 lchar '('

150 args <- sepBy pLExp (lchar ',')

151 lchar ')'

152− if null args

152+ if null args

153 then if lazy then return (LLazyApp x [])

154− else return (LV (Glob x))

154+ else return (LV (Glob x))

155 else if lazy then return (LLazyApp x args)

156 else return (LApp tc (LV (Glob x)) args))

157 <|> do lchar '('; e <- pLExp; lchar ')'; return e

@@ -172,7 +172,7 @@ pLExp' = try (do lchar '%'; pCast)

172 <|> pCase

173 <|> do x <- iName []

174 return (LV (Glob x))

175−

175+

176pLang = do reserved "C"; return LANG_C

177

178pType = do reserved "Int"; return (FArith (ATInt ITNative))

@@ -215,10 +215,10 @@ pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'

215pPrim :: LParser LExp

216pPrim = do reserved "StrEq"; lchar '(';

217 e <- pLExp; lchar ',';

218− e' <- pLExp; lchar ')';

218+ e' <- pLExp; lchar ')';

219 return (LOp LStrEq [e, e'])

220 <|> do reserved "StrLt"; lchar '('

221− e <- pLExp; lchar ','; e' <- pLExp;

221+ e <- pLExp; lchar ','; e' <- pLExp;

222 lchar ')'

223 return (LOp LStrLt [e, e'])

224 <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')';

@@ -228,7 +228,7 @@ pPrim = do reserved "StrEq"; lchar '(';

228 <|> do reserved "WriteString"; lchar '(';

229 e <- pLExp; lchar ')'

230 return (LOp LPrintStr [e])

231− <|> do reserved "WriteInt"; lchar '(';

231+ <|> do reserved "WriteInt"; lchar '(';

232 e <- pLExp; lchar ')';

233 return (LOp LPrintNum [e])

234 <|> do reserved "lazy"; lchar '(';

@@ -240,10 +240,10 @@ pPrim = do reserved "StrEq"; lchar '(';

240 return (LOp LStrTail [e])

241 <|> do reserved "StrRev"; lchar '('; e <- pLExp; lchar ')';

242 return (LOp LStrRev [e])

243− <|> do reserved "StrCons"; lchar '('; x <- pLExp; lchar ',';

243+ <|> do reserved "StrCons"; lchar '('; x <- pLExp; lchar ',';

244 xs <- pLExp; lchar ')';

245 return (LOp LStrCons [x, xs])

246− <|> do reserved "StrIndex"; lchar '('; x <- pLExp; lchar ',';

246+ <|> do reserved "StrIndex"; lchar '('; x <- pLExp; lchar ',';

247 i <- pLExp; lchar ')';

248 return (LOp LStrIndex [x, i])

249

@@ -269,8 +269,8 @@ pAlt = try (do x <- iName []

269

270pLConst :: LParser LExp

271pLConst = try (do f <- float; return $ LConst (Fl f))

272− <|> try (do i <- natural; lchar ':'; return $ LConst (BI i))

272+ <|> try (do i <- natural; lchar ':'; return $ LConst (BI i))

273− <|> try (do i <- natural; return $ LConst (I (fromInteger i)))

273+ <|> try (do i <- natural; return $ LConst (I (fromInteger i)))

274 <|> try (do s <- strlit; return $ LConst (Str s))

275 <|> try (do c <- chlit; return $ LConst (Ch c))

276

src/IRTS/Simplified.hs+20−20

@@ -7,7 +7,7 @@ import Control.Monad.State

7

8import Debug.Trace

9

10−-- Simplified expressions, where functions/constructors can only be applied

10+-- Simplified expressions, where functions/constructors can only be applied

11-- to variables

12

13data SExp = SV LVar

@@ -44,14 +44,14 @@ ldefs = do (l, h) <- get

44

45simplify :: Bool -> DExp -> State (DDefs, Int) SExp

46simplify tl (DV (Loc i)) = return (SV (Loc i))

47−simplify tl (DV (Glob x))

47+simplify tl (DV (Glob x))

48 = do ctxt <- ldefs

49 case lookupCtxtExact x ctxt of

50 [DConstructor _ t 0] -> return $ SCon t x []

51 _ -> return $ SV (Glob x)

52simplify tl (DApp tc n args) = do args' <- mapM sVar args

53 mkapp (SApp (tl || tc) n) args'

54−simplify tl (DForeign lang ty fn args)

54+simplify tl (DForeign lang ty fn args)

55 = do args' <- mapM sVar (map snd args)

56 let fargs = zip (map fst args) args'

57 mkfapp (SForeign lang ty fn) fargs

@@ -69,21 +69,21 @@ simplify tl (DProj t i) = do v <- sVar t

69 return (SLet (Glob x) e (SProj (Glob x) i))

70simplify tl (DCase e alts) = do v <- sVar e

71 alts' <- mapM (sAlt tl) alts

72− case v of

72+ case v of

73 (x, Nothing) -> return (SCase x alts')

74− (Glob x, Just e) ->

74+ (Glob x, Just e) ->

75 return (SLet (Glob x) e (SCase (Glob x) alts'))

76−simplify tl (DChkCase e alts)

76+simplify tl (DChkCase e alts)

77 = do v <- sVar e

78 alts' <- mapM (sAlt tl) alts

79− case v of

79+ case v of

80 (x, Nothing) -> return (SChkCase x alts')

81− (Glob x, Just e) ->

81+ (Glob x, Just e) ->

82 return (SLet (Glob x) e (SChkCase (Glob x) alts'))

83simplify tl (DConst c) = return (SConst c)

84simplify tl (DOp p args) = do args' <- mapM sVar args

85 mkapp (SOp p) args'

86−simplify tl DNothing = return SNothing

86+simplify tl DNothing = return SNothing

87simplify tl (DError str) = return $ SError str

88

89sVar (DV (Glob x))

@@ -99,14 +99,14 @@ sVar e = do e' <- simplify False e

99mkapp f args = mkapp' f args [] where

100 mkapp' f [] args = return $ f (reverse args)

101 mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args)

102− mkapp' f ((x, Just e) : xs) args

102+ mkapp' f ((x, Just e) : xs) args

103 = do sc <- mkapp' f xs (x : args)

104 return (SLet x e sc)

105

106mkfapp f args = mkapp' f args [] where

107 mkapp' f [] args = return $ f (reverse args)

108 mkapp' f ((ty, (x, Nothing)) : xs) args = mkapp' f xs ((ty, x) : args)

109− mkapp' f ((ty, (x, Just e)) : xs) args

109+ mkapp' f ((ty, (x, Just e)) : xs) args

110 = do sc <- mkapp' f xs ((ty, x) : args)

111 return (SLet x e sc)

112

@@ -119,10 +119,10 @@ sAlt tl (DDefaultCase e) = do e' <- simplify tl e

119

120checkDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]

121checkDefs ctxt [] = return []

122−checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)

122+checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)

123 = do xs' <- checkDefs ctxt xs

124 return xs'

125−checkDefs ctxt ((n, DFun n' args exp) : xs)

125+checkDefs ctxt ((n, DFun n' args exp) : xs)

126 = do let sexp = evalState (simplify True exp) (ctxt, 0)

127 (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args)

128 xs' <- checkDefs ctxt xs

@@ -131,14 +131,14 @@ checkDefs ctxt ((n, DFun n' args exp) : xs)

131lvar v = do i <- get

132 put (max i v)

133

134−scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp

134+scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp

135scopecheck ctxt envTop tm = sc envTop tm where

136 sc env (SV (Glob n)) =

137 case lookup n (reverse env) of -- most recent first

138 Just i -> do lvar i; return (SV (Loc i))

139 Nothing -> case lookupCtxtExact n ctxt of

140 [DConstructor _ i ar] ->

141− if True -- ar == 0

141+ if True -- ar == 0

142 then return (SCon i n [])

143 else fail $ "Codegen error: Constructor " ++ show n ++

144 " has arity " ++ show ar

@@ -150,7 +150,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

150 [DConstructor n tag ar] ->

151 if True -- (ar == length args)

152 then return $ SCon tag n args'

153− else fail $ "Codegen error: Constructor " ++ show f ++

153+ else fail $ "Codegen error: Constructor " ++ show f ++

154 " has arity " ++ show ar

155 [_] -> return $ SApp tc f args'

156 [] -> fail $ "Codegen error: No such variable " ++ show f

@@ -164,7 +164,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

164 [DConstructor n tag ar] ->

165 if True -- (ar == length args)

166 then return $ SCon tag n args'

167− else fail $ "Codegen error: Constructor " ++ show f ++

167+ else fail $ "Codegen error: Constructor " ++ show f ++

168 " has arity " ++ show ar

169 _ -> fail $ "Codegen error: No such constructor " ++ show f

170 sc env (SProj e i)

@@ -201,15 +201,15 @@ scopecheck ctxt envTop tm = sc envTop tm where

201 [DConstructor _ i ar] ->

202 fail $ "Codegen error : can't pass constructor here"

203 [_] -> return (Glob n)

204− [] -> fail $ "Codegen error: No such variable " ++ show n ++

204+ [] -> fail $ "Codegen error: No such variable " ++ show n ++

205 " in " ++ show tm ++ " " ++ show envTop

206 scVar _ x = return x

207

208 scalt env (SConCase _ i n args e)

209 = do let env' = env ++ zip args [length env..]

210 tag <- case lookupCtxtExact n ctxt of

211− [DConstructor _ i ar] ->

211+ [DConstructor _ i ar] ->

212− if True -- (length args == ar)

212+ if True -- (length args == ar)

213 then return i

214 else fail $ "Codegen error: Constructor " ++ show n ++

215 " has arity " ++ show ar

src/Idris/AbsSyntax.hs+108−108

@@ -90,7 +90,7 @@ addLangExt ErrorReflection = do i <- getIState

90 }

91

92addTrans :: (Term, Term) -> Idris ()

93−addTrans t = do i <- getIState

93+addTrans t = do i <- getIState

94 putIState $ i { idris_transforms = t : idris_transforms i }

95

96totcheck :: (FC, Name) -> Idris ()

@@ -103,19 +103,19 @@ setFlags :: Name -> [FnOpt] -> Idris ()

103setFlags n fs = do i <- getIState; putIState $ i { idris_flags = addDef n fs (idris_flags i) }

104

105setAccessibility :: Name -> Accessibility -> Idris ()

106−setAccessibility n a

106+setAccessibility n a

107 = do i <- getIState

108 let ctxt = setAccess n a (tt_ctxt i)

109 putIState $ i { tt_ctxt = ctxt }

110

111setTotality :: Name -> Totality -> Idris ()

112−setTotality n a

112+setTotality n a

113 = do i <- getIState

114 let ctxt = setTotal n a (tt_ctxt i)

115 putIState $ i { tt_ctxt = ctxt }

116

117getTotality :: Name -> Idris Totality

118−getTotality n

118+getTotality n

119 = do i <- getIState

120 case lookupTotal n (tt_ctxt i) of

121 [t] -> return t

@@ -131,13 +131,13 @@ getCoercionsTo i ty =

131 findCoercions t (n : ns) =

132 let ps = case lookupTy n (tt_ctxt i) of

133 [ty] -> case unApply (getRetTy ty) of

134− (t', _) ->

134+ (t', _) ->

135 if t == t' then [n] else []

136 _ -> [] in

137 ps ++ findCoercions t ns

138

139addToCG :: Name -> CGInfo -> Idris ()

140−addToCG n cg

140+addToCG n cg

141 = do i <- getIState

142 putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) }

143

@@ -146,7 +146,7 @@ addCoercion n = do i <- getIState

146 putIState $ i { idris_coercions = nub $ n : idris_coercions i }

147

148addDocStr :: Name -> String -> Idris ()

149−addDocStr n doc

149+addDocStr n doc

150 = do i <- getIState

151 putIState $ i { idris_docstrings = addDef n doc (idris_docstrings i) }

152

@@ -158,7 +158,7 @@ addToCalledG n ns = return () -- TODO

158-- Dodgy hack 2: put constraint chasers (@@) last

159

160addInstance :: Bool -> Name -> Name -> Idris ()

161−addInstance int n i

161+addInstance int n i

162 = do ist <- getIState

163 case lookupCtxt n (idris_classes ist) of

164 [CI a b c d ins] ->

@@ -178,7 +178,7 @@ addInstance int n i

178 chaser _ = False

179

180addClass :: Name -> ClassInfo -> Idris ()

181−addClass n i

181+addClass n i

182 = do ist <- getIState

183 let i' = case lookupCtxt n (idris_classes ist) of

184 [c] -> c { class_instances = class_instances i }

@@ -186,7 +186,7 @@ addClass n i

186 putIState $ ist { idris_classes = addDef n i' (idris_classes ist) }

187

188addIBC :: IBCWrite -> Idris ()

189−addIBC ibc@(IBCDef n)

189+addIBC ibc@(IBCDef n)

190 = do i <- getIState

191 when (notDef (ibc_write i)) $

192 putIState $ i { ibc_write = ibc : ibc_write i }

@@ -249,15 +249,15 @@ getInternalApp fp l = do i <- getIState

249 -- TODO: What if it's not there?

250

251checkUndefined :: FC -> Name -> Idris ()

252−checkUndefined fc n

252+checkUndefined fc n

253 = do i <- getContext

254 case lookupTy n i of

255− (_:_) -> fail $ show fc ++ ":" ++

255+ (_:_) -> fail $ show fc ++ ":" ++

256 show n ++ " already defined"

257 _ -> return ()

258

259isUndefined :: FC -> Name -> Idris Bool

260−isUndefined fc n

260+isUndefined fc n

261 = do i <- getContext

262 case lookupTy n i of

263 (_:_) -> return False

@@ -282,10 +282,10 @@ addDeferred = addDeferred' Ref

282addDeferredTyCon = addDeferred' (TCon 0 0)

283

284addDeferred' :: NameType -> [(Name, (Int, Maybe Name, Type))] -> Idris ()

285−addDeferred' nt ns

285+addDeferred' nt ns

286 = do mapM_ (\(n, (i, _, t)) -> updateContext (addTyDecl n nt (tidyNames [] t))) ns

287 i <- getIState

288− putIState $ i { idris_metavars = map (\(n, (i, top, _)) -> (n, (top, i))) ns ++

288+ putIState $ i { idris_metavars = map (\(n, (i, top, _)) -> (n, (top, i))) ns ++

289 idris_metavars i }

290 where tidyNames used (Bind (MN i x) b sc)

291 = let n' = uniqueName (UN x) used in

@@ -297,7 +297,7 @@ addDeferred' nt ns

297

298solveDeferred :: Name -> Idris ()

299solveDeferred n = do i <- getIState

300− putIState $ i { idris_metavars =

300+ putIState $ i { idris_metavars =

301 filter (\(n', _) -> n/=n')

302 (idris_metavars i) }

303

@@ -607,7 +607,7 @@ bi = fileFC "builtin"

607

608inferTy = MN 0 "__Infer"

609inferCon = MN 0 "__infer"

610−inferDecl = PDatadecl inferTy

610+inferDecl = PDatadecl inferTy

611 PType

612 [("", inferCon, PPi impl (MN 0 "A") PType (

613 PPi expl (MN 0 "a") (PRef bi (MN 0 "A"))

@@ -644,7 +644,7 @@ pairDecl = PDatadecl pairTy (piBind [(n "A", PType), (n "B", PType)] PType)

644 [("", pairCon, PPi impl (n "A") PType (

645 PPi impl (n "B") PType (

646 PPi expl (n "a") (PRef bi (n "A")) (

647− PPi expl (n "b") (PRef bi (n "B"))

647+ PPi expl (n "b") (PRef bi (n "B"))

648 (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

649 pexp (PRef bi (n "B"))])))), bi)]

650 where n a = MN 0 a

@@ -672,10 +672,10 @@ piBind = piBindp expl

672piBindp :: Plicity -> [(Name, PTerm)] -> PTerm -> PTerm

673piBindp p [] t = t

674piBindp p ((n, ty):ns) t = PPi p n ty (piBindp p ns t)

675−

675+

676-- Dealing with parameters

677

678−expandParams :: (Name -> Name) -> [(Name, PTerm)] ->

678+expandParams :: (Name -> Name) -> [(Name, PTerm)] ->

679 [Name] -> -- all names

680 [Name] -> -- names with no declaration

681 PTerm -> PTerm

@@ -686,7 +686,7 @@ expandParams dec ps ns infs tm = en tm

686 -- binding and once to call the lifted functions. So we'll explicitly shadow

687 -- it. (Yes, it's a hack. The alternative would be to resolve names earlier

688 -- but we didn't...)

689−

689+

690 mkShadow (UN n) = MN 0 n

691 mkShadow (MN i n) = MN (i+1) n

692 mkShadow (NS x s) = NS (mkShadow x) s

@@ -696,18 +696,18 @@ expandParams dec ps ns infs tm = en tm

696 = let n' = mkShadow n in

697 PLam n' (en t) (en (shadow n n' s))

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

699− en (PPi p n t s)

699+ en (PPi p n t s)

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

701 = let n' = mkShadow n in

702 PPi p n' (en t) (en (shadow n n' s))

703 | otherwise = PPi p n (en t) (en s)

704− en (PLet n ty v s)

704+ en (PLet n ty v s)

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

706 = let n' = mkShadow n in

707 PLet n' (en ty) (en v) (en (shadow n n' s))

708 | otherwise = PLet n (en ty) (en v) (en s)

709− -- FIXME: Should only do this in a type signature!

709+ -- FIXME: Should only do this in a type signature!

710− en (PDPair f (PRef f' n) t r)

710+ en (PDPair f (PRef f' n) t r)

711 | n `elem` (map fst ps ++ ns) && t /= Placeholder

712 = let n' = mkShadow n in

713 PDPair f (PRef f' n') (en t) (en (shadow n n' r))

@@ -724,28 +724,28 @@ expandParams dec ps ns infs tm = en tm

724 en (PProof ts) = PProof (map (fmap en) ts)

725 en (PTactics ts) = PTactics (map (fmap en) ts)

726

727− en (PQuote (Var n))

727+ en (PQuote (Var n))

728 | n `nselem` ns = PQuote (Var (dec n))

729 en (PApp fc (PInferRef fc' n) as)

730− | n `nselem` ns = PApp fc (PInferRef fc' (dec n))

730+ | n `nselem` ns = PApp fc (PInferRef fc' (dec n))

731 (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as))

732 en (PApp fc (PRef fc' n) as)

733− | n `elem` infs = PApp fc (PInferRef fc' (dec n))

733+ | n `elem` infs = PApp fc (PInferRef fc' (dec n))

734 (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as))

735− | n `nselem` ns = PApp fc (PRef fc' (dec n))

735+ | n `nselem` ns = PApp fc (PRef fc' (dec n))

736 (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as))

737 en (PAppBind fc (PRef fc' n) as)

738− | n `elem` infs = PAppBind fc (PInferRef fc' (dec n))

738+ | n `elem` infs = PAppBind fc (PInferRef fc' (dec n))

739 (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as))

740− | n `nselem` ns = PAppBind fc (PRef fc' (dec n))

740+ | n `nselem` ns = PAppBind fc (PRef fc' (dec n))

741 (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as))

742 en (PRef fc n)

743− | n `elem` infs = PApp fc (PInferRef fc (dec n))

743+ | n `elem` infs = PApp fc (PInferRef fc (dec n))

744 (map (pexp . (PRef fc)) (map fst ps))

745− | n `nselem` ns = PApp fc (PRef fc (dec n))

745+ | n `nselem` ns = PApp fc (PRef fc (dec n))

746 (map (pexp . (PRef fc)) (map fst ps))

747 en (PInferRef fc n)

748− | n `nselem` ns = PApp fc (PInferRef fc (dec n))

748+ | n `nselem` ns = PApp fc (PInferRef fc (dec n))

749 (map (pexp . (PRef fc)) (map fst ps))

750 en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)

751 en (PAppBind fc f as) = PAppBind fc (en f) (map (fmap en) as)

@@ -759,20 +759,20 @@ expandParams dec ps ns infs tm = en tm

759 nseq x y = nsroot x == nsroot y

760

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

762− IState ->

762+ IState ->

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

764−expandParamsD rhsonly ist dec ps ns (PTy doc syn fc o n ty)

764+expandParamsD rhsonly ist dec ps ns (PTy doc syn fc o n ty)

765 = if n `elem` ns && (not rhsonly)

766 then -- trace (show (n, expandParams dec ps ns ty)) $

767 PTy doc syn fc o (dec n) (piBindp expl_param ps (expandParams dec ps ns [] ty))

768− else --trace (show (n, expandParams dec ps ns ty)) $

768+ else --trace (show (n, expandParams dec ps ns ty)) $

769 PTy doc syn fc o n (expandParams dec ps ns [] ty)

770−expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty)

770+expandParamsD rhsonly ist dec ps ns (PPostulate doc syn fc o n ty)

771 = if n `elem` ns && (not rhsonly)

772 then -- trace (show (n, expandParams dec ps ns ty)) $

773− PPostulate doc syn fc o (dec n) (piBind ps

773+ PPostulate doc syn fc o (dec n) (piBind ps

774 (expandParams dec ps ns [] ty))

775− else --trace (show (n, expandParams dec ps ns ty)) $

775+ else --trace (show (n, expandParams dec ps ns ty)) $

776 PPostulate doc syn fc o n (expandParams dec ps ns [] ty)

777expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

778 = let n' = if n `elem` ns then dec n else n in

@@ -782,7 +782,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

782 = let -- ps' = updateps True (namesIn ist rhs) (zip ps [0..])

783 ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..])

784 lhs' = if rhsonly then lhs else (expandParams dec ps'' ns [] lhs)

785− n' = if n `elem` ns then dec n else n

785+ n' = if n `elem` ns then dec n else n

786 -- names bound on the lhs should not be expanded on the rhs

787 ns' = removeBound lhs ns in

788 PClause fc n' lhs'

@@ -793,7 +793,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

793 = let -- ps' = updateps True (namesIn ist wval) (zip ps [0..])

794 ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..])

795 lhs' = if rhsonly then lhs else (expandParams dec ps'' ns [] lhs)

796− n' = if n `elem` ns then dec n else n

796+ n' = if n `elem` ns then dec n else n

797 ns' = removeBound lhs ns in

798 PWith fc n' lhs'

799 (map (expandParams dec ps'' ns' []) ws)

@@ -812,32 +812,32 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

812 bnames (PDPair _ l Placeholder r) = bnames l ++ bnames r

813 bnames _ = []

814

815−expandParamsD rhs ist dec ps ns (PData doc syn fc co pd)

815+expandParamsD rhs ist dec ps ns (PData doc syn fc co pd)

816 = PData doc syn fc co (expandPData pd)

817 where

818 -- just do the type decl, leave constructors alone (parameters will be

819 -- added implicitly)

820− expandPData (PDatadecl n ty cons)

820+ expandPData (PDatadecl n ty cons)

821 = if n `elem` ns

822− then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))

822+ then PDatadecl (dec n) (piBind ps (expandParams dec ps ns [] ty))

823 (map econ cons)

824 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

825− econ (doc, n, t, fc)

825+ econ (doc, n, t, fc)

826 = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc)

827expandParamsD rhs ist dec ps ns (PParams f params pds)

828− = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

828+ = PParams f (ps ++ map (mapsnd (expandParams dec ps ns [])) params)

829 (map (expandParamsD True ist dec ps ns) pds)

830−-- (map (expandParamsD ist dec ps ns) pds)

830+-- (map (expandParamsD ist dec ps ns) pds)

831expandParamsD rhs ist dec ps ns (PMutual f pds)

832 = PMutual f (map (expandParamsD rhs ist dec ps ns) pds)

833expandParamsD rhs ist dec ps ns (PClass doc info f cs n params decls)

834− = PClass doc info f

834+ = PClass doc info f

835 (map (expandParams dec ps ns []) cs)

836 n

837 (map (mapsnd (expandParams dec ps ns [])) params)

838 (map (expandParamsD rhs ist dec ps ns) decls)

839expandParamsD rhs ist dec ps ns (PInstance info f cs n params ty cn decls)

840− = PInstance info f

840+ = PInstance info f

841 (map (expandParams dec ps ns []) cs)

842 n

843 (map (expandParams dec ps ns []) params)

@@ -855,7 +855,7 @@ mapsnd f (x, t) = (x, f t)

855-- * finally, everything else (3)

856

857getPriority :: IState -> PTerm -> Int

858−getPriority i tm = 1 -- pri tm

858+getPriority i tm = 1 -- pri tm

859 where

860 pri (PRef _ n) =

861 case lookupP n (tt_ctxt i) of

@@ -869,9 +869,9 @@ getPriority i tm = 1 -- pri tm

869 pri (PRefl _ _) = 1

870 pri (PEq _ l r) = max 1 (max (pri l) (pri r))

871 pri (PRewrite _ l r _) = max 1 (max (pri l) (pri r))

872− pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

872+ pri (PApp _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

873− pri (PAppBind _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

873+ pri (PAppBind _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.getTm) as)))

874− pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as)))

874+ pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as)))

875 pri (PTyped l r) = pri l

876 pri (PPair _ l r) = max 1 (max (pri l) (pri r))

877 pri (PDPair _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

@@ -888,7 +888,7 @@ addStatics n tm ptm =

888 when (not (null statics)) $

889 logLvl 7 $ show n ++ " " ++ show statics ++ "\n" ++ show dynamics

890 ++ "\n" ++ show stnames ++ "\n" ++ show dnames

891− let statics' = nub $ map fst statics ++

891+ let statics' = nub $ map fst statics ++

892 filter (\x -> not (elem x dnames)) stnames

893 let stpos = staticList statics' tm

894 i <- getIState

@@ -909,7 +909,7 @@ addStatics n tm ptm =

909-- Add constraint bindings from using block

910

911addUsingConstraints :: SyntaxInfo -> FC -> PTerm -> Idris PTerm

912−addUsingConstraints syn fc t

912+addUsingConstraints syn fc t

913 = do ist <- get

914 let ns = namesIn [] ist t

915 let cs = getConstraints t -- check declared constraints

@@ -924,12 +924,12 @@ addUsingConstraints syn fc t

924 doAdd [] _ t = t

925 -- if all of args in ns, then add it

926 doAdd (UConstraint c args : cs) ns t

927− | all (\n -> elem n ns) args

927+ | all (\n -> elem n ns) args

928 = PPi (Constraint False Dynamic "") (MN 0 "cu")

929 (mkConst c args) (doAdd cs ns t)

930 | otherwise = doAdd cs ns t

931

932− mkConst c args = PApp fc (PRef fc c)

932+ mkConst c args = PApp fc (PRef fc c)

933 (map (\n -> PExp 0 False (PRef fc n) "") args)

934

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

@@ -937,7 +937,7 @@ addUsingConstraints syn fc t

937 getConstraints (PPi _ _ c sc) = getConstraints sc

938 getConstraints _ = []

939

940− getcapp (PApp _ (PRef _ c) args)

940+ getcapp (PApp _ (PRef _ c) args)

941 = do ns <- mapM getName args

942 return (UConstraint c ns)

943 getcapp _ = []

@@ -954,7 +954,7 @@ implicit :: SyntaxInfo -> Name -> PTerm -> Idris PTerm

954implicit syn n ptm = implicit' syn [] n ptm

955

956implicit' :: SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

957−implicit' syn ignore n ptm

957+implicit' syn ignore n ptm

958 = do i <- getIState

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

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

@@ -967,12 +967,12 @@ implicit' syn ignore n ptm

967

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

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

970− let (declimps, ns') = execState (imps True [] tm) ([], [])

970+ let (declimps, ns') = execState (imps True [] tm) ([], [])

971 ns = filter (\n -> implicitable n || elem n (map fst uvars)) $

972− ns' \\ (map fst pvars ++ no_imp syn ++ ignore)

972+ ns' \\ (map fst pvars ++ no_imp syn ++ ignore)

973 nsOrder = filter (not . inUsing) ns ++ filter inUsing ns in

974− if null ns

974+ if null ns

975− then (tm, reverse declimps)

975+ then (tm, reverse declimps)

976 else implicitise syn ignore ist (pibind uvars nsOrder tm)

977 where

978 uvars = map ipair (filter uimplicit (using syn))

@@ -992,18 +992,18 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

992 = do (decls, ns) <- get

993 let isn = concatMap (namesIn uvars ist) (map getTm as)

994 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

995− imps top env (PPi (Imp l _ doc _) n ty sc)

995+ imps top env (PPi (Imp l _ doc _) n ty sc)

996 = do let isn = nub (namesIn uvars ist ty) `dropAll` [n]

997 (decls , ns) <- get

998− put (PImp (getPriority ist ty) True l n ty doc : decls,

998+ put (PImp (getPriority ist ty) True l n ty doc : decls,

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

1000 imps True (n:env) sc

1001− imps top env (PPi (Exp l _ doc _) n ty sc)

1001+ imps top env (PPi (Exp l _ doc _) n ty sc)

1002 = do let isn = nub (namesIn uvars ist ty ++ case sc of

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

1004 _ -> [])

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

1006− put (PExp (getPriority ist ty) l ty doc : decls,

1006+ put (PExp (getPriority ist ty) l ty doc : decls,

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

1008 imps True (n:env) sc

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

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

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

1012 _ -> [])

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

1014− put (PConstraint 10 l ty doc : decls,

1014+ put (PConstraint 10 l ty doc : decls,

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

1016 imps True (n:env) sc

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

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

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

1020 _ -> [])

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

1022− put (PTacImplicit 10 l n scr ty doc : decls,

1022+ put (PTacImplicit 10 l n scr ty doc : decls,

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

1024 imps True (n:env) sc

1025 imps top env (PEq _ l r)

@@ -1042,14 +1042,14 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1042 put (decls, nub (ns ++ (isn \\ (env ++ map fst (getImps decls)))))

1043 imps top env (PDPair _ l t r)

1044 = do (decls, ns) <- get

1045− let isn = namesIn uvars ist l ++ namesIn uvars ist t ++

1045+ let isn = namesIn uvars ist l ++ namesIn uvars ist t ++

1046 namesIn uvars ist r

1047 put (decls, nub (ns ++ (isn \\ (env ++ map fst (getImps decls)))))

1048 imps top env (PAlternative a as)

1049 = do (decls, ns) <- get

1050 let isn = concatMap (namesIn uvars ist) as

1051 put (decls, nub (ns ++ (isn `dropAll` (env ++ map fst (getImps decls)))))

1052− imps top env (PLam n ty sc)

1052+ imps top env (PLam n ty sc)

1053 = do imps False env ty

1054 imps False (n:env) sc

1055 imps top env (PHidden tm) = imps False env tm

@@ -1058,10 +1058,10 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

1058 imps top env _ = return ()

1059

1060 pibind using [] sc = sc

1061− pibind using (n:ns) sc

1061+ pibind using (n:ns) sc

1062 = case lookup n using of

1063 Just ty -> PPi (Imp False Dynamic "" False) n ty (pibind using ns sc)

1064− Nothing -> PPi (Imp False Dynamic "" False) n Placeholder

1064+ Nothing -> PPi (Imp False Dynamic "" False) n Placeholder

1065 (pibind using ns sc)

1066

1067-- Add implicit arguments in function calls

@@ -1083,7 +1083,7 @@ addImpl = addImpl' False [] []

1083addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm

1084addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

1085 where

1086− ai env (PRef fc f)

1086+ ai env (PRef fc f)

1087 | f `elem` infns = PInferRef fc f

1088 | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f []

1089 ai env (PHidden (PRef fc f))

@@ -1107,16 +1107,16 @@ addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

1107 PDPair fc l' t' r'

1108 ai env (PAlternative a as) = let as' = map (ai env) as in

1109 PAlternative a as'

1110− ai env (PApp fc (PInferRef _ f) as)

1110+ ai env (PApp fc (PInferRef _ f) as)

1111 = let as' = map (fmap (ai env)) as in

1112− PApp fc (PInferRef fc f) as'

1112+ PApp fc (PInferRef fc f) as'

1113− ai env (PApp fc ftm@(PRef _ f) as)

1113+ ai env (PApp fc ftm@(PRef _ f) as)

1114 | f `elem` infns = ai env (PApp fc (PInferRef fc f) as)

1115 | not (f `elem` map fst env)

1116 = let as' = map (fmap (ai env)) as in

1117 handleErr $ aiFn inpat False ist fc f as'

1118 | Just (Just ty) <- lookup f env

1119− = let as' = map (fmap (ai env)) as

1119+ = let as' = map (fmap (ai env)) as

1120 arity = getPArity ty in

1121 mkPApp fc arity ftm as'

1122 ai env (PApp fc f as) = let f' = ai env f

@@ -1158,8 +1158,8 @@ aiFn inpat True ist fc f []

1158 = case lookupDef f (tt_ctxt ist) of

1159 [] -> Right $ PPatvar fc f

1160 alts -> let ialts = lookupCtxtName f (idris_implicits ist) in

1161− -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

1161+ -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

1162− if (not (vname f) || tcname f

1162+ if (not (vname f) || tcname f

1163 || any (conCaf (tt_ctxt ist)) ialts)

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

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

@@ -1187,7 +1187,7 @@ aiFn inpat expat ist fc f as

1187 else Right $ mkPApp fc (length as) (PRef fc f) as

1188 alts -> Right $

1189 PAlternative True $

1190− map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f')

1190+ map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f')

1191 (insertImpl ns as)) alts

1192 where

1193 insertImpl :: [PArg] -> [PArg] -> [PArg]

@@ -1204,16 +1204,16 @@ aiFn inpat expat ist fc f as

1204 insertImpl (PTacImplicit p l n sc ty d : ps) given =

1205 case find n given [] of

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

1207− Nothing -> if inpat

1207+ Nothing -> if inpat

1208 then PTacImplicit p l n sc Placeholder "" : insertImpl ps given

1209 else PTacImplicit p l n sc sc "" : insertImpl ps given

1210 insertImpl expected [] = []

1211 insertImpl _ given = given

1212

1213 find n [] acc = Nothing

1214− find n (PImp _ _ _ n' t _ : gs) acc

1214+ find n (PImp _ _ _ n' t _ : gs) acc

1215 | n == n' = Just (t, reverse acc ++ gs)

1216− find n (PTacImplicit _ _ n' _ t _ : gs) acc

1216+ find n (PTacImplicit _ _ n' _ t _ : gs) acc

1217 | n == n' = Just (t, reverse acc ++ gs)

1218 find n (g : gs) acc = find n gs (g : acc)

1219

@@ -1222,9 +1222,9 @@ aiFn inpat expat ist fc f as

1222-- it is hard to get right!

1223

1224stripLinear :: IState -> PTerm -> PTerm

1225−stripLinear i tm = evalState (sl tm) [] where

1225+stripLinear i tm = evalState (sl tm) [] where

1226 sl :: PTerm -> State [Name] PTerm

1227− sl (PRef fc f)

1227+ sl (PRef fc f)

1228 | (_:_) <- lookupTy f (tt_ctxt i)

1229 = return $ PRef fc f

1230 | otherwise = do ns <- get

@@ -1232,7 +1232,7 @@ stripLinear i tm = evalState (sl tm) [] where

1232 then return Placeholder

1233 else do put (f : ns)

1234 return (PRef fc f)

1235− sl (PPatvar fc f)

1235+ sl (PPatvar fc f)

1236 = do ns <- get

1237 if (f `elem` ns)

1238 then return Placeholder

@@ -1245,10 +1245,10 @@ stripLinear i tm = evalState (sl tm) [] where

1245 return $ PImp p m l n t' d

1246 slA (PExp p l t d) = do t' <- sl t

1247 return $ PExp p l t' d

1248− slA (PConstraint p l t d)

1248+ slA (PConstraint p l t d)

1249 = do t' <- sl t

1250 return $ PConstraint p l t' d

1251− slA (PTacImplicit p l n sc t d)

1251+ slA (PTacImplicit p l n sc t d)

1252 = do t' <- sl t

1253 return $ PTacImplicit p l n sc t' d

1254 sl x = return x

@@ -1261,7 +1261,7 @@ mkPApp fc a f as = let rest = drop a as in

1261 appRest fc f (a : as) = appRest fc (PApp fc f [a]) as

1262

1263-- Find 'static' argument positions

1264−-- (the declared ones, plus any names in argument position in the declared

1264+-- (the declared ones, plus any names in argument position in the declared

1265-- statics)

1266-- FIXME: It's possible that this really has to happen after elaboration

1267

@@ -1279,7 +1279,7 @@ findStatics ist tm = trace (showImp Nothing True False tm) $

1279

1280 inOne n ns = length (filter id (map (elem n) ns)) == 1

1281

1282− pos ns ss (PPi p n t sc)

1282+ pos ns ss (PPi p n t sc)

1283 | elem n ss = do sc' <- pos ns ss sc

1284 spos <- get

1285 put (True : spos)

@@ -1296,16 +1296,16 @@ dumpDecls :: [PDecl] -> String

1296dumpDecls [] = ""

1297dumpDecls (d:ds) = dumpDecl d ++ "\n" ++ dumpDecls ds

1298

1299−dumpDecl (PFix _ f ops) = show f ++ " " ++ showSep ", " ops

1299+dumpDecl (PFix _ f ops) = show f ++ " " ++ showSep ", " ops

1300dumpDecl (PTy _ _ _ _ n t) = "tydecl " ++ show n ++ " : " ++ showImp Nothing True False t

1301dumpDecl (PClauses _ _ n cs) = "pat " ++ show n ++ "\t" ++ showSep "\n\t" (map (showCImp True) cs)

1302dumpDecl (PData _ _ _ _ d) = showDImp True d

1303dumpDecl (PParams _ ns ps) = "params {" ++ show ns ++ "\n" ++ dumpDecls ps ++ "}\n"

1304dumpDecl (PNamespace n ps) = "namespace {" ++ n ++ "\n" ++ dumpDecls ps ++ "}\n"

1305dumpDecl (PSyntax _ syn) = "syntax " ++ show syn

1306−dumpDecl (PClass _ _ _ cs n ps ds)

1306+dumpDecl (PClass _ _ _ cs n ps ds)

1307 = "class " ++ show cs ++ " " ++ show n ++ " " ++ show ps ++ "\n" ++ dumpDecls ds

1308−dumpDecl (PInstance _ _ cs n _ t _ ds)

1308+dumpDecl (PInstance _ _ cs n _ t _ ds)

1309 = "instance " ++ show cs ++ " " ++ show n ++ " " ++ show t ++ "\n" ++ dumpDecls ds

1310dumpDecl _ = "..."

1311-- dumpDecl (PImport i) = "import " ++ i

@@ -1322,7 +1322,7 @@ instance Monad (EitherErr a) where

1322toEither (LeftErr e) = Left e

1323toEither (RightOK ho) = Right ho

1324

1325−-- syntactic match of a against b, returning pair of variables in a

1325+-- syntactic match of a against b, returning pair of variables in a

1326-- and what they match. Returns the pair that failed if not a match.

1327

1328matchClause :: IState -> PTerm -> PTerm -> Either (PTerm, PTerm) [(Name, PTerm)]

@@ -1336,7 +1336,7 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

1336 fullApp x = x

1337

1338 match' x y = match (fullApp x) (fullApp y)

1339− match (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) x'

1339+ match (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x]) x'

1340 | PConstant (I _) <- getTm x = match (getTm x) x'

1341 match x' (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x])

1342 | PConstant (I _) <- getTm x = match (getTm x) x'

@@ -1354,17 +1354,17 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

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

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

1356 match (PRef _ n) tm@(PRef _ n')

1357− | n == n' && not names &&

1357+ | n == n' && not names &&

1358 (not (isConName n (tt_ctxt i)) || tm == Placeholder)

1359 = return [(n, tm)]

1360 | n == n' = return []

1361− match (PRef _ n) tm

1361+ match (PRef _ n) tm

1362 | not names && (not (isConName n (tt_ctxt i)) || tm == Placeholder)

1363 = return [(n, tm)]

1364 match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l'

1365 mr <- match' r r'

1366 return (ml ++ mr)

1367− match (PRewrite _ l r _) (PRewrite _ l' r' _)

1367+ match (PRewrite _ l r _) (PRewrite _ l' r' _)

1368 = do ml <- match' l l'

1369 mr <- match' r r'

1370 return (ml ++ mr)

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

1380 mt <- match' t t'

1381 mr <- match' r r'

1382 return (ml ++ mt ++ mr)

1383− match (PAlternative a as) (PAlternative a' as')

1383+ match (PAlternative a as) (PAlternative a' as')

1384− = do ms <- zipWithM match' as as'

1384+ = do ms <- zipWithM match' as as'

1385 return (concat ms)

1386 match a@(PAlternative _ as) b

1387 = do let ms = zipWith match' as (repeat b)

@@ -1421,9 +1421,9 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

1421 | otherwise = LeftErr (a, b)

1422

1423 checkRpts (RightOK ms) = check ms where

1424− check ((n,t):xs)

1424+ check ((n,t):xs)

1425 | Just t' <- lookup n xs = if t/=t' && t/=Placeholder && t'/=Placeholder

1426− then Left (t, t')

1426+ then Left (t, t')

1427 else check xs

1428 check (_:xs) = check xs

1429 check [] = Right ms

@@ -1434,7 +1434,7 @@ substMatches ms = substMatchesShadow ms []

1434

1435substMatchesShadow :: [(Name, PTerm)] -> [Name] -> PTerm -> PTerm

1436substMatchesShadow [] shs t = t

1437−substMatchesShadow ((n,tm):ns) shs t

1437+substMatchesShadow ((n,tm):ns) shs t

1438 = substMatchShadow n shs tm (substMatchesShadow ns shs t)

1439

1440substMatch :: Name -> PTerm -> PTerm -> PTerm

@@ -1444,10 +1444,10 @@ substMatchShadow :: Name -> [Name] -> PTerm -> PTerm -> PTerm

1444substMatchShadow n shs tm t = sm shs t where

1445 sm xs (PRef _ n') | n == n' = tm

1446 sm xs (PLam x t sc) = PLam x (sm xs t) (sm xs sc)

1447− sm xs (PPi p x t sc)

1447+ sm xs (PPi p x t sc)

1448− | x `elem` xs

1448+ | x `elem` xs

1449 = let x' = nextName x in

1450− PPi p x' (sm (x':xs) (substMatch x (PRef emptyFC x') t))

1450+ PPi p x' (sm (x':xs) (substMatch x (PRef emptyFC x') t))

1451 (sm (x':xs) (substMatch x (PRef emptyFC x') sc))

1452 | otherwise = PPi p x (sm xs t) (sm (x : xs) sc)

1453 sm xs (PApp f x as) = fullApp $ PApp f (sm xs x) (map (fmap (sm xs)) as)

src/Idris/AbsSyntaxTree.hs+89−89

@@ -88,7 +88,7 @@ data IState = IState {

88 idris_statics :: Ctxt [Bool],

89 idris_classes :: Ctxt ClassInfo,

90 idris_dsls :: Ctxt DSL,

91− idris_optimisation :: Ctxt OptInfo,

91+ idris_optimisation :: Ctxt OptInfo,

92 idris_datatypes :: Ctxt TypeInfo,

93 idris_patdefs :: Ctxt ([([Name], Term, Term)], [PTerm]), -- not exported

94 -- ^ list of lhs/rhs, and a list of missing clauses

@@ -100,8 +100,8 @@ data IState = IState {

100 idris_log :: String,

101 idris_options :: IOption,

102 idris_name :: Int,

103− idris_lineapps :: [((FilePath, Int), PTerm)],

103+ idris_lineapps :: [((FilePath, Int), PTerm)],

104− -- ^ Full application LHS on source line

104+ -- ^ Full application LHS on source line

105 idris_metavars :: [(Name, (Maybe Name, Int))], -- ^ The currently defined but not proven metavariables

106 idris_coercions :: [Name],

107 idris_transforms :: [(Term, Term)],

@@ -145,15 +145,15 @@ data CGInfo = CGInfo { argsdef :: [Name],

145 argsused :: [Name],

146 unusedpos :: [Int] }

147 deriving Show

148−{-!

148+{-!

149−deriving instance Binary CGInfo

149+deriving instance Binary CGInfo

150!-}

151

152−primDefs = [UN "unsafePerformPrimIO",

152+primDefs = [UN "unsafePerformPrimIO",

153− UN "mkLazyForeignPrim",

153+ UN "mkLazyForeignPrim",

154− UN "mkForeignPrim",

154+ UN "mkForeignPrim",

155 UN "FalseElim"]

156−

156+

157-- information that needs writing for the current module's .ibc file

158data IBCWrite = IBCFix FixDecl

159 | IBCImp Name

@@ -183,13 +183,13 @@ data IBCWrite = IBCFix FixDecl

183 deriving Show

184

185idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

186− emptyContext emptyContext emptyContext emptyContext

186+ emptyContext emptyContext emptyContext emptyContext

187 emptyContext emptyContext emptyContext emptyContext

188 [] "" defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] []

189 [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

190 True defaultTheme stdout

191

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

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

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

194--type Idris = WriterT [Either String (IO ())] (State IState a))

195type Idris = StateT IState (ErrorT Err IO)

@@ -212,9 +212,9 @@ data Command = Quit

212 | DocStr Name

213 | TotCheck Name

214 | Reload

215− | Load FilePath

215+ | Load FilePath

216 | ChangeDirectory FilePath

217− | ModImport String

217+ | ModImport String

218 | Edit

219 | Compile Codegen String

220 | Execute

@@ -240,11 +240,11 @@ data Command = Quit

240 | DebugInfo Name

241 | Search PTerm

242 | CaseSplit Name PTerm

243− | CaseSplitAt Bool Int Name

243+ | CaseSplitAt Bool Int Name

244− | AddClauseFrom Bool Int Name

244+ | AddClauseFrom Bool Int Name

245− | AddProofClauseFrom Bool Int Name

245+ | AddProofClauseFrom Bool Int Name

246− | AddMissing Bool Int Name

246+ | AddMissing Bool Int Name

247− | MakeWith Bool Int Name

247+ | MakeWith Bool Int Name

248 | DoProofSearch Bool Int Name [Name]

249 | SetOpt Opt

250 | UnsetOpt Opt

@@ -298,13 +298,13 @@ data Opt = Filename String

298

299-- Parsed declarations

300

301−data Fixity = Infixl { prec :: Int }

301+data Fixity = Infixl { prec :: Int }

302 | Infixr { prec :: Int }

303− | InfixN { prec :: Int }

303+ | InfixN { prec :: Int }

304 | PrefixN { prec :: Int }

305 deriving Eq

306−{-!

306+{-!

307−deriving instance Binary Fixity

307+deriving instance Binary Fixity

308!-}

309

310instance Show Fixity where

@@ -313,14 +313,14 @@ instance Show Fixity where

313 show (InfixN i) = "infix " ++ show i

314 show (PrefixN i) = "prefix " ++ show i

315

316−data FixDecl = Fix Fixity String

316+data FixDecl = Fix Fixity String

317 deriving Eq

318

319instance Show FixDecl where

320 show (Fix f s) = show f ++ " " ++ s

321

322−{-!

322+{-!

323−deriving instance Binary FixDecl

323+deriving instance Binary FixDecl

324!-}

325

326instance Ord FixDecl where

@@ -329,8 +329,8 @@ instance Ord FixDecl where

329

330data Static = Static | Dynamic

331 deriving (Show, Eq)

332−{-!

332+{-!

333−deriving instance Binary Static

333+deriving instance Binary Static

334!-}

335

336-- Mark bindings with their explicitness, and laziness

@@ -352,7 +352,7 @@ data Plicity = Imp { plazy :: Bool,

352 deriving (Show, Eq)

353

354{-!

355−deriving instance Binary Plicity

355+deriving instance Binary Plicity

356!-}

357

358impl = Imp False Dynamic "" False

@@ -363,8 +363,8 @@ tacimpl t = TacImp False Dynamic t ""

363

364data FnOpt = Inlinable -- always evaluate when simplifying

365 | TotalFn | PartialFn

366− | Coinductive | AssertTotal

366+ | Coinductive | AssertTotal

367− | Dictionary -- type class dictionary, eval only when

367+ | Dictionary -- type class dictionary, eval only when

368 -- a function argument, and further evaluation resutls

369 | Implicit -- implicit coercion

370 | CExport String -- export, with a C name

@@ -395,7 +395,7 @@ data PDecl' t

395 | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block

396 | PNamespace String [PDecl' t] -- ^ New namespace

397 | PRecord String SyntaxInfo FC Name t String Name t -- ^ Record declaration

398− | PClass String SyntaxInfo FC

398+ | PClass String SyntaxInfo FC

399 [t] -- constraints

400 Name

401 [(Name, t)] -- parameters

@@ -436,7 +436,7 @@ type ElabD a = Elab' [PDecl] a

436-- 4. The where block (PDecl' t)

437

438data PClause' t = PClause FC Name t [t] t [PDecl' t] -- ^ A normal top-level definition.

439− | PWith FC Name t [t] t [PDecl' t]

439+ | PWith FC Name t [t] t [PDecl' t]

440 | PClauseR FC [t] t [PDecl' t]

441 | PWithR FC [t] t [PDecl' t]

442 deriving Functor

@@ -462,7 +462,7 @@ deriving instance Binary PData'

462

463type PDecl = PDecl' PTerm

464type PData = PData' PTerm

465−type PClause = PClause' PTerm

465+type PClause = PClause' PTerm

466

467-- get all the names declared in a decl

468

@@ -494,7 +494,7 @@ tldeclared (PClauses _ _ n _) = [] -- not a declaration

494tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]

495tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

496 where fstt (_, a, _, _) = a

497−tldeclared (PParams _ _ ds) = []

497+tldeclared (PParams _ _ ds) = []

498tldeclared (PMutual _ ds) = concatMap tldeclared ds

499tldeclared (PNamespace _ ds) = concatMap tldeclared ds

500tldeclared (PClass _ _ _ _ n _ ms) = concatMap tldeclared ms

@@ -528,14 +528,14 @@ updateN _ n = n

528updateNs :: [(Name, Name)] -> PTerm -> PTerm

529updateNs [] t = t

530updateNs ns t = mapPT updateRef t

531− where updateRef (PRef fc f) = PRef fc (updateN ns f)

531+ where updateRef (PRef fc f) = PRef fc (updateN ns f)

532 updateRef t = t

533

534-- updateDNs :: [(Name, Name)] -> PDecl -> PDecl

535-- updateDNs [] t = t

536-- updateDNs ns (PTy s f n t) | Just n' <- lookup n ns = PTy s f n' t

537-- updateDNs ns (PClauses f n c) | Just n' <- lookup n ns = PClauses f n' (map updateCNs c)

538−-- where updateCNs ns (PClause n l ts r ds)

538+-- where updateCNs ns (PClause n l ts r ds)

539-- = PClause (updateN ns n) (fmap (updateNs ns) l)

540-- (map (fmap (updateNs ns)) ts)

541-- (fmap (updateNs ns) r)

@@ -579,12 +579,12 @@ data PTerm = PQuote Raw

579 | PImpossible -- ^ Special case for declaring when an LHS can't typecheck

580 | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice

581 | PUnifyLog PTerm -- ^ dump a trace of unifications when building term

582− | PNoImplicits PTerm -- ^ never run implicit converions on the term

582+ | PNoImplicits PTerm -- ^ never run implicit converions on the term

583 deriving Eq

584

585

586−{-!

586+{-!

587−deriving instance Binary PTerm

587+deriving instance Binary PTerm

588!-}

589

590mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

@@ -592,7 +592,7 @@ mapPT f t = f (mpt t) where

592 mpt (PLam n t s) = PLam n (mapPT f t) (mapPT f s)

593 mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s)

594 mpt (PLet n ty v s) = PLet n (mapPT f ty) (mapPT f v) (mapPT f s)

595− mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s)

595+ mpt (PRewrite fc t s g) = PRewrite fc (mapPT f t) (mapPT f s)

596 (fmap (mapPT f) g)

597 mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)

598 mpt (PAppBind fc t as) = PAppBind fc (mapPT f t) (map (fmap (mapPT f)) as)

@@ -613,11 +613,11 @@ mapPT f t = f (mpt t) where

613

614

615data PTactic' t = Intro [Name] | Intros | Focus Name

616− | Refine Name [Bool] | Rewrite t

616+ | Refine Name [Bool] | Rewrite t

617 | Equiv t

618− | MatchRefine Name

618+ | MatchRefine Name

619 | LetTac Name t | LetTacTy Name t t

620− | Exact t | Compute | Trivial

620+ | Exact t | Compute | Trivial

621 | ProofSearch (Maybe Name) Name [Name]

622 | Solve

623 | Attack

@@ -630,8 +630,8 @@ data PTactic' t = Intro [Name] | Intros | Focus Name

630 | GoalType String (PTactic' t)

631 | Qed | Abandon

632 deriving (Show, Eq, Functor)

633−{-!

633+{-!

634−deriving instance Binary PTactic'

634+deriving instance Binary PTactic'

635!-}

636

637instance Sized a => Sized (PTactic' a) where

@@ -665,8 +665,8 @@ data PDo' t = DoExp FC t

665 | DoLet FC Name t t

666 | DoLetP FC t t

667 deriving (Eq, Functor)

668−{-!

668+{-!

669−deriving instance Binary PDo'

669+deriving instance Binary PDo'

670!-}

671

672instance Sized a => Sized (PDo' a) where

@@ -682,7 +682,7 @@ type PDo = PDo' PTerm

682-- things early which will help give a more concrete type to other

683-- variables, e.g. a before (interpTy a).

684

685−data PArg' t = PImp { priority :: Int,

685+data PArg' t = PImp { priority :: Int,

686 machine_inf :: Bool, -- true if the machine inferred it

687 lazyarg :: Bool, pname :: Name, getTm :: t,

688 pargdoc :: String }

@@ -693,9 +693,9 @@ data PArg' t = PImp { priority :: Int,

693 lazyarg :: Bool, getTm :: t,

694 pargdoc :: String }

695 | PTacImplicit { priority :: Int,

696− lazyarg :: Bool, pname :: Name,

696+ lazyarg :: Bool, pname :: Name,

697 getScript :: t,

698− getTm :: t,

698+ getTm :: t,

699 pargdoc :: String }

700 deriving (Show, Eq, Functor)

701

@@ -705,8 +705,8 @@ instance Sized a => Sized (PArg' a) where

705 size (PConstraint p l trm _) = 1 + size trm

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

707

708−{-!

708+{-!

709−deriving instance Binary PArg'

709+deriving instance Binary PArg'

710!-}

711

712pimp n t mach = PImp 1 mach True n t ""

@@ -724,8 +724,8 @@ data ClassInfo = CI { instanceName :: Name,

724 class_params :: [Name],

725 class_instances :: [Name] }

726 deriving Show

727−{-!

727+{-!

728−deriving instance Binary ClassInfo

728+deriving instance Binary ClassInfo

729!-}

730

731data OptInfo = Optimise { collapsible :: Bool,

@@ -733,12 +733,12 @@ data OptInfo = Optimise { collapsible :: Bool,

733 forceable :: [Int], -- argument positions

734 recursive :: [Int] }

735 deriving Show

736−{-!

736+{-!

737−deriving instance Binary OptInfo

737+deriving instance Binary OptInfo

738!-}

739

740

741−data TypeInfo = TI { con_names :: [Name],

741+data TypeInfo = TI { con_names :: [Name],

742 codata :: Bool,

743 param_pos :: [Int] }

744 deriving Show

@@ -746,7 +746,7 @@ data TypeInfo = TI { con_names :: [Name],

746deriving instance Binary TypeInfo

747!-}

748

749−-- Syntactic sugar info

749+-- Syntactic sugar info

750

751data DSL' t = DSL { dsl_bind :: t,

752 dsl_return :: t,

@@ -767,14 +767,14 @@ type DSL = DSL' PTerm

767

768data SynContext = PatternSyntax | TermSyntax | AnySyntax

769 deriving Show

770−{-!

770+{-!

771−deriving instance Binary SynContext

771+deriving instance Binary SynContext

772!-}

773

774data Syntax = Rule [SSymbol] PTerm SynContext

775 deriving Show

776−{-!

776+{-!

777−deriving instance Binary Syntax

777+deriving instance Binary Syntax

778!-}

779

780data SSymbol = Keyword Name

@@ -783,11 +783,11 @@ data SSymbol = Keyword Name

783 | Expr Name

784 | SimpleExpr Name

785 deriving Show

786−{-!

786+{-!

787−deriving instance Binary SSymbol

787+deriving instance Binary SSymbol

788!-}

789

790−initDSL = DSL (PRef f (UN ">>="))

790+initDSL = DSL (PRef f (UN ">>="))

791 (PRef f (UN "return"))

792 (PRef f (UN "<$>"))

793 (PRef f (UN "pure"))

@@ -849,29 +849,29 @@ showDeclImp t (PTy _ _ _ _ n ty) = show n ++ " : " ++ showImp Nothing t False ty

849showDeclImp t (PPostulate _ _ _ _ n ty) = show n ++ " : " ++ showImp Nothing t False ty

850showDeclImp _ (PClauses _ _ n c) = showSep "\n" (map show c)

851showDeclImp _ (PData _ _ _ _ d) = show d

852−showDeclImp _ (PParams f ns ps) = "parameters " ++ show ns ++ "\n" ++

852+showDeclImp _ (PParams f ns ps) = "parameters " ++ show ns ++ "\n" ++

853 showSep "\n" (map show ps)

854

855

856showCImp :: Bool -> PClause -> String

857−showCImp impl (PClause _ n l ws r w)

857+showCImp impl (PClause _ n l ws r w)

858 = showImp Nothing impl False l ++ showWs ws ++ " = " ++ showImp Nothing impl False r

859− ++ " where " ++ show w

859+ ++ " where " ++ show w

860 where

861 showWs [] = ""

862 showWs (x : xs) = " | " ++ showImp Nothing impl False x ++ showWs xs

863−showCImp impl (PWith _ n l ws r w)

863+showCImp impl (PWith _ n l ws r w)

864 = showImp Nothing impl False l ++ showWs ws ++ " with " ++ showImp Nothing impl False r

865− ++ " { " ++ show w ++ " } "

865+ ++ " { " ++ show w ++ " } "

866 where

867 showWs [] = ""

868 showWs (x : xs) = " | " ++ showImp Nothing impl False x ++ showWs xs

869

870

871showDImp :: Bool -> PData -> String

872−showDImp impl (PDatadecl n ty cons)

872+showDImp impl (PDatadecl n ty cons)

873 = "data " ++ show n ++ " : " ++ showImp Nothing impl False ty ++ " where\n\t"

874− ++ showSep "\n\t| "

874+ ++ showSep "\n\t| "

875 (map (\ (_, n, t, _) -> show n ++ " : " ++ showImp Nothing impl False t) cons)

876

877getImps :: [PArg] -> [(Name, PTerm)]

@@ -890,7 +890,7 @@ getConsts (PConstraint _ _ tm _ : xs) = tm : getConsts xs

890getConsts (_ : xs) = getConsts xs

891

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

893−getAll = map getTm

893+getAll = map getTm

894

895-- | Pretty-print a high-level Idris term

896prettyImp :: Bool -- ^^ whether to show implicits

@@ -1135,7 +1135,7 @@ showImp ist impl colour tm = se 10 [] tm where

1135 | Just num <- snat p e = perhapsColourise colouriseData (show num)

1136 se p bnd (PRef fc n) = showName ist bnd impl colour n

1137 se p bnd (PLam n ty sc) = bracket p 2 $ "\\ " ++ perhapsColourise colouriseBound (show n) ++

1138− (if impl then " : " ++ se 10 bnd ty else "") ++ " => "

1138+ (if impl then " : " ++ se 10 bnd ty else "") ++ " => "

1139 ++ se 10 ((n, False):bnd) sc

1140 se p bnd (PLet n ty v sc) = bracket p 2 $ "let " ++ perhapsColourise colouriseBound (show n) ++

1141 " = " ++ se 10 bnd v ++

@@ -1145,7 +1145,7 @@ showImp ist impl colour tm = se 10 [] tm where

1145 = bracket p 2 $

1146 (if l then "|(" else "(") ++

1147 perhapsColourise colouriseBound (show n) ++ " : " ++ se 10 bnd ty ++

1148− ") " ++

1148+ ") " ++

1149 (if (impl && param) then "P" else "") ++

1150 st ++

1151 "-> " ++ se 10 ((n, False):bnd) sc

@@ -1155,7 +1155,7 @@ showImp ist impl colour tm = se 10 [] tm where

1155 _ -> ""

1156 se p bnd (PPi (Imp l s _ _) n ty sc)

1157 | impl = bracket p 2 $ (if l then "|{" else "{") ++

1158− perhapsColourise colouriseBound (show n) ++ " : " ++ se 10 bnd ty ++

1158+ perhapsColourise colouriseBound (show n) ++ " : " ++ se 10 bnd ty ++

1159 "} " ++ st ++ "-> " ++ se 10 ((n, True):bnd) sc

1160 | otherwise = se 10 ((n, True):bnd) sc

1161 where st = case s of

@@ -1173,12 +1173,12 @@ showImp ist impl colour tm = se 10 [] tm where

1173 se p bnd (PAppBind _ hd@(PRef _ f) [])

1174 | not impl = "!" ++ se p bnd hd

1175 se p bnd (PApp _ op@(PRef _ (UN (f:_))) args)

1176− | length (getExps args) == 2 && not impl && not (isAlpha f)

1176+ | length (getExps args) == 2 && not impl && not (isAlpha f)

1177 = let [l, r] = getExps args in

1178 bracket p 1 $ se 1 bnd l ++ " " ++ se p bnd op ++ " " ++ se 0 bnd r

1179 se p bnd (PApp _ f as)

1180 = -- let args = getExps as in

1181− bracket p 1 $ se 1 bnd f ++

1181+ bracket p 1 $ se 1 bnd f ++

1182 if impl then concatMap (sArg bnd) as

1183 else concatMap (suiArg impl bnd) as

1184 se p bnd (PAppBind _ f as)

@@ -1257,16 +1257,16 @@ showImp ist impl colour tm = se 10 [] tm where

1257 sArg bnd (PTacImplicit _ _ n _ tm _) = stiArg bnd (n, tm)

1258

1259 -- show argument, implicits given by the user also shown

1260− suiArg impl bnd (PImp _ mi _ n tm _)

1260+ suiArg impl bnd (PImp _ mi _ n tm _)

1261 | impl || not mi = siArg bnd (n, tm)

1262 suiArg impl bnd (PExp _ _ tm _) = seArg bnd tm

1263 suiArg impl bnd _ = ""

1264

1265 seArg bnd arg = " " ++ se 0 bnd arg

1266− siArg bnd (n, val) =

1266+ siArg bnd (n, val) =

1267 let n' = show n

1268 val' = se 10 bnd val in

1269− if (n' == val')

1269+ if (n' == val')

1270 then " {" ++ n' ++ "}"

1271 else " {" ++ n' ++ " = " ++ val' ++ "}"

1272 scArg bnd val = " {{" ++ se 10 bnd val ++ "}}"

@@ -1316,9 +1316,9 @@ getPArity _ = 0

1316-- Return all names, free or globally bound, in the given term.

1317

1318allNamesIn :: PTerm -> [Name]

1319−allNamesIn tm = nub $ ni [] tm

1319+allNamesIn tm = nub $ ni [] tm

1320 where

1321− ni env (PRef _ n)

1321+ ni env (PRef _ n)

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

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

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

@@ -1340,10 +1340,10 @@ allNamesIn tm = nub $ ni [] tm

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

1341

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

1343−namesIn uvars ist tm = nub $ ni [] tm

1343+namesIn uvars ist tm = nub $ ni [] tm

1344 where

1345− ni env (PRef _ n)

1345+ ni env (PRef _ n)

1346− | not (n `elem` env)

1346+ | not (n `elem` env)

1347 = case lookupTy n (tt_ctxt ist) of

1348 [] -> [n]

1349 _ -> if n `elem` (map fst uvars) then [n] else []

@@ -1367,10 +1367,10 @@ namesIn uvars ist tm = nub $ ni [] tm

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

1368

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

1370−usedNamesIn vars ist tm = nub $ ni [] tm

1370+usedNamesIn vars ist tm = nub $ ni [] tm

1371 where

1372− ni env (PRef _ n)

1372+ ni env (PRef _ n)

1373− | n `elem` vars && not (n `elem` env)

1373+ | n `elem` vars && not (n `elem` env)

1374 = case lookupTy n (tt_ctxt ist) of

1375 [] -> [n]

1376 _ -> []

src/Idris/CaseSplit.hs+2−2

@@ -276,10 +276,10 @@ getProofClause :: Int -> -- ^ Line type is declared on

276 Name -> -- ^ Function name

277 FilePath -> -- ^ Source file name

278 Idris String

279−getProofClause l fn fp

279+getProofClause l fn fp

280 = do ty <- getInternalApp fp l

281 return (mkApp ty ++ " = ?" ++ show fn ++ "_rhs")

282− where mkApp (PPi _ _ _ sc) = mkApp sc

282+ where mkApp (PPi _ _ _ sc) = mkApp sc

283 mkApp rt = "(" ++ show rt ++ ") <== " ++ show fn

284

285-- Purely syntactic - turn a pattern match clause into a with and a new

src/Idris/Chaser.hs+9−9

@@ -51,7 +51,7 @@ getModuleFiles ts = nub $ execState (modList ts) [] where

51

52 ibc (IBC _ _) = True

53 ibc _ = False

54−

54+

55 chkReload False p = p

56 chkReload True (IBC fn src) = chkReload True src

57 chkReload True p = p

@@ -74,19 +74,19 @@ buildTree built fp = idrisCatch (btree [] fp)

74 (\e -> do now <- runIO $ getCurrentTime

75 return [MTree (IDR fp) True now []])

76 where

77− btree done f =

77+ btree done f =

78 do i <- getIState

79 let file = takeWhile (/= ' ') f

80 iLOG $ "CHASING " ++ show file

81 ibcsd <- valIBCSubDir i

82− ids <- allImportDirs

82+ ids <- allImportDirs

83 fp <- runIO $ findImport ids ibcsd file

84 mt <- runIO $ getIModTime fp

85− if (file `elem` built)

85+ if (file `elem` built)

86 then return [MTree fp False mt []]

87− else if file `elem` done

87+ else if file `elem` done

88 then return []

89− else mkChildren fp

89+ else mkChildren fp

90

91 where mkChildren (LIDR fn) = do ms <- children True fn (f:done)

92 mt <- runIO $ getModificationTime fn

@@ -94,7 +94,7 @@ buildTree built fp = idrisCatch (btree [] fp)

94 mkChildren (IDR fn) = do ms <- children False fn (f:done)

95 mt <- runIO $ getModificationTime fn

96 return [MTree (IDR fn) True mt ms]

97− mkChildren (IBC fn src)

97+ mkChildren (IBC fn src)

98 = do srcexist <- runIO $ doesFileExist (getSrcFile src)

99 ms <- if srcexist then

100 do [MTree _ _ _ ms'] <- mkChildren src

@@ -119,7 +119,7 @@ buildTree built fp = idrisCatch (btree [] fp)

119 if exist then do

120 ibct <- runIO $ getModificationTime ibc

121 srct <- runIO $ getModificationTime src

122− return (srct > ibct)

122+ return (srct > ibct)

123 else return False

124

125 children :: Bool -> FilePath -> [FilePath] -> Idris [ModuleTree]

@@ -129,7 +129,7 @@ buildTree built fp = idrisCatch (btree [] fp)

129 file_in <- runIO $ readFile f

130 file <- if lit then tclift $ unlit f file_in else return file_in

131 (_, modules, _) <- parseImports f file

132− ms <- mapM (btree done) modules

132+ ms <- mapM (btree done) modules

133 return (concat ms)

134 else return []) -- IBC with no source available

135 (\c -> return []) -- error, can't chase modules here

src/Idris/Coverage.hs+90−90

@@ -31,7 +31,7 @@ mkPatTm t = do i <- getIState

31 return $ mkApp t' args'

32 toTT _ = do v <- get

33 put (v + 1)

34− return (P Bound (MN v "imp") Erased)

34+ return (P Bound (MN v "imp") Erased)

35

36-- Given a list of LHSs, generate a extra clauses which cover the remaining

37-- cases. The ones which haven't been provided are marked 'absurd' so that the

@@ -49,7 +49,7 @@ genClauses fc n xs given

49 logLvl 5 $ "COVERAGE of " ++ show n

50 logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

51 logLvl 10 $ show argss ++ "\n" ++ show all_args

52− logLvl 10 $ "Original: \n" ++

52+ logLvl 10 $ "Original: \n" ++

53 showSep "\n" (map (\t -> showImp Nothing True False (delab' i t True)) xs)

54 -- add an infinite supply of explicit arguments to update the possible

55 -- cases for (the return type may be variadic, or function type, sp

@@ -61,13 +61,13 @@ genClauses fc n xs given

61 let tryclauses = mkClauses parg all_args

62 logLvl 2 $ show (length tryclauses) ++ " initially to check"

63 logLvl 5 $ showSep "\n" (map (showImp Nothing True False) tryclauses)

64− let new = filter (noMatch i) (nub tryclauses)

64+ let new = filter (noMatch i) (nub tryclauses)

65 logLvl 1 $ show (length new) ++ " clauses to check for impossibility"

66 logLvl 5 $ "New clauses: \n" ++ showSep "\n" (map (showImp Nothing True False) new)

67−-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)

67+-- ++ " from:\n" ++ showSep "\n" (map (showImp True) tryclauses)

68 return new

69-- return (map (\t -> PClause n t [] PImpossible []) new)

70− where getLHS i term

70+ where getLHS i term

71 | (f, args) <- unApply term = map (\t -> delab' i t True) args

72 | otherwise = []

73

@@ -76,7 +76,7 @@ genClauses fc n xs given

76

77 noMatch i tm = all (\x -> case matchClause i (delab' i x True) tm of

78 Right _ -> False

79− Left miss -> True) xs

79+ Left miss -> True) xs

80

81

82 mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]

@@ -102,7 +102,7 @@ fnub' acc [] = acc

102-- quick check for constructor equality

103quickEq :: PTerm -> PTerm -> Bool

104quickEq (PRef _ n) (PRef _ n') = n == n'

105−quickEq (PApp _ t as) (PApp _ t' as')

105+quickEq (PApp _ t as) (PApp _ t' as')

106 | length as == length as'

107 = quickEq t t' && and (zipWith quickEq (map getTm as) (map getTm as'))

108quickEq Placeholder Placeholder = True

@@ -112,15 +112,15 @@ qelem x [] = False

112qelem x (y : ys) | x `quickEq` y = True

113 | otherwise = qelem x ys

114

115−-- FIXME: Just look for which one is the deepest, then generate all

115+-- FIXME: Just look for which one is the deepest, then generate all

116-- possibilities up to that depth.

117

118genAll :: IState -> [PTerm] -> [PTerm]

119−genAll i args

119+genAll i args

120 = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of

121 [] -> [Placeholder]

122 xs -> inventConsts xs

123− where

123+ where

124 -- if they're constants, invent a new one to make sure that

125 -- constants which are not explicitly handled are covered

126 inventConsts cs@(PConstant c : _) = map PConstant (ic' (mapMaybe getConst cs))

@@ -128,21 +128,21 @@ genAll i args

128 getConst _ = Nothing

129 inventConsts xs = xs

130

131− -- try constants until they're not in the list.

131+ -- try constants until they're not in the list.

132− -- FIXME: It is, of course, possible that someone has enumerated all

132+ -- FIXME: It is, of course, possible that someone has enumerated all

133− -- the constants and matched on them (maybe in generated code) and this

133+ -- the constants and matched on them (maybe in generated code) and this

134− -- will be really slow. This is sufficiently unlikely that we won't

134+ -- will be really slow. This is sufficiently unlikely that we won't

135− -- worry for now...

135+ -- worry for now...

136

137− ic' xs@(I _ : _) = firstMissing xs (lotsOfNums I)

137+ ic' xs@(I _ : _) = firstMissing xs (lotsOfNums I)

138 ic' xs@(BI _ : _) = firstMissing xs (lotsOfNums BI)

139− ic' xs@(Fl _ : _) = firstMissing xs (lotsOfNums Fl)

139+ ic' xs@(Fl _ : _) = firstMissing xs (lotsOfNums Fl)

140− ic' xs@(B8 _ : _) = firstMissing xs (lotsOfNums B8)

140+ ic' xs@(B8 _ : _) = firstMissing xs (lotsOfNums B8)

141− ic' xs@(B16 _ : _) = firstMissing xs (lotsOfNums B16)

141+ ic' xs@(B16 _ : _) = firstMissing xs (lotsOfNums B16)

142− ic' xs@(B32 _ : _) = firstMissing xs (lotsOfNums B32)

142+ ic' xs@(B32 _ : _) = firstMissing xs (lotsOfNums B32)

143− ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64)

143+ ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64)

144 ic' xs@(Ch _ : _) = firstMissing xs lotsOfChars

145− ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings

145+ ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings

146 -- TODO: Bit vectors

147 -- The rest are types with only one case

148 ic' xs = xs

@@ -166,16 +166,16 @@ genAll i args

166 otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o

167 otherPats o@(PPair fc l r)

168 = ops fc pairCon

169− ([pimp (UN "A") Placeholder True,

169+ ([pimp (UN "A") Placeholder True,

170 pimp (UN "B") Placeholder True] ++

171 [pexp l, pexp r]) o

172− otherPats o@(PDPair fc t _ v)

172+ otherPats o@(PDPair fc t _ v)

173− = ops fc (UN "Ex_intro")

173+ = ops fc (UN "Ex_intro")

174− ([pimp (UN "a") Placeholder True,

174+ ([pimp (UN "a") Placeholder True,

175 pimp (UN "P") Placeholder True] ++

176 [pexp t,pexp v]) o

177 otherPats o@(PConstant c) = return o

178− otherPats arg = return Placeholder

178+ otherPats arg = return Placeholder

179

180 ops fc n xs o

181 | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i)

@@ -202,7 +202,7 @@ genAll i args

202 [o] -> forceable o

203 _ -> []

204

205− dropForce force (x : xs) i | i `elem` force

205+ dropForce force (x : xs) i | i `elem` force

206 = upd Placeholder x : dropForce force xs (i + 1)

207 dropForce force (x : xs) i = x : dropForce force xs (i + 1)

208 dropForce _ [] _ = []

@@ -216,7 +216,7 @@ genAll i args

216

217 mkPat fc x = case lookupCtxt x (idris_implicits i) of

218 (pargs : _)

219− -> PApp fc (PRef fc x) (map (upd Placeholder) pargs)

219+ -> PApp fc (PRef fc x) (map (upd Placeholder) pargs)

220 _ -> error "Can't happen - genAll"

221

222upd p' p = p { getTm = p' }

@@ -225,7 +225,7 @@ upd p' p = p { getTm = p' }

225-- and update the context accordingly

226

227checkPositive :: Name -> (Name, Type) -> Idris ()

228−checkPositive n (cn, ty)

228+checkPositive n (cn, ty)

229 = do let p = cp ty

230 i <- getIState

231 let tot = if p then Total (args ty) else Partial NotPositive

@@ -245,20 +245,20 @@ checkPositive n (cn, ty)

245 posArg t = True

246

247calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality

248−calcProd i fc topn pats

248+calcProd i fc topn pats

249 = cp topn pats []

250 where

251− -- every application of n must be in an argument of a coinductive

251+ -- every application of n must be in an argument of a coinductive

252 -- constructor, in every function reachable from here in the

253 -- call graph.

254 cp n pats done = do patsprod <- mapM (prodRec n done) pats

255− if (and patsprod)

255+ if (and patsprod)

256 then return Productive

257 else return (Partial NotProductive)

258

259 prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

260 prodRec n done _ | n `elem` done = return True

261− prodRec n done (_, _, tm) = prod n done False tm

261+ prodRec n done (_, _, tm) = prod n done False tm

262

263 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

264 prod n done ok ap@(App _ _)

@@ -269,26 +269,26 @@ calcProd i fc topn pats

269 let [ty] = lookupTy f ctxt -- must exist!

270 let co = cotype nt f ty in

271 if (not recOK) then return False else

272− if f == topn

272+ if f == topn

273 then do argsprod <- mapM (prod n done co) args

274 return (and (ok : argsprod) )

275 else do argsprod <- mapM (prod n done co) args

276 return (and argsprod)

277− prod n done ok (App f a) = liftM2 (&&) (prod n done False f)

277+ prod n done ok (App f a) = liftM2 (&&) (prod n done False f)

278 (prod n done False a)

279− prod n done ok (Bind _ (Let t v) sc)

279+ prod n done ok (Bind _ (Let t v) sc)

280 = liftM2 (&&) (prod n done False v) (prod n done False v)

281 prod n done ok (Bind _ b sc) = prod n done ok sc

282− prod n done ok t = return True

282+ prod n done ok t = return True

283−

283+

284 checkProdRec :: [Name] -> Name -> Idris Bool

285− checkProdRec done f

285+ checkProdRec done f

286 = case lookupCtxt f (idris_patdefs i) of

287 [(def, _)] -> do ok <- mapM (prodRec f done) def

288 return (and ok)

289 _ -> return True -- defined elsewhere, can't call topn

290

291− cotype (DCon _ _) n ty

291+ cotype (DCon _ _) n ty

292 | (P _ t _, _) <- unApply (getRetTy ty)

293 = case lookupCtxt t (idris_datatypes i) of

294 [TI _ True _] -> True

@@ -297,26 +297,26 @@ calcProd i fc topn pats

297

298calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]

299 -> Idris Totality

300−calcTotality path fc n pats

300+calcTotality path fc n pats

301 = do i <- getIState

302 let opts = case lookupCtxt n (idris_flags i) of

303 [fs] -> fs

304 _ -> []

305 case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of

306 (failure : _) -> return failure

307− _ -> if (Coinductive `elem` opts)

307+ _ -> if (Coinductive `elem` opts)

308 then calcProd i fc n pats

309 else checkSizeChange n

310 where

311− checkLHS i (P _ fn _)

311+ checkLHS i (P _ fn _)

312 = case lookupTotal fn (tt_ctxt i) of

313− [Partial _] -> return (Partial (Other [fn]))

313+ [Partial _] -> return (Partial (Other [fn]))

314 _ -> Nothing

315 checkLHS i (App f a) = mplus (checkLHS i f) (checkLHS i a)

316 checkLHS _ _ = Nothing

317

318checkTotality :: [Name] -> FC -> Name -> Idris Totality

319−checkTotality path fc n

319+checkTotality path fc n

320 | n `elem` path = return (Partial (Mutual (n : path)))

321 | otherwise = do

322 t <- getTotality n

@@ -326,10 +326,10 @@ checkTotality path fc n

326 let opts = case lookupCtxt n (idris_flags i) of

327 [fs] -> fs

328 _ -> []

329− t' <- case t of

329+ t' <- case t of

330− Unchecked ->

330+ Unchecked ->

331 case lookupDef n ctxt of

332− [CaseOp _ _ _ pats _] ->

332+ [CaseOp _ _ _ pats _] ->

333 do t' <- if AssertTotal `elem` opts

334 then return $ Total []

335 else calcTotality path fc n pats

@@ -338,10 +338,10 @@ checkTotality path fc n

338 -- if it's not total, it can't reduce, to keep

339 -- typechecking decidable

340 case t' of

341− p@(Partial _) ->

341+ p@(Partial _) ->

342− do setAccessibility n Frozen

342+ do setAccessibility n Frozen

343 addIBC (IBCAccess n Frozen)

344− logLvl 5 $ "HIDDEN: "

344+ logLvl 5 $ "HIDDEN: "

345 ++ show n ++ show p

346 _ -> return ()

347 return t'

@@ -353,7 +353,7 @@ checkTotality path fc n

353 e -> do w <- cmdOptType WarnPartial

354 if TotalFn `elem` opts

355 then totalityError t'

356− else do when (w && not (PartialFn `elem` opts)) $

356+ else do when (w && not (PartialFn `elem` opts)) $

357 warnPartial n t'

358 return t'

359 where

@@ -363,14 +363,14 @@ checkTotality path fc n

363 = do i <- getIState

364 case lookupDef n (tt_ctxt i) of

365 [x] -> do

366− iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t

366+ iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t

367-- ++ "\n" ++ show x

368-- let cg = lookupCtxtName Nothing n (idris_callgraph i)

369-- iputStrLn (show cg)

370

371

372checkDeclTotality :: (FC, Name) -> Idris Totality

373−checkDeclTotality (fc, n)

373+checkDeclTotality (fc, n)

374 = do logLvl 2 $ "Checking " ++ show n ++ " for totality"

375-- buildSCG (fc, n)

376-- logLvl 2 $ "Built SCG"

@@ -383,7 +383,7 @@ checkDeclTotality (fc, n)

383

384-- where g is a function called

385-- a1 ... an are the arguments of f in positions 1..n of g

386−-- sizechange1 ... sizechange2 is how their size has changed wrt the input

386+-- sizechange1 ... sizechange2 is how their size has changed wrt the input

387-- to f

388-- Nothing, if the argument is unrelated to the input

389

@@ -392,9 +392,9 @@ buildSCG (_, n) = do

392 ist <- getIState

393 case lookupCtxt n (idris_callgraph ist) of

394 [cg] -> case lookupDef n (tt_ctxt ist) of

395− [CaseOp _ _ pats _ cd] ->

395+ [CaseOp _ _ pats _ cd] ->

396 let (args, sc) = cases_totcheck cd in

397− do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n"

397+ do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n"

398 ++ show pats ++ "\n" ++ show sc

399 let newscg = buildSCG' ist (rights pats) args

400 logLvl 5 $ show newscg

@@ -411,15 +411,15 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

411 | (P _ (UN "lazy") _, [_, arg]) <- unApply ap

412 = findCalls arg pvs pargs

413 | (P _ n _, args) <- unApply ap

414− = mkChange n args pargs ++

414+ = mkChange n args pargs ++

415 concatMap (\x -> findCalls x pvs pargs) args

416− findCalls (App f a) pvs pargs

416+ findCalls (App f a) pvs pargs

417 = findCalls f pvs pargs ++ findCalls a pvs pargs

418 findCalls (Bind n (Let t v) e) pvs pargs

419 = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs

420 findCalls (Bind n _ e) pvs pargs

421 = findCalls e (n : pvs) pargs

422− findCalls (P _ f _ ) pvs pargs

422+ findCalls (P _ f _ ) pvs pargs

423 | not (f `elem` pvs) = [(f, [])]

424 findCalls _ _ _ = []

425

@@ -439,16 +439,16 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

439 -- not be coinductive - so carry the type of the constructor we've

440 -- gone under.

441

442− smaller (Just tyn) a (t, Just tyt)

442+ smaller (Just tyn) a (t, Just tyt)

443− | a == t = isInductive (fst (unApply (getRetTy tyn)))

443+ | a == t = isInductive (fst (unApply (getRetTy tyn)))

444 (fst (unApply (getRetTy tyt)))

445 smaller ty a (ap@(App f s), _)

446− | (P (DCon _ _) n _, args) <- unApply ap

446+ | (P (DCon _ _) n _, args) <- unApply ap

447 = let tyn = getType n in

448− any (smaller (ty `mplus` Just tyn) a)

448+ any (smaller (ty `mplus` Just tyn) a)

449 (zip args (map toJust (getArgTys tyn)))

450 -- check higher order recursive arguments

451− smaller ty (App f s) a = smaller ty f a

451+ smaller ty (App f s) a = smaller ty f a

452 smaller _ _ _ = False

453

454 toJust (n, t) = Just t

@@ -472,19 +472,19 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

472 patvars _ = []

473

474{-

475−buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]

475+buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]

476buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

477− nub $ scg sc (zip args args)

477+ nub $ scg sc (zip args args)

478 (zip args (zip args (repeat Same)))

479 where

480 scg :: SC -> [(Name, Name)] -> -- local var, originating top level var

481 [(Name, (Name, SizeChange))] -> -- orig to new, and relationship

482 [SCGEntry]

483− scg (Case x alts) vars szs

483+ scg (Case x alts) vars szs

484 = let x' = findTL x vars in

485 concatMap (scgAlt x' vars szs) alts

486 where

487− findTL x vars

487+ findTL x vars

488 | Just x' <- lookup x vars

489 = if x' `elem` args then x'

490 else findTL x' vars

@@ -514,7 +514,7 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

514 -- not coinductive)

515 | Just tvar <- lookup x vars

516 = let arel = argRels n

517− szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel

517+ szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel

518 ++ szs

519 vars' = nub (zip args (repeat tvar) ++ vars) in

520 scg sc vars' szs'

@@ -529,7 +529,7 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

529 = let rest = concatMap (\x -> scgTerm x vars szs) args in

530 case lookup fn vars of

531 Just _ -> rest

532− Nothing -> nub $ (fn, map (mkChange szs) args) : rest

532+ Nothing -> nub $ (fn, map (mkChange szs) args) : rest

533 scgTerm (App f a) vars szs

534 = scgTerm f vars szs ++ scgTerm a vars szs

535 scgTerm (Bind n (Let t v) e) vars szs

@@ -542,7 +542,7 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

542 Nothing -> [(fn, [])]

543 scgTerm _ _ _ = []

544

545− mkChange :: [(Name, (Name, SizeChange))] -> Term

545+ mkChange :: [(Name, (Name, SizeChange))] -> Term

546 -> Maybe (Int, SizeChange)

547 mkChange szs tm

548 | (P _ (UN "lazy") _, [_, arg]) <- unApply tm = mkChange szs arg

@@ -567,12 +567,12 @@ checkSizeChange n = do

567 [cg] -> do let ms = mkMultiPaths ist [] (scg cg)

568 logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++

569 "from " ++ show (scg cg) ++ "\n" ++

570− show (length ms) ++ "\n" ++

570+ show (length ms) ++ "\n" ++

571 showSep "\n" (map show ms))

572 logLvl 6 (show cg)

573− -- every multipath must have an infinitely descending

573+ -- every multipath must have an infinitely descending

574 -- thread, then the function terminates

575− -- also need to checks functions called are all total

575+ -- also need to checks functions called are all total

576 -- (Unchecked is okay as we'll spot problems here)

577 let tot = map (checkMP ist (length (argsdef cg))) ms

578 logLvl 4 $ "Generated " ++ show (length tot) ++ " paths"

@@ -587,11 +587,11 @@ mkMultiPaths :: IState -> MultiPath -> [SCGEntry] -> [MultiPath]

587mkMultiPaths ist path [] = [reverse path]

588mkMultiPaths ist path cg

589 = concat (map extend cg)

590− where extend (nextf, args)

590+ where extend (nextf, args)

591 | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ]

592− | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)

592+ | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)

593 = case lookupCtxt nextf (idris_callgraph ist) of

594− [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

594+ [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

595 _ -> [ reverse ((nextf, args) : path) ]

596 | otherwise = [ reverse ((nextf, args) : path) ]

597

@@ -599,7 +599,7 @@ mkMultiPaths ist path cg

599-- if ((nextf, args) `elem` path)

600-- then return (reverse ((nextf, args) : path))

601-- else case lookupCtxt nextf (idris_callgraph ist) of

602−-- [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

602+-- [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

603-- _ -> return (reverse ((nextf, args) : path))

604

605-- If any route along the multipath leads to infinite descent, we're fine.

@@ -608,11 +608,11 @@ mkMultiPaths ist path cg

608-- that means there is an infinitely descending path from that argument.

609

610checkMP :: IState -> Int -> MultiPath -> Totality

611−checkMP ist i mp = if i > 0

611+checkMP ist i mp = if i > 0

612 then collapse (map (tryPath 0 [] mp) [0..i-1])

613 else tryPath 0 [] mp 0

614 where

615− tryPath' d path mp arg

615+ tryPath' d path mp arg

616 = let res = tryPath d path mp arg in

617 trace (show mp ++ "\n" ++ show arg ++ " " ++ show res) res

618

@@ -633,14 +633,14 @@ checkMP ist i mp = if i > 0

633 | e `elem` es && allNothing args = Partial (Mutual [f])

634 tryPath desc path (e@(f, nextargs) : es) arg

635 | Just d <- lookup e path

636− = if desc > 0

636+ = if desc > 0

637 then -- trace ("Descent " ++ show (desc - d) ++ " "

638 -- ++ show (path, e)) $

639 Total []

640 else Partial (Mutual (map (fst . fst) path ++ [f]))

641 | [Unchecked] <- lookupTotal f (tt_ctxt ist) =

642 let argspos = collapseNothing (zip nextargs [0..]) in

643− collapse' Unchecked $

643+ collapse' Unchecked $

644 do (a, pos) <- argspos

645 case a of

646 Nothing -> -- don't know, but if the

@@ -656,11 +656,11 @@ checkMP ist i mp = if i > 0

656 case sc of

657 Same -> return $ tryPath desc ((e, desc) : path)

658 es pos

659− Smaller -> return $ tryPath (desc+1)

659+ Smaller -> return $ tryPath (desc+1)

660− ((e, desc):path)

660+ ((e, desc):path)

661 es

662 pos

663− _ -> trace ("Shouldn't happen " ++ show e) $

663+ _ -> trace ("Shouldn't happen " ++ show e) $

664 return (Partial Itself)

665 else return Unchecked

666 | [Total a] <- lookupTotal f (tt_ctxt ist) = Total a

@@ -669,7 +669,7 @@ checkMP ist i mp = if i > 0

669

670allNothing xs = null (collapseNothing (zip xs [0..]))

671

672−collapseNothing ((Nothing, _) : xs)

672+collapseNothing ((Nothing, _) : xs)

673 = filter (\ (x, _) -> case x of

674 Nothing -> False

675 _ -> True) xs

@@ -678,11 +678,11 @@ collapseNothing [] = []

678

679noPartial (Partial p : xs) = Partial p

680noPartial (_ : xs) = noPartial xs

681−noPartial [] = Total []

681+noPartial [] = Total []

682

683collapse xs = collapse' Unchecked xs

684collapse' def (Total r : xs) = Total r

685−collapse' def (Unchecked : xs) = collapse' def xs

685+collapse' def (Unchecked : xs) = collapse' def xs

686collapse' def (d : xs) = collapse' d xs

687-- collapse' Unchecked [] = Total []

688collapse' def [] = def

src/Idris/DSL.hs+13−13

@@ -13,7 +13,7 @@ import Control.Monad.State

13import Debug.Trace

14

15debindApp :: SyntaxInfo -> PTerm -> PTerm

16−debindApp syn t = debind (dsl_bind (dsl_info syn)) t

16+debindApp syn t = debind (dsl_bind (dsl_info syn)) t

17

18desugar :: SyntaxInfo -> IState -> PTerm -> PTerm

19desugar syn i t = let t' = expandDo (dsl_info syn) t in

@@ -21,7 +21,7 @@ desugar syn i t = let t' = expandDo (dsl_info syn) t in

21

22expandDo :: DSL -> PTerm -> PTerm

23expandDo dsl (PLam n ty tm)

24− | Just lam <- dsl_lambda dsl

24+ | Just lam <- dsl_lambda dsl

25 = let sc = PApp (fileFC "(dsl)") lam [pexp (var dsl n tm 0)] in

26 expandDo dsl sc

27expandDo dsl (PLam n ty tm) = PLam n (expandDo dsl ty) (expandDo dsl tm)

@@ -33,13 +33,13 @@ expandDo dsl (PLet n ty v tm) = PLet n (expandDo dsl ty) (expandDo dsl v) (expan

33expandDo dsl (PPi p n ty tm) = PPi p n (expandDo dsl ty) (expandDo dsl tm)

34expandDo dsl (PApp fc t args) = PApp fc (expandDo dsl t)

35 (map (fmap (expandDo dsl)) args)

36−expandDo dsl (PAppBind fc t args) = PAppBind fc (expandDo dsl t)

36+expandDo dsl (PAppBind fc t args) = PAppBind fc (expandDo dsl t)

37− (map (fmap (expandDo dsl)) args)

37+ (map (fmap (expandDo dsl)) args)

38expandDo dsl (PCase fc s opts) = PCase fc (expandDo dsl s)

39 (map (pmap (expandDo dsl)) opts)

40expandDo dsl (PEq fc l r) = PEq fc (expandDo dsl l) (expandDo dsl r)

41expandDo dsl (PPair fc l r) = PPair fc (expandDo dsl l) (expandDo dsl r)

42−expandDo dsl (PDPair fc l t r) = PDPair fc (expandDo dsl l) (expandDo dsl t)

42+expandDo dsl (PDPair fc l t r) = PDPair fc (expandDo dsl l) (expandDo dsl t)

43 (expandDo dsl r)

44expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as)

45expandDo dsl (PHidden t) = PHidden (expandDo dsl t)

@@ -50,15 +50,15 @@ expandDo dsl (PRewrite fc r t ty)

50 = PRewrite fc r (expandDo dsl t) ty

51expandDo dsl (PGoal fc r n sc)

52 = PGoal fc (expandDo dsl r) n (expandDo dsl sc)

53−expandDo dsl (PDoBlock ds)

53+expandDo dsl (PDoBlock ds)

54 = expandDo dsl $ debind (dsl_bind dsl) (block (dsl_bind dsl) ds)

55 where

56− block b [DoExp fc tm] = tm

56+ block b [DoExp fc tm] = tm

57 block b [a] = PElabError (Msg "Last statement in do block must be an expression")

58 block b (DoBind fc n tm : rest)

59 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

60 block b (DoBindP fc p tm : rest)

61− = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder

61+ = PApp fc b [pexp tm, pexp (PLam (MN 0 "bpat") Placeholder

62 (PCase fc (PRef fc (MN 0 "bpat"))

63 [(p, block b rest)]))]

64 block b (DoLet fc n ty tm : rest)

@@ -66,8 +66,8 @@ expandDo dsl (PDoBlock ds)

66 block b (DoLetP fc p tm : rest)

67 = PCase fc tm [(p, block b rest)]

68 block b (DoExp fc tm : rest)

69− = PApp fc b

69+ = PApp fc b

70− [pexp tm,

70+ [pexp tm,

71 pexp (PLam (MN 0 "bindx") Placeholder (block b rest))]

72 block b _ = PElabError (Msg "Invalid statement in do block")

73

@@ -76,7 +76,7 @@ expandDo dsl t = t

76

77var :: DSL -> Name -> PTerm -> Int -> PTerm

78var dsl n t i = v' i t where

79− v' i (PRef fc x) | x == n =

79+ v' i (PRef fc x) | x == n =

80 case dsl_var dsl of

81 Nothing -> PElabError (Msg "No 'variable' defined in dsl")

82 Just v -> PApp fc v [pexp (mkVar fc i)]

@@ -107,7 +107,7 @@ var dsl n t i = v' i t where

107 Just f -> f

108 mkVar fc n = case index_next dsl of

109 Nothing -> PElabError (Msg "No index_next defined")

110− Just f -> PApp fc f [pexp (mkVar fc (n-1))]

110+ Just f -> PApp fc f [pexp (mkVar fc (n-1))]

111

112unIdiom :: PTerm -> PTerm -> FC -> PTerm -> PTerm

113unIdiom ap pure fc e@(PApp _ _ _) = let f = getFn e in

@@ -150,7 +150,7 @@ debind b tm = let (tm', (bs, _)) = runState (db' tm) ([], 0) in

150 db' (PDPair fc l t r) = do l' <- db' l

151 r' <- db' r

152 return (PDPair fc l' t r')

153− db' t = return t

153+ db' t = return t

154

155 dbArg a = do t' <- db' (getTm a)

156 return (a { getTm = t' })

src/Idris/DataOpts.hs+12−12

@@ -28,11 +28,11 @@ forceArgs n t = do i <- getIState

28 where

29 force :: IState -> Int -> Term -> [Int]

30 force ist i (Bind _ (Pi ty) sc)

31− | collapsibleIn ist ty

31+ | collapsibleIn ist ty

32 = nub $ i : (force ist (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc)

33 | otherwise = force ist (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc

34− force _ _ sc@(App f a)

34+ force _ _ sc@(App f a)

35− | (_, args) <- unApply sc

35+ | (_, args) <- unApply sc

36 = nub $ concatMap guarded args

37 force _ _ _ = []

38

@@ -57,7 +57,7 @@ forceArgs n t = do i <- getIState

57-- Calculate whether a collection of constructors is collapsible

58

59collapseCons :: Name -> [(Name, Type)] -> Idris ()

60−collapseCons ty cons =

60+collapseCons ty cons =

61 do i <- getIState

62 let cons' = map (\ (n, t) -> (n, map snd (getArgTys t))) cons

63 allFR <- mapM (forceRec i) cons'

@@ -75,7 +75,7 @@ collapseCons ty cons =

75 putIState (i { idris_optimisation = opts })

76 else return ()

77 _ -> return ()

78−

78+

79 checkNewType _ = return ()

80

81 setCollapsible :: Name -> Idris ()

@@ -101,12 +101,12 @@ collapseCons ty cons =

101 checkFR fs i (t : xs)

102 -- must be recursive or type is not collapsible

103 = do let (rtf, rta) = unApply $ getRetTy t

104− if (ty `elem` freeNames rtf)

104+ if (ty `elem` freeNames rtf)

105 then checkFR fs (i+1) xs

106 else return False

107

108 detaggable :: [Type] -> Idris ()

109− detaggable rtys

109+ detaggable rtys

110 = do let rtyArgs = map (snd . unApply) rtys

111 -- if every rtyArgs is disjoint with every other, it's detaggable,

112 -- therefore also collapsible given forceable/recursive check

@@ -204,7 +204,7 @@ instance Optimisable t => Optimisable (Binder t) where

204

205applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw

206applyDataOpt oi n args

207− = let args' = zipWith doForce (map (\x -> x `elem` (forceable oi)) [0..])

207+ = let args' = zipWith doForce (map (\x -> x `elem` (forceable oi)) [0..])

208 args in

209 raw_apply (Var n) args'

210 where

@@ -267,7 +267,7 @@ applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term

267applyDataOptRT oi n tag arity args

268 | length args == arity = doOpts n args (collapsible oi) (forceable oi)

269 | otherwise = let extra = satArgs (arity - length args)

270− tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra)

270+ tm = doOpts n (args ++ map (\n -> P Bound n Erased) extra)

271 (collapsible oi) (forceable oi) in

272 bind extra tm

273 where

@@ -279,7 +279,7 @@ applyDataOptRT oi n tag arity args

279 -- Nat special cases

280 -- TODO: Would be nice if this was configurable in idris source!

281 doOpts (NS (UN "Z") ["Nat", "Prelude"]) [] _ _ = Constant (BI 0)

282− doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _

282+ doOpts (NS (UN "S") ["Nat", "Prelude"]) [k] _ _

283 = App (App (P Ref (UN "prim__addBigInt") Erased) k) (Constant (BI 1))

284

285 doOpts n args True f = Erased

@@ -290,8 +290,8 @@ applyDataOptRT oi n tag arity args

290 then case args' of

291 [(_, val)] -> val

292 _ -> error "Can't happen (not isnewtype)"

293− else

293+ else

294− mkApp (P (DCon tag (arity - length forced)) n Erased)

294+ mkApp (P (DCon tag (arity - length forced)) n Erased)

295 (map snd args')

296

297 keep (forced, _) = not forced

src/Idris/Delaborate.hs+20−20

@@ -17,7 +17,7 @@ delab :: IState -> Term -> PTerm

17delab i tm = delab' i tm False

18

19delabTy :: IState -> Name -> PTerm

20−delabTy i n

20+delabTy i n

21 = case lookupTy n (tt_ctxt i) of

22 (ty:_) -> case lookupCtxt n (idris_implicits i) of

23 (imps:_) -> delabTy' i imps ty False

@@ -43,17 +43,17 @@ delabTy' ist imps tm fullname = de [] imps tm

43 = case lookup n (idris_metavars ist) of

44 Just (Just _, mi) -> mkMVApp (dens n) []

45 _ -> PRef un (dens n)

46− de env _ (Bind n (Lam ty) sc)

46+ de env _ (Bind n (Lam ty) sc)

47 = PLam n (de env [] ty) (de ((n,n):env) [] sc)

48− de env (PImp _ _ _ _ _ _:is) (Bind n (Pi ty) sc)

48+ de env (PImp _ _ _ _ _ _:is) (Bind n (Pi ty) sc)

49 = PPi impl n (de env [] ty) (de ((n,n):env) is sc)

50− de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc)

50+ de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc)

51 = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)

52− de env (PTacImplicit _ _ _ tac _ _:is) (Bind n (Pi ty) sc)

52+ de env (PTacImplicit _ _ _ tac _ _:is) (Bind n (Pi ty) sc)

53 = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)

54− de env _ (Bind n (Pi ty) sc)

54+ de env _ (Bind n (Pi ty) sc)

55 = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

56− de env _ (Bind n (Let ty val) sc)

56+ de env _ (Bind n (Let ty val) sc)

57 = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

58 de env _ (Bind n (Hole ty) sc) = de ((n, UN "[__]"):env) [] sc

59 de env _ (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) [] sc

@@ -61,7 +61,7 @@ delabTy' ist imps tm fullname = de [] imps tm

61 de env _ (Constant i) = PConstant i

62 de env _ Erased = Placeholder

63 de env _ Impossible = Placeholder

64− de env _ (TType i) = PType

64+ de env _ (TType i) = PType

65

66 dens x | fullname = x

67 dens ns@(NS n _) = case lookupCtxt n (idris_implicits ist) of

@@ -71,31 +71,31 @@ delabTy' ist imps tm fullname = de [] imps tm

71 dens n = n

72

73 deFn env (App f a) args = deFn env f (a:args)

74− deFn env (P _ n _) [l,r]

74+ deFn env (P _ n _) [l,r]

75 | n == pairTy = PPair un (de env [] l) (de env [] r)

76 | n == eqCon = PRefl un (de env [] r)

77 | n == UN "lazy" = de env [] r

78 deFn env (P _ n _) [ty, Bind x (Lam _) r]

79− | n == UN "Exists"

79+ | n == UN "Exists"

80 = PDPair un (PRef un x) (de env [] ty)

81 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

82− deFn env (P _ n _) [_,_,l,r]

82+ deFn env (P _ n _) [_,_,l,r]

83 | n == pairCon = PPair un (de env [] l) (de env [] r)

84 | n == eqTy = PEq un (de env [] l) (de env [] r)

85 | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder

86 (de env [] r)

87− deFn env (P _ n _) args

87+ deFn env (P _ n _) args

88 = case lookup n (idris_metavars ist) of

89− Just (Just _, mi) ->

89+ Just (Just _, mi) ->

90 mkMVApp (dens n) (drop mi (map (de env []) args))

91 _ -> mkPApp (dens n) (map (de env []) args)

92 deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args))

93

94 mkMVApp n []

95 = PMetavar n

96− mkMVApp n args

96+ mkMVApp n args

97 = PApp un (PMetavar n) (map pexp args)

98− mkPApp n args

98+ mkPApp n args

99 | [imps] <- lookupCtxt n (idris_implicits ist)

100 = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)

101 | otherwise = PApp un (PRef un n) (map pexp args)

@@ -113,7 +113,7 @@ indented text = boxIt '\n' $ unlines $ map ('\t':) $ lines text where

113

114pshow :: IState -> Err -> String

115pshow i (Msg s) = s

116−pshow i (InternalMsg s) = "INTERNAL ERROR: " ++ show s ++

116+pshow i (InternalMsg s) = "INTERNAL ERROR: " ++ show s ++

117 "\nThis is probably a bug, or a missing error message.\n" ++

118 "Please consider reporting at " ++ bugaddr

119pshow i (CantUnify _ x y e sc s)

@@ -152,11 +152,11 @@ pshow i (CantIntroduce ty)

152 let colour = idris_colourRepl i in

153 "Can't use lambda here: type is " ++ showImp (Just i) imps colour (delab i ty)

154pshow i (InfiniteUnify x tm env)

155− = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++

155+ = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++

156 " would lead to infinite value" ++

157 if (opt_errContext (idris_options i)) then showSc i env else ""

158pshow i (NotInjective p x y) = "Can't verify injectivity of " ++ show (delab i p) ++

159− " when unifying " ++ show (delab i x) ++ " and " ++

159+ " when unifying " ++ show (delab i x) ++ " and " ++

160 show (delab i y)

161pshow i (CantResolve c) = "Can't resolve type class " ++ show (delab i c)

162pshow i (CantResolveAlts as) = "Can't disambiguate name: " ++ showSep ", " as

@@ -166,13 +166,13 @@ pshow i (IncompleteTerm t) = "Incomplete term " ++ showImp Nothing True False (d

166pshow i UniverseError = "Universe inconsistency"

167pshow i ProgramLineComment = "Program line next to comment"

168pshow i (Inaccessible n) = show n ++ " is not an accessible pattern variable"

169−pshow i (NonCollapsiblePostulate n)

169+pshow i (NonCollapsiblePostulate n)

170 = "The return type of postulate " ++ show n ++ " is not collapsible"

171pshow i (AlreadyDefined n) = show n ++ " is already defined"

172pshow i (ProofSearchFail e) = pshow i e

173pshow i (NoRewriting tm) = "rewrite did not change type " ++ show (delab i tm)

174pshow i (At f e) = show f ++ ":" ++ pshow i e

175−pshow i (Elaborating s n e) = "When elaborating " ++ s ++

175+pshow i (Elaborating s n e) = "When elaborating " ++ s ++

176 showqual i n ++ ":\n" ++ pshow i e

177pshow i (ProviderError msg) = "Type provider error: " ++ msg

178pshow i (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ pshow i e

src/Idris/Docs.hs+8−8

@@ -11,7 +11,7 @@ import Data.List

11

12-- TODO: Only include names with public/abstract accessibility

13

14−data FunDoc = Doc Name String

14+data FunDoc = Doc Name String

15 [(Name, PArg)] -- args

16 PTerm -- function type

17 (Maybe Fixity)

@@ -23,7 +23,7 @@ data Doc = FunDoc FunDoc

23 [FunDoc] -- method docs

24

25showDoc "" = ""

26−showDoc x = " -- " ++ x

26+showDoc x = " -- " ++ x

27

28instance Show FunDoc where

29 show (Doc n doc args ty f)

@@ -35,7 +35,7 @@ instance Show FunDoc where

35 else ""

36

37 where showArg (n, arg@(PExp _ _ _ _))

38− = Just $ showName n ++ show (getTm arg) ++

38+ = Just $ showName n ++ show (getTm arg) ++

39 showDoc (pargdoc arg) ++ "\n"

40 showArg (n, arg@(PConstraint _ _ _ _))

41 = Just $ "Class constraint " ++

@@ -44,7 +44,7 @@ instance Show FunDoc where

44 showArg (n, arg@(PImp _ _ _ _ _ doc))

45 | not (null doc)

46 = Just $ "(implicit) " ++

47− show n ++ " : " ++ show (getTm arg)

47+ show n ++ " : " ++ show (getTm arg)

48 ++ showDoc (pargdoc arg) ++ "\n"

49 showArg (n, _) = Nothing

50

@@ -57,13 +57,13 @@ instance Show Doc where

57 show (DataDoc t args) = "Data type " ++ show t ++

58 "\nConstructors:\n\n" ++

59 showSep "\n" (map show args)

60− show (ClassDoc n doc meths)

60+ show (ClassDoc n doc meths)

61 = "Type class " ++ show n ++ -- parameters?

62 "\nMethods:\n\n" ++

63 showSep "\n" (map show meths)

64

65getDocs :: Name -> Idris Doc

66−getDocs n

66+getDocs n

67 = do i <- getIState

68 case lookupCtxt n (idris_classes i) of

69 [ci] -> docClass n ci

@@ -73,7 +73,7 @@ getDocs n

73 return (FunDoc fd)

74

75docData :: Name -> TypeInfo -> Idris Doc

76−docData n ti

76+docData n ti

77 = do tdoc <- docFun n

78 cdocs <- mapM docFun (con_names ti)

79 return (DataDoc tdoc cdocs)

@@ -103,7 +103,7 @@ docFun n

103 let fixdecls = filter (\(Fix _ x) -> x == funName n) infixes

104 let f = case fixdecls of

105 [] -> Nothing

106− (Fix x _:_) -> Just x

106+ (Fix x _:_) -> Just x

107

108 return (Doc n docstr args (delab i ty) f)

109 where funName :: Name -> String

src/Idris/ElabDecls.hs+176−176

@@ -31,9 +31,9 @@ import Data.List

31import Data.Maybe

32import Debug.Trace

33

34−recheckC fc env t

34+recheckC fc env t

35 = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...)

36− ctxt <- getContext

36+ ctxt <- getContext

37 (tm, ty, cs) <- tclift $ case recheck ctxt env (forget t) t of

38 Error e -> tfail (At fc e)

39 OK x -> return x

@@ -47,7 +47,7 @@ checkDef fc ns = do ctxt <- getContext

47-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

48elabType :: ElabInfo -> SyntaxInfo -> String ->

49 FC -> FnOpts -> Name -> PTerm -> Idris ()

50−elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in

50+elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in

51 n = liftname info n_in in -}

52 do checkUndefined fc n

53 ctxt <- getContext

@@ -59,12 +59,12 @@ elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in

59

60 let ty = addImpl i ty'

61 logLvl 2 $ show n ++ " type " ++ showImp Nothing True False ty

62− ((tyT, defer, is), log) <-

62+ ((tyT, defer, is), log) <-

63 tclift $ elaborate ctxt n (TType (UVal 0)) []

64 (errAt "type of " n (erun fc (build i info False n ty)))

65 ds <- checkDef fc defer

66 addDeferred ds

67− mapM_ (elabCaseBlock info opts) is

67+ mapM_ (elabCaseBlock info opts) is

68 ctxt <- getContext

69 logLvl 5 $ "Rechecking"

70 logLvl 6 $ show tyT

@@ -147,7 +147,7 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

147 i <- getIState

148 t_in <- implicit syn n t_in

149 let t = addImpl i t_in

150− ((t', defer, is), log) <-

150+ ((t', defer, is), log) <-

151 tclift $ elaborate ctxt n (TType (UVal 0)) []

152 (errAt "data declaration " n (erun fc (build i info False n t)))

153 def' <- checkDef fc defer

@@ -156,11 +156,11 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

156 (cty, _) <- recheckC fc [] t'

157 logLvl 2 $ "---> " ++ show cty

158 -- temporary, to check cons

159− when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

159+ when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

160 cons <- mapM (elabCon info syn n codata) dcons

161 ttag <- getName

162 i <- getIState

163− let as = map (const Nothing) (getArgTys cty)

163+ let as = map (const Nothing) (getArgTys cty)

164 let params = findParams (map snd cons)

165 logLvl 2 $ "Parameters : " ++ show params

166 putIState (i { idris_datatypes = addDef n (TI (map fst cons) codata params)

@@ -172,7 +172,7 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

172 collapseCons n cons

173 updateContext (addDatatype (Data n ttag cty cons))

174 mapM_ (checkPositive n) cons

175− where

175+ where

176 -- parameters are names which are unchanged across the structure,

177 -- which appear exactly once in the return type of a constructor

178

@@ -184,14 +184,14 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

184 paramPos allapps

185

186 paramPos [] = []

187− paramPos (args : rest)

187+ paramPos (args : rest)

188 = dropNothing $ keepSame (zip [0..] args) rest

189

190 dropNothing [] = []

191 dropNothing ((x, Nothing) : ts) = dropNothing ts

192 dropNothing ((x, _) : ts) = x : dropNothing ts

193

194− keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] ->

194+ keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] ->

195 [(Int, Maybe Name)]

196 keepSame as [] = as

197 keepSame as (args : rest) = keepSame (update as args) rest

@@ -211,14 +211,14 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

211 getDataApp _ = []

212

213 -- keep the arguments which are single names, which don't appear

214− -- elsewhere

214+ -- elsewhere

215

216 mParam args [] = []

217 mParam args (P Bound n _ : rest)

218− | count n args == 1

218+ | count n args == 1

219 = Just n : mParam args rest

220 where count n [] = 0

221− count n (t : ts)

221+ count n (t : ts)

222 | n `elem` freeNames t = 1 + count n ts

223 | otherwise = count n ts

224 mParam args (_ : rest) = Nothing : mParam args rest

@@ -253,7 +253,7 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

253 believeTy = Bind (UN "a") (Pi (TType (UVar (-2))))

254 (Bind (UN "b") (Pi (TType (UVar (-2))))

255 (Bind (UN "x") (Pi (V 1)) (V 1)))

256− elabBelieveMe

256+ elabBelieveMe

257 = do let prim__believe_me = (UN "prim__believe_me")

258 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)

259 setTotality prim__believe_me (Partial NotCovering)

@@ -279,7 +279,7 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

279 (Bind (UN "y") (Pi (V 1))

280 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)

281 [V 3, V 2, V 1, V 0]]))))

282− elabSynEq

282+ elabSynEq

283 = do let synEq = UN "prim__syntactic_eq"

284

285 updateContext (addOperator synEq synEqTy 4 p_synEq)

@@ -375,10 +375,10 @@ elabTransform info fc safe lhs_in rhs_in

375 addIBC (IBCTrans (clhs_tm, crhs_tm))

376

377

378−elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

378+elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

379 PTerm -> String -> Name -> PTerm -> Idris ()

380elabRecord info syn doc fc tyn ty cdoc cn cty

381− = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)])

381+ = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)])

382 cty' <- implicit syn cn cty

383 i <- getIState

384 cty <- case lookupTy cn (tt_ctxt i) of

@@ -408,8 +408,8 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

408 = do i <- getIState

409 idrisCatch (do elabDecl' EAll info ty

410 elabDecl' EAll info val)

411− (\v -> do iputStrLn $ show fc ++

411+ (\v -> do iputStrLn $ show fc ++

412− ":Warning - can't generate setter for " ++

412+ ":Warning - can't generate setter for " ++

413 show fn ++ " (" ++ show ty ++ ")"

414 putIState i)

415

@@ -459,9 +459,9 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

459 let lhs = PApp fc (PRef fc pn)

460 [pexp (PApp fc (PRef fc cn) iargs)]

461 let rhs = PRef fc (mkp pn)

462− let pclause = PClause fc pn lhs [] rhs []

462+ let pclause = PClause fc pn lhs [] rhs []

463 return [pfnTy, PClauses fc [] pn [pclause]]

464−

464+

465 implicitise (pa, t) = pa { getTm = t }

466

467 mkUpdate recty k num ((pn, pty), pos)

@@ -484,7 +484,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

484 (map pexp rhsArgs)) []

485 return (pn, pfnTy, PClauses fc [] setname [pclause])

486

487−elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

487+elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

488 (String, Name, PTerm, FC) -> Idris (Name, Type)

489elabCon info syn tn codata (doc, n, t_in, fc)

490 = do checkUndefined fc n

@@ -493,7 +493,7 @@ elabCon info syn tn codata (doc, n, t_in, fc)

493 t_in <- implicit syn n (if codata then mkLazy t_in else t_in)

494 let t = addImpl i t_in

495 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ showImp Nothing True False t

496− ((t', defer, is), log) <-

496+ ((t', defer, is), log) <-

497 tclift $ elaborate ctxt n (TType (UVal 0)) []

498 (errAt "constructor " n (erun fc (build i info False n t)))

499 logLvl 2 $ "Rechecking " ++ show t'

@@ -512,8 +512,8 @@ elabCon info syn tn codata (doc, n, t_in, fc)

512 return (n, cty')

513 where

514 tyIs (Bind n b sc) = tyIs sc

515− tyIs t | (P _ n' _, _) <- unApply t

515+ tyIs t | (P _ n' _, _) <- unApply t

516− = if n' /= tn then tclift $ tfail (At fc (Msg (show n' ++ " is not " ++ show tn)))

516+ = if n' /= tn then tclift $ tfail (At fc (Msg (show n' ++ " is not " ++ show tn)))

517 else return ()

518 tyIs t = tclift $ tfail (At fc (Msg (show t ++ " is not " ++ show tn)))

519

@@ -523,7 +523,7 @@ elabCon info syn tn codata (doc, n, t_in, fc)

523-- | Elaborate a collection of left-hand and right-hand pairs - that is, a

524-- top-level definition.

525elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

526−elabClauses info fc opts n_in cs = let n = liftname info n_in in

526+elabClauses info fc opts n_in cs = let n = liftname info n_in in

527 do ctxt <- getContext

528 -- Check n actually exists, with no definition yet

529 let tys = lookupTy n ctxt

@@ -535,7 +535,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

535 -- question: CAFs in where blocks?

536 tclift $ tfail $ At fc (NoTypeDecl n)

537 [ty] -> return ty

538− pats_in <- mapM (elabClause info opts)

538+ pats_in <- mapM (elabClause info opts)

539 (zip [0..] cs)

540 logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in

541

@@ -553,9 +553,9 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

553 _ -> False

554 solveDeferred n

555 ist <- getIState

556− when doNothing $

556+ when doNothing $

557 case lookupCtxt n (idris_optimisation ist) of

558− [oi] -> do let opts = addDef n (oi { collapsible = True })

558+ [oi] -> do let opts = addDef n (oi { collapsible = True })

559 (idris_optimisation ist)

560 putIState (ist { idris_optimisation = opts })

561 _ -> do let opts = addDef n (Optimise True False [] [])

@@ -563,10 +563,10 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

563 putIState (ist { idris_optimisation = opts })

564 addIBC (IBCOpt n)

565 ist <- getIState

566− let pats = doTransforms ist pats_in

566+ let pats = doTransforms ist pats_in

567

568− -- logLvl 3 (showSep "\n" (map (\ (l,r) ->

568+ -- logLvl 3 (showSep "\n" (map (\ (l,r) ->

569− -- show l ++ " = " ++

569+ -- show l ++ " = " ++

570 -- show r) pats))

571 let tcase = opt_typecase (idris_options ist)

572

@@ -583,7 +583,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

583 -- This will get further optimised for run-time, and, separately,

584 -- further inlined to help with totality checking.

585 let pdef = map debind $ map (simple_lhs (tt_ctxt ist)) pats

586−

586+

587 logLvl 5 $ "Initial typechecked patterns:\n" ++ show pdef

588

589 -- TODO: Inlining on initial definition happens here.

@@ -600,7 +600,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

600

601 -- patterns after collapsing optimisation applied

602 -- (i.e. check if the function should do nothing at run time)

603− optpats <- if doNothing

603+ optpats <- if doNothing

604 then return $ [Right (mkApp (P Bound n Erased)

605 (take numArgs (repeat Erased)), Erased)]

606 else stripCollapsed pats

@@ -610,22 +610,22 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

610 _ -> return ()

611

612 let optpdef = map debind $ map (simple_lhs (tt_ctxt ist)) optpats

613− tree@(CaseDef scargs sc _) <- tclift $

613+ tree@(CaseDef scargs sc _) <- tclift $

614 simpleCase tcase False reflect CompileTime fc pdef

615 cov <- coverage

616 pmissing <-

617− if cov

617+ if cov

618 then do missing <- genClauses fc n (map getLHS pdef) cs

619− -- missing <- genMissing n scargs sc

619+ -- missing <- genMissing n scargs sc

620 missing' <- filterM (checkPossible info fc True n) missing

621 let clhs = map getLHS pdef

622− logLvl 2 $ "Must be unreachable:\n" ++

622+ logLvl 2 $ "Must be unreachable:\n" ++

623 showSep "\n" (map (showImp Nothing True False) missing') ++

624 "\nAgainst: " ++

625 showSep "\n" (map (\t -> showImp Nothing True False (delab ist t)) (map getLHS pdef))

626 -- filter out anything in missing' which is

627 -- matched by any of clhs. This might happen since

628− -- unification may force a variable to take a

628+ -- unification may force a variable to take a

629 -- particular form, rather than force a case

630 -- to be impossible.

631 return (filter (noMatch ist clhs) missing')

@@ -633,7 +633,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

633 let pcover = null pmissing

634

635 -- pdef' is the version that gets compiled for run-time

636− pdef' <- applyOpts optpdef

636+ pdef' <- applyOpts optpdef

637 logLvl 5 $ "After data structure transformations:\n" ++ show pdef'

638

639 ist <- getIState

@@ -641,8 +641,8 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

641 let tot = if pcover || AssertTotal `elem` opts

642 then Unchecked -- finish checking later

643 else Partial NotCovering -- already know it's not total

644− -- case lookupCtxt (namespace info) n (idris_flags ist) of

644+ -- case lookupCtxt (namespace info) n (idris_flags ist) of

645− -- [fs] -> if TotalFn `elem` fs

645+ -- [fs] -> if TotalFn `elem` fs

646 -- then case tot of

647 -- Total _ -> return ()

648 -- t -> tclift $ tfail (At fc (Msg (show n ++ " is " ++ show t)))

@@ -652,7 +652,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

652 CaseDef _ _ [] -> return ()

653 CaseDef _ _ xs -> mapM_ (\x ->

654 iputStrLn $ show fc ++

655− ":warning - Unreachable case: " ++

655+ ":warning - Unreachable case: " ++

656 show (delab ist x)) xs

657 let knowncovering = (pcover && cov) || AssertTotal `elem` opts

658

@@ -662,12 +662,12 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

662 logLvl 3 $ "Optimised: " ++ show tree'

663 ctxt <- getContext

664 ist <- getIState

665− putIState (ist { idris_patdefs = addDef n (pdef', pmissing)

665+ putIState (ist { idris_patdefs = addDef n (pdef', pmissing)

666 (idris_patdefs ist) })

667 let caseInfo = CaseInfo (inlinable opts) (dictionary opts)

668 case lookupTy n ctxt of

669 [ty] -> do updateContext (addCasedef n caseInfo

670− tcase knowncovering

670+ tcase knowncovering

671 reflect

672 (AssertTotal `elem` opts)

673 pats

@@ -698,14 +698,14 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

698 where

699 noMatch i cs tm = all (\x -> case matchClause i (delab' i x True) tm of

700 Right _ -> False

701− Left miss -> True) cs

701+ Left miss -> True) cs

702

703 checkUndefined n ctxt = case lookupDef n ctxt of

704 [] -> return ()

705 [TyDecl _ _] -> return ()

706 _ -> tclift $ tfail (At fc (AlreadyDefined n))

707

708− debind (Right (x, y)) = let (vs, x') = depat [] x

708+ debind (Right (x, y)) = let (vs, x') = depat [] x

709 (_, y') = depat [] y in

710 (vs, x', y')

711 debind (Left x) = let (vs, x') = depat [] x in

@@ -713,26 +713,26 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

713

714 depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)

715 depat acc x = (acc, x)

716−

716+

717 getLHS (_, l, _) = l

718

719− simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)

719+ simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)

720 simple_lhs ctxt t = t

721

722 specNames [] = Nothing

723 specNames (Specialise ns : _) = Just ns

724 specNames (_ : xs) = specNames xs

725

726− sameLength ((_, x, _) : xs)

726+ sameLength ((_, x, _) : xs)

727 = do l <- sameLength xs

728 let (f, as) = unApply x

729 if (null xs || l == length as) then return (length as)

730 else tfail (At fc (Msg "Clauses have differing numbers of arguments "))

731 sameLength [] = return 0

732

733− -- apply all transformations (just specialisation for now, add

733+ -- apply all transformations (just specialisation for now, add

734 -- user defined transformation rules later)

735− doTransforms ist pats =

735+ doTransforms ist pats =

736 case specNames opts of

737 Nothing -> pats

738 Just ns -> partial_eval (tt_ctxt ist) ns pats

@@ -750,14 +750,14 @@ elabValBind info aspat tm_in

750 -- * ordinary elaboration

751 -- * elaboration as a Type

752 -- * elaboration as a function a -> b

753−

753+

754− ((tm', defer, is), _) <-

754+ ((tm', defer, is), _) <-

755−-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

755+-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

756-- (build i info aspat (MN 0 "val") tm))

757 tclift (elaborate ctxt (MN 0 "val") infP []

758 (build i info aspat (MN 0 "val") (infTerm tm)))

759 let vtm = orderPats (getInferTerm tm')

760− let bargs = getPBtys vtm

760+ let bargs = getPBtys vtm

761

762 def' <- checkDef (fileFC "(input)") defer

763 addDeferred def'

@@ -796,7 +796,7 @@ checkPossible info fc tcgen fname lhs_in

796-- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)

797 err@(Error _) -> return False

798

799−elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

799+elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

800 Idris (Either Term (Term, Term))

801elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

802 = do let tcgen = Dictionary `elem` opts

@@ -805,7 +805,7 @@ elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

805 True -> ifail $ show fc ++ ":" ++ show lhs_in ++ " is a possible case"

806 False -> do ptm <- mkPatTm lhs_in

807 return (Left ptm)

808−elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

808+elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

809 = do let tcgen = Dictionary `elem` opts

810 ctxt <- getContext

811

@@ -818,15 +818,15 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

818 _ -> error "Can't happen (elabClause function type)"

819 let fn_is = case lookupCtxt fname (idris_implicits i) of

820 [t] -> t

821− _ -> []

821+ _ -> []

822 let params = getParamsInType i [] fn_is fn_ty

823 let lhs = addImplPat i (propagateParams params (stripLinear i lhs_in))

824 logLvl 5 ("LHS: " ++ show fc ++ " " ++ showImp Nothing True False lhs)

825 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is))

826

827− ((lhs', dlhs, []), _) <-

827+ ((lhs', dlhs, []), _) <-

828 tclift $ elaborate ctxt (MN 0 "patLHS") infP []

829− (errAt "left hand side of " fname

829+ (errAt "left hand side of " fname

830 (erun fc (buildTC i info True tcgen fname (infTerm lhs))))

831 let lhs_tm = orderPats (getInferTerm lhs')

832 let lhs_ty = getInferType lhs'

@@ -848,7 +848,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

848 let defs = nub (decls ++ concatMap defined whereblock)

849 let newargs = pvars ist lhs_tm

850 let wb = map (expandParamsD False ist decorate newargs defs) whereblock

851−

851+

852 -- Split the where block into declarations with a type, and those

853 -- without

854 -- Elaborate those with a type *before* RHS, those without *after*

@@ -864,12 +864,12 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

864 logLvl 2 $ "RHS: " ++ showImp Nothing True False rhs

865 ctxt <- getContext -- new context with where block added

866 logLvl 5 "STARTING CHECK"

867− ((rhs', defer, is), _) <-

867+ ((rhs', defer, is), _) <-

868 tclift $ elaborate ctxt (MN 0 "patRHS") clhsty []

869 (do pbinds lhs_tm

870− (_, _, is) <- errAt "right hand side of " fname

870+ (_, _, is) <- errAt "right hand side of " fname

871 (erun fc (build i info False fname rhs))

872− errAt "right hand side of " fname

872+ errAt "right hand side of " fname

873 (erun fc $ psolve lhs_tm)

874 tt <- get_term

875 let (tm, ds) = runState (collectDeferred (Just fname) tt) []

@@ -897,10 +897,10 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

897 checkInferred fc (delab' i crhs True) rhs

898 return $ Right (clhs, crhs)

899 where

900− decorate (NS x ns)

900+ decorate (NS x ns)

901− = NS (SN (WhereN cnum fname x)) ns -- ++ [show cnum])

901+ = NS (SN (WhereN cnum fname x)) ns -- ++ [show cnum])

902-- = NS (UN ('#':show x)) (ns ++ [show cnum, show fname])

903− decorate x

903+ decorate x

904 = SN (WhereN cnum fname x)

905-- = NS (SN (WhereN cnum fname x)) [show cnum]

906-- = NS (UN ('#':show x)) [show cnum, show fname]

@@ -909,18 +909,18 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

909 sepBlocks' ns (d@(PTy _ _ _ _ n t) : bs)

910 = let (bf, af) = sepBlocks' (n : ns) bs in

911 (d : bf, af)

912− sepBlocks' ns (d@(PClauses _ _ n _) : bs)

912+ sepBlocks' ns (d@(PClauses _ _ n _) : bs)

913 | not (n `elem` ns) = let (bf, af) = sepBlocks' ns bs in

914 (bf, d : af)

915 sepBlocks' ns (b : bs) = let (bf, af) = sepBlocks' ns bs in

916 (b : bf, af)

917 sepBlocks' ns [] = ([], [])

918

919− pinfo ns ps i

919+ pinfo ns ps i

920 = let ds = concatMap declared ps

921 newps = params info ++ ns

922 dsParams = map (\n -> (n, map fst newps)) ds

923− newb = addAlist dsParams (inblock info)

923+ newb = addAlist dsParams (inblock info)

924 l = liftname info in

925 info { params = newps,

926 inblock = newb,

@@ -929,24 +929,24 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

929 -- _ -> MN i (show n)) . l

930 }

931

932− getParamsInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)

932+ getParamsInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)

933 = getParamsInType i env is (instantiate (P Bound n t) sc)

934− getParamsInType i env (_ : is) (Bind n (Pi t) sc)

934+ getParamsInType i env (_ : is) (Bind n (Pi t) sc)

935 = getParamsInType i (n : env) is (instantiate (P Bound n t) sc)

936 getParamsInType i env is tm@(App f a)

937− | (P _ tn _, args) <- unApply tm

937+ | (P _ tn _, args) <- unApply tm

938 = case lookupCtxt tn (idris_datatypes i) of

939 [t] -> nub $ paramNames args env (param_pos t) ++

940− getParamsInType i env is f ++

940+ getParamsInType i env is f ++

941 getParamsInType i env is a

942− [] -> nub $ getParamsInType i env is f ++

942+ [] -> nub $ getParamsInType i env is f ++

943 getParamsInType i env is a

944− | otherwise = nub $ getParamsInType i env is f ++

944+ | otherwise = nub $ getParamsInType i env is f ++

945 getParamsInType i env is a

946 getParamsInType i _ _ _ = []

947

948 paramNames args env [] = []

949− paramNames args env (p : ps)

949+ paramNames args env (p : ps)

950 | length args > p = case args!!p of

951 P _ n _ -> if n `elem` env

952 then n : paramNames args env ps

@@ -964,7 +964,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

964 = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)

965 propagateParams ps x = x

966

967−elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

967+elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

968 = do let tcgen = Dictionary `elem` opts

969 ctxt <- getContext

970 -- Build the LHS as an "Infer", and pull out its type and

@@ -972,7 +972,7 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

972 i <- getIState

973 let lhs = addImplPat i lhs_in

974 logLvl 5 ("LHS: " ++ showImp Nothing True False lhs)

975− ((lhs', dlhs, []), _) <-

975+ ((lhs', dlhs, []), _) <-

976 tclift $ elaborate ctxt (MN 0 "patLHS") infP []

977 (errAt "left hand side of with in " fname

978 (erun fc (buildTC i info True tcgen fname (infTerm lhs))) )

@@ -986,12 +986,12 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

986 let wval = addImplBound i (map fst bargs) wval_in

987 logLvl 5 ("Checking " ++ showImp Nothing True False wval)

988 -- Elaborate wval in this context

989− ((wval', defer, is), _) <-

989+ ((wval', defer, is), _) <-

990− tclift $ elaborate ctxt (MN 0 "withRHS")

990+ tclift $ elaborate ctxt (MN 0 "withRHS")

991 (bindTyArgs PVTy bargs infP) []

992 (do pbinds lhs_tm

993 -- TODO: may want where here - see winfo abpve

994− (_', d, is) <- errAt "with value in " fname

994+ (_', d, is) <- errAt "with value in " fname

995 (erun fc (build i info False fname (infTerm wval)))

996 erun fc $ psolve lhs_tm

997 tt <- get_term

@@ -1008,18 +1008,18 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1008 -- rather than a de Bruijn index.

1009 let pdeps = usedNamesIn pvars i (delab i cwvalty)

1010 let (bargs_pre, bargs_post) = split pdeps bargs []

1011− logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

1011+ logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

1012 " depends on " ++ show pdeps ++ " from " ++ show pvars)

1013 logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)

1014 windex <- getName

1015 -- build a type declaration for the new function:

1016− -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty

1016+ -- (ps : Xs) -> (withval : cwvalty) -> (ps' : Xs') -> ret_ty

1017 let wargval = getRetTy cwvalN

1018 let wargtype = getRetTy cwvaltyN

1019 logLvl 5 ("Abstract over " ++ show wargval)

1020− let wtype = bindTyArgs Pi (bargs_pre ++

1020+ let wtype = bindTyArgs Pi (bargs_pre ++

1021− (MN 0 "warg", wargtype) :

1021+ (MN 0 "warg", wargtype) :

1022− map (abstract (MN 0 "warg") wargval wargtype) bargs_post)

1022+ map (abstract (MN 0 "warg") wargval wargtype) bargs_post)

1023 (substTerm wargval (P Bound (MN 0 "warg") wargtype) ret_ty)

1024 logLvl 3 ("New function type " ++ show wtype)

1025 let wname = MN windex (show fname)

@@ -1041,8 +1041,8 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1041 mapM_ (elabDecl EAll info) wb

1042

1043 -- rhs becomes: fname' ps wval

1044− let rhs = PApp fc (PRef fc wname)

1044+ let rhs = PApp fc (PRef fc wname)

1045− (map (pexp . (PRef fc) . fst) bargs_pre ++

1045+ (map (pexp . (PRef fc) . fst) bargs_pre ++

1046 pexp wval :

1047 (map (pexp . (PRef fc) . fst) bargs_post))

1048 logLvl 5 ("New RHS " ++ showImp Nothing True False rhs)

@@ -1074,25 +1074,25 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1074 mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)

1075 = do i <- getIState

1076 let tm = addImplPat i tm_in

1077− logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++

1077+ logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++

1078 showImp Nothing True False toplhs)

1079 case matchClause i toplhs tm of

1080 Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ ":with clause does not match top level")

1081− Right mvars ->

1081+ Right mvars ->

1082 do logLvl 3 ("Match vars : " ++ show mvars)

1083 lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

1084 return $ PClause fc wname lhs ws rhs wheres

1085 mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs)

1086 = do i <- getIState

1087 let tm = addImplPat i tm_in

1088− logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++

1088+ logLvl 2 ("Matching " ++ showImp Nothing True False tm ++ " against " ++

1089 showImp Nothing True False toplhs)

1090 withs' <- mapM (mkAuxC wname toplhs ns ns') withs

1091 case matchClause i toplhs tm of

1092 Left (a,b) -> trace ("matchClause: " ++ show a ++ " =/= " ++ show b) (ifail $ show fc ++ "with clause does not match top level")

1093− Right mvars ->

1093+ Right mvars ->

1094 do lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

1095− return $ PWith fc wname lhs ws wval withs'

1095+ return $ PWith fc wname lhs ws wval withs'

1096 mkAux wname toplhs ns ns' c

1097 = ifail $ show fc ++ "badly formed with clause"

1098

@@ -1102,11 +1102,11 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1102 updateLHS n wname mvars ns_in ns_in' (PApp fc (PRef fc' n') args) w

1103 = let ns = map (keepMvar (map fst mvars) fc') ns_in

1104 ns' = map (keepMvar (map fst mvars) fc') ns_in' in

1105− return $ substMatches mvars $

1105+ return $ substMatches mvars $

1106− PApp fc (PRef fc' wname)

1106+ PApp fc (PRef fc' wname)

1107 (map pexp ns ++ pexp w : (map pexp ns'))

1108− updateLHS n wname mvars ns ns' tm w

1108+ updateLHS n wname mvars ns ns' tm w

1109− = ifail $ "Not implemented match " ++ show tm

1109+ = ifail $ "Not implemented match " ++ show tm

1110

1111 keepMvar mvs fc v | v `elem` mvs = PRef fc v

1112 | otherwise = Placeholder

@@ -1118,16 +1118,16 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

1118 split deps ((n, ty) : rest) pre

1119 | n `elem` deps = split (deps \\ [n]) rest ((n, ty) : pre)

1120 | otherwise = split deps rest ((n, ty) : pre)

1121− split deps [] pre = (reverse pre, [])

1121+ split deps [] pre = (reverse pre, [])

1122

1123 abstract wn wv wty (n, argty) = (n, substTerm wv (P Bound wn wty) argty)

1124

1125data MArgTy = IA | EA | CA deriving Show

1126

1127elabClass :: ElabInfo -> SyntaxInfo -> String ->

1128− FC -> [PTerm] ->

1128+ FC -> [PTerm] ->

1129 Name -> [(Name, PTerm)] -> [PDecl] -> Idris ()

1130−elabClass info syn doc fc constraints tn ps ds

1130+elabClass info syn doc fc constraints tn ps ds

1131 = do let cn = UN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)

1132 let tty = pibind ps PType

1133 let constraint = PApp fc (PRef fc tn)

@@ -1137,20 +1137,20 @@ elabClass info syn doc fc constraints tn ps ds

1137 let mnames = map getMName mdecls

1138 logLvl 2 $ "Building methods " ++ show mnames

1139 ims <- mapM (tdecl mnames) mdecls

1140− defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)

1140+ defs <- mapM (defdecl (map (\ (x,y,z) -> z) ims) constraint)

1141 (filter clause ds)

1142− let (methods, imethods)

1142+ let (methods, imethods)

1143 = unzip (map (\ ( x,y,z) -> (x, y)) ims)

1144 let defaults = map (\ (x, (y, z)) -> (x,y)) defs

1145− addClass tn (CI cn (map nodoc imethods) defaults (map fst ps) [])

1145+ addClass tn (CI cn (map nodoc imethods) defaults (map fst ps) [])

1146 -- build instance constructor type

1147 -- decorate names of functions to ensure they can't be referred

1148 -- to elsewhere in the class declaration

1149 -- TODO: Remove mdec to make it a dependent record, which would

1150 -- allow dependent type classes, but building instances will

1151 -- then need some attention.

1152− let cty = impbind ps $ conbind constraints

1152+ let cty = impbind ps $ conbind constraints

1153− $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods)

1153+ $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods)

1154 constraint

1155 let cons = [("", cn, cty, fc)]

1156 let ddecl = PDatadecl tn tty cons

@@ -1158,7 +1158,7 @@ elabClass info syn doc fc constraints tn ps ds

1158 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc False ddecl

1159 -- for each constraint, build a top level function to chase it

1160 logLvl 5 $ "Building functions"

1161− let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps

1161+ let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps

1162 ++ using syn }

1163 fns <- mapM (cfun cn constraint usyn (map fst imethods)) constraints

1164 mapM_ (elabDecl EAll info) (concat fns)

@@ -1172,19 +1172,19 @@ elabClass info syn doc fc constraints tn ps ds

1172 where

1173 nodoc (n, (_, o, t)) = (n, (o, t))

1174 pibind [] x = x

1175− pibind ((n, ty): ns) x = PPi expl n ty (pibind ns x)

1175+ pibind ((n, ty): ns) x = PPi expl n ty (pibind ns x)

1176

1177 mdec (UN n) = SN (MethodN (UN n))

1178 mdec (NS x n) = NS (mdec x) n

1179 mdec x = x

1180

1181 impbind [] x = x

1182− impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x)

1182+ impbind ((n, ty): ns) x = PPi impl n ty (impbind ns x)

1183 conbind (ty : ns) x = PPi constraint (MN 0 "class") ty (conbind ns x)

1184 conbind [] x = x

1185

1186 getMName (PTy _ _ _ _ n _) = nsroot n

1187− tdecl allmeths (PTy doc syn _ o n t)

1187+ tdecl allmeths (PTy doc syn _ o n t)

1188 = do t' <- implicit' syn allmeths n t

1189 logLvl 5 $ "Method " ++ show n ++ " : " ++ showImp Nothing True False t'

1190 return ( (n, (toExp (map fst ps) Exp t')),

@@ -1192,12 +1192,12 @@ elabClass info syn doc fc constraints tn ps ds

1192 (n, (syn, o, t) ) )

1193 tdecl _ _ = ifail "Not allowed in a class declaration"

1194

1195− -- Create default definitions

1195+ -- Create default definitions

1196 defdecl mtys c d@(PClauses fc opts n cs) =

1197 case lookup n mtys of

1198 Just (syn, o, ty) -> do let ty' = insertConstraint c ty

1199 let ds = map (decorateid defaultdec)

1200− [PTy "" syn fc [] n ty',

1200+ [PTy "" syn fc [] n ty',

1201 PClauses fc (o ++ opts) n cs]

1202 iLOG (show ds)

1203 return (n, ((defaultdec n, ds!!1), ds))

@@ -1214,7 +1214,7 @@ elabClass info syn doc fc constraints tn ps ds

1214

1215 -- Generate a function for chasing a dictionary constraint

1216 cfun cn c syn all con

1217− = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con)

1217+ = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con)

1218 -- SN (ParentN cn (show con))

1219 let mnames = take (length all) $ map (\x -> MN x "meth") [0..]

1220 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

@@ -1238,7 +1238,7 @@ elabClass info syn doc fc constraints tn ps ds

1238

1239 -- Generate a top level function which looks up a method in a given

1240 -- dictionary (this is inlinable, always)

1241− tfun cn c syn all (m, (doc, o, ty))

1241+ tfun cn c syn all (m, (doc, o, ty))

1242 = do let ty' = insertConstraint c ty

1243 let mnames = take (length all) $ map (\x -> MN x "meth") [0..]

1244 let capp = PApp fc (PRef fc cn) (map (pexp . PRef fc) mnames)

@@ -1260,13 +1260,13 @@ elabClass info syn doc fc constraints tn ps ds

1260 getMeth (m:ms) (a:as) x | x == a = PRef fc m

1261 | otherwise = getMeth ms as x

1262

1263− lhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : lhsArgs xs ns

1263+ lhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : lhsArgs xs ns

1264− lhsArgs (IA : xs) ns = lhsArgs xs ns

1264+ lhsArgs (IA : xs) ns = lhsArgs xs ns

1265 lhsArgs (CA : xs) ns = lhsArgs xs ns

1266 lhsArgs [] _ = []

1267

1268− rhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : rhsArgs xs ns

1268+ rhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : rhsArgs xs ns

1269− rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns

1269+ rhsArgs (IA : xs) ns = pexp Placeholder : rhsArgs xs ns

1270 rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns

1271 rhsArgs [] _ = []

1272

@@ -1281,43 +1281,43 @@ elabClass info syn doc fc constraints tn ps ds

1281 toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

1282 toExp ns e sc = sc

1283

1284−elabInstance :: ElabInfo -> SyntaxInfo ->

1284+elabInstance :: ElabInfo -> SyntaxInfo ->

1285 FC -> [PTerm] -> -- constraints

1286− Name -> -- the class

1286+ Name -> -- the class

1287− [PTerm] -> -- class parameters (i.e. instance)

1287+ [PTerm] -> -- class parameters (i.e. instance)

1288 PTerm -> -- full instance type

1289 Maybe Name -> -- explicit name

1290 [PDecl] -> Idris ()

1291elabInstance info syn fc cs n ps t expn ds

1292− = do i <- getIState

1292+ = do i <- getIState

1293 (n, ci) <- case lookupCtxtName n (idris_classes i) of

1294 [c] -> return c

1295 _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

1296 let constraint = PApp fc (PRef fc n) (map pexp ps)

1297 let iname = case expn of

1298− Nothing -> SN (InstanceN n (map show ps))

1298+ Nothing -> SN (InstanceN n (map show ps))

1299 -- UN ('@':show n ++ "$" ++ show ps)

1300 Just nm -> nm

1301 -- if the instance type matches any of the instances we have already,

1302 -- and it's not a named instance, then it's overlapping, so report an error

1303 case expn of

1304− Nothing -> do mapM_ (checkNotOverlapping i t) (class_instances ci)

1304+ Nothing -> do mapM_ (checkNotOverlapping i t) (class_instances ci)

1305 addInstance intInst n iname

1306− Just _ -> addInstance intInst n iname

1306+ Just _ -> addInstance intInst n iname

1307 elabType info syn "" fc [] iname t

1308 let ips = zip (class_params ci) ps

1309 let ns = case n of

1310 NS n ns' -> ns'

1311 _ -> []

1312− -- get the implicit parameters that need passing through to the

1312+ -- get the implicit parameters that need passing through to the

1313 -- where block

1314 wparams <- mapM (\p -> case p of

1315 PApp _ _ args -> getWParams args

1316 _ -> return []) ps

1317 let pnames = map pname (concat (nub wparams))

1318− let mtys = map (\ (n, (op, t)) ->

1318+ let mtys = map (\ (n, (op, t)) ->

1319 let t' = substMatchesShadow ips pnames t in

1320− (decorate ns iname n,

1320+ (decorate ns iname n,

1321 op, coninsert cs t', t'))

1322 (class_methods ci)

1323 logLvl 3 (show (mtys, ips))

@@ -1329,12 +1329,12 @@ elabInstance info syn fc cs n ps t expn ds

1329 let wbVals = map (decorateid (decorate ns iname)) ds'

1330 let wb = wbTys ++ wbVals

1331 logLvl 3 $ "Method types " ++ showSep "\n" (map (showDeclImp True . mkTyDecl) mtys)

1332− logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++

1332+ logLvl 3 $ "Instance is " ++ show ps ++ " implicits " ++

1333 show (concat (nub wparams))

1334 let lhs = PRef fc iname

1335 let rhs = PApp fc (PRef fc (instanceName ci))

1336 (map (pexp . mkMethApp) mtys)

1337− let idecls = [PClauses fc [Dictionary] iname

1337+ let idecls = [PClauses fc [Dictionary] iname

1338 [PClause fc iname lhs [] rhs wb]]

1339 iLOG (show idecls)

1340 mapM (elabDecl EAll info) idecls

@@ -1360,23 +1360,23 @@ elabInstance info syn fc cs n ps t expn ds

1360 Right _ -> overlapping tret tret'

1361 Left _ -> return ()

1362 _ -> return ()

1363− overlapping t t' = tclift $ tfail (At fc (Msg $

1363+ overlapping t t' = tclift $ tfail (At fc (Msg $

1364 "Overlapping instance: " ++ show t' ++ " already defined"))

1365 getRetType (PPi _ _ _ sc) = getRetType sc

1366 getRetType t = t

1367

1368− mkMethApp (n, _, _, ty)

1368+ mkMethApp (n, _, _, ty)

1369 = lamBind 0 ty (papp fc (PRef fc n) (methArgs 0 ty))

1370− lamBind i (PPi (Constraint _ _ _) _ _ sc) sc'

1370+ lamBind i (PPi (Constraint _ _ _) _ _ sc) sc'

1371 = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')

1372− lamBind i (PPi _ n ty sc) sc'

1372+ lamBind i (PPi _ n ty sc) sc'

1373 = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')

1374 lamBind i _ sc = sc

1375− methArgs i (PPi (Imp _ _ _ _) n ty sc)

1375+ methArgs i (PPi (Imp _ _ _ _) n ty sc)

1376 = PImp 0 True False n (PRef fc (MN i "meth")) "" : methArgs (i+1) sc

1377− methArgs i (PPi (Exp _ _ _ _) n ty sc)

1377+ methArgs i (PPi (Exp _ _ _ _) n ty sc)

1378 = PExp 0 False (PRef fc (MN i "meth")) "" : methArgs (i+1) sc

1379− methArgs i (PPi (Constraint _ _ _) n ty sc)

1379+ methArgs i (PPi (Constraint _ _ _) n ty sc)

1380 = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc

1381 methArgs i _ = []

1382

@@ -1384,8 +1384,8 @@ elabInstance info syn fc cs n ps t expn ds

1384 papp fc f as = PApp fc f as

1385

1386 getWParams [] = return []

1387− getWParams (p : ps)

1387+ getWParams (p : ps)

1388− | PRef _ n <- getTm p

1388+ | PRef _ n <- getTm p

1389 = do ps' <- getWParams ps

1390 ctxt <- getContext

1391 case lookupP n ctxt of

@@ -1405,16 +1405,16 @@ elabInstance info syn fc cs n ps t expn ds

1405 coninsert cs sc = conbind cs sc

1406

1407 insertDefaults :: IState -> Name ->

1408− [(Name, (Name, PDecl))] -> [String] ->

1408+ [(Name, (Name, PDecl))] -> [String] ->

1409 [PDecl] -> [PDecl]

1410 insertDefaults i iname [] ns ds = ds

1411− insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds

1411+ insertDefaults i iname ((n,(dn, clauses)) : defs) ns ds

1412 = insertDefaults i iname defs ns (insertDef i n dn clauses ns iname ds)

1413

1414 insertDef i meth def clauses ns iname decls

1415 | null $ filter (clauseFor meth iname ns) decls

1416 = let newd = expandParamsD False i (\n -> meth) [] [def] clauses in

1417− -- trace (show newd) $

1417+ -- trace (show newd) $

1418 decls ++ [newd]

1419 | otherwise = decls

1420

@@ -1425,12 +1425,12 @@ elabInstance info syn fc cs n ps t expn ds

1425

1426 checkInClass ns meth

1427 | not (null (filter (eqRoot meth) ns)) = return ()

1428− | otherwise = tclift $ tfail (At fc (Msg $

1428+ | otherwise = tclift $ tfail (At fc (Msg $

1429 show meth ++ " not a method of class " ++ show n))

1430

1431 eqRoot x y = nsroot x == nsroot y

1432

1433− clauseFor m iname ns (PClauses _ _ m' _)

1433+ clauseFor m iname ns (PClauses _ _ m' _)

1434 = decorate ns iname m == decorate ns iname m'

1435 clauseFor m iname ns _ = False

1436

@@ -1460,17 +1460,17 @@ elabInstance info syn fc cs n ps t expn ds

1460-}

1461

1462decorateid decorate (PTy doc s f o n t) = PTy doc s f o (decorate n) t

1463−decorateid decorate (PClauses f o n cs)

1463+decorateid decorate (PClauses f o n cs)

1464 = PClauses f o (decorate n) (map dc cs)

1465 where dc (PClause fc n t as w ds) = PClause fc (decorate n) (dappname t) as w ds

1466− dc (PWith fc n t as w ds)

1466+ dc (PWith fc n t as w ds)

1467− = PWith fc (decorate n) (dappname t) as w

1467+ = PWith fc (decorate n) (dappname t) as w

1468 (map (decorateid decorate) ds)

1469 dappname (PApp fc (PRef fc' n) as) = PApp fc (PRef fc' (decorate n)) as

1470 dappname t = t

1471

1472

1473−pbinds (Bind n (PVar t) sc) = do attack; patbind n

1473+pbinds (Bind n (PVar t) sc) = do attack; patbind n

1474 pbinds sc

1475pbinds tm = return ()

1476

@@ -1495,8 +1495,8 @@ elabDecls info ds = do mapM_ (elabDecl EAll info) ds

1495-- mapM_ (elabDecl EDefns info) ds

1496

1497elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris ()

1498−elabDecl what info d

1498+elabDecl what info d

1499− = idrisCatch (elabDecl' what info d)

1499+ = idrisCatch (elabDecl' what info d)

1500 (\e -> do setErrLine (getErrLine e)

1501 ist <- getIState

1502 let h = idris_outh ist

@@ -1504,24 +1504,24 @@ elabDecl what info d

1504

1505elabDecl' _ info (PFix _ _ _)

1506 = return () -- nothing to elaborate

1507−elabDecl' _ info (PSyntax _ p)

1507+elabDecl' _ info (PSyntax _ p)

1508 = return () -- nothing to elaborate

1509−elabDecl' what info (PTy doc s f o n ty)

1509+elabDecl' what info (PTy doc s f o n ty)

1510 | what /= EDefns

1511 = do iLOG $ "Elaborating type decl " ++ show n ++ show o

1512 elabType info s doc f o n ty

1513−elabDecl' what info (PPostulate doc s f o n ty)

1513+elabDecl' what info (PPostulate doc s f o n ty)

1514 | what /= EDefns

1515 = do iLOG $ "Elaborating postulate " ++ show n ++ show o

1516 elabPostulate info s doc f o n ty

1517−elabDecl' what info (PData doc s f co d)

1517+elabDecl' what info (PData doc s f co d)

1518 | what /= ETypes

1519 = do iLOG $ "Elaborating " ++ show (d_name d)

1520 elabData info s doc f co d

1521− | otherwise

1521+ | otherwise

1522 = do iLOG $ "Elaborating [type of] " ++ show (d_name d)

1523 elabData info s doc f co (PLaterdecl (d_name d) (d_tcon d))

1524−elabDecl' what info d@(PClauses f o n ps)

1524+elabDecl' what info d@(PClauses f o n ps)

1525 | what /= ETypes

1526 = do iLOG $ "Elaborating clause " ++ show n

1527 i <- getIState -- get the type options too

@@ -1529,7 +1529,7 @@ elabDecl' what info d@(PClauses f o n ps)

1529 [fs] -> fs

1530 [] -> []

1531 elabClauses info f (o ++ o') n ps

1532−elabDecl' what info (PMutual f ps)

1532+elabDecl' what info (PMutual f ps)

1533 = do mapM_ (elabDecl ETypes info) ps

1534 mapM_ (elabDecl EDefns info) ps

1535 -- Do totality checking after entire mutual block

@@ -1541,32 +1541,32 @@ elabDecl' what info (PMutual f ps)

1541 mapM_ checkDeclTotality (idris_totcheck i)

1542 clear_totcheck

1543

1544−elabDecl' what info (PParams f ns ps)

1544+elabDecl' what info (PParams f ns ps)

1545 = do i <- getIState

1546 iLOG $ "Expanding params block with " ++ show ns ++ " decls " ++

1547 show (concatMap tldeclared ps)

1548 let nblock = pblock i

1549− mapM_ (elabDecl' what info) nblock

1549+ mapM_ (elabDecl' what info) nblock

1550 where

1551 pinfo = let ds = concatMap tldeclared ps

1552 newps = params info ++ ns

1553 dsParams = map (\n -> (n, map fst newps)) ds

1554− newb = addAlist dsParams (inblock info) in

1554+ newb = addAlist dsParams (inblock info) in

1555 info { params = newps,

1556 inblock = newb }

1557− pblock i = map (expandParamsD False i id ns

1557+ pblock i = map (expandParamsD False i id ns

1558 (concatMap tldeclared ps)) ps

1559

1560elabDecl' what info (PNamespace n ps) = mapM_ (elabDecl' what ninfo) ps

1561 where

1562 ninfo = case namespace info of

1563 Nothing -> info { namespace = Just [n] }

1564− Just ns -> info { namespace = Just (n:ns) }

1564+ Just ns -> info { namespace = Just (n:ns) }

1565−elabDecl' what info (PClass doc s f cs n ps ds)

1565+elabDecl' what info (PClass doc s f cs n ps ds)

1566 | what /= EDefns

1567 = do iLOG $ "Elaborating class " ++ show n

1568 elabClass info (s { syn_params = [] }) doc f cs n ps ds

1569−elabDecl' what info (PInstance s f cs n ps t expn ds)

1569+elabDecl' what info (PInstance s f cs n ps t expn ds)

1570 | what /= ETypes

1571 = do iLOG $ "Elaborating instance " ++ show n

1572 elabInstance info s f cs n ps t expn ds

@@ -1574,27 +1574,27 @@ elabDecl' what info (PRecord doc s f tyn ty cdoc cn cty)

1574 | what /= ETypes

1575 = do iLOG $ "Elaborating record " ++ show tyn

1576 elabRecord info s doc f tyn ty cdoc cn cty

1577− | otherwise

1577+ | otherwise

1578 = do iLOG $ "Elaborating [type of] " ++ show tyn

1579 elabData info s doc f False (PLaterdecl tyn ty)

1580elabDecl' _ info (PDSL n dsl)

1581 = do i <- getIState

1582− putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })

1582+ putIState (i { idris_dsls = addDef n dsl (idris_dsls i) })

1583 addIBC (IBCDSL n)

1584−elabDecl' what info (PDirective i)

1584+elabDecl' what info (PDirective i)

1585 | what /= EDefns = i

1586elabDecl' what info (PProvider syn fc n tp tm)

1587 | what /= EDefns

1588 = do iLOG $ "Elaborating type provider " ++ show n

1589 elabProvider info syn fc n tp tm

1590elabDecl' what info (PTransform fc safety old new)

1591− = elabTransform info fc safety old new

1591+ = elabTransform info fc safety old new

1592−elabDecl' _ _ _ = return () -- skipped this time

1592+elabDecl' _ _ _ = return () -- skipped this time

1593

1594−elabCaseBlock info opts d@(PClauses f o n ps)

1594+elabCaseBlock info opts d@(PClauses f o n ps)

1595 = do addIBC (IBCDef n)

1596 logLvl 6 $ "CASE BLOCK: " ++ show (n, d)

1597− elabDecl' EAll info (PClauses f (nub (o ++ opts)) n ps )

1597+ elabDecl' EAll info (PClauses f (nub (o ++ opts)) n ps )

1598

1599-- elabDecl' info (PImport i) = loadModule i

1600

@@ -1608,9 +1608,9 @@ checkInferred fc inf user =

1608 showImp Nothing True False user

1609 logLvl 10 $ "Checking match"

1610 i <- getIState

1611− tclift $ case matchClause' True i user inf of

1611+ tclift $ case matchClause' True i user inf of

1612 _ -> return ()

1613−-- Left (x, y) -> tfail $ At fc

1613+-- Left (x, y) -> tfail $ At fc

1614-- (Msg $ "The type-checked term and given term do not match: "

1615-- ++ show x ++ " and " ++ show y)

1616 logLvl 10 $ "Checked match"

@@ -1624,7 +1624,7 @@ inferredDiff fc inf user =

1624 do i <- getIState

1625 logLvl 6 $ "Checked to\n" ++ showImp Nothing True False inf ++ "\n" ++

1626 showImp Nothing True False user

1627− tclift $ case matchClause' True i user inf of

1627+ tclift $ case matchClause' True i user inf of

1628 Right vs -> return False

1629 Left (x, y) -> return True

1630

src/Idris/ElabTerm.hs+102−102

@@ -35,9 +35,9 @@ toplevel = EInfo [] emptyContext id Nothing

35

36-- Also find deferred names in the term and their types

37

38−build :: IState -> ElabInfo -> Bool -> Name -> PTerm ->

38+build :: IState -> ElabInfo -> Bool -> Name -> PTerm ->

39 ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])

40−build ist info pattern fn tm

40+build ist info pattern fn tm

41 = do elab ist info pattern False fn tm

42 ivs <- get_instances

43 hs <- get_holes

@@ -45,14 +45,14 @@ build ist info pattern fn tm

45 -- Resolve remaining type classes. Two passes - first to get the

46 -- default Num instances, second to clean up the rest

47 when (not pattern) $

48− mapM_ (\n -> when (n `elem` hs) $

48+ mapM_ (\n -> when (n `elem` hs) $

49 do focus n

50 try (resolveTC 7 fn ist)

51 (movelast n)) ivs

52 ivs <- get_instances

53 hs <- get_holes

54 when (not pattern) $

55− mapM_ (\n -> when (n `elem` hs) $

55+ mapM_ (\n -> when (n `elem` hs) $

56 do focus n

57 resolveTC 7 fn ist) ivs

58 tm <- get_term

@@ -73,9 +73,9 @@ build ist info pattern fn tm

73-- (Separate, so we don't go overboard resolving things that we don't

74-- know about yet on the LHS of a pattern def)

75

76−buildTC :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

76+buildTC :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

77 ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])

78−buildTC ist info pattern tcgen fn tm

78+buildTC ist info pattern tcgen fn tm

79 = do elab ist info pattern tcgen fn tm

80 probs <- get_probs

81 tm <- get_term

@@ -92,9 +92,9 @@ buildTC ist info pattern tcgen fn tm

92-- Returns the set of declarations we need to add to complete the definition

93-- (most likely case blocks to elaborate)

94

95−elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

95+elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

96 ElabD ()

97−elab ist info pattern tcgen fn tm

97+elab ist info pattern tcgen fn tm

98 = do let loglvl = opt_logLevel (idris_options ist)

99 when (loglvl > 5) $ unifyLog True

100 compute -- expand type synonyms, etc

@@ -125,15 +125,15 @@ elab ist info pattern tcgen fn tm

125

126 elabE ina t = {- do g <- goal

127 tm <- get_term

128− trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm)

128+ trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm)

129− $ -}

129+ $ -}

130 do t' <- insertCoerce ina t

131 g <- goal

132 tm <- get_term

133 ps <- get_probs

134 hs <- get_holes

135-- trace ("Elaborating " ++ show t' ++ " in " ++ show g

136−-- -- ++ "\n" ++ show tm

136+-- -- ++ "\n" ++ show tm

137-- ++ "\nholes " ++ show hs

138-- ++ "\nproblems " ++ show ps

139-- ++ "\n-----------\n") $

@@ -151,22 +151,22 @@ elab ist info pattern tcgen fn tm

151 elab' ina (PFalse fc) = elab' ina (PRef fc falseTy)

152 elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

153 = resolveTC 5 fn ist

154− elab' ina (PResolveTC fc)

154+ elab' ina (PResolveTC fc)

155 | True = do c <- unique_hole (MN 0 "class")

156 instanceArg c

157 | otherwise = do g <- goal

158 try (resolveTC 2 fn ist)

159 (do c <- unique_hole (MN 0 "class")

160 instanceArg c)

161− elab' ina (PRefl fc t)

161+ elab' ina (PRefl fc t)

162 = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder True,

163 pimp (MN 0 "x") t False])

164− elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy)

164+ elab' ina (PEq fc l r) = elab' ina (PApp fc (PRef fc eqTy)

165 [pimp (MN 0 "a") Placeholder True,

166 pimp (MN 0 "b") Placeholder False,

167 pexp l, pexp r])

168− elab' ina@(_, a) (PPair fc l r)

168+ elab' ina@(_, a) (PPair fc l r)

169− = do hnf_compute

169+ = do hnf_compute

170 g <- goal

171 case g of

172 TType _ -> elabE (True, a) (PApp fc (PRef fc pairTy)

@@ -176,8 +176,8 @@ elab ist info pattern tcgen fn tm

176 pimp (MN 0 "B") Placeholder True,

177 pexp l, pexp r])

178 elab' ina (PDPair fc l@(PRef _ n) t r)

179− = case t of

179+ = case t of

180− Placeholder ->

180+ Placeholder ->

181 do hnf_compute

182 g <- goal

183 case g of

@@ -195,7 +195,7 @@ elab ist info pattern tcgen fn tm

195 [pimp (MN 0 "a") t False,

196 pimp (MN 0 "P") Placeholder True,

197 pexp l, pexp r])

198− elab' ina (PAlternative True as)

198+ elab' ina (PAlternative True as)

199 = do hnf_compute

200 ty <- goal

201 ctxt <- get_context

@@ -207,13 +207,13 @@ elab ist info pattern tcgen fn tm

207 tryAll (zip (map (elab' ina) as') (map showHd as'))

208 where showHd (PApp _ h _) = show h

209 showHd x = show x

210− elab' ina (PAlternative False as)

210+ elab' ina (PAlternative False as)

211 = trySeq as

212 where -- if none work, take the error from the first

213 trySeq (x : xs) = let e1 = elab' ina x in

214 try' e1 (trySeq' e1 xs) True

215 trySeq' deferr [] = proofFail deferr

216− trySeq' deferr (x : xs)

216+ trySeq' deferr (x : xs)

217 = try' (elab' ina x) (trySeq' deferr xs) True

218 elab' ina (PPatvar fc n) | pattern = patvar n

219 elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n)

@@ -239,8 +239,8 @@ elab ist info pattern tcgen fn tm

239 ptm <- get_term

240 g <- goal

241 checkPiGoal n

242− attack; intro (Just n);

242+ attack; intro (Just n);

243− -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

243+ -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

244 elabE (True, a) sc; solve

245 where repN n n' (PRef fc x) | x == n' = PRef fc n'

246 repN _ _ t = t

@@ -254,7 +254,7 @@ elab ist info pattern tcgen fn tm

254 ptm <- get_term

255 hs <- get_holes

256 -- trace ("BEFORE:\n" ++ show hsin ++ "\n" ++ show ptmin ++

257− -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $

257+ -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $

258 introTy (Var tyn) (Just n)

259 -- end_unify

260 focus tyn

@@ -265,10 +265,10 @@ elab ist info pattern tcgen fn tm

265 solve

266 elab' ina@(_,a) (PPi _ n Placeholder sc)

267 = do attack; arg n (MN 0 "ty"); elabE (True, a) sc; solve

268− elab' ina@(_,a) (PPi _ n ty sc)

268+ elab' ina@(_,a) (PPi _ n ty sc)

269 = do attack; tyn <- unique_hole (MN 0 "ty")

270 claim tyn RType

271− n' <- case n of

271+ n' <- case n of

272 MN _ _ -> unique_hole n

273 _ -> return n

274 forall n' (Var tyn)

@@ -310,8 +310,8 @@ elab ist info pattern tcgen fn tm

310 computeLet n

311 elabE (True, a) sc

312 solve

313−-- elab' ina (PLet n Placeholder

313+-- elab' ina (PLet n Placeholder

314−-- (PApp fc r [pexp (delab ist rty)]) sc)

314+-- (PApp fc r [pexp (delab ist rty)]) sc)

315 elab' ina tm@(PApp fc (PInferRef _ f) args) = do

316 rty <- goal

317 ds <- get_deferred

@@ -330,10 +330,10 @@ elab ist info pattern tcgen fn tm

330 mapM_ elabIArg (zip argTys args)

331 where claimArgTys env [] = return []

332 claimArgTys env (arg : xs) | Just n <- localVar env (getTm arg)

333− = do nty <- get_type (Var n)

333+ = do nty <- get_type (Var n)

334 ans <- claimArgTys env xs

335 return ((n, (False, forget nty)) : ans)

336− claimArgTys env (_ : xs)

336+ claimArgTys env (_ : xs)

337 = do an <- unique_hole (MN 0 "inf_argTy")

338 aval <- unique_hole (MN 0 "inf_arg")

339 claim an RType

@@ -343,15 +343,15 @@ elab ist info pattern tcgen fn tm

343 fnTy [] ret = forget ret

344 fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi xt) (fnTy xs ret)

345

346− localVar env (PRef _ x)

346+ localVar env (PRef _ x)

347 = case lookup x env of

348 Just _ -> Just x

349 _ -> Nothing

350 localVar env _ = Nothing

351

352− elabIArg ((n, (True, ty)), def) = do focus n; elabE ina (getTm def)

352+ elabIArg ((n, (True, ty)), def) = do focus n; elabE ina (getTm def)

353 elabIArg _ = return () -- already done, just a name

354−

354+

355 mkN n@(NS _ _) = n

356 mkN n@(SN _) = n

357 mkN n = case namespace info of

@@ -365,7 +365,7 @@ elab ist info pattern tcgen fn tm

365 ns <- match_apply (Var fn') (map (\x -> (x,0)) imps)

366 solve

367 -- if f is local, just do a simple_app

368− elab' (ina, g) tm@(PApp fc (PRef _ f) args')

368+ elab' (ina, g) tm@(PApp fc (PRef _ f) args')

369 = do let args = {- case lookupCtxt f (inblock info) of

370 Just ps -> (map (pexp . (PRef fc)) ps ++ args')

371 _ -> -} args'

@@ -373,11 +373,11 @@ elab ist info pattern tcgen fn tm

373 env <- get_env

374 if (f `elem` map fst env && length args' == 1)

375 then -- simple app, as below

376− do simple_app (elabE (ina, g) (PRef fc f))

376+ do simple_app (elabE (ina, g) (PRef fc f))

377 (elabE (True, g) (getTm (head args')))

378 (show tm)

379 solve

380− else

380+ else

381 do ivs <- get_instances

382 ps <- get_probs

383 -- HACK: we shouldn't resolve type classes if we're defining an instance

@@ -394,8 +394,8 @@ elab ist info pattern tcgen fn tm

394 ptm <- get_term

395 g <- goal

396 -- Sort so that the implicit tactics go last

397− let (ns', eargs) = unzip $

397+ let (ns', eargs) = unzip $

398− sortBy (\(_,x) (_,y) ->

398+ sortBy (\(_,x) (_,y) ->

399 compare (priority x) (priority y))

400 (zip ns args)

401 elabArgs (ina || not isinf, guarded)

@@ -416,7 +416,7 @@ elab ist info pattern tcgen fn tm

416 -- let insts = filter tcname $ map fst (ctxtAlist (tt_ctxt ist))

417 then try (resolveTC 7 fn ist)

418 (movelast n)

419− else movelast n)

419+ else movelast n)

420 (ivs' \\ ivs)

421 where tcArg (n, PConstraint _ _ Placeholder _) = True

422 tcArg _ = False

@@ -430,7 +430,7 @@ elab ist info pattern tcgen fn tm

430 setInjective _ = return ()

431

432 elab' ina@(_, a) tm@(PApp fc f [arg])

433− = erun fc $

433+ = erun fc $

434 do simple_app (elabE ina f) (elabE (True, a) (getTm arg))

435 (show tm)

436 solve

@@ -443,18 +443,18 @@ elab ist info pattern tcgen fn tm

443 Just xs@(_:_) -> NS n xs

444 _ -> n

445 elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts

446− elab' ina (PTactics ts)

446+ elab' ina (PTactics ts)

447 | not pattern = do mapM_ (runTac False ist) ts

448 | otherwise = elab' ina Placeholder

449 elab' ina (PElabError e) = fail (pshow ist e)

450− elab' ina (PRewrite fc r sc newg)

450+ elab' ina (PRewrite fc r sc newg)

451 = do attack

452 tyn <- unique_hole (MN 0 "rty")

453 claim tyn RType

454 valn <- unique_hole (MN 0 "rval")

455 claim valn (Var tyn)

456 letn <- unique_hole (MN 0 "rewrite_rule")

457− letbind letn (Var tyn) (Var valn)

457+ letbind letn (Var tyn) (Var valn)

458 focus valn

459 elab' ina r

460 compute

@@ -494,7 +494,7 @@ elab ist info pattern tcgen fn tm

494 cname <- unique_hole' True (mkCaseName fn)

495 let cname' = mkN cname

496 elab' ina (PMetavar cname')

497− let newdef = PClauses fc [] cname'

497+ let newdef = PClauses fc [] cname'

498 (caseBlock fc cname' (reverse args) opts)

499 -- elaborate case

500 env <- get_env

@@ -506,7 +506,7 @@ elab ist info pattern tcgen fn tm

506 mkCaseName n = SN (CaseN n)

507-- mkCaseName (UN x) = UN (x ++ "_case")

508-- mkCaseName (MN i x) = MN i (x ++ "_case")

509−-- mkCaseName (SN s) =

509+-- mkCaseName (SN s) =

510 mkN n@(NS _ _) = n

511 mkN n = case namespace info of

512 Just xs@(_:_) -> NS n xs

@@ -516,16 +516,16 @@ elab ist info pattern tcgen fn tm

516 unifyLog False

517 elab' ina x = fail $ "Unelaboratable syntactic form " ++ show x

518

519− caseBlock :: FC -> Name -> [(Name, Binder Term)] ->

519+ caseBlock :: FC -> Name -> [(Name, Binder Term)] ->

520 [(PTerm, PTerm)] -> [PClause]

521− caseBlock fc n env opts

521+ caseBlock fc n env opts

522 = let args = map mkarg (map fst (init env)) in

523 map (mkClause args) opts

524 where -- mkarg (MN _ _) = Placeholder

525 mkarg n = PRef fc n

526 -- may be shadowed names in the new pattern - so replace the

527 -- old ones with an _

528− mkClause args (l, r)

528+ mkClause args (l, r)

529 = let args' = map (shadowed (allNamesIn l)) args

530 lhs = PApp (getFC fc l) (PRef (getFC fc l) n)

531 (map pexp args' ++ [pexp l]) in

@@ -552,7 +552,7 @@ elab ist info pattern tcgen fn tm

552 (_, cs) -> PAlternative False [t ,

553 PAlternative True (map (mkCoerce t) cs)]

554 return t'

555− where

555+ where

556 mkCoerce t n = let fc = fileFC "Coercion" in -- line never appears!

557 addImpl ist (PApp fc (PRef fc n) [pexp (PCoerced t)])

558

@@ -560,18 +560,18 @@ elab ist info pattern tcgen fn tm

560-- | retry = let (ns, ts) = unzip (reverse failed) in

561-- elabArgs ina [] False ns ts

562 | otherwise = return ()

563− elabArgs ina failed fc r (n:ns) ((_, Placeholder) : args)

563+ elabArgs ina failed fc r (n:ns) ((_, Placeholder) : args)

564 = elabArgs ina failed fc r ns args

565 elabArgs ina failed fc r (n:ns) ((lazy, t) : args)

566 | lazy && not pattern

567 = do elabArg n (PApp bi (PRef bi (UN "lazy"))

568 [pimp (UN "a") Placeholder True,

569− pexp t]);

569+ pexp t]);

570 | otherwise = elabArg n t

571− where elabArg n t

571+ where elabArg n t

572 = do hs <- get_holes

573 tm <- get_term

574− failed' <- -- trace (show (n, t, hs, tm)) $

574+ failed' <- -- trace (show (n, t, hs, tm)) $

575 -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

576 case n `elem` hs of

577 True ->

@@ -588,7 +588,7 @@ elab ist info pattern tcgen fn tm

588pruneAlt :: [PTerm] -> [PTerm]

589pruneAlt xs = map prune xs

590 where

591− prune (PApp fc1 (PRef fc2 f) as)

591+ prune (PApp fc1 (PRef fc2 f) as)

592 = PApp fc1 (PRef fc2 f) (fmap (fmap (choose f)) as)

593 prune t = t

594

@@ -608,11 +608,11 @@ pruneAlt xs = map prune xs

608-- Rule out alternatives that don't return the same type as the head of the goal

609-- (If there are none left as a result, do nothing)

610pruneByType :: Term -> Context -> [PTerm] -> [PTerm]

611−pruneByType (P _ n _) c as

611+pruneByType (P _ n _) c as

612-- if the goal type is polymorphic, keep e

613 | [] <- lookupTy n c = as

614− | otherwise

614+ | otherwise

615− = let asV = filter (headIs True n) as

615+ = let asV = filter (headIs True n) as

616 as' = filter (headIs False n) as in

617 case as' of

618 [] -> case asV of

@@ -625,7 +625,7 @@ pruneByType (P _ n _) c as

625 headIs var f (PPi _ _ _ sc) = headIs var f sc

626 headIs _ _ _ = True -- keep if it's not an application

627

628− typeHead var f f'

628+ typeHead var f f'

629 = case lookupTy f' c of

630 [ty] -> let ty' = normalise c [] ty in

631 case unApply (getRetTy ty') of

@@ -637,27 +637,27 @@ pruneByType (P _ n _) c as

637pruneByType t _ as = as

638

639findInstances :: IState -> Term -> [Name]

640−findInstances ist t

640+findInstances ist t

641− | (P _ n _, _) <- unApply t

641+ | (P _ n _, _) <- unApply t

642 = case lookupCtxt n (idris_classes ist) of

643 [CI _ _ _ _ ins] -> ins

644 _ -> []

645 | otherwise = []

646

647−trivial' ist

647+trivial' ist

648 = trivial (elab ist toplevel False False (MN 0 "tac")) ist

649proofSearch' ist top n hints

650 = proofSearch (elab ist toplevel False False (MN 0 "tac")) top n hints ist

651−

651+

652

653resolveTC :: Int -> Name -> IState -> ElabD ()

654resolveTC 0 fn ist = fail $ "Can't resolve type class"

655resolveTC 1 fn ist = try' (trivial' ist) (resolveTC 0 fn ist) True

656−resolveTC depth fn ist

656+resolveTC depth fn ist

657 = do hnf_compute

658 g <- goal

659 ptm <- get_term

660− hs <- get_holes

660+ hs <- get_holes

661 if True -- all (\n -> not (n `elem` hs)) (freeNames g)

662 then try' (trivial' ist)

663 (do t <- goal

@@ -703,17 +703,17 @@ resolveTC depth fn ist

703 blunderbuss t d [] = do -- c <- get_env

704 -- ps <- get_probs

705 lift $ tfail $ CantResolve t

706− blunderbuss t d (n:ns)

706+ blunderbuss t d (n:ns)

707 | n /= fn && tcname n = try' (resolve n d)

708 (blunderbuss t d ns) True

709 | otherwise = blunderbuss t d ns

710

711 resolve n depth

712 | depth == 0 = fail $ "Can't resolve type class"

713− | otherwise

713+ | otherwise

714 = do t <- goal

715 let (tc, ttypes) = unApply t

716−-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist

716+-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist

717-- else do

718 -- if there's a hole in the goal, don't even try

719 let imps = case lookupCtxtName n (idris_implicits ist) of

@@ -728,7 +728,7 @@ resolveTC depth fn ist

728 t' <- goal

729 let (tc', ttype) = unApply t'

730 let depth' = if t == t' then depth - 1 else depth

731− resolveTC depth' fn ist)

731+ resolveTC depth' fn ist)

732 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

733 -- if there's any arguments left, we've failed to resolve

734 hs <- get_holes

@@ -757,9 +757,9 @@ collectDeferred top t = return t

757-- if a tactic adds unification problems, return an error

758

759runTac :: Bool -> IState -> PTactic -> ElabD ()

760−runTac autoSolve ist tac

760+runTac autoSolve ist tac

761 = do env <- get_env

762− no_errors $ runT (fmap (addImplBound ist (map fst env)) tac)

762+ no_errors $ runT (fmap (addImplBound ist (map fst env)) tac)

763 where

764 runT (Intro []) = do g <- goal

765 attack; intro (bname g)

@@ -776,8 +776,8 @@ runTac autoSolve ist tac

776 bname _ = Nothing

777 runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm

778 when autoSolve solveAll

779− runT (MatchRefine fn)

779+ runT (MatchRefine fn)

780− = do fnimps <-

780+ = do fnimps <-

781 case lookupCtxtName fn (idris_implicits ist) of

782 [] -> do a <- envArgs fn

783 return [(fn, a)]

@@ -792,8 +792,8 @@ runTac autoSolve ist tac

792 Just t -> return $ map (const False)

793 (getArgTys (binderTy t))

794 _ -> return []

795− runT (Refine fn [])

795+ runT (Refine fn [])

796− = do fnimps <-

796+ = do fnimps <-

797 case lookupCtxtName fn (idris_implicits ist) of

798 [] -> do a <- envArgs fn

799 return [(fn, a)]

@@ -812,7 +812,7 @@ runTac autoSolve ist tac

812 _ -> return []

813 runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps)

814 when autoSolve solveAll

815− runT (Equiv tm) -- let bind tm, then

815+ runT (Equiv tm) -- let bind tm, then

816 = do attack

817 tyn <- unique_hole (MN 0 "ety")

818 claim tyn RType

@@ -832,7 +832,7 @@ runTac autoSolve ist tac

832 valn <- unique_hole (MN 0 "rval")

833 claim valn (Var tyn)

834 letn <- unique_hole (MN 0 "rewrite_rule")

835− letbind letn (Var tyn) (Var valn)

835+ letbind letn (Var tyn) (Var valn)

836 focus valn

837 elab ist toplevel False False (MN 0 "tac") tm

838 rewrite (Var letn)

@@ -863,7 +863,7 @@ runTac autoSolve ist tac

863 when autoSolve solveAll

864 runT Compute = compute

865 runT Trivial = do trivial' ist; when autoSolve solveAll

866− runT (ProofSearch top n hints)

866+ runT (ProofSearch top n hints)

867 = do proofSearch' ist top n hints; when autoSolve solveAll

868 runT (Focus n) = focus n

869 runT Solve = solve

@@ -884,7 +884,7 @@ runTac autoSolve ist tac

884 restac <- unique_hole (MN 0 "restac")

885 claim restac tacticTy

886 focus restac

887− fill (raw_apply (forget script')

887+ fill (raw_apply (forget script')

888 [reflectEnv tenv, reflect tgoal])

889 restac' <- get_guess

890 solve

@@ -896,9 +896,9 @@ runTac autoSolve ist tac

896 runReflected tactic

897 where tacticTy = Var (reflm "Tactic")

898 listTy = Var (NS (UN "List") ["List", "Prelude"])

899− scriptTy = (RBind (UN "__pi_arg")

899+ scriptTy = (RBind (UN "__pi_arg")

900 (Pi (RApp listTy envTupleType))

901− (RBind (UN "__pi_arg1")

901+ (RBind (UN "__pi_arg1")

902 (Pi (Var $ reflm "TT")) tacticTy))

903

904 runT (Reflect v) = do attack -- let x = reflect v in ...

@@ -932,7 +932,7 @@ runTac autoSolve ist tac

932 runTac autoSolve ist (Exact $ PQuote rawValue)

933 runT (GoalType n tac) = do g <- goal

934 case unApply g of

935− (P _ n' _, _) ->

935+ (P _ n' _, _) ->

936 if nsroot n' == UN n

937 then runT tac

938 else fail "Wrong goal type"

@@ -969,7 +969,7 @@ reifyApp ist t [Constant (Str n), x]

969 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

970reifyApp _ t [Constant (Str n)]

971 | t == reflm "Intro" = return $ Intro [UN n]

972−reifyApp ist t [t']

972+reifyApp ist t [t']

973 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

974reifyApp ist t [t']

975 | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

@@ -1071,9 +1071,9 @@ reifyTTNameApp t []

1071reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

1072

1073reifyTTNamespace :: Term -> ElabD [String]

1074−reifyTTNamespace t@(App _ _)

1074+reifyTTNamespace t@(App _ _)

1075 = case unApply t of

1076− (P _ f _, [Constant StrType])

1076+ (P _ f _, [Constant StrType])

1077 | f == NS (UN "Nil") ["List", "Prelude"] -> return []

1078 (P _ f _, [Constant StrType, Constant (Str n), ns])

1079 | f == NS (UN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns)

@@ -1094,7 +1094,7 @@ reifyTTNameType t = fail ("Unknown reflection name type: " ++ show t)

1094reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a)

1095reifyTTBinder reificator binderType t@(App _ _)

1096 = case unApply t of

1097− (P _ f _, bt:args) | forget bt == Var binderType

1097+ (P _ f _, bt:args) | forget bt == Var binderType

1098 -> reifyTTBinderApp reificator f args

1099 _ -> fail ("Mismatching binder reflection: " ++ show t)

1100reifyTTBinder _ _ t = fail ("Unknown reflection binder: " ++ show t)

@@ -1168,14 +1168,14 @@ reifyTTUExp t = fail ("Unknown reflection type universe expression: " ++ show t)

1168

1169-- | Create a reflected call to a named function/constructor

1170reflCall :: String -> [Raw] -> Raw

1171−reflCall funName args

1171+reflCall funName args

1172 = raw_apply (Var (reflm funName)) args

1173

1174-- | Lift a term into its Language.Reflection.TT representation

1175reflect :: Term -> Raw

1176−reflect (P nt n t)

1176+reflect (P nt n t)

1177 = reflCall "P" [reflectNameType nt, reflectName n, reflect t]

1178−reflect (V n)

1178+reflect (V n)

1179 = reflCall "V" [RConstant (I n)]

1180reflect (Bind n b x)

1181 = reflCall "Bind" [reflectName n, reflectBinder b, reflect x]

@@ -1192,24 +1192,24 @@ reflect (TType exp) = reflCall "TType" [reflectUExp exp]

1192reflectNameType :: NameType -> Raw

1193reflectNameType (Bound) = Var (reflm "Bound")

1194reflectNameType (Ref) = Var (reflm "Ref")

1195−reflectNameType (DCon x y)

1195+reflectNameType (DCon x y)

1196 = reflCall "DCon" [RConstant (I x), RConstant (I y)]

1197−reflectNameType (TCon x y)

1197+reflectNameType (TCon x y)

1198 = reflCall "TCon" [RConstant (I x), RConstant (I y)]

1199

1200reflectName :: Name -> Raw

1201−reflectName (UN str)

1201+reflectName (UN str)

1202 = reflCall "UN" [RConstant (Str str)]

1203reflectName (NS n ns)

1204 = reflCall "NS" [ reflectName n

1205− , foldr (\ n s ->

1205+ , foldr (\ n s ->

1206 raw_apply ( Var $ NS (UN "::") ["List", "Prelude"] )

1207 [ RConstant StrType, RConstant (Str n), s ])

1208 ( raw_apply ( Var $ NS (UN "Nil") ["List", "Prelude"] )

1209 [ RConstant StrType ])

1210− ns

1210+ ns

1211− ]

1211+ ]

1212−reflectName (MN i n)

1212+reflectName (MN i n)

1213 = reflCall "MN" [RConstant (I i), RConstant (Str n)]

1214reflectName (NErased) = Var (reflm "NErased")

1215reflectName n = Var (reflm "NErased") -- special name, not yet implemented

@@ -1270,16 +1270,16 @@ reflectEnv = foldr consToEnvList emptyEnvList

1270 = raw_apply (Var (NS (UN "::") ["List", "Prelude"]))

1271 [ envTupleType

1272 , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

1273− , (RApp (Var $ reflm "Binder")

1273+ , (RApp (Var $ reflm "Binder")

1274 (Var $ reflm "TT"))

1275− , reflectName n

1275+ , reflectName n

1276 , reflectBinder b

1277 ]

1278 , l

1279 ]

1280

1281 emptyEnvList :: Raw

1282− emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"]))

1282+ emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"]))

1283 [envTupleType]

1284

1285-- | Reflect an error into the internal datatype of Idris -- TODO

@@ -1289,8 +1289,8 @@ reflectErr (InternalMsg msg) = raw_apply (Var (NS (UN "InternalMsg") ["Reflectio

1289reflectErr x = trace ("Couldn't reflect error " ++ show x) raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str $ show x)]

1290

1291envTupleType :: Raw

1292−envTupleType

1292+envTupleType

1293− = raw_apply (Var pairTy) [ (Var $ reflm "TTName")

1293+ = raw_apply (Var pairTy) [ (Var $ reflm "TTName")

1294 , (RApp (Var $ reflm "Binder") (Var $ reflm "TT"))

1295 ]

1296

@@ -1322,7 +1322,7 @@ mkSpecDecl i n pargs tm'

1322 let g' = g -- specialise ctxt env ntimes g

1323 return tm'

1324-- trace (show t ++ "\n" ++

1325−-- show ntimes ++ "\n" ++

1325+-- show ntimes ++ "\n" ++

1326-- show (delab i g) ++ "\n" ++ show (delab i g')) $ return tm' -- TODO

1327 else return tm'

1328 where

@@ -1330,7 +1330,7 @@ mkSpecDecl i n pargs tm'

1330 cg = idris_callgraph i

1331

1332 staticFnNames tm | (P _ f _, as) <- unApply tm

1333− = if not (isFnName f ctxt) then []

1333+ = if not (isFnName f ctxt) then []

1334 else case lookupCtxt f cg of

1335 [ns] -> f : f : [] --(ns \\ [f])

1336 [] -> [f,f]

src/Idris/Error.hs+2−2

@@ -32,7 +32,7 @@ showErr e = getIState >>= return . flip pshow e

32

33report :: IOError -> String

34report e

35− | isUserError e = ioeGetErrorString e

35+ | isUserError e = ioeGetErrorString e

36 | otherwise = show e

37

38--idrisCatch :: Idris a -> (SomeException -> Idris a) -> Idris a

@@ -54,7 +54,7 @@ tclift (Error err@(At (FC f l c) e)) = do setErrLine l ; throwError err

54tclift (Error err) = throwError err

55

56tctry :: TC a -> TC a -> Idris a

57−tctry tc1 tc2

57+tctry tc1 tc2

58 = case tc1 of

59 OK v -> return v

60 Error err -> tclift tc2

src/Idris/IBC.hs+50−50

@@ -54,8 +54,8 @@ data IBCFile = IBCFile { ver :: Word8,

54 ibc_lineapps :: [(FilePath, Int, PTerm)]

55 }

56 deriving Show

57−{-!

57+{-!

58−deriving instance Binary IBCFile

58+deriving instance Binary IBCFile

59!-}

60

61initIBC :: IBCFile

@@ -67,13 +67,13 @@ loadIBC fp = do iLOG $ "Loading ibc " ++ fp

67 process ibcf fp

68

69writeIBC :: FilePath -> FilePath -> Idris ()

70−writeIBC src f

70+writeIBC src f

71 = do iLOG $ "Writing ibc " ++ show f

72 i <- getIState

73 case (Data.List.map fst (idris_metavars i)) \\ primDefs of

74 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

75 [] -> return ()

76− ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

76+ ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

77 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

78 runIO $ encodeFile f ibcf

79 iLOG "Written")

@@ -88,25 +88,25 @@ mkIBC (i:is) f = do ist <- getIState

88 mkIBC is f'

89

90ibc :: IState -> IBCWrite -> IBCFile -> Idris IBCFile

91−ibc i (IBCFix d) f = return f { ibc_fixes = d : ibc_fixes f }

91+ibc i (IBCFix d) f = return f { ibc_fixes = d : ibc_fixes f }

92ibc i (IBCImp n) f = case lookupCtxt n (idris_implicits i) of

93 [v] -> return f { ibc_implicits = (n,v): ibc_implicits f }

94 _ -> ifail "IBC write failed"

95−ibc i (IBCStatic n) f

95+ibc i (IBCStatic n) f

96 = case lookupCtxt n (idris_statics i) of

97 [v] -> return f { ibc_statics = (n,v): ibc_statics f }

98 _ -> ifail "IBC write failed"

99−ibc i (IBCClass n) f

99+ibc i (IBCClass n) f

100 = case lookupCtxt n (idris_classes i) of

101 [v] -> return f { ibc_classes = (n,v): ibc_classes f }

102 _ -> ifail "IBC write failed"

103−ibc i (IBCInstance int n ins) f

103+ibc i (IBCInstance int n ins) f

104 = return f { ibc_instances = (int,n,ins): ibc_instances f }

105−ibc i (IBCDSL n) f

105+ibc i (IBCDSL n) f

106 = case lookupCtxt n (idris_dsls i) of

107 [v] -> return f { ibc_dsls = (n,v): ibc_dsls f }

108 _ -> ifail "IBC write failed"

109−ibc i (IBCData n) f

109+ibc i (IBCData n) f

110 = case lookupCtxt n (idris_datatypes i) of

111 [v] -> return f { ibc_datatypes = (n,v): ibc_datatypes f }

112 _ -> ifail "IBC write failed"

@@ -135,7 +135,7 @@ ibc i (IBCAccess n a) f = return f { ibc_access = (n,a) : ibc_access f }

135ibc i (IBCFlags n a) f = return f { ibc_flags = (n,a) : ibc_flags f }

136ibc i (IBCTotal n a) f = return f { ibc_total = (n,a) : ibc_total f }

137ibc i (IBCTrans t) f = return f { ibc_transforms = t : ibc_transforms f }

138−ibc i (IBCLineApp fp l t) f

138+ibc i (IBCLineApp fp l t) f

139 = return f { ibc_lineapps = (fp,l,t) : ibc_lineapps f }

140

141process :: IBCFile -> FilePath -> Idris ()

@@ -181,7 +181,7 @@ timestampOlder src ibc = do srct <- getModificationTime src

181 else return ()

182

183pImports :: [FilePath] -> Idris ()

184−pImports fs

184+pImports fs

185 = do mapM_ (\f -> do i <- getIState

186 ibcsd <- valIBCSubDir i

187 ids <- allImportDirs

@@ -189,18 +189,18 @@ pImports fs

189 if (f `elem` imported i)

190 then iLOG $ "Already read " ++ f

191 else do putIState (i { imported = f : imported i })

192− case fp of

192+ case fp of

193 LIDR fn -> do iLOG $ "Failed at " ++ fn

194 ifail "Must be an ibc"

195 IDR fn -> do iLOG $ "Failed at " ++ fn

196 ifail "Must be an ibc"

197− IBC fn src -> loadIBC fn)

197+ IBC fn src -> loadIBC fn)

198 fs

199

200pImps :: [(Name, [PArg])] -> Idris ()

201−pImps imps = mapM_ (\ (n, imp) ->

201+pImps imps = mapM_ (\ (n, imp) ->

202 do i <- getIState

203− putIState (i { idris_implicits

203+ putIState (i { idris_implicits

204 = addDef n imp (idris_implicits i) }))

205 imps

206

@@ -216,7 +216,7 @@ pStatics ss = mapM_ (\ (n, s) ->

216 ss

217

218pClasses :: [(Name, ClassInfo)] -> Idris ()

219−pClasses cs = mapM_ (\ (n, c) ->

219+pClasses cs = mapM_ (\ (n, c) ->

220 do i <- getIState

221 -- Don't lose instances from previous IBCs, which

222 -- could have loaded in any order

@@ -283,11 +283,11 @@ pHdrs :: [(Codegen, String)] -> Idris ()

283pHdrs hs = mapM_ (uncurry addHdr) hs

284

285pDefs :: [(Name, Def)] -> Idris ()

286−pDefs ds = mapM_ (\ (n, d) ->

286+pDefs ds = mapM_ (\ (n, d) ->

287 do i <- getIState

288 logLvl 5 $ "Added " ++ show (n, d)

289 putIState (i { tt_ctxt = addCtxtDef n d (tt_ctxt i) }))

290− ds

290+ ds

291

292pDocs :: [(Name, String)] -> Idris ()

293pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds

@@ -363,7 +363,7 @@ instance Binary FC where

363 x3 <- get

364 return (FC x1 x2 x3)

365

366−

366+

367instance Binary Name where

368 put x

369 = case x of

@@ -508,7 +508,7 @@ instance Binary Const where

508

509 _ -> error "Corrupted binary data for Const"

510

511−

511+

512instance Binary Raw where

513 put x

514 = case x of

@@ -545,7 +545,7 @@ instance Binary Raw where

545 return (RForce x1)

546 _ -> error "Corrupted binary data for Raw"

547

548−

548+

549instance (Binary b) => Binary (Binder b) where

550 put x

551 = case x of

@@ -598,7 +598,7 @@ instance (Binary b) => Binary (Binder b) where

598 return (PVTy x1)

599 _ -> error "Corrupted binary data for Binder"

600

601−

601+

602instance Binary NameType where

603 put x

604 = case x of

@@ -626,7 +626,7 @@ instance Binary NameType where

626

627instance {-(Binary n) =>-} Binary (TT Name) where

628 put x

629− = {-# SCC "putTT" #-}

629+ = {-# SCC "putTT" #-}

630 case x of

631 P x1 x2 x3 -> do putWord8 0

632 put x1

@@ -705,12 +705,12 @@ instance Binary SC where

705 3 -> do x1 <- get

706 return (UnmatchedCase x1)

707 4 -> return ImpossibleCase

708− _ -> error "Corrupted binary data for SC"

708+ _ -> error "Corrupted binary data for SC"

709+

709

710

710−

711instance Binary CaseAlt where

712 put x

713− = {-# SCC "putCaseAlt" #-}

713+ = {-# SCC "putCaseAlt" #-}

714 case x of

715 ConCase x1 x2 x3 x4 -> do putWord8 0

716 put x1

@@ -769,10 +769,10 @@ instance Binary CaseInfo where

769 get = do x1 <- get

770 x2 <- get

771 return (CaseInfo x1 x2)

772−

772+

773instance Binary Def where

774 put x

775− = {-# SCC "putDef" #-}

775+ = {-# SCC "putDef" #-}

776 case x of

777 Function x1 x2 -> do putWord8 0

778 put x1

@@ -871,7 +871,7 @@ instance Binary Totality where

871

872instance Binary IBCFile where

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

874− = {-# SCC "putIBCFile" #-}

874+ = {-# SCC "putIBCFile" #-}

875 do put x1

876 put x2

877 put x3

@@ -901,7 +901,7 @@ instance Binary IBCFile where

901 put x27

902 get

903 = do x1 <- get

904− if x1 == ibcVersion then

904+ if x1 == ibcVersion then

905 do x2 <- get

906 x3 <- get

907 x4 <- get

@@ -930,7 +930,7 @@ instance Binary IBCFile where

930 x27 <- get

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

932 else return (initIBC { ver = x1 })

933−

933+

934instance Binary FnOpt where

935 put x

936 = case x of

@@ -983,7 +983,7 @@ instance Binary Fixity where

983 return (PrefixN x1)

984 _ -> error "Corrupted binary data for Fixity"

985

986−

986+

987instance Binary FixDecl where

988 put (Fix x1 x2)

989 = do put x1

@@ -993,7 +993,7 @@ instance Binary FixDecl where

993 x2 <- get

994 return (Fix x1 x2)

995

996−

996+

997instance Binary Static where

998 put x

999 = case x of

@@ -1006,28 +1006,28 @@ instance Binary Static where

1006 1 -> return Dynamic

1007 _ -> error "Corrupted binary data for Static"

1008

1009−

1009+

1010instance Binary Plicity where

1011 put x

1012 = case x of

1013− Imp x1 x2 x3 x4 ->

1013+ Imp x1 x2 x3 x4 ->

1014 do putWord8 0

1015 put x1

1016 put x2

1017 put x3

1018 put x4

1019− Exp x1 x2 x3 x4 ->

1019+ Exp x1 x2 x3 x4 ->

1020 do putWord8 1

1021 put x1

1022 put x2

1023 put x3

1024 put x4

1025− Constraint x1 x2 x3 ->

1025+ Constraint x1 x2 x3 ->

1026 do putWord8 2

1027 put x1

1028 put x2

1029 put x3

1030− TacImp x1 x2 x3 x4 ->

1030+ TacImp x1 x2 x3 x4 ->

1031 do putWord8 3

1032 put x1

1033 put x2

@@ -1057,7 +1057,7 @@ instance Binary Plicity where

1057 return (TacImp x1 x2 x3 x4)

1058 _ -> error "Corrupted binary data for Plicity"

1059

1060−

1060+

1061instance (Binary t) => Binary (PDecl' t) where

1062 put x

1063 = case x of

@@ -1078,7 +1078,7 @@ instance (Binary t) => Binary (PDecl' t) where

1078 put x2

1079 put x3

1080 put x4

1081− PData x1 x2 x3 x4 x5 ->

1081+ PData x1 x2 x3 x4 x5 ->

1082 do putWord8 3

1083 put x1

1084 put x2

@@ -1092,7 +1092,7 @@ instance (Binary t) => Binary (PDecl' t) where

1092 PNamespace x1 x2 -> do putWord8 5

1093 put x1

1094 put x2

1095− PRecord x1 x2 x3 x4 x5 x6 x7 x8 ->

1095+ PRecord x1 x2 x3 x4 x5 x6 x7 x8 ->

1096 do putWord8 6

1097 put x1

1098 put x2

@@ -1575,7 +1575,7 @@ instance (Binary t) => Binary (PTactic' t) where

1575 Reflect x1 -> do putWord8 17

1576 put x1

1577 Fill x1 -> do putWord8 18

1578− put x1

1578+ put x1

1579 get

1580 = do i <- getWord8

1581 case i of

@@ -1668,7 +1668,7 @@ instance (Binary t) => Binary (PDo' t) where

1668instance (Binary t) => Binary (PArg' t) where

1669 put x

1670 = case x of

1671− PImp x1 x2 x3 x4 x5 x6 ->

1671+ PImp x1 x2 x3 x4 x5 x6 ->

1672 do putWord8 0

1673 put x1

1674 put x2

@@ -1676,19 +1676,19 @@ instance (Binary t) => Binary (PArg' t) where

1676 put x4

1677 put x5

1678 put x6

1679− PExp x1 x2 x3 x4 ->

1679+ PExp x1 x2 x3 x4 ->

1680 do putWord8 1

1681 put x1

1682 put x2

1683 put x3

1684 put x4

1685− PConstraint x1 x2 x3 x4 ->

1685+ PConstraint x1 x2 x3 x4 ->

1686 do putWord8 2

1687 put x1

1688 put x2

1689 put x3

1690 put x4

1691− PTacImplicit x1 x2 x3 x4 x5 x6 ->

1691+ PTacImplicit x1 x2 x3 x4 x5 x6 ->

1692 do putWord8 3

1693 put x1

1694 put x2

@@ -1725,7 +1725,7 @@ instance (Binary t) => Binary (PArg' t) where

1725 return (PTacImplicit x1 x2 x3 x4 x5 x6)

1726 _ -> error "Corrupted binary data for PArg'"

1727

1728−

1728+

1729instance Binary ClassInfo where

1730 put (CI x1 x2 x3 x4 _)

1731 = do put x1

@@ -1775,7 +1775,7 @@ instance Binary SynContext where

1775 2 -> return AnySyntax

1776 _ -> error "Corrupted binary data for SynContext"

1777

1778−

1778+

1779instance Binary Syntax where

1780 put (Rule x1 x2 x3)

1781 = do put x1

@@ -1809,7 +1809,7 @@ instance (Binary t) => Binary (DSL' t) where

1809 x8 <- get

1810 x9 <- get

1811 return (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9)

1812−

1812+

1813instance Binary SSymbol where

1814 put x

1815 = case x of

src/Idris/Imports.hs+2−2

@@ -9,7 +9,7 @@ import System.FilePath

9import System.Directory

10import Control.Monad.State

11

12−data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType

12+data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType

13 deriving (Show, Eq)

14

15srcPath :: FilePath -> FilePath

@@ -60,7 +60,7 @@ findImport (d:ds) ibcsd fp = do let fp_full = d </> fp

60 else IDR idrp

61 if ibc

62 then return (IBC ibcp isrc)

63− else if (idr || lidr)

63+ else if (idr || lidr)

64 then return isrc

65 else findImport ds ibcsd fp

66

src/Idris/Inliner.hs+2−2

@@ -15,13 +15,13 @@ inlineDef ist ds = map (\ (ns, lhs, rhs) -> (ns, lhs, inlineTerm ist rhs)) ds

15-- (Dictionaries are inlinable in an argument, not otherwise)

16-- - If so, try inlining without reducing its arguments

17-- + If successful, then continue on the result (top level)

18−-- + If not, reduce the arguments (argument level) and try again

18+-- + If not, reduce the arguments (argument level) and try again

19-- - If not, inline all the arguments (top level)

20

21inlineTerm :: IState -> Term -> Term

22inlineTerm ist tm = inl tm where

23 inl orig@(P _ n _) = inlApp n [] orig

24− inl orig@(App f a)

24+ inl orig@(App f a)

25 | (P _ fn _, args) <- unApply orig = inlApp fn args orig

26 inl (Bind n (Let t v) sc) = Bind n (Let t (inl v)) (inl sc)

27 inl (Bind n b sc) = Bind n b (inl sc)

src/Idris/ParseData.hs+1−1

@@ -38,7 +38,7 @@ Record ::=

38 DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock;

39-}

40record :: SyntaxInfo -> IdrisParser PDecl

41−record syn = do (doc, acc) <- try (do

41+record syn = do (doc, acc) <- try (do

42 doc <- option "" (docComment '|')

43 acc <- optional accessibility

44 reserved "record"

src/Idris/ParseExpr.hs+1−1

@@ -313,7 +313,7 @@ bracketed syn =

313 <|>

314 try (do l <- expr syn

315 lchar ')'

316− return l)

316+ return l)

317 <|> do (l, fc) <- try (do

318 l <- expr syn

319 fc <- getFC

src/Idris/ParseHelpers.hs+2−2

@@ -487,9 +487,9 @@ collect (c@(PClauses _ o _ _) : ds)

487collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds

488collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds

489collect (PNamespace ns ps : ds) = PNamespace ns (collect ps) : collect ds

490−collect (PClass doc f s cs n ps ds : ds')

490+collect (PClass doc f s cs n ps ds : ds')

491 = PClass doc f s cs n ps (collect ds) : collect ds'

492−collect (PInstance f s cs n ps t en ds : ds')

492+collect (PInstance f s cs n ps t en ds : ds')

493 = PInstance f s cs n ps t en (collect ds) : collect ds'

494collect (d : ds) = d : collect ds

495collect [] = []

src/Idris/Parser.hs+4−4

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

1{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−module Idris.Parser(module Idris.Parser,

2+module Idris.Parser(module Idris.Parser,

3 module Idris.ParseExpr,

4 module Idris.ParseData,

5 module Idris.ParseHelpers,

@@ -262,7 +262,7 @@ fnDecl syn

262 ;

263-}

264fnDecl' :: SyntaxInfo -> IdrisParser PDecl

265−fnDecl' syn = do (doc, fc, opts', n, acc) <- try (do

265+fnDecl' syn = do (doc, fc, opts', n, acc) <- try (do

266 doc <- option "" (docComment '|')

267 pushIndent

268 ist <- get

@@ -443,7 +443,7 @@ Class ::=

443 ;

444-}

445class_ :: SyntaxInfo -> IdrisParser [PDecl]

446−class_ syn = do (doc, acc) <- try (do

446+class_ syn = do (doc, acc) <- try (do

447 doc <- option "" (docComment '|')

448 acc <- optional accessibility

449 return (doc, acc))

@@ -645,7 +645,7 @@ clause syn

645 ist <- get

646 put (ist { lastParse = Just n })

647 return $ PClause fc n capp [] r wheres

648− <|> do (l, op) <- try (do

648+ <|> do (l, op) <- try (do

649 pushIndent

650 l <- argExpr syn

651 op <- operator

src/Idris/PartialEval.hs+1−1

@@ -7,7 +7,7 @@ import Core.Evaluate

7

8import Debug.Trace

9

10−partial_eval :: Context -> [(Name, Maybe Int)] ->

10+partial_eval :: Context -> [(Name, Maybe Int)] ->

11 [Either Term (Term, Term)] ->

12 [Either Term (Term, Term)]

13partial_eval ctxt ns tms = map peClause tms where

src/Idris/Primitives.hs+2−2

@@ -131,7 +131,7 @@ primitives =

131 (1, LFloatStr) total,

132

133 Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)

134− (1, LFExp) total,

134+ (1, LFExp) total,

135 Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)

136 (1, LFLog) total,

137 Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)

@@ -191,7 +191,7 @@ intSCmps ity =

191

192intCmps :: IntTy -> [Prim]

193intCmps ITNative = intSCmps ITNative

194−intCmps ity =

194+intCmps ity =

195 intSCmps ity ++

196 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total

197 , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total

src/Idris/ProofSearch.hs+7−7

@@ -24,7 +24,7 @@ trivial elab ist = try' (do elab (PRefl (fileFC "prf") Placeholder)

24 return ()) True

25 where

26 tryAll [] = fail "No trivial solution"

27− tryAll ((x, b):xs)

27+ tryAll ((x, b):xs)

28 = do -- if type of x has any holes in it, move on

29 hs <- get_holes

30 g <- goal

@@ -35,10 +35,10 @@ trivial elab ist = try' (do elab (PRefl (fileFC "prf") Placeholder)

35

36proofSearch :: (PTerm -> ElabD ()) -> Maybe Name -> Name -> [Name] ->

37 IState -> ElabD ()

38−proofSearch elab fn nroot hints ist = psRec maxDepth

38+proofSearch elab fn nroot hints ist = psRec maxDepth

39 where

40 maxDepth = 6

41−

41+

42 psRec 0 = do attack; defer nroot; solve --fail "Maximum depth reached"

43 psRec d = try' (trivial elab ist)

44 (try' (try' (resolveByCon (d - 1)) (resolveByLocals (d - 1))

@@ -50,7 +50,7 @@ proofSearch elab fn nroot hints ist = psRec maxDepth

50 getFn d (Just f) | d < maxDepth-1 = [f]

51 | otherwise = []

52

53− resolveByCon d

53+ resolveByCon d

54 = do t <- goal

55 let (f, _) = unApply t

56 case f of

@@ -71,7 +71,7 @@ proofSearch elab fn nroot hints ist = psRec maxDepth

71

72 tryCons d [] = fail "Constructors failed"

73 tryCons d (c : cs) = try' (tryCon d c) (tryCons d cs) True

74−

74+

75 tryLocal d n t = do let a = getPArity (delab ist (binderTy t))

76 tryLocalArg d n a

77

@@ -80,7 +80,7 @@ proofSearch elab fn nroot hints ist = psRec maxDepth

80 (psRec d) "proof search local apply"

81

82 -- Like type class resolution, but searching with constructors

83− tryCon d n =

83+ tryCon d n =

84 do let imps = case lookupCtxtName n (idris_implicits ist) of

85 [] -> []

86 [args] -> map isImp (snd args)

@@ -93,7 +93,7 @@ proofSearch elab fn nroot hints ist = psRec maxDepth

93 psRec d)

94 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

95 solve

96−

96+

97 isImp (PImp p _ _ _ _ _) = (True, p)

98 isImp arg = (False, priority arg)

99

src/Idris/Prover.hs+2−2

@@ -36,7 +36,7 @@ prover lit x =

36 _ -> fail "No such metavariable"

37

38showProof :: Bool -> Name -> [String] -> String

39−showProof lit n ps

39+showProof lit n ps

40 = bird ++ show n ++ " = proof" ++ break ++

41 showSep break (map (\x -> " " ++ x) ps) ++

42 break ++ "\n"

@@ -105,7 +105,7 @@ dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = d

105 prettyPs ((n, Let t v) : bs) =

106 nest nestingSize (pretty n <+> text "=" <+> tPretty v <> colon <+>

107 tPretty t $$ prettyPs bs)

108− prettyPs ((n, b) : bs) =

108+ prettyPs ((n, b) : bs) =

109 pretty n <+> colon <+> tPretty (binderTy b) $$ prettyPs bs

110

111 prettyG (Guess t v) = tPretty t <+> text "=?=" <+> tPretty v

src/Idris/REPL.hs+55−55

@@ -100,7 +100,7 @@ repl orig stvar mods

100 Just mods -> repl orig stvar mods

101 Nothing -> return ())

102 ctrlC)

103− ctrlC

103+ ctrlC

104 where ctrlC :: SomeException -> InputT Idris ()

105 ctrlC e = do lift $ iputStrLn (show e)

106 repl orig stvar mods

@@ -111,7 +111,7 @@ startServer orig stvar fn_in = do tid <- runIO $ forkOS serverLoop

111 return ()

112 where serverLoop :: IO ()

113 -- TODO: option for port number

114− serverLoop = withSocketsDo $

114+ serverLoop = withSocketsDo $

115 do sock <- listenOnLocalhost $ PortNumber 4294

116 i <- readMVar stvar

117 loop fn i sock

@@ -120,12 +120,12 @@ startServer orig stvar fn_in = do tid <- runIO $ forkOS serverLoop

120 (f:_) -> f

121 _ -> ""

122

123− loop fn ist sock

123+ loop fn ist sock

124 = do (h,host,_) <- accept sock

125 -- just use the local part of the hostname

126 -- for the "localhost.localdomain" case

127 if ((takeWhile (/= '.') host) == "localhost" ||

128− host == "127.0.0.1")

128+ host == "127.0.0.1")

129 then do

130 cmd <- hGetLine h

131 takeMVar stvar

@@ -135,10 +135,10 @@ startServer orig stvar fn_in = do tid <- runIO $ forkOS serverLoop

135 loop fn ist' sock

136 else hClose h

137

138−processNetCmd :: MVar IState ->

138+processNetCmd :: MVar IState ->

139− IState -> IState -> Handle -> FilePath -> String ->

139+ IState -> IState -> Handle -> FilePath -> String ->

140 IO (IState, FilePath)

141−processNetCmd stvar orig i h fn cmd

141+processNetCmd stvar orig i h fn cmd

142 = do res <- case parseCmd i "(net)" cmd of

143 Failure err -> return (Left (Msg " invalid command"))

144 Success c -> runErrorT $ evalStateT (processNet fn c) i

@@ -146,7 +146,7 @@ processNetCmd stvar orig i h fn cmd

146 Right x -> return x

147 Left err -> do hPutStrLn h (show err)

148 return (i, fn)

149− where

149+ where

150 processNet fn Reload = processNet fn (Load fn)

151 processNet fn (Load f) =

152 do let ist = orig { idris_options = idris_options i

@@ -164,7 +164,7 @@ processNetCmd stvar orig i h fn cmd

164 processNet fn c = do process h fn c

165 ist <- getIState

166 return (ist, fn)

167−

167+

168-- | Run a command on the server on localhost

169runClient :: String -> IO ()

170runClient str = withSocketsDo $ do

@@ -294,7 +294,7 @@ lit f = case splitExtension f of

294 (_, ".lidr") -> True

295 _ -> False

296

297−processInput :: MVar IState -> String ->

297+processInput :: MVar IState -> String ->

298 IState -> [FilePath] -> Idris (Maybe [FilePath])

299processInput stvar cmd orig inputs

300 = do i <- getIState

@@ -321,7 +321,7 @@ processInput stvar cmd orig inputs

321 clearErr

322 mod <- loadModule stdout f

323 return (Just [f])

324− Success (ModImport f) ->

324+ Success (ModImport f) ->

325 do clearErr

326 fmod <- loadModule stdout f

327 return (Just (inputs ++ [fmod]))

@@ -429,7 +429,7 @@ process h fn (Check (PRef _ n))

429 imp <- impShow

430 c <- colourise

431 case lookupNames n ctxt of

432− ts@(t:_) ->

432+ ts@(t:_) ->

433 case lookup t (idris_metavars ist) of

434 Just (_, i) -> showMetavarInfo c imp ist n i

435 Nothing -> do mapM_ (\n -> ihputStrLn h $ showName (Just ist) [] False c n ++ " : " ++

@@ -437,22 +437,22 @@ process h fn (Check (PRef _ n))

437 ihPrintResult h ""

438 [] -> ihPrintError h $ "No such variable " ++ show n

439 where

440− showMetavarInfo c imp ist n i

440+ showMetavarInfo c imp ist n i

441 = case lookupTy n (tt_ctxt ist) of

442 (ty:_) -> putTy c imp ist i (delab ist ty)

443 putTy c imp ist 0 sc = putGoal c imp ist sc

444− putTy c imp ist i (PPi _ n t sc)

444+ putTy c imp ist i (PPi _ n t sc)

445− = do ihputStrLn h $ " " ++

445+ = do ihputStrLn h $ " " ++

446 (case n of

447 MN _ _ -> "_"

448 UN ('_':'_':_) -> "_"

449− _ -> showName (Just ist) [] False c n) ++

449+ _ -> showName (Just ist) [] False c n) ++

450 " : " ++ showImp (Just ist) imp c t

451 putTy c imp ist (i-1) sc

452 putTy c imp ist _ sc = putGoal c imp ist sc

453 putGoal c imp ist g

454 = do ihputStrLn h $ "--------------------------------------"

455− ihputStrLn h $ showName (Just ist) [] False c n ++ " : "

455+ ihputStrLn h $ showName (Just ist) [] False c n ++ " : "

456 ++ showImp (Just ist) imp c g

457

458

@@ -468,7 +468,7 @@ process h fn (Check t)

468 _ -> ihPrintResult h (showImp (Just ist) imp c (delab ist tm) ++ " : " ++

469 showImp (Just ist) imp c (delab ist ty))

470

471−process h fn (DocStr n)

471+process h fn (DocStr n)

472 = do i <- getIState

473 case lookupCtxtName n (idris_docstrings i) of

474 [] -> iPrintError $ "No documentation for " ++ show n

@@ -477,7 +477,7 @@ process h fn (DocStr n)

477 where showDoc (n, d)

478 = do doc <- getDocs n

479 iputStrLn $ show doc

480−process h fn Universes

480+process h fn Universes

481 = do i <- getIState

482 let cs = idris_constraints i

483-- iputStrLn $ showSep "\n" (map show cs)

@@ -487,7 +487,7 @@ process h fn Universes

487 case ucheck cs of

488 Error e -> iPrintError $ pshow i e

489 OK _ -> iPrintResult "Universes OK"

490−process h fn (Defn n)

490+process h fn (Defn n)

491 = do i <- getIState

492 iputStrLn "Compiled patterns:\n"

493 iputStrLn $ show (lookupDef n (tt_ctxt i))

@@ -502,7 +502,7 @@ process h fn (Defn n)

502 = do c <- colourise

503 iputStrLn (showImp (Just i) True c (delab i lhs) ++ " = " ++

504 showImp (Just i) True c (delab i rhs))

505−process h fn (TotCheck n)

505+process h fn (TotCheck n)

506 = do i <- getIState

507 case lookupTotal n (tt_ctxt i) of

508 [t] -> iPrintResult (showTotal t i)

@@ -538,10 +538,10 @@ process h fn (CaseSplit n t)

538-- FIXME: There is far too much repetition in the cases below!

539process h fn (CaseSplitAt updatefile l n)

540 = do src <- runIO $ readFile fn

541− res <- splitOnLine l n fn

541+ res <- splitOnLine l n fn

542 iLOG (showSep "\n" (map show res))

543 let (before, (ap : later)) = splitAt (l-1) (lines src)

544− res' <- replaceSplits ap res

544+ res' <- replaceSplits ap res

545 let new = concat res'

546 if updatefile then

547 do let fb = fn ++ "~" -- make a backup!

@@ -558,7 +558,7 @@ process h fn (AddClauseFrom updatefile l n)

558 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

559 if updatefile then

560 do let fb = fn ++ "~"

561− runIO $ writeFile fb (unlines (before ++ nonblank)

561+ runIO $ writeFile fb (unlines (before ++ nonblank)

562 ++ replicate indent ' ' ++

563 cl ++ "\n" ++

564 unlines rest)

@@ -577,7 +577,7 @@ process h fn (AddProofClauseFrom updatefile l n)

577 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

578 if updatefile then

579 do let fb = fn ++ "~"

580− runIO $ writeFile fb (unlines (before ++ nonblank)

580+ runIO $ writeFile fb (unlines (before ++ nonblank)

581 ++ replicate indent ' ' ++

582 cl ++ "\n" ++

583 unlines rest)

@@ -604,7 +604,7 @@ process h fn (AddMissing updatefile l n)

604 runIO $ copyFile fb fn

605 else ihputStrLn h extras

606 where showPat = show . stripNS

607− stripNS tm = mapPT dens tm where

607+ stripNS tm = mapPT dens tm where

608 dens (PRef fc n) = PRef fc (nsroot n)

609 dens t = t

610

@@ -616,7 +616,7 @@ process h fn (AddMissing updatefile l n)

616 getAppName (PRef _ r) = r

617 getAppName _ = n

618

619− showNew nm i (tm : tms)

619+ showNew nm i (tm : tms)

620 = do (nm', i') <- getUniq nm i

621 rest <- showNew nm i' tms

622 return (showPat tm ++ " = ?" ++ nm' ++

@@ -631,7 +631,7 @@ process h fn (MakeWith updatefile l n)

631 let (nonblank, rest) = span (not . all isSpace) later

632 if updatefile then

633 do let fb = fn ++ "~"

634− runIO $ writeFile fb (unlines (before ++ nonblank)

634+ runIO $ writeFile fb (unlines (before ++ nonblank)

635 ++ with ++ "\n" ++

636 unlines rest)

637 runIO $ copyFile fb fn

@@ -649,7 +649,7 @@ process h fn (DoProofSearch updatefile l n hints)

649 Just mi -> mi

650 _ -> (Nothing, 0)

651 let fc = fileFC fn

652− let body t = PProof [Try (TSeq Intros (ProofSearch t n hints))

652+ let body t = PProof [Try (TSeq Intros (ProofSearch t n hints))

653 (ProofSearch t n hints)]

654 let def = PClause fc mn (PRef fc mn) [] (body top) []

655 newmv <- idrisCatch

@@ -658,12 +658,12 @@ process h fn (DoProofSearch updatefile l n hints)

658 ctxt <- getContext

659 i <- getIState

660 return $ show (stripNS

661− (dropCtxt envlen

661+ (dropCtxt envlen

662 (delab i (specialise ctxt [] [(mn, 1)] tm)))))

663 (\e -> return ("?" ++ show n))

664 if updatefile then

665 do let fb = fn ++ "~"

666− runIO $ writeFile fb (unlines before ++

666+ runIO $ writeFile fb (unlines before ++

667 updateMeta tyline (show n) newmv ++ "\n"

668 ++ unlines later)

669 runIO $ copyFile fb fn

@@ -673,8 +673,8 @@ process h fn (DoProofSearch updatefile l n hints)

673 dropCtxt i (PLet _ _ _ sc) = dropCtxt (i - 1) sc

674 dropCtxt i (PLam _ _ sc) = dropCtxt (i - 1) sc

675 dropCtxt _ t = t

676−

676+

677− stripNS tm = mapPT dens tm where

677+ stripNS tm = mapPT dens tm where

678 dens (PRef fc n) = PRef fc (nsroot n)

679 dens t = t

680

@@ -689,7 +689,7 @@ process h fn (DoProofSearch updatefile l n hints)

689 if (isSpace c && mv == n)

690 then new ++ (c : cs)

691 else '?' : mv ++ c : updateMeta cs n new

692− (mv, []) -> if (mv == n) then new else '?' : mv

692+ (mv, []) -> if (mv == n) then new else '?' : mv

693 updateMeta (c:cs) n new = c : updateMeta cs n new

694 updateMeta [] n new = ""

695

@@ -767,13 +767,13 @@ process h fn (Prove n')

767 mapM_ (\ (f,n) -> setTotality n Unchecked) (idris_totcheck i)

768 mapM_ checkDeclTotality (idris_totcheck i)

769

770−process h fn (HNF t)

770+process h fn (HNF t)

771 = do (tm, ty) <- elabVal toplevel False t

772 ctxt <- getContext

773 ist <- getIState

774 let tm' = hnf ctxt [] tm

775 iPrintResult (show (delab ist tm'))

776−process h fn (TestInline t)

776+process h fn (TestInline t)

777 = do (tm, ty) <- elabVal toplevel False t

778 ctxt <- getContext

779 ist <- getIState

@@ -781,12 +781,12 @@ process h fn (TestInline t)

781 imp <- impShow

782 c <- colourise

783 iPrintResult (showImp (Just ist) imp c (delab ist tm'))

784−process h fn TTShell

784+process h fn TTShell

785 = do ist <- getIState

786 let shst = initState (tt_ctxt ist)

787 runShell shst

788 return ()

789−process h fn Execute

789+process h fn Execute

790 = do (m, _) <- elabVal toplevel False

791 (PApp fc

792 (PRef fc (UN "run__IO"))

@@ -819,7 +819,7 @@ process h fn (Missing n)

819 [(_, tms)] ->

820 iPrintResult (showSep "\n" (map (showImp (Just i) True c) tms))

821 _ -> iPrintError $ "Ambiguous name"

822−process h fn (DynamicLink l)

822+process h fn (DynamicLink l)

823 = do i <- getIState

824 let lib = trim l

825 handle <- lift . lift $ tryLoadLib lib

@@ -831,7 +831,7 @@ process h fn (DynamicLink l)

831 return ()

832 else putIState $ i { idris_dynamic_libs = x:libs }

833 where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace

834−process h fn ListDynamic

834+process h fn ListDynamic

835 = do i <- getIState

836 iputStrLn "Dynamic libraries:"

837 showLibs $ idris_dynamic_libs i

@@ -856,7 +856,7 @@ process h fn (SetColour ty c) = setColour ty c

856process h fn ColourOn

857 = do ist <- getIState

858 putIState $ ist { idris_colourRepl = True }

859−process h fn ColourOff

859+process h fn ColourOff

860 = do ist <- getIState

861 putIState $ ist { idris_colourRepl = False }

862

@@ -890,9 +890,9 @@ displayHelp = let vstr = showVersion version in

890 "--------------" ++ map (\x -> '-') vstr ++ "\n\n" ++

891 concatMap cmdInfo helphead ++

892 concatMap cmdInfo help

893− where cmdInfo (cmds, args, text) = " " ++ col 16 12 (showSep " " cmds) (show args) text

893+ where cmdInfo (cmds, args, text) = " " ++ col 16 12 (showSep " " cmds) (show args) text

894− col c1 c2 l m r =

894+ col c1 c2 l m r =

895− l ++ take (c1 - length l) (repeat ' ') ++

895+ l ++ take (c1 - length l) (repeat ' ') ++

896 m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n"

897

898parseCodegen :: String -> Codegen

@@ -982,27 +982,27 @@ loadInputs :: Handle -> [FilePath] -> Idris ()

982loadInputs h inputs

983 = do ist <- getIState

984 -- if we're in --check and not outputting anything, don't bother

985− -- loading, as it gets really slow if there's lots of modules in

985+ -- loading, as it gets really slow if there's lots of modules in

986 -- a package (instead, reload all at the end to check for

987 -- consistency only)

988 opts <- getCmdLine

989

990 let loadCode = case opt getOutput opts of

991− [] -> not (NoREPL `elem` opts)

991+ [] -> not (NoREPL `elem` opts)

992 _ -> True

993

994 -- For each ifile list, check it and build ibcs in the same clean IState

995 -- so that they don't interfere with each other when checking

996

997 let ninputs = zip [1..] inputs

998− ifiles <- mapM (\(num, input) ->

998+ ifiles <- mapM (\(num, input) ->

999 do putIState ist

1000 v <- verbose

1001−-- when v $ iputStrLn $ "(" ++ show num ++ "/" ++

1001+-- when v $ iputStrLn $ "(" ++ show num ++ "/" ++

1002-- show (length inputs) ++

1003−-- ") " ++ input

1003+-- ") " ++ input

1004− modTree <- buildTree

1004+ modTree <- buildTree

1005− (map snd (take (num-1) ninputs))

1005+ (map snd (take (num-1) ninputs))

1006 input

1007 let ifiles = getModuleFiles modTree

1008 iLOG ("MODULE TREE : " ++ show modTree)

@@ -1093,11 +1093,11 @@ idrisMain opts =

1093 -- if we have the --fovm flag, drop into the first order VM testing

1094 case vm of

1095 [] -> return ()

1096− xs -> runIO $ mapM_ (fovm cgn outty) xs

1096+ xs -> runIO $ mapM_ (fovm cgn outty) xs

1097 -- if we have the --bytecode flag, drop into the bytecode assembler

1098 case bcs of

1099 [] -> return ()

1100− xs -> return () -- runIO $ mapM_ bcAsm xs

1100+ xs -> return () -- runIO $ mapM_ bcAsm xs

1101 case ibcsubdir of

1102 [] -> setIBCSubDir ""

1103 (d:_) -> setIBCSubDir d

@@ -1272,10 +1272,10 @@ opt = mapMaybe

1272

1273ver = showVersion version

1274

1275−banner = " ____ __ _ \n" ++

1275+banner = " ____ __ _ \n" ++

1276 " / _/___/ /____(_)____ \n" ++

1277 " / // __ / ___/ / ___/ Version " ++ ver ++ "\n" ++

1278 " _/ // /_/ / / / (__ ) http://www.idris-lang.org/ \n" ++

1279− " /___/\\__,_/_/ /_/____/ Type :? for help \n"

1279+ " /___/\\__,_/_/ /_/____/ Type :? for help \n"

1280

1281

src/Idris/REPLParser.hs+12−12

@@ -65,29 +65,29 @@ pCmd = do P.whiteSpace; try (do cmd ["q", "quit"]; eof; return Quit)

65 <|> try (do cmd ["set"]; o <-pOption; return (SetOpt o))

66 <|> try (do cmd ["unset"]; o <-pOption; return (UnsetOpt o))

67 <|> try (do cmd ["s", "search"]; P.whiteSpace; t <- P.fullExpr defaultSyntax; return (Search t))

68− <|> try (do cmd ["cs", "casesplit"]; P.whiteSpace;

68+ <|> try (do cmd ["cs", "casesplit"]; P.whiteSpace;

69 upd <- option False (do P.lchar '!'; return True)

70− l <- P.natural; n <- P.name;

70+ l <- P.natural; n <- P.name;

71 return (CaseSplitAt upd (fromInteger l) n))

72− <|> try (do cmd ["apc", "addproofclause"]; P.whiteSpace;

72+ <|> try (do cmd ["apc", "addproofclause"]; P.whiteSpace;

73 upd <- option False (do P.lchar '!'; return True)

74− l <- P.natural; n <- P.name;

74+ l <- P.natural; n <- P.name;

75 return (AddProofClauseFrom upd (fromInteger l) n))

76− <|> try (do cmd ["ac", "addclause"]; P.whiteSpace;

76+ <|> try (do cmd ["ac", "addclause"]; P.whiteSpace;

77 upd <- option False (do P.lchar '!'; return True)

78− l <- P.natural; n <- P.name;

78+ l <- P.natural; n <- P.name;

79 return (AddClauseFrom upd (fromInteger l) n))

80− <|> try (do cmd ["am", "addmissing"]; P.whiteSpace;

80+ <|> try (do cmd ["am", "addmissing"]; P.whiteSpace;

81 upd <- option False (do P.lchar '!'; return True)

82− l <- P.natural; n <- P.name;

82+ l <- P.natural; n <- P.name;

83 return (AddMissing upd (fromInteger l) n))

84− <|> try (do cmd ["mw", "makewith"]; P.whiteSpace;

84+ <|> try (do cmd ["mw", "makewith"]; P.whiteSpace;

85 upd <- option False (do P.lchar '!'; return True)

86− l <- P.natural; n <- P.name;

86+ l <- P.natural; n <- P.name;

87 return (MakeWith upd (fromInteger l) n))

88− <|> try (do cmd ["ps", "proofsearch"]; P.whiteSpace;

88+ <|> try (do cmd ["ps", "proofsearch"]; P.whiteSpace;

89 upd <- option False (do P.lchar '!'; return True)

90− l <- P.natural; n <- P.name;

90+ l <- P.natural; n <- P.name;

91 hints <- many P.name

92 return (DoProofSearch upd (fromInteger l) n hints))

93 <|> try (do cmd ["p", "prove"]; n <- P.name; eof; return (Prove n))

src/Idris/Transforms.hs+2−2

@@ -40,7 +40,7 @@ instance Transform CaseAlt where

40natTrans = [TermTrans zero, TermTrans suc, CaseTrans natcase]

41

42zname = NS (UN "Z") ["Nat","Prelude"]

43−sname = NS (UN "S") ["Nat","Prelude"]

43+sname = NS (UN "S") ["Nat","Prelude"]

44

45zero :: TT Name -> TT Name

46zero (P _ n _) | n == zname

@@ -53,5 +53,5 @@ suc (App (P _ s _) a) | s == sname

53suc x = x

54

55natcase :: SC -> SC

56−natcase = undefined

56+natcase = undefined

57

src/Idris/Unlit.hs+1−1

@@ -15,7 +15,7 @@ ulLine ('>':' ':xs) = (Prog, xs)

15ulLine ('>':xs) = (Prog, xs)

16ulLine xs | all isSpace xs = (Blank, "")

17-- make sure it's not a doc comment

18− | otherwise = (Comm, '-':'-':' ':'>':xs)

18+ | otherwise = (Comm, '-':'-':' ':'>':xs)

19

20check :: FilePath -> Int -> [(LineType, String)] -> TC ()

21check f l (a:b:cs) = do chkAdj f l (fst a) (fst b)

src/Idris/UnusedArgs.hs+9−9

@@ -13,18 +13,18 @@ findUnusedArgs :: [Name] -> Idris ()

13findUnusedArgs ns = mapM_ traceUnused ns

14

15traceUnused :: Name -> Idris ()

16−traceUnused n

16+traceUnused n

17 = do i <- getIState

18− case lookupCtxt n (idris_callgraph i) of

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

23+ recused <- mapM (\ (argn, i, (g, j)) ->

24 do u <- used [(n, i)] g j

25 return (argn, u)) fargs

26 let fused = nub $ usedns ++ map fst (filter snd recused)

27− logLvl 1 $ show n ++ " used args: " ++ show fused

27+ logLvl 1 $ show n ++ " used args: " ++ show fused

28 let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)

29 logLvl 1 $ show n ++ " unused args: " ++ show (args, unusedpos)

30 addToCG n (CGInfo args calls scg usedns unusedpos) -- updates

@@ -34,14 +34,14 @@ traceUnused n

34 | otherwise = Just i

35

36used :: [(Name, Int)] -> Name -> Int -> Idris Bool

37−used path g j

37+used path g j

38 | (g, j) `elem` path = return False -- cycle, never used on the way

39− | otherwise

39+ | otherwise

40− = do logLvl 5 $ (show ((g, j) : path))

40+ = do logLvl 5 $ (show ((g, j) : path))

41 i <- getIState

42 case lookupCtxt g (idris_callgraph i) of

43 [CGInfo args calls scg usedns unused] ->

44− if (j >= length args)

44+ if (j >= length args)

45 then -- overapplied, assume used

46 return True

47 else do let directuse = args!!j `elem` usedns

@@ -50,7 +50,7 @@ used path g j

50 recused <- mapM (\ (argn, j, (g', j')) ->

51 used ((g,j):path) g' j') garg

52 -- used on any route from here, or not used recursively

53− return (directuse || null recused || or recused)

53+ return (directuse || null recused || or recused)

54 _ -> return True -- no definition, assume used

55

56getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]

src/Pkg/PParser.hs+4−4

@@ -58,10 +58,10 @@ parseDesc fp = do p <- readFile fp

58 Right x -> return x

59

60pPkg :: PParser PkgDesc

61−pPkg = do reserved "package"; p <- identifier

61+pPkg = do reserved "package"; p <- identifier

62 st <- getState

63 setState (st { pkgname = p })

64− many1 pClause

64+ many1 pClause

65 st <- getState

66 return st

67

@@ -84,7 +84,7 @@ pClause = do reserved "executable"; lchar '=';

84 let args = parseArgs (words opts)

85 setState (st { idris_opts = args })

86 <|> do reserved "modules"; lchar '=';

87− ms <- sepBy1 (iName []) (lchar ',')

87+ ms <- sepBy1 (iName []) (lchar ',')

88 st <- getState

89 setState (st { modules = modules st ++ ms })

90 <|> do reserved "libs"; lchar '=';

@@ -99,4 +99,4 @@ pClause = do reserved "executable"; lchar '=';

99 mk <- iName []

100 st <- getState

101 setState (st { makefile = Just (show mk) })

102−

102+

src/Pkg/Package.hs+9−9

@@ -30,7 +30,7 @@ import Paths_idris (getDataDir)

30-- * install everything into datadir/pname, if install flag is set

31

32buildPkg :: Bool -> (Bool, FilePath) -> IO ()

33−buildPkg warnonly (install, fp)

33+buildPkg warnonly (install, fp)

34 = do pkgdesc <- parseDesc fp

35 ok <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)

36 when (and ok) $

@@ -42,17 +42,17 @@ buildPkg warnonly (install, fp)

42 (modules pkgdesc)

43 Just o -> do let exec = dir </> o

44 buildMods

45− (NoREPL : Verbose : Output exec : idris_opts pkgdesc)

45+ (NoREPL : Verbose : Output exec : idris_opts pkgdesc)

46 [idris_main pkgdesc]

47 setCurrentDirectory dir

48 when install $ installPkg pkgdesc

49

50cleanPkg :: FilePath -> IO ()

51−cleanPkg fp

51+cleanPkg fp

52 = do pkgdesc <- parseDesc fp

53 dir <- getCurrentDirectory

54 setCurrentDirectory $ dir </> sourcedir pkgdesc

55− clean (makefile pkgdesc)

55+ clean (makefile pkgdesc)

56 mapM_ rmIBC (modules pkgdesc)

57 case execout pkgdesc of

58 Nothing -> return ()

@@ -75,7 +75,7 @@ buildMods opts ns = do let f = map (toPath . show) ns

75 where toPath n = foldl1' (</>) $ splitOn "." n

76

77testLib :: Bool -> String -> String -> IO Bool

78−testLib warn p f

78+testLib warn p f

79 = do d <- getDataDir

80 gcc <- getCC

81 (tmpf, tmph) <- tempfile

@@ -84,15 +84,15 @@ testLib warn p f

84 e <- system $ gcc ++ " " ++ libtest ++ " -l" ++ f ++ " -o " ++ tmpf

85 case e of

86 ExitSuccess -> return True

87− _ -> do if warn

87+ _ -> do if warn

88− then do putStrLn $ "Not building " ++ p ++

88+ then do putStrLn $ "Not building " ++ p ++

89 " due to missing library " ++ f

90 return False

91 else fail $ "Missing library " ++ f

92

93rmIBC :: Name -> IO ()

94−rmIBC m = rmFile $ toIBCFile m

94+rmIBC m = rmFile $ toIBCFile m

95−

95+

96toIBCFile (UN n) = n ++ ".ibc"

97toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns))

98

src/Util/LLVMStubs.hs+2−2

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

1−{--

1+{--

2

3−Things needed to build without LLVM

3+Things needed to build without LLVM

4Replaces stuff from LLVM.General.Target and IRTS.CodegenLLVM.

5

6--}

src/Util/System.hs+6−6

@@ -48,17 +48,17 @@ tempfile = do dir <- getTemporaryDirectory

48 openTempFile (normalise dir) "idris"

49

50withTempdir :: String -> (FilePath -> IO a) -> IO a

51−withTempdir subdir callback

51+withTempdir subdir callback

52 = do dir <- getTemporaryDirectory

53 let tmpDir = (normalise dir) </> subdir

54 removeLater <- catchIO (createDirectoryIfMissing True tmpDir >> return True)

55− (\ ioError -> if isAlreadyExistsError ioError then return False

55+ (\ ioError -> if isAlreadyExistsError ioError then return False

56 else throw ioError

57 )

58 result <- callback tmpDir

59 when removeLater $ removeDirectoryRecursive tmpDir

60 return result

61−

61+

62environment :: String -> IO (Maybe String)

63environment x = catchIO (do e <- getEnv x

64 return (Just e))

@@ -70,13 +70,13 @@ getTargetDir = environment "TARGET" >>= maybe getDataDir return

70rmFile :: FilePath -> IO ()

71rmFile f = do putStrLn $ "Removing " ++ f

72 catchIO (removeFile f)

73− (\ioerr -> putStrLn $ "WARNING: Cannot remove file "

73+ (\ioerr -> putStrLn $ "WARNING: Cannot remove file "

74 ++ f ++ ", Error msg:" ++ show ioerr)

75

76−

76+

77getLibFlags = do dir <- getDataDir

78 return $ "-L" ++ (dir </> "rts") ++ " -lidris_rts -lgmp -lpthread"

79−

79+

80getIdrisLibDir = do dir <- getDataDir

81 return $ addTrailingPathSeparator dir

82

test/mktest.pl+1−1

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

2

3if ($#ARGV>=0) {

4 $test=shift(@ARGV);

5−} else {

5+} else {

6 print "What's its name?\n";

7 exit;

8}

test/reg001/reg001.idr+3−3

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

1apply : (a -> b) -> a -> b

2apply f x = f x

3

4−class Functor f => VerifiedFunctor (f : Type -> Type) where

4+class Functor f => VerifiedFunctor (f : Type -> Type) where

5− identity : (fa : f a) -> map id fa = fa

5+ identity : (fa : f a) -> map id fa = fa

6

7−data Imp : Type where

7+data Imp : Type where

8 MkImp : {any : Type} -> any -> Imp

9

10testVal : Imp

test/reg002/reg002.idr+2−2

@@ -2,7 +2,7 @@ module Main

2

3%default total

4

5−data CoNat

5+data CoNat

6 = Co Nat

7 | Infinity

8

@@ -11,7 +11,7 @@ S (Co n) = Co (S n)

11S Infinity = Infinity

12

13Sn_notzero : Main.S n = Co 0 -> _|_

14−Sn_notzero = believe_me

14+Sn_notzero = believe_me

15

16S_Co_not_Inf : Main.S (Co n) = Infinity -> _|_

17S_Co_not_Inf = believe_me

test/reg003/reg003.idr+1−1

@@ -7,7 +7,7 @@ mutual

7

8 namespace Odd

9 data OddList : Type where

10− (::) : Nat -> EvenList -> OddList

10+ (::) : Nat -> EvenList -> OddList

11

12test : EvenList

13test = [1, 2, 3, 4, 5, 6]

test/reg003/reg003a.idr+2−2

@@ -4,7 +4,7 @@ data EvenList : Type where

4 ECons : Nat -> OddList -> EvenList

5

6data OddList : Type where

7− OCons : Nat -> EvenList -> OddList

7+ OCons : Nat -> EvenList -> OddList

8

9test : EvenList

10−test = ECons 1 ENil

10+test = ECons 1 ENil

test/reg003/run+2−2

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

1#!/bin/bash

2−idris --check reg003.idr

2+idris --check reg003.idr

3−idris --check reg003a.idr

3+idris --check reg003a.idr

4rm -f *.ibc

test/reg005/reg005.idr+3−3

@@ -7,7 +7,7 @@ rep (S k) x = x :: rep k x

7data RLE : Vect n Char -> Type where

8 REnd : RLE []

9 RChar : {xs : Vect k Char} ->

10− (n : Nat) -> (x : Char) -> RLE xs ->

10+ (n : Nat) -> (x : Char) -> RLE xs ->

11 RLE (rep (S n) x ++ xs)

12

13eq : (x : Char) -> (y : Char) -> Maybe (x = y)

@@ -22,13 +22,13 @@ rle (x :: xs) with (rle xs)

22 rle (x :: rep (S n) yvar ++ ys) | RChar n yvar rs with (eq x yvar)

23 rle (x :: rep (S n) x ++ ys) | RChar n x rs | Just refl

24 = RChar (S n) x rs

25− rle (x :: rep (S n) y ++ ys) | RChar n y rs | Nothing

25+ rle (x :: rep (S n) y ++ ys) | RChar n y rs | Nothing

26 = RChar Z x (RChar n y rs)

27

28compress : Vect n Char -> String

29compress xs with (rle xs)

30 compress Nil | REnd = ""

31− compress (rep (S n) x ++ xs) | RChar _ _ rs

31+ compress (rep (S n) x ++ xs) | RChar _ _ rs

32 = let ni : Integer = cast (S n) in

33 show ni ++ show x ++ compress xs

34

test/reg006/reg006.idr+4−4

@@ -1,17 +1,17 @@

1module RBTree

2−

2+

3data Colour = Red | Black

4

5data RBTree : Type -> Type -> Nat -> Colour -> Type where

6 Leaf : RBTree k v Z Black

7 RedBranch : k -> v -> RBTree k v n Black -> RBTree k v n Black -> RBTree k v n Red

8 BlackBranch : k -> v -> RBTree k v n x -> RBTree k v n y -> RBTree k v (S n) Black

9−

9+

10toBlack : RBTree k v n c -> (m ** (RBTree k v m Black, Either (m = n) (m = (S n))))

11toBlack (RedBranch k v l r) = (_ ** (BlackBranch k v l r, Right refl))

12toBlack Leaf = (_ ** (Leaf, Left refl))

13toBlack (BlackBranch k v l r) = (_ ** (BlackBranch k v l r, Left refl))

14−

14+

15total

16lookup : Ord k => k -> RBTree k v n Black -> Maybe v

17lookup k Leaf = Nothing

@@ -23,5 +23,5 @@ lookup k (BlackBranch k0 v0 l r) =

23 lookup k t

24 GT =>

25 let (_ ** (t, _)) = toBlack r in

26− lookup k t

26+ lookup k t

27

test/reg007/run+1−1

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

1#!/bin/bash

2−idris --check $@ reg007.lidr

2+idris --check $@ reg007.lidr

3rm -f *.ibc

test/reg009/reg009.lidr+5−5

@@ -2,15 +2,15 @@

2> isAnyBy _ (_ ** Nil) = False

3> isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as)

4

5−> filterTagP : (p : alpha -> Bool) ->

5+> filterTagP : (p : alpha -> Bool) ->

6−> (as : Vect n alpha) ->

6+> (as : Vect n alpha) ->

7> so (isAnyBy p (n ** as)) ->

8> (m : Nat ** (Vect m (a : alpha ** so (p a)), so (m > Z)))

9> filterTagP {n = S m} p (a :: as) q with (p a)

10> | True = (_

11−> **

11+> **

12−> ((a ** believe_me oh)

12+> ((a ** believe_me oh)

13−> ::

13+> ::

14> (fst (getProof (filterTagP p as (believe_me oh)))),

15> oh

16> )

test/reg011/reg011.idr+4−4

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

1−vfoldl : (P : Nat -> Type) ->

1+vfoldl : (P : Nat -> Type) ->

2 ((x : Nat) -> P x -> a -> P (S x)) -> P Z

3 -> Vect m a -> P m

4−-- vfoldl P cons nil []

4+-- vfoldl P cons nil []

5-- = nil

6−vfoldl P cons nil (x :: xs)

6+vfoldl P cons nil (x :: xs)

7 = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons Z nil x) xs

8−-- vfoldl P cons nil (x :: xs)

8+-- vfoldl P cons nil (x :: xs)

9-- = vfoldl (\n => P (S n)) (\ n => cons _) (cons _ nil x) xs

test/reg012/reg012.lidr+7−7

@@ -13,22 +13,22 @@

13> soTrue : so b -> b = True

14> soTrue {b = False} x = soFalseElim x

15> soTrue {b = True} x = refl

16−

16+

17> class Eq alpha => ReflEqEq alpha where

18> reflexive_eqeq : (a : alpha) -> so (a == a)

19

20−> modifyFun : (Eq alpha) =>

20+> modifyFun : (Eq alpha) =>

21−> (alpha -> beta) ->

21+> (alpha -> beta) ->

22−> (alpha, beta) ->

22+> (alpha, beta) ->

23> (alpha -> beta)

24> modifyFun f (a, b) a' = if a' == a then b else f a'

25

26−> modifyFunLemma : (ReflEqEq alpha) =>

26+> modifyFunLemma : (ReflEqEq alpha) =>

27> (f : alpha -> beta) ->

28> (ab : (alpha, beta)) ->

29> modifyFun f ab (fst ab) = snd ab

30−> modifyFunLemma f (a,b) =

30+> modifyFunLemma f (a,b) =

31> rewrite soTrue (reflexive_eqeq a) in refl

32

33− replace {P = \ z => boolElim (a == a) b (f a) = boolElim z b (f a)}

33+ replace {P = \ z => boolElim (a == a) b (f a) = boolElim z b (f a)}

34 (soTrue (reflexive_eqeq a)) refl

test/reg014/reg014.idr+2−2

@@ -6,7 +6,7 @@ Matrix a n m = Vect n (Vect m a)

6transpose : Matrix a (S n) (S m) -> Matrix a (S m) (S n)

7transpose ((x:: []) :: []) = [[x]]

8transpose [x :: y :: xs] = [x] :: (transpose [y :: xs])

9−transpose (x :: y :: xs)

9+transpose (x :: y :: xs)

10− = let tx = transpose [x] in

10+ = let tx = transpose [x] in

11 let ux = transpose (y :: xs) in zipWith (++) tx ux

12

test/reg018/reg018b.idr+2−2

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

1−module A

1+module A

2

3%default total

4

@@ -8,7 +8,7 @@ showB : B -> String

8showB (I x) = "I" ++ showB x

9showB (Z x) = "Z" ++ showB x

10

11−instance Show B where show = showB

11+instance Show B where show = showB

12

13os : B

14os = Z os

test/reg018/reg018c.idr+1−1

@@ -2,7 +2,7 @@ module CodataTest

2%default total

3

4codata InfStream a = (::) a (InfStream a)

5−--

5+--

6-- natStream : InfStream Nat

7-- natStream = natFromStream 0 where

8-- natFromStream : Nat -> InfStream Nat

test/reg019/reg019.idr+1−1

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

1−m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->

1+m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->

2 Maybe (Either Bool Int)

3m_add x y = do x' <- x -- Extract value from x

4 y' <- y -- Extract value from y

test/reg022/reg022.idr+1−1

@@ -9,7 +9,7 @@ instance Functor (Result str) where

9ParserT : (Type -> Type) -> Type -> Type -> Type

10ParserT m str a = str -> m (Result str a)

11

12−ap : Monad m => ParserT m str (a -> b) -> ParserT m str a ->

12+ap : Monad m => ParserT m str (a -> b) -> ParserT m str a ->

13 ParserT m str b

14ap f x = \s => do f' <- f s

15 case f' of

test/runtest.pl+3−3

@@ -24,7 +24,7 @@ sub runtest {

24 $got =~ s/\r\n/\n/g;

25 $exp =~ s/\r\n/\n/g;

26

27− # Normalize paths in $got and $exp, so the expected outcomes don't

27+ # Normalize paths in $got and $exp, so the expected outcomes don't

28 # change between platforms

29 while($got =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms) {

30 $got = "$1$2/$3:$4:$5";

@@ -35,7 +35,7 @@ sub runtest {

35

36 if ($got eq $exp) {

37 print "Ran $test...success\n";

38− }

38+ }

39 else {

40 if ($update == 0) {

41 $exitstatus = 1;

@@ -66,7 +66,7 @@ if ($#ARGV>=0) {

66 push @tests, $test;

67 }

68 @opts = @ARGV;

69−}

69+}

70else {

71 print "Give a test name, or 'all' to run all.\n";

72 exit;

test/test001/test001.idr+9−9

@@ -27,11 +27,11 @@ using (G : Vect n Ty)

27 Val : (x : Int) -> Expr G TyInt

28 Lam : Expr (a :: G) t -> Expr G (TyFun a t)

29 App : Expr G (TyFun a t) -> Expr G a -> Expr G t

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

30+ Op : (interpTy a -> interpTy b -> interpTy c) -> Expr G a -> Expr G b ->

31 Expr G c

32 If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a

33 Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b

34−

34+

35 dsl expr

36 lambda = Lam

37 variable = Var

@@ -46,7 +46,7 @@ using (G : Vect n Ty)

46 interp env (Op op x y) = op (interp env x) (interp env y)

47 interp env (If x t e) = if interp env x then interp env t else interp env e

48 interp env (Bind v f) = interp env (f (interp env v))

49−

49+

50 eId : Expr G (TyFun TyInt TyInt)

51 eId = expr (\x => x)

52

@@ -55,25 +55,25 @@ using (G : Vect n Ty)

55

56 eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt))

57 eAdd = expr (\x, y => Op (+) x y)

58−

58+

59-- eDouble : Expr G (TyFun TyInt TyInt)

60-- eDouble = Lam (App (App (Lam (Lam (Op' (+) (Var fZ) (Var (fS fZ))))) (Var fZ)) (Var fZ))

61−

61+

62 eDouble : Expr G (TyFun TyInt TyInt)

63 eDouble = expr (\x => App (App eAdd x) (Var stop))

64−

64+

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

66 app = \f, a => App f a

67

68 eFac : Expr G (TyFun TyInt TyInt)

69 eFac = expr (\x => If (Op (==) x (Val 0))

70− (Val 1)

70+ (Val 1)

71 (Op (*) (app eFac (Op (-) x (Val 1))) x))

72

73 -- Exercise elaborator: Complicated way of doing \x y => x*4 + y*2

74−

74+

75 eProg : Expr G (TyFun TyInt (TyFun TyInt TyInt))

76− eProg = Lam (Lam

76+ eProg = Lam (Lam

77 (Bind (App eDouble (Var (pop stop)))

78 (\x => Bind (App eDouble (Var stop))

79 (\y => Bind (App eDouble (Val x))

test/test003/Lit.lidr+2−2

@@ -4,14 +4,14 @@ Test some string primitives while we're at it

4

5> st : String

6> st = "abcdefg"

7−

7+

8Literate main program

9

10> main : IO ()

11> main = do { putStrLn (show (strHead st))

12> putStrLn (show (strIndex st 3))

13> putStrLn (strCons 'z' st)

14−> putStrLn (reverse st)

14+> putStrLn (reverse st)

15> let x = unpack st

16> putStrLn (show (reverse x))

17> putStrLn (pack x)

test/test004/test004.idr+2−2

@@ -20,10 +20,10 @@ main : IO ()

20main = do { h <- openFile "testfile" Write

21 fwrite h "Hello!\nWorld!\n...\n3\n4\nLast line\n"

22 closeFile h

23− putStrLn "Reading testfile"

23+ putStrLn "Reading testfile"

24 f <- readFile "testfile"

25 putStrLn f

26− putStrLn "---"

26+ putStrLn "---"

27 dumpFile "testfile"

28 putStrLn "---"

29 }

test/test007/test007.idr+1−1

@@ -16,7 +16,7 @@ fetch x = MkEval (\e => fetchVal e) where

16instance Functor Eval where

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

18

19−instance Applicative Eval where

19+instance Applicative Eval where

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

21

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

test/test008/test008.idr+1−1

@@ -14,7 +14,7 @@ foo = (4, "foo")

14

15

16ioVals : IO (String, String)

17−ioVals = do { return ("First", "second") }

17+ioVals = do { return ("First", "second") }

18

19main : IO ()

20main = do (a, b) <- ioVals

test/test009/test009.idr+1−1

@@ -6,4 +6,4 @@ pythag n = [ (x, y, z) | z <- [1..n], y <- [1..z], x <- [1..y],

6

7main : IO ()

8main = putStrLn (show (pythag 50))

9−

9+

test/test011/test011.idr+1−1

@@ -16,7 +16,7 @@ person : Person

16person = MkPerson "Fred" 30

17

18main : IO ()

19−main = do let x = record { name = "foo",

19+main = do let x = record { name = "foo",

20 more_things = reverse ["a","b"] } testFoo

21 print $ name x

22 print $ name person

test/test012/test012a.idr+3−3

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

1module Main

2−

2+

3f : Nat -> Nat

4f x = x + 1

5−

5+

6foo : Nat -> Nat

7foo (f x) = x

8−

8+

9main : IO ()

10main = putStrLn (show (foo 1))

test/test013/test013.idr+1−1

@@ -9,7 +9,7 @@ syntax for {x} "in" [xs] ":" [body] = forLoop xs (\x => body)

9

10main : IO ()

11main = do putStrLn "Counting:"

12− for x in [1..10]:

12+ for x in [1..10]:

13 putStrLn $ "Number " ++ show x

14 putStrLn "Done!"

15

test/test014/Resimp.idr+18−18

@@ -29,7 +29,7 @@ getCreator (MkCreator x) = x

29

30ioc : IO a -> Creator a

31ioc = MkCreator

32−

32+

33infixr 5 :->

34

35using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty)

@@ -63,14 +63,14 @@ using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty)

63 update Nil stop _ impossible

64

65 total

66− envUpdate : (p:HasType gam i a) -> (val:interpTy b) ->

66+ envUpdate : (p:HasType gam i a) -> (val:interpTy b) ->

67 Env gam -> Env (update gam p b)

68 envUpdate stop val (x :: xs) = val :: xs

69 envUpdate (pop k) val (x :: xs) = x :: envUpdate k val xs

70 envUpdate stop _ Nil impossible

71

72 total

73− envUpdateVal : (p:HasType gam i a) -> (val:b) ->

73+ envUpdateVal : (p:HasType gam i a) -> (val:b) ->

74 Env gam -> Env (update gam p (Val b))

75 envUpdateVal stop val (x :: xs) = val :: xs

76 envUpdateVal (pop k) val (x :: xs) = x :: envUpdateVal k val xs

@@ -81,7 +81,7 @@ using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty)

81

82 data Args : Vect n Ty -> List Type -> Type where

83 ANil : Args gam []

84− ACons : HasType gam i a ->

84+ ACons : HasType gam i a ->

85 Args gam as -> Args gam (interpTy a :: as)

86

87 funTy : List Type -> Ty -> Ty

@@ -95,31 +95,31 @@ using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty)

95 it goes out of scope, where "consumed" simply means that it has been

96 replaced with a value of type '()'. --}

97

98− Let : Creator (interpTy a) ->

98+ Let : Creator (interpTy a) ->

99− Res (a :: gam) (Val () :: gam') (R t) ->

99+ Res (a :: gam) (Val () :: gam') (R t) ->

100 Res gam gam' (R t)

101− Update : (a -> Updater b) -> (p:HasType gam i (Val a)) ->

101+ Update : (a -> Updater b) -> (p:HasType gam i (Val a)) ->

102 Res gam (update gam p (Val b)) (R ())

103− Use : (a -> Reader b) -> HasType gam i (Val a) ->

103+ Use : (a -> Reader b) -> HasType gam i (Val a) ->

104 Res gam gam (R b)

105

106{-- Control structures --}

107

108 Lift : |(action:IO a) -> Res gam gam (R a)

109− Check : (p:HasType gam i (Choice (interpTy a) (interpTy b))) ->

109+ Check : (p:HasType gam i (Choice (interpTy a) (interpTy b))) ->

110 (failure:Res (update gam p a) (update gam p c) t) ->

111 (success:Res (update gam p b) (update gam p c) t) ->

112 Res gam (update gam p c) t

113− While : Res gam gam (R Bool) ->

113+ While : Res gam gam (R Bool) ->

114 Res gam gam (R ()) -> Res gam gam (R ())

115 Return : a -> Res gam gam (R a)

116− (>>=) : Res gam gam' (R a) -> (a -> Res gam' gam'' (R t)) ->

116+ (>>=) : Res gam gam' (R a) -> (a -> Res gam' gam'' (R t)) ->

117 Res gam gam'' (R t)

118

119 ioret : a -> IO a

120 ioret = return

121

122− interp : Env gam -> {static} Res gam gam' t ->

122+ interp : Env gam -> {static} Res gam gam' t ->

123 (Env gam' -> interpTy t -> IO u) -> IO u

124

125 interp env (Let val scope) k

@@ -128,24 +128,24 @@ using (i: Fin n, gam : Vect n Ty, gam' : Vect n Ty, gam'' : Vect n Ty)

128 (\env', scope' => k (envTail env') scope')

129 interp env (Update method x) k

130 = do x' <- getUpdater (method (envLookup x env))

131− k (envUpdateVal x x' env) (return ())

131+ k (envUpdateVal x x' env) (return ())

132 interp env (Use method x) k

133 = do x' <- getReader (method (envLookup x env))

134 k env (return x')

135− interp env (Lift io) k

135+ interp env (Lift io) k

136 = k env io

137 interp env (Check x left right) k =

138− either (envLookup x env)

138+ either (envLookup x env)

139 (\a => interp (envUpdate x a env) left k)

140 (\b => interp (envUpdate x b env) right k)

141 interp env (While test body) k

142 = interp env test

143 (\env', result =>

144 do r <- result

145− if (not r)

145+ if (not r)

146 then (k env' (return ()))

147− else (interp env' body

147+ else (interp env' body

148− (\env'', body' =>

148+ (\env'', body' =>

149 do v <- body' -- make sure it's evalled

150 interp env'' (While test body) k )))

151 interp env (Return v) k = k env (return v)

test/test014/test014.idr+1−1

@@ -16,7 +16,7 @@ syntax ifM [test] then [t] else [e]

16

17open : String -> (p:Purpose) -> Creator (Either () (FILE p))

18open fn p = ioc (do h <- fopen fn (pstring p)

19− ifM validFile h

19+ ifM validFile h

20 then return (Right (OpenH h))

21 else return (Left ()))

22

test/test015/test015.idr+10−10

@@ -24,7 +24,7 @@ instance Show (Binary w k) where

24 show (bin # bit) = show bin ++ show bit

25

26pad : Binary w n -> Binary (S w) n

27−pad zero = zero # b0

27+pad zero = zero # b0

28pad (num # x) = pad num # x

29

30natToBin : (width : Nat) -> (n : Nat) ->

@@ -47,21 +47,21 @@ testBin = natToBin _ _

47pattern syntax bitpair [x] [y] = (_ ** (_ ** (x, y, _)))

48term syntax bitpair [x] [y] = (_ ** (_ ** (x, y, refl)))

49

50−addBit : Bit x -> Bit y -> Bit c ->

50+addBit : Bit x -> Bit y -> Bit c ->

51 (bX ** (bY ** (Bit bX, Bit bY, c + x + y = bY + 2 * bX)))

52addBit b0 b0 b0 = bitpair b0 b0

53−addBit b0 b0 b1 = bitpair b0 b1

53+addBit b0 b0 b1 = bitpair b0 b1

54addBit b0 b1 b0 = bitpair b0 b1

55addBit b0 b1 b1 = bitpair b1 b0

56−addBit b1 b0 b0 = bitpair b0 b1

56+addBit b1 b0 b0 = bitpair b0 b1

57−addBit b1 b0 b1 = bitpair b1 b0

57+addBit b1 b0 b1 = bitpair b1 b0

58−addBit b1 b1 b0 = bitpair b1 b0

58+addBit b1 b1 b0 = bitpair b1 b0

59−addBit b1 b1 b1 = bitpair b1 b1

59+addBit b1 b1 b1 = bitpair b1 b1

60

61−adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y)

61+adc : Binary w x -> Binary w y -> Bit c -> Binary (S w) (c + x + y)

62adc zero zero carry ?= zero # carry

63adc (numx # bX) (numy # bY) carry

64− ?= let (bitpair carry0 lsb) = addBit bX bY carry in

64+ ?= let (bitpair carry0 lsb) = addBit bX bY carry in

65 adc numx numy carry0 # lsb

66

67readNum : IO Nat

@@ -82,7 +82,7 @@ main = do let Just bin1 = natToBin 8 42

82

83

84

85−

85+

86---------- Proofs ----------

87

88Main.ntbOdd = proof {

test/test017/test017.idr+2−2

@@ -13,7 +13,7 @@ ordElim : (x : Ord) ->

13 (P : Ord -> Type) ->

14 (P Zero) ->

15 ((x : Ord) -> P x -> P (Suc x)) ->

16− ((f : Nat -> Ord) -> ((n : Nat) -> P (f n)) ->

16+ ((f : Nat -> Ord) -> ((n : Nat) -> P (f n)) ->

17 P (Sup f)) -> P x

18ordElim Zero P mZ mSuc mSup = mZ

19ordElim (Suc o) P mZ mSuc mSup = mSuc o (ordElim o P mZ mSuc mSup)

@@ -56,7 +56,7 @@ even (S k) = odd k

56ack : Nat -> Nat -> Nat

57ack Z n = S n

58ack (S m) Z = ack m (S Z)

59−ack (S m) (S n) = ack m (ack (S m) n)

59+ack (S m) (S n) = ack m (ack (S m) n)

60

61data Bin = eps | c0 Bin | c1 Bin

62

test/test018/test018.idr+2−2

@@ -17,10 +17,10 @@ ping : Ptr -> IO ()

17ping thread = sendToThread thread (prim__vm, "Hello!")

18

19pingpong : IO ()

20−pingpong

20+pingpong

21 = do th <- fork pong

22 putStrLn "Sending"

23− ping th

23+ ping th

24 reply <- getMsg

25 putStrLn reply

26 usleep 100000

test/test018/test018a.idr+3−3

@@ -3,7 +3,7 @@ module Main

3import System.Concurrency.Process

4

5ping : ProcID String -> ProcID String -> Process String ()

6−ping main proc

6+ping main proc

7 = do lift (usleep 1000)

8 send proc "Hello!"

9 lift (putStrLn "Sent ping")

@@ -14,7 +14,7 @@ ping main proc

14pong : Process String ()

15pong = do -- lift (putStrLn "Waiting for message")

16 (sender, m) <- recvWithSender

17− lift $ putStrLn ("Received " ++ m)

17+ lift $ putStrLn ("Received " ++ m)

18 send sender ("Hello back!")

19

20mainProc : Process String ()

@@ -27,7 +27,7 @@ mainProc = do mainID <- myID

27repeatIO : Int -> IO ()

28repeatIO 0 = return ()

29repeatIO n = do print n

30− run mainProc

30+ run mainProc

31 repeatIO (n - 1)

32

33main : IO ()

test/test020/test020.idr+2−2

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

1module Main

2

3−implicit

3+implicit

4natInt : Nat -> Integer

5natInt x = cast x

6

7−implicit

7+implicit

8forget : Vect n a -> List a

9forget [] = []

10forget (x :: xs) = x :: forget xs

test/test020/test020a.idr+1−1

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

1module Main

2

3−implicit

3+implicit

4forget : Vect n a -> List a

5forget [] = []

6forget (x :: xs) = x :: forget xs

test/test021/test021.idr+5−5

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

1−module Main

1+module Main

2

3import Effect.File

4import Effect.State

@@ -8,20 +8,20 @@ import Control.IOExcept

8data FName = Count | NotCount

9

10FileIO : Type -> Type -> Type

11−FileIO st t

11+FileIO st t

12 = Eff (IOExcept String) [FILE_IO st, STDIO, Count ::: STATE Int] t

13

14readFile : FileIO (OpenFile Read) (List String)

15readFile = readAcc [] where

16− readAcc : List String -> FileIO (OpenFile Read) (List String)

16+ readAcc : List String -> FileIO (OpenFile Read) (List String)

17 readAcc acc = do e <- eof

18− if (not e)

18+ if (not e)

19 then do str <- readLine

20 Count :- put (!(Count :- get) + 1)

21 readAcc (str :: acc)

22 else return (reverse acc)

23

24−testFile : FileIO () ()

24+testFile : FileIO () ()

25testFile = do open "testFile" Read

26 if_valid then do putStrLn (show !readFile)

27 close

test/test021/test021a.idr+1−1

@@ -14,7 +14,7 @@ Env : Type

14Env = List (String, Integer)

15

16-- Evaluator : Type -> Type

17−-- Evaluator t

17+-- Evaluator t

18-- = Eff m [EXCEPTION String, RND, STATE Env] t

19

20eval : Expr -> Eff IO [EXCEPTION String, STDIO, RND, STATE Env] Integer

test/test025/test025.idr+1−1

@@ -26,7 +26,7 @@ testMemory = do Src :- allocate 5

26 res <- Dst :- peek 1 (S(S(S(S Z)))) oh

27 Dst :- free

28 return (map (prim__zextB8_Int) res)

29−

29+

30main : IO ()

31main = do ioe_run (run [Dst := (), Src := ()] testMemory)

32 (\err => print err) (\ok => print ok)

test/test029/test029.idr+2−2

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

1−module simple

1+module simple

2

3plus_comm : (n : Nat) -> (m : Nat) -> (n + m = m + n)

4

5-- Base case

6(Z + m = m + Z) <== plus_comm =

7− rewrite ((m + Z = m) <== plusZeroRightNeutral) ==>

7+ rewrite ((m + Z = m) <== plusZeroRightNeutral) ==>

8 (Z + m = m) in refl

9

10-- Step case

test/test030/Reflect.idr+7−7

@@ -41,7 +41,7 @@ using (xs : List a, ys : List a, G : List (List a))

41 expr_r (App ex ey) = let (xl ** (xr, xprf)) = expr_r ex in

42 let (yl ** (yr, yprf)) = expr_r ey in

43 appRExpr _ _ xr yr xprf yprf

44− where

44+ where

45 appRExpr : (xs', ys' : List a) ->

46 RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->

47 (ws' ** (RExpr G ws', xs' ++ ys' = ws'))

@@ -80,13 +80,13 @@ using (xs : List a, ys : List a, G : List (List a))

80

81 buildProof : {xs : List a} -> {ys : List a} ->

82 Expr G ln -> Expr G rn ->

83− (xs = ln) -> (ys = rn) -> Maybe (xs = ys)

83+ (xs = ln) -> (ys = rn) -> Maybe (xs = ys)

84 buildProof e e' lp rp with (eqExpr e e')

85 buildProof e e lp rp | Just refl = ?bp1

86 buildProof e e' lp rp | Nothing = Nothing

87

88 testEq : Expr G xs -> Expr G ys -> Maybe (xs = ys)

89− testEq l r = let (ln ** (l', lPrf)) = reduce l in

89+ testEq l r = let (ln ** (l', lPrf)) = reduce l in

90 let (rn ** (r', rPrf)) = reduce r in

91 buildProof l' r' lPrf rPrf

92

@@ -129,7 +129,7 @@ using (xs : List a, ys : List a, G : List (List a))

129-- reduction will work the right way.

130

131%reflection

132−reflectList : (G : List (List a)) ->

132+reflectList : (G : List (List a)) ->

133 (xs : List a) -> (G' ** Expr (G' ++ G) xs)

134reflectList G [] = ([] ** ENil)

135

@@ -140,7 +140,7 @@ reflectList G (x :: xs) with (reflectList G xs)

140

141reflectList G (xs ++ ys) with (reflectList G xs)

142 | (G' ** xs') with (reflectList (G' ++ G) ys)

143− | (G'' ** ys') = ((G'' ++ G') **

143+ | (G'' ** ys') = ((G'' ++ G') **

144 rewrite (sym (appendAssociative G'' G' G)) in

145 App (weaken G'' xs') ys')

146reflectList G t with (isElem t G)

@@ -157,7 +157,7 @@ reflectList G t with (isElem t G)

157

158%reflection

159reflectEq : (a : Type) -> (G : List (List a)) -> (P : Type) -> (G' ** ListEq (G' ++ G) P)

160−reflectEq a G (the (List a) xs = the (List a) ys) with (reflectList G xs)

160+reflectEq a G (the (List a) xs = the (List a) ys) with (reflectList G xs)

161 | (G' ** xs') with (reflectList (G' ++ G) ys)

162 | (G'' ** ys') = ((G'' ++ G') **

163 rewrite (sym (appendAssociative G'' G' G)) in

@@ -197,7 +197,7 @@ Reflect.bp1 = proof {

197-- The effect is to bind x to p applied to the current goal. If 'p' is a

198-- reflection function (which is the most likely thing to be useful...)

199-- then we can feed the result to the above 'prove' function and pull out

200−-- the proof, if it exists.

200+-- the proof, if it exists.

201

202-- The syntax declaration below just gives us an easy way to invoke the

203-- prover.

test/test030/test030.idr+2−2

@@ -7,7 +7,7 @@ testReflect0 : (xs, ys : List a) -> ((xs ++ (ys ++ xs)) = ((xs ++ ys) ++ xs))

7testReflect0 {a} xs ys = AssocProof a

8

9total

10−testReflect1 : (xs, ys : List a) ->

10+testReflect1 : (xs, ys : List a) ->

11 ((xs ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs)))

12−testReflect1 {a} xs ys = AssocProof a

12+testReflect1 {a} xs ys = AssocProof a

13

test/test030/test030a.idr+2−2

@@ -7,7 +7,7 @@ testReflect0 : (xs, ys : List a) -> ((xs ++ (ys ++ xs)) = ((xs ++ ys) ++ xs))

7testReflect0 {a} xs ys = AssocProof a

8

9total

10−testReflect1 : (xs, ys : List a) ->

10+testReflect1 : (xs, ys : List a) ->

11 ((ys ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs)))

12−testReflect1 {a} xs ys = AssocProof a

12+testReflect1 {a} xs ys = AssocProof a

13

test/test032/expected+2−2

@@ -2,8 +2,8 @@ Type checking ./test032.idr

2isElem x [] = ?isElem_rhs_1

3isElem x (_ :: _) = ?isElem_rhs_3

4

5− localZipWith f (_ :: _) ys = ?localZipWith_rhs_1

5+ localZipWith f (_ :: _) ys = ?localZipWith_rhs_1

6− localZipWith f (_ :: _) ys = ?localZipWith_rhs_2

6+ localZipWith f (_ :: _) ys = ?localZipWith_rhs_2

7

8f x :: (map f xs)

9isElem2 x (y :: ys) with (_)

test/test032/test032.idr+1−1

@@ -14,7 +14,7 @@ vadd : Num a => Vect n a -> Vect n a -> Vect n a

14vadd xs ys = localZipWith (+) xs ys where

15 localZipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

16 localZipWith f [] [] = []

17− localZipWith f (_ :: _) ys = ?localZipWith_rhs

17+ localZipWith f (_ :: _) ys = ?localZipWith_rhs

18

19map : (a -> b) -> Vect n a -> Vect n b

20map f [] = []

tutorial/examples/bmain.idr+1−1

@@ -3,6 +3,6 @@ module Main

3import btree

4

5main : IO ()

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

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

7 print (btree.toList t)

8

tutorial/examples/classes.idr+1−1

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

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

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

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

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

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

5

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

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

tutorial/examples/foo.idr+1−1

@@ -6,5 +6,5 @@ namespace x

6

7namespace y

8 test : String -> String

9− test x = x ++ x

9+ test x = x ++ x

10

tutorial/examples/idiom.idr+1−1

@@ -16,7 +16,7 @@ fetch x = MkEval (\e => fetchVal e) where

16instance Functor Eval where

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

18

19−instance Applicative Eval where

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

tutorial/examples/interp.idr+7−7

@@ -7,7 +7,7 @@ interpTy TyInt = Int

7interpTy TyBool = Bool

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

9

10−using (G : Vect n Ty)

10+using (G : Vect n Ty)

11

12 data Env : Vect n Ty -> Type where

13 Nil : Env Nil

@@ -26,17 +26,17 @@ using (G : Vect n Ty)

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

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−

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

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)

@@ -47,10 +47,10 @@ using (G : Vect n Ty)

47

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

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

50−

50+

51 eDouble : Expr G (TyFun TyInt TyInt)

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

53−

53+

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

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

56

@@ -67,5 +67,5 @@ unitTestFac = oh

67main : IO ()

68main = do putStr "Enter a number: "

69 x <- getLine

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

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

71

tutorial/examples/wheres.idr+3−3

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

1module wheres

2

3−even : Nat -> Bool

3+even : Nat -> Bool

4even Z = True

5−even (S k) = odd k where

5+even (S k) = odd k where

6 odd Z = False

7− odd (S k) = even k

7+ odd (S k) = even k

8

9test : List Nat

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