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

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

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

11module Main

22import Sqlite3

33

4−

4+

55testexpr : DB()

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

77 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

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

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

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

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

1313 exec_db_v2 stmt -- execute the prepared query

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

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

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

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

1717 close_db db -- close the datbase

1818 return ()

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

2424 let list = (snd sql)

2525 liftIO(print x)

2626 stmt <- (prepare_db db x)

27− bindMulti stmt list

28− exec_db_v2 stmt

27+ bindMulti stmt list

28+ exec_db_v2 stmt

2929 finalize_db stmt

3030 close_db db

3131 return ()

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

3737 let list = (snd sql)

3838 liftIO(print x)

3939 stmt <- (prepare_db db x)

40− bindMulti stmt list

41− exec_db_v2 stmt

40+ bindMulti stmt list

41+ exec_db_v2 stmt

4242 finalize_db stmt

4343 close_db db

44− return ()

45−

44+ return ()

45+

4646testNull : DB()

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

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

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

5050 let list = (snd sql)

5151 liftIO(print x)

5252 stmt <- (prepare_db db x)

53− bindMulti stmt list

53+ bindMulti stmt list

5454 exec_db_v2 stmt

5555 res <- toList_v1 db

56− liftIO(print res)

56+ liftIO(print res)

5757 finalize_db stmt

5858 close_db db

59− return ()

59+ return ()

60+

6061

61−

6262testInsertWithCond : DB()

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

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

6666 let list = (snd sql)

6767 liftIO(print x)

6868 stmt <- (prepare_db db x)

69− bindMulti stmt list

70− exec_db_v2 stmt

69+ bindMulti stmt list

70+ exec_db_v2 stmt

7171 finalize_db stmt

7272 close_db db

73− return ()

74−

73+ return ()

74+

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

7676testNestedSel1 : DB()

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

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

8080 let list = (snd sql)

8181 liftIO(print x)

8282 stmt <- (prepare_db db x)

83− bindMulti stmt list

84− exec_db_v2 stmt

83+ bindMulti stmt list

84+ exec_db_v2 stmt

8585 res <- toList_v1 db

86− liftIO(print res)

86+ liftIO(print res)

8787 finalize_db stmt

8888 close_db db

89− return ()

89+ return ()

9090

9191-- Testing Create Table

9292testCreateTable : DB ()

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

9696 let list = (snd sql)

9797 liftIO(print x)

9898 stmt <- (prepare_db db x)

99− bindMulti stmt list

100− exec_db_v2 stmt

99+ bindMulti stmt list

100+ exec_db_v2 stmt

101101 finalize_db stmt

102102 close_db db

103− return ()

103+ return ()

104104

105105-- This may be a bit slow

106106testMultiTable : DB ()

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

110110 let list = (snd sql)

111111 liftIO(print x)

112112 stmt <- (prepare_db db x)

113− bindMulti stmt list

114− exec_db_v2 stmt

113+ bindMulti stmt list

114+ exec_db_v2 stmt

115115 res <- toList_v1 db

116− liftIO(print res)

116+ liftIO(print res)

117117 finalize_db stmt

118118 close_db db

119119 return ()

120−

120+

121121testSelAll : DB ()

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

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

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

125125 let list = (snd sql)

126126 liftIO(print x)

127127 stmt <- (prepare_db db x)

128− bindMulti stmt list

129− exec_db_v2 stmt

128+ bindMulti stmt list

129+ exec_db_v2 stmt

130130 res <- toList_v1 db

131− liftIO(print res)

131+ liftIO(print res)

132132 finalize_db stmt

133133 close_db db

134134 return ()

135135

136−

136+

137137main : IO ()

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

139139 --y <- runDB (testNestedSel1)

effects/Effect/Exception.idr+2−2

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

55import Control.IOExcept

66

77data Exception : Type -> Type -> Type -> Type -> Type where

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

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

99

1010instance Handler (Exception a) Maybe where

1111 handle _ (Raise e) k = Nothing

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

2121 handle _ (Raise e) k = Left e

2222

2323EXCEPTION : Type -> EFFECT

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

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

2525

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

2727raise err = Raise err

effects/Effect/File.idr+5−5

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

99data FileIO : Effect where

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

1111 Close : FileIO (OpenFile m) () ()

12−

12+

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

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

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

16−

16+

1717

1818instance Handler FileIO IO where

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

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

3030 k (FH h) e

3131

3232instance Handler FileIO (IOExcept String) where

33− handle () (Open fname m) k

33+ handle () (Open fname m) k

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

3535 valid <- ioe_lift (validFile h)

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

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

4444 k (FH h) e

4545

4646FILE_IO : Type -> EFFECT

47−FILE_IO t = MkEff t FileIO

47+FILE_IO t = MkEff t FileIO

4848

4949open : Handler FileIO e =>

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

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

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

5252open f m = Open f m

5353

effects/Effect/Select.idr+1−1

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

1414

1515instance Handler Selection List where

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

17−

17+

1818SELECT : EFFECT

1919SELECT = MkEff () Selection

2020

effects/Effect/State.idr+2−2

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

1717STATE t = MkEff t State

1818

1919get : Eff m [STATE x] x

20−get = Get

20+get = Get

2121

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

2323put val = Put val

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

2626putM val = Put val

2727

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

29−update f = put (f !get)

29+update f = put (f !get)

3030

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

3232updateM f = putM (f !get)

effects/Effect/StdIO.idr+7−7

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

99

1010instance Handler StdIO IO where

1111 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

1313

1414instance Handler StdIO (IOExcept a) where

1515 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

1717

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

1919

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

21−

21+

2222instance Handler StdIO IOStream where

2323 handle () (PutStr s) k

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

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

3131 where

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

3333 cont t ts = case k () t of

34− MkStream f => f ts

34+ MkStream f => f ts

3535

3636--- The Effect and associated functions

3737

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

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

4848getStr = GetStr

4949

50−mkStrFn : Env IOStream xs ->

51− Eff IOStream xs a ->

50+mkStrFn : Env IOStream xs ->

51+ Eff IOStream xs a ->

5252 List String -> (a, List String)

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

5454 MkStream f => f input

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

5757 mkStrFn' : IOStream a

5858 mkStrFn' = runWith injStream env p

5959

60−

60+

effects/Effects.idr+30−30

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

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

5353

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

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

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

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

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

5757rebuildEnv [] SubNil env = env

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

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

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

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

6161

6262---- The Effect EDSL itself ----

6363

6464-- some proof automation

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

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

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

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

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

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

7070

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

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

7373findSubList (S n) ctxt goal

74− = GoalType "SubList"

74+ = GoalType "SubList"

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

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

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

7878

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

8080 List EFFECT

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

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

8383

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

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

8585 List EFFECT

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

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

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

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

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

9393

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

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

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

9696

9797private

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

108108 List EFFECT -> List EFFECT -> Type -> Type where

109109 value : a -> EffM m xs xs a

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

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

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

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

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

113113 EffM m xs (updateResTy xs prf eff) t

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

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

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

142142

143143implicit

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

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

146− prf : EffElem e a xs} ->

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

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

146+ prf : EffElem e a xs} ->

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

148148 EffM m xs (updateResTy xs prf eff) t

149149effect' {prf} e = effect prf e

150150

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

152152

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

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

155−

155+

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

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

158−

158+

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

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

161−

161+

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

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

164164

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

166166

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

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

169−

169+

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

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

172−

172+

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

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

175−

175+

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

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

178−

178+

179179

180180-- for 'do' notation

181181

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

200200-- an interpreter

201201

202202private

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

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

204204 (eff : e res b a) ->

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

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

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

210210

211211private

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

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

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

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

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

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

221221

222222private

223223testEffLbl : {x : lbl} ->

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

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

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

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

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

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

233233

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

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

236236

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

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

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

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

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

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

242−eff env (lift prf effP) k

243− = let env' = dropEnv env prf in

242+eff env (lift prf effP) k

243+ = let env' = dropEnv env prf in

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

245245eff env (new r prog) k

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

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

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

248248eff env (test prf l r) k

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

281281-- some higher order things

282282

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

284−mapE f [] = pure []

284+mapE f [] = pure []

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

286286

287287when : 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!

3939believe_me x = prim__believe_me _ _ x

4040

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

42−really_believe_me : a -> b

42+really_believe_me : a -> b

4343really_believe_me x = prim__believe_me _ _ x

4444

4545namespace Builtins {

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

8484

8585data Bool = False | True

8686

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

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

8888boolElim True t e = t

8989boolElim False t e = e

9090

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

120120intToBool x = True

121121

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

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

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

124124

125125class Eq a where

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

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

129129 x /= y = not (x == y)

130130 x == y = not (x /= y)

131131

132−instance Eq Int where

132+instance Eq Int where

133133 (==) = boolOp prim__eqInt

134134

135135instance Eq Integer where

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

162162 GT == GT = True

163163 _ == _ = False

164164

165−class Eq a => Ord a where

165+class Eq a => Ord a where

166166 compare : a -> a -> Ordering

167167

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

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

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

170170 (<) x y | LT = True

171171 (<) x y | _ = False

172172

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

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

189189

190190

191−instance Ord Int where

191+instance Ord Int where

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

193193 if (boolOp prim__sltInt x y) then LT else

194194 GT

195195

196196

197−instance Ord Integer where

197+instance Ord Integer where

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

199199 if (boolOp prim__sltBigInt x y) then LT else

200200 GT

201201

202202

203−instance Ord Float where

203+instance Ord Float where

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

205205 if (boolOp prim__sltFloat x y) then LT else

206206 GT

207207

208208

209−instance Ord Char where

209+instance Ord Char where

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

211211 if (boolOp prim__sltChar x y) then LT else

212212 GT

213213

214214

215−instance Ord String where

215+instance Ord String where

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

217217 if (boolOp prim__ltString x y) then LT else

218218 GT

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

225225 else compare xr yr

226226

227227

228−class Num a where

228+class Num a where

229229 (+) : a -> a -> a

230230 (-) : a -> a -> a

231231 (*) : a -> a -> a

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

233233 abs : a -> a

234234 fromInteger : Integer -> a

235235

236−instance Num Integer where

236+instance Num Integer where

237237 (+) = prim__addBigInt

238238 (-) = prim__subBigInt

239239 (*) = prim__mulBigInt

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

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

242242 fromInteger = id

243243

244−instance Num Int where

244+instance Num Int where

245245 (+) = prim__addInt

246246 (-) = prim__subInt

247247 (*) = prim__mulInt

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

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

251251

252252

253−instance Num Float where

253+instance Num Float where

254254 (+) = prim__addFloat

255255 (-) = prim__subFloat

256256 (*) = prim__mulFloat

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

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

22

33import Prelude.Functor

44import Prelude.Applicative

5−import Prelude.Monad

5+import Prelude.Monad

66

77public record Identity : Type -> Type where

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

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

1212

1313instance Applicative Identity where

1414 pure x = Id x

15−

15+

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

1717

1818instance Monad Identity where

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

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

3333

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

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

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

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

3737

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

3939modify f = do s <- get

lib/Data/Bits.idr+2−2

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

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

3434natToBits' a Z = a

3535natToBits' {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

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

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

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

114114

115115public

116116shiftRightLogical : Bits n -> Bits n -> Bits n

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

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

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

119119

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

lib/Data/Morphisms.idr+1−1

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

11module Data.Morphisms

22

3−import Prelude

3+import Prelude

44

55%access public

66

lib/Debug/Trace.idr+1−1

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

44import IO

55

66trace : String -> a -> a

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

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

88

99

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

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

110110lemma_snd_neq refl p refl = p refl

111111

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

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

114− (y = y') ->

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

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

114+ (y = y') ->

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

116116lemma_fst_neq_snd_eq p_x_not_x' refl refl = p_x_not_x' refl

117117

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

133133lemma_val_not_nil refl impossible

134134

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

137137

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

139139lemma_x_neq_xs_eq p refl refl = p refl

lib/Decidable/Order.idr+1−1

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

4545 transitive = NatLTEIsTransitive

4646 reflexive = NatLTEIsReflexive

4747

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

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

4949 NatLTE m n -> NatLTE n m -> m = n

5050NatLTEIsAntisymmetric n n nEqn nEqn = refl

5151NatLTEIsAntisymmetric n m nEqn (nLTESm _) impossible

lib/IO.idr+7−7

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

9797

9898

9999data Foreign : Type -> Type where

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

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

101101 Foreign (ForeignTy xs t)

102102

103103mkForeignPrim : Foreign x -> x

104104mkLazyForeignPrim : Foreign x -> x

105105-- mkForeign and mkLazyForeign compiled as primitives

106106

107−abstract

107+abstract

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

109109io_bind (MkIO fn) k

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

111111 (\ b => case k b of

112112 MkIO fkb => fkb w))

113113

114−abstract

114+abstract

115115io_return : a -> IO a

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

117117

118118liftPrimIO : (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)

120120 (\x => prim_io_return x))

121121

122122run__IO : IO () -> PrimIO ()

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

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

124124 (\ b => prim_io_return b)

125125

126126run__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)

128128 (\ b => prim_io_return b)

129129

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

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

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

144144

145145unsafePerformIO : IO a -> a

146−unsafePerformIO (MkIO f) = unsafePerformPrimIO

146+unsafePerformIO (MkIO f) = unsafePerformPrimIO

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

148148

149149

lib/Language/Reflection.idr+1−1

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

172172 | Reflect TT

173173 -- ^ turn a value into its reflected representation

174174 | Fill Raw

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

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

176176 | Exact TT

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

178178 | Focus TTName

lib/Network/Cgi.idr+9−9

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

3333

3434instance Applicative CGI where

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

36−

36+

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

3838 (c, j) <- b i

3939 return (f c, j))

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

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

5151

5252abstract

53−lift : IO a -> CGI a

53+lift : IO a -> CGI a

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

55− return (x, st) } )

55+ return (x, st) } )

5656

5757abstract

5858output : String -> CGI ()

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

9595abstract

9696flush : CGI ()

9797flush = do o <- getOutput

98− lift (putStr o)

98+ lift (putStr o)

9999

100100getVars : 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)

102102 where

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

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

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

118118getCgiEnv : String -> IO String

119119getCgiEnv key = do

120120 val <- getEnv key

121− return $ maybe "" id val

121+ return $ maybe "" id val

122122

123123abstract

124124runCGI : CGI a -> IO a

125−runCGI prog = do

125+runCGI prog = do

126126 clen_in <- getCgiEnv "CONTENT_LENGTH"

127127 let clen = prim__fromStrInt clen_in

128128 content <- getContent clen

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

134134 let post_vars = getVars ['&'] content

135135 let cookies = getVars [';'] cookie

136136

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

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

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

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

139139 "")

140140 putStrLn (Headers st)

141141 putStr (Output st)

lib/Prelude.idr+36−36

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

2323

2424-- Show and instances

2525

26−class Show a where

26+class Show a where

2727 partial show : a -> String

2828

29−instance Show Int where

29+instance Show Int where

3030 show = prim__toStrInt

3131

32−instance Show Integer where

32+instance Show Integer where

3333 show = prim__toStrBigInt

3434

35−instance Show Float where

35+instance Show Float where

3636 show = prim__floatToStr

3737

38−instance Show Char where

39− show x = strCons x ""

38+instance Show Char where

39+ show x = strCons x ""

4040

41−instance Show String where

41+instance Show String where

4242 show = id

4343

44−instance Show Nat where

44+instance Show Nat where

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

4646

47−instance Show Bool where

47+instance Show Bool where

4848 show True = "True"

4949 show False = "False"

5050

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

163163 ++ ", " ++ prim__toStrB64 b

164164 ++ ">"

165165

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

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

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

168168

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

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

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

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

171171 show' acc [] = acc

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

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

174174

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

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

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

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

177177 show' : Vect n a -> String

178178 show' [] = ""

179179 show' [x] = show x

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

181181

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

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

183183 show Nothing = "Nothing"

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

185185

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

191191instance Functor IO where

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

193193

194−instance Functor Maybe where

194+instance Functor Maybe where

195195 map f (Just x) = Just (f x)

196196 map f Nothing = Nothing

197197

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

203203

204204instance Applicative PrimIO where

205205 pure = prim_io_return

206−

206+

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

208208

209209instance Applicative IO where

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

245245

246246instance Alternative List where

247247 empty = []

248−

248+

249249 (<|>) = (++)

250250

251251---- Monad instances

252252

253−instance Monad PrimIO where

253+instance Monad PrimIO where

254254 b >>= k = prim_io_bind b k

255255

256256instance Monad IO where

257257 b >>= k = io_bind b k

258258

259−instance Monad Maybe where

259+instance Monad Maybe where

260260 Nothing >>= k = Nothing

261261 (Just x) >>= k = k x

262262

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

264264 (Left n) >>= _ = Left n

265265 (Right r) >>= f = f r

266266

267−instance Monad List where

267+instance Monad List where

268268 m >>= f = concatMap f m

269269

270270instance Monad (Vect n) where

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

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

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

349349 else []

350−

350+

351351partial abstract

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

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

359354

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] "..]"

361361 = countFrom start 1

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

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

363363 = countFrom start (next - start)

364364

365365---- More utilities

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

410410

411411---- some basic file handling

412412

413−abstract

413+abstract

414414data File = FHandle Ptr

415415

416416partial stdin : File

417417stdin = FHandle prim__stdin

418418

419419do_fopen : String -> String -> IO Ptr

420−do_fopen f m

420+do_fopen f m

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

422422

423423fopen : String -> String -> IO File

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

425− return (FHandle h)

425+ return (FHandle h)

426426

427427data Mode = Read | Write | ReadWrite

428428

429429partial

430430openFile : String -> Mode -> IO File

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

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

432432 modeStr Read = "r"

433433 modeStr Write = "w"

434434 modeStr ReadWrite = "r+"

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

454454

455455partial

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

457−do_fwrite h s

457+do_fwrite h s

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

459459

460460partial

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

498498 if v then do b

499499 while t b

500500 else return ()

501−

501+

502502partial -- no error checking!

503503readFile : String -> IO String

504504readFile fn = do h <- openFile fn Read

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

508508 where

509509 partial

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

511− readFile' h contents =

511+ readFile' h contents =

512512 do x <- feof h

513513 if not x then do l <- fread h

514514 readFile' h (contents ++ l)

lib/Prelude/Algebra.idr+2−2

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

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

249249

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

251−

252−

251+

252+

253253-- XXX todo:

254254-- Fields and vector spaces.

255255-- Structures where "abs" make sense.

lib/Prelude/Applicative.idr+2−2

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

55

66---- Applicative functors/Idioms

77

8−infixl 2 <$>

8+infixl 2 <$>

99

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

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

1111 pure : a -> f a

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

1313

lib/Prelude/Chars.idr+3−3

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

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

1010

1111isAlpha : Char -> Bool

12−isAlpha x = isUpper x || isLower x

12+isAlpha x = isUpper x || isLower x

1313

1414isDigit : Char -> Bool

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

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

2323 x == '\xa0'

2424

2525isNL : Char -> Bool

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

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

2727

2828toUpper : Char -> Char

29−toUpper x = if (isLower x)

29+toUpper x = if (isLower x)

3030 then (prim__intToChar (prim__charToInt x - 32))

3131 else x

3232

lib/Prelude/Complex.idr+1−1

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

88import Builtins

99import Prelude

1010

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

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

1212

1313infix 6 :+

1414data Complex a = (:+) a a

lib/Prelude/Either.idr+1−1

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

4949

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

5151partitionEithers l = (lefts l, rights l)

52−

52+

5353fromEither : Either a a -> a

5454fromEither (Left l) = l

5555fromEither (Right r) = r

lib/Prelude/Fin.idr+3−3

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

5858integerToFin x = natToFin (cast x)

5959

6060data IsJust : Maybe a -> Type where

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

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

6262

63−fromInteger : (x : Integer) ->

64− {default (ItIsJust _ _)

63+fromInteger : (x : Integer) ->

64+ {default (ItIsJust _ _)

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

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

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

lib/Prelude/Functor.idr+1−1

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

11module Prelude.Functor

22

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

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

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

lib/Prelude/Heap.idr+1−1

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

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

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

129129 _ == _ = False

130−

130+

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

132132 (<+>) = merge

133133

lib/Prelude/List.idr+1−1

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

537537

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

539539hasAnyNilFalse l = ?hasAnyNilFalseBody

540−

540+

541541--------------------------------------------------------------------------------

542542-- Proofs

543543--------------------------------------------------------------------------------

lib/Prelude/Monad.idr+1−1

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

1010

1111infixl 5 >>=

1212

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

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

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

1515

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

lib/Prelude/Vect.idr+2−2

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

99%access public

1010%default total

1111

12−infixr 7 ::

12+infixr 7 ::

1313

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

1515 Nil : Vect Z a

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

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

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

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

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

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

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

114114-- where

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

lib/System.idr+2−2

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

77

88getArgs : IO (List String)

99getArgs = do n <- numArgs

10− ga' [] 0 n

10+ ga' [] 0 n

1111 where

1212 numArgs : IO Int

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

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

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

2424-- otherwise it returns Nothing.

2525getEnv : String -> IO (Maybe String)

26−getEnv key = do

26+getEnv key = do

2727 str_ptr <- getEnv'

2828 is_nil <- nullStr str_ptr

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

22

33module System.Concurrency.Process

44

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

66

77%access public

88

9−abstract

9+abstract

1010data ProcID msg = MkPID Ptr

1111

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

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

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

4444

4545msgWaiting : Process msg Bool

46−msgWaiting = lift checkMsgs

46+msgWaiting = lift checkMsgs

4747

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

4949

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

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

5757

5858recvWithSender : Process msg (ProcID msg, msg)

59−recvWithSender {msg}

59+recvWithSender {msg}

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

6161 return (MkPID senderid, m)

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

22

33module System.Concurrency.Raw

44

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

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

1010

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

12−sendToThread {a} dest val

13− = mkForeign (FFun "idris_sendMessage"

12+sendToThread {a} dest val

13+ = mkForeign (FFun "idris_sendMessage"

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

1515

1616checkMsgs : IO Bool

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

2222-- arrives.

2323

2424getMsg : IO a

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

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

2626 [FPtr] (FAny a)) prim__vm

2727

samples/binary.idr+8−8

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

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

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

2323

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

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

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

2626addBit b0 b0 b0 = bitpair b0 b0

27−addBit b0 b0 b1 = bitpair b0 b1

27+addBit b0 b0 b1 = bitpair b0 b1

2828addBit b0 b1 b0 = bitpair b0 b1

2929addBit b0 b1 b1 = bitpair b1 b0

30−addBit b1 b0 b0 = bitpair b0 b1

31−addBit b1 b0 b1 = bitpair b1 b0

32−addBit b1 b1 b0 = bitpair b1 b0

33−addBit b1 b1 b1 = bitpair b1 b1

30+addBit b1 b0 b0 = bitpair b0 b1

31+addBit b1 b0 b1 = bitpair b1 b0

32+addBit b1 b1 b0 = bitpair b1 b0

33+addBit b1 b1 b1 = bitpair b1 b1

3434

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)

3636adc zero zero carry ?= zero # carry

3737adc (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

3939 adc numx numy carry0 # lsb

4040

4141main : IO ()

samples/interp-alt.idr+7−7

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

2626 Val : (x : Int) -> Expr G TyInt

2727 Lam : Expr (a :: G) t -> Expr G (TyFun a t)

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

3030 Expr G c

3131 If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a

3232 Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b

33−

33+

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

3535 interp env (Var i) = lookup i env

3636 interp env (Val x) = x

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

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

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

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

42−

42+

4343 eId : Expr G (TyFun TyInt TyInt)

4444 eId = Lam (Var fZ)

4545

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

4848

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

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

51−

51+

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

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

54−

54+

5555 eDouble : Expr G (TyFun TyInt TyInt)

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

57−

57+

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

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

6060

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

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

6464

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

66−

66+

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

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

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

samples/interp.idr+5−5

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

2626 Val : (x : Int) -> Expr G TyInt

2727 Lam : Expr (a :: G) t -> Expr G (TyFun a t)

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

3030 Expr G c

3131 If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a

3232 Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b

33−

33+

3434 dsl expr

3535 lambda = Lam

3636 variable = Var

3737 index_first = stop

3838 index_next = pop

39−

39+

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

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

4242

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

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

6060

6161 fromInteger = Val . fromInteger

62−

62+

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

6464 interp env (Var i) = lookup i env

6565 interp env (Val x) = x

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

7777

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

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

80−

80+

8181 eDouble : Expr G (TyFun TyInt TyInt)

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

8383

samples/named_instance.lidr+2−2

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

2121Sort foo using the default comparison operator:

2222

2323> test1 : List Nat

24−> test1 = sort foo

24+> test1 = sort foo

2525

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

2727

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

2929such functions. Hoorah!

3030

3131> test2 : List Nat

32−> test2 = sort @{myord} foo

32+> test2 = sort @{myord} foo

3333

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

3535

samples/reflection.idr+1−1

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

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

6767

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

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

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

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

src/Core/CaseTree.hs+52−52

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

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

22

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

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

44 Phase(..), CaseTree,

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

66

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

2020 | UnmatchedCase String -- ^ error message

2121 | ImpossibleCase -- ^ already checked to be impossible

2222 deriving (Eq, Ord, Functor)

23−{-!

24−deriving instance Binary SC

23+{-!

24+deriving instance Binary SC

2525!-}

2626

2727type SC = SC' Term

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

3232 | SucCase Name (SC' t)

3333 | DefaultCase (SC' t)

3434 deriving (Show, Eq, Ord, Functor)

35−{-!

36−deriving instance Binary CaseAlt

35+{-!

36+deriving instance Binary CaseAlt

3737!-}

3838

3939type CaseAlt = CaseAlt' Term

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

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

4242 show sc = show' 1 sc

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

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

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

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

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

5151

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

5353

54− showA i (ConCase n t args sc)

54+ showA i (ConCase n t args sc)

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

5656 ++ show' (i+1) sc

57− showA i (FnCase n args sc)

57+ showA i (FnCase n args sc)

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

5959 ++ show' (i+1) sc

60− showA i (ConstCase t sc)

60+ showA i (ConstCase t sc)

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

62− showA i (SucCase n sc)

62+ showA i (SucCase n sc)

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

64− showA i (DefaultCase sc)

64+ showA i (DefaultCase sc)

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

66−

66+

6767

6868type CaseTree = SC

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

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

8888

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

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

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

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

9292 termsize n t < 10

9393

9494namesUsed :: SC -> [Name]

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

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

9898 (concatMap (nua ps) alts))

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

100100 nu' ps _ = []

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

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

125125 nu' ps _ = []

126126

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)

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)

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

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

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

132132

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

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

135− nut ps fn@(App f a)

135+ nut ps fn@(App f a)

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

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

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

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

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

153153 ++ directUse t

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

155−directUse fn@(App f a)

155+directUse fn@(App f a)

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

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

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

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

169169 nu' (STerm t) = directUse t

170170 nu' _ = []

171171

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

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

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

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

174174 nua (ConstCase _ sc) = nu' sc

175175 nua (SucCase _ sc) = nu' sc

176176 nua (DefaultCase sc) = nu' sc

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

182182-- Work Right to Left

183183

184184simpleCase :: Bool -> Bool -> Bool ->

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

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

186186 TC CaseDef

187187simpleCase tc cover reflect phase fc cs

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

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

189189 case r of

190190 Impossible -> False

191− _ -> True) cs)

191+ _ -> True) cs)

192192 where

193− sc' tc cover phase fc []

193+ sc' tc cover phase fc []

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

195− sc' tc cover phase fc cs

195+ sc' tc cover phase fc cs

196196 = let proj = phase == RunTime

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

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

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

199199 chkPats = mapM chkAccessible pats in

200200 case chkPats of

201201 OK pats ->

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

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

203203 ns = take numargs args

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

205− (tree, st) = runState

205+ (tree, st) = runState

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

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

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

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

211211 defaultCase True = STerm Erased

212212 defaultCase False = UnmatchedCase "Error"

213213

214− chkAccessible (avs, l, c)

214+ chkAccessible (avs, l, c)

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

216216 | otherwise = do mapM_ (acc l) avs

217217 return (l, c)

218218

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

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

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

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

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

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

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

245245 return $ PCon n t args'

246246 -- n + 1

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

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

248248 [p, Constant (BI 1)]

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

250250 return $ PSuc p'

251251 -- Typecase

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

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

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

254254 return $ PCon n t args'

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

266− if n `elem` ns

267− then return PAny

266+ if n `elem` ns

267+ then return PAny

268268 else do put (n : ns)

269269 return (PV n)

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

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

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

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

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

274274 sc' <- toPat' sc []

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

323323

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

325325

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

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

327327 (numNames [] (map snd xs))

328328

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

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

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

331331 numNames xs (PConst c : ps)

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

335335

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

337337 -> State CS SC

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

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

339339 = do (ts, v) <- get

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

341341 case snd ret of

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

382382 = do g <- altSucGroup args

383383 rest <- altGroups cs

384384 return (g : rest)

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

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

386386 = do g <- altConstGroup c args

387387 rest <- altGroups cs

388388 return (g : rest)

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

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

406406 = do newArgs <- getNewVars r

407407 return (newArgs, addRs rs)

408− where

408+ where

409409 getNewVars [] = return []

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

411411 nsv <- getNewVars ns

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

429429groupCons cs = gc [] cs

430430 where

431431 gc acc [] = return acc

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

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

433433 do acc' <- addGroup p ps res acc

434434 gc acc' cs

435435 addGroup p ps res acc = case p of

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

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

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

441441

442− addg c conargs res []

442+ addg c conargs res []

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

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

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

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

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

457457 match vs alts' err

458458 where

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

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

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

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

462462

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

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

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

489489 | otherwise = applyMap ms nt cn pty args'

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

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

491491 same _ _ = False

492492

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

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

495495

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

497497 -> SC -> SC

498−prune proj (Case n alts)

498+prune proj (Case n alts)

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

500500 case alts' of

501501 [] -> ImpossibleCase

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

521521

522522 projRep :: Name -> Name -> Int -> SC -> SC

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

525525 (map (projRepAlt arg n i) alts)

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

527527 projRep arg n i (ProjCase t alts)

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

540540 projRepAlt arg n i (DefaultCase rhs)

541541 = DefaultCase (projRep arg n i rhs)

542542

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

544544

545545prune _ t = t

546546

src/Core/Constraints.hs+5−5

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

2525

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

2727mkRels [] acc = acc

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

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

2929 | not (ignore c)

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

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

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

3838

3939

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

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

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

4242 where

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

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

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

5050

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

5252 check fc path inc cv

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

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

5454 = Error $ At fc UniverseError

5555 -- FIXME: Make informative

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

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

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

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

60− = return ()

60+ = return ()

6161 | otherwise = case M.lookup cv r of

6262 Nothing -> return ()

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

64−

64+

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

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

6767

src/Core/CoreParser.hs+16−16

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

11{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

22

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

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

44 idrisLexer, maybeWithNS, pDocComment, opChars) where

55

66import Core.TT

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

2121

2222type TokenParser a = PTok.TokenParser a

2323

24−idrisDef = haskellDef {

24+idrisDef = haskellDef {

2525 opStart = iOpStart,

2626 opLetter = iOpLetter,

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

28− reservedOpNames

28+ reservedOpNames

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

30− reservedNames

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

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

30+ reservedNames

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

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

3333 "case", "of", "total", "partial", "mutual",

3434 "infix", "infixl", "infixr", "rewrite",

3535 "where", "with", "syntax", "proof", "postulate",

3636 "using", "namespace", "class", "instance",

3737 "public", "private", "abstract", "implicit",

3838 "quoteGoal"]

39− }

39+ }

4040

4141-- | The characters allowed in operator names

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

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

4646-- <|> letter

4747

4848idrisLexer :: TokenParser a

49−idrisLexer = idrisMakeTokenParser idrisDef

49+idrisLexer = idrisMakeTokenParser idrisDef

5050

5151lexer = idrisLexer

5252

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

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

131131-- namespace.

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

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

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

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

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

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

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

138138

139139pDocComment :: Char -> CParser a String

140−pDocComment c

140+pDocComment c

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

142142 char c

143143 skipMany simpleSpace

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

193193 lchar '.';

194194 sc <- pTerm

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

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

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

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

198198 lchar ')';

199199 symbol "->";

200200 sc <- pTerm

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

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

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

203203 t <- pTerm

204204 lchar ')'

205205 return t)

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

209209 val <- pTerm

210210 sc <- pTerm

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

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

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

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

214214 lchar '=';

215215 val <- pTerm

216216 reserved "in";

217217 sc <- pTerm

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

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

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

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

221221 lchar '.';

222222 sc <- pTerm

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

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

237237 return (c, ty)

238238

239−------ borrowed from Parsec

239+------ borrowed from Parsec

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

241241

242242idrisMakeTokenParser languageDef

243− = PTok.TokenParser{

243+ = PTok.TokenParser{

244244 PTok.identifier = identifier

245245 , PTok.reserved = reserved

246246 , PTok.operator = operator

src/Core/Elaborate.hs+37−37

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

88 tactics out of the primitives.

99-}

1010

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

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

1212 module Core.ProofState) where

1313

1414import Core.ProofState

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

6464 case runStateT elab s of

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

6666 return a

67− Error (At f e) ->

67+ Error (At f e) ->

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

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

7070

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

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

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

184184 if isInj ctxt tm then return ()

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

186− where isInj ctxt (P _ n _)

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

186+ where isInj ctxt (P _ n _)

187187 | isConName n ctxt = True

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

189189 isInj ctxt (Constant _) = True

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

200200unique_hole = unique_hole' False

201201

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

203−unique_hole' reusable n

203+unique_hole' reusable n

204204 = do ES p _ _ <- get

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

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

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

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

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

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

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

213213 return n'

214214 where

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

221221 bound_in _ = []

222222

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

224−uniqueNameCtxt ctxt n hs

224+uniqueNameCtxt ctxt n hs

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

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

227227 | otherwise = return n

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

272272compute :: Elab' aux ()

273273compute = processTactic' Compute

274274

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

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

276276computeLet n = processTactic' (ComputeLet n)

277277

278278simplify :: Elab' aux ()

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

391391 | Var n <- fn

392392 = do ctxt <- get_context

393393 case lookupTy n ctxt of

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

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

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

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

397397

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

415415match_apply = apply' match_fill

416416

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

418−apply' fillt fn imps =

418+apply' fillt fn imps =

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

420420 env <- get_env

421421 g <- goal

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

428428 hs <- get_holes

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

430430 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

432432 else

433433 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) $

435435 unified p

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

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

437437 dropGiven dont hunis hs

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

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

439439 keepGiven dont hunis hs

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

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

442442 ptm <- get_term

443443 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) $

445445 end_unify

446446 ptm <- get_term

447447 return (map (updateUnify unify) args)

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

449449 Just (P _ t _) -> t

450450 _ -> n

451451

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

453−apply2 fn elabs =

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

453+apply2 fn elabs =

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

455455 fill (raw_apply fn (map Var args))

456456 elabArgs args elabs

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

463463 elabArgs ns es

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

465465

466− isJust (Just _) = False

466+ isJust (Just _) = False

467467 isJust _ = True

468468

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

470−apply_elab n args =

470+apply_elab n args =

471471 do ty <- get_type (Var n)

472472 ctxt <- get_context

473473 env <- get_env

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

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

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

499499

500− elabClaims failed r []

500+ elabClaims failed r []

501501 | null failed = return ()

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

503503 else return ()

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

515515

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

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

518−checkPiGoal n

518+checkPiGoal n

519519 = do g <- goal

520520 case g of

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

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

551551 complete_fill

552552 hs <- get_holes

553553 env <- get_env

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.

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.

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

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

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

@@ -569,7 +569,7 @@ arg n tyhole = do ty <- unique_hole tyhole

569569

570570-- try a tactic, if it adds any unification problem, return an error

571571no_errors :: Elab' aux () -> Elab' aux ()

572−no_errors tac

572+no_errors tac

573573 = do ps <- get_probs

574574 tac

575575 ps' <- get_probs

@@ -594,11 +594,11 @@ try' t1 t2 proofSearch

594594 Error e1 -> if recoverableErr e1 then

595595 do case runStateT t2 s of

596596 OK (v, s') -> do put s'; return v

597− Error e2 -> if score e1 >= score e2

598− then lift (tfail e1)

597+ Error e2 -> if score e1 >= score e2

598+ then lift (tfail e1)

599599 else lift (tfail e2)

600600 else lift (tfail e1)

601− where recoverableErr err@(CantUnify r _ _ _ _ _)

601+ where recoverableErr err@(CantUnify r _ _ _ _ _)

602602 = -- traceWhen r (show err) $

603603 r || proofSearch

604604 recoverableErr (ProofSearchFail _) = False

@@ -614,7 +614,7 @@ tryAll :: [(Elab' aux a, String)] -> Elab' aux a

614614tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

615615 where

616616 cantResolve :: Elab' aux a

617− cantResolve = lift $ tfail $ CantResolveAlts (map snd xs)

617+ cantResolve = lift $ tfail $ CantResolveAlts (map snd xs)

618618

619619 tryAll' :: [Elab' aux a] -> -- successes

620620 Int -> -- most problems

@@ -624,12 +624,12 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

624624 tryAll' [res] pmax _ [] = res

625625 tryAll' (_:_) pmax _ [] = cantResolve

626626 tryAll' [] pmax (f, _) [] = f

627− tryAll' cs pmax f (x:xs)

627+ tryAll' cs pmax f (x:xs)

628628 = do s <- get

629629 ps <- get_probs

630630 case prunStateT pmax True ps x s of

631− OK ((v, newps), s') ->

632− do let cs' = if (newps < pmax)

631+ OK ((v, newps), s') ->

632+ do let cs' = if (newps < pmax)

633633 then [do put s'; return v]

634634 else (do put s'; return v) : cs

635635 tryAll' cs' newps f xs

@@ -643,10 +643,10 @@ tryAll xs = tryAll' [] 999999 (cantResolve, 0) (map fst xs)

643643 if (s >= i) then (lift (tfail err), s)

644644 else (f, i)

645645

646−prunStateT pmax zok ps x s

646+prunStateT pmax zok ps x s

647647 = case runStateT x s of

648− OK (v, s'@(ES (p, _) _ _)) ->

649− let newps = length (problems p) - length ps

648+ OK (v, s'@(ES (p, _) _ _)) ->

649+ let newps = length (problems p) - length ps

650650 newpmax = if newps < 0 then 0 else newps in

651651 if (newpmax > pmax || (not zok && newps > 0)) -- length ps == 0 && newpmax > 0))

652652 then case reverse (problems p) of

@@ -655,7 +655,7 @@ prunStateT pmax zok ps x s

655655 Error e -> Error e

656656

657657qshow :: Fails -> String

658−qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

658+qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

659659

660660dumpprobs [] = ""

661661dumpprobs ((_,_,_,e):es) = show e ++ "\n" ++ dumpprobs es

src/Core/Evaluate.hs+114−114

@@ -6,9 +6,9 @@ module Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,

66 Def(..), CaseInfo(..), CaseDefs(..),

77 Accessibility(..), Totality(..), PReason(..),

88 Context, initContext, ctxtAlist, uconstraints, next_tvar,

9− addToCtxt, setAccess, setTotal, addCtxtDef, addTyDecl,

9+ addToCtxt, setAccess, setTotal, addCtxtDef, addTyDecl,

1010 addDatatype, addCasedef, simplifyCasedef, addOperator,

11− lookupNames, lookupTy, lookupP, lookupDef, lookupVal,

11+ lookupNames, lookupTy, lookupP, lookupDef, lookupVal,

1212 lookupTotal, lookupTyEnv, isDConName, isTConName, isConName, isFnName,

1313 Value(..), Quote(..), initEval) where

1414

@@ -25,9 +25,9 @@ data EvalState = ES { limited :: [(Name, Int)],

2525

2626type Eval a = State EvalState a

2727

28−data EvalOpt = Spec

29− | HNF

30− | Simplify

28+data EvalOpt = Spec

29+ | HNF

30+ | Simplify

3131 | AtREPL

3232 deriving (Show, Eq)

3333

@@ -56,19 +56,19 @@ instance Show (a -> b) where

5656

5757-- THE EVALUATOR ------------------------------------------------------------

5858

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

6060-- indexed.

6161-- i.e. it's an intermediate environment that we have while type checking or

6262-- while building a proof.

6363

6464-- | Normalise fully type checked terms (so, assume all names/let bindings resolved)

6565normaliseC :: Context -> Env -> TT Name -> TT Name

66−normaliseC ctxt env t

66+normaliseC ctxt env t

6767 = evalState (do val <- eval False ctxt [] env t []

6868 quote 0 val) initEval

6969

7070normaliseAll :: Context -> Env -> TT Name -> TT Name

71−normaliseAll ctxt env t

71+normaliseAll ctxt env t

7272 = evalState (do val <- eval False ctxt [] env t [AtREPL]

7373 quote 0 val) initEval

7474

@@ -76,38 +76,38 @@ normalise :: Context -> Env -> TT Name -> TT Name

7676normalise = normaliseTrace False

7777

7878normaliseTrace :: Bool -> Context -> Env -> TT Name -> TT Name

79−normaliseTrace tr ctxt env t

79+normaliseTrace tr ctxt env t

8080 = evalState (do val <- eval tr ctxt [] (map finalEntry env) (finalise t) []

8181 quote 0 val) initEval

8282

8383specialise :: Context -> Env -> [(Name, Int)] -> TT Name -> TT Name

84−specialise ctxt env limits t

85− = evalState (do val <- eval False ctxt []

86− (map finalEntry env) (finalise t)

84+specialise ctxt env limits t

85+ = evalState (do val <- eval False ctxt []

86+ (map finalEntry env) (finalise t)

8787 [Spec]

8888 quote 0 val) (initEval { limited = limits })

8989

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

9191-- inline (and probably shouldn't reduce lets?)

9292-- 20130908: now only used to reduce for totality checking. Inlining should

9393-- be done elsewhere.

9494

9595simplify :: Context -> Env -> TT Name -> TT Name

96−simplify ctxt env t

96+simplify ctxt env t

9797 = evalState (do val <- eval False ctxt [(UN "lazy", 0),

9898 (UN "assert_smaller", 0),

9999 (UN "par", 0),

100100 (UN "prim__syntactic_eq", 0),

101− (UN "fork", 0)]

102− (map finalEntry env) (finalise t)

101+ (UN "fork", 0)]

102+ (map finalEntry env) (finalise t)

103103 [Simplify]

104104 quote 0 val) initEval

105105

106106-- | Reduce a term to head normal form

107107hnf :: Context -> Env -> TT Name -> TT Name

108−hnf ctxt env t

109− = evalState (do val <- eval False ctxt []

110− (map finalEntry env)

108+hnf ctxt env t

109+ = evalState (do val <- eval False ctxt []

110+ (map finalEntry env)

111111 (finalise t) [HNF]

112112 quote 0 val) initEval

113113

@@ -136,7 +136,7 @@ usable True n ns

136136 Just 0 -> return (False, ns)

137137 Just i -> return (True, ns)

138138 _ -> return (False, ns)

139−usable False n ns

139+usable False n ns

140140 = case lookup n ns of

141141 Just 0 -> return (False, ns)

142142 Just i -> return $ (True, (n, abs (i-1)) : filter (\ (n', _) -> n/=n') ns)

@@ -157,58 +157,58 @@ deduct n = do ES ls num <- get

157157-- a name. The corresponding pair in the state is the maximum number of

158158-- unfoldings overall.

159159

160−eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name ->

160+eval :: Bool -> Context -> [(Name, Int)] -> Env -> TT Name ->

161161 [EvalOpt] -> Eval Value

162162eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

163163 spec = Spec `elem` opts

164− simpl = Simplify `elem` opts

164+ simpl = Simplify `elem` opts

165165 atRepl = AtREPL `elem` opts

166166 hnf = HNF `elem` opts

167167

168168 -- returns 'True' if the function should block

169169 -- normal evaluation should return false

170− blockSimplify (CaseInfo inl dict) n stk

171− | Simplify `elem` opts

170+ blockSimplify (CaseInfo inl dict) n stk

171+ | Simplify `elem` opts

172172 = (not (inl || dict) || elem n stk)

173173 || (n == UN "prim__syntactic_eq")

174174 | otherwise = False

175175

176176 ev ntimes stk top env (P _ n ty)

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)

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)

179179 | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty)

180− | otherwise

180+ | otherwise

181181 = do (u, ntimes) <- usable spec n ntimes_in

182182 if u then

183− do let val = lookupDefAcc n atRepl ctxt

183+ do let val = lookupDefAcc n atRepl ctxt

184184 case val of

185− [(Function _ tm, Public)] ->

185+ [(Function _ tm, Public)] ->

186186 ev ntimes (n:stk) True env tm

187187 [(TyDecl nt ty, _)] -> do vty <- ev ntimes stk True env ty

188188 return $ VP nt n vty

189− [(CaseOp ci _ _ _ cd, acc)]

189+ [(CaseOp ci _ _ _ cd, acc)]

190190 | acc == Public &&

191191 null (fst (cases_totcheck cd)) -> -- unoptimised version

192192 let (_, tree) = if simpl then cases_totcheck cd

193193 else cases_compiletime cd in

194194 if blockSimplify ci n stk

195195 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

197197 case c of

198198 (Nothing, _) -> liftM (VP Ref n) (ev ntimes stk top env ty)

199199 (Just v, _) -> return v

200200 _ -> liftM (VP Ref n) (ev ntimes stk top env ty)

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

203203 = 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)

205205 | i < length env && i >= 0 = return $ env !! i

206− | otherwise = return $ VV i

206+ | otherwise = return $ VV i

207207 ev ntimes stk top env (Bind n (Let t v) sc)

208208 = do v' <- ev ntimes stk top env v --(finalise v)

209209 sc' <- ev ntimes stk top (v' : env) sc

210210 wknV (-1) sc'

211−-- | otherwise

211+-- | otherwise

212212-- = do t' <- ev ntimes stk top env t

213213-- v' <- ev ntimes stk top env v --(finalise v)

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

223223 v' <- ev ntimes stk top env (finalise v)

224224 sc' <- ev ntimes stk top (v' : env) sc

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

227227 = do b' <- vbind env b

228228 return $ VBind True -- (vinstances 0 sc < 2)

229229 n b' (\x -> ev ntimes stk False (x:env) sc)

230− where vbind env t

231−-- | simpl

232−-- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

233−-- stk top env (finalise tm)) t

234−-- | otherwise

230+ where vbind env t

231+-- | simpl

232+-- = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

233+-- stk top env (finalise tm)) t

234+-- | otherwise

235235 = 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)

237237 = do f' <- ev ntimes stk False env f

238238 a' <- ev ntimes stk False env a

239239 evApply ntimes stk top env [a'] f'

240240 ev ntimes stk top env (Constant c) = return $ VConstant c

241241 ev ntimes stk top env Erased = return VErased

242242 ev ntimes stk top env (TType i) = return $ VType i

243−

243+

244244 evApply ntimes stk top env args (VApp f a)

245245 = evApply ntimes stk top env (a:args) f

246− evApply ntimes stk top env args f

246+ evApply ntimes stk top env args f

247247 = apply ntimes stk top env f args

248248

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)

250250 = do a' <- sc a

251− app <- apply ntimes stk top env a' as

251+ app <- apply ntimes stk top env a' as

252252 wknV (-1) app

253253 apply ntimes_in stk top env f@(VP Ref n ty) args

254254 | not top && hnf = case args of

255255 [] -> return f

256256 _ -> return $ unload env f args

257− | otherwise

257+ | otherwise

258258 = do (u, ntimes) <- usable spec n ntimes_in

259− if u then

259+ if u then

260260 do let val = lookupDefAcc n atRepl ctxt

261261 case val of

262262 [(CaseOp ci _ _ _ cd, acc)]

@@ -286,19 +286,19 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

286286

287287-- specApply stk env f@(VP Ref n ty) args

288288-- = case lookupCtxt n statics of

289−-- [as] -> if or as

290−-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $

289+-- [as] -> if or as

290+-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $

291291-- return $ unload env f args

292292-- else return $ unload env f args

293293-- _ -> return $ unload env f args

294294-- specApply stk env f args = return $ unload env f args

295295

296− unload :: [Value] -> Value -> [Value] -> Value

296+ unload :: [Value] -> Value -> [Value] -> Value

297297 unload env f [] = f

298298 unload env f (a:as) = unload env (VApp f a) as

299299

300300 evCase ntimes n stk top env ns args tree

301− | length ns <= length args

301+ | length ns <= length args

302302 = do let args' = take (length ns) args

303303 let rest = drop (length ns) args

304304 when spec $ deduct n -- successful, so deduct usages

@@ -307,12 +307,12 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

307307 return (t, rest)

308308 | otherwise = return (Nothing, args)

309309

310− evTree :: [(Name, Int)] -> [Name] -> Bool ->

310+ evTree :: [(Name, Int)] -> [Name] -> Bool ->

311311 [Value] -> [(Name, Value)] -> SC -> Eval (Maybe Value)

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

314314 = do let etm = pToVs (map fst amap) tm

315− etm' <- ev ntimes stk (not (conHeaded tm))

315+ etm' <- ev ntimes stk (not (conHeaded tm))

316316 (map snd amap ++ env) etm

317317 return $ Just etm'

318318 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

327327 _ -> return Nothing

328328 evTree ntimes stk top env amap ImpossibleCase = return Nothing

329329

330− conHeaded tm@(App _ _)

330+ conHeaded tm@(App _ _)

331331 | (P (DCon _ _) _ _, args) <- unApply tm = True

332332 conHeaded t = False

333333

@@ -336,14 +336,14 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

336336 chooseAlt env f' (getValArgs f')

337337 alts amap

338338

339− chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] ->

339+ chooseAlt :: [Value] -> Value -> (Value, [Value]) -> [CaseAlt] ->

340340 [(Name, Value)] ->

341341 Eval (Maybe ([(Name, Value)], SC))

342342 chooseAlt env _ (VP (DCon i a) _ _, args) alts amap

343343 | Just (ns, sc) <- findTag i alts = return $ Just (updateAmap (zip ns args) amap, sc)

344344 | Just v <- findDefault alts = return $ Just (amap, v)

345345 chooseAlt env _ (VP (TCon i a) _ _, args) alts amap

346− | Just (ns, sc) <- findTag i alts

346+ | Just (ns, sc) <- findTag i alts

347347 = return $ Just (updateAmap (zip ns args) amap, sc)

348348 | Just v <- findDefault alts = return $ Just (amap, v)

349349 chooseAlt env _ (VConstant c, []) alts amap

@@ -358,7 +358,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

358358 = do t' <- t (VV 0) -- we know it's not in scope or it's not a pattern

359359 return $ Just (updateAmap (zip ns [s, t']) amap, sc)

360360 chooseAlt _ _ _ alts amap

361− | Just v <- findDefault alts

361+ | Just v <- findDefault alts

362362 = if (any fnCase alts)

363363 then return $ Just (amap, v)

364364 else return Nothing

@@ -370,7 +370,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

370370 -- Replace old variable names in the map with new matches

371371 -- (This is possibly unnecessary since we make unique names and don't

372372 -- allow repeated variables...?)

373− updateAmap newm amap

373+ updateAmap newm amap

374374 = newm ++ filter (\ (x, _) -> not (elem x (map fst newm))) amap

375375 findTag i [] = Nothing

376376 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

382382

383383 findDefault [] = Nothing

384384 findDefault (DefaultCase sc : xs) = Just sc

385− findDefault (_ : xs) = findDefault xs

385+ findDefault (_ : xs) = findDefault xs

386386

387387 findSuc c [] = Nothing

388388 findSuc (BI val) (SucCase n sc : _)

@@ -393,10 +393,10 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

393393 findConst c (ConstCase c' v : xs) | c == c' = Just v

394394 findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v

395395 findConst (AType ATFloat) (ConCase n 2 [] 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

396+ findConst (AType (ATInt ITChar)) (ConCase n 3 [] v : xs) = Just v

397+ findConst StrType (ConCase n 4 [] v : xs) = Just v

398398 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

400400 findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs)

401401 | tag == 7 + fromEnum ity = Just v

402402 findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs)

@@ -430,7 +430,7 @@ instance Quote Value where

430430 b' <- quoteB b

431431 liftM (Bind n b') (quote (i+1) sc')

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

434434 = do sc' <- quote i sc

435435 t' <- quote i t

436436 v' <- quote i v

@@ -455,7 +455,7 @@ convEq' ctxt x y = evalStateT (convEq ctxt x y) (0, [])

455455convEq :: Context -> TT Name -> TT Name -> StateT UCs TC Bool

456456convEq ctxt = ceq [] where

457457 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 _)

459459 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

460460 | otherwise = sameDefs ps x y

461461 ceq ps x (Bind n (Lam t) (App y (V 0))) = ceq ps x y

@@ -465,9 +465,9 @@ convEq ctxt = ceq [] where

465465 ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y

466466 | n == n' = ceq ps x y

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

469469 = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys)

470− where

470+ where

471471 ceqB ps (Let v t) (Let v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

472472 ceqB ps (Guess v t) (Guess v' t') = liftM2 (&&) (ceq ps v v') (ceq ps t t')

473473 ceqB ps b b' = ceq ps (binderTy b) (binderTy b')

@@ -501,7 +501,7 @@ convEq ctxt = ceq [] where

501501 sameDefs ps x y = case (lookupDef x ctxt, lookupDef y ctxt) of

502502 ([Function _ xdef], [Function _ ydef])

503503 -> ceq ((x,y):ps) xdef ydef

504− ([CaseOp _ _ _ _ xd],

504+ ([CaseOp _ _ _ _ xd],

505505 [CaseOp _ _ _ _ yd])

506506 -> let (_, xdef) = cases_compiletime xd

507507 (_, ydef) = cases_compiletime yd in

@@ -509,25 +509,25 @@ convEq ctxt = ceq [] where

509509 _ -> return False

510510

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

513513-- evaluator

514514

515515spec :: 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"

517517

518518-- CONTEXTS -----------------------------------------------------------------

519519

520520{-| A definition is either a simple function (just an expression with a type),

521521 a constant, which could be a data or type constructor, an axiom or as an

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

524524 A CaseOp is a function defined by a simple case tree -}

525−

525+

526526data Def = Function Type Term

527− | TyDecl NameType Type

527+ | TyDecl NameType Type

528528 | Operator Type Int ([Value] -> Maybe Value)

529− | CaseOp CaseInfo

530− Type

529+ | CaseOp CaseInfo

530+ Type

531531 [Either Term (Term, Term)] -- original definition

532532 [([Name], Term, Term)] -- simplified for totality check definition

533533 CaseDefs

@@ -546,13 +546,13 @@ data CaseInfo = CaseInfo {

546546 tc_dictionary :: Bool

547547 }

548548

549−{-!

550−deriving instance Binary Def

549+{-!

550+deriving instance Binary Def

551551!-}

552−{-!

552+{-!

553553deriving instance Binary CaseInfo

554554!-}

555−{-!

555+{-!

556556deriving instance Binary CaseDefs

557557!-}

558558

@@ -560,11 +560,11 @@ instance Show Def where

560560 show (Function ty tm) = "Function: " ++ show (ty, tm)

561561 show (TyDecl nt ty) = "TyDecl: " ++ show nt ++ " " ++ show ty

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

564564 = let (ns, sc) = cases_compiletime cd

565− (ns_t, sc_t) = cases_totcheck cd

565+ (ns_t, sc_t) = cases_totcheck cd

566566 (ns', sc') = cases_runtime cd in

567− "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++

567+ "Case: " ++ show ty ++ " " ++ show ps ++ "\n" ++

568568 "TOTALITY CHECK TIME:\n\n" ++

569569 show ns_t ++ " " ++ show sc_t ++ "\n\n" ++

570570 "COMPILE TIME:\n\n" ++

@@ -580,7 +580,7 @@ instance Binary (a -> b) where

580580 put x = return ()

581581 get = error "Getting a function"

582582

583−-------

583+-------

584584

585585-- Frozen => doesn't reduce

586586-- Hidden => doesn't reduce and invisible to type checker

@@ -610,7 +610,7 @@ instance Show Totality where

610610 show (Partial NotProductive) = "not productive"

611611 show (Partial BelieveMe) = "not total due to use of believe_me in proof"

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

614614 showSep " --> " (map show ns)

615615

616616{-!

@@ -627,10 +627,10 @@ deriving instance Binary PReason

627627

628628-- | Contexts used for global definitions and for proof state. They contain

629629-- universe constraints and existing definitions.

630−data Context = MkContext {

630+data Context = MkContext {

631631 uconstraints :: [UConstraint],

632632 next_tvar :: Int,

633− definitions :: Ctxt (Def, Accessibility, Totality)

633+ definitions :: Ctxt (Def, Accessibility, Totality)

634634 } deriving Show

635635

636636-- | The initial empty context

@@ -643,10 +643,10 @@ ctxtAlist ctxt = map (\(n, (d, a, t)) -> (n, d)) $ toAlist (definitions ctxt)

643643veval ctxt env t = evalState (eval False ctxt [] env t []) initEval

644644

645645addToCtxt :: Name -> Term -> Type -> Context -> Context

646−addToCtxt n tm ty uctxt

647− = let ctxt = definitions uctxt

646+addToCtxt n tm ty uctxt

647+ = let ctxt = definitions uctxt

648648 ctxt' = addDef n (Function ty tm, Public, Unchecked) ctxt in

649− uctxt { definitions = ctxt' }

649+ uctxt { definitions = ctxt' }

650650

651651setAccess :: Name -> Accessibility -> Context -> Context

652652setAccess n a uctxt

@@ -666,54 +666,54 @@ addCtxtDef n d c = let ctxt = definitions c

666666 c { definitions = ctxt' }

667667

668668addTyDecl :: Name -> NameType -> Type -> Context -> Context

669−addTyDecl n nt ty uctxt

669+addTyDecl n nt ty uctxt

670670 = let ctxt = definitions uctxt

671671 ctxt' = addDef n (TyDecl nt ty, Public, Unchecked) ctxt in

672672 uctxt { definitions = ctxt' }

673673

674674addDatatype :: Datatype Name -> Context -> Context

675675addDatatype (Data n tag ty cons) uctxt

676− = let ctxt = definitions uctxt

676+ = let ctxt = definitions uctxt

677677 ty' = normalise uctxt [] ty

678− ctxt' = addCons 0 cons (addDef n

678+ ctxt' = addCons 0 cons (addDef n

679679 (TyDecl (TCon tag (arity ty')) ty, Public, Unchecked) ctxt) in

680680 uctxt { definitions = ctxt' }

681681 where

682682 addCons tag [] ctxt = ctxt

683− addCons tag ((n, ty) : cons) ctxt

683+ addCons tag ((n, ty) : cons) ctxt

684684 = let ty' = normalise uctxt [] ty in

685685 addCons (tag+1) cons (addDef n

686686 (TyDecl (DCon tag (arity ty')) ty, Public, Unchecked) ctxt)

687687

688688-- FIXME: Too many arguments! Refactor all these Bools.

689689addCasedef :: Name -> CaseInfo -> Bool -> Bool -> Bool -> Bool ->

690− [Either Term (Term, Term)] ->

690+ [Either Term (Term, Term)] ->

691691 [([Name], Term, Term)] -> -- totality

692692 [([Name], Term, Term)] -> -- compile time

693− [([Name], Term, Term)] -> -- inlined

693+ [([Name], Term, Term)] -> -- inlined

694694 [([Name], Term, Term)] -> -- run time

695695 Type -> Context -> Context

696696addCasedef n ci@(CaseInfo alwaysInline tcdict)

697− tcase covering reflect asserted ps_in

698− ps_tot ps_inl ps_ct ps_rt ty uctxt

697+ tcase covering reflect asserted ps_in

698+ ps_tot ps_inl ps_ct ps_rt ty uctxt

699699 = let ctxt = definitions uctxt

700700 access = case lookupDefAcc n False uctxt of

701701 [(_, acc)] -> acc

702702 _ -> Public

703703 ctxt' = case (simpleCase tcase covering reflect CompileTime emptyFC ps_tot,

704− simpleCase tcase covering reflect CompileTime emptyFC ps_ct,

705− simpleCase tcase covering reflect CompileTime emptyFC ps_inl,

704+ simpleCase tcase covering reflect CompileTime emptyFC ps_ct,

705+ simpleCase tcase covering reflect CompileTime emptyFC ps_inl,

706706 simpleCase tcase covering reflect RunTime emptyFC ps_rt) of

707− (OK (CaseDef args_tot sc_tot _),

707+ (OK (CaseDef args_tot sc_tot _),

708708 OK (CaseDef args_ct sc_ct _),

709709 OK (CaseDef args_inl sc_inl _),

710− OK (CaseDef args_rt sc_rt _)) ->

710+ OK (CaseDef args_rt sc_rt _)) ->

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

713713 inlr = inl || small n args_rt sc_rt

714− cdef = CaseDefs (args_tot, sc_tot)

715− (args_ct, sc_ct)

716− (args_inl, sc_inl)

714+ cdef = CaseDefs (args_tot, sc_tot)

715+ (args_ct, sc_ct)

716+ (args_inl, sc_inl)

717717 (args_rt, sc_rt) in

718718 addDef n (CaseOp (ci { case_inlinable = inlc })

719719 ty ps_in ps_tot cdef,

@@ -732,17 +732,17 @@ simplifyCasedef n uctxt

732732 pdef = map debind ps_in' in

733733 case simpleCase False True False CompileTime emptyFC pdef of

734734 OK (CaseDef args sc _) ->

735− addDef n (CaseOp ci

735+ addDef n (CaseOp ci

736736 ty ps_in' ps (cd { cases_totcheck = (args, sc) }),

737− acc, tot) ctxt

737+ acc, tot) ctxt

738738 Error err -> error (show err)

739739 _ -> ctxt in

740740 uctxt { definitions = ctxt' }

741− where

742− depat acc (Bind n (PVar t) sc)

741+ where

742+ depat acc (Bind n (PVar t) sc)

743743 = depat (n : acc) (instantiate (P Bound n t) sc)

744744 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

746746 (_, y') = depat [] y in

747747 (vs, x', y')

748748 debind (Left x) = let (vs, x') = depat [] x in

@@ -750,10 +750,10 @@ simplifyCasedef n uctxt

750750 simpl (Right (x, y)) = Right (x, simplify uctxt [] y)

751751 simpl t = t

752752

753−addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) ->

753+addOperator :: Name -> Type -> Int -> ([Value] -> Maybe Value) ->

754754 Context -> Context

755755addOperator n ty a op uctxt

756− = let ctxt = definitions uctxt

756+ = let ctxt = definitions uctxt

757757 ctxt' = addDef n (Operator ty a op, Public, Unchecked) ctxt in

758758 uctxt { definitions = ctxt' }

759759

@@ -836,7 +836,7 @@ lookupVal n ctxt

836836lookupTyEnv :: Name -> Env -> Maybe (Int, Type)

837837lookupTyEnv n env = li n 0 env where

838838 li n i [] = Nothing

839− li n i ((x, b): xs)

839+ li n i ((x, b): xs)

840840 | n == x = Just (i, binderTy b)

841841 | otherwise = li n (i+1) xs

842842

src/Core/Execute.hs+7−7

@@ -247,15 +247,15 @@ execApp' env ctxt con@(EP _ (UN "prim_io_return") _) args@(tp:v:rest) =

247247

248248-- Special cases arising from not having access to the C RTS in the interpreter

249249execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str arg):_:rest)

250− | Just (FFun "putStr" _ _) <- foreignFromTT fn

250+ | Just (FFun "putStr" _ _) <- foreignFromTT fn

251251 = do execIO (putStr arg)

252252 execApp' env ctxt ioUnit rest

253253execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:_:EHandle h:_:rest)

254− | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

254+ | Just (FFun "idris_readStr" _ _) <- foreignFromTT fn

255255 = do contents <- execIO $ hGetLine h

256256 execApp' env ctxt (EConstant (Str (contents ++ "\n"))) rest

257257execApp' 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

259259 = do m <- case mode of

260260 "r" -> return ReadMode

261261 "w" -> return WriteMode

@@ -268,25 +268,25 @@ execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:EConstant (Str f):EConstan

268268 execApp' env ctxt (ioWrap (EHandle h)) (tail rest)

269269

270270execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

271− | Just (FFun "fileEOF" _ _) <- foreignFromTT fn

271+ | Just (FFun "fileEOF" _ _) <- foreignFromTT fn

272272 = do eofp <- execIO $ hIsEOF h

273273 let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

274274 execApp' env ctxt res (tail rest)

275275

276276execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EHandle h):rest)

277− | Just (FFun "fileClose" _ _) <- foreignFromTT fn

277+ | Just (FFun "fileClose" _ _) <- foreignFromTT fn

278278 = do execIO $ hClose h

279279 execApp' env ctxt ioUnit (tail rest)

280280

281281execApp' env ctxt (EP _ (UN "mkForeignPrim") _) (_:fn:(EPtr p):rest)

282− | Just (FFun "isNull" _ _) <- foreignFromTT fn

282+ | Just (FFun "isNull" _ _) <- foreignFromTT fn

283283 = let res = ioWrap . EConstant . I $

284284 if p == nullPtr then 1 else 0

285285 in execApp' env ctxt res (tail rest)

286286

287287-- Throw away the 'World' argument to the foreign function

288288

289−execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs)

289+execApp' env ctxt f@(EP _ (UN "mkForeignPrim") _) args@(ty:fn:xs)

290290 | Just (FFun f argTs retT) <- foreignFromTT fn

291291 , length xs >= length argTs =

292292 do let (args', xs') = (take (length argTs) xs, -- foreign args

src/Core/ProofShell.hs+11−11

@@ -15,7 +15,7 @@ import Idris.AbsSyntaxTree (Idris)

1515

1616import Util.Pretty

1717

18−data ShellState = ShellState

18+data ShellState = ShellState

1919 { ctxt :: Context,

2020 prf :: Maybe ProofState,

2121 deferred :: [(Name, ProofState)],

@@ -25,18 +25,18 @@ data ShellState = ShellState

2525initState c = ShellState c Nothing [] False

2626

2727processCommand :: Command -> ShellState -> (ShellState, String)

28−processCommand (Theorem n ty) state

28+processCommand (Theorem n ty) state

2929 = case check (ctxt state) [] ty of

30− OK (gl, t) ->

30+ OK (gl, t) ->

3131 case isType (ctxt state) [] t of

3232 OK _ -> (state { prf = Just (newProof n (ctxt state) gl) }, "")

3333 _ -> (state, "Goal is not a type")

3434 err -> (state, show err)

3535processCommand Quit state = (state { exitNow = True }, "Bye bye")

36−processCommand (Eval t) state =

36+processCommand (Eval t) state =

3737 case check (ctxt state) [] t of

3838 OK (val, ty) ->

39− let nf = normalise (ctxt state) [] val

39+ let nf = normalise (ctxt state) [] val

4040 tnf = normalise (ctxt state) [] ty in

4141 (state, show nf ++ " : " ++ show ty)

4242 err -> (state, show err)

@@ -44,10 +44,10 @@ processCommand (Print n) state =

4444 case lookupDef n (ctxt state) of

4545 [tm] -> (state, show tm)

4646 _ -> (state, "No such name")

47−processCommand (Tac e) state

47+processCommand (Tac e) state

4848 | Just ps <- prf state = case execElab () e ps of

49− OK (ES (ps', _) resp _) ->

50− if (not (done ps'))

49+ OK (ES (ps', _) resp _) ->

50+ if (not (done ps'))

5151 then (state { prf = Just ps' }, resp)

5252 else (state { prf = Nothing,

5353 ctxt = addToCtxt (thname ps')

@@ -60,10 +60,10 @@ processCommand (Tac e) state

6060runShell :: ShellState -> Idris ShellState

6161runShell st = runInputT defaultSettings $ runShell' st

6262 where

63− runShell' st = do (prompt, parser) <-

64− maybe (return ("TT# ", parseCommand))

63+ runShell' st = do (prompt, parser) <-

64+ maybe (return ("TT# ", parseCommand))

6565 (\st -> do outputStrLn . render . pretty $ st

66− return (show (thname st) ++ "# ", parseTactic))

66+ return (show (thname st) ++ "# ", parseTactic))

6767 (prf st)

6868 x <- getInputLine prompt

6969 cmd <- case x of

src/Core/ProofState.hs+104−104

@@ -5,7 +5,7 @@

55 evaluation/checking inside the proof system, etc. --}

66

77module Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,

8− Tactic(..), Goal(..), processTactic,

8+ Tactic(..), Goal(..), processTactic,

99 dropGiven, keepGiven) where

1010

1111import Core.Typecheck

@@ -31,7 +31,7 @@ data ProofState = PS { thname :: Name,

3131 notunified :: [(Name, Term)],

3232 solved :: Maybe (Name, Term),

3333 problems :: Fails,

34− injective :: [Name],

34+ injective :: [Name],

3535 deferred :: [Name], -- names we'll need to define

3636 instances :: [Name], -- instance arguments (for type classes)

3737 previous :: Maybe ProofState, -- for undo

@@ -40,7 +40,7 @@ data ProofState = PS { thname :: Name,

4040 unifylog :: Bool,

4141 done :: Bool

4242 }

43−

43+

4444data Goal = GD { premises :: Env,

4545 goalType :: Binder Term

4646 }

@@ -88,27 +88,27 @@ data Tactic = Attack

8888-- Some utilites on proof and tactic states

8989

9090instance Show ProofState where

91− show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _)

91+ show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _ _)

9292 = show nm ++ ": no more goals"

93− show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _)

93+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _ _)

9494 = let OK g = goal (Just h) tm

9595 wkenv = premises g in

9696 "Other goals: " ++ show hs ++ "\n" ++

9797 showPs wkenv (reverse wkenv) ++ "\n" ++

98− "-------------------------------- (" ++ show nm ++

98+ "-------------------------------- (" ++ show nm ++

9999 ") -------\n " ++

100100 show h ++ " : " ++ showG wkenv (goalType g) ++ "\n"

101101 where showPs env [] = ""

102− showPs env ((n, Let t v):bs)

103− = " " ++ show n ++ " : " ++

102+ showPs env ((n, Let t v):bs)

103+ = " " ++ show n ++ " : " ++

104104 showEnv env ({- normalise ctxt env -} t) ++ " = " ++

105105 showEnv env ({- normalise ctxt env -} v) ++

106106 "\n" ++ showPs env bs

107− showPs env ((n, b):bs)

108− = " " ++ show n ++ " : " ++

109− showEnv env ({- normalise ctxt env -} (binderTy b)) ++

107+ showPs env ((n, b):bs)

108+ = " " ++ show n ++ " : " ++

109+ showEnv env ({- normalise ctxt env -} (binderTy b)) ++

110110 "\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) ++

112112 " =?= " ++ showEnv ps v

113113 showG ps b = showEnv ps (binderTy b)

114114

@@ -130,7 +130,7 @@ instance Pretty ProofState where

130130 if size v > breakingSize then

131131 prettyEnv ps t <+> text "=?=" $$

132132 nest nestingSize (prettyEnv ps v)

133− else

133+ else

134134 prettyEnv ps t <+> text "=?=" <+> prettyEnv ps v

135135 prettyGoal ps b = prettyEnv ps $ binderTy b

136136

@@ -158,14 +158,14 @@ hole (Hole _) = True

158158hole (Guess _ _) = True

159159hole _ = False

160160

161−holeName i = MN i "hole"

161+holeName i = MN i "hole"

162162

163163qshow :: Fails -> String

164−qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

164+qshow fs = show (map (\ (x, y, _, _) -> (x, y)) fs)

165165

166−match_unify' :: Context -> Env -> TT Name -> TT Name ->

166+match_unify' :: Context -> Env -> TT Name -> TT Name ->

167167 StateT TState TC [(Name, TT Name)]

168−match_unify' ctxt env topx topy =

168+match_unify' ctxt env topx topy =

169169 do ps <- get

170170 let dont = dontunify ps

171171 u <- lift $ match_unify ctxt env topx topy dont (holes ps)

@@ -173,34 +173,34 @@ match_unify' ctxt env topx topy =

173173 put (ps { unified = (h, u ++ ns) })

174174 return u

175175

176−unify' :: Context -> Env -> TT Name -> TT Name ->

176+unify' :: Context -> Env -> TT Name -> TT Name ->

177177 StateT TState TC [(Name, TT Name)]

178−unify' ctxt env topx topy =

178+unify' ctxt env topx topy =

179179 do ps <- get

180180 let dont = dontunify ps

181− (u, fails) <- traceWhen (unifylog ps)

181+ (u, fails) <- traceWhen (unifylog ps)

182182 ("Trying " ++ show (topx, topy) ++

183− " in " ++ show env ++

184− "\nHoles: " ++ show (holes ps) ++ "\n") $

183+ " in " ++ show env ++

184+ "\nHoles: " ++ show (holes ps) ++ "\n") $

185185 lift $ unify ctxt env topx topy dont (holes ps)

186186 traceWhen (unifylog ps)

187187 ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

188− "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

188+ "\nSolved: " ++ show u ++ "\nNew problems: " ++ qshow fails

189189 ++ "\nCurrent problems:\n" ++ qshow (problems ps)

190−-- ++ show (pterm ps)

190+-- ++ show (pterm ps)

191191 ++ "\n----------") $

192192 case fails of

193193-- [] -> return u

194− err ->

194+ err ->

195195 do ps <- get

196196 let (h, ns) = unified ps

197− let (ns', probs') = updateProblems (context ps) (u ++ ns)

197+ let (ns', probs') = updateProblems (context ps) (u ++ ns)

198198 (err ++ problems ps)

199199 (injective ps)

200200 (holes ps)

201201 put (ps { problems = probs',

202202 unified = (h, ns') })

203− return u

203+ return u

204204

205205getName :: Monad m => String -> StateT TState m Name

206206getName tag = do ps <- get

@@ -216,9 +216,9 @@ addLog :: Monad m => String -> StateT TState m ()

216216addLog str = action (\ps -> ps { plog = plog ps ++ str ++ "\n" })

217217

218218newProof :: Name -> Context -> Type -> ProofState

219−newProof n ctxt ty = let h = holeName 0

219+newProof n ctxt ty = let h = holeName 0

220220 ty' = vToP ty in

221− PS n [h] [] 1 (Bind h (Hole ty')

221+ PS n [h] [] 1 (Bind h (Hole ty')

222222 (P Bound h ty')) ty [] (h, []) []

223223 Nothing [] []

224224 [] []

@@ -229,7 +229,7 @@ type RunTactic = Context -> Env -> Term -> StateT TState TC Term

229229type Hole = Maybe Name -- Nothing = default hole, first in list in proof state

230230

231231envAtFocus :: ProofState -> TC Env

232−envAtFocus ps

232+envAtFocus ps

233233 | not $ null (holes ps) = do g <- goal (Just (head (holes ps))) (pterm ps)

234234 return (premises g)

235235 | otherwise = fail "No holes"

@@ -242,12 +242,12 @@ goalAtFocus ps

242242

243243goal :: Hole -> Term -> TC Goal

244244goal h tm = g [] tm where

245− g env (Bind n b@(Guess _ _) sc)

246− | same h n = return $ GD env b

247− | otherwise

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

250− | otherwise

245+ g env (Bind n b@(Guess _ _) sc)

246+ | same h n = return $ GD env b

247+ | otherwise

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

250+ | otherwise

251251 = g ((n, b):env) sc `mplus` gb env b

252252 g env (App f a) = g env f `mplus` g env a

253253 g env t = fail "Can't find hole"

@@ -265,7 +265,7 @@ tactic h f = do ps <- get

265265 updated o = do o' <- o

266266 return (o', True)

267267

268− ulift2 c env op a b

268+ ulift2 c env op a b

269269 = do (b', u) <- atH c env b

270270 if u then return (op a b', True)

271271 else do (a', u) <- atH c env a

@@ -274,15 +274,15 @@ tactic h f = do ps <- get

274274 -- Search the things most likely to contain the binding first!

275275

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

278278 | same h n = updated (f c env binder)

279− | otherwise

279+ | otherwise

280280 = do -- binder first

281281 (b', u) <- ulift2 c env Guess t v

282282 if u then return (Bind n b' sc, True)

283283 else do (sc', u) <- atH c ((n, b) : env) sc

284284 return (Bind n b' sc', u)

285− atH c env binder@(Bind n b sc)

285+ atH c env binder@(Bind n b sc)

286286 | hole b && same h n = updated (f c env binder)

287287 | otherwise -- scope first

288288 = do (sc', u) <- atH c ((n, b) : env) sc

@@ -291,8 +291,8 @@ tactic h f = do ps <- get

291291 return (Bind n b' sc', u)

292292 atH c env (App f a) = ulift2 c env App f a

293293 atH c env t = return (t, False)

294−

295− atHb c env (Let t v) = ulift2 c env Let t v

294+

295+ atHb c env (Let t v) = ulift2 c env Let t v

296296 atHb c env (Guess t v) = ulift2 c env Guess t v

297297 atHb c env t = do (ty', u) <- atH c env (binderTy t)

298298 return (t { binderTy = ty' }, u)

@@ -307,12 +307,12 @@ computeLet ctxt n tm = cl [] tm where

307307 cl env t = t

308308

309309attack :: RunTactic

310−attack ctxt env (Bind x (Hole t) sc)

310+attack ctxt env (Bind x (Hole t) sc)

311311 = do h <- getName "hole"

312312 action (\ps -> ps { holes = h : holes ps })

313313 return $ Bind x (Guess t (newtm h)) sc

314314 where

315− newtm h = Bind h (Hole t) (P Bound h t)

315+ newtm h = Bind h (Hole t) (P Bound h t)

316316attack ctxt env _ = fail "Not an attackable hole"

317317

318318claim :: Name -> Raw -> RunTactic

@@ -325,7 +325,7 @@ claim n ty ctxt env t =

325325

326326reorder_claims :: RunTactic

327327reorder_claims ctxt env t

328− = -- trace (showSep "\n" (map show (scvs t))) $

328+ = -- trace (showSep "\n" (map show (scvs t))) $

329329 let (bs, sc) = scvs t []

330330 newbs = reverse (sortB (reverse bs)) in

331331 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

352352 then ps { holes = n : (hs \\ [n]) }

353353 else ps)

354354 ps <- get

355− return t

355+ return t

356356

357357movelast :: Name -> RunTactic

358358movelast n ctxt env t = do action (\ps -> let hs = holes ps in

359359 if n `elem` hs

360360 then ps { holes = (hs \\ [n]) ++ [n] }

361361 else ps)

362− return t

362+ return t

363363

364364instanceArg :: Name -> RunTactic

365365instanceArg n ctxt env (Bind x (Hole t) sc)

@@ -376,10 +376,10 @@ setinj n ctxt env (Bind x (Hole t) sc)

376376 return (Bind x (Hole t) sc)

377377

378378defer :: 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' =

380380 do action (\ps -> let hs = holes ps in

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

383383 (mkApp (P Ref n ty) (map getP (reverse env))))

384384 where

385385 mkTy [] t = t

@@ -389,13 +389,13 @@ defer n ctxt env (Bind x (Hole t) (P nt x' ty)) | x == x' =

389389

390390-- as defer, but build the type and application explicitly

391391deferType :: 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' =

393393 do (fty, _) <- lift $ check ctxt env fty_in

394− action (\ps -> let hs = holes ps

394+ action (\ps -> let hs = holes ps

395395 ds = deferred ps in

396396 ps { holes = hs \\ [x],

397397 deferred = n : ds })

398− return (Bind n (GHole 0 fty)

398+ return (Bind n (GHole 0 fty)

399399 (mkApp (P Ref n ty) (map getP args)))

400400 where

401401 getP n = case lookup n env of

@@ -407,12 +407,12 @@ regret ctxt env (Bind x (Hole t) sc) | noOccurrence x sc =

407407 do action (\ps -> let hs = holes ps in

408408 ps { holes = hs \\ [x] })

409409 return sc

410−regret ctxt env (Bind x (Hole t) _)

410+regret ctxt env (Bind x (Hole t) _)

411411 = fail $ show x ++ " : " ++ show t ++ " is not solved..."

412412

413413exact :: Raw -> RunTactic

414−exact guess ctxt env (Bind x (Hole ty) sc) =

415− do (val, valty) <- lift $ check ctxt env guess

414+exact guess ctxt env (Bind x (Hole ty) sc) =

415+ do (val, valty) <- lift $ check ctxt env guess

416416 lift $ converts ctxt env valty ty

417417 return $ Bind x (Guess ty val) sc

418418exact _ _ _ _ = fail "Can't fill here."

@@ -420,7 +420,7 @@ exact _ _ _ _ = fail "Can't fill here."

420420-- As exact, but attempts to solve other goals by unification

421421

422422fill :: Raw -> RunTactic

423−fill guess ctxt env (Bind x (Hole ty) sc) =

423+fill guess ctxt env (Bind x (Hole ty) sc) =

424424 do (val, valty) <- lift $ check ctxt env guess

425425-- let valtyn = normalise ctxt env valty

426426-- let tyn = normalise ctxt env ty

@@ -435,7 +435,7 @@ fill _ _ _ _ = fail "Can't fill here."

435435-- As fill, but attempts to solve other goals by matching

436436

437437match_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) =

439439 do (val, valty) <- lift $ check ctxt env guess

440440-- let valtyn = normalise ctxt env valty

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

456456complete_fill :: RunTactic

457457complete_fill ctxt env (Bind x (Guess ty val) sc) =

458458 do let guess = forget val

459− (val', valty) <- lift $ check ctxt env guess

459+ (val', valty) <- lift $ check ctxt env guess

460460 ns <- unify' ctxt env valty ty

461461 ps <- get

462462 let (uh, uns) = unified ps

@@ -473,13 +473,13 @@ solve ctxt env (Bind x (Guess ty val) sc)

473473 | True = do ps <- get

474474 let (uh, uns) = unified ps

475475 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)) $

477477 -- return []

478478 unify' ctxt env tm val

479479 _ -> return []

480480 action (\ps -> ps { holes = holes ps \\ [x],

481481 solved = Just (x, val),

482−-- problems = solveInProblems

482+-- problems = solveInProblems

483483-- x val (problems ps),

484484 -- dontunify = dontunify ps \\ [x],

485485 -- unified = (uh, uns ++ [(x, val)]),

@@ -487,13 +487,13 @@ solve ctxt env (Bind x (Guess ty val) sc)

487487 let tm' = instantiate val (pToV x sc) in

488488 return tm'

489489 | otherwise = lift $ tfail $ IncompleteTerm val

490−solve _ _ h@(Bind x t sc)

490+solve _ _ h@(Bind x t sc)

491491 = do ps <- get

492492 fail $ "Not a guess " ++ show h ++ "\n" ++ show (holes ps, pterm ps)

493493

494494introTy :: Raw -> Maybe Name -> RunTactic

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

497497 Just name -> name

498498 Nothing -> x

499499 let t' = case t of

@@ -513,7 +513,7 @@ introTy ty n ctxt env _ = fail "Can't introduce here."

513513

514514intro :: Maybe Name -> RunTactic

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

517517 Just name -> name

518518 Nothing -> x

519519 let t' = case t of

@@ -521,7 +521,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

521521 _ -> hnf ctxt env t

522522 case t' of

523523 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

525525 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

526526 _ -> lift $ tfail $ CantIntroduce t'

527527intro n ctxt env _ = fail "Can't introduce here."

@@ -529,7 +529,7 @@ intro n ctxt env _ = fail "Can't introduce here."

529529forall :: Name -> Raw -> RunTactic

530530forall n ty ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

531531 do (tyv, tyt) <- lift $ check ctxt env ty

532− unify' ctxt env tyt (TType (UVar 0))

532+ unify' ctxt env tyt (TType (UVar 0))

533533 return $ Bind n (Pi tyv) (Bind x (Hole t) (P Bound x t))

534534forall n ty ctxt env _ = fail "Can't pi bind here"

535535

@@ -548,7 +548,7 @@ letbind n ty val ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

548548letbind n ty val ctxt env _ = fail "Can't let bind here"

549549

550550expandLet :: Name -> Term -> RunTactic

551−expandLet n v ctxt env tm =

551+expandLet n v ctxt env tm =

552552 return $ subst n v tm

553553

554554rewrite :: Raw -> RunTactic

@@ -558,8 +558,8 @@ rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

558558 case unApply tmt' of

559559 (P _ (UN "=") _, [lt,rt,l,r]) ->

560560 do let p = Bind rname (Lam lt) (mkP (P Bound rname lt) r l t)

561− let newt = mkP l r l t

562− let sc = forget $ (Bind x (Hole newt)

561+ let newt = mkP l r l t

562+ let sc = forget $ (Bind x (Hole newt)

563563 (mkApp (P Ref (UN "replace") (TType (UVal 0)))

564564 [lt, l, r, p, tmv, xp]))

565565 (scv, sct) <- lift $ check ctxt env sc

@@ -572,14 +572,14 @@ rewrite tm ctxt env (Bind x (Hole t) xp@(P _ x' _)) | x == x' =

572572 mkP lt l r (App f a) = let f' = if (r /= f) then mkP lt l r f else f

573573 a' = if (r /= a) then mkP lt l r a else a in

574574 App f' a'

575− mkP lt l r (Bind n b sc)

576− = let b' = mkPB b

575+ mkP lt l r (Bind n b sc)

576+ = let b' = mkPB b

577577 sc' = if (r /= sc) then mkP lt l r sc else sc in

578578 Bind n b' sc'

579579 where mkPB (Let t v) = let t' = if (r /= t) then mkP lt l r t else t

580580 v' = if (r /= v) then mkP lt l r v else v in

581581 Let t' v'

582− mkPB b = let ty = binderTy b

582+ mkPB b = let ty = binderTy b

583583 ty' = if (r /= ty) then mkP lt l r ty else ty in

584584 b { binderTy = ty' }

585585 mkP lt l r x = x

@@ -609,11 +609,11 @@ compute :: RunTactic

609609compute ctxt env (Bind x (Hole ty) sc) =

610610 do return $ Bind x (Hole (normalise ctxt env ty)) sc

611611compute ctxt env t = return t

612−

612+

613613hnf_compute :: RunTactic

614−hnf_compute ctxt env (Bind x (Hole ty) sc) =

614+hnf_compute ctxt env (Bind x (Hole ty) sc) =

615615 do let ty' = hnf ctxt env ty in

616−-- trace ("HNF " ++ show (ty, ty')) $

616+-- trace ("HNF " ++ show (ty, ty')) $

617617 return $ Bind x (Hole ty') sc

618618hnf_compute ctxt env t = return t

619619

@@ -622,23 +622,23 @@ simplify :: RunTactic

622622simplify ctxt env (Bind x (Hole ty) sc) =

623623 do return $ Bind x (Hole (specialise ctxt env [] ty)) sc

624624simplify ctxt env t = return t

625−

625+

626626check_in :: Raw -> RunTactic

627−check_in t ctxt env tm =

627+check_in t ctxt env tm =

628628 do (val, valty) <- lift $ check ctxt env t

629629 addLog (showEnv env val ++ " : " ++ showEnv env valty)

630630 return tm

631631

632632eval_in :: Raw -> RunTactic

633−eval_in t ctxt env tm =

633+eval_in t ctxt env tm =

634634 do (val, valty) <- lift $ check ctxt env t

635635 let val' = normalise ctxt env val

636636 let valty' = normalise ctxt env valty

637− addLog (showEnv env val ++ " : " ++

638− showEnv env valty ++

639−-- " in " ++ show env ++

637+ addLog (showEnv env val ++ " : " ++

638+ showEnv env valty ++

639+-- " in " ++ show env ++

640640 " ==>\n " ++

641− showEnv env val' ++ " : " ++

641+ showEnv env val' ++ " : " ++

642642 showEnv env valty')

643643 return tm

644644

@@ -649,7 +649,7 @@ start_unify n ctxt env tm = do -- action (\ps -> ps { unified = (n, []) })

649649tmap f (a, b, c) = (f a, b, c)

650650

651651solve_unified :: RunTactic

652−solve_unified ctxt env tm =

652+solve_unified ctxt env tm =

653653 do ps <- get

654654 let (_, ns) = unified ps

655655 let unify = dropGiven (dontunify ps) ns (holes ps)

@@ -663,7 +663,7 @@ dropGiven du ((n, P Bound t ty) : us) hs

663663 | n `elem` du && not (t `elem` du)

664664 && n `elem` hs && t `elem` hs

665665 = (t, P Bound n ty) : dropGiven du us hs

666−dropGiven du (u@(n, _) : us) hs

666+dropGiven du (u@(n, _) : us) hs

667667 | n `elem` du = dropGiven du us hs

668668-- dropGiven du (u@(_, P a n ty) : us) | n `elem` du = dropGiven du us

669669dropGiven du (u : us) hs = u : dropGiven du us hs

@@ -673,15 +673,15 @@ keepGiven du ((n, P Bound t ty) : us) hs

673673 | n `elem` du && not (t `elem` du)

674674 && n `elem` hs && t `elem` hs

675675 = keepGiven du us hs

676−keepGiven du (u@(n, _) : us) hs

676+keepGiven du (u@(n, _) : us) hs

677677 | n `elem` du = u : keepGiven du us hs

678678keepGiven du (u : us) hs = keepGiven du us hs

679679

680−updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

680+updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

681681 updateSolved' xs x

682682updateSolved' xs (Bind n (Hole ty) t)

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

685685 | otherwise = Bind n (fmap (updateSolved' xs) b) (updateSolved' xs t)

686686updateSolved' xs (App f a) = App (updateSolved' xs f) (updateSolved' xs a)

687687updateSolved' xs (P _ n _)

@@ -704,11 +704,11 @@ updateProblems ctxt ns ps inj holes = up ns ps where

704704 up ns [] = (ns, [])

705705 up ns ((x, y, env, err) : ps) =

706706 let x' = updateSolved ns x

707− y' = updateSolved ns y

707+ y' = updateSolved ns y

708708 err' = updateError ns err

709709 env' = updateEnv ns env in

710710 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')) $

712712 up (ns ++ v) ps

713713 _ -> let (ns', ps') = up ns ps in

714714 (ns', (x',y',env',err') : ps')

@@ -718,11 +718,11 @@ matchProblems ctxt ps inj holes = up [] ps where

718718 up ns [] = (ns, [])

719719 up ns ((x, y, env, err) : ps) =

720720 let x' = updateSolved ns x

721− y' = updateSolved ns y

721+ y' = updateSolved ns y

722722 err' = updateError ns err

723723 env' = updateEnv ns env in

724724 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')) $

726726 up (ns ++ v) ps

727727 _ -> let (ns', ps') = up ns ps in

728728 (ns', (x',y',env',err') : ps')

@@ -731,60 +731,60 @@ processTactic :: Tactic -> ProofState -> TC (ProofState, String)

731731processTactic QED ps = case holes ps of

732732 [] -> do let tm = {- normalise (context ps) [] -} (pterm ps)

733733 (tm', ty', _) <- recheck (context ps) [] (forget tm) tm

734− return (ps { done = True, pterm = tm' },

734+ return (ps { done = True, pterm = tm' },

735735 "Proof complete: " ++ showEnv [] tm')

736736 _ -> fail "Still holes to fill."

737737processTactic ProofState ps = return (ps, showEnv [] (pterm ps))

738738processTactic Undo ps = case previous ps of

739739 Nothing -> fail "Nothing to undo."

740740 Just pold -> return (pold, "")

741−processTactic EndUnify ps

741+processTactic EndUnify ps

742742 = let (h, ns_in) = unified ps

743743 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

745745 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

746746 (injective ps) (holes ps)

747747 tm' = -- trace ("Updating " ++ show ns_in ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $

748748 updateSolved ns'' (pterm ps) in

749− return (ps { pterm = tm',

749+ return (ps { pterm = tm',

750750 unified = (h, []),

751751 problems = probs',

752752 holes = holes ps \\ map fst ns'' }, "")

753−processTactic (Reorder n) ps

753+processTactic (Reorder n) ps

754754 = do ps' <- execStateT (tactic (Just n) reorder_claims) ps

755755 return (ps' { previous = Just ps, plog = "" }, plog ps')

756756processTactic (ComputeLet n) ps

757757 = return (ps { pterm = computeLet (context ps) n (pterm ps) }, "")

758−processTactic UnifyProblems ps

758+processTactic UnifyProblems ps

759759 = let (ns', probs') = updateProblems (context ps) []

760760 (problems ps)

761761 (injective ps)

762− (holes ps)

762+ (holes ps)

763763 pterm' = updateSolved ns' (pterm ps) in

764764 return (ps { pterm = pterm', solved = Nothing, problems = probs',

765765 previous = Just ps, plog = "",

766766 holes = holes ps \\ (map fst ns') }, plog ps)

767−processTactic MatchProblems ps

767+processTactic MatchProblems ps

768768 = let (ns', probs') = matchProblems (context ps)

769769 (problems ps)

770770 (injective ps)

771− (holes ps)

771+ (holes ps)

772772 pterm' = updateSolved ns' (pterm ps) in

773773 return (ps { pterm = pterm', solved = Nothing, problems = probs',

774774 previous = Just ps, plog = "",

775775 holes = holes ps \\ (map fst ns') }, plog ps)

776−processTactic t ps

776+processTactic t ps

777777 = case holes ps of

778778 [] -> fail "Nothing to fill in."

779779 (h:_) -> do ps' <- execStateT (process t h) ps

780− let (ns', probs')

780+ let (ns', probs')

781781 = case solved ps' of

782782 Just s -> updateProblems (context ps')

783− [s] (problems ps')

783+ [s] (problems ps')

784784 (injective ps')

785785 (holes ps')

786786 _ -> ([], problems ps')

787− -- rechecking problems may find more solutions, so

787+ -- rechecking problems may find more solutions, so

788788 -- apply them here

789789 let pterm'' = updateSolved ns' (pterm ps')

790790 return (ps' { pterm = pterm'',

@@ -794,7 +794,7 @@ processTactic t ps

794794 holes = holes ps' \\ (map fst ns')}, plog ps')

795795

796796process :: Tactic -> Name -> StateT TState TC ()

797−process EndUnify _

797+process EndUnify _

798798 = do ps <- get

799799 let (h, _) = unified ps

800800 tactic (Just h) solve_unified

src/Core/ShellParser.hs+1−1

@@ -50,7 +50,7 @@ pTactic = do reserved "attack"; return attack

5050 <|> do reserved "regret"; return regret

5151 <|> do reserved "exact"; tm <- pTerm; return (exact tm)

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

5454 return (discard (apply tm (map (\x -> (x,0)) args)))

5555 <|> do reserved "solve"; return solve

5656 <|> do reserved "compute"; return compute

src/Core/TT.hs+48−48

@@ -63,8 +63,8 @@ emptyFC = fileFC ""

6363fileFC :: String -> FC

6464fileFC s = FC s 0 0

6565

66−{-!

67−deriving instance Binary FC

66+{-!

67+deriving instance Binary FC

6868!-}

6969

7070instance Sized FC where

@@ -75,7 +75,7 @@ instance Show FC where

7575

7676data Err = Msg String

7777 | InternalMsg String

78− | CantUnify Bool Term Term Err [(Name, Type)] Int

78+ | CantUnify Bool Term Term Err [(Name, Type)] Int

7979 -- Int is 'score' - how much we did unify

8080 -- Bool indicates recoverability, True indicates more info may make

8181 -- unification succeed

@@ -181,8 +181,8 @@ instance Show a => Show (TC a) where

181181-- (e.g. Type:Type)

182182

183183instance Monad TC where

184− return = OK

185− x >>= k = case x of

184+ return = OK

185+ x >>= k = case x of

186186 OK v -> k v

187187 Error e -> Error e

188188 fail e = Error (InternalMsg e)

@@ -192,7 +192,7 @@ tfail e = Error e

192192

193193trun :: FC -> TC a -> TC a

194194trun fc (OK a) = OK a

195−trun fc (Error e) = Error (At fc e)

195+trun fc (Error e) = Error (At fc e)

196196

197197instance MonadPlus TC where

198198 mzero = fail "Unknown error"

@@ -218,23 +218,23 @@ traceWhen False _ a = a

218218-- | Names are hierarchies of strings, describing scope (so no danger of

219219-- duplicate names, but need to be careful on lookup).

220220data Name = UN String -- ^ User-provided name

221− | NS Name [String] -- ^ Root, namespaces

221+ | NS Name [String] -- ^ Root, namespaces

222222 | MN Int String -- ^ Machine chosen names

223223 | NErased -- ^ Name of somethng which is never used in scope

224224 | SN SpecialName -- ^ Decorated function names

225225 deriving (Eq, Ord)

226−{-!

227−deriving instance Binary Name

226+{-!

227+deriving instance Binary Name

228228!-}

229229

230230data SpecialName = WhereN Int Name Name

231231 | InstanceN Name [String]

232232 | ParentN Name String

233− | MethodN Name

233+ | MethodN Name

234234 | CaseN Name

235235 deriving (Eq, Ord)

236−{-!

237−deriving instance Binary SpecialName

236+{-!

237+deriving instance Binary SpecialName

238238!-}

239239

240240instance Sized Name where

@@ -300,9 +300,9 @@ nsroot n = n

300300

301301addDef :: Name -> a -> Ctxt a -> Ctxt a

302302addDef n v ctxt = case Map.lookup (nsroot n) ctxt of

303− Nothing -> Map.insert (nsroot n)

303+ Nothing -> Map.insert (nsroot n)

304304 (Map.insert n v Map.empty) ctxt

305− Just xs -> Map.insert (nsroot n)

305+ Just xs -> Map.insert (nsroot n)

306306 (Map.insert n v xs) ctxt

307307

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

326326 Nothing -> []

327327 where

328328 filterNS [] = []

329− filterNS ((found, v) : xs)

329+ filterNS ((found, v) : xs)

330330 | nsmatch n found = (found, v) : filterNS xs

331331 | otherwise = filterNS xs

332332

@@ -341,9 +341,9 @@ lookupCtxtExact :: Name -> Ctxt a -> [a]

341341lookupCtxtExact n ctxt = [ v | (nm, v) <- lookupCtxtName n ctxt, nm == n]

342342

343343updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a

344−updateDef n f ctxt

344+updateDef n f ctxt

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

347347

348348toAlist :: Ctxt a -> [(Name, a)]

349349toAlist ctxt = let allns = map snd (Map.toList ctxt) in

@@ -390,15 +390,15 @@ intTyWidth ITNative = 8 * sizeOf (0 :: Int)

390390intTyWidth ITChar = error "IRTS.Lang.intTyWidth: Characters have platform and backend dependent width"

391391intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width"

392392

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

394394 | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64

395395 | B8V (Vector Word8) | B16V (Vector Word16)

396396 | B32V (Vector Word32) | B64V (Vector Word64)

397397 | AType ArithTy | StrType

398398 | PtrType | VoidType | Forgot

399399 deriving (Eq, Ord)

400−{-!

401−deriving instance Binary Const

400+{-!

401+deriving instance Binary Const

402402!-}

403403

404404instance Sized Const where

@@ -439,8 +439,8 @@ instance Sized Raw where

439439instance Pretty Raw where

440440 pretty = text . show

441441

442−{-!

443−deriving instance Binary Raw

442+{-!

443+deriving instance Binary Raw

444444!-}

445445

446446-- | All binding forms are represented in a unform fashion.

@@ -458,8 +458,8 @@ data Binder b = Lam { binderTy :: b {-^ type annotation for bound variable-}}

458458 | PVar { binderTy :: b }

459459 | PVTy { binderTy :: b }

460460 deriving (Show, Eq, Ord, Functor)

461−{-!

462−deriving instance Binary Binder

461+{-!

462+deriving instance Binary Binder

463463!-}

464464

465465instance Sized a => Sized (Binder a) where

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

548548 | DCon Int Int -- ^ Data constructor; Ints are tag and arity

549549 | TCon Int Int -- ^ Type constructor; Ints are tag and arity

550550 deriving (Show, Ord)

551−{-!

552−deriving instance Binary NameType

551+{-!

552+deriving instance Binary NameType

553553!-}

554554

555555instance Sized NameType where

@@ -576,8 +576,8 @@ data TT n = P NameType n (TT n) -- ^ named references

576576 | Impossible -- ^ special case for totality checking

577577 | TType UExp -- ^ the type of types at some level

578578 deriving (Ord, Functor)

579−{-!

580−deriving instance Binary TT

579+{-!

580+deriving instance Binary TT

581581!-}

582582

583583class TermSize a where

@@ -588,14 +588,14 @@ instance TermSize a => TermSize [a] where

588588 termsize n (x : xs) = termsize n x + termsize n xs

589589

590590instance TermSize (TT Name) where

591− termsize n (P _ x _)

591+ termsize n (P _ x _)

592592 | x == n = 1000000 -- recursive => really big

593593 | otherwise = 1

594594 termsize n (V _) = 1

595− termsize n (Bind n' (Let t v) sc)

595+ termsize n (Bind n' (Let t v) sc)

596596 = let rn = if n == n' then MN 0 "noname" else n in

597597 termsize rn v + termsize rn sc

598− termsize n (Bind n' b sc)

598+ termsize n (Bind n' b sc)

599599 = let rn = if n == n' then MN 0 "noname" else n in

600600 termsize rn sc

601601 termsize n (App f a) = termsize n f + termsize n a

@@ -652,7 +652,7 @@ isInjective _ = False

652652vinstances :: Int -> TT n -> Int

653653vinstances i (V x) | i == x = 1

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

656656 where instancesB (Let t v) = vinstances i v

657657 instancesB _ = 0

658658vinstances i t = 0

@@ -662,7 +662,7 @@ instantiate e = subst 0 where

662662 subst i (V x) | i == x = e

663663 subst i (Bind x b sc) = Bind x (fmap (subst i) b) (subst (i+1) sc)

664664 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

666666 subst i t = t

667667

668668substV :: TT n -> TT n -> TT n

@@ -677,7 +677,7 @@ substV x tm = dropV 0 (instantiate x tm) where

677677explicitNames :: TT n -> TT n

678678explicitNames (Bind x b sc) = let b' = fmap explicitNames b in

679679 Bind x b'

680− (explicitNames (instantiate

680+ (explicitNames (instantiate

681681 (P Bound x (binderTy b')) sc))

682682explicitNames (App f a) = App (explicitNames f) (explicitNames a)

683683explicitNames (Proj x idx) = Proj (explicitNames x) idx

@@ -785,15 +785,15 @@ forget tm = fe [] tm

785785 where

786786 fe env (P _ n _) = Var n

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

789789 (fe (n:env) sc)

790790 fe env (App f a) = RApp (fe env f) (fe env a)

791− fe env (Constant c)

791+ fe env (Constant c)

792792 = RConstant c

793793 fe env (TType i) = RType

794− fe env Erased = RConstant Forgot

795−

796−bindAll :: [(n, Binder (TT n))] -> TT n -> TT n

794+ fe env Erased = RConstant Forgot

795+

796+bindAll :: [(n, Binder (TT n))] -> TT n -> TT n

797797bindAll [] t =t

798798bindAll ((n, b) : bs) t = Bind n b (bindAll bs t)

799799

@@ -820,7 +820,7 @@ uniqueBinders ns (Bind n b sc)

820820 Bind n' (fmap (uniqueBinders (n':ns)) b) (uniqueBinders ns sc)

821821uniqueBinders ns (App f a) = App (uniqueBinders ns f) (uniqueBinders ns a)

822822uniqueBinders ns t = t

823−

823+

824824

825825nextName (NS x s) = NS (nextName x) s

826826nextName (MN i n) = MN (i+1) n

@@ -892,7 +892,7 @@ prettyEnv env t = prettyEnv' env t False

892892 | otherwise = p

893893

894894 prettySe p env (P nt n t) debug =

895− pretty n <+>

895+ pretty n <+>

896896 if debug then

897897 lbrack <+> pretty nt <+> colon <+> prettySe 10 env t debug <+> rbrack

898898 else

@@ -931,16 +931,16 @@ prettyEnv env t = prettyEnv' env t False

931931 prettyBv env op sc n t v debug =

932932 text op <> pretty n <+> colon <+> prettySe 10 env t debug <+> text "=" <+>

933933 prettySe 10 env v debug <> text sc

934−

934+

935935

936936showEnv' 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

938938 ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else ""

939939 se p env (V i) | i < length env && i >= 0

940940 = (show $ fst $ env!!i) ++

941941 if dbg then "{" ++ show i ++ "}" else ""

942942 | otherwise = "!!V " ++ show i ++ "!!"

943− se p env (Bind n b@(Pi t) sc)

943+ se p env (Bind n b@(Pi t) sc)

944944 | noOccurrence n sc && not dbg = bracket p 2 $ se 1 env t ++ " -> " ++ se 10 ((n,b):env) sc

945945 se p env (Bind n b sc) = bracket p 2 $ sb env n b ++ se 10 ((n,b):env) sc

946946 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

960960 sb env n (Guess t v) = showbv env "?? " " in " n t v

961961

962962 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 ++ " = " ++

964− se 10 env v ++ sc

963+ showbv env op sc n t v = op ++ show n ++ " : " ++ se 10 env t ++ " = " ++

964+ se 10 env v ++ sc

965965

966966 bracket outer inner str | inner > outer = "(" ++ str ++ ")"

967967 | otherwise = str

@@ -1008,7 +1008,7 @@ orderPats tm = op [] tm

10081008 where

10091009 op ps (Bind n (PVar t) sc) = op ((n, PVar t) : ps) sc

10101010 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

10121012

10131013 sortP ps = pick [] (reverse ps)

10141014

@@ -1025,7 +1025,7 @@ orderPats tm = op [] tm

10251025

10261026 insert n t [] = [(n, t)]

10271027 insert n t ((n',t') : ps)

1028− | n `elem` (namesIn (binderTy t') ++

1028+ | n `elem` (namesIn (binderTy t') ++

10291029 concatMap namesIn (map (binderTy . snd) ps))

10301030 = (n', t') : insert n t ps

10311031 | otherwise = (n,t):(n',t'):ps

src/Core/Typecheck.hs+17−17

@@ -16,10 +16,10 @@ import Core.Evaluate

1616-- indexed with 'finalise'

1717

1818convertsC :: Context -> Env -> Term -> Term -> StateT UCs TC ()

19−convertsC ctxt env x y

19+convertsC ctxt env x y

2020 = do c1 <- convEq ctxt x y

2121 if c1 then return ()

22− else

22+ else

2323 do c2 <- convEq ctxt (finalise (normalise ctxt env x))

2424 (finalise (normalise ctxt env y))

2525 if c2 then return ()

@@ -28,10 +28,10 @@ convertsC ctxt env x y

2828 (finalise (normalise ctxt env y)) (errEnv env))

2929

3030converts :: Context -> Env -> Term -> Term -> TC ()

31−converts ctxt env x y

32− = case convEq' ctxt x y of

31+converts ctxt env x y

32+ = case convEq' ctxt x y of

3333 OK True -> return ()

34− _ -> case convEq' ctxt (finalise (normalise ctxt env x))

34+ _ -> case convEq' ctxt (finalise (normalise ctxt env x))

3535 (finalise (normalise ctxt env y)) of

3636 OK True -> return ()

3737 _ -> tfail (CantConvert

@@ -51,7 +51,7 @@ recheck ctxt env tm orig

5151 case runStateT (check' False ctxt env tm) (v, []) of -- holes banned

5252 Error (IncompleteTerm _) -> Error $ IncompleteTerm orig

5353 Error e -> Error e

54− OK ((tm, ty), constraints) ->

54+ OK ((tm, ty), constraints) ->

5555 return (tm, ty, constraints)

5656

5757check :: Context -> Env -> Raw -> TC (Term, Type)

@@ -68,7 +68,7 @@ check' holes ctxt env top = chk env top where

6868 (av, aty) <- chk env a

6969 let fty' = case uniqueBinders (map fst env) (finalise fty) of

7070 ty@(Bind x (Pi s) t) -> ty

71− _ -> uniqueBinders (map fst env)

71+ _ -> uniqueBinders (map fst env)

7272 $ case hnf ctxt env fty of

7373 ty@(Bind x (Pi s) t) -> ty

7474 _ -> normalise ctxt env fty

@@ -77,21 +77,21 @@ check' holes ctxt env top = chk env top where

7777-- trace ("Converting " ++ show aty ++ " and " ++ show s ++

7878-- " from " ++ show fv ++ " : " ++ show fty) $

7979 do convertsC ctxt env aty s

80− -- let apty = normalise initContext env

80+ -- let apty = normalise initContext env

8181 -- (Bind x (Let aty av) t)

82− let apty = simplify initContext env

82+ let apty = simplify initContext env

8383 (Bind x (Let aty av) t)

8484 return (App fv av, apty)

8585 t -> lift $ tfail $ NonFunctionType fv fty -- "Can't apply a non-function type"

86− -- This rather unpleasant hack is needed because during incomplete

87− -- proofs, variables are locally bound with an explicit name. If we just

86+ -- This rather unpleasant hack is needed because during incomplete

87+ -- proofs, variables are locally bound with an explicit name. If we just

8888 -- make sure bound names in function types are locally unique, machine

8989 -- generated names, we'll be fine.

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

9292 (renameBinders (i+1) t)

9393 renameBinders i sc = sc

94− chk env RType

94+ chk env RType

9595 | holes = return (TType (UVal 0), TType (UVal 0))

9696 | otherwise = do (v, cs) <- get

9797 let c = ULT (UVar v) (UVar (v+1))

@@ -123,8 +123,8 @@ check' holes ctxt env top = chk env top where

123123 let TType su = normalise ctxt env st

124124 let TType tu = normalise ctxt env tt

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

127− (pToV n tv), TType (UVar v))

126+ return (Bind n (Pi (uniqueBinders (map fst env) sv))

127+ (pToV n tv), TType (UVar v))

128128 chk env (RBind n b sc)

129129 = do b' <- checkBinder b

130130 (scv, sct) <- chk ((n, b'):env) sc

@@ -193,7 +193,7 @@ check' holes ctxt env top = chk env top where

193193 let tt' = normalise ctxt env tt

194194 lift $ isType ctxt env tt'

195195 return (PVTy tv)

196−

196+

197197 discharge n (Lam t) scv sct

198198 = return (Bind n (Lam t) scv, Bind n (Pi t) sct)

199199 discharge n (Pi t) scv sct

@@ -216,7 +216,7 @@ check' holes ctxt env top = chk env top where

216216

217217checkProgram :: Context -> RProgram -> TC Context

218218checkProgram ctxt [] = return ctxt

219−checkProgram ctxt ((n, RConst t) : xs)

219+checkProgram ctxt ((n, RConst t) : xs)

220220 = do (t', tt') <- trace (show n) $ check ctxt [] t

221221 isType ctxt [] tt'

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

3636match_unify ctxt env topx topy dont holes =

3737 case runStateT (un [] topx topy) (UI 0 []) of

3838 OK (v, UI _ []) -> return (filter notTrivial v)

39− res ->

39+ res ->

4040 let topxn = normalise ctxt env topx

4141 topyn = normalise ctxt env topy in

4242 case runStateT (un [] topxn topyn)

4343 (UI 0 []) of

44− OK (v, UI _ fails) ->

44+ OK (v, UI _ fails) ->

4545 return (filter notTrivial v)

46− Error e ->

46+ Error e ->

4747 -- just normalise the term we're matching against

4848 case runStateT (un [] topxn topy)

4949 (UI 0 []) of

50− OK (v, UI _ fails) ->

50+ OK (v, UI _ fails) ->

5151 return (filter notTrivial v)

5252 _ -> tfail e

5353 where

@@ -66,7 +66,7 @@ match_unify ctxt env topx topy dont holes =

6666 h2 <- un ((x, y) : bnames) sx sy

6767 combine bnames h1 h2

6868 un names (App fx ax) (App fy ay)

69− = do hf <- un names fx fy

69+ = do hf <- un names fx fy

7070 ha <- un names ax ay

7171 combine names hf ha

7272 un names x y

@@ -87,7 +87,7 @@ match_unify ctxt env topx topy dont holes =

8787 uB bnames (Pi tx) (Pi ty) = un bnames tx ty

8888 uB bnames x y = do UI s f <- get

8989 let r = recoverable (binderTy x) (binderTy y)

90− let err = CantUnify r topx topy

90+ let err = CantUnify r topx topy

9191 (CantUnify r (binderTy x) (binderTy y) (Msg "") [] s)

9292 (errEnv env) s

9393 put (UI s ((binderTy x, binderTy y, env, err) : f))

@@ -107,7 +107,7 @@ match_unify ctxt env topx topy dont holes =

107107 lift $ tfail err

108108 combine bnames as [] = return as

109109 combine bnames as ((n, t) : bs)

110− = case lookup n as of

110+ = case lookup n as of

111111 Nothing -> combine bnames (as ++ [(n,t)]) bs

112112 Just t' -> do ns <- un bnames t t'

113113 -- make sure there's n mapping from n in ns

@@ -115,15 +115,15 @@ match_unify ctxt env topx topy dont holes =

115115 sc 1

116116 combine bnames as (ns' ++ bs)

117117

118− checkCycle ns p@(x, P _ _ _) = return [p]

119− checkCycle ns (x, tm)

118+ checkCycle ns p@(x, P _ _ _) = return [p]

119+ checkCycle ns (x, tm)

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

122122

123123 checkScope ns (x, tm) =

124124 case boundVs (envPos x 0 env) tm of

125125 [] -> return [(x, tm)]

126− (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))

126+ (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))

127127 (inst ns tm) (errEnv env))

128128 where inst [] tm = tm

129129 inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm)

@@ -146,15 +146,15 @@ unify ctxt env topx topy dont holes =

146146-- trace ("Unifying " ++ show (topx, topy)) $

147147 -- don't bother if topx and topy are different at the head

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

150150 [])

151− res ->

151+ res ->

152152 let topxn = normalise ctxt env topx

153153 topyn = normalise ctxt env topy in

154154-- trace ("Unifying " ++ show (topx, topy) ++ "\n\n==>\n" ++ show (topxn, topyn) ++ "\n\n" ++ show res ++ "\n\n") $

155155 case runStateT (un False [] topxn topyn)

156156 (UI 0 []) of

157− OK (v, UI _ fails) ->

157+ OK (v, UI _ fails) ->

158158 return (filter notTrivial v, reverse fails)

159159-- Error e@(CantUnify False _ _ _ _ _) -> tfail e

160160 Error e -> tfail e

@@ -165,8 +165,8 @@ unify ctxt env topx topy dont holes =

165165

166166 injective (P (DCon _ _) _ _) = True

167167 injective (P (TCon _ _) _ _) = True

168−-- injective (App f (P _ _ _)) = injective f

169−-- injective (App f (Constant _)) = injective f

168+-- injective (App f (P _ _ _)) = injective f

169+-- injective (App f (Constant _)) = injective f

170170 injective (App f a) = injective f -- && injective a

171171 injective _ = False

172172

@@ -182,15 +182,15 @@ unify ctxt env topx topy dont holes =

182182 uplus u1 u2 = do UI s f <- get

183183 r <- u1

184184 UI s f' <- get

185− if (length f == length f')

185+ if (length f == length f')

186186 then return r

187187 else do put (UI s f); u2

188188

189189 un :: Bool -> [(Name, Name)] -> TT Name -> TT Name ->

190− StateT UInfo

190+ StateT UInfo

191191 TC [(Name, TT Name)]

192192 un = un'

193−-- un fn names x y

193+-- un fn names x y

194194-- = let (xf, _) = unApply x

195195-- (yf, _) = unApply y in

196196-- if headDiff xf yf then unifyFail x y else

@@ -198,7 +198,7 @@ unify ctxt env topx topy dont holes =

198198-- (un' fn names (hnf ctxt env x) (hnf ctxt env y))

199199

200200 un' :: Bool -> [(Name, Name)] -> TT Name -> TT Name ->

201− StateT UInfo

201+ StateT UInfo

202202 TC [(Name, TT Name)]

203203 un' fn names x y | x == y = return [] -- shortcut

204204 un' fn names topx@(P (DCon _ _) x _) topy@(P (DCon _ _) y _)

@@ -213,7 +213,7 @@ unify ctxt env topx topy dont holes =

213213 = unifyFail topx topy

214214 un' fn names topx@(P (TCon _ _) x _) topy@(Constant _)

215215 = unifyFail topx topy

216− un' fn bnames tx@(P _ x _) ty@(P _ y _)

216+ un' fn bnames tx@(P _ x _) ty@(P _ y _)

217217 | (x,y) `elem` bnames || x == y = do sc 1; return []

218218 | injective tx && not (holeIn env y || y `elem` holes)

219219 = unifyTmpFail tx ty

@@ -223,10 +223,10 @@ unify ctxt env topx topy dont holes =

223223 | holeIn env x || x `elem` holes

224224 = do UI s f <- get

225225 -- injectivity check

226− if (notP tm && fn)

226+ if (notP tm && fn)

227227-- trace (show (x, tm, normalise ctxt env tm)) $

228228-- put (UI s ((tm, topx, topy) : i) f)

229− then unifyTmpFail xtm tm

229+ then unifyTmpFail xtm tm

230230 else do sc 1

231231 checkCycle bnames (x, tm)

232232 | not (injective xtm) && injective tm = unifyFail xtm tm

@@ -246,7 +246,7 @@ unify ctxt env topx topy dont holes =

246246 un' fn bnames (P _ x _) (V i)

247247 | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []

248248

249− un' fn bnames appx@(App _ _) appy@(App _ _)

249+ un' fn bnames appx@(App _ _) appy@(App _ _)

250250 = unApp fn bnames appx appy

251251-- = uplus (unApp fn bnames appx appy)

252252-- (unifyTmpFail appx appy) -- take the whole lot

@@ -259,15 +259,15 @@ unify ctxt env topx topy dont holes =

259259 = un' False bnames x y

260260 un' fn bnames (Bind n (Lam t) (App x (V 0))) y

261261 = 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)

263263-- = 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)

265265-- = 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)

267267 = do h1 <- uB bnames bx by

268268 h2 <- un' False ((x,y):bnames) sx sy

269269 combine bnames h1 h2

270− un' fn bnames x y

270+ un' fn bnames x y

271271 | OK True <- convEq' ctxt x y = do sc 1; return []

272272 | otherwise = do UI s f <- get

273273 let r = recoverable x y

@@ -277,7 +277,7 @@ unify ctxt env topx topy dont holes =

277277 else do put (UI s ((x, y, env, err) : f))

278278 return [] -- lift $ tfail err

279279

280− unApp fn bnames appx@(App fx ax) appy@(App fy ay)

280+ unApp fn bnames appx@(App fx ax) appy@(App fy ay)

281281 | (injective fx && injective fy)

282282 || (injective fx && rigid appx && metavarApp appy)

283283 || (injective fy && rigid appy && metavarApp appx)

@@ -288,11 +288,11 @@ unify ctxt env topx topy dont holes =

288288 -- fail quickly if the heads are disjoint

289289 checkHeads headx heady

290290-- if True then -- (injective fx || injective fy || fx == fy) then

291−-- if (injective fx && metavarApp appy) ||

291+-- if (injective fx && metavarApp appy) ||

292292-- (injective fy && metavarApp appx) ||

293293-- (injective fx && injective fy) || fx == fy

294294 uplus

295− (do hf <- un' True bnames fx fy

295+ (do hf <- un' True bnames fx fy

296296 let ax' = hnormalise hf ctxt env (substNames hf ax)

297297 let ay' = hnormalise hf ctxt env (substNames hf ay)

298298 ha <- un' False bnames ax' ay'

@@ -309,7 +309,7 @@ unify ctxt env topx topy dont holes =

309309 let (heady, argsy) = unApply appy

310310 -- traceWhen (headx == heady) (show (appx, appy)) $

311311 uplus (

312− if (length argsx == length argsy &&

312+ if (length argsx == length argsy &&

313313 ((headx == heady && inenv headx) || (argsx == argsy) ||

314314 (and (zipWith sameStruct (headx:argsx) (heady:argsy)))))

315315 then

@@ -318,7 +318,7 @@ unify ctxt env topx topy dont holes =

318318 failed <- errors

319319 if (not failed) then unArgs uf argsx argsy

320320 else return []

321− else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $

321+ else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $

322322 unifyTmpFail appx appy)

323323 (unifyTmpFail appx appy) -- whole application fails

324324 where hnormalise [] _ _ t = t

@@ -334,9 +334,9 @@ unify ctxt env topx topy dont holes =

334334 checkHeads _ _ = return []

335335

336336 unArgs as [] [] = return as

337− unArgs as (x : xs) (y : ys)

337+ unArgs as (x : xs) (y : ys)

338338 = 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)

340340 as' <- un' False bnames x' y'

341341 vs <- combine bnames as as'

342342 unArgs vs xs ys

@@ -352,13 +352,13 @@ unify ctxt env topx topy dont holes =

352352 all (\x -> pat x || metavar x) (f : args)

353353 && nub args == args

354354

355− sameArgStruct appx appy

355+ sameArgStruct appx appy

356356 = let (_, ax) = unApply appx

357357 (_, ay) = unApply appy in

358358 length ax == length ay &&

359359 and (zipWith sameStruct ax ay)

360360

361− sameStruct fapp@(App f x) gapp@(App g y)

361+ sameStruct fapp@(App f x) gapp@(App g y)

362362 = let (f',a') = unApply fapp

363363 (g',b') = unApply gapp in

364364 (f' == g' && length a' == length b' &&

@@ -389,13 +389,13 @@ unify ctxt env topx topy dont holes =

389389 P _ x _ -> x `elem` holes || patIn env x

390390 _ -> False

391391 inenv t = case t of

392− P _ x _ -> x `elem` (map fst env)

392+ P _ x _ -> x `elem` (map fst env)

393393 _ -> False

394394

395− notFn t = injective t || metavar t || inenv t

395+ notFn t = injective t || metavar t || inenv t

396396

397397

398− unifyTmpFail x y

398+ unifyTmpFail x y

399399 = do UI s f <- get

400400 let r = recoverable x y

401401 let err = CantUnify r

@@ -434,15 +434,15 @@ unify ctxt env topx topy dont holes =

434434 put (UI s ((binderTy x, binderTy y, env, err) : f))

435435 return [] -- lift $ tfail err

436436

437− checkCycle ns p@(x, P _ _ _) = return [p]

438− checkCycle ns (x, tm)

437+ checkCycle ns p@(x, P _ _ _) = return [p]

438+ checkCycle ns (x, tm)

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

441441

442442 checkScope ns (x, tm) =

443443 case boundVs (envPos x 0 env) tm of

444444 [] -> return [(x, tm)]

445− (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))

445+ (i:_) -> lift $ tfail (UnifyScope x (fst (ns!!i))

446446 (inst ns tm) (errEnv env))

447447 where inst [] tm = tm

448448 inst ((n, _) : ns) tm = inst ns (substV (P Bound n Erased) tm)

@@ -454,7 +454,7 @@ unify ctxt env topx topy dont holes =

454454

455455 combine bnames as [] = return as

456456 combine bnames as ((n, t) : bs)

457− = case lookup n as of

457+ = case lookup n as of

458458 Nothing -> combine bnames (as ++ [(n,t)]) bs

459459 Just t' -> do ns <- un' False bnames t t'

460460 -- make sure there's n mapping from n in ns

@@ -466,7 +466,7 @@ boundVs :: Int -> Term -> [Int]

466466boundVs i (V j) | j <= i = []

467467 | otherwise = [j]

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

470470 xs = boundVs i x in

471471 nub (fs ++ xs)

472472boundVs i _ = []

src/IRTS/BCImp.hs+1−1

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

11module IRTS.BCImp where

22

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

44-- imperative language where we let the language deal with GC)

55

66import IRTS.Lang

src/IRTS/CodegenC.hs+40−40

@@ -20,9 +20,9 @@ import Control.Monad

2020

2121codegenC :: [(Name, SDecl)] ->

2222 String -> -- output file name

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

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

2424 [FilePath] -> -- include files

25− String -> -- extra object files

25+ String -> -- extra object files

2626 String -> -- extra compiler flags (libraries)

2727 String -> -- extra compiler flags (anything)

2828 DbgLevel ->

@@ -34,7 +34,7 @@ codegenC defs out exec incs objs libs flags dbg

3434 let cc = concatMap (uncurry toC) bc

3535 d <- getDataDir

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

3838 (if (exec == Executable) then mprog else "")

3939 case exec of

4040 MavenProject -> putStrLn ("FAILURE: output type not supported")

@@ -94,18 +94,18 @@ creg (T i) = "TOP(" ++ show i ++ ")"

9494creg Tmp = "REG1"

9595

9696toDecl :: Name -> String

97−toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"

97+toDecl f = "void " ++ cname f ++ "(VM*, VAL*);\n"

9898

9999toC :: Name -> [BC] -> String

100−toC f code

101− = -- "/* " ++ show code ++ "*/\n\n" ++

100+toC f code

101+ = -- "/* " ++ show code ++ "*/\n\n" ++

102102 "void " ++ cname f ++ "(VM* vm, VAL* oldbase) {\n" ++

103− indent 1 ++ "INITFRAME;\n" ++

103+ indent 1 ++ "INITFRAME;\n" ++

104104 concatMap (bcc 1) code ++ "}\n\n"

105105

106106bcc :: Int -> BC -> String

107107bcc i (ASSIGN l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

108−bcc i (ASSIGNCONST l c)

108+bcc i (ASSIGNCONST l c)

109109 = indent i ++ creg l ++ " = " ++ mkConst c ++ ";\n"

110110 where

111111 mkConst (I i) = "MKINT(" ++ show i ++ ")"

@@ -123,9 +123,9 @@ bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

123123bcc i (MKCON l tag args)

124124 = indent i ++ "allocCon(" ++ creg Tmp ++ ", vm, " ++ show tag ++ "," ++

125125 show (length args) ++ ", 0);\n" ++

126− indent i ++ setArgs 0 args ++ "\n" ++

126+ indent i ++ setArgs 0 args ++ "\n" ++

127127 indent i ++ creg l ++ " = " ++ creg Tmp ++ ";\n"

128−

128+

129129-- "MKCON(vm, " ++ creg l ++ ", " ++ show tag ++ ", " ++

130130-- show (length args) ++ concatMap showArg args ++ ");\n"

131131 where showArg r = ", " ++ creg r

@@ -133,15 +133,15 @@ bcc i (MKCON l tag args)

133133 setArgs i (x : xs) = "SETARG(" ++ creg Tmp ++ ", " ++ show i ++ ", " ++ creg x ++

134134 "); " ++ setArgs (i + 1) xs

135135

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

137137 ", " ++ show a ++ ");\n"

138138bcc i (PROJECTINTO r t idx)

139− = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"

140−bcc i (CASE True r code def)

139+ = indent i ++ creg r ++ " = GETARG(" ++ creg t ++ ", " ++ show idx ++ ");\n"

140+bcc i (CASE True r code def)

141141 | length code < 4 = showCase i def code

142142 where

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

145145 indent i ++ "}\n"

146146

147147 showCase :: Int -> Maybe [BC] -> [(Int, [BC])] -> String

@@ -151,7 +151,7 @@ bcc i (CASE True r code def)

151151 = "if (CTAG(" ++ creg r ++ ") == " ++ show t ++ ") " ++ showCode i c

152152 ++ "else " ++ showCase i def cs

153153

154−bcc i (CASE safe r code def)

154+bcc i (CASE safe r code def)

155155 = indent i ++ "switch(" ++ ctag safe ++ "(" ++ creg r ++ ")) {\n" ++

156156 concatMap (showCase i) code ++

157157 showDef i def ++

@@ -163,9 +163,9 @@ bcc i (CASE safe r code def)

163163 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"

164164 ++ concatMap (bcc (i+1)) bc ++ indent (i + 1) ++ "break;\n"

165165 showDef i Nothing = ""

166− showDef i (Just c) = indent i ++ "default:\n"

166+ showDef i (Just c) = indent i ++ "default:\n"

167167 ++ concatMap (bcc (i+1)) c ++ indent (i + 1) ++ "break;\n"

168−bcc i (CONSTCASE r code def)

168+bcc i (CONSTCASE r code def)

169169 | intConsts code

170170-- = indent i ++ "switch(GETINT(" ++ creg r ++ ")) {\n" ++

171171-- concatMap (showCase i) code ++

@@ -205,11 +205,11 @@ bcc i (CONSTCASE r code def)

205205 ++ concatMap (bcc (i+1)) bc ++ indent i ++ "} else\n"

206206

207207 showCase i (t, bc) = indent i ++ "case " ++ show t ++ ":\n"

208− ++ concatMap (bcc (i+1)) bc ++

208+ ++ concatMap (bcc (i+1)) bc ++

209209 indent (i + 1) ++ "break;\n"

210210 showDef i Nothing = ""

211− showDef i (Just c) = indent i ++ "default:\n"

212− ++ concatMap (bcc (i+1)) c ++

211+ showDef i (Just c) = indent i ++ "default:\n"

212+ ++ concatMap (bcc (i+1)) c ++

213213 indent (i + 1) ++ "break;\n"

214214 showDefS i Nothing = ""

215215 showDefS i (Just c) = concatMap (bcc (i+1)) c

@@ -227,8 +227,8 @@ bcc i (BASETOP n) = indent i ++ "BASETOP(" ++ show n ++ ");\n"

227227bcc i STOREOLD = indent i ++ "STOREOLD;\n"

228228bcc i (OP l fn args) = indent i ++ doOp (creg l ++ " = ") fn args ++ ";\n"

229229bcc i (FOREIGNCALL l LANG_C rty fn args)

230− = indent i ++

231− c_irts rty (creg l ++ " = ")

230+ = indent i ++

231+ c_irts rty (creg l ++ " = ")

232232 (fn ++ "(" ++ showSep "," (map fcall args) ++ ")") ++ ";\n"

233233 where fcall (t, arg) = irts_c t (creg arg)

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

289289doOp v (LGt ITNative) [l, r] = v ++ "UINTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

290290doOp v (LGe ITNative) [l, r] = v ++ "UINTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

291291

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]

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]

294294doOp 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]

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]

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]

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]

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]

304−doOp v (LASHR ITChar) [l, r] = doOp v (LASHR ITNative) [l, r]

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]

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]

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]

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]

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]

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]

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]

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]

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]

309309doOp v (LSGt (ATInt ITChar)) [l, r] = doOp v (LSGt (ATInt ITNative)) [l, r]

310310doOp 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]

312−doOp v (LLe ITChar) [l, r] = doOp v (LLe 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]

313313doOp v (LGt ITChar) [l, r] = doOp v (LGt ITNative) [l, r]

314314doOp v (LGe ITChar) [l, r] = doOp v (LGe ITNative) [l, r]

315315

src/IRTS/CodegenLLVM.hs+4−4

@@ -216,7 +216,7 @@ initDefs tgt =

216216 , G.name = Name $ "__idris_" ++ name

217217 , G.basicBlocks = def

218218 }

219−

219+

220220 exfun :: String -> Type -> [Type] -> Bool -> Definition

221221 exfun name rty argtys vari =

222222 GlobalDefinition $ functionDefaults

@@ -562,7 +562,7 @@ cgCase val alts =

562562 defExp = getDefExp =<< find isDefCase alts

563563 constAlts = filter isConstCase alts

564564 conAlts = filter isConCase alts

565−

565+

566566 isConstCase (SConstCase {}) = True

567567 isConstCase _ = False

568568

@@ -806,7 +806,7 @@ addGlobal' ty val = do

806806 , G.initializer = Just val

807807 }

808808 return . C.GlobalReference $ name

809−

809+

810810

811811ensureCDecl :: String -> FType -> [FType] -> Codegen Operand

812812ensureCDecl name rty argtys = do

@@ -1110,7 +1110,7 @@ cgStrCat x y = do

11101110 end <- inst $ IntToPtr offj (PointerType (IntegerType 8) (AddrSpace 0)) []

11111111 inst' $ Store False end (ConstantOperand (C.Int 8 0)) Nothing 0 []

11121112 box FString mem

1113−

1113+

11141114ibin :: IntTy -> Operand -> Operand

11151115 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand

11161116ibin ity x y instCon = do

src/IRTS/Compiler.hs+30−30

@@ -80,7 +80,7 @@ compile codegen f tm

8080 ViaC ->

8181 codegenC c f outty hdrs

8282 (concatMap mkObj objs)

83− (concatMap mkLib libs)

83+ (concatMap mkLib libs)

8484 (concatMap mkFlag flags ++

8585 concatMap incdir impdirs) NONE

8686 ViaJava ->

@@ -114,12 +114,12 @@ allNames :: [Name] -> Name -> Idris [Name]

114114allNames ns n | n `elem` ns = return []

115115allNames ns n = do i <- getIState

116116 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'))

118118 return (nub (n : concat more))

119119 _ -> return [n]

120120

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

122−mkDecls t used

122+mkDecls t used

123123 = do i <- getIState

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

125125 mapM traceUnused used

@@ -129,10 +129,10 @@ mkDecls t used

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

130130showCaseTrees ds = showSep "\n\n" (map showCT ds)

131131 where

132− showCT (n, LFun _ f args lexp)

132+ showCT (n, LFun _ f args lexp)

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

134− ++ show lexp

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

134+ ++ show lexp

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

136136

137137isCon (TyDecl _ _) = True

138138isCon _ = False

@@ -144,9 +144,9 @@ build :: (Name, Def) -> Idris (Name, LDecl)

144144build (n, d)

145145 = do i <- getIState

146146 case lookup n (idris_scprims i) of

147− Just (ar, op) ->

147+ Just (ar, op) ->

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

150150 (LOp op (map (LV . Glob) (take ar args)))))

151151 _ -> do def <- mkLDecl n d

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

@@ -154,18 +154,18 @@ build (n, d)

154154

155155getPrim :: IState -> Name -> [LExp] -> Maybe LExp

156156getPrim i n args = case lookup n (idris_scprims i) of

157− Just (ar, op) ->

158− if (ar == length args)

157+ Just (ar, op) ->

158+ if (ar == length args)

159159 then return (LOp op args)

160160 else Nothing

161161 _ -> Nothing

162162

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

165165

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

167167 return (declArgs [] True n e)

168−mkLDecl n (CaseOp ci _ _ pats cd)

168+mkLDecl n (CaseOp ci _ _ pats cd)

169169 = let (args, sc) = cases_runtime cd in

170170 do e <- ir (args, sc)

171171 return (declArgs [] (case_inlinable ci) n e)

@@ -173,14 +173,14 @@ mkLDecl n (TyDecl (DCon t a) _) = return $ LConstructor n t a

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

174174mkLDecl n _ = return (LFun [] n [] (LError ("Impossible declaration " ++ show n)))

175175

176−instance ToIR (TT Name) where

176+instance ToIR (TT Name) where

177177 ir tm = ir' [] tm where

178178 ir' env tm@(App f a)

179179 | (P _ (UN "mkForeignPrim") _, args) <- unApply tm

180180 = doForeign env args

181181 | (P _ (UN "unsafePerformPrimIO") _, [_, arg]) <- unApply tm

182182 = ir' env arg

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

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

184184 | (P _ (UN "replace") _, [_, _, _, _, _, arg]) <- unApply tm

185185 = ir' env arg

186186 | (P _ (UN "lazy") _, [_, arg]) <- unApply tm

@@ -198,11 +198,11 @@ instance ToIR (TT Name) where

198198-- = do v' <- ir' env v

199199-- return v'

200200-- | (P _ (UN "prim_io_bind") _, [_,_,v,Bind n (Lam _) sc]) <- unApply tm

201−-- = do v' <- ir' env v

201+-- = do v' <- ir' env v

202202-- sc' <- ir' (n:env) sc

203203-- return (LLet n (LForce v') sc')

204204-- | (P _ (UN "prim_io_bind") _, [_,_,v,k]) <- unApply tm

205−-- = do v' <- ir' env v

205+-- = do v' <- ir' env v

206206-- k' <- ir' env k

207207-- return (LApp False k' [LForce v'])

208208 | (P _ (UN "malloc") _, [_,size,t]) <- unApply tm

@@ -223,20 +223,20 @@ instance ToIR (TT Name) where

223223 case getPrim i n args' of

224224 Just tm -> return tm

225225 _ -> do

226− let collapse

226+ let collapse

227227 = case lookupCtxtExact n

228228 (idris_optimisation i) of

229229 [oi] -> collapsible oi

230230 _ -> False

231− let unused

231+ let unused

232232 = case lookupCtxtExact n

233233 (idris_callgraph i) of

234− [CGInfo _ _ _ _ unusedpos] ->

234+ [CGInfo _ _ _ _ unusedpos] ->

235235 unusedpos

236236 _ -> []

237− if collapse

237+ if collapse

238238 then return LNothing

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

239+ else return (LApp False (LV (Glob n))

240240 (mkUnused unused 0 args'))

241241 | (f, args) <- unApply tm

242242 = do f' <- ir' env f

@@ -270,10 +270,10 @@ instance ToIR (TT Name) where

270270 irCon env t arity n args

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

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

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

273+ do sc' <- irCon env t arity n

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

275275 return $ LLam extra sc'

276−

276+

277277 satArgs n = map (\i -> MN i "sat") [1..n]

278278

279279 buildApp env e [] = return e

@@ -298,7 +298,7 @@ instance ToIR (TT Name) where

298298getFTypes :: TT Name -> Maybe [FType]

299299getFTypes tm = case unApply tm of

300300 (nil, []) -> Just []

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

301+ (cons, [ty, xs]) ->

302302 fmap (mkIty' ty :) (getFTypes xs)

303303 _ -> Nothing

304304

@@ -340,7 +340,7 @@ mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))

340340mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))

341341

342342zname = NS (UN "Z") ["Nat","Prelude"]

343−sname = NS (UN "S") ["Nat","Prelude"]

343+sname = NS (UN "S") ["Nat","Prelude"]

344344

345345instance ToIR ([Name], SC) where

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

@@ -367,9 +367,9 @@ instance ToIR SC where

367367-- = do n' <- ir n

368368-- rhs' <- ir rhs

369369-- return $ LDefaultCase

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

370+-- (LLet arg (LOp LBMinus [n', LConst (BI 1)])

371371-- rhs')

372− mkIRAlt _ (ConCase n t args rhs)

372+ mkIRAlt _ (ConCase n t args rhs)

373373 = do rhs' <- ir rhs

374374 return $ LConCase (-1) n args rhs'

375375 mkIRAlt _ (ConstCase x rhs)

@@ -377,15 +377,15 @@ instance ToIR SC where

377377 = do rhs' <- ir rhs

378378 return $ LConstCase x rhs'

379379 | matchableTy x

380− = do rhs' <- ir rhs

380+ = do rhs' <- ir rhs

381381 return $ LDefaultCase rhs'

382− mkIRAlt tm (SucCase n rhs)

382+ mkIRAlt tm (SucCase n rhs)

383383 = do rhs' <- ir rhs

384384 return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))

385385 [tm,

386386 LConst (BI 1)]) rhs')

387387-- return $ LSucCase n rhs'

388− mkIRAlt _ (ConstCase c rhs)

388+ mkIRAlt _ (ConstCase c rhs)

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

390390 mkIRAlt _ (DefaultCase rhs)

391391 = 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,

22 module IRTS.Lang) where

33

44import IRTS.Lang

@@ -37,8 +37,8 @@ data DDecl = DFun Name [Name] DExp -- name, arg names, definition

3737

3838type DDefs = Ctxt DDecl

3939

40−defunctionalise :: Int -> LDefs -> DDefs

41−defunctionalise nexttag defs

40+defunctionalise :: Int -> LDefs -> DDefs

41+defunctionalise nexttag defs

4242 = let all = toAlist defs

4343 -- sort newcons so that EVAL and APPLY cons get sequential tags

4444 (allD, enames) = runState (mapM (addApps defs) all) []

@@ -51,7 +51,7 @@ defunctionalise nexttag defs

5151

5252getFn :: [(Name, LDecl)] -> [(Name, Int)]

5353getFn xs = mapMaybe fnData xs

54− where fnData (n, LFun _ _ args _) = Just (n, length args)

54+ where fnData (n, LFun _ _ args _) = Just (n, length args)

5555 fnData _ = Nothing

5656

5757-- To defunctionalise:

@@ -68,9 +68,9 @@ getFn xs = mapMaybe fnData xs

6868-- 8 Add explicit EVAL to case, primitives, and foreign calls

6969

7070addApps :: LDefs -> (Name, LDecl) -> State [Name] (Name, DDecl)

71−addApps defs o@(n, LConstructor _ t a)

72− = return (n, DConstructor n t a)

73−addApps defs (n, LFun _ _ args e)

71+addApps defs o@(n, LConstructor _ t a)

72+ = return (n, DConstructor n t a)

73+addApps defs (n, LFun _ _ args e)

7474 = do e' <- aa args e

7575 return (n, DFun n args e')

7676 where

@@ -79,7 +79,7 @@ addApps defs (n, LFun _ _ args e)

7979 | otherwise = aa env (LApp False (LV (Glob n)) [])

8080-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e

8181 aa env (LApp tc (LV (Glob n)) args)

82− = do args' <- mapM (aa env) args

82+ = do args' <- mapM (aa env) args

8383 case lookupCtxtExact n defs of

8484 [LConstructor _ i ar] -> return $ DApp tc n args'

8585 [LFun _ _ as _] -> let arity = length as in

@@ -96,7 +96,7 @@ addApps defs (n, LFun _ _ args e)

9696 aa env (LForce e) = liftM eEVAL (aa env e)

9797 aa env (LLet n v sc) = liftM2 (DLet n) (aa env v) (aa (n : env) sc)

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

100100 = do t' <- aa env t

101101 return $ DProj (DUpdate n (eEVAL t')) i

102102 aa env (LProj t i) = do t' <- aa env t

@@ -115,33 +115,33 @@ addApps defs (n, LFun _ _ args e)

115115 aaF env (t, e) = do e' <- aa env e

116116 return (t, eEVAL e')

117117

118− aaAlt env (LConCase i n args e)

118+ aaAlt env (LConCase i n args e)

119119 = liftM (DConCase i n args) (aa (args ++ env) e)

120120 aaAlt env (LConstCase c e) = liftM (DConstCase c) (aa env e)

121121 aaAlt env (LDefaultCase e) = liftM DDefaultCase (aa env e)

122122

123− fixApply tc n args ar

124− | length args == ar

123+ fixApply tc n args ar

124+ | length args == ar

125125 = return $ DApp tc n args

126− | length args < ar

126+ | length args < ar

127127 = do ns <- get

128128 put $ nub (n : ns)

129129 return $ DApp tc (mkUnderCon n (ar - length args)) args

130− | length args > ar

130+ | length args > ar

131131 = return $ chainAPPLY (DApp tc n (take ar args)) (drop ar args)

132132

133− fixLazyApply n args ar

134− | length args == ar

133+ fixLazyApply n args ar

134+ | length args == ar

135135 = do ns <- get

136136 put $ nub (n : ns)

137137 return $ DApp False (mkFnCon n) args

138− | length args < ar

138+ | length args < ar

139139 = do ns <- get

140140 put $ nub (n : ns)

141141 return $ DApp False (mkUnderCon n (ar - length args)) args

142− | length args > ar

142+ | length args > ar

143143 = return $ chainAPPLY (DApp False n (take ar args)) (drop ar args)

144−

144+

145145 chainAPPLY f [] = f

146146 chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as

147147

@@ -149,7 +149,7 @@ addApps defs (n, LFun _ _ args e)

149149 -- but we only want to do it once, rather than every time we project.

150150

151151 preEval [] t = t

152− preEval (x : xs) t

152+ preEval (x : xs) t

153153 | needsEval x t = DLet x (eEVAL (DV (Glob x))) (preEval xs t)

154154 | otherwise = preEval xs t

155155

@@ -163,7 +163,7 @@ addApps defs (n, LFun _ _ args e)

163163 where nec (DConCase _ _ _ e) = needsEval x e

164164 nec (DConstCase _ e) = needsEval x e

165165 nec (DDefaultCase e) = needsEval x e

166− needsEval x (DLet n v e)

166+ needsEval x (DLet n v e)

167167 | x == n = needsEval x v

168168 | otherwise = needsEval x v || needsEval x e

169169 needsEval x (DForeign _ _ _ args) = or (map (needsEval x) (map snd args))

@@ -181,9 +181,9 @@ data EvalApply a = EvalCase (Name -> a)

181181-- data constuctors, and whether to handle them in EVAL or APPLY

182182

183183toCons :: [Name] -> (Name, Int) -> [(Name, Int, EvalApply DAlt)]

184−toCons ns (n, i)

184+toCons ns (n, i)

185185 | n `elem` ns

186− = (mkFnCon n, i,

186+ = (mkFnCon n, i,

187187 EvalCase (\tlarg ->

188188 (DConCase (-1) (mkFnCon n) (take i (genArgs 0))

189189 (dupdate tlarg

@@ -193,11 +193,11 @@ toCons ns (n, i)

193193 where dupdate tlarg x = x

194194

195195mkApplyCase fname n ar | n == ar = []

196−mkApplyCase fname n ar

196+mkApplyCase fname n ar

197197 = let nm = mkUnderCon fname (ar - n) in

198198 (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))

199− (DApp False (mkUnderCon fname (ar - (n + 1)))

200− (map (DV . Glob) (take n (genArgs 0) ++

199+ (DApp False (mkUnderCon fname (ar - (n + 1)))

200+ (map (DV . Glob) (take n (genArgs 0) ++

201201 [MN 0 "arg"])))))

202202 : mkApplyCase fname (n + 1) ar

203203

@@ -207,7 +207,7 @@ mkEval xs = (MN 0 "EVAL", DFun (MN 0 "EVAL") [MN 0 "arg"]

207207 (mapMaybe evalCase xs ++

208208 [DDefaultCase (DV (Glob (MN 0 "arg")))])))

209209 where

210− evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg"))

210+ evalCase (n, t, EvalCase x) = Just (x (MN 0 "arg"))

211211 evalCase _ = Nothing

212212

213213mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)

@@ -259,7 +259,7 @@ instance Show DExp where

259259 show' env (DError str) = "error " ++ show str

260260 show' env DNothing = "____"

261261

262− showAlt env (DConCase _ n args e)

262+ showAlt env (DConCase _ n args e)

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

264264 ++ show' env e

265265 showAlt env (DConstCase c e) = show c ++ " => " ++ show' env e

@@ -268,7 +268,7 @@ instance Show DExp where

268268-- Divide up a large case expression so that each has a maximum of

269269-- 'max' branches

270270

271−mkBigCase cn max arg branches

271+mkBigCase cn max arg branches

272272 | length branches <= max = DChkCase arg branches

273273 | otherwise = -- DChkCase arg branches -- until I think of something...

274274 -- divide the branches into groups of at most max (by tag),

@@ -281,7 +281,7 @@ mkBigCase cn max arg branches

281281 cs = map mkCase bss in

282282 DChkCase arg branches

283283

284− where mkCase bs = DChkCase arg bs

284+ where mkCase bs = DChkCase arg bs

285285

286286 tagOrd (DConCase t _ _ _) (DConCase t' _ _ _) = compare t t'

287287 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

309309

310310dumpDefuns :: DDefs -> String

311311dumpDefuns ds = showSep "\n" $ map showDef (toAlist ds)

312− where showDef (x, DFun fn args exp)

312+ where showDef (x, DFun fn args exp)

313313 = show fn ++ "(" ++ showSep ", " (map show args) ++ ") = \n\t" ++

314314 show exp ++ "\n"

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

5050 CALL x -> "CALL " ++ show x

5151 TAILCALL x -> "TAILCALL " ++ show x

5252 FOREIGNCALL r _ ret name args ->

53− "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret ++

53+ "FOREIGNCALL " ++ serializeReg r ++ " \"" ++ name ++ "\" " ++ show ret ++

5454 " [" ++ interMap args ", " (\(ty, r) -> serializeReg r ++ " : " ++ show ty) ++ "]"

5555 SLIDE n -> "SLIDE " ++ show n

5656 REBASE -> "REBASE"

src/IRTS/Inliner.hs+2−2

@@ -4,13 +4,13 @@ import Core.TT

44

55import IRTS.Defunctionalise

66

7−inline :: DDefs -> DDefs

7+inline :: DDefs -> DDefs

88inline xs = let sep = toAlist xs

99 inls = map (inl xs) sep in

1010 addAlist inls emptyContext

1111

1212inl :: DDefs -> (Name, DDecl) -> (Name, DDecl)

13−inl ds d@(n, DFun n' args exp)

13+inl ds d@(n, DFun n' args exp)

1414 = case evalD ds exp of

1515 Just exp' -> (n, DFun n' args exp')

1616 _ -> d

src/IRTS/LParser.hs+13−13

@@ -31,7 +31,7 @@ type TokenParser a = PTok.TokenParser a

3131type LParser = GenParser Char ()

3232

3333lexer :: TokenParser ()

34−lexer = idrisLexer

34+lexer = idrisLexer

3535

3636whiteSpace= PTok.whiteSpace lexer

3737lexeme = PTok.lexeme lexer

@@ -75,7 +75,7 @@ parseFOVM fname = do -- putStrLn $ "Reading " ++ fname

7575pProgram :: LParser [(Name, LDecl)]

7676pProgram = do fs <- many1 pLDecl

7777 eof

78− return fs

78+ return fs

7979

8080pLDecl :: LParser (Name, LDecl)

8181pLDecl = do reserved "data"

@@ -91,7 +91,7 @@ pLDecl = do reserved "data"

9191 def <- pLExp

9292 return (n, LFun [] n args def)

9393

94−pLExp = buildExpressionParser optable pLExp'

94+pLExp = buildExpressionParser optable pLExp'

9595

9696optable = [[binary "*" (\x y -> LOp (LTimes (ATInt ITNative)) [x,y]) AssocLeft,

9797 binary "/" (\x y -> LOp (LSDiv (ATInt ITNative)) [x,y]) AssocLeft,

@@ -149,9 +149,9 @@ pLExp' = try (do lchar '%'; pCast)

149149 lchar '('

150150 args <- sepBy pLExp (lchar ',')

151151 lchar ')'

152− if null args

152+ if null args

153153 then if lazy then return (LLazyApp x [])

154− else return (LV (Glob x))

154+ else return (LV (Glob x))

155155 else if lazy then return (LLazyApp x args)

156156 else return (LApp tc (LV (Glob x)) args))

157157 <|> do lchar '('; e <- pLExp; lchar ')'; return e

@@ -172,7 +172,7 @@ pLExp' = try (do lchar '%'; pCast)

172172 <|> pCase

173173 <|> do x <- iName []

174174 return (LV (Glob x))

175−

175+

176176pLang = do reserved "C"; return LANG_C

177177

178178pType = do reserved "Int"; return (FArith (ATInt ITNative))

@@ -215,10 +215,10 @@ pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'

215215pPrim :: LParser LExp

216216pPrim = do reserved "StrEq"; lchar '(';

217217 e <- pLExp; lchar ',';

218− e' <- pLExp; lchar ')';

218+ e' <- pLExp; lchar ')';

219219 return (LOp LStrEq [e, e'])

220220 <|> do reserved "StrLt"; lchar '('

221− e <- pLExp; lchar ','; e' <- pLExp;

221+ e <- pLExp; lchar ','; e' <- pLExp;

222222 lchar ')'

223223 return (LOp LStrLt [e, e'])

224224 <|> do reserved "StrLen"; lchar '('; e <- pLExp; lchar ')';

@@ -228,7 +228,7 @@ pPrim = do reserved "StrEq"; lchar '(';

228228 <|> do reserved "WriteString"; lchar '(';

229229 e <- pLExp; lchar ')'

230230 return (LOp LPrintStr [e])

231− <|> do reserved "WriteInt"; lchar '(';

231+ <|> do reserved "WriteInt"; lchar '(';

232232 e <- pLExp; lchar ')';

233233 return (LOp LPrintNum [e])

234234 <|> do reserved "lazy"; lchar '(';

@@ -240,10 +240,10 @@ pPrim = do reserved "StrEq"; lchar '(';

240240 return (LOp LStrTail [e])

241241 <|> do reserved "StrRev"; lchar '('; e <- pLExp; lchar ')';

242242 return (LOp LStrRev [e])

243− <|> do reserved "StrCons"; lchar '('; x <- pLExp; lchar ',';

243+ <|> do reserved "StrCons"; lchar '('; x <- pLExp; lchar ',';

244244 xs <- pLExp; lchar ')';

245245 return (LOp LStrCons [x, xs])

246− <|> do reserved "StrIndex"; lchar '('; x <- pLExp; lchar ',';

246+ <|> do reserved "StrIndex"; lchar '('; x <- pLExp; lchar ',';

247247 i <- pLExp; lchar ')';

248248 return (LOp LStrIndex [x, i])

249249

@@ -269,8 +269,8 @@ pAlt = try (do x <- iName []

269269

270270pLConst :: LParser LExp

271271pLConst = try (do f <- float; return $ LConst (Fl f))

272− <|> try (do i <- natural; lchar ':'; return $ LConst (BI i))

273− <|> try (do i <- natural; return $ LConst (I (fromInteger i)))

272+ <|> try (do i <- natural; lchar ':'; return $ LConst (BI i))

273+ <|> try (do i <- natural; return $ LConst (I (fromInteger i)))

274274 <|> try (do s <- strlit; return $ LConst (Str s))

275275 <|> try (do c <- chlit; return $ LConst (Ch c))

276276

src/IRTS/Simplified.hs+20−20

@@ -7,7 +7,7 @@ import Control.Monad.State

77

88import Debug.Trace

99

10−-- Simplified expressions, where functions/constructors can only be applied

10+-- Simplified expressions, where functions/constructors can only be applied

1111-- to variables

1212

1313data SExp = SV LVar

@@ -44,14 +44,14 @@ ldefs = do (l, h) <- get

4444

4545simplify :: Bool -> DExp -> State (DDefs, Int) SExp

4646simplify tl (DV (Loc i)) = return (SV (Loc i))

47−simplify tl (DV (Glob x))

47+simplify tl (DV (Glob x))

4848 = do ctxt <- ldefs

4949 case lookupCtxtExact x ctxt of

5050 [DConstructor _ t 0] -> return $ SCon t x []

5151 _ -> return $ SV (Glob x)

5252simplify tl (DApp tc n args) = do args' <- mapM sVar args

5353 mkapp (SApp (tl || tc) n) args'

54−simplify tl (DForeign lang ty fn args)

54+simplify tl (DForeign lang ty fn args)

5555 = do args' <- mapM sVar (map snd args)

5656 let fargs = zip (map fst args) args'

5757 mkfapp (SForeign lang ty fn) fargs

@@ -69,21 +69,21 @@ simplify tl (DProj t i) = do v <- sVar t

6969 return (SLet (Glob x) e (SProj (Glob x) i))

7070simplify tl (DCase e alts) = do v <- sVar e

7171 alts' <- mapM (sAlt tl) alts

72− case v of

72+ case v of

7373 (x, Nothing) -> return (SCase x alts')

74− (Glob x, Just e) ->

74+ (Glob x, Just e) ->

7575 return (SLet (Glob x) e (SCase (Glob x) alts'))

76−simplify tl (DChkCase e alts)

76+simplify tl (DChkCase e alts)

7777 = do v <- sVar e

7878 alts' <- mapM (sAlt tl) alts

79− case v of

79+ case v of

8080 (x, Nothing) -> return (SChkCase x alts')

81− (Glob x, Just e) ->

81+ (Glob x, Just e) ->

8282 return (SLet (Glob x) e (SChkCase (Glob x) alts'))

8383simplify tl (DConst c) = return (SConst c)

8484simplify tl (DOp p args) = do args' <- mapM sVar args

8585 mkapp (SOp p) args'

86−simplify tl DNothing = return SNothing

86+simplify tl DNothing = return SNothing

8787simplify tl (DError str) = return $ SError str

8888

8989sVar (DV (Glob x))

@@ -99,14 +99,14 @@ sVar e = do e' <- simplify False e

9999mkapp f args = mkapp' f args [] where

100100 mkapp' f [] args = return $ f (reverse args)

101101 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

103103 = do sc <- mkapp' f xs (x : args)

104104 return (SLet x e sc)

105105

106106mkfapp f args = mkapp' f args [] where

107107 mkapp' f [] args = return $ f (reverse args)

108108 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

110110 = do sc <- mkapp' f xs ((ty, x) : args)

111111 return (SLet x e sc)

112112

@@ -119,10 +119,10 @@ sAlt tl (DDefaultCase e) = do e' <- simplify tl e

119119

120120checkDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]

121121checkDefs ctxt [] = return []

122−checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)

122+checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)

123123 = do xs' <- checkDefs ctxt xs

124124 return xs'

125−checkDefs ctxt ((n, DFun n' args exp) : xs)

125+checkDefs ctxt ((n, DFun n' args exp) : xs)

126126 = do let sexp = evalState (simplify True exp) (ctxt, 0)

127127 (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args)

128128 xs' <- checkDefs ctxt xs

@@ -131,14 +131,14 @@ checkDefs ctxt ((n, DFun n' args exp) : xs)

131131lvar v = do i <- get

132132 put (max i v)

133133

134−scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp

134+scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp

135135scopecheck ctxt envTop tm = sc envTop tm where

136136 sc env (SV (Glob n)) =

137137 case lookup n (reverse env) of -- most recent first

138138 Just i -> do lvar i; return (SV (Loc i))

139139 Nothing -> case lookupCtxtExact n ctxt of

140140 [DConstructor _ i ar] ->

141− if True -- ar == 0

141+ if True -- ar == 0

142142 then return (SCon i n [])

143143 else fail $ "Codegen error: Constructor " ++ show n ++

144144 " has arity " ++ show ar

@@ -150,7 +150,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

150150 [DConstructor n tag ar] ->

151151 if True -- (ar == length args)

152152 then return $ SCon tag n args'

153− else fail $ "Codegen error: Constructor " ++ show f ++

153+ else fail $ "Codegen error: Constructor " ++ show f ++

154154 " has arity " ++ show ar

155155 [_] -> return $ SApp tc f args'

156156 [] -> fail $ "Codegen error: No such variable " ++ show f

@@ -164,7 +164,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

164164 [DConstructor n tag ar] ->

165165 if True -- (ar == length args)

166166 then return $ SCon tag n args'

167− else fail $ "Codegen error: Constructor " ++ show f ++

167+ else fail $ "Codegen error: Constructor " ++ show f ++

168168 " has arity " ++ show ar

169169 _ -> fail $ "Codegen error: No such constructor " ++ show f

170170 sc env (SProj e i)

@@ -201,15 +201,15 @@ scopecheck ctxt envTop tm = sc envTop tm where

201201 [DConstructor _ i ar] ->

202202 fail $ "Codegen error : can't pass constructor here"

203203 [_] -> return (Glob n)

204− [] -> fail $ "Codegen error: No such variable " ++ show n ++

204+ [] -> fail $ "Codegen error: No such variable " ++ show n ++

205205 " in " ++ show tm ++ " " ++ show envTop

206206 scVar _ x = return x

207207

208208 scalt env (SConCase _ i n args e)

209209 = do let env' = env ++ zip args [length env..]

210210 tag <- case lookupCtxtExact n ctxt of

211− [DConstructor _ i ar] ->

212− if True -- (length args == ar)

211+ [DConstructor _ i ar] ->

212+ if True -- (length args == ar)

213213 then return i

214214 else fail $ "Codegen error: Constructor " ++ show n ++

215215 " has arity " ++ show ar

src/Idris/AbsSyntax.hs+108−108

@@ -90,7 +90,7 @@ addLangExt ErrorReflection = do i <- getIState

9090 }

9191

9292addTrans :: (Term, Term) -> Idris ()

93−addTrans t = do i <- getIState

93+addTrans t = do i <- getIState

9494 putIState $ i { idris_transforms = t : idris_transforms i }

9595

9696totcheck :: (FC, Name) -> Idris ()

@@ -103,19 +103,19 @@ setFlags :: Name -> [FnOpt] -> Idris ()

103103setFlags n fs = do i <- getIState; putIState $ i { idris_flags = addDef n fs (idris_flags i) }

104104

105105setAccessibility :: Name -> Accessibility -> Idris ()

106−setAccessibility n a

106+setAccessibility n a

107107 = do i <- getIState

108108 let ctxt = setAccess n a (tt_ctxt i)

109109 putIState $ i { tt_ctxt = ctxt }

110110

111111setTotality :: Name -> Totality -> Idris ()

112−setTotality n a

112+setTotality n a

113113 = do i <- getIState

114114 let ctxt = setTotal n a (tt_ctxt i)

115115 putIState $ i { tt_ctxt = ctxt }

116116

117117getTotality :: Name -> Idris Totality

118−getTotality n

118+getTotality n

119119 = do i <- getIState

120120 case lookupTotal n (tt_ctxt i) of

121121 [t] -> return t

@@ -131,13 +131,13 @@ getCoercionsTo i ty =

131131 findCoercions t (n : ns) =

132132 let ps = case lookupTy n (tt_ctxt i) of

133133 [ty] -> case unApply (getRetTy ty) of

134− (t', _) ->

134+ (t', _) ->

135135 if t == t' then [n] else []

136136 _ -> [] in

137137 ps ++ findCoercions t ns

138138

139139addToCG :: Name -> CGInfo -> Idris ()

140−addToCG n cg

140+addToCG n cg

141141 = do i <- getIState

142142 putIState $ i { idris_callgraph = addDef n cg (idris_callgraph i) }

143143

@@ -146,7 +146,7 @@ addCoercion n = do i <- getIState

146146 putIState $ i { idris_coercions = nub $ n : idris_coercions i }

147147

148148addDocStr :: Name -> String -> Idris ()

149−addDocStr n doc

149+addDocStr n doc

150150 = do i <- getIState

151151 putIState $ i { idris_docstrings = addDef n doc (idris_docstrings i) }

152152

@@ -158,7 +158,7 @@ addToCalledG n ns = return () -- TODO

158158-- Dodgy hack 2: put constraint chasers (@@) last

159159

160160addInstance :: Bool -> Name -> Name -> Idris ()

161−addInstance int n i

161+addInstance int n i

162162 = do ist <- getIState

163163 case lookupCtxt n (idris_classes ist) of

164164 [CI a b c d ins] ->

@@ -178,7 +178,7 @@ addInstance int n i

178178 chaser _ = False

179179

180180addClass :: Name -> ClassInfo -> Idris ()

181−addClass n i

181+addClass n i

182182 = do ist <- getIState

183183 let i' = case lookupCtxt n (idris_classes ist) of

184184 [c] -> c { class_instances = class_instances i }

@@ -186,7 +186,7 @@ addClass n i

186186 putIState $ ist { idris_classes = addDef n i' (idris_classes ist) }

187187

188188addIBC :: IBCWrite -> Idris ()

189−addIBC ibc@(IBCDef n)

189+addIBC ibc@(IBCDef n)

190190 = do i <- getIState

191191 when (notDef (ibc_write i)) $

192192 putIState $ i { ibc_write = ibc : ibc_write i }

@@ -249,15 +249,15 @@ getInternalApp fp l = do i <- getIState

249249 -- TODO: What if it's not there?

250250

251251checkUndefined :: FC -> Name -> Idris ()

252−checkUndefined fc n

252+checkUndefined fc n

253253 = do i <- getContext

254254 case lookupTy n i of

255− (_:_) -> fail $ show fc ++ ":" ++

255+ (_:_) -> fail $ show fc ++ ":" ++

256256 show n ++ " already defined"

257257 _ -> return ()

258258

259259isUndefined :: FC -> Name -> Idris Bool

260−isUndefined fc n

260+isUndefined fc n

261261 = do i <- getContext

262262 case lookupTy n i of

263263 (_:_) -> return False

@@ -282,10 +282,10 @@ addDeferred = addDeferred' Ref

282282addDeferredTyCon = addDeferred' (TCon 0 0)

283283

284284addDeferred' :: NameType -> [(Name, (Int, Maybe Name, Type))] -> Idris ()

285−addDeferred' nt ns

285+addDeferred' nt ns

286286 = do mapM_ (\(n, (i, _, t)) -> updateContext (addTyDecl n nt (tidyNames [] t))) ns

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

289289 idris_metavars i }

290290 where tidyNames used (Bind (MN i x) b sc)

291291 = let n' = uniqueName (UN x) used in

@@ -297,7 +297,7 @@ addDeferred' nt ns

297297

298298solveDeferred :: Name -> Idris ()

299299solveDeferred n = do i <- getIState

300− putIState $ i { idris_metavars =

300+ putIState $ i { idris_metavars =

301301 filter (\(n', _) -> n/=n')

302302 (idris_metavars i) }

303303

@@ -607,7 +607,7 @@ bi = fileFC "builtin"

607607

608608inferTy = MN 0 "__Infer"

609609inferCon = MN 0 "__infer"

610−inferDecl = PDatadecl inferTy

610+inferDecl = PDatadecl inferTy

611611 PType

612612 [("", inferCon, PPi impl (MN 0 "A") PType (

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

644644 [("", pairCon, PPi impl (n "A") PType (

645645 PPi impl (n "B") PType (

646646 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"))

648648 (PApp bi (PRef bi pairTy) [pexp (PRef bi (n "A")),

649649 pexp (PRef bi (n "B"))])))), bi)]

650650 where n a = MN 0 a

@@ -672,10 +672,10 @@ piBind = piBindp expl

672672piBindp :: Plicity -> [(Name, PTerm)] -> PTerm -> PTerm

673673piBindp p [] t = t

674674piBindp p ((n, ty):ns) t = PPi p n ty (piBindp p ns t)

675−

675+

676676-- Dealing with parameters

677677

678−expandParams :: (Name -> Name) -> [(Name, PTerm)] ->

678+expandParams :: (Name -> Name) -> [(Name, PTerm)] ->

679679 [Name] -> -- all names

680680 [Name] -> -- names with no declaration

681681 PTerm -> PTerm

@@ -686,7 +686,7 @@ expandParams dec ps ns infs tm = en tm

686686 -- binding and once to call the lifted functions. So we'll explicitly shadow

687687 -- it. (Yes, it's a hack. The alternative would be to resolve names earlier

688688 -- but we didn't...)

689−

689+

690690 mkShadow (UN n) = MN 0 n

691691 mkShadow (MN i n) = MN (i+1) n

692692 mkShadow (NS x s) = NS (mkShadow x) s

@@ -696,18 +696,18 @@ expandParams dec ps ns infs tm = en tm

696696 = let n' = mkShadow n in

697697 PLam n' (en t) (en (shadow n n' s))

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

699− en (PPi p n t s)

699+ en (PPi p n t s)

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

701701 = let n' = mkShadow n in

702702 PPi p n' (en t) (en (shadow n n' s))

703703 | otherwise = PPi p n (en t) (en s)

704− en (PLet n ty v s)

704+ en (PLet n ty v s)

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

706706 = let n' = mkShadow n in

707707 PLet n' (en ty) (en v) (en (shadow n n' s))

708708 | otherwise = PLet n (en ty) (en v) (en s)

709− -- FIXME: Should only do this in a type signature!

710− en (PDPair f (PRef f' n) t r)

709+ -- FIXME: Should only do this in a type signature!

710+ en (PDPair f (PRef f' n) t r)

711711 | n `elem` (map fst ps ++ ns) && t /= Placeholder

712712 = let n' = mkShadow n in

713713 PDPair f (PRef f' n') (en t) (en (shadow n n' r))

@@ -724,28 +724,28 @@ expandParams dec ps ns infs tm = en tm

724724 en (PProof ts) = PProof (map (fmap en) ts)

725725 en (PTactics ts) = PTactics (map (fmap en) ts)

726726

727− en (PQuote (Var n))

727+ en (PQuote (Var n))

728728 | n `nselem` ns = PQuote (Var (dec n))

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

731731 (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as))

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

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

736736 (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as))

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

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

741741 (map (pexp . (PRef fc)) (map fst ps) ++ (map (fmap en) as))

742742 en (PRef fc n)

743− | n `elem` infs = PApp fc (PInferRef fc (dec n))

743+ | n `elem` infs = PApp fc (PInferRef fc (dec n))

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

746746 (map (pexp . (PRef fc)) (map fst ps))

747747 en (PInferRef fc n)

748− | n `nselem` ns = PApp fc (PInferRef fc (dec n))

748+ | n `nselem` ns = PApp fc (PInferRef fc (dec n))

749749 (map (pexp . (PRef fc)) (map fst ps))

750750 en (PApp fc f as) = PApp fc (en f) (map (fmap en) as)

751751 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

759759 nseq x y = nsroot x == nsroot y

760760

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

762− IState ->

762+ IState ->

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

765765 = if n `elem` ns && (not rhsonly)

766766 then -- trace (show (n, expandParams dec ps ns ty)) $

767767 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)) $

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

771771 = if n `elem` ns && (not rhsonly)

772772 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

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

776776 PPostulate doc syn fc o n (expandParams dec ps ns [] ty)

777777expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

778778 = 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)

782782 = let -- ps' = updateps True (namesIn ist rhs) (zip ps [0..])

783783 ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..])

784784 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

786786 -- names bound on the lhs should not be expanded on the rhs

787787 ns' = removeBound lhs ns in

788788 PClause fc n' lhs'

@@ -793,7 +793,7 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

793793 = let -- ps' = updateps True (namesIn ist wval) (zip ps [0..])

794794 ps'' = updateps False (namesIn [] ist lhs) (zip ps [0..])

795795 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

797797 ns' = removeBound lhs ns in

798798 PWith fc n' lhs'

799799 (map (expandParams dec ps'' ns' []) ws)

@@ -812,32 +812,32 @@ expandParamsD rhsonly ist dec ps ns (PClauses fc opts n cs)

812812 bnames (PDPair _ l Placeholder r) = bnames l ++ bnames r

813813 bnames _ = []

814814

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)

816816 = PData doc syn fc co (expandPData pd)

817817 where

818818 -- just do the type decl, leave constructors alone (parameters will be

819819 -- added implicitly)

820− expandPData (PDatadecl n ty cons)

820+ expandPData (PDatadecl n ty cons)

821821 = 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))

823823 (map econ cons)

824824 else PDatadecl n (expandParams dec ps ns [] ty) (map econ cons)

825− econ (doc, n, t, fc)

825+ econ (doc, n, t, fc)

826826 = (doc, dec n, piBindp expl ps (expandParams dec ps ns [] t), fc)

827827expandParamsD 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)

829829 (map (expandParamsD True ist dec ps ns) pds)

830−-- (map (expandParamsD ist dec ps ns) pds)

830+-- (map (expandParamsD ist dec ps ns) pds)

831831expandParamsD rhs ist dec ps ns (PMutual f pds)

832832 = PMutual f (map (expandParamsD rhs ist dec ps ns) pds)

833833expandParamsD rhs ist dec ps ns (PClass doc info f cs n params decls)

834− = PClass doc info f

834+ = PClass doc info f

835835 (map (expandParams dec ps ns []) cs)

836836 n

837837 (map (mapsnd (expandParams dec ps ns [])) params)

838838 (map (expandParamsD rhs ist dec ps ns) decls)

839839expandParamsD rhs ist dec ps ns (PInstance info f cs n params ty cn decls)

840− = PInstance info f

840+ = PInstance info f

841841 (map (expandParams dec ps ns []) cs)

842842 n

843843 (map (expandParams dec ps ns []) params)

@@ -855,7 +855,7 @@ mapsnd f (x, t) = (x, f t)

855855-- * finally, everything else (3)

856856

857857getPriority :: IState -> PTerm -> Int

858−getPriority i tm = 1 -- pri tm

858+getPriority i tm = 1 -- pri tm

859859 where

860860 pri (PRef _ n) =

861861 case lookupP n (tt_ctxt i) of

@@ -869,9 +869,9 @@ getPriority i tm = 1 -- pri tm

869869 pri (PRefl _ _) = 1

870870 pri (PEq _ l r) = max 1 (max (pri l) (pri r))

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

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

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

874+ pri (PCase _ f as) = max 1 (max (pri f) (foldr max 0 (map (pri.snd) as)))

875875 pri (PTyped l r) = pri l

876876 pri (PPair _ l r) = max 1 (max (pri l) (pri r))

877877 pri (PDPair _ l t r) = max 1 (max (pri l) (max (pri t) (pri r)))

@@ -888,7 +888,7 @@ addStatics n tm ptm =

888888 when (not (null statics)) $

889889 logLvl 7 $ show n ++ " " ++ show statics ++ "\n" ++ show dynamics

890890 ++ "\n" ++ show stnames ++ "\n" ++ show dnames

891− let statics' = nub $ map fst statics ++

891+ let statics' = nub $ map fst statics ++

892892 filter (\x -> not (elem x dnames)) stnames

893893 let stpos = staticList statics' tm

894894 i <- getIState

@@ -909,7 +909,7 @@ addStatics n tm ptm =

909909-- Add constraint bindings from using block

910910

911911addUsingConstraints :: SyntaxInfo -> FC -> PTerm -> Idris PTerm

912−addUsingConstraints syn fc t

912+addUsingConstraints syn fc t

913913 = do ist <- get

914914 let ns = namesIn [] ist t

915915 let cs = getConstraints t -- check declared constraints

@@ -924,12 +924,12 @@ addUsingConstraints syn fc t

924924 doAdd [] _ t = t

925925 -- if all of args in ns, then add it

926926 doAdd (UConstraint c args : cs) ns t

927− | all (\n -> elem n ns) args

927+ | all (\n -> elem n ns) args

928928 = PPi (Constraint False Dynamic "") (MN 0 "cu")

929929 (mkConst c args) (doAdd cs ns t)

930930 | otherwise = doAdd cs ns t

931931

932− mkConst c args = PApp fc (PRef fc c)

932+ mkConst c args = PApp fc (PRef fc c)

933933 (map (\n -> PExp 0 False (PRef fc n) "") args)

934934

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

@@ -937,7 +937,7 @@ addUsingConstraints syn fc t

937937 getConstraints (PPi _ _ c sc) = getConstraints sc

938938 getConstraints _ = []

939939

940− getcapp (PApp _ (PRef _ c) args)

940+ getcapp (PApp _ (PRef _ c) args)

941941 = do ns <- mapM getName args

942942 return (UConstraint c ns)

943943 getcapp _ = []

@@ -954,7 +954,7 @@ implicit :: SyntaxInfo -> Name -> PTerm -> Idris PTerm

954954implicit syn n ptm = implicit' syn [] n ptm

955955

956956implicit' :: SyntaxInfo -> [Name] -> Name -> PTerm -> Idris PTerm

957−implicit' syn ignore n ptm

957+implicit' syn ignore n ptm

958958 = do i <- getIState

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

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

@@ -967,12 +967,12 @@ implicit' syn ignore n ptm

967967

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

969969implicitise 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) ([], [])

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

973973 nsOrder = filter (not . inUsing) ns ++ filter inUsing ns in

974− if null ns

975− then (tm, reverse declimps)

974+ if null ns

975+ then (tm, reverse declimps)

976976 else implicitise syn ignore ist (pibind uvars nsOrder tm)

977977 where

978978 uvars = map ipair (filter uimplicit (using syn))

@@ -992,18 +992,18 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

992992 = do (decls, ns) <- get

993993 let isn = concatMap (namesIn uvars ist) (map getTm as)

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

996996 = do let isn = nub (namesIn uvars ist ty) `dropAll` [n]

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

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

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

10021002 = do let isn = nub (namesIn uvars ist ty ++ case sc of

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

10041004 _ -> [])

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

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

10081008 imps True (n:env) sc

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

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

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

10121012 _ -> [])

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

1014− put (PConstraint 10 l ty doc : decls,

1014+ put (PConstraint 10 l ty doc : decls,

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

10161016 imps True (n:env) sc

10171017 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) $

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

10201020 _ -> [])

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

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

10241024 imps True (n:env) sc

10251025 imps top env (PEq _ l r)

@@ -1042,14 +1042,14 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

10421042 put (decls, nub (ns ++ (isn \\ (env ++ map fst (getImps decls)))))

10431043 imps top env (PDPair _ l t r)

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

10461046 namesIn uvars ist r

10471047 put (decls, nub (ns ++ (isn \\ (env ++ map fst (getImps decls)))))

10481048 imps top env (PAlternative a as)

10491049 = do (decls, ns) <- get

10501050 let isn = concatMap (namesIn uvars ist) as

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

10531053 = do imps False env ty

10541054 imps False (n:env) sc

10551055 imps top env (PHidden tm) = imps False env tm

@@ -1058,10 +1058,10 @@ implicitise syn ignore ist tm = -- trace ("INCOMING " ++ showImp True tm) $

10581058 imps top env _ = return ()

10591059

10601060 pibind using [] sc = sc

1061− pibind using (n:ns) sc

1061+ pibind using (n:ns) sc

10621062 = case lookup n using of

10631063 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

10651065 (pibind using ns sc)

10661066

10671067-- Add implicit arguments in function calls

@@ -1083,7 +1083,7 @@ addImpl = addImpl' False [] []

10831083addImpl' :: Bool -> [Name] -> [Name] -> IState -> PTerm -> PTerm

10841084addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

10851085 where

1086− ai env (PRef fc f)

1086+ ai env (PRef fc f)

10871087 | f `elem` infns = PInferRef fc f

10881088 | not (f `elem` map fst env) = handleErr $ aiFn inpat inpat ist fc f []

10891089 ai env (PHidden (PRef fc f))

@@ -1107,16 +1107,16 @@ addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

11071107 PDPair fc l' t' r'

11081108 ai env (PAlternative a as) = let as' = map (ai env) as in

11091109 PAlternative a as'

1110− ai env (PApp fc (PInferRef _ f) as)

1110+ ai env (PApp fc (PInferRef _ f) as)

11111111 = let as' = map (fmap (ai env)) as in

1112− PApp fc (PInferRef fc f) as'

1113− ai env (PApp fc ftm@(PRef _ f) as)

1112+ PApp fc (PInferRef fc f) as'

1113+ ai env (PApp fc ftm@(PRef _ f) as)

11141114 | f `elem` infns = ai env (PApp fc (PInferRef fc f) as)

11151115 | not (f `elem` map fst env)

11161116 = let as' = map (fmap (ai env)) as in

11171117 handleErr $ aiFn inpat False ist fc f as'

11181118 | Just (Just ty) <- lookup f env

1119− = let as' = map (fmap (ai env)) as

1119+ = let as' = map (fmap (ai env)) as

11201120 arity = getPArity ty in

11211121 mkPApp fc arity ftm as'

11221122 ai env (PApp fc f as) = let f' = ai env f

@@ -1158,8 +1158,8 @@ aiFn inpat True ist fc f []

11581158 = case lookupDef f (tt_ctxt ist) of

11591159 [] -> Right $ PPatvar fc f

11601160 alts -> let ialts = lookupCtxtName f (idris_implicits ist) in

1161− -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

1162− if (not (vname f) || tcname f

1161+ -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

1162+ if (not (vname f) || tcname f

11631163 || any (conCaf (tt_ctxt ist)) ialts)

11641164-- any constructor alts || any allImp ialts))

11651165 then aiFn inpat False ist fc f [] -- use it as a constructor

@@ -1187,7 +1187,7 @@ aiFn inpat expat ist fc f as

11871187 else Right $ mkPApp fc (length as) (PRef fc f) as

11881188 alts -> Right $

11891189 PAlternative True $

1190− map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f')

1190+ map (\(f', ns) -> mkPApp fc (length ns) (PRef fc f')

11911191 (insertImpl ns as)) alts

11921192 where

11931193 insertImpl :: [PArg] -> [PArg] -> [PArg]

@@ -1204,16 +1204,16 @@ aiFn inpat expat ist fc f as

12041204 insertImpl (PTacImplicit p l n sc ty d : ps) given =

12051205 case find n given [] of

12061206 Just (tm, given') -> PTacImplicit p l n sc tm "" : insertImpl ps given'

1207− Nothing -> if inpat

1207+ Nothing -> if inpat

12081208 then PTacImplicit p l n sc Placeholder "" : insertImpl ps given

12091209 else PTacImplicit p l n sc sc "" : insertImpl ps given

12101210 insertImpl expected [] = []

12111211 insertImpl _ given = given

12121212

12131213 find n [] acc = Nothing

1214− find n (PImp _ _ _ n' t _ : gs) acc

1214+ find n (PImp _ _ _ n' t _ : gs) acc

12151215 | n == n' = Just (t, reverse acc ++ gs)

1216− find n (PTacImplicit _ _ n' _ t _ : gs) acc

1216+ find n (PTacImplicit _ _ n' _ t _ : gs) acc

12171217 | n == n' = Just (t, reverse acc ++ gs)

12181218 find n (g : gs) acc = find n gs (g : acc)

12191219

@@ -1222,9 +1222,9 @@ aiFn inpat expat ist fc f as

12221222-- it is hard to get right!

12231223

12241224stripLinear :: IState -> PTerm -> PTerm

1225−stripLinear i tm = evalState (sl tm) [] where

1225+stripLinear i tm = evalState (sl tm) [] where

12261226 sl :: PTerm -> State [Name] PTerm

1227− sl (PRef fc f)

1227+ sl (PRef fc f)

12281228 | (_:_) <- lookupTy f (tt_ctxt i)

12291229 = return $ PRef fc f

12301230 | otherwise = do ns <- get

@@ -1232,7 +1232,7 @@ stripLinear i tm = evalState (sl tm) [] where

12321232 then return Placeholder

12331233 else do put (f : ns)

12341234 return (PRef fc f)

1235− sl (PPatvar fc f)

1235+ sl (PPatvar fc f)

12361236 = do ns <- get

12371237 if (f `elem` ns)

12381238 then return Placeholder

@@ -1245,10 +1245,10 @@ stripLinear i tm = evalState (sl tm) [] where

12451245 return $ PImp p m l n t' d

12461246 slA (PExp p l t d) = do t' <- sl t

12471247 return $ PExp p l t' d

1248− slA (PConstraint p l t d)

1248+ slA (PConstraint p l t d)

12491249 = do t' <- sl t

12501250 return $ PConstraint p l t' d

1251− slA (PTacImplicit p l n sc t d)

1251+ slA (PTacImplicit p l n sc t d)

12521252 = do t' <- sl t

12531253 return $ PTacImplicit p l n sc t' d

12541254 sl x = return x

@@ -1261,7 +1261,7 @@ mkPApp fc a f as = let rest = drop a as in

12611261 appRest fc f (a : as) = appRest fc (PApp fc f [a]) as

12621262

12631263-- 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

12651265-- statics)

12661266-- FIXME: It's possible that this really has to happen after elaboration

12671267

@@ -1279,7 +1279,7 @@ findStatics ist tm = trace (showImp Nothing True False tm) $

12791279

12801280 inOne n ns = length (filter id (map (elem n) ns)) == 1

12811281

1282− pos ns ss (PPi p n t sc)

1282+ pos ns ss (PPi p n t sc)

12831283 | elem n ss = do sc' <- pos ns ss sc

12841284 spos <- get

12851285 put (True : spos)

@@ -1296,16 +1296,16 @@ dumpDecls :: [PDecl] -> String

12961296dumpDecls [] = ""

12971297dumpDecls (d:ds) = dumpDecl d ++ "\n" ++ dumpDecls ds

12981298

1299−dumpDecl (PFix _ f ops) = show f ++ " " ++ showSep ", " ops

1299+dumpDecl (PFix _ f ops) = show f ++ " " ++ showSep ", " ops

13001300dumpDecl (PTy _ _ _ _ n t) = "tydecl " ++ show n ++ " : " ++ showImp Nothing True False t

13011301dumpDecl (PClauses _ _ n cs) = "pat " ++ show n ++ "\t" ++ showSep "\n\t" (map (showCImp True) cs)

13021302dumpDecl (PData _ _ _ _ d) = showDImp True d

13031303dumpDecl (PParams _ ns ps) = "params {" ++ show ns ++ "\n" ++ dumpDecls ps ++ "}\n"

13041304dumpDecl (PNamespace n ps) = "namespace {" ++ n ++ "\n" ++ dumpDecls ps ++ "}\n"

13051305dumpDecl (PSyntax _ syn) = "syntax " ++ show syn

1306−dumpDecl (PClass _ _ _ cs n ps ds)

1306+dumpDecl (PClass _ _ _ cs n ps ds)

13071307 = "class " ++ show cs ++ " " ++ show n ++ " " ++ show ps ++ "\n" ++ dumpDecls ds

1308−dumpDecl (PInstance _ _ cs n _ t _ ds)

1308+dumpDecl (PInstance _ _ cs n _ t _ ds)

13091309 = "instance " ++ show cs ++ " " ++ show n ++ " " ++ show t ++ "\n" ++ dumpDecls ds

13101310dumpDecl _ = "..."

13111311-- dumpDecl (PImport i) = "import " ++ i

@@ -1322,7 +1322,7 @@ instance Monad (EitherErr a) where

13221322toEither (LeftErr e) = Left e

13231323toEither (RightOK ho) = Right ho

13241324

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

13261326-- and what they match. Returns the pair that failed if not a match.

13271327

13281328matchClause :: IState -> PTerm -> PTerm -> Either (PTerm, PTerm) [(Name, PTerm)]

@@ -1336,7 +1336,7 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

13361336 fullApp x = x

13371337

13381338 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'

13401340 | PConstant (I _) <- getTm x = match (getTm x) x'

13411341 match x' (PApp _ (PRef _ (NS (UN "fromInteger") ["builtins"])) [_,_,x])

13421342 | PConstant (I _) <- getTm x = match (getTm x) x'

@@ -1354,17 +1354,17 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

13541354 match xr (PPatvar f n) = match xr (PRef f n)

13551355 match (PApp _ x []) (PRef f n) = match x (PRef f n)

13561356 match (PRef _ n) tm@(PRef _ n')

1357− | n == n' && not names &&

1357+ | n == n' && not names &&

13581358 (not (isConName n (tt_ctxt i)) || tm == Placeholder)

13591359 = return [(n, tm)]

13601360 | n == n' = return []

1361− match (PRef _ n) tm

1361+ match (PRef _ n) tm

13621362 | not names && (not (isConName n (tt_ctxt i)) || tm == Placeholder)

13631363 = return [(n, tm)]

13641364 match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l'

13651365 mr <- match' r r'

13661366 return (ml ++ mr)

1367− match (PRewrite _ l r _) (PRewrite _ l' r' _)

1367+ match (PRewrite _ l r _) (PRewrite _ l' r' _)

13681368 = do ml <- match' l l'

13691369 mr <- match' r r'

13701370 return (ml ++ mr)

@@ -1380,8 +1380,8 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

13801380 mt <- match' t t'

13811381 mr <- match' r r'

13821382 return (ml ++ mt ++ mr)

1383− match (PAlternative a as) (PAlternative a' as')

1384− = do ms <- zipWithM match' as as'

1383+ match (PAlternative a as) (PAlternative a' as')

1384+ = do ms <- zipWithM match' as as'

13851385 return (concat ms)

13861386 match a@(PAlternative _ as) b

13871387 = do let ms = zipWith match' as (repeat b)

@@ -1421,9 +1421,9 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

14211421 | otherwise = LeftErr (a, b)

14221422

14231423 checkRpts (RightOK ms) = check ms where

1424− check ((n,t):xs)

1424+ check ((n,t):xs)

14251425 | Just t' <- lookup n xs = if t/=t' && t/=Placeholder && t'/=Placeholder

1426− then Left (t, t')

1426+ then Left (t, t')

14271427 else check xs

14281428 check (_:xs) = check xs

14291429 check [] = Right ms

@@ -1434,7 +1434,7 @@ substMatches ms = substMatchesShadow ms []

14341434

14351435substMatchesShadow :: [(Name, PTerm)] -> [Name] -> PTerm -> PTerm

14361436substMatchesShadow [] shs t = t

1437−substMatchesShadow ((n,tm):ns) shs t

1437+substMatchesShadow ((n,tm):ns) shs t

14381438 = substMatchShadow n shs tm (substMatchesShadow ns shs t)

14391439

14401440substMatch :: Name -> PTerm -> PTerm -> PTerm

@@ -1444,10 +1444,10 @@ substMatchShadow :: Name -> [Name] -> PTerm -> PTerm -> PTerm

14441444substMatchShadow n shs tm t = sm shs t where

14451445 sm xs (PRef _ n') | n == n' = tm

14461446 sm xs (PLam x t sc) = PLam x (sm xs t) (sm xs sc)

1447− sm xs (PPi p x t sc)

1448− | x `elem` xs

1447+ sm xs (PPi p x t sc)

1448+ | x `elem` xs

14491449 = 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))

14511451 (sm (x':xs) (substMatch x (PRef emptyFC x') sc))

14521452 | otherwise = PPi p x (sm xs t) (sm (x : xs) sc)

14531453 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 {

8888 idris_statics :: Ctxt [Bool],

8989 idris_classes :: Ctxt ClassInfo,

9090 idris_dsls :: Ctxt DSL,

91− idris_optimisation :: Ctxt OptInfo,

91+ idris_optimisation :: Ctxt OptInfo,

9292 idris_datatypes :: Ctxt TypeInfo,

9393 idris_patdefs :: Ctxt ([([Name], Term, Term)], [PTerm]), -- not exported

9494 -- ^ list of lhs/rhs, and a list of missing clauses

@@ -100,8 +100,8 @@ data IState = IState {

100100 idris_log :: String,

101101 idris_options :: IOption,

102102 idris_name :: Int,

103− idris_lineapps :: [((FilePath, Int), PTerm)],

104− -- ^ Full application LHS on source line

103+ idris_lineapps :: [((FilePath, Int), PTerm)],

104+ -- ^ Full application LHS on source line

105105 idris_metavars :: [(Name, (Maybe Name, Int))], -- ^ The currently defined but not proven metavariables

106106 idris_coercions :: [Name],

107107 idris_transforms :: [(Term, Term)],

@@ -145,15 +145,15 @@ data CGInfo = CGInfo { argsdef :: [Name],

145145 argsused :: [Name],

146146 unusedpos :: [Int] }

147147 deriving Show

148−{-!

149−deriving instance Binary CGInfo

148+{-!

149+deriving instance Binary CGInfo

150150!-}

151151

152−primDefs = [UN "unsafePerformPrimIO",

153− UN "mkLazyForeignPrim",

154− UN "mkForeignPrim",

152+primDefs = [UN "unsafePerformPrimIO",

153+ UN "mkLazyForeignPrim",

154+ UN "mkForeignPrim",

155155 UN "FalseElim"]

156−

156+

157157-- information that needs writing for the current module's .ibc file

158158data IBCWrite = IBCFix FixDecl

159159 | IBCImp Name

@@ -183,13 +183,13 @@ data IBCWrite = IBCFix FixDecl

183183 deriving Show

184184

185185idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

186− emptyContext emptyContext emptyContext emptyContext

186+ emptyContext emptyContext emptyContext emptyContext

187187 emptyContext emptyContext emptyContext emptyContext

188188 [] "" defaultOpts 6 [] [] [] [] [] [] [] [] [] [] [] []

189189 [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

190190 True defaultTheme stdout

191191

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

193193-- global state (hence the IO inner monad).

194194--type Idris = WriterT [Either String (IO ())] (State IState a))

195195type Idris = StateT IState (ErrorT Err IO)

@@ -212,9 +212,9 @@ data Command = Quit

212212 | DocStr Name

213213 | TotCheck Name

214214 | Reload

215− | Load FilePath

215+ | Load FilePath

216216 | ChangeDirectory FilePath

217− | ModImport String

217+ | ModImport String

218218 | Edit

219219 | Compile Codegen String

220220 | Execute

@@ -240,11 +240,11 @@ data Command = Quit

240240 | DebugInfo Name

241241 | Search PTerm

242242 | CaseSplit Name PTerm

243− | CaseSplitAt Bool Int Name

244− | AddClauseFrom Bool Int Name

245− | AddProofClauseFrom Bool Int Name

246− | AddMissing Bool Int Name

247− | MakeWith Bool Int Name

243+ | CaseSplitAt Bool Int Name

244+ | AddClauseFrom Bool Int Name

245+ | AddProofClauseFrom Bool Int Name

246+ | AddMissing Bool Int Name

247+ | MakeWith Bool Int Name

248248 | DoProofSearch Bool Int Name [Name]

249249 | SetOpt Opt

250250 | UnsetOpt Opt

@@ -298,13 +298,13 @@ data Opt = Filename String

298298

299299-- Parsed declarations

300300

301−data Fixity = Infixl { prec :: Int }

301+data Fixity = Infixl { prec :: Int }

302302 | Infixr { prec :: Int }

303− | InfixN { prec :: Int }

303+ | InfixN { prec :: Int }

304304 | PrefixN { prec :: Int }

305305 deriving Eq

306−{-!

307−deriving instance Binary Fixity

306+{-!

307+deriving instance Binary Fixity

308308!-}

309309

310310instance Show Fixity where

@@ -313,14 +313,14 @@ instance Show Fixity where

313313 show (InfixN i) = "infix " ++ show i

314314 show (PrefixN i) = "prefix " ++ show i

315315

316−data FixDecl = Fix Fixity String

316+data FixDecl = Fix Fixity String

317317 deriving Eq

318318

319319instance Show FixDecl where

320320 show (Fix f s) = show f ++ " " ++ s

321321

322−{-!

323−deriving instance Binary FixDecl

322+{-!

323+deriving instance Binary FixDecl

324324!-}

325325

326326instance Ord FixDecl where

@@ -329,8 +329,8 @@ instance Ord FixDecl where

329329

330330data Static = Static | Dynamic

331331 deriving (Show, Eq)

332−{-!

333−deriving instance Binary Static

332+{-!

333+deriving instance Binary Static

334334!-}

335335

336336-- Mark bindings with their explicitness, and laziness

@@ -352,7 +352,7 @@ data Plicity = Imp { plazy :: Bool,

352352 deriving (Show, Eq)

353353

354354{-!

355−deriving instance Binary Plicity

355+deriving instance Binary Plicity

356356!-}

357357

358358impl = Imp False Dynamic "" False

@@ -363,8 +363,8 @@ tacimpl t = TacImp False Dynamic t ""

363363

364364data FnOpt = Inlinable -- always evaluate when simplifying

365365 | TotalFn | PartialFn

366− | Coinductive | AssertTotal

367− | Dictionary -- type class dictionary, eval only when

366+ | Coinductive | AssertTotal

367+ | Dictionary -- type class dictionary, eval only when

368368 -- a function argument, and further evaluation resutls

369369 | Implicit -- implicit coercion

370370 | CExport String -- export, with a C name

@@ -395,7 +395,7 @@ data PDecl' t

395395 | PParams FC [(Name, t)] [PDecl' t] -- ^ Params block

396396 | PNamespace String [PDecl' t] -- ^ New namespace

397397 | PRecord String SyntaxInfo FC Name t String Name t -- ^ Record declaration

398− | PClass String SyntaxInfo FC

398+ | PClass String SyntaxInfo FC

399399 [t] -- constraints

400400 Name

401401 [(Name, t)] -- parameters

@@ -436,7 +436,7 @@ type ElabD a = Elab' [PDecl] a

436436-- 4. The where block (PDecl' t)

437437

438438data 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]

440440 | PClauseR FC [t] t [PDecl' t]

441441 | PWithR FC [t] t [PDecl' t]

442442 deriving Functor

@@ -462,7 +462,7 @@ deriving instance Binary PData'

462462

463463type PDecl = PDecl' PTerm

464464type PData = PData' PTerm

465−type PClause = PClause' PTerm

465+type PClause = PClause' PTerm

466466

467467-- get all the names declared in a decl

468468

@@ -494,7 +494,7 @@ tldeclared (PClauses _ _ n _) = [] -- not a declaration

494494tldeclared (PRecord _ _ _ n _ _ c _) = [n, c]

495495tldeclared (PData _ _ _ _ (PDatadecl n _ ts)) = n : map fstt ts

496496 where fstt (_, a, _, _) = a

497−tldeclared (PParams _ _ ds) = []

497+tldeclared (PParams _ _ ds) = []

498498tldeclared (PMutual _ ds) = concatMap tldeclared ds

499499tldeclared (PNamespace _ ds) = concatMap tldeclared ds

500500tldeclared (PClass _ _ _ _ n _ ms) = concatMap tldeclared ms

@@ -528,14 +528,14 @@ updateN _ n = n

528528updateNs :: [(Name, Name)] -> PTerm -> PTerm

529529updateNs [] t = t

530530updateNs 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)

532532 updateRef t = t

533533

534534-- updateDNs :: [(Name, Name)] -> PDecl -> PDecl

535535-- updateDNs [] t = t

536536-- updateDNs ns (PTy s f n t) | Just n' <- lookup n ns = PTy s f n' t

537537-- 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)

539539-- = PClause (updateN ns n) (fmap (updateNs ns) l)

540540-- (map (fmap (updateNs ns)) ts)

541541-- (fmap (updateNs ns) r)

@@ -579,12 +579,12 @@ data PTerm = PQuote Raw

579579 | PImpossible -- ^ Special case for declaring when an LHS can't typecheck

580580 | PCoerced PTerm -- ^ To mark a coerced argument, so as not to coerce twice

581581 | 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

583583 deriving Eq

584584

585585

586−{-!

587−deriving instance Binary PTerm

586+{-!

587+deriving instance Binary PTerm

588588!-}

589589

590590mapPT :: (PTerm -> PTerm) -> PTerm -> PTerm

@@ -592,7 +592,7 @@ mapPT f t = f (mpt t) where

592592 mpt (PLam n t s) = PLam n (mapPT f t) (mapPT f s)

593593 mpt (PPi p n t s) = PPi p n (mapPT f t) (mapPT f s)

594594 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)

596596 (fmap (mapPT f) g)

597597 mpt (PApp fc t as) = PApp fc (mapPT f t) (map (fmap (mapPT f)) as)

598598 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

613613

614614

615615data PTactic' t = Intro [Name] | Intros | Focus Name

616− | Refine Name [Bool] | Rewrite t

616+ | Refine Name [Bool] | Rewrite t

617617 | Equiv t

618− | MatchRefine Name

618+ | MatchRefine Name

619619 | LetTac Name t | LetTacTy Name t t

620− | Exact t | Compute | Trivial

620+ | Exact t | Compute | Trivial

621621 | ProofSearch (Maybe Name) Name [Name]

622622 | Solve

623623 | Attack

@@ -630,8 +630,8 @@ data PTactic' t = Intro [Name] | Intros | Focus Name

630630 | GoalType String (PTactic' t)

631631 | Qed | Abandon

632632 deriving (Show, Eq, Functor)

633−{-!

634−deriving instance Binary PTactic'

633+{-!

634+deriving instance Binary PTactic'

635635!-}

636636

637637instance Sized a => Sized (PTactic' a) where

@@ -665,8 +665,8 @@ data PDo' t = DoExp FC t

665665 | DoLet FC Name t t

666666 | DoLetP FC t t

667667 deriving (Eq, Functor)

668−{-!

669−deriving instance Binary PDo'

668+{-!

669+deriving instance Binary PDo'

670670!-}

671671

672672instance Sized a => Sized (PDo' a) where

@@ -682,7 +682,7 @@ type PDo = PDo' PTerm

682682-- things early which will help give a more concrete type to other

683683-- variables, e.g. a before (interpTy a).

684684

685−data PArg' t = PImp { priority :: Int,

685+data PArg' t = PImp { priority :: Int,

686686 machine_inf :: Bool, -- true if the machine inferred it

687687 lazyarg :: Bool, pname :: Name, getTm :: t,

688688 pargdoc :: String }

@@ -693,9 +693,9 @@ data PArg' t = PImp { priority :: Int,

693693 lazyarg :: Bool, getTm :: t,

694694 pargdoc :: String }

695695 | PTacImplicit { priority :: Int,

696− lazyarg :: Bool, pname :: Name,

696+ lazyarg :: Bool, pname :: Name,

697697 getScript :: t,

698− getTm :: t,

698+ getTm :: t,

699699 pargdoc :: String }

700700 deriving (Show, Eq, Functor)

701701

@@ -705,8 +705,8 @@ instance Sized a => Sized (PArg' a) where

705705 size (PConstraint p l trm _) = 1 + size trm

706706 size (PTacImplicit p l nm scr trm _) = 1 + size nm + size scr + size trm

707707

708−{-!

709−deriving instance Binary PArg'

708+{-!

709+deriving instance Binary PArg'

710710!-}

711711

712712pimp n t mach = PImp 1 mach True n t ""

@@ -724,8 +724,8 @@ data ClassInfo = CI { instanceName :: Name,

724724 class_params :: [Name],

725725 class_instances :: [Name] }

726726 deriving Show

727−{-!

728−deriving instance Binary ClassInfo

727+{-!

728+deriving instance Binary ClassInfo

729729!-}

730730

731731data OptInfo = Optimise { collapsible :: Bool,

@@ -733,12 +733,12 @@ data OptInfo = Optimise { collapsible :: Bool,

733733 forceable :: [Int], -- argument positions

734734 recursive :: [Int] }

735735 deriving Show

736−{-!

737−deriving instance Binary OptInfo

736+{-!

737+deriving instance Binary OptInfo

738738!-}

739739

740740

741−data TypeInfo = TI { con_names :: [Name],

741+data TypeInfo = TI { con_names :: [Name],

742742 codata :: Bool,

743743 param_pos :: [Int] }

744744 deriving Show

@@ -746,7 +746,7 @@ data TypeInfo = TI { con_names :: [Name],

746746deriving instance Binary TypeInfo

747747!-}

748748

749−-- Syntactic sugar info

749+-- Syntactic sugar info

750750

751751data DSL' t = DSL { dsl_bind :: t,

752752 dsl_return :: t,

@@ -767,14 +767,14 @@ type DSL = DSL' PTerm

767767

768768data SynContext = PatternSyntax | TermSyntax | AnySyntax

769769 deriving Show

770−{-!

771−deriving instance Binary SynContext

770+{-!

771+deriving instance Binary SynContext

772772!-}

773773

774774data Syntax = Rule [SSymbol] PTerm SynContext

775775 deriving Show

776−{-!

777−deriving instance Binary Syntax

776+{-!

777+deriving instance Binary Syntax

778778!-}

779779

780780data SSymbol = Keyword Name

@@ -783,11 +783,11 @@ data SSymbol = Keyword Name

783783 | Expr Name

784784 | SimpleExpr Name

785785 deriving Show

786−{-!

787−deriving instance Binary SSymbol

786+{-!

787+deriving instance Binary SSymbol

788788!-}

789789

790−initDSL = DSL (PRef f (UN ">>="))

790+initDSL = DSL (PRef f (UN ">>="))

791791 (PRef f (UN "return"))

792792 (PRef f (UN "<$>"))

793793 (PRef f (UN "pure"))

@@ -849,29 +849,29 @@ showDeclImp t (PTy _ _ _ _ n ty) = show n ++ " : " ++ showImp Nothing t False ty

849849showDeclImp t (PPostulate _ _ _ _ n ty) = show n ++ " : " ++ showImp Nothing t False ty

850850showDeclImp _ (PClauses _ _ n c) = showSep "\n" (map show c)

851851showDeclImp _ (PData _ _ _ _ d) = show d

852−showDeclImp _ (PParams f ns ps) = "parameters " ++ show ns ++ "\n" ++

852+showDeclImp _ (PParams f ns ps) = "parameters " ++ show ns ++ "\n" ++

853853 showSep "\n" (map show ps)

854854

855855

856856showCImp :: Bool -> PClause -> String

857−showCImp impl (PClause _ n l ws r w)

857+showCImp impl (PClause _ n l ws r w)

858858 = showImp Nothing impl False l ++ showWs ws ++ " = " ++ showImp Nothing impl False r

859− ++ " where " ++ show w

859+ ++ " where " ++ show w

860860 where

861861 showWs [] = ""

862862 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)

864864 = showImp Nothing impl False l ++ showWs ws ++ " with " ++ showImp Nothing impl False r

865− ++ " { " ++ show w ++ " } "

865+ ++ " { " ++ show w ++ " } "

866866 where

867867 showWs [] = ""

868868 showWs (x : xs) = " | " ++ showImp Nothing impl False x ++ showWs xs

869869

870870

871871showDImp :: Bool -> PData -> String

872−showDImp impl (PDatadecl n ty cons)

872+showDImp impl (PDatadecl n ty cons)

873873 = "data " ++ show n ++ " : " ++ showImp Nothing impl False ty ++ " where\n\t"

874− ++ showSep "\n\t| "

874+ ++ showSep "\n\t| "

875875 (map (\ (_, n, t, _) -> show n ++ " : " ++ showImp Nothing impl False t) cons)

876876

877877getImps :: [PArg] -> [(Name, PTerm)]

@@ -890,7 +890,7 @@ getConsts (PConstraint _ _ tm _ : xs) = tm : getConsts xs

890890getConsts (_ : xs) = getConsts xs

891891

892892getAll :: [PArg] -> [PTerm]

893−getAll = map getTm

893+getAll = map getTm

894894

895895-- | Pretty-print a high-level Idris term

896896prettyImp :: Bool -- ^^ whether to show implicits

@@ -1135,7 +1135,7 @@ showImp ist impl colour tm = se 10 [] tm where

11351135 | Just num <- snat p e = perhapsColourise colouriseData (show num)

11361136 se p bnd (PRef fc n) = showName ist bnd impl colour n

11371137 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 "") ++ " => "

11391139 ++ se 10 ((n, False):bnd) sc

11401140 se p bnd (PLet n ty v sc) = bracket p 2 $ "let " ++ perhapsColourise colouriseBound (show n) ++

11411141 " = " ++ se 10 bnd v ++

@@ -1145,7 +1145,7 @@ showImp ist impl colour tm = se 10 [] tm where

11451145 = bracket p 2 $

11461146 (if l then "|(" else "(") ++

11471147 perhapsColourise colouriseBound (show n) ++ " : " ++ se 10 bnd ty ++

1148− ") " ++

1148+ ") " ++

11491149 (if (impl && param) then "P" else "") ++

11501150 st ++

11511151 "-> " ++ se 10 ((n, False):bnd) sc

@@ -1155,7 +1155,7 @@ showImp ist impl colour tm = se 10 [] tm where

11551155 _ -> ""

11561156 se p bnd (PPi (Imp l s _ _) n ty sc)

11571157 | 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 ++

11591159 "} " ++ st ++ "-> " ++ se 10 ((n, True):bnd) sc

11601160 | otherwise = se 10 ((n, True):bnd) sc

11611161 where st = case s of

@@ -1173,12 +1173,12 @@ showImp ist impl colour tm = se 10 [] tm where

11731173 se p bnd (PAppBind _ hd@(PRef _ f) [])

11741174 | not impl = "!" ++ se p bnd hd

11751175 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)

11771177 = let [l, r] = getExps args in

11781178 bracket p 1 $ se 1 bnd l ++ " " ++ se p bnd op ++ " " ++ se 0 bnd r

11791179 se p bnd (PApp _ f as)

11801180 = -- let args = getExps as in

1181− bracket p 1 $ se 1 bnd f ++

1181+ bracket p 1 $ se 1 bnd f ++

11821182 if impl then concatMap (sArg bnd) as

11831183 else concatMap (suiArg impl bnd) as

11841184 se p bnd (PAppBind _ f as)

@@ -1257,16 +1257,16 @@ showImp ist impl colour tm = se 10 [] tm where

12571257 sArg bnd (PTacImplicit _ _ n _ tm _) = stiArg bnd (n, tm)

12581258

12591259 -- 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 _)

12611261 | impl || not mi = siArg bnd (n, tm)

12621262 suiArg impl bnd (PExp _ _ tm _) = seArg bnd tm

12631263 suiArg impl bnd _ = ""

12641264

12651265 seArg bnd arg = " " ++ se 0 bnd arg

1266− siArg bnd (n, val) =

1266+ siArg bnd (n, val) =

12671267 let n' = show n

12681268 val' = se 10 bnd val in

1269− if (n' == val')

1269+ if (n' == val')

12701270 then " {" ++ n' ++ "}"

12711271 else " {" ++ n' ++ " = " ++ val' ++ "}"

12721272 scArg bnd val = " {{" ++ se 10 bnd val ++ "}}"

@@ -1316,9 +1316,9 @@ getPArity _ = 0

13161316-- Return all names, free or globally bound, in the given term.

13171317

13181318allNamesIn :: PTerm -> [Name]

1319−allNamesIn tm = nub $ ni [] tm

1319+allNamesIn tm = nub $ ni [] tm

13201320 where

1321− ni env (PRef _ n)

1321+ ni env (PRef _ n)

13221322 | not (n `elem` env) = [n]

13231323 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

13241324 ni env (PAppBind _ f as) = ni env f ++ concatMap (ni env) (map getTm as)

@@ -1340,10 +1340,10 @@ allNamesIn tm = nub $ ni [] tm

13401340-- Return names which are free in the given term.

13411341

13421342namesIn :: [(Name, PTerm)] -> IState -> PTerm -> [Name]

1343−namesIn uvars ist tm = nub $ ni [] tm

1343+namesIn uvars ist tm = nub $ ni [] tm

13441344 where

1345− ni env (PRef _ n)

1346− | not (n `elem` env)

1345+ ni env (PRef _ n)

1346+ | not (n `elem` env)

13471347 = case lookupTy n (tt_ctxt ist) of

13481348 [] -> [n]

13491349 _ -> if n `elem` (map fst uvars) then [n] else []

@@ -1367,10 +1367,10 @@ namesIn uvars ist tm = nub $ ni [] tm

13671367-- Return which of the given names are used in the given term.

13681368

13691369usedNamesIn :: [Name] -> IState -> PTerm -> [Name]

1370−usedNamesIn vars ist tm = nub $ ni [] tm

1370+usedNamesIn vars ist tm = nub $ ni [] tm

13711371 where

1372− ni env (PRef _ n)

1373− | n `elem` vars && not (n `elem` env)

1372+ ni env (PRef _ n)

1373+ | n `elem` vars && not (n `elem` env)

13741374 = case lookupTy n (tt_ctxt ist) of

13751375 [] -> [n]

13761376 _ -> []

src/Idris/CaseSplit.hs+2−2

@@ -276,10 +276,10 @@ getProofClause :: Int -> -- ^ Line type is declared on

276276 Name -> -- ^ Function name

277277 FilePath -> -- ^ Source file name

278278 Idris String

279−getProofClause l fn fp

279+getProofClause l fn fp

280280 = do ty <- getInternalApp fp l

281281 return (mkApp ty ++ " = ?" ++ show fn ++ "_rhs")

282− where mkApp (PPi _ _ _ sc) = mkApp sc

282+ where mkApp (PPi _ _ _ sc) = mkApp sc

283283 mkApp rt = "(" ++ show rt ++ ") <== " ++ show fn

284284

285285-- 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

5151

5252 ibc (IBC _ _) = True

5353 ibc _ = False

54−

54+

5555 chkReload False p = p

5656 chkReload True (IBC fn src) = chkReload True src

5757 chkReload True p = p

@@ -74,19 +74,19 @@ buildTree built fp = idrisCatch (btree [] fp)

7474 (\e -> do now <- runIO $ getCurrentTime

7575 return [MTree (IDR fp) True now []])

7676 where

77− btree done f =

77+ btree done f =

7878 do i <- getIState

7979 let file = takeWhile (/= ' ') f

8080 iLOG $ "CHASING " ++ show file

8181 ibcsd <- valIBCSubDir i

82− ids <- allImportDirs

82+ ids <- allImportDirs

8383 fp <- runIO $ findImport ids ibcsd file

8484 mt <- runIO $ getIModTime fp

85− if (file `elem` built)

85+ if (file `elem` built)

8686 then return [MTree fp False mt []]

87− else if file `elem` done

87+ else if file `elem` done

8888 then return []

89− else mkChildren fp

89+ else mkChildren fp

9090

9191 where mkChildren (LIDR fn) = do ms <- children True fn (f:done)

9292 mt <- runIO $ getModificationTime fn

@@ -94,7 +94,7 @@ buildTree built fp = idrisCatch (btree [] fp)

9494 mkChildren (IDR fn) = do ms <- children False fn (f:done)

9595 mt <- runIO $ getModificationTime fn

9696 return [MTree (IDR fn) True mt ms]

97− mkChildren (IBC fn src)

97+ mkChildren (IBC fn src)

9898 = do srcexist <- runIO $ doesFileExist (getSrcFile src)

9999 ms <- if srcexist then

100100 do [MTree _ _ _ ms'] <- mkChildren src

@@ -119,7 +119,7 @@ buildTree built fp = idrisCatch (btree [] fp)

119119 if exist then do

120120 ibct <- runIO $ getModificationTime ibc

121121 srct <- runIO $ getModificationTime src

122− return (srct > ibct)

122+ return (srct > ibct)

123123 else return False

124124

125125 children :: Bool -> FilePath -> [FilePath] -> Idris [ModuleTree]

@@ -129,7 +129,7 @@ buildTree built fp = idrisCatch (btree [] fp)

129129 file_in <- runIO $ readFile f

130130 file <- if lit then tclift $ unlit f file_in else return file_in

131131 (_, modules, _) <- parseImports f file

132− ms <- mapM (btree done) modules

132+ ms <- mapM (btree done) modules

133133 return (concat ms)

134134 else return []) -- IBC with no source available

135135 (\c -> return []) -- error, can't chase modules here

src/Idris/Coverage.hs+90−90

@@ -31,7 +31,7 @@ mkPatTm t = do i <- getIState

3131 return $ mkApp t' args'

3232 toTT _ = do v <- get

3333 put (v + 1)

34− return (P Bound (MN v "imp") Erased)

34+ return (P Bound (MN v "imp") Erased)

3535

3636-- Given a list of LHSs, generate a extra clauses which cover the remaining

3737-- cases. The ones which haven't been provided are marked 'absurd' so that the

@@ -49,7 +49,7 @@ genClauses fc n xs given

4949 logLvl 5 $ "COVERAGE of " ++ show n

5050 logLvl 5 $ show (map length argss) ++ "\n" ++ show (map length all_args)

5151 logLvl 10 $ show argss ++ "\n" ++ show all_args

52− logLvl 10 $ "Original: \n" ++

52+ logLvl 10 $ "Original: \n" ++

5353 showSep "\n" (map (\t -> showImp Nothing True False (delab' i t True)) xs)

5454 -- add an infinite supply of explicit arguments to update the possible

5555 -- cases for (the return type may be variadic, or function type, sp

@@ -61,13 +61,13 @@ genClauses fc n xs given

6161 let tryclauses = mkClauses parg all_args

6262 logLvl 2 $ show (length tryclauses) ++ " initially to check"

6363 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)

6565 logLvl 1 $ show (length new) ++ " clauses to check for impossibility"

6666 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)

6868 return new

6969-- return (map (\t -> PClause n t [] PImpossible []) new)

70− where getLHS i term

70+ where getLHS i term

7171 | (f, args) <- unApply term = map (\t -> delab' i t True) args

7272 | otherwise = []

7373

@@ -76,7 +76,7 @@ genClauses fc n xs given

7676

7777 noMatch i tm = all (\x -> case matchClause i (delab' i x True) tm of

7878 Right _ -> False

79− Left miss -> True) xs

79+ Left miss -> True) xs

8080

8181

8282 mkClauses :: [PArg] -> [[PTerm]] -> [PTerm]

@@ -102,7 +102,7 @@ fnub' acc [] = acc

102102-- quick check for constructor equality

103103quickEq :: PTerm -> PTerm -> Bool

104104quickEq (PRef _ n) (PRef _ n') = n == n'

105−quickEq (PApp _ t as) (PApp _ t' as')

105+quickEq (PApp _ t as) (PApp _ t' as')

106106 | length as == length as'

107107 = quickEq t t' && and (zipWith quickEq (map getTm as) (map getTm as'))

108108quickEq Placeholder Placeholder = True

@@ -112,15 +112,15 @@ qelem x [] = False

112112qelem x (y : ys) | x `quickEq` y = True

113113 | otherwise = qelem x ys

114114

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

116116-- possibilities up to that depth.

117117

118118genAll :: IState -> [PTerm] -> [PTerm]

119−genAll i args

119+genAll i args

120120 = case filter (/=Placeholder) $ fnub (concatMap otherPats (fnub args)) of

121121 [] -> [Placeholder]

122122 xs -> inventConsts xs

123− where

123+ where

124124 -- if they're constants, invent a new one to make sure that

125125 -- constants which are not explicitly handled are covered

126126 inventConsts cs@(PConstant c : _) = map PConstant (ic' (mapMaybe getConst cs))

@@ -128,21 +128,21 @@ genAll i args

128128 getConst _ = Nothing

129129 inventConsts xs = xs

130130

131− -- try constants until they're not in the list.

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

134− -- will be really slow. This is sufficiently unlikely that we won't

135− -- worry for now...

131+ -- try constants until they're not in the list.

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

134+ -- will be really slow. This is sufficiently unlikely that we won't

135+ -- worry for now...

136136

137− ic' xs@(I _ : _) = firstMissing xs (lotsOfNums I)

137+ ic' xs@(I _ : _) = firstMissing xs (lotsOfNums I)

138138 ic' xs@(BI _ : _) = firstMissing xs (lotsOfNums BI)

139− ic' xs@(Fl _ : _) = firstMissing xs (lotsOfNums Fl)

140− ic' xs@(B8 _ : _) = firstMissing xs (lotsOfNums B8)

141− ic' xs@(B16 _ : _) = firstMissing xs (lotsOfNums B16)

142− ic' xs@(B32 _ : _) = firstMissing xs (lotsOfNums B32)

143− ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64)

139+ ic' xs@(Fl _ : _) = firstMissing xs (lotsOfNums Fl)

140+ ic' xs@(B8 _ : _) = firstMissing xs (lotsOfNums B8)

141+ ic' xs@(B16 _ : _) = firstMissing xs (lotsOfNums B16)

142+ ic' xs@(B32 _ : _) = firstMissing xs (lotsOfNums B32)

143+ ic' xs@(B64 _ : _) = firstMissing xs (lotsOfNums B64)

144144 ic' xs@(Ch _ : _) = firstMissing xs lotsOfChars

145− ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings

145+ ic' xs@(Str _ : _) = firstMissing xs lotsOfStrings

146146 -- TODO: Bit vectors

147147 -- The rest are types with only one case

148148 ic' xs = xs

@@ -166,16 +166,16 @@ genAll i args

166166 otherPats o@(PApp _ (PRef fc n) xs) = ops fc n xs o

167167 otherPats o@(PPair fc l r)

168168 = ops fc pairCon

169− ([pimp (UN "A") Placeholder True,

169+ ([pimp (UN "A") Placeholder True,

170170 pimp (UN "B") Placeholder True] ++

171171 [pexp l, pexp r]) o

172− otherPats o@(PDPair fc t _ v)

173− = ops fc (UN "Ex_intro")

174− ([pimp (UN "a") Placeholder True,

172+ otherPats o@(PDPair fc t _ v)

173+ = ops fc (UN "Ex_intro")

174+ ([pimp (UN "a") Placeholder True,

175175 pimp (UN "P") Placeholder True] ++

176176 [pexp t,pexp v]) o

177177 otherPats o@(PConstant c) = return o

178− otherPats arg = return Placeholder

178+ otherPats arg = return Placeholder

179179

180180 ops fc n xs o

181181 | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i)

@@ -202,7 +202,7 @@ genAll i args

202202 [o] -> forceable o

203203 _ -> []

204204

205− dropForce force (x : xs) i | i `elem` force

205+ dropForce force (x : xs) i | i `elem` force

206206 = upd Placeholder x : dropForce force xs (i + 1)

207207 dropForce force (x : xs) i = x : dropForce force xs (i + 1)

208208 dropForce _ [] _ = []

@@ -216,7 +216,7 @@ genAll i args

216216

217217 mkPat fc x = case lookupCtxt x (idris_implicits i) of

218218 (pargs : _)

219− -> PApp fc (PRef fc x) (map (upd Placeholder) pargs)

219+ -> PApp fc (PRef fc x) (map (upd Placeholder) pargs)

220220 _ -> error "Can't happen - genAll"

221221

222222upd p' p = p { getTm = p' }

@@ -225,7 +225,7 @@ upd p' p = p { getTm = p' }

225225-- and update the context accordingly

226226

227227checkPositive :: Name -> (Name, Type) -> Idris ()

228−checkPositive n (cn, ty)

228+checkPositive n (cn, ty)

229229 = do let p = cp ty

230230 i <- getIState

231231 let tot = if p then Total (args ty) else Partial NotPositive

@@ -245,20 +245,20 @@ checkPositive n (cn, ty)

245245 posArg t = True

246246

247247calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality

248−calcProd i fc topn pats

248+calcProd i fc topn pats

249249 = cp topn pats []

250250 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

252252 -- constructor, in every function reachable from here in the

253253 -- call graph.

254254 cp n pats done = do patsprod <- mapM (prodRec n done) pats

255− if (and patsprod)

255+ if (and patsprod)

256256 then return Productive

257257 else return (Partial NotProductive)

258258

259259 prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

260260 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

262262

263263 prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

264264 prod n done ok ap@(App _ _)

@@ -269,26 +269,26 @@ calcProd i fc topn pats

269269 let [ty] = lookupTy f ctxt -- must exist!

270270 let co = cotype nt f ty in

271271 if (not recOK) then return False else

272− if f == topn

272+ if f == topn

273273 then do argsprod <- mapM (prod n done co) args

274274 return (and (ok : argsprod) )

275275 else do argsprod <- mapM (prod n done co) args

276276 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)

278278 (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)

280280 = liftM2 (&&) (prod n done False v) (prod n done False v)

281281 prod n done ok (Bind _ b sc) = prod n done ok sc

282− prod n done ok t = return True

283−

282+ prod n done ok t = return True

283+

284284 checkProdRec :: [Name] -> Name -> Idris Bool

285− checkProdRec done f

285+ checkProdRec done f

286286 = case lookupCtxt f (idris_patdefs i) of

287287 [(def, _)] -> do ok <- mapM (prodRec f done) def

288288 return (and ok)

289289 _ -> return True -- defined elsewhere, can't call topn

290290

291− cotype (DCon _ _) n ty

291+ cotype (DCon _ _) n ty

292292 | (P _ t _, _) <- unApply (getRetTy ty)

293293 = case lookupCtxt t (idris_datatypes i) of

294294 [TI _ True _] -> True

@@ -297,26 +297,26 @@ calcProd i fc topn pats

297297

298298calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]

299299 -> Idris Totality

300−calcTotality path fc n pats

300+calcTotality path fc n pats

301301 = do i <- getIState

302302 let opts = case lookupCtxt n (idris_flags i) of

303303 [fs] -> fs

304304 _ -> []

305305 case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of

306306 (failure : _) -> return failure

307− _ -> if (Coinductive `elem` opts)

307+ _ -> if (Coinductive `elem` opts)

308308 then calcProd i fc n pats

309309 else checkSizeChange n

310310 where

311− checkLHS i (P _ fn _)

311+ checkLHS i (P _ fn _)

312312 = case lookupTotal fn (tt_ctxt i) of

313− [Partial _] -> return (Partial (Other [fn]))

313+ [Partial _] -> return (Partial (Other [fn]))

314314 _ -> Nothing

315315 checkLHS i (App f a) = mplus (checkLHS i f) (checkLHS i a)

316316 checkLHS _ _ = Nothing

317317

318318checkTotality :: [Name] -> FC -> Name -> Idris Totality

319−checkTotality path fc n

319+checkTotality path fc n

320320 | n `elem` path = return (Partial (Mutual (n : path)))

321321 | otherwise = do

322322 t <- getTotality n

@@ -326,10 +326,10 @@ checkTotality path fc n

326326 let opts = case lookupCtxt n (idris_flags i) of

327327 [fs] -> fs

328328 _ -> []

329− t' <- case t of

330− Unchecked ->

329+ t' <- case t of

330+ Unchecked ->

331331 case lookupDef n ctxt of

332− [CaseOp _ _ _ pats _] ->

332+ [CaseOp _ _ _ pats _] ->

333333 do t' <- if AssertTotal `elem` opts

334334 then return $ Total []

335335 else calcTotality path fc n pats

@@ -338,10 +338,10 @@ checkTotality path fc n

338338 -- if it's not total, it can't reduce, to keep

339339 -- typechecking decidable

340340 case t' of

341− p@(Partial _) ->

342− do setAccessibility n Frozen

341+ p@(Partial _) ->

342+ do setAccessibility n Frozen

343343 addIBC (IBCAccess n Frozen)

344− logLvl 5 $ "HIDDEN: "

344+ logLvl 5 $ "HIDDEN: "

345345 ++ show n ++ show p

346346 _ -> return ()

347347 return t'

@@ -353,7 +353,7 @@ checkTotality path fc n

353353 e -> do w <- cmdOptType WarnPartial

354354 if TotalFn `elem` opts

355355 then totalityError t'

356− else do when (w && not (PartialFn `elem` opts)) $

356+ else do when (w && not (PartialFn `elem` opts)) $

357357 warnPartial n t'

358358 return t'

359359 where

@@ -363,14 +363,14 @@ checkTotality path fc n

363363 = do i <- getIState

364364 case lookupDef n (tt_ctxt i) of

365365 [x] -> do

366− iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t

366+ iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t

367367-- ++ "\n" ++ show x

368368-- let cg = lookupCtxtName Nothing n (idris_callgraph i)

369369-- iputStrLn (show cg)

370370

371371

372372checkDeclTotality :: (FC, Name) -> Idris Totality

373−checkDeclTotality (fc, n)

373+checkDeclTotality (fc, n)

374374 = do logLvl 2 $ "Checking " ++ show n ++ " for totality"

375375-- buildSCG (fc, n)

376376-- logLvl 2 $ "Built SCG"

@@ -383,7 +383,7 @@ checkDeclTotality (fc, n)

383383

384384-- where g is a function called

385385-- 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

387387-- to f

388388-- Nothing, if the argument is unrelated to the input

389389

@@ -392,9 +392,9 @@ buildSCG (_, n) = do

392392 ist <- getIState

393393 case lookupCtxt n (idris_callgraph ist) of

394394 [cg] -> case lookupDef n (tt_ctxt ist) of

395− [CaseOp _ _ pats _ cd] ->

395+ [CaseOp _ _ pats _ cd] ->

396396 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"

398398 ++ show pats ++ "\n" ++ show sc

399399 let newscg = buildSCG' ist (rights pats) args

400400 logLvl 5 $ show newscg

@@ -411,15 +411,15 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

411411 | (P _ (UN "lazy") _, [_, arg]) <- unApply ap

412412 = findCalls arg pvs pargs

413413 | (P _ n _, args) <- unApply ap

414− = mkChange n args pargs ++

414+ = mkChange n args pargs ++

415415 concatMap (\x -> findCalls x pvs pargs) args

416− findCalls (App f a) pvs pargs

416+ findCalls (App f a) pvs pargs

417417 = findCalls f pvs pargs ++ findCalls a pvs pargs

418418 findCalls (Bind n (Let t v) e) pvs pargs

419419 = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs

420420 findCalls (Bind n _ e) pvs pargs

421421 = findCalls e (n : pvs) pargs

422− findCalls (P _ f _ ) pvs pargs

422+ findCalls (P _ f _ ) pvs pargs

423423 | not (f `elem` pvs) = [(f, [])]

424424 findCalls _ _ _ = []

425425

@@ -439,16 +439,16 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

439439 -- not be coinductive - so carry the type of the constructor we've

440440 -- gone under.

441441

442− smaller (Just tyn) a (t, Just tyt)

443− | a == t = isInductive (fst (unApply (getRetTy tyn)))

442+ smaller (Just tyn) a (t, Just tyt)

443+ | a == t = isInductive (fst (unApply (getRetTy tyn)))

444444 (fst (unApply (getRetTy tyt)))

445445 smaller ty a (ap@(App f s), _)

446− | (P (DCon _ _) n _, args) <- unApply ap

446+ | (P (DCon _ _) n _, args) <- unApply ap

447447 = let tyn = getType n in

448− any (smaller (ty `mplus` Just tyn) a)

448+ any (smaller (ty `mplus` Just tyn) a)

449449 (zip args (map toJust (getArgTys tyn)))

450450 -- 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

452452 smaller _ _ _ = False

453453

454454 toJust (n, t) = Just t

@@ -472,19 +472,19 @@ buildSCG' ist pats args = nub $ concatMap scgPat pats where

472472 patvars _ = []

473473

474474{-

475−buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]

475+buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]

476476buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

477− nub $ scg sc (zip args args)

477+ nub $ scg sc (zip args args)

478478 (zip args (zip args (repeat Same)))

479479 where

480480 scg :: SC -> [(Name, Name)] -> -- local var, originating top level var

481481 [(Name, (Name, SizeChange))] -> -- orig to new, and relationship

482482 [SCGEntry]

483− scg (Case x alts) vars szs

483+ scg (Case x alts) vars szs

484484 = let x' = findTL x vars in

485485 concatMap (scgAlt x' vars szs) alts

486486 where

487− findTL x vars

487+ findTL x vars

488488 | Just x' <- lookup x vars

489489 = if x' `elem` args then x'

490490 else findTL x' vars

@@ -514,7 +514,7 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

514514 -- not coinductive)

515515 | Just tvar <- lookup x vars

516516 = let arel = argRels n

517− szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel

517+ szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel

518518 ++ szs

519519 vars' = nub (zip args (repeat tvar) ++ vars) in

520520 scg sc vars' szs'

@@ -529,7 +529,7 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

529529 = let rest = concatMap (\x -> scgTerm x vars szs) args in

530530 case lookup fn vars of

531531 Just _ -> rest

532− Nothing -> nub $ (fn, map (mkChange szs) args) : rest

532+ Nothing -> nub $ (fn, map (mkChange szs) args) : rest

533533 scgTerm (App f a) vars szs

534534 = scgTerm f vars szs ++ scgTerm a vars szs

535535 scgTerm (Bind n (Let t v) e) vars szs

@@ -542,7 +542,7 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

542542 Nothing -> [(fn, [])]

543543 scgTerm _ _ _ = []

544544

545− mkChange :: [(Name, (Name, SizeChange))] -> Term

545+ mkChange :: [(Name, (Name, SizeChange))] -> Term

546546 -> Maybe (Int, SizeChange)

547547 mkChange szs tm

548548 | (P _ (UN "lazy") _, [_, arg]) <- unApply tm = mkChange szs arg

@@ -567,12 +567,12 @@ checkSizeChange n = do

567567 [cg] -> do let ms = mkMultiPaths ist [] (scg cg)

568568 logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++

569569 "from " ++ show (scg cg) ++ "\n" ++

570− show (length ms) ++ "\n" ++

570+ show (length ms) ++ "\n" ++

571571 showSep "\n" (map show ms))

572572 logLvl 6 (show cg)

573− -- every multipath must have an infinitely descending

573+ -- every multipath must have an infinitely descending

574574 -- 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

576576 -- (Unchecked is okay as we'll spot problems here)

577577 let tot = map (checkMP ist (length (argsdef cg))) ms

578578 logLvl 4 $ "Generated " ++ show (length tot) ++ " paths"

@@ -587,11 +587,11 @@ mkMultiPaths :: IState -> MultiPath -> [SCGEntry] -> [MultiPath]

587587mkMultiPaths ist path [] = [reverse path]

588588mkMultiPaths ist path cg

589589 = concat (map extend cg)

590− where extend (nextf, args)

590+ where extend (nextf, args)

591591 | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ]

592− | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)

592+ | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)

593593 = 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)

595595 _ -> [ reverse ((nextf, args) : path) ]

596596 | otherwise = [ reverse ((nextf, args) : path) ]

597597

@@ -599,7 +599,7 @@ mkMultiPaths ist path cg

599599-- if ((nextf, args) `elem` path)

600600-- then return (reverse ((nextf, args) : path))

601601-- 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)

603603-- _ -> return (reverse ((nextf, args) : path))

604604

605605-- If any route along the multipath leads to infinite descent, we're fine.

@@ -608,11 +608,11 @@ mkMultiPaths ist path cg

608608-- that means there is an infinitely descending path from that argument.

609609

610610checkMP :: IState -> Int -> MultiPath -> Totality

611−checkMP ist i mp = if i > 0

611+checkMP ist i mp = if i > 0

612612 then collapse (map (tryPath 0 [] mp) [0..i-1])

613613 else tryPath 0 [] mp 0

614614 where

615− tryPath' d path mp arg

615+ tryPath' d path mp arg

616616 = let res = tryPath d path mp arg in

617617 trace (show mp ++ "\n" ++ show arg ++ " " ++ show res) res

618618

@@ -633,14 +633,14 @@ checkMP ist i mp = if i > 0

633633 | e `elem` es && allNothing args = Partial (Mutual [f])

634634 tryPath desc path (e@(f, nextargs) : es) arg

635635 | Just d <- lookup e path

636− = if desc > 0

636+ = if desc > 0

637637 then -- trace ("Descent " ++ show (desc - d) ++ " "

638638 -- ++ show (path, e)) $

639639 Total []

640640 else Partial (Mutual (map (fst . fst) path ++ [f]))

641641 | [Unchecked] <- lookupTotal f (tt_ctxt ist) =

642642 let argspos = collapseNothing (zip nextargs [0..]) in

643− collapse' Unchecked $

643+ collapse' Unchecked $

644644 do (a, pos) <- argspos

645645 case a of

646646 Nothing -> -- don't know, but if the

@@ -656,11 +656,11 @@ checkMP ist i mp = if i > 0

656656 case sc of

657657 Same -> return $ tryPath desc ((e, desc) : path)

658658 es pos

659− Smaller -> return $ tryPath (desc+1)

660− ((e, desc):path)

659+ Smaller -> return $ tryPath (desc+1)

660+ ((e, desc):path)

661661 es

662662 pos

663− _ -> trace ("Shouldn't happen " ++ show e) $

663+ _ -> trace ("Shouldn't happen " ++ show e) $

664664 return (Partial Itself)

665665 else return Unchecked

666666 | [Total a] <- lookupTotal f (tt_ctxt ist) = Total a

@@ -669,7 +669,7 @@ checkMP ist i mp = if i > 0

669669

670670allNothing xs = null (collapseNothing (zip xs [0..]))

671671

672−collapseNothing ((Nothing, _) : xs)

672+collapseNothing ((Nothing, _) : xs)

673673 = filter (\ (x, _) -> case x of

674674 Nothing -> False

675675 _ -> True) xs

@@ -678,11 +678,11 @@ collapseNothing [] = []

678678

679679noPartial (Partial p : xs) = Partial p

680680noPartial (_ : xs) = noPartial xs

681−noPartial [] = Total []

681+noPartial [] = Total []

682682

683683collapse xs = collapse' Unchecked xs

684684collapse' def (Total r : xs) = Total r

685−collapse' def (Unchecked : xs) = collapse' def xs

685+collapse' def (Unchecked : xs) = collapse' def xs

686686collapse' def (d : xs) = collapse' d xs

687687-- collapse' Unchecked [] = Total []

688688collapse' def [] = def

src/Idris/DSL.hs+13−13

@@ -13,7 +13,7 @@ import Control.Monad.State

1313import Debug.Trace

1414

1515debindApp :: 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

1717

1818desugar :: SyntaxInfo -> IState -> PTerm -> PTerm

1919desugar 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

2121

2222expandDo :: DSL -> PTerm -> PTerm

2323expandDo dsl (PLam n ty tm)

24− | Just lam <- dsl_lambda dsl

24+ | Just lam <- dsl_lambda dsl

2525 = let sc = PApp (fileFC "(dsl)") lam [pexp (var dsl n tm 0)] in

2626 expandDo dsl sc

2727expandDo 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

3333expandDo dsl (PPi p n ty tm) = PPi p n (expandDo dsl ty) (expandDo dsl tm)

3434expandDo dsl (PApp fc t args) = PApp fc (expandDo dsl t)

3535 (map (fmap (expandDo dsl)) args)

36−expandDo dsl (PAppBind fc t args) = PAppBind fc (expandDo dsl t)

37− (map (fmap (expandDo dsl)) args)

36+expandDo dsl (PAppBind fc t args) = PAppBind fc (expandDo dsl t)

37+ (map (fmap (expandDo dsl)) args)

3838expandDo dsl (PCase fc s opts) = PCase fc (expandDo dsl s)

3939 (map (pmap (expandDo dsl)) opts)

4040expandDo dsl (PEq fc l r) = PEq fc (expandDo dsl l) (expandDo dsl r)

4141expandDo 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)

4343 (expandDo dsl r)

4444expandDo dsl (PAlternative a as) = PAlternative a (map (expandDo dsl) as)

4545expandDo dsl (PHidden t) = PHidden (expandDo dsl t)

@@ -50,15 +50,15 @@ expandDo dsl (PRewrite fc r t ty)

5050 = PRewrite fc r (expandDo dsl t) ty

5151expandDo dsl (PGoal fc r n sc)

5252 = PGoal fc (expandDo dsl r) n (expandDo dsl sc)

53−expandDo dsl (PDoBlock ds)

53+expandDo dsl (PDoBlock ds)

5454 = expandDo dsl $ debind (dsl_bind dsl) (block (dsl_bind dsl) ds)

5555 where

56− block b [DoExp fc tm] = tm

56+ block b [DoExp fc tm] = tm

5757 block b [a] = PElabError (Msg "Last statement in do block must be an expression")

5858 block b (DoBind fc n tm : rest)

5959 = PApp fc b [pexp tm, pexp (PLam n Placeholder (block b rest))]

6060 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

6262 (PCase fc (PRef fc (MN 0 "bpat"))

6363 [(p, block b rest)]))]

6464 block b (DoLet fc n ty tm : rest)

@@ -66,8 +66,8 @@ expandDo dsl (PDoBlock ds)

6666 block b (DoLetP fc p tm : rest)

6767 = PCase fc tm [(p, block b rest)]

6868 block b (DoExp fc tm : rest)

69− = PApp fc b

70− [pexp tm,

69+ = PApp fc b

70+ [pexp tm,

7171 pexp (PLam (MN 0 "bindx") Placeholder (block b rest))]

7272 block b _ = PElabError (Msg "Invalid statement in do block")

7373

@@ -76,7 +76,7 @@ expandDo dsl t = t

7676

7777var :: DSL -> Name -> PTerm -> Int -> PTerm

7878var dsl n t i = v' i t where

79− v' i (PRef fc x) | x == n =

79+ v' i (PRef fc x) | x == n =

8080 case dsl_var dsl of

8181 Nothing -> PElabError (Msg "No 'variable' defined in dsl")

8282 Just v -> PApp fc v [pexp (mkVar fc i)]

@@ -107,7 +107,7 @@ var dsl n t i = v' i t where

107107 Just f -> f

108108 mkVar fc n = case index_next dsl of

109109 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))]

111111

112112unIdiom :: PTerm -> PTerm -> FC -> PTerm -> PTerm

113113unIdiom 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

150150 db' (PDPair fc l t r) = do l' <- db' l

151151 r' <- db' r

152152 return (PDPair fc l' t r')

153− db' t = return t

153+ db' t = return t

154154

155155 dbArg a = do t' <- db' (getTm a)

156156 return (a { getTm = t' })

src/Idris/DataOpts.hs+12−12

@@ -28,11 +28,11 @@ forceArgs n t = do i <- getIState

2828 where

2929 force :: IState -> Int -> Term -> [Int]

3030 force ist i (Bind _ (Pi ty) sc)

31− | collapsibleIn ist ty

31+ | collapsibleIn ist ty

3232 = nub $ i : (force ist (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc)

3333 | otherwise = force ist (i + 1) $ instantiate (P Bound (MN i "?") Erased) sc

34− force _ _ sc@(App f a)

35− | (_, args) <- unApply sc

34+ force _ _ sc@(App f a)

35+ | (_, args) <- unApply sc

3636 = nub $ concatMap guarded args

3737 force _ _ _ = []

3838

@@ -57,7 +57,7 @@ forceArgs n t = do i <- getIState

5757-- Calculate whether a collection of constructors is collapsible

5858

5959collapseCons :: Name -> [(Name, Type)] -> Idris ()

60−collapseCons ty cons =

60+collapseCons ty cons =

6161 do i <- getIState

6262 let cons' = map (\ (n, t) -> (n, map snd (getArgTys t))) cons

6363 allFR <- mapM (forceRec i) cons'

@@ -75,7 +75,7 @@ collapseCons ty cons =

7575 putIState (i { idris_optimisation = opts })

7676 else return ()

7777 _ -> return ()

78−

78+

7979 checkNewType _ = return ()

8080

8181 setCollapsible :: Name -> Idris ()

@@ -101,12 +101,12 @@ collapseCons ty cons =

101101 checkFR fs i (t : xs)

102102 -- must be recursive or type is not collapsible

103103 = do let (rtf, rta) = unApply $ getRetTy t

104− if (ty `elem` freeNames rtf)

104+ if (ty `elem` freeNames rtf)

105105 then checkFR fs (i+1) xs

106106 else return False

107107

108108 detaggable :: [Type] -> Idris ()

109− detaggable rtys

109+ detaggable rtys

110110 = do let rtyArgs = map (snd . unApply) rtys

111111 -- if every rtyArgs is disjoint with every other, it's detaggable,

112112 -- therefore also collapsible given forceable/recursive check

@@ -204,7 +204,7 @@ instance Optimisable t => Optimisable (Binder t) where

204204

205205applyDataOpt :: OptInfo -> Name -> [Raw] -> Raw

206206applyDataOpt 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..])

208208 args in

209209 raw_apply (Var n) args'

210210 where

@@ -267,7 +267,7 @@ applyDataOptRT :: OptInfo -> Name -> Int -> Int -> [Term] -> Term

267267applyDataOptRT oi n tag arity args

268268 | length args == arity = doOpts n args (collapsible oi) (forceable oi)

269269 | 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)

271271 (collapsible oi) (forceable oi) in

272272 bind extra tm

273273 where

@@ -279,7 +279,7 @@ applyDataOptRT oi n tag arity args

279279 -- Nat special cases

280280 -- TODO: Would be nice if this was configurable in idris source!

281281 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] _ _

283283 = App (App (P Ref (UN "prim__addBigInt") Erased) k) (Constant (BI 1))

284284

285285 doOpts n args True f = Erased

@@ -290,8 +290,8 @@ applyDataOptRT oi n tag arity args

290290 then case args' of

291291 [(_, val)] -> val

292292 _ -> error "Can't happen (not isnewtype)"

293− else

294− mkApp (P (DCon tag (arity - length forced)) n Erased)

293+ else

294+ mkApp (P (DCon tag (arity - length forced)) n Erased)

295295 (map snd args')

296296

297297 keep (forced, _) = not forced

src/Idris/Delaborate.hs+20−20

@@ -17,7 +17,7 @@ delab :: IState -> Term -> PTerm

1717delab i tm = delab' i tm False

1818

1919delabTy :: IState -> Name -> PTerm

20−delabTy i n

20+delabTy i n

2121 = case lookupTy n (tt_ctxt i) of

2222 (ty:_) -> case lookupCtxt n (idris_implicits i) of

2323 (imps:_) -> delabTy' i imps ty False

@@ -43,17 +43,17 @@ delabTy' ist imps tm fullname = de [] imps tm

4343 = case lookup n (idris_metavars ist) of

4444 Just (Just _, mi) -> mkMVApp (dens n) []

4545 _ -> PRef un (dens n)

46− de env _ (Bind n (Lam ty) sc)

46+ de env _ (Bind n (Lam ty) sc)

4747 = 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)

4949 = 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)

5151 = 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)

5353 = 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)

5555 = 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)

5757 = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

5858 de env _ (Bind n (Hole ty) sc) = de ((n, UN "[__]"):env) [] sc

5959 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

6161 de env _ (Constant i) = PConstant i

6262 de env _ Erased = Placeholder

6363 de env _ Impossible = Placeholder

64− de env _ (TType i) = PType

64+ de env _ (TType i) = PType

6565

6666 dens x | fullname = x

6767 dens ns@(NS n _) = case lookupCtxt n (idris_implicits ist) of

@@ -71,31 +71,31 @@ delabTy' ist imps tm fullname = de [] imps tm

7171 dens n = n

7272

7373 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]

7575 | n == pairTy = PPair un (de env [] l) (de env [] r)

7676 | n == eqCon = PRefl un (de env [] r)

7777 | n == UN "lazy" = de env [] r

7878 deFn env (P _ n _) [ty, Bind x (Lam _) r]

79− | n == UN "Exists"

79+ | n == UN "Exists"

8080 = PDPair un (PRef un x) (de env [] ty)

8181 (de ((x,x):env) [] (instantiate (P Bound x ty) r))

82− deFn env (P _ n _) [_,_,l,r]

82+ deFn env (P _ n _) [_,_,l,r]

8383 | n == pairCon = PPair un (de env [] l) (de env [] r)

8484 | n == eqTy = PEq un (de env [] l) (de env [] r)

8585 | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder

8686 (de env [] r)

87− deFn env (P _ n _) args

87+ deFn env (P _ n _) args

8888 = case lookup n (idris_metavars ist) of

89− Just (Just _, mi) ->

89+ Just (Just _, mi) ->

9090 mkMVApp (dens n) (drop mi (map (de env []) args))

9191 _ -> mkPApp (dens n) (map (de env []) args)

9292 deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args))

9393

9494 mkMVApp n []

9595 = PMetavar n

96− mkMVApp n args

96+ mkMVApp n args

9797 = PApp un (PMetavar n) (map pexp args)

98− mkPApp n args

98+ mkPApp n args

9999 | [imps] <- lookupCtxt n (idris_implicits ist)

100100 = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)

101101 | otherwise = PApp un (PRef un n) (map pexp args)

@@ -113,7 +113,7 @@ indented text = boxIt '\n' $ unlines $ map ('\t':) $ lines text where

113113

114114pshow :: IState -> Err -> String

115115pshow i (Msg s) = s

116−pshow i (InternalMsg s) = "INTERNAL ERROR: " ++ show s ++

116+pshow i (InternalMsg s) = "INTERNAL ERROR: " ++ show s ++

117117 "\nThis is probably a bug, or a missing error message.\n" ++

118118 "Please consider reporting at " ++ bugaddr

119119pshow i (CantUnify _ x y e sc s)

@@ -152,11 +152,11 @@ pshow i (CantIntroduce ty)

152152 let colour = idris_colourRepl i in

153153 "Can't use lambda here: type is " ++ showImp (Just i) imps colour (delab i ty)

154154pshow i (InfiniteUnify x tm env)

155− = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++

155+ = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++

156156 " would lead to infinite value" ++

157157 if (opt_errContext (idris_options i)) then showSc i env else ""

158158pshow 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 " ++

160160 show (delab i y)

161161pshow i (CantResolve c) = "Can't resolve type class " ++ show (delab i c)

162162pshow i (CantResolveAlts as) = "Can't disambiguate name: " ++ showSep ", " as

@@ -166,13 +166,13 @@ pshow i (IncompleteTerm t) = "Incomplete term " ++ showImp Nothing True False (d

166166pshow i UniverseError = "Universe inconsistency"

167167pshow i ProgramLineComment = "Program line next to comment"

168168pshow i (Inaccessible n) = show n ++ " is not an accessible pattern variable"

169−pshow i (NonCollapsiblePostulate n)

169+pshow i (NonCollapsiblePostulate n)

170170 = "The return type of postulate " ++ show n ++ " is not collapsible"

171171pshow i (AlreadyDefined n) = show n ++ " is already defined"

172172pshow i (ProofSearchFail e) = pshow i e

173173pshow i (NoRewriting tm) = "rewrite did not change type " ++ show (delab i tm)

174174pshow 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 ++

176176 showqual i n ++ ":\n" ++ pshow i e

177177pshow i (ProviderError msg) = "Type provider error: " ++ msg

178178pshow i (LoadingFailed fn e) = "Loading " ++ fn ++ " failed: " ++ pshow i e

src/Idris/Docs.hs+8−8

@@ -11,7 +11,7 @@ import Data.List

1111

1212-- TODO: Only include names with public/abstract accessibility

1313

14−data FunDoc = Doc Name String

14+data FunDoc = Doc Name String

1515 [(Name, PArg)] -- args

1616 PTerm -- function type

1717 (Maybe Fixity)

@@ -23,7 +23,7 @@ data Doc = FunDoc FunDoc

2323 [FunDoc] -- method docs

2424

2525showDoc "" = ""

26−showDoc x = " -- " ++ x

26+showDoc x = " -- " ++ x

2727

2828instance Show FunDoc where

2929 show (Doc n doc args ty f)

@@ -35,7 +35,7 @@ instance Show FunDoc where

3535 else ""

3636

3737 where showArg (n, arg@(PExp _ _ _ _))

38− = Just $ showName n ++ show (getTm arg) ++

38+ = Just $ showName n ++ show (getTm arg) ++

3939 showDoc (pargdoc arg) ++ "\n"

4040 showArg (n, arg@(PConstraint _ _ _ _))

4141 = Just $ "Class constraint " ++

@@ -44,7 +44,7 @@ instance Show FunDoc where

4444 showArg (n, arg@(PImp _ _ _ _ _ doc))

4545 | not (null doc)

4646 = Just $ "(implicit) " ++

47− show n ++ " : " ++ show (getTm arg)

47+ show n ++ " : " ++ show (getTm arg)

4848 ++ showDoc (pargdoc arg) ++ "\n"

4949 showArg (n, _) = Nothing

5050

@@ -57,13 +57,13 @@ instance Show Doc where

5757 show (DataDoc t args) = "Data type " ++ show t ++

5858 "\nConstructors:\n\n" ++

5959 showSep "\n" (map show args)

60− show (ClassDoc n doc meths)

60+ show (ClassDoc n doc meths)

6161 = "Type class " ++ show n ++ -- parameters?

6262 "\nMethods:\n\n" ++

6363 showSep "\n" (map show meths)

6464

6565getDocs :: Name -> Idris Doc

66−getDocs n

66+getDocs n

6767 = do i <- getIState

6868 case lookupCtxt n (idris_classes i) of

6969 [ci] -> docClass n ci

@@ -73,7 +73,7 @@ getDocs n

7373 return (FunDoc fd)

7474

7575docData :: Name -> TypeInfo -> Idris Doc

76−docData n ti

76+docData n ti

7777 = do tdoc <- docFun n

7878 cdocs <- mapM docFun (con_names ti)

7979 return (DataDoc tdoc cdocs)

@@ -103,7 +103,7 @@ docFun n

103103 let fixdecls = filter (\(Fix _ x) -> x == funName n) infixes

104104 let f = case fixdecls of

105105 [] -> Nothing

106− (Fix x _:_) -> Just x

106+ (Fix x _:_) -> Just x

107107

108108 return (Doc n docstr args (delab i ty) f)

109109 where funName :: Name -> String

src/Idris/ElabDecls.hs+176−176

@@ -31,9 +31,9 @@ import Data.List

3131import Data.Maybe

3232import Debug.Trace

3333

34−recheckC fc env t

34+recheckC fc env t

3535 = do -- t' <- applyOpts (forget t) (doesn't work, or speed things up...)

36− ctxt <- getContext

36+ ctxt <- getContext

3737 (tm, ty, cs) <- tclift $ case recheck ctxt env (forget t) t of

3838 Error e -> tfail (At fc e)

3939 OK x -> return x

@@ -47,7 +47,7 @@ checkDef fc ns = do ctxt <- getContext

4747-- | Elaborate a top-level type declaration - for example, "foo : Int -> Int".

4848elabType :: ElabInfo -> SyntaxInfo -> String ->

4949 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

5151 n = liftname info n_in in -}

5252 do checkUndefined fc n

5353 ctxt <- getContext

@@ -59,12 +59,12 @@ elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in

5959

6060 let ty = addImpl i ty'

6161 logLvl 2 $ show n ++ " type " ++ showImp Nothing True False ty

62− ((tyT, defer, is), log) <-

62+ ((tyT, defer, is), log) <-

6363 tclift $ elaborate ctxt n (TType (UVal 0)) []

6464 (errAt "type of " n (erun fc (build i info False n ty)))

6565 ds <- checkDef fc defer

6666 addDeferred ds

67− mapM_ (elabCaseBlock info opts) is

67+ mapM_ (elabCaseBlock info opts) is

6868 ctxt <- getContext

6969 logLvl 5 $ "Rechecking"

7070 logLvl 6 $ show tyT

@@ -147,7 +147,7 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

147147 i <- getIState

148148 t_in <- implicit syn n t_in

149149 let t = addImpl i t_in

150− ((t', defer, is), log) <-

150+ ((t', defer, is), log) <-

151151 tclift $ elaborate ctxt n (TType (UVal 0)) []

152152 (errAt "data declaration " n (erun fc (build i info False n t)))

153153 def' <- checkDef fc defer

@@ -156,11 +156,11 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

156156 (cty, _) <- recheckC fc [] t'

157157 logLvl 2 $ "---> " ++ show cty

158158 -- temporary, to check cons

159− when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

159+ when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

160160 cons <- mapM (elabCon info syn n codata) dcons

161161 ttag <- getName

162162 i <- getIState

163− let as = map (const Nothing) (getArgTys cty)

163+ let as = map (const Nothing) (getArgTys cty)

164164 let params = findParams (map snd cons)

165165 logLvl 2 $ "Parameters : " ++ show params

166166 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)

172172 collapseCons n cons

173173 updateContext (addDatatype (Data n ttag cty cons))

174174 mapM_ (checkPositive n) cons

175− where

175+ where

176176 -- parameters are names which are unchanged across the structure,

177177 -- which appear exactly once in the return type of a constructor

178178

@@ -184,14 +184,14 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

184184 paramPos allapps

185185

186186 paramPos [] = []

187− paramPos (args : rest)

187+ paramPos (args : rest)

188188 = dropNothing $ keepSame (zip [0..] args) rest

189189

190190 dropNothing [] = []

191191 dropNothing ((x, Nothing) : ts) = dropNothing ts

192192 dropNothing ((x, _) : ts) = x : dropNothing ts

193193

194− keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] ->

194+ keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] ->

195195 [(Int, Maybe Name)]

196196 keepSame as [] = as

197197 keepSame as (args : rest) = keepSame (update as args) rest

@@ -211,14 +211,14 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

211211 getDataApp _ = []

212212

213213 -- keep the arguments which are single names, which don't appear

214− -- elsewhere

214+ -- elsewhere

215215

216216 mParam args [] = []

217217 mParam args (P Bound n _ : rest)

218− | count n args == 1

218+ | count n args == 1

219219 = Just n : mParam args rest

220220 where count n [] = 0

221− count n (t : ts)

221+ count n (t : ts)

222222 | n `elem` freeNames t = 1 + count n ts

223223 | otherwise = count n ts

224224 mParam args (_ : rest) = Nothing : mParam args rest

@@ -253,7 +253,7 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

253253 believeTy = Bind (UN "a") (Pi (TType (UVar (-2))))

254254 (Bind (UN "b") (Pi (TType (UVar (-2))))

255255 (Bind (UN "x") (Pi (V 1)) (V 1)))

256− elabBelieveMe

256+ elabBelieveMe

257257 = do let prim__believe_me = (UN "prim__believe_me")

258258 updateContext (addOperator prim__believe_me believeTy 3 p_believeMe)

259259 setTotality prim__believe_me (Partial NotCovering)

@@ -279,7 +279,7 @@ elabPrims = do mapM_ (elabDecl EAll toplevel)

279279 (Bind (UN "y") (Pi (V 1))

280280 (mkApp nMaybe [mkApp (P (TCon 0 4) eqTy Erased)

281281 [V 3, V 2, V 1, V 0]]))))

282− elabSynEq

282+ elabSynEq

283283 = do let synEq = UN "prim__syntactic_eq"

284284

285285 updateContext (addOperator synEq synEqTy 4 p_synEq)

@@ -375,10 +375,10 @@ elabTransform info fc safe lhs_in rhs_in

375375 addIBC (IBCTrans (clhs_tm, crhs_tm))

376376

377377

378−elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

378+elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

379379 PTerm -> String -> Name -> PTerm -> Idris ()

380380elabRecord 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)])

382382 cty' <- implicit syn cn cty

383383 i <- getIState

384384 cty <- case lookupTy cn (tt_ctxt i) of

@@ -408,8 +408,8 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

408408 = do i <- getIState

409409 idrisCatch (do elabDecl' EAll info ty

410410 elabDecl' EAll info val)

411− (\v -> do iputStrLn $ show fc ++

412− ":Warning - can't generate setter for " ++

411+ (\v -> do iputStrLn $ show fc ++

412+ ":Warning - can't generate setter for " ++

413413 show fn ++ " (" ++ show ty ++ ")"

414414 putIState i)

415415

@@ -459,9 +459,9 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

459459 let lhs = PApp fc (PRef fc pn)

460460 [pexp (PApp fc (PRef fc cn) iargs)]

461461 let rhs = PRef fc (mkp pn)

462− let pclause = PClause fc pn lhs [] rhs []

462+ let pclause = PClause fc pn lhs [] rhs []

463463 return [pfnTy, PClauses fc [] pn [pclause]]

464−

464+

465465 implicitise (pa, t) = pa { getTm = t }

466466

467467 mkUpdate recty k num ((pn, pty), pos)

@@ -484,7 +484,7 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

484484 (map pexp rhsArgs)) []

485485 return (pn, pfnTy, PClauses fc [] setname [pclause])

486486

487−elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

487+elabCon :: ElabInfo -> SyntaxInfo -> Name -> Bool ->

488488 (String, Name, PTerm, FC) -> Idris (Name, Type)

489489elabCon info syn tn codata (doc, n, t_in, fc)

490490 = do checkUndefined fc n

@@ -493,7 +493,7 @@ elabCon info syn tn codata (doc, n, t_in, fc)

493493 t_in <- implicit syn n (if codata then mkLazy t_in else t_in)

494494 let t = addImpl i t_in

495495 logLvl 2 $ show fc ++ ":Constructor " ++ show n ++ " : " ++ showImp Nothing True False t

496− ((t', defer, is), log) <-

496+ ((t', defer, is), log) <-

497497 tclift $ elaborate ctxt n (TType (UVal 0)) []

498498 (errAt "constructor " n (erun fc (build i info False n t)))

499499 logLvl 2 $ "Rechecking " ++ show t'

@@ -512,8 +512,8 @@ elabCon info syn tn codata (doc, n, t_in, fc)

512512 return (n, cty')

513513 where

514514 tyIs (Bind n b sc) = tyIs sc

515− tyIs t | (P _ n' _, _) <- unApply t

516− = if n' /= tn then tclift $ tfail (At fc (Msg (show n' ++ " is not " ++ show tn)))

515+ tyIs t | (P _ n' _, _) <- unApply t

516+ = if n' /= tn then tclift $ tfail (At fc (Msg (show n' ++ " is not " ++ show tn)))

517517 else return ()

518518 tyIs t = tclift $ tfail (At fc (Msg (show t ++ " is not " ++ show tn)))

519519

@@ -523,7 +523,7 @@ elabCon info syn tn codata (doc, n, t_in, fc)

523523-- | Elaborate a collection of left-hand and right-hand pairs - that is, a

524524-- top-level definition.

525525elabClauses :: 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

527527 do ctxt <- getContext

528528 -- Check n actually exists, with no definition yet

529529 let tys = lookupTy n ctxt

@@ -535,7 +535,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

535535 -- question: CAFs in where blocks?

536536 tclift $ tfail $ At fc (NoTypeDecl n)

537537 [ty] -> return ty

538− pats_in <- mapM (elabClause info opts)

538+ pats_in <- mapM (elabClause info opts)

539539 (zip [0..] cs)

540540 logLvl 3 $ "Elaborated patterns:\n" ++ show pats_in

541541

@@ -553,9 +553,9 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

553553 _ -> False

554554 solveDeferred n

555555 ist <- getIState

556− when doNothing $

556+ when doNothing $

557557 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 })

559559 (idris_optimisation ist)

560560 putIState (ist { idris_optimisation = opts })

561561 _ -> 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

563563 putIState (ist { idris_optimisation = opts })

564564 addIBC (IBCOpt n)

565565 ist <- getIState

566− let pats = doTransforms ist pats_in

566+ let pats = doTransforms ist pats_in

567567

568− -- logLvl 3 (showSep "\n" (map (\ (l,r) ->

569− -- show l ++ " = " ++

568+ -- logLvl 3 (showSep "\n" (map (\ (l,r) ->

569+ -- show l ++ " = " ++

570570 -- show r) pats))

571571 let tcase = opt_typecase (idris_options ist)

572572

@@ -583,7 +583,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

583583 -- This will get further optimised for run-time, and, separately,

584584 -- further inlined to help with totality checking.

585585 let pdef = map debind $ map (simple_lhs (tt_ctxt ist)) pats

586−

586+

587587 logLvl 5 $ "Initial typechecked patterns:\n" ++ show pdef

588588

589589 -- 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

600600

601601 -- patterns after collapsing optimisation applied

602602 -- (i.e. check if the function should do nothing at run time)

603− optpats <- if doNothing

603+ optpats <- if doNothing

604604 then return $ [Right (mkApp (P Bound n Erased)

605605 (take numArgs (repeat Erased)), Erased)]

606606 else stripCollapsed pats

@@ -610,22 +610,22 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

610610 _ -> return ()

611611

612612 let optpdef = map debind $ map (simple_lhs (tt_ctxt ist)) optpats

613− tree@(CaseDef scargs sc _) <- tclift $

613+ tree@(CaseDef scargs sc _) <- tclift $

614614 simpleCase tcase False reflect CompileTime fc pdef

615615 cov <- coverage

616616 pmissing <-

617− if cov

617+ if cov

618618 then do missing <- genClauses fc n (map getLHS pdef) cs

619− -- missing <- genMissing n scargs sc

619+ -- missing <- genMissing n scargs sc

620620 missing' <- filterM (checkPossible info fc True n) missing

621621 let clhs = map getLHS pdef

622− logLvl 2 $ "Must be unreachable:\n" ++

622+ logLvl 2 $ "Must be unreachable:\n" ++

623623 showSep "\n" (map (showImp Nothing True False) missing') ++

624624 "\nAgainst: " ++

625625 showSep "\n" (map (\t -> showImp Nothing True False (delab ist t)) (map getLHS pdef))

626626 -- filter out anything in missing' which is

627627 -- 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

629629 -- particular form, rather than force a case

630630 -- to be impossible.

631631 return (filter (noMatch ist clhs) missing')

@@ -633,7 +633,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

633633 let pcover = null pmissing

634634

635635 -- pdef' is the version that gets compiled for run-time

636− pdef' <- applyOpts optpdef

636+ pdef' <- applyOpts optpdef

637637 logLvl 5 $ "After data structure transformations:\n" ++ show pdef'

638638

639639 ist <- getIState

@@ -641,8 +641,8 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

641641 let tot = if pcover || AssertTotal `elem` opts

642642 then Unchecked -- finish checking later

643643 else Partial NotCovering -- already know it's not total

644− -- case lookupCtxt (namespace info) n (idris_flags ist) of

645− -- [fs] -> if TotalFn `elem` fs

644+ -- case lookupCtxt (namespace info) n (idris_flags ist) of

645+ -- [fs] -> if TotalFn `elem` fs

646646 -- then case tot of

647647 -- Total _ -> return ()

648648 -- 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

652652 CaseDef _ _ [] -> return ()

653653 CaseDef _ _ xs -> mapM_ (\x ->

654654 iputStrLn $ show fc ++

655− ":warning - Unreachable case: " ++

655+ ":warning - Unreachable case: " ++

656656 show (delab ist x)) xs

657657 let knowncovering = (pcover && cov) || AssertTotal `elem` opts

658658

@@ -662,12 +662,12 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

662662 logLvl 3 $ "Optimised: " ++ show tree'

663663 ctxt <- getContext

664664 ist <- getIState

665− putIState (ist { idris_patdefs = addDef n (pdef', pmissing)

665+ putIState (ist { idris_patdefs = addDef n (pdef', pmissing)

666666 (idris_patdefs ist) })

667667 let caseInfo = CaseInfo (inlinable opts) (dictionary opts)

668668 case lookupTy n ctxt of

669669 [ty] -> do updateContext (addCasedef n caseInfo

670− tcase knowncovering

670+ tcase knowncovering

671671 reflect

672672 (AssertTotal `elem` opts)

673673 pats

@@ -698,14 +698,14 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

698698 where

699699 noMatch i cs tm = all (\x -> case matchClause i (delab' i x True) tm of

700700 Right _ -> False

701− Left miss -> True) cs

701+ Left miss -> True) cs

702702

703703 checkUndefined n ctxt = case lookupDef n ctxt of

704704 [] -> return ()

705705 [TyDecl _ _] -> return ()

706706 _ -> tclift $ tfail (At fc (AlreadyDefined n))

707707

708− debind (Right (x, y)) = let (vs, x') = depat [] x

708+ debind (Right (x, y)) = let (vs, x') = depat [] x

709709 (_, y') = depat [] y in

710710 (vs, x', y')

711711 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

713713

714714 depat acc (Bind n (PVar t) sc) = depat (n : acc) (instantiate (P Bound n t) sc)

715715 depat acc x = (acc, x)

716−

716+

717717 getLHS (_, l, _) = l

718718

719− simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)

719+ simple_lhs ctxt (Right (x, y)) = Right (normalise ctxt [] x, y)

720720 simple_lhs ctxt t = t

721721

722722 specNames [] = Nothing

723723 specNames (Specialise ns : _) = Just ns

724724 specNames (_ : xs) = specNames xs

725725

726− sameLength ((_, x, _) : xs)

726+ sameLength ((_, x, _) : xs)

727727 = do l <- sameLength xs

728728 let (f, as) = unApply x

729729 if (null xs || l == length as) then return (length as)

730730 else tfail (At fc (Msg "Clauses have differing numbers of arguments "))

731731 sameLength [] = return 0

732732

733− -- apply all transformations (just specialisation for now, add

733+ -- apply all transformations (just specialisation for now, add

734734 -- user defined transformation rules later)

735− doTransforms ist pats =

735+ doTransforms ist pats =

736736 case specNames opts of

737737 Nothing -> pats

738738 Just ns -> partial_eval (tt_ctxt ist) ns pats

@@ -750,14 +750,14 @@ elabValBind info aspat tm_in

750750 -- * ordinary elaboration

751751 -- * elaboration as a Type

752752 -- * elaboration as a function a -> b

753−

754− ((tm', defer, is), _) <-

755−-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

753+

754+ ((tm', defer, is), _) <-

755+-- tctry (elaborate ctxt (MN 0 "val") (TType (UVal 0)) []

756756-- (build i info aspat (MN 0 "val") tm))

757757 tclift (elaborate ctxt (MN 0 "val") infP []

758758 (build i info aspat (MN 0 "val") (infTerm tm)))

759759 let vtm = orderPats (getInferTerm tm')

760− let bargs = getPBtys vtm

760+ let bargs = getPBtys vtm

761761

762762 def' <- checkDef (fileFC "(input)") defer

763763 addDeferred def'

@@ -796,7 +796,7 @@ checkPossible info fc tcgen fname lhs_in

796796-- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)

797797 err@(Error _) -> return False

798798

799−elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

799+elabClause :: ElabInfo -> FnOpts -> (Int, PClause) ->

800800 Idris (Either Term (Term, Term))

801801elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

802802 = do let tcgen = Dictionary `elem` opts

@@ -805,7 +805,7 @@ elabClause info opts (_, PClause fc fname lhs_in [] PImpossible [])

805805 True -> ifail $ show fc ++ ":" ++ show lhs_in ++ " is a possible case"

806806 False -> do ptm <- mkPatTm lhs_in

807807 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)

809809 = do let tcgen = Dictionary `elem` opts

810810 ctxt <- getContext

811811

@@ -818,15 +818,15 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

818818 _ -> error "Can't happen (elabClause function type)"

819819 let fn_is = case lookupCtxt fname (idris_implicits i) of

820820 [t] -> t

821− _ -> []

821+ _ -> []

822822 let params = getParamsInType i [] fn_is fn_ty

823823 let lhs = addImplPat i (propagateParams params (stripLinear i lhs_in))

824824 logLvl 5 ("LHS: " ++ show fc ++ " " ++ showImp Nothing True False lhs)

825825 logLvl 4 ("Fixed parameters: " ++ show params ++ " from " ++ show (fn_ty, fn_is))

826826

827− ((lhs', dlhs, []), _) <-

827+ ((lhs', dlhs, []), _) <-

828828 tclift $ elaborate ctxt (MN 0 "patLHS") infP []

829− (errAt "left hand side of " fname

829+ (errAt "left hand side of " fname

830830 (erun fc (buildTC i info True tcgen fname (infTerm lhs))))

831831 let lhs_tm = orderPats (getInferTerm lhs')

832832 let lhs_ty = getInferType lhs'

@@ -848,7 +848,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

848848 let defs = nub (decls ++ concatMap defined whereblock)

849849 let newargs = pvars ist lhs_tm

850850 let wb = map (expandParamsD False ist decorate newargs defs) whereblock

851−

851+

852852 -- Split the where block into declarations with a type, and those

853853 -- without

854854 -- 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)

864864 logLvl 2 $ "RHS: " ++ showImp Nothing True False rhs

865865 ctxt <- getContext -- new context with where block added

866866 logLvl 5 "STARTING CHECK"

867− ((rhs', defer, is), _) <-

867+ ((rhs', defer, is), _) <-

868868 tclift $ elaborate ctxt (MN 0 "patRHS") clhsty []

869869 (do pbinds lhs_tm

870− (_, _, is) <- errAt "right hand side of " fname

870+ (_, _, is) <- errAt "right hand side of " fname

871871 (erun fc (build i info False fname rhs))

872− errAt "right hand side of " fname

872+ errAt "right hand side of " fname

873873 (erun fc $ psolve lhs_tm)

874874 tt <- get_term

875875 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)

897897 checkInferred fc (delab' i crhs True) rhs

898898 return $ Right (clhs, crhs)

899899 where

900− decorate (NS x ns)

901− = NS (SN (WhereN cnum fname x)) ns -- ++ [show cnum])

900+ decorate (NS x ns)

901+ = NS (SN (WhereN cnum fname x)) ns -- ++ [show cnum])

902902-- = NS (UN ('#':show x)) (ns ++ [show cnum, show fname])

903− decorate x

903+ decorate x

904904 = SN (WhereN cnum fname x)

905905-- = NS (SN (WhereN cnum fname x)) [show cnum]

906906-- = 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)

909909 sepBlocks' ns (d@(PTy _ _ _ _ n t) : bs)

910910 = let (bf, af) = sepBlocks' (n : ns) bs in

911911 (d : bf, af)

912− sepBlocks' ns (d@(PClauses _ _ n _) : bs)

912+ sepBlocks' ns (d@(PClauses _ _ n _) : bs)

913913 | not (n `elem` ns) = let (bf, af) = sepBlocks' ns bs in

914914 (bf, d : af)

915915 sepBlocks' ns (b : bs) = let (bf, af) = sepBlocks' ns bs in

916916 (b : bf, af)

917917 sepBlocks' ns [] = ([], [])

918918

919− pinfo ns ps i

919+ pinfo ns ps i

920920 = let ds = concatMap declared ps

921921 newps = params info ++ ns

922922 dsParams = map (\n -> (n, map fst newps)) ds

923− newb = addAlist dsParams (inblock info)

923+ newb = addAlist dsParams (inblock info)

924924 l = liftname info in

925925 info { params = newps,

926926 inblock = newb,

@@ -929,24 +929,24 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

929929 -- _ -> MN i (show n)) . l

930930 }

931931

932− getParamsInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)

932+ getParamsInType i env (PExp _ _ _ _ : is) (Bind n (Pi t) sc)

933933 = 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)

935935 = getParamsInType i (n : env) is (instantiate (P Bound n t) sc)

936936 getParamsInType i env is tm@(App f a)

937− | (P _ tn _, args) <- unApply tm

937+ | (P _ tn _, args) <- unApply tm

938938 = case lookupCtxt tn (idris_datatypes i) of

939939 [t] -> nub $ paramNames args env (param_pos t) ++

940− getParamsInType i env is f ++

940+ getParamsInType i env is f ++

941941 getParamsInType i env is a

942− [] -> nub $ getParamsInType i env is f ++

942+ [] -> nub $ getParamsInType i env is f ++

943943 getParamsInType i env is a

944− | otherwise = nub $ getParamsInType i env is f ++

944+ | otherwise = nub $ getParamsInType i env is f ++

945945 getParamsInType i env is a

946946 getParamsInType i _ _ _ = []

947947

948948 paramNames args env [] = []

949− paramNames args env (p : ps)

949+ paramNames args env (p : ps)

950950 | length args > p = case args!!p of

951951 P _ n _ -> if n `elem` env

952952 then n : paramNames args env ps

@@ -964,7 +964,7 @@ elabClause info opts (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

964964 = PApp fc (PRef fc n) (map (\x -> pimp x (PRef fc x) True) ps)

965965 propagateParams ps x = x

966966

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)

968968 = do let tcgen = Dictionary `elem` opts

969969 ctxt <- getContext

970970 -- 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)

972972 i <- getIState

973973 let lhs = addImplPat i lhs_in

974974 logLvl 5 ("LHS: " ++ showImp Nothing True False lhs)

975− ((lhs', dlhs, []), _) <-

975+ ((lhs', dlhs, []), _) <-

976976 tclift $ elaborate ctxt (MN 0 "patLHS") infP []

977977 (errAt "left hand side of with in " fname

978978 (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)

986986 let wval = addImplBound i (map fst bargs) wval_in

987987 logLvl 5 ("Checking " ++ showImp Nothing True False wval)

988988 -- Elaborate wval in this context

989− ((wval', defer, is), _) <-

990− tclift $ elaborate ctxt (MN 0 "withRHS")

989+ ((wval', defer, is), _) <-

990+ tclift $ elaborate ctxt (MN 0 "withRHS")

991991 (bindTyArgs PVTy bargs infP) []

992992 (do pbinds lhs_tm

993993 -- TODO: may want where here - see winfo abpve

994− (_', d, is) <- errAt "with value in " fname

994+ (_', d, is) <- errAt "with value in " fname

995995 (erun fc (build i info False fname (infTerm wval)))

996996 erun fc $ psolve lhs_tm

997997 tt <- get_term

@@ -1008,18 +1008,18 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

10081008 -- rather than a de Bruijn index.

10091009 let pdeps = usedNamesIn pvars i (delab i cwvalty)

10101010 let (bargs_pre, bargs_post) = split pdeps bargs []

1011− logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

1011+ logLvl 10 ("With type " ++ show (getRetTy cwvaltyN) ++

10121012 " depends on " ++ show pdeps ++ " from " ++ show pvars)

10131013 logLvl 10 ("Pre " ++ show bargs_pre ++ "\nPost " ++ show bargs_post)

10141014 windex <- getName

10151015 -- 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

10171017 let wargval = getRetTy cwvalN

10181018 let wargtype = getRetTy cwvaltyN

10191019 logLvl 5 ("Abstract over " ++ show wargval)

1020− let wtype = bindTyArgs Pi (bargs_pre ++

1021− (MN 0 "warg", wargtype) :

1022− map (abstract (MN 0 "warg") wargval wargtype) bargs_post)

1020+ let wtype = bindTyArgs Pi (bargs_pre ++

1021+ (MN 0 "warg", wargtype) :

1022+ map (abstract (MN 0 "warg") wargval wargtype) bargs_post)

10231023 (substTerm wargval (P Bound (MN 0 "warg") wargtype) ret_ty)

10241024 logLvl 3 ("New function type " ++ show wtype)

10251025 let wname = MN windex (show fname)

@@ -1041,8 +1041,8 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

10411041 mapM_ (elabDecl EAll info) wb

10421042

10431043 -- rhs becomes: fname' ps wval

1044− let rhs = PApp fc (PRef fc wname)

1045− (map (pexp . (PRef fc) . fst) bargs_pre ++

1044+ let rhs = PApp fc (PRef fc wname)

1045+ (map (pexp . (PRef fc) . fst) bargs_pre ++

10461046 pexp wval :

10471047 (map (pexp . (PRef fc) . fst) bargs_post))

10481048 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)

10741074 mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)

10751075 = do i <- getIState

10761076 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 " ++

10781078 showImp Nothing True False toplhs)

10791079 case matchClause i toplhs tm of

10801080 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 ->

10821082 do logLvl 3 ("Match vars : " ++ show mvars)

10831083 lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

10841084 return $ PClause fc wname lhs ws rhs wheres

10851085 mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs)

10861086 = do i <- getIState

10871087 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 " ++

10891089 showImp Nothing True False toplhs)

10901090 withs' <- mapM (mkAuxC wname toplhs ns ns') withs

10911091 case matchClause i toplhs tm of

10921092 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 ->

10941094 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'

10961096 mkAux wname toplhs ns ns' c

10971097 = ifail $ show fc ++ "badly formed with clause"

10981098

@@ -1102,11 +1102,11 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

11021102 updateLHS n wname mvars ns_in ns_in' (PApp fc (PRef fc' n') args) w

11031103 = let ns = map (keepMvar (map fst mvars) fc') ns_in

11041104 ns' = map (keepMvar (map fst mvars) fc') ns_in' in

1105− return $ substMatches mvars $

1106− PApp fc (PRef fc' wname)

1105+ return $ substMatches mvars $

1106+ PApp fc (PRef fc' wname)

11071107 (map pexp ns ++ pexp w : (map pexp ns'))

1108− updateLHS n wname mvars ns ns' tm w

1109− = ifail $ "Not implemented match " ++ show tm

1108+ updateLHS n wname mvars ns ns' tm w

1109+ = ifail $ "Not implemented match " ++ show tm

11101110

11111111 keepMvar mvs fc v | v `elem` mvs = PRef fc v

11121112 | otherwise = Placeholder

@@ -1118,16 +1118,16 @@ elabClause info opts (_, PWith fc fname lhs_in withs wval_in withblock)

11181118 split deps ((n, ty) : rest) pre

11191119 | n `elem` deps = split (deps \\ [n]) rest ((n, ty) : pre)

11201120 | otherwise = split deps rest ((n, ty) : pre)

1121− split deps [] pre = (reverse pre, [])

1121+ split deps [] pre = (reverse pre, [])

11221122

11231123 abstract wn wv wty (n, argty) = (n, substTerm wv (P Bound wn wty) argty)

11241124

11251125data MArgTy = IA | EA | CA deriving Show

11261126

11271127elabClass :: ElabInfo -> SyntaxInfo -> String ->

1128− FC -> [PTerm] ->

1128+ FC -> [PTerm] ->

11291129 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

11311131 = do let cn = UN ("instance" ++ show tn) -- MN 0 ("instance" ++ show tn)

11321132 let tty = pibind ps PType

11331133 let constraint = PApp fc (PRef fc tn)

@@ -1137,20 +1137,20 @@ elabClass info syn doc fc constraints tn ps ds

11371137 let mnames = map getMName mdecls

11381138 logLvl 2 $ "Building methods " ++ show mnames

11391139 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)

11411141 (filter clause ds)

1142− let (methods, imethods)

1142+ let (methods, imethods)

11431143 = unzip (map (\ ( x,y,z) -> (x, y)) ims)

11441144 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) [])

11461146 -- build instance constructor type

11471147 -- decorate names of functions to ensure they can't be referred

11481148 -- to elsewhere in the class declaration

11491149 -- TODO: Remove mdec to make it a dependent record, which would

11501150 -- allow dependent type classes, but building instances will

11511151 -- then need some attention.

1152− let cty = impbind ps $ conbind constraints

1153− $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods)

1152+ let cty = impbind ps $ conbind constraints

1153+ $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods)

11541154 constraint

11551155 let cons = [("", cn, cty, fc)]

11561156 let ddecl = PDatadecl tn tty cons

@@ -1158,7 +1158,7 @@ elabClass info syn doc fc constraints tn ps ds

11581158 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc False ddecl

11591159 -- for each constraint, build a top level function to chase it

11601160 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

11621162 ++ using syn }

11631163 fns <- mapM (cfun cn constraint usyn (map fst imethods)) constraints

11641164 mapM_ (elabDecl EAll info) (concat fns)

@@ -1172,19 +1172,19 @@ elabClass info syn doc fc constraints tn ps ds

11721172 where

11731173 nodoc (n, (_, o, t)) = (n, (o, t))

11741174 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)

11761176

11771177 mdec (UN n) = SN (MethodN (UN n))

11781178 mdec (NS x n) = NS (mdec x) n

11791179 mdec x = x

11801180

11811181 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)

11831183 conbind (ty : ns) x = PPi constraint (MN 0 "class") ty (conbind ns x)

11841184 conbind [] x = x

11851185

11861186 getMName (PTy _ _ _ _ n _) = nsroot n

1187− tdecl allmeths (PTy doc syn _ o n t)

1187+ tdecl allmeths (PTy doc syn _ o n t)

11881188 = do t' <- implicit' syn allmeths n t

11891189 logLvl 5 $ "Method " ++ show n ++ " : " ++ showImp Nothing True False t'

11901190 return ( (n, (toExp (map fst ps) Exp t')),

@@ -1192,12 +1192,12 @@ elabClass info syn doc fc constraints tn ps ds

11921192 (n, (syn, o, t) ) )

11931193 tdecl _ _ = ifail "Not allowed in a class declaration"

11941194

1195− -- Create default definitions

1195+ -- Create default definitions

11961196 defdecl mtys c d@(PClauses fc opts n cs) =

11971197 case lookup n mtys of

11981198 Just (syn, o, ty) -> do let ty' = insertConstraint c ty

11991199 let ds = map (decorateid defaultdec)

1200− [PTy "" syn fc [] n ty',

1200+ [PTy "" syn fc [] n ty',

12011201 PClauses fc (o ++ opts) n cs]

12021202 iLOG (show ds)

12031203 return (n, ((defaultdec n, ds!!1), ds))

@@ -1214,7 +1214,7 @@ elabClass info syn doc fc constraints tn ps ds

12141214

12151215 -- Generate a function for chasing a dictionary constraint

12161216 cfun cn c syn all con

1217− = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con)

1217+ = do let cfn = UN ('@':'@':show cn ++ "#" ++ show con)

12181218 -- SN (ParentN cn (show con))

12191219 let mnames = take (length all) $ map (\x -> MN x "meth") [0..]

12201220 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

12381238

12391239 -- Generate a top level function which looks up a method in a given

12401240 -- 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))

12421242 = do let ty' = insertConstraint c ty

12431243 let mnames = take (length all) $ map (\x -> MN x "meth") [0..]

12441244 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

12601260 getMeth (m:ms) (a:as) x | x == a = PRef fc m

12611261 | otherwise = getMeth ms as x

12621262

1263− lhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : lhsArgs xs ns

1264− lhsArgs (IA : xs) ns = lhsArgs xs ns

1263+ lhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : lhsArgs xs ns

1264+ lhsArgs (IA : xs) ns = lhsArgs xs ns

12651265 lhsArgs (CA : xs) ns = lhsArgs xs ns

12661266 lhsArgs [] _ = []

12671267

1268− rhsArgs (EA : xs) (n : ns) = pexp (PRef fc n) : rhsArgs xs ns

1269− rhsArgs (IA : xs) ns = pexp Placeholder : 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

12701270 rhsArgs (CA : xs) ns = pconst (PResolveTC fc) : rhsArgs xs ns

12711271 rhsArgs [] _ = []

12721272

@@ -1281,43 +1281,43 @@ elabClass info syn doc fc constraints tn ps ds

12811281 toExp ns e (PPi p n ty sc) = PPi p n ty (toExp ns e sc)

12821282 toExp ns e sc = sc

12831283

1284−elabInstance :: ElabInfo -> SyntaxInfo ->

1284+elabInstance :: ElabInfo -> SyntaxInfo ->

12851285 FC -> [PTerm] -> -- constraints

1286− Name -> -- the class

1287− [PTerm] -> -- class parameters (i.e. instance)

1286+ Name -> -- the class

1287+ [PTerm] -> -- class parameters (i.e. instance)

12881288 PTerm -> -- full instance type

12891289 Maybe Name -> -- explicit name

12901290 [PDecl] -> Idris ()

12911291elabInstance info syn fc cs n ps t expn ds

1292− = do i <- getIState

1292+ = do i <- getIState

12931293 (n, ci) <- case lookupCtxtName n (idris_classes i) of

12941294 [c] -> return c

12951295 _ -> ifail $ show fc ++ ":" ++ show n ++ " is not a type class"

12961296 let constraint = PApp fc (PRef fc n) (map pexp ps)

12971297 let iname = case expn of

1298− Nothing -> SN (InstanceN n (map show ps))

1298+ Nothing -> SN (InstanceN n (map show ps))

12991299 -- UN ('@':show n ++ "$" ++ show ps)

13001300 Just nm -> nm

13011301 -- if the instance type matches any of the instances we have already,

13021302 -- and it's not a named instance, then it's overlapping, so report an error

13031303 case expn of

1304− Nothing -> do mapM_ (checkNotOverlapping i t) (class_instances ci)

1304+ Nothing -> do mapM_ (checkNotOverlapping i t) (class_instances ci)

13051305 addInstance intInst n iname

1306− Just _ -> addInstance intInst n iname

1306+ Just _ -> addInstance intInst n iname

13071307 elabType info syn "" fc [] iname t

13081308 let ips = zip (class_params ci) ps

13091309 let ns = case n of

13101310 NS n ns' -> ns'

13111311 _ -> []

1312− -- get the implicit parameters that need passing through to the

1312+ -- get the implicit parameters that need passing through to the

13131313 -- where block

13141314 wparams <- mapM (\p -> case p of

13151315 PApp _ _ args -> getWParams args

13161316 _ -> return []) ps

13171317 let pnames = map pname (concat (nub wparams))

1318− let mtys = map (\ (n, (op, t)) ->

1318+ let mtys = map (\ (n, (op, t)) ->

13191319 let t' = substMatchesShadow ips pnames t in

1320− (decorate ns iname n,

1320+ (decorate ns iname n,

13211321 op, coninsert cs t', t'))

13221322 (class_methods ci)

13231323 logLvl 3 (show (mtys, ips))

@@ -1329,12 +1329,12 @@ elabInstance info syn fc cs n ps t expn ds

13291329 let wbVals = map (decorateid (decorate ns iname)) ds'

13301330 let wb = wbTys ++ wbVals

13311331 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 " ++

13331333 show (concat (nub wparams))

13341334 let lhs = PRef fc iname

13351335 let rhs = PApp fc (PRef fc (instanceName ci))

13361336 (map (pexp . mkMethApp) mtys)

1337− let idecls = [PClauses fc [Dictionary] iname

1337+ let idecls = [PClauses fc [Dictionary] iname

13381338 [PClause fc iname lhs [] rhs wb]]

13391339 iLOG (show idecls)

13401340 mapM (elabDecl EAll info) idecls

@@ -1360,23 +1360,23 @@ elabInstance info syn fc cs n ps t expn ds

13601360 Right _ -> overlapping tret tret'

13611361 Left _ -> return ()

13621362 _ -> return ()

1363− overlapping t t' = tclift $ tfail (At fc (Msg $

1363+ overlapping t t' = tclift $ tfail (At fc (Msg $

13641364 "Overlapping instance: " ++ show t' ++ " already defined"))

13651365 getRetType (PPi _ _ _ sc) = getRetType sc

13661366 getRetType t = t

13671367

1368− mkMethApp (n, _, _, ty)

1368+ mkMethApp (n, _, _, ty)

13691369 = 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'

13711371 = 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'

13731373 = PLam (MN i "meth") Placeholder (lamBind (i+1) sc sc')

13741374 lamBind i _ sc = sc

1375− methArgs i (PPi (Imp _ _ _ _) n ty sc)

1375+ methArgs i (PPi (Imp _ _ _ _) n ty sc)

13761376 = 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)

13781378 = 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)

13801380 = PConstraint 0 False (PResolveTC fc) "" : methArgs (i+1) sc

13811381 methArgs i _ = []

13821382

@@ -1384,8 +1384,8 @@ elabInstance info syn fc cs n ps t expn ds

13841384 papp fc f as = PApp fc f as

13851385

13861386 getWParams [] = return []

1387− getWParams (p : ps)

1388− | PRef _ n <- getTm p

1387+ getWParams (p : ps)

1388+ | PRef _ n <- getTm p

13891389 = do ps' <- getWParams ps

13901390 ctxt <- getContext

13911391 case lookupP n ctxt of

@@ -1405,16 +1405,16 @@ elabInstance info syn fc cs n ps t expn ds

14051405 coninsert cs sc = conbind cs sc

14061406

14071407 insertDefaults :: IState -> Name ->

1408− [(Name, (Name, PDecl))] -> [String] ->

1408+ [(Name, (Name, PDecl))] -> [String] ->

14091409 [PDecl] -> [PDecl]

14101410 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

14121412 = insertDefaults i iname defs ns (insertDef i n dn clauses ns iname ds)

14131413

14141414 insertDef i meth def clauses ns iname decls

14151415 | null $ filter (clauseFor meth iname ns) decls

14161416 = let newd = expandParamsD False i (\n -> meth) [] [def] clauses in

1417− -- trace (show newd) $

1417+ -- trace (show newd) $

14181418 decls ++ [newd]

14191419 | otherwise = decls

14201420

@@ -1425,12 +1425,12 @@ elabInstance info syn fc cs n ps t expn ds

14251425

14261426 checkInClass ns meth

14271427 | not (null (filter (eqRoot meth) ns)) = return ()

1428− | otherwise = tclift $ tfail (At fc (Msg $

1428+ | otherwise = tclift $ tfail (At fc (Msg $

14291429 show meth ++ " not a method of class " ++ show n))

14301430

14311431 eqRoot x y = nsroot x == nsroot y

14321432

1433− clauseFor m iname ns (PClauses _ _ m' _)

1433+ clauseFor m iname ns (PClauses _ _ m' _)

14341434 = decorate ns iname m == decorate ns iname m'

14351435 clauseFor m iname ns _ = False

14361436

@@ -1460,17 +1460,17 @@ elabInstance info syn fc cs n ps t expn ds

14601460-}

14611461

14621462decorateid 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)

14641464 = PClauses f o (decorate n) (map dc cs)

14651465 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)

1467− = PWith fc (decorate n) (dappname t) as w

1466+ dc (PWith fc n t as w ds)

1467+ = PWith fc (decorate n) (dappname t) as w

14681468 (map (decorateid decorate) ds)

14691469 dappname (PApp fc (PRef fc' n) as) = PApp fc (PRef fc' (decorate n)) as

14701470 dappname t = t

14711471

14721472

1473−pbinds (Bind n (PVar t) sc) = do attack; patbind n

1473+pbinds (Bind n (PVar t) sc) = do attack; patbind n

14741474 pbinds sc

14751475pbinds tm = return ()

14761476

@@ -1495,8 +1495,8 @@ elabDecls info ds = do mapM_ (elabDecl EAll info) ds

14951495-- mapM_ (elabDecl EDefns info) ds

14961496

14971497elabDecl :: ElabWhat -> ElabInfo -> PDecl -> Idris ()

1498−elabDecl what info d

1499− = idrisCatch (elabDecl' what info d)

1498+elabDecl what info d

1499+ = idrisCatch (elabDecl' what info d)

15001500 (\e -> do setErrLine (getErrLine e)

15011501 ist <- getIState

15021502 let h = idris_outh ist

@@ -1504,24 +1504,24 @@ elabDecl what info d

15041504

15051505elabDecl' _ info (PFix _ _ _)

15061506 = return () -- nothing to elaborate

1507−elabDecl' _ info (PSyntax _ p)

1507+elabDecl' _ info (PSyntax _ p)

15081508 = 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)

15101510 | what /= EDefns

15111511 = do iLOG $ "Elaborating type decl " ++ show n ++ show o

15121512 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)

15141514 | what /= EDefns

15151515 = do iLOG $ "Elaborating postulate " ++ show n ++ show o

15161516 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)

15181518 | what /= ETypes

15191519 = do iLOG $ "Elaborating " ++ show (d_name d)

15201520 elabData info s doc f co d

1521− | otherwise

1521+ | otherwise

15221522 = do iLOG $ "Elaborating [type of] " ++ show (d_name d)

15231523 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)

15251525 | what /= ETypes

15261526 = do iLOG $ "Elaborating clause " ++ show n

15271527 i <- getIState -- get the type options too

@@ -1529,7 +1529,7 @@ elabDecl' what info d@(PClauses f o n ps)

15291529 [fs] -> fs

15301530 [] -> []

15311531 elabClauses info f (o ++ o') n ps

1532−elabDecl' what info (PMutual f ps)

1532+elabDecl' what info (PMutual f ps)

15331533 = do mapM_ (elabDecl ETypes info) ps

15341534 mapM_ (elabDecl EDefns info) ps

15351535 -- Do totality checking after entire mutual block

@@ -1541,32 +1541,32 @@ elabDecl' what info (PMutual f ps)

15411541 mapM_ checkDeclTotality (idris_totcheck i)

15421542 clear_totcheck

15431543

1544−elabDecl' what info (PParams f ns ps)

1544+elabDecl' what info (PParams f ns ps)

15451545 = do i <- getIState

15461546 iLOG $ "Expanding params block with " ++ show ns ++ " decls " ++

15471547 show (concatMap tldeclared ps)

15481548 let nblock = pblock i

1549− mapM_ (elabDecl' what info) nblock

1549+ mapM_ (elabDecl' what info) nblock

15501550 where

15511551 pinfo = let ds = concatMap tldeclared ps

15521552 newps = params info ++ ns

15531553 dsParams = map (\n -> (n, map fst newps)) ds

1554− newb = addAlist dsParams (inblock info) in

1554+ newb = addAlist dsParams (inblock info) in

15551555 info { params = newps,

15561556 inblock = newb }

1557− pblock i = map (expandParamsD False i id ns

1557+ pblock i = map (expandParamsD False i id ns

15581558 (concatMap tldeclared ps)) ps

15591559

15601560elabDecl' what info (PNamespace n ps) = mapM_ (elabDecl' what ninfo) ps

15611561 where

15621562 ninfo = case namespace info of

15631563 Nothing -> info { namespace = Just [n] }

1564− Just ns -> info { namespace = Just (n:ns) }

1565−elabDecl' what info (PClass doc s f cs n ps ds)

1564+ Just ns -> info { namespace = Just (n:ns) }

1565+elabDecl' what info (PClass doc s f cs n ps ds)

15661566 | what /= EDefns

15671567 = do iLOG $ "Elaborating class " ++ show n

15681568 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)

15701570 | what /= ETypes

15711571 = do iLOG $ "Elaborating instance " ++ show n

15721572 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)

15741574 | what /= ETypes

15751575 = do iLOG $ "Elaborating record " ++ show tyn

15761576 elabRecord info s doc f tyn ty cdoc cn cty

1577− | otherwise

1577+ | otherwise

15781578 = do iLOG $ "Elaborating [type of] " ++ show tyn

15791579 elabData info s doc f False (PLaterdecl tyn ty)

15801580elabDecl' _ info (PDSL n dsl)

15811581 = 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) })

15831583 addIBC (IBCDSL n)

1584−elabDecl' what info (PDirective i)

1584+elabDecl' what info (PDirective i)

15851585 | what /= EDefns = i

15861586elabDecl' what info (PProvider syn fc n tp tm)

15871587 | what /= EDefns

15881588 = do iLOG $ "Elaborating type provider " ++ show n

15891589 elabProvider info syn fc n tp tm

15901590elabDecl' what info (PTransform fc safety old new)

1591− = elabTransform info fc safety old new

1592−elabDecl' _ _ _ = return () -- skipped this time

1591+ = elabTransform info fc safety old new

1592+elabDecl' _ _ _ = return () -- skipped this time

15931593

1594−elabCaseBlock info opts d@(PClauses f o n ps)

1594+elabCaseBlock info opts d@(PClauses f o n ps)

15951595 = do addIBC (IBCDef n)

15961596 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 )

15981598

15991599-- elabDecl' info (PImport i) = loadModule i

16001600

@@ -1608,9 +1608,9 @@ checkInferred fc inf user =

16081608 showImp Nothing True False user

16091609 logLvl 10 $ "Checking match"

16101610 i <- getIState

1611− tclift $ case matchClause' True i user inf of

1611+ tclift $ case matchClause' True i user inf of

16121612 _ -> return ()

1613−-- Left (x, y) -> tfail $ At fc

1613+-- Left (x, y) -> tfail $ At fc

16141614-- (Msg $ "The type-checked term and given term do not match: "

16151615-- ++ show x ++ " and " ++ show y)

16161616 logLvl 10 $ "Checked match"

@@ -1624,7 +1624,7 @@ inferredDiff fc inf user =

16241624 do i <- getIState

16251625 logLvl 6 $ "Checked to\n" ++ showImp Nothing True False inf ++ "\n" ++

16261626 showImp Nothing True False user

1627− tclift $ case matchClause' True i user inf of

1627+ tclift $ case matchClause' True i user inf of

16281628 Right vs -> return False

16291629 Left (x, y) -> return True

16301630

src/Idris/ElabTerm.hs+102−102

@@ -35,9 +35,9 @@ toplevel = EInfo [] emptyContext id Nothing

3535

3636-- Also find deferred names in the term and their types

3737

38−build :: IState -> ElabInfo -> Bool -> Name -> PTerm ->

38+build :: IState -> ElabInfo -> Bool -> Name -> PTerm ->

3939 ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])

40−build ist info pattern fn tm

40+build ist info pattern fn tm

4141 = do elab ist info pattern False fn tm

4242 ivs <- get_instances

4343 hs <- get_holes

@@ -45,14 +45,14 @@ build ist info pattern fn tm

4545 -- Resolve remaining type classes. Two passes - first to get the

4646 -- default Num instances, second to clean up the rest

4747 when (not pattern) $

48− mapM_ (\n -> when (n `elem` hs) $

48+ mapM_ (\n -> when (n `elem` hs) $

4949 do focus n

5050 try (resolveTC 7 fn ist)

5151 (movelast n)) ivs

5252 ivs <- get_instances

5353 hs <- get_holes

5454 when (not pattern) $

55− mapM_ (\n -> when (n `elem` hs) $

55+ mapM_ (\n -> when (n `elem` hs) $

5656 do focus n

5757 resolveTC 7 fn ist) ivs

5858 tm <- get_term

@@ -73,9 +73,9 @@ build ist info pattern fn tm

7373-- (Separate, so we don't go overboard resolving things that we don't

7474-- know about yet on the LHS of a pattern def)

7575

76−buildTC :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

76+buildTC :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

7777 ElabD (Term, [(Name, (Int, Maybe Name, Type))], [PDecl])

78−buildTC ist info pattern tcgen fn tm

78+buildTC ist info pattern tcgen fn tm

7979 = do elab ist info pattern tcgen fn tm

8080 probs <- get_probs

8181 tm <- get_term

@@ -92,9 +92,9 @@ buildTC ist info pattern tcgen fn tm

9292-- Returns the set of declarations we need to add to complete the definition

9393-- (most likely case blocks to elaborate)

9494

95−elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

95+elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

9696 ElabD ()

97−elab ist info pattern tcgen fn tm

97+elab ist info pattern tcgen fn tm

9898 = do let loglvl = opt_logLevel (idris_options ist)

9999 when (loglvl > 5) $ unifyLog True

100100 compute -- expand type synonyms, etc

@@ -125,15 +125,15 @@ elab ist info pattern tcgen fn tm

125125

126126 elabE ina t = {- do g <- goal

127127 tm <- get_term

128− trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm)

129− $ -}

128+ trace ("Elaborating " ++ show t ++ " : " ++ show g ++ "\n\tin " ++ show tm)

129+ $ -}

130130 do t' <- insertCoerce ina t

131131 g <- goal

132132 tm <- get_term

133133 ps <- get_probs

134134 hs <- get_holes

135135-- trace ("Elaborating " ++ show t' ++ " in " ++ show g

136−-- -- ++ "\n" ++ show tm

136+-- -- ++ "\n" ++ show tm

137137-- ++ "\nholes " ++ show hs

138138-- ++ "\nproblems " ++ show ps

139139-- ++ "\n-----------\n") $

@@ -151,22 +151,22 @@ elab ist info pattern tcgen fn tm

151151 elab' ina (PFalse fc) = elab' ina (PRef fc falseTy)

152152 elab' ina (PResolveTC (FC "HACK" _ _)) -- for chasing parent classes

153153 = resolveTC 5 fn ist

154− elab' ina (PResolveTC fc)

154+ elab' ina (PResolveTC fc)

155155 | True = do c <- unique_hole (MN 0 "class")

156156 instanceArg c

157157 | otherwise = do g <- goal

158158 try (resolveTC 2 fn ist)

159159 (do c <- unique_hole (MN 0 "class")

160160 instanceArg c)

161− elab' ina (PRefl fc t)

161+ elab' ina (PRefl fc t)

162162 = elab' ina (PApp fc (PRef fc eqCon) [pimp (MN 0 "a") Placeholder True,

163163 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)

165165 [pimp (MN 0 "a") Placeholder True,

166166 pimp (MN 0 "b") Placeholder False,

167167 pexp l, pexp r])

168− elab' ina@(_, a) (PPair fc l r)

169− = do hnf_compute

168+ elab' ina@(_, a) (PPair fc l r)

169+ = do hnf_compute

170170 g <- goal

171171 case g of

172172 TType _ -> elabE (True, a) (PApp fc (PRef fc pairTy)

@@ -176,8 +176,8 @@ elab ist info pattern tcgen fn tm

176176 pimp (MN 0 "B") Placeholder True,

177177 pexp l, pexp r])

178178 elab' ina (PDPair fc l@(PRef _ n) t r)

179− = case t of

180− Placeholder ->

179+ = case t of

180+ Placeholder ->

181181 do hnf_compute

182182 g <- goal

183183 case g of

@@ -195,7 +195,7 @@ elab ist info pattern tcgen fn tm

195195 [pimp (MN 0 "a") t False,

196196 pimp (MN 0 "P") Placeholder True,

197197 pexp l, pexp r])

198− elab' ina (PAlternative True as)

198+ elab' ina (PAlternative True as)

199199 = do hnf_compute

200200 ty <- goal

201201 ctxt <- get_context

@@ -207,13 +207,13 @@ elab ist info pattern tcgen fn tm

207207 tryAll (zip (map (elab' ina) as') (map showHd as'))

208208 where showHd (PApp _ h _) = show h

209209 showHd x = show x

210− elab' ina (PAlternative False as)

210+ elab' ina (PAlternative False as)

211211 = trySeq as

212212 where -- if none work, take the error from the first

213213 trySeq (x : xs) = let e1 = elab' ina x in

214214 try' e1 (trySeq' e1 xs) True

215215 trySeq' deferr [] = proofFail deferr

216− trySeq' deferr (x : xs)

216+ trySeq' deferr (x : xs)

217217 = try' (elab' ina x) (trySeq' deferr xs) True

218218 elab' ina (PPatvar fc n) | pattern = patvar n

219219 elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n)

@@ -239,8 +239,8 @@ elab ist info pattern tcgen fn tm

239239 ptm <- get_term

240240 g <- goal

241241 checkPiGoal n

242− attack; intro (Just n);

243− -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

242+ attack; intro (Just n);

243+ -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

244244 elabE (True, a) sc; solve

245245 where repN n n' (PRef fc x) | x == n' = PRef fc n'

246246 repN _ _ t = t

@@ -254,7 +254,7 @@ elab ist info pattern tcgen fn tm

254254 ptm <- get_term

255255 hs <- get_holes

256256 -- trace ("BEFORE:\n" ++ show hsin ++ "\n" ++ show ptmin ++

257− -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $

257+ -- "\nNOW:\n" ++ show hs ++ "\n" ++ show ptm) $

258258 introTy (Var tyn) (Just n)

259259 -- end_unify

260260 focus tyn

@@ -265,10 +265,10 @@ elab ist info pattern tcgen fn tm

265265 solve

266266 elab' ina@(_,a) (PPi _ n Placeholder sc)

267267 = 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)

269269 = do attack; tyn <- unique_hole (MN 0 "ty")

270270 claim tyn RType

271− n' <- case n of

271+ n' <- case n of

272272 MN _ _ -> unique_hole n

273273 _ -> return n

274274 forall n' (Var tyn)

@@ -310,8 +310,8 @@ elab ist info pattern tcgen fn tm

310310 computeLet n

311311 elabE (True, a) sc

312312 solve

313−-- elab' ina (PLet n Placeholder

314−-- (PApp fc r [pexp (delab ist rty)]) sc)

313+-- elab' ina (PLet n Placeholder

314+-- (PApp fc r [pexp (delab ist rty)]) sc)

315315 elab' ina tm@(PApp fc (PInferRef _ f) args) = do

316316 rty <- goal

317317 ds <- get_deferred

@@ -330,10 +330,10 @@ elab ist info pattern tcgen fn tm

330330 mapM_ elabIArg (zip argTys args)

331331 where claimArgTys env [] = return []

332332 claimArgTys env (arg : xs) | Just n <- localVar env (getTm arg)

333− = do nty <- get_type (Var n)

333+ = do nty <- get_type (Var n)

334334 ans <- claimArgTys env xs

335335 return ((n, (False, forget nty)) : ans)

336− claimArgTys env (_ : xs)

336+ claimArgTys env (_ : xs)

337337 = do an <- unique_hole (MN 0 "inf_argTy")

338338 aval <- unique_hole (MN 0 "inf_arg")

339339 claim an RType

@@ -343,15 +343,15 @@ elab ist info pattern tcgen fn tm

343343 fnTy [] ret = forget ret

344344 fnTy ((x, (_, xt)) : xs) ret = RBind x (Pi xt) (fnTy xs ret)

345345

346− localVar env (PRef _ x)

346+ localVar env (PRef _ x)

347347 = case lookup x env of

348348 Just _ -> Just x

349349 _ -> Nothing

350350 localVar env _ = Nothing

351351

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)

353353 elabIArg _ = return () -- already done, just a name

354−

354+

355355 mkN n@(NS _ _) = n

356356 mkN n@(SN _) = n

357357 mkN n = case namespace info of

@@ -365,7 +365,7 @@ elab ist info pattern tcgen fn tm

365365 ns <- match_apply (Var fn') (map (\x -> (x,0)) imps)

366366 solve

367367 -- 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')

369369 = do let args = {- case lookupCtxt f (inblock info) of

370370 Just ps -> (map (pexp . (PRef fc)) ps ++ args')

371371 _ -> -} args'

@@ -373,11 +373,11 @@ elab ist info pattern tcgen fn tm

373373 env <- get_env

374374 if (f `elem` map fst env && length args' == 1)

375375 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))

377377 (elabE (True, g) (getTm (head args')))

378378 (show tm)

379379 solve

380− else

380+ else

381381 do ivs <- get_instances

382382 ps <- get_probs

383383 -- HACK: we shouldn't resolve type classes if we're defining an instance

@@ -394,8 +394,8 @@ elab ist info pattern tcgen fn tm

394394 ptm <- get_term

395395 g <- goal

396396 -- Sort so that the implicit tactics go last

397− let (ns', eargs) = unzip $

398− sortBy (\(_,x) (_,y) ->

397+ let (ns', eargs) = unzip $

398+ sortBy (\(_,x) (_,y) ->

399399 compare (priority x) (priority y))

400400 (zip ns args)

401401 elabArgs (ina || not isinf, guarded)

@@ -416,7 +416,7 @@ elab ist info pattern tcgen fn tm

416416 -- let insts = filter tcname $ map fst (ctxtAlist (tt_ctxt ist))

417417 then try (resolveTC 7 fn ist)

418418 (movelast n)

419− else movelast n)

419+ else movelast n)

420420 (ivs' \\ ivs)

421421 where tcArg (n, PConstraint _ _ Placeholder _) = True

422422 tcArg _ = False

@@ -430,7 +430,7 @@ elab ist info pattern tcgen fn tm

430430 setInjective _ = return ()

431431

432432 elab' ina@(_, a) tm@(PApp fc f [arg])

433− = erun fc $

433+ = erun fc $

434434 do simple_app (elabE ina f) (elabE (True, a) (getTm arg))

435435 (show tm)

436436 solve

@@ -443,18 +443,18 @@ elab ist info pattern tcgen fn tm

443443 Just xs@(_:_) -> NS n xs

444444 _ -> n

445445 elab' ina (PProof ts) = do compute; mapM_ (runTac True ist) ts

446− elab' ina (PTactics ts)

446+ elab' ina (PTactics ts)

447447 | not pattern = do mapM_ (runTac False ist) ts

448448 | otherwise = elab' ina Placeholder

449449 elab' ina (PElabError e) = fail (pshow ist e)

450− elab' ina (PRewrite fc r sc newg)

450+ elab' ina (PRewrite fc r sc newg)

451451 = do attack

452452 tyn <- unique_hole (MN 0 "rty")

453453 claim tyn RType

454454 valn <- unique_hole (MN 0 "rval")

455455 claim valn (Var tyn)

456456 letn <- unique_hole (MN 0 "rewrite_rule")

457− letbind letn (Var tyn) (Var valn)

457+ letbind letn (Var tyn) (Var valn)

458458 focus valn

459459 elab' ina r

460460 compute

@@ -494,7 +494,7 @@ elab ist info pattern tcgen fn tm

494494 cname <- unique_hole' True (mkCaseName fn)

495495 let cname' = mkN cname

496496 elab' ina (PMetavar cname')

497− let newdef = PClauses fc [] cname'

497+ let newdef = PClauses fc [] cname'

498498 (caseBlock fc cname' (reverse args) opts)

499499 -- elaborate case

500500 env <- get_env

@@ -506,7 +506,7 @@ elab ist info pattern tcgen fn tm

506506 mkCaseName n = SN (CaseN n)

507507-- mkCaseName (UN x) = UN (x ++ "_case")

508508-- mkCaseName (MN i x) = MN i (x ++ "_case")

509−-- mkCaseName (SN s) =

509+-- mkCaseName (SN s) =

510510 mkN n@(NS _ _) = n

511511 mkN n = case namespace info of

512512 Just xs@(_:_) -> NS n xs

@@ -516,16 +516,16 @@ elab ist info pattern tcgen fn tm

516516 unifyLog False

517517 elab' ina x = fail $ "Unelaboratable syntactic form " ++ show x

518518

519− caseBlock :: FC -> Name -> [(Name, Binder Term)] ->

519+ caseBlock :: FC -> Name -> [(Name, Binder Term)] ->

520520 [(PTerm, PTerm)] -> [PClause]

521− caseBlock fc n env opts

521+ caseBlock fc n env opts

522522 = let args = map mkarg (map fst (init env)) in

523523 map (mkClause args) opts

524524 where -- mkarg (MN _ _) = Placeholder

525525 mkarg n = PRef fc n

526526 -- may be shadowed names in the new pattern - so replace the

527527 -- old ones with an _

528− mkClause args (l, r)

528+ mkClause args (l, r)

529529 = let args' = map (shadowed (allNamesIn l)) args

530530 lhs = PApp (getFC fc l) (PRef (getFC fc l) n)

531531 (map pexp args' ++ [pexp l]) in

@@ -552,7 +552,7 @@ elab ist info pattern tcgen fn tm

552552 (_, cs) -> PAlternative False [t ,

553553 PAlternative True (map (mkCoerce t) cs)]

554554 return t'

555− where

555+ where

556556 mkCoerce t n = let fc = fileFC "Coercion" in -- line never appears!

557557 addImpl ist (PApp fc (PRef fc n) [pexp (PCoerced t)])

558558

@@ -560,18 +560,18 @@ elab ist info pattern tcgen fn tm

560560-- | retry = let (ns, ts) = unzip (reverse failed) in

561561-- elabArgs ina [] False ns ts

562562 | otherwise = return ()

563− elabArgs ina failed fc r (n:ns) ((_, Placeholder) : args)

563+ elabArgs ina failed fc r (n:ns) ((_, Placeholder) : args)

564564 = elabArgs ina failed fc r ns args

565565 elabArgs ina failed fc r (n:ns) ((lazy, t) : args)

566566 | lazy && not pattern

567567 = do elabArg n (PApp bi (PRef bi (UN "lazy"))

568568 [pimp (UN "a") Placeholder True,

569− pexp t]);

569+ pexp t]);

570570 | otherwise = elabArg n t

571− where elabArg n t

571+ where elabArg n t

572572 = do hs <- get_holes

573573 tm <- get_term

574− failed' <- -- trace (show (n, t, hs, tm)) $

574+ failed' <- -- trace (show (n, t, hs, tm)) $

575575 -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $

576576 case n `elem` hs of

577577 True ->

@@ -588,7 +588,7 @@ elab ist info pattern tcgen fn tm

588588pruneAlt :: [PTerm] -> [PTerm]

589589pruneAlt xs = map prune xs

590590 where

591− prune (PApp fc1 (PRef fc2 f) as)

591+ prune (PApp fc1 (PRef fc2 f) as)

592592 = PApp fc1 (PRef fc2 f) (fmap (fmap (choose f)) as)

593593 prune t = t

594594

@@ -608,11 +608,11 @@ pruneAlt xs = map prune xs

608608-- Rule out alternatives that don't return the same type as the head of the goal

609609-- (If there are none left as a result, do nothing)

610610pruneByType :: Term -> Context -> [PTerm] -> [PTerm]

611−pruneByType (P _ n _) c as

611+pruneByType (P _ n _) c as

612612-- if the goal type is polymorphic, keep e

613613 | [] <- lookupTy n c = as

614− | otherwise

615− = let asV = filter (headIs True n) as

614+ | otherwise

615+ = let asV = filter (headIs True n) as

616616 as' = filter (headIs False n) as in

617617 case as' of

618618 [] -> case asV of

@@ -625,7 +625,7 @@ pruneByType (P _ n _) c as

625625 headIs var f (PPi _ _ _ sc) = headIs var f sc

626626 headIs _ _ _ = True -- keep if it's not an application

627627

628− typeHead var f f'

628+ typeHead var f f'

629629 = case lookupTy f' c of

630630 [ty] -> let ty' = normalise c [] ty in

631631 case unApply (getRetTy ty') of

@@ -637,27 +637,27 @@ pruneByType (P _ n _) c as

637637pruneByType t _ as = as

638638

639639findInstances :: IState -> Term -> [Name]

640−findInstances ist t

641− | (P _ n _, _) <- unApply t

640+findInstances ist t

641+ | (P _ n _, _) <- unApply t

642642 = case lookupCtxt n (idris_classes ist) of

643643 [CI _ _ _ _ ins] -> ins

644644 _ -> []

645645 | otherwise = []

646646

647−trivial' ist

647+trivial' ist

648648 = trivial (elab ist toplevel False False (MN 0 "tac")) ist

649649proofSearch' ist top n hints

650650 = proofSearch (elab ist toplevel False False (MN 0 "tac")) top n hints ist

651−

651+

652652

653653resolveTC :: Int -> Name -> IState -> ElabD ()

654654resolveTC 0 fn ist = fail $ "Can't resolve type class"

655655resolveTC 1 fn ist = try' (trivial' ist) (resolveTC 0 fn ist) True

656−resolveTC depth fn ist

656+resolveTC depth fn ist

657657 = do hnf_compute

658658 g <- goal

659659 ptm <- get_term

660− hs <- get_holes

660+ hs <- get_holes

661661 if True -- all (\n -> not (n `elem` hs)) (freeNames g)

662662 then try' (trivial' ist)

663663 (do t <- goal

@@ -703,17 +703,17 @@ resolveTC depth fn ist

703703 blunderbuss t d [] = do -- c <- get_env

704704 -- ps <- get_probs

705705 lift $ tfail $ CantResolve t

706− blunderbuss t d (n:ns)

706+ blunderbuss t d (n:ns)

707707 | n /= fn && tcname n = try' (resolve n d)

708708 (blunderbuss t d ns) True

709709 | otherwise = blunderbuss t d ns

710710

711711 resolve n depth

712712 | depth == 0 = fail $ "Can't resolve type class"

713− | otherwise

713+ | otherwise

714714 = do t <- goal

715715 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

717717-- else do

718718 -- if there's a hole in the goal, don't even try

719719 let imps = case lookupCtxtName n (idris_implicits ist) of

@@ -728,7 +728,7 @@ resolveTC depth fn ist

728728 t' <- goal

729729 let (tc', ttype) = unApply t'

730730 let depth' = if t == t' then depth - 1 else depth

731− resolveTC depth' fn ist)

731+ resolveTC depth' fn ist)

732732 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

733733 -- if there's any arguments left, we've failed to resolve

734734 hs <- get_holes

@@ -757,9 +757,9 @@ collectDeferred top t = return t

757757-- if a tactic adds unification problems, return an error

758758

759759runTac :: Bool -> IState -> PTactic -> ElabD ()

760−runTac autoSolve ist tac

760+runTac autoSolve ist tac

761761 = 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)

763763 where

764764 runT (Intro []) = do g <- goal

765765 attack; intro (bname g)

@@ -776,8 +776,8 @@ runTac autoSolve ist tac

776776 bname _ = Nothing

777777 runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm

778778 when autoSolve solveAll

779− runT (MatchRefine fn)

780− = do fnimps <-

779+ runT (MatchRefine fn)

780+ = do fnimps <-

781781 case lookupCtxtName fn (idris_implicits ist) of

782782 [] -> do a <- envArgs fn

783783 return [(fn, a)]

@@ -792,8 +792,8 @@ runTac autoSolve ist tac

792792 Just t -> return $ map (const False)

793793 (getArgTys (binderTy t))

794794 _ -> return []

795− runT (Refine fn [])

796− = do fnimps <-

795+ runT (Refine fn [])

796+ = do fnimps <-

797797 case lookupCtxtName fn (idris_implicits ist) of

798798 [] -> do a <- envArgs fn

799799 return [(fn, a)]

@@ -812,7 +812,7 @@ runTac autoSolve ist tac

812812 _ -> return []

813813 runT (Refine fn imps) = do ns <- apply (Var fn) (map (\x -> (x,0)) imps)

814814 when autoSolve solveAll

815− runT (Equiv tm) -- let bind tm, then

815+ runT (Equiv tm) -- let bind tm, then

816816 = do attack

817817 tyn <- unique_hole (MN 0 "ety")

818818 claim tyn RType

@@ -832,7 +832,7 @@ runTac autoSolve ist tac

832832 valn <- unique_hole (MN 0 "rval")

833833 claim valn (Var tyn)

834834 letn <- unique_hole (MN 0 "rewrite_rule")

835− letbind letn (Var tyn) (Var valn)

835+ letbind letn (Var tyn) (Var valn)

836836 focus valn

837837 elab ist toplevel False False (MN 0 "tac") tm

838838 rewrite (Var letn)

@@ -863,7 +863,7 @@ runTac autoSolve ist tac

863863 when autoSolve solveAll

864864 runT Compute = compute

865865 runT Trivial = do trivial' ist; when autoSolve solveAll

866− runT (ProofSearch top n hints)

866+ runT (ProofSearch top n hints)

867867 = do proofSearch' ist top n hints; when autoSolve solveAll

868868 runT (Focus n) = focus n

869869 runT Solve = solve

@@ -884,7 +884,7 @@ runTac autoSolve ist tac

884884 restac <- unique_hole (MN 0 "restac")

885885 claim restac tacticTy

886886 focus restac

887− fill (raw_apply (forget script')

887+ fill (raw_apply (forget script')

888888 [reflectEnv tenv, reflect tgoal])

889889 restac' <- get_guess

890890 solve

@@ -896,9 +896,9 @@ runTac autoSolve ist tac

896896 runReflected tactic

897897 where tacticTy = Var (reflm "Tactic")

898898 listTy = Var (NS (UN "List") ["List", "Prelude"])

899− scriptTy = (RBind (UN "__pi_arg")

899+ scriptTy = (RBind (UN "__pi_arg")

900900 (Pi (RApp listTy envTupleType))

901− (RBind (UN "__pi_arg1")

901+ (RBind (UN "__pi_arg1")

902902 (Pi (Var $ reflm "TT")) tacticTy))

903903

904904 runT (Reflect v) = do attack -- let x = reflect v in ...

@@ -932,7 +932,7 @@ runTac autoSolve ist tac

932932 runTac autoSolve ist (Exact $ PQuote rawValue)

933933 runT (GoalType n tac) = do g <- goal

934934 case unApply g of

935− (P _ n' _, _) ->

935+ (P _ n' _, _) ->

936936 if nsroot n' == UN n

937937 then runT tac

938938 else fail "Wrong goal type"

@@ -969,7 +969,7 @@ reifyApp ist t [Constant (Str n), x]

969969 | t == reflm "GoalType" = liftM (GoalType n) (reify ist x)

970970reifyApp _ t [Constant (Str n)]

971971 | t == reflm "Intro" = return $ Intro [UN n]

972−reifyApp ist t [t']

972+reifyApp ist t [t']

973973 | t == reflm "ApplyTactic" = liftM (ApplyTactic . delab ist) (reifyTT t')

974974reifyApp ist t [t']

975975 | t == reflm "Reflect" = liftM (Reflect . delab ist) (reifyTT t')

@@ -1071,9 +1071,9 @@ reifyTTNameApp t []

10711071reifyTTNameApp t args = fail ("Unknown reflection term name: " ++ show (t, args))

10721072

10731073reifyTTNamespace :: Term -> ElabD [String]

1074−reifyTTNamespace t@(App _ _)

1074+reifyTTNamespace t@(App _ _)

10751075 = case unApply t of

1076− (P _ f _, [Constant StrType])

1076+ (P _ f _, [Constant StrType])

10771077 | f == NS (UN "Nil") ["List", "Prelude"] -> return []

10781078 (P _ f _, [Constant StrType, Constant (Str n), ns])

10791079 | f == NS (UN "::") ["List", "Prelude"] -> liftM (n:) (reifyTTNamespace ns)

@@ -1094,7 +1094,7 @@ reifyTTNameType t = fail ("Unknown reflection name type: " ++ show t)

10941094reifyTTBinder :: (Term -> ElabD a) -> Name -> Term -> ElabD (Binder a)

10951095reifyTTBinder reificator binderType t@(App _ _)

10961096 = case unApply t of

1097− (P _ f _, bt:args) | forget bt == Var binderType

1097+ (P _ f _, bt:args) | forget bt == Var binderType

10981098 -> reifyTTBinderApp reificator f args

10991099 _ -> fail ("Mismatching binder reflection: " ++ show t)

11001100reifyTTBinder _ _ t = fail ("Unknown reflection binder: " ++ show t)

@@ -1168,14 +1168,14 @@ reifyTTUExp t = fail ("Unknown reflection type universe expression: " ++ show t)

11681168

11691169-- | Create a reflected call to a named function/constructor

11701170reflCall :: String -> [Raw] -> Raw

1171−reflCall funName args

1171+reflCall funName args

11721172 = raw_apply (Var (reflm funName)) args

11731173

11741174-- | Lift a term into its Language.Reflection.TT representation

11751175reflect :: Term -> Raw

1176−reflect (P nt n t)

1176+reflect (P nt n t)

11771177 = reflCall "P" [reflectNameType nt, reflectName n, reflect t]

1178−reflect (V n)

1178+reflect (V n)

11791179 = reflCall "V" [RConstant (I n)]

11801180reflect (Bind n b x)

11811181 = reflCall "Bind" [reflectName n, reflectBinder b, reflect x]

@@ -1192,24 +1192,24 @@ reflect (TType exp) = reflCall "TType" [reflectUExp exp]

11921192reflectNameType :: NameType -> Raw

11931193reflectNameType (Bound) = Var (reflm "Bound")

11941194reflectNameType (Ref) = Var (reflm "Ref")

1195−reflectNameType (DCon x y)

1195+reflectNameType (DCon x y)

11961196 = reflCall "DCon" [RConstant (I x), RConstant (I y)]

1197−reflectNameType (TCon x y)

1197+reflectNameType (TCon x y)

11981198 = reflCall "TCon" [RConstant (I x), RConstant (I y)]

11991199

12001200reflectName :: Name -> Raw

1201−reflectName (UN str)

1201+reflectName (UN str)

12021202 = reflCall "UN" [RConstant (Str str)]

12031203reflectName (NS n ns)

12041204 = reflCall "NS" [ reflectName n

1205− , foldr (\ n s ->

1205+ , foldr (\ n s ->

12061206 raw_apply ( Var $ NS (UN "::") ["List", "Prelude"] )

12071207 [ RConstant StrType, RConstant (Str n), s ])

12081208 ( raw_apply ( Var $ NS (UN "Nil") ["List", "Prelude"] )

12091209 [ RConstant StrType ])

1210− ns

1211− ]

1212−reflectName (MN i n)

1210+ ns

1211+ ]

1212+reflectName (MN i n)

12131213 = reflCall "MN" [RConstant (I i), RConstant (Str n)]

12141214reflectName (NErased) = Var (reflm "NErased")

12151215reflectName n = Var (reflm "NErased") -- special name, not yet implemented

@@ -1270,16 +1270,16 @@ reflectEnv = foldr consToEnvList emptyEnvList

12701270 = raw_apply (Var (NS (UN "::") ["List", "Prelude"]))

12711271 [ envTupleType

12721272 , raw_apply (Var pairCon) [ (Var $ reflm "TTName")

1273− , (RApp (Var $ reflm "Binder")

1273+ , (RApp (Var $ reflm "Binder")

12741274 (Var $ reflm "TT"))

1275− , reflectName n

1275+ , reflectName n

12761276 , reflectBinder b

12771277 ]

12781278 , l

12791279 ]

12801280

12811281 emptyEnvList :: Raw

1282− emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"]))

1282+ emptyEnvList = raw_apply (Var (NS (UN "Nil") ["List", "Prelude"]))

12831283 [envTupleType]

12841284

12851285-- | Reflect an error into the internal datatype of Idris -- TODO

@@ -1289,8 +1289,8 @@ reflectErr (InternalMsg msg) = raw_apply (Var (NS (UN "InternalMsg") ["Reflectio

12891289reflectErr x = trace ("Couldn't reflect error " ++ show x) raw_apply (Var (NS (UN "Msg") ["Reflection", "Language"])) [reflectConstant (Str $ show x)]

12901290

12911291envTupleType :: Raw

1292−envTupleType

1293− = raw_apply (Var pairTy) [ (Var $ reflm "TTName")

1292+envTupleType

1293+ = raw_apply (Var pairTy) [ (Var $ reflm "TTName")

12941294 , (RApp (Var $ reflm "Binder") (Var $ reflm "TT"))

12951295 ]

12961296

@@ -1322,7 +1322,7 @@ mkSpecDecl i n pargs tm'

13221322 let g' = g -- specialise ctxt env ntimes g

13231323 return tm'

13241324-- trace (show t ++ "\n" ++

1325−-- show ntimes ++ "\n" ++

1325+-- show ntimes ++ "\n" ++

13261326-- show (delab i g) ++ "\n" ++ show (delab i g')) $ return tm' -- TODO

13271327 else return tm'

13281328 where

@@ -1330,7 +1330,7 @@ mkSpecDecl i n pargs tm'

13301330 cg = idris_callgraph i

13311331

13321332 staticFnNames tm | (P _ f _, as) <- unApply tm

1333− = if not (isFnName f ctxt) then []

1333+ = if not (isFnName f ctxt) then []

13341334 else case lookupCtxt f cg of

13351335 [ns] -> f : f : [] --(ns \\ [f])

13361336 [] -> [f,f]

src/Idris/Error.hs+2−2

@@ -32,7 +32,7 @@ showErr e = getIState >>= return . flip pshow e

3232

3333report :: IOError -> String

3434report e

35− | isUserError e = ioeGetErrorString e

35+ | isUserError e = ioeGetErrorString e

3636 | otherwise = show e

3737

3838--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

5454tclift (Error err) = throwError err

5555

5656tctry :: TC a -> TC a -> Idris a

57−tctry tc1 tc2

57+tctry tc1 tc2

5858 = case tc1 of

5959 OK v -> return v

6060 Error err -> tclift tc2

src/Idris/IBC.hs+50−50

@@ -54,8 +54,8 @@ data IBCFile = IBCFile { ver :: Word8,

5454 ibc_lineapps :: [(FilePath, Int, PTerm)]

5555 }

5656 deriving Show

57−{-!

58−deriving instance Binary IBCFile

57+{-!

58+deriving instance Binary IBCFile

5959!-}

6060

6161initIBC :: IBCFile

@@ -67,13 +67,13 @@ loadIBC fp = do iLOG $ "Loading ibc " ++ fp

6767 process ibcf fp

6868

6969writeIBC :: FilePath -> FilePath -> Idris ()

70−writeIBC src f

70+writeIBC src f

7171 = do iLOG $ "Writing ibc " ++ show f

7272 i <- getIState

7373 case (Data.List.map fst (idris_metavars i)) \\ primDefs of

7474 (_:_) -> ifail "Can't write ibc when there are unsolved metavariables"

7575 [] -> return ()

76− ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

76+ ibcf <- mkIBC (ibc_write i) (initIBC { sourcefile = src })

7777 idrisCatch (do runIO $ createDirectoryIfMissing True (dropFileName f)

7878 runIO $ encodeFile f ibcf

7979 iLOG "Written")

@@ -88,25 +88,25 @@ mkIBC (i:is) f = do ist <- getIState

8888 mkIBC is f'

8989

9090ibc :: 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 }

9292ibc i (IBCImp n) f = case lookupCtxt n (idris_implicits i) of

9393 [v] -> return f { ibc_implicits = (n,v): ibc_implicits f }

9494 _ -> ifail "IBC write failed"

95−ibc i (IBCStatic n) f

95+ibc i (IBCStatic n) f

9696 = case lookupCtxt n (idris_statics i) of

9797 [v] -> return f { ibc_statics = (n,v): ibc_statics f }

9898 _ -> ifail "IBC write failed"

99−ibc i (IBCClass n) f

99+ibc i (IBCClass n) f

100100 = case lookupCtxt n (idris_classes i) of

101101 [v] -> return f { ibc_classes = (n,v): ibc_classes f }

102102 _ -> ifail "IBC write failed"

103−ibc i (IBCInstance int n ins) f

103+ibc i (IBCInstance int n ins) f

104104 = return f { ibc_instances = (int,n,ins): ibc_instances f }

105−ibc i (IBCDSL n) f

105+ibc i (IBCDSL n) f

106106 = case lookupCtxt n (idris_dsls i) of

107107 [v] -> return f { ibc_dsls = (n,v): ibc_dsls f }

108108 _ -> ifail "IBC write failed"

109−ibc i (IBCData n) f

109+ibc i (IBCData n) f

110110 = case lookupCtxt n (idris_datatypes i) of

111111 [v] -> return f { ibc_datatypes = (n,v): ibc_datatypes f }

112112 _ -> ifail "IBC write failed"

@@ -135,7 +135,7 @@ ibc i (IBCAccess n a) f = return f { ibc_access = (n,a) : ibc_access f }

135135ibc i (IBCFlags n a) f = return f { ibc_flags = (n,a) : ibc_flags f }

136136ibc i (IBCTotal n a) f = return f { ibc_total = (n,a) : ibc_total f }

137137ibc 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

139139 = return f { ibc_lineapps = (fp,l,t) : ibc_lineapps f }

140140

141141process :: IBCFile -> FilePath -> Idris ()

@@ -181,7 +181,7 @@ timestampOlder src ibc = do srct <- getModificationTime src

181181 else return ()

182182

183183pImports :: [FilePath] -> Idris ()

184−pImports fs

184+pImports fs

185185 = do mapM_ (\f -> do i <- getIState

186186 ibcsd <- valIBCSubDir i

187187 ids <- allImportDirs

@@ -189,18 +189,18 @@ pImports fs

189189 if (f `elem` imported i)

190190 then iLOG $ "Already read " ++ f

191191 else do putIState (i { imported = f : imported i })

192− case fp of

192+ case fp of

193193 LIDR fn -> do iLOG $ "Failed at " ++ fn

194194 ifail "Must be an ibc"

195195 IDR fn -> do iLOG $ "Failed at " ++ fn

196196 ifail "Must be an ibc"

197− IBC fn src -> loadIBC fn)

197+ IBC fn src -> loadIBC fn)

198198 fs

199199

200200pImps :: [(Name, [PArg])] -> Idris ()

201−pImps imps = mapM_ (\ (n, imp) ->

201+pImps imps = mapM_ (\ (n, imp) ->

202202 do i <- getIState

203− putIState (i { idris_implicits

203+ putIState (i { idris_implicits

204204 = addDef n imp (idris_implicits i) }))

205205 imps

206206

@@ -216,7 +216,7 @@ pStatics ss = mapM_ (\ (n, s) ->

216216 ss

217217

218218pClasses :: [(Name, ClassInfo)] -> Idris ()

219−pClasses cs = mapM_ (\ (n, c) ->

219+pClasses cs = mapM_ (\ (n, c) ->

220220 do i <- getIState

221221 -- Don't lose instances from previous IBCs, which

222222 -- could have loaded in any order

@@ -283,11 +283,11 @@ pHdrs :: [(Codegen, String)] -> Idris ()

283283pHdrs hs = mapM_ (uncurry addHdr) hs

284284

285285pDefs :: [(Name, Def)] -> Idris ()

286−pDefs ds = mapM_ (\ (n, d) ->

286+pDefs ds = mapM_ (\ (n, d) ->

287287 do i <- getIState

288288 logLvl 5 $ "Added " ++ show (n, d)

289289 putIState (i { tt_ctxt = addCtxtDef n d (tt_ctxt i) }))

290− ds

290+ ds

291291

292292pDocs :: [(Name, String)] -> Idris ()

293293pDocs ds = mapM_ (\ (n, a) -> addDocStr n a) ds

@@ -363,7 +363,7 @@ instance Binary FC where

363363 x3 <- get

364364 return (FC x1 x2 x3)

365365

366−

366+

367367instance Binary Name where

368368 put x

369369 = case x of

@@ -508,7 +508,7 @@ instance Binary Const where

508508

509509 _ -> error "Corrupted binary data for Const"

510510

511−

511+

512512instance Binary Raw where

513513 put x

514514 = case x of

@@ -545,7 +545,7 @@ instance Binary Raw where

545545 return (RForce x1)

546546 _ -> error "Corrupted binary data for Raw"

547547

548−

548+

549549instance (Binary b) => Binary (Binder b) where

550550 put x

551551 = case x of

@@ -598,7 +598,7 @@ instance (Binary b) => Binary (Binder b) where

598598 return (PVTy x1)

599599 _ -> error "Corrupted binary data for Binder"

600600

601−

601+

602602instance Binary NameType where

603603 put x

604604 = case x of

@@ -626,7 +626,7 @@ instance Binary NameType where

626626

627627instance {-(Binary n) =>-} Binary (TT Name) where

628628 put x

629− = {-# SCC "putTT" #-}

629+ = {-# SCC "putTT" #-}

630630 case x of

631631 P x1 x2 x3 -> do putWord8 0

632632 put x1

@@ -705,12 +705,12 @@ instance Binary SC where

705705 3 -> do x1 <- get

706706 return (UnmatchedCase x1)

707707 4 -> return ImpossibleCase

708− _ -> error "Corrupted binary data for SC"

708+ _ -> error "Corrupted binary data for SC"

709+

709710

710−

711711instance Binary CaseAlt where

712712 put x

713− = {-# SCC "putCaseAlt" #-}

713+ = {-# SCC "putCaseAlt" #-}

714714 case x of

715715 ConCase x1 x2 x3 x4 -> do putWord8 0

716716 put x1

@@ -769,10 +769,10 @@ instance Binary CaseInfo where

769769 get = do x1 <- get

770770 x2 <- get

771771 return (CaseInfo x1 x2)

772−

772+

773773instance Binary Def where

774774 put x

775− = {-# SCC "putDef" #-}

775+ = {-# SCC "putDef" #-}

776776 case x of

777777 Function x1 x2 -> do putWord8 0

778778 put x1

@@ -871,7 +871,7 @@ instance Binary Totality where

871871

872872instance Binary IBCFile where

873873 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" #-}

875875 do put x1

876876 put x2

877877 put x3

@@ -901,7 +901,7 @@ instance Binary IBCFile where

901901 put x27

902902 get

903903 = do x1 <- get

904− if x1 == ibcVersion then

904+ if x1 == ibcVersion then

905905 do x2 <- get

906906 x3 <- get

907907 x4 <- get

@@ -930,7 +930,7 @@ instance Binary IBCFile where

930930 x27 <- get

931931 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)

932932 else return (initIBC { ver = x1 })

933−

933+

934934instance Binary FnOpt where

935935 put x

936936 = case x of

@@ -983,7 +983,7 @@ instance Binary Fixity where

983983 return (PrefixN x1)

984984 _ -> error "Corrupted binary data for Fixity"

985985

986−

986+

987987instance Binary FixDecl where

988988 put (Fix x1 x2)

989989 = do put x1

@@ -993,7 +993,7 @@ instance Binary FixDecl where

993993 x2 <- get

994994 return (Fix x1 x2)

995995

996−

996+

997997instance Binary Static where

998998 put x

999999 = case x of

@@ -1006,28 +1006,28 @@ instance Binary Static where

10061006 1 -> return Dynamic

10071007 _ -> error "Corrupted binary data for Static"

10081008

1009−

1009+

10101010instance Binary Plicity where

10111011 put x

10121012 = case x of

1013− Imp x1 x2 x3 x4 ->

1013+ Imp x1 x2 x3 x4 ->

10141014 do putWord8 0

10151015 put x1

10161016 put x2

10171017 put x3

10181018 put x4

1019− Exp x1 x2 x3 x4 ->

1019+ Exp x1 x2 x3 x4 ->

10201020 do putWord8 1

10211021 put x1

10221022 put x2

10231023 put x3

10241024 put x4

1025− Constraint x1 x2 x3 ->

1025+ Constraint x1 x2 x3 ->

10261026 do putWord8 2

10271027 put x1

10281028 put x2

10291029 put x3

1030− TacImp x1 x2 x3 x4 ->

1030+ TacImp x1 x2 x3 x4 ->

10311031 do putWord8 3

10321032 put x1

10331033 put x2

@@ -1057,7 +1057,7 @@ instance Binary Plicity where

10571057 return (TacImp x1 x2 x3 x4)

10581058 _ -> error "Corrupted binary data for Plicity"

10591059

1060−

1060+

10611061instance (Binary t) => Binary (PDecl' t) where

10621062 put x

10631063 = case x of

@@ -1078,7 +1078,7 @@ instance (Binary t) => Binary (PDecl' t) where

10781078 put x2

10791079 put x3

10801080 put x4

1081− PData x1 x2 x3 x4 x5 ->

1081+ PData x1 x2 x3 x4 x5 ->

10821082 do putWord8 3

10831083 put x1

10841084 put x2

@@ -1092,7 +1092,7 @@ instance (Binary t) => Binary (PDecl' t) where

10921092 PNamespace x1 x2 -> do putWord8 5

10931093 put x1

10941094 put x2

1095− PRecord x1 x2 x3 x4 x5 x6 x7 x8 ->

1095+ PRecord x1 x2 x3 x4 x5 x6 x7 x8 ->

10961096 do putWord8 6

10971097 put x1

10981098 put x2

@@ -1575,7 +1575,7 @@ instance (Binary t) => Binary (PTactic' t) where

15751575 Reflect x1 -> do putWord8 17

15761576 put x1

15771577 Fill x1 -> do putWord8 18

1578− put x1

1578+ put x1

15791579 get

15801580 = do i <- getWord8

15811581 case i of

@@ -1668,7 +1668,7 @@ instance (Binary t) => Binary (PDo' t) where

16681668instance (Binary t) => Binary (PArg' t) where

16691669 put x

16701670 = case x of

1671− PImp x1 x2 x3 x4 x5 x6 ->

1671+ PImp x1 x2 x3 x4 x5 x6 ->

16721672 do putWord8 0

16731673 put x1

16741674 put x2

@@ -1676,19 +1676,19 @@ instance (Binary t) => Binary (PArg' t) where

16761676 put x4

16771677 put x5

16781678 put x6

1679− PExp x1 x2 x3 x4 ->

1679+ PExp x1 x2 x3 x4 ->

16801680 do putWord8 1

16811681 put x1

16821682 put x2

16831683 put x3

16841684 put x4

1685− PConstraint x1 x2 x3 x4 ->

1685+ PConstraint x1 x2 x3 x4 ->

16861686 do putWord8 2

16871687 put x1

16881688 put x2

16891689 put x3

16901690 put x4

1691− PTacImplicit x1 x2 x3 x4 x5 x6 ->

1691+ PTacImplicit x1 x2 x3 x4 x5 x6 ->

16921692 do putWord8 3

16931693 put x1

16941694 put x2

@@ -1725,7 +1725,7 @@ instance (Binary t) => Binary (PArg' t) where

17251725 return (PTacImplicit x1 x2 x3 x4 x5 x6)

17261726 _ -> error "Corrupted binary data for PArg'"

17271727

1728−

1728+

17291729instance Binary ClassInfo where

17301730 put (CI x1 x2 x3 x4 _)

17311731 = do put x1

@@ -1775,7 +1775,7 @@ instance Binary SynContext where

17751775 2 -> return AnySyntax

17761776 _ -> error "Corrupted binary data for SynContext"

17771777

1778−

1778+

17791779instance Binary Syntax where

17801780 put (Rule x1 x2 x3)

17811781 = do put x1

@@ -1809,7 +1809,7 @@ instance (Binary t) => Binary (DSL' t) where

18091809 x8 <- get

18101810 x9 <- get

18111811 return (DSL x1 x2 x3 x4 x5 x6 x7 x8 x9)

1812−

1812+

18131813instance Binary SSymbol where

18141814 put x

18151815 = case x of

src/Idris/Imports.hs+2−2

@@ -9,7 +9,7 @@ import System.FilePath

99import System.Directory

1010import Control.Monad.State

1111

12−data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType

12+data IFileType = IDR FilePath | LIDR FilePath | IBC FilePath IFileType

1313 deriving (Show, Eq)

1414

1515srcPath :: FilePath -> FilePath

@@ -60,7 +60,7 @@ findImport (d:ds) ibcsd fp = do let fp_full = d </> fp

6060 else IDR idrp

6161 if ibc

6262 then return (IBC ibcp isrc)

63− else if (idr || lidr)

63+ else if (idr || lidr)

6464 then return isrc

6565 else findImport ds ibcsd fp

6666

src/Idris/Inliner.hs+2−2

@@ -15,13 +15,13 @@ inlineDef ist ds = map (\ (ns, lhs, rhs) -> (ns, lhs, inlineTerm ist rhs)) ds

1515-- (Dictionaries are inlinable in an argument, not otherwise)

1616-- - If so, try inlining without reducing its arguments

1717-- + 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

1919-- - If not, inline all the arguments (top level)

2020

2121inlineTerm :: IState -> Term -> Term

2222inlineTerm ist tm = inl tm where

2323 inl orig@(P _ n _) = inlApp n [] orig

24− inl orig@(App f a)

24+ inl orig@(App f a)

2525 | (P _ fn _, args) <- unApply orig = inlApp fn args orig

2626 inl (Bind n (Let t v) sc) = Bind n (Let t (inl v)) (inl sc)

2727 inl (Bind n b sc) = Bind n b (inl sc)

src/Idris/ParseData.hs+1−1

@@ -38,7 +38,7 @@ Record ::=

3838 DocComment Accessibility? 'record' FnName TypeSig 'where' OpenBlock Constructor KeepTerminator CloseBlock;

3939-}

4040record :: SyntaxInfo -> IdrisParser PDecl

41−record syn = do (doc, acc) <- try (do

41+record syn = do (doc, acc) <- try (do

4242 doc <- option "" (docComment '|')

4343 acc <- optional accessibility

4444 reserved "record"

src/Idris/ParseExpr.hs+1−1

@@ -313,7 +313,7 @@ bracketed syn =

313313 <|>

314314 try (do l <- expr syn

315315 lchar ')'

316− return l)

316+ return l)

317317 <|> do (l, fc) <- try (do

318318 l <- expr syn

319319 fc <- getFC

src/Idris/ParseHelpers.hs+2−2

@@ -487,9 +487,9 @@ collect (c@(PClauses _ o _ _) : ds)

487487collect (PParams f ns ps : ds) = PParams f ns (collect ps) : collect ds

488488collect (PMutual f ms : ds) = PMutual f (collect ms) : collect ds

489489collect (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')

491491 = 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')

493493 = PInstance f s cs n ps t en (collect ds) : collect ds'

494494collect (d : ds) = d : collect ds

495495collect [] = []

src/Idris/Parser.hs+4−4

@@ -1,5 +1,5 @@

11{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, PatternGuards #-}

2−module Idris.Parser(module Idris.Parser,

2+module Idris.Parser(module Idris.Parser,

33 module Idris.ParseExpr,

44 module Idris.ParseData,

55 module Idris.ParseHelpers,

@@ -262,7 +262,7 @@ fnDecl syn

262262 ;

263263-}

264264fnDecl' :: 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

266266 doc <- option "" (docComment '|')

267267 pushIndent

268268 ist <- get

@@ -443,7 +443,7 @@ Class ::=

443443 ;

444444-}

445445class_ :: SyntaxInfo -> IdrisParser [PDecl]

446−class_ syn = do (doc, acc) <- try (do

446+class_ syn = do (doc, acc) <- try (do

447447 doc <- option "" (docComment '|')

448448 acc <- optional accessibility

449449 return (doc, acc))

@@ -645,7 +645,7 @@ clause syn

645645 ist <- get

646646 put (ist { lastParse = Just n })

647647 return $ PClause fc n capp [] r wheres

648− <|> do (l, op) <- try (do

648+ <|> do (l, op) <- try (do

649649 pushIndent

650650 l <- argExpr syn

651651 op <- operator

src/Idris/PartialEval.hs+1−1

@@ -7,7 +7,7 @@ import Core.Evaluate

77

88import Debug.Trace

99

10−partial_eval :: Context -> [(Name, Maybe Int)] ->

10+partial_eval :: Context -> [(Name, Maybe Int)] ->

1111 [Either Term (Term, Term)] ->

1212 [Either Term (Term, Term)]

1313partial_eval ctxt ns tms = map peClause tms where

src/Idris/Primitives.hs+2−2

@@ -131,7 +131,7 @@ primitives =

131131 (1, LFloatStr) total,

132132

133133 Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)

134− (1, LFExp) total,

134+ (1, LFExp) total,

135135 Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)

136136 (1, LFLog) total,

137137 Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)

@@ -191,7 +191,7 @@ intSCmps ity =

191191

192192intCmps :: IntTy -> [Prim]

193193intCmps ITNative = intSCmps ITNative

194−intCmps ity =

194+intCmps ity =

195195 intSCmps ity ++

196196 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total

197197 , 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)

2424 return ()) True

2525 where

2626 tryAll [] = fail "No trivial solution"

27− tryAll ((x, b):xs)

27+ tryAll ((x, b):xs)

2828 = do -- if type of x has any holes in it, move on

2929 hs <- get_holes

3030 g <- goal

@@ -35,10 +35,10 @@ trivial elab ist = try' (do elab (PRefl (fileFC "prf") Placeholder)

3535

3636proofSearch :: (PTerm -> ElabD ()) -> Maybe Name -> Name -> [Name] ->

3737 IState -> ElabD ()

38−proofSearch elab fn nroot hints ist = psRec maxDepth

38+proofSearch elab fn nroot hints ist = psRec maxDepth

3939 where

4040 maxDepth = 6

41−

41+

4242 psRec 0 = do attack; defer nroot; solve --fail "Maximum depth reached"

4343 psRec d = try' (trivial elab ist)

4444 (try' (try' (resolveByCon (d - 1)) (resolveByLocals (d - 1))

@@ -50,7 +50,7 @@ proofSearch elab fn nroot hints ist = psRec maxDepth

5050 getFn d (Just f) | d < maxDepth-1 = [f]

5151 | otherwise = []

5252

53− resolveByCon d

53+ resolveByCon d

5454 = do t <- goal

5555 let (f, _) = unApply t

5656 case f of

@@ -71,7 +71,7 @@ proofSearch elab fn nroot hints ist = psRec maxDepth

7171

7272 tryCons d [] = fail "Constructors failed"

7373 tryCons d (c : cs) = try' (tryCon d c) (tryCons d cs) True

74−

74+

7575 tryLocal d n t = do let a = getPArity (delab ist (binderTy t))

7676 tryLocalArg d n a

7777

@@ -80,7 +80,7 @@ proofSearch elab fn nroot hints ist = psRec maxDepth

8080 (psRec d) "proof search local apply"

8181

8282 -- Like type class resolution, but searching with constructors

83− tryCon d n =

83+ tryCon d n =

8484 do let imps = case lookupCtxtName n (idris_implicits ist) of

8585 [] -> []

8686 [args] -> map isImp (snd args)

@@ -93,7 +93,7 @@ proofSearch elab fn nroot hints ist = psRec maxDepth

9393 psRec d)

9494 (filter (\ (x, y) -> not x) (zip (map fst imps) args))

9595 solve

96−

96+

9797 isImp (PImp p _ _ _ _ _) = (True, p)

9898 isImp arg = (False, priority arg)

9999

src/Idris/Prover.hs+2−2

@@ -36,7 +36,7 @@ prover lit x =

3636 _ -> fail "No such metavariable"

3737

3838showProof :: Bool -> Name -> [String] -> String

39−showProof lit n ps

39+showProof lit n ps

4040 = bird ++ show n ++ " = proof" ++ break ++

4141 showSep break (map (\x -> " " ++ x) ps) ++

4242 break ++ "\n"

@@ -105,7 +105,7 @@ dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _ _) = d

105105 prettyPs ((n, Let t v) : bs) =

106106 nest nestingSize (pretty n <+> text "=" <+> tPretty v <> colon <+>

107107 tPretty t $$ prettyPs bs)

108− prettyPs ((n, b) : bs) =

108+ prettyPs ((n, b) : bs) =

109109 pretty n <+> colon <+> tPretty (binderTy b) $$ prettyPs bs

110110

111111 prettyG (Guess t v) = tPretty t <+> text "=?=" <+> tPretty v

src/Idris/REPL.hs+55−55

@@ -100,7 +100,7 @@ repl orig stvar mods

100100 Just mods -> repl orig stvar mods

101101 Nothing -> return ())

102102 ctrlC)

103− ctrlC

103+ ctrlC

104104 where ctrlC :: SomeException -> InputT Idris ()

105105 ctrlC e = do lift $ iputStrLn (show e)

106106 repl orig stvar mods

@@ -111,7 +111,7 @@ startServer orig stvar fn_in = do tid <- runIO $ forkOS serverLoop

111111 return ()

112112 where serverLoop :: IO ()

113113 -- TODO: option for port number

114− serverLoop = withSocketsDo $

114+ serverLoop = withSocketsDo $

115115 do sock <- listenOnLocalhost $ PortNumber 4294

116116 i <- readMVar stvar

117117 loop fn i sock

@@ -120,12 +120,12 @@ startServer orig stvar fn_in = do tid <- runIO $ forkOS serverLoop

120120 (f:_) -> f

121121 _ -> ""

122122

123− loop fn ist sock

123+ loop fn ist sock

124124 = do (h,host,_) <- accept sock

125125 -- just use the local part of the hostname

126126 -- for the "localhost.localdomain" case

127127 if ((takeWhile (/= '.') host) == "localhost" ||

128− host == "127.0.0.1")

128+ host == "127.0.0.1")

129129 then do

130130 cmd <- hGetLine h

131131 takeMVar stvar

@@ -135,10 +135,10 @@ startServer orig stvar fn_in = do tid <- runIO $ forkOS serverLoop

135135 loop fn ist' sock

136136 else hClose h

137137

138−processNetCmd :: MVar IState ->

139− IState -> IState -> Handle -> FilePath -> String ->

138+processNetCmd :: MVar IState ->

139+ IState -> IState -> Handle -> FilePath -> String ->

140140 IO (IState, FilePath)

141−processNetCmd stvar orig i h fn cmd

141+processNetCmd stvar orig i h fn cmd

142142 = do res <- case parseCmd i "(net)" cmd of

143143 Failure err -> return (Left (Msg " invalid command"))

144144 Success c -> runErrorT $ evalStateT (processNet fn c) i

@@ -146,7 +146,7 @@ processNetCmd stvar orig i h fn cmd

146146 Right x -> return x

147147 Left err -> do hPutStrLn h (show err)

148148 return (i, fn)

149− where

149+ where

150150 processNet fn Reload = processNet fn (Load fn)

151151 processNet fn (Load f) =

152152 do let ist = orig { idris_options = idris_options i

@@ -164,7 +164,7 @@ processNetCmd stvar orig i h fn cmd

164164 processNet fn c = do process h fn c

165165 ist <- getIState

166166 return (ist, fn)

167−

167+

168168-- | Run a command on the server on localhost

169169runClient :: String -> IO ()

170170runClient str = withSocketsDo $ do

@@ -294,7 +294,7 @@ lit f = case splitExtension f of

294294 (_, ".lidr") -> True

295295 _ -> False

296296

297−processInput :: MVar IState -> String ->

297+processInput :: MVar IState -> String ->

298298 IState -> [FilePath] -> Idris (Maybe [FilePath])

299299processInput stvar cmd orig inputs

300300 = do i <- getIState

@@ -321,7 +321,7 @@ processInput stvar cmd orig inputs

321321 clearErr

322322 mod <- loadModule stdout f

323323 return (Just [f])

324− Success (ModImport f) ->

324+ Success (ModImport f) ->

325325 do clearErr

326326 fmod <- loadModule stdout f

327327 return (Just (inputs ++ [fmod]))

@@ -429,7 +429,7 @@ process h fn (Check (PRef _ n))

429429 imp <- impShow

430430 c <- colourise

431431 case lookupNames n ctxt of

432− ts@(t:_) ->

432+ ts@(t:_) ->

433433 case lookup t (idris_metavars ist) of

434434 Just (_, i) -> showMetavarInfo c imp ist n i

435435 Nothing -> do mapM_ (\n -> ihputStrLn h $ showName (Just ist) [] False c n ++ " : " ++

@@ -437,22 +437,22 @@ process h fn (Check (PRef _ n))

437437 ihPrintResult h ""

438438 [] -> ihPrintError h $ "No such variable " ++ show n

439439 where

440− showMetavarInfo c imp ist n i

440+ showMetavarInfo c imp ist n i

441441 = case lookupTy n (tt_ctxt ist) of

442442 (ty:_) -> putTy c imp ist i (delab ist ty)

443443 putTy c imp ist 0 sc = putGoal c imp ist sc

444− putTy c imp ist i (PPi _ n t sc)

445− = do ihputStrLn h $ " " ++

444+ putTy c imp ist i (PPi _ n t sc)

445+ = do ihputStrLn h $ " " ++

446446 (case n of

447447 MN _ _ -> "_"

448448 UN ('_':'_':_) -> "_"

449− _ -> showName (Just ist) [] False c n) ++

449+ _ -> showName (Just ist) [] False c n) ++

450450 " : " ++ showImp (Just ist) imp c t

451451 putTy c imp ist (i-1) sc

452452 putTy c imp ist _ sc = putGoal c imp ist sc

453453 putGoal c imp ist g

454454 = do ihputStrLn h $ "--------------------------------------"

455− ihputStrLn h $ showName (Just ist) [] False c n ++ " : "

455+ ihputStrLn h $ showName (Just ist) [] False c n ++ " : "

456456 ++ showImp (Just ist) imp c g

457457

458458

@@ -468,7 +468,7 @@ process h fn (Check t)

468468 _ -> ihPrintResult h (showImp (Just ist) imp c (delab ist tm) ++ " : " ++

469469 showImp (Just ist) imp c (delab ist ty))

470470

471−process h fn (DocStr n)

471+process h fn (DocStr n)

472472 = do i <- getIState

473473 case lookupCtxtName n (idris_docstrings i) of

474474 [] -> iPrintError $ "No documentation for " ++ show n

@@ -477,7 +477,7 @@ process h fn (DocStr n)

477477 where showDoc (n, d)

478478 = do doc <- getDocs n

479479 iputStrLn $ show doc

480−process h fn Universes

480+process h fn Universes

481481 = do i <- getIState

482482 let cs = idris_constraints i

483483-- iputStrLn $ showSep "\n" (map show cs)

@@ -487,7 +487,7 @@ process h fn Universes

487487 case ucheck cs of

488488 Error e -> iPrintError $ pshow i e

489489 OK _ -> iPrintResult "Universes OK"

490−process h fn (Defn n)

490+process h fn (Defn n)

491491 = do i <- getIState

492492 iputStrLn "Compiled patterns:\n"

493493 iputStrLn $ show (lookupDef n (tt_ctxt i))

@@ -502,7 +502,7 @@ process h fn (Defn n)

502502 = do c <- colourise

503503 iputStrLn (showImp (Just i) True c (delab i lhs) ++ " = " ++

504504 showImp (Just i) True c (delab i rhs))

505−process h fn (TotCheck n)

505+process h fn (TotCheck n)

506506 = do i <- getIState

507507 case lookupTotal n (tt_ctxt i) of

508508 [t] -> iPrintResult (showTotal t i)

@@ -538,10 +538,10 @@ process h fn (CaseSplit n t)

538538-- FIXME: There is far too much repetition in the cases below!

539539process h fn (CaseSplitAt updatefile l n)

540540 = do src <- runIO $ readFile fn

541− res <- splitOnLine l n fn

541+ res <- splitOnLine l n fn

542542 iLOG (showSep "\n" (map show res))

543543 let (before, (ap : later)) = splitAt (l-1) (lines src)

544− res' <- replaceSplits ap res

544+ res' <- replaceSplits ap res

545545 let new = concat res'

546546 if updatefile then

547547 do let fb = fn ++ "~" -- make a backup!

@@ -558,7 +558,7 @@ process h fn (AddClauseFrom updatefile l n)

558558 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

559559 if updatefile then

560560 do let fb = fn ++ "~"

561− runIO $ writeFile fb (unlines (before ++ nonblank)

561+ runIO $ writeFile fb (unlines (before ++ nonblank)

562562 ++ replicate indent ' ' ++

563563 cl ++ "\n" ++

564564 unlines rest)

@@ -577,7 +577,7 @@ process h fn (AddProofClauseFrom updatefile l n)

577577 let (nonblank, rest) = span (not . all isSpace) (tyline:later)

578578 if updatefile then

579579 do let fb = fn ++ "~"

580− runIO $ writeFile fb (unlines (before ++ nonblank)

580+ runIO $ writeFile fb (unlines (before ++ nonblank)

581581 ++ replicate indent ' ' ++

582582 cl ++ "\n" ++

583583 unlines rest)

@@ -604,7 +604,7 @@ process h fn (AddMissing updatefile l n)

604604 runIO $ copyFile fb fn

605605 else ihputStrLn h extras

606606 where showPat = show . stripNS

607− stripNS tm = mapPT dens tm where

607+ stripNS tm = mapPT dens tm where

608608 dens (PRef fc n) = PRef fc (nsroot n)

609609 dens t = t

610610

@@ -616,7 +616,7 @@ process h fn (AddMissing updatefile l n)

616616 getAppName (PRef _ r) = r

617617 getAppName _ = n

618618

619− showNew nm i (tm : tms)

619+ showNew nm i (tm : tms)

620620 = do (nm', i') <- getUniq nm i

621621 rest <- showNew nm i' tms

622622 return (showPat tm ++ " = ?" ++ nm' ++

@@ -631,7 +631,7 @@ process h fn (MakeWith updatefile l n)

631631 let (nonblank, rest) = span (not . all isSpace) later

632632 if updatefile then

633633 do let fb = fn ++ "~"

634− runIO $ writeFile fb (unlines (before ++ nonblank)

634+ runIO $ writeFile fb (unlines (before ++ nonblank)

635635 ++ with ++ "\n" ++

636636 unlines rest)

637637 runIO $ copyFile fb fn

@@ -649,7 +649,7 @@ process h fn (DoProofSearch updatefile l n hints)

649649 Just mi -> mi

650650 _ -> (Nothing, 0)

651651 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))

653653 (ProofSearch t n hints)]

654654 let def = PClause fc mn (PRef fc mn) [] (body top) []

655655 newmv <- idrisCatch

@@ -658,12 +658,12 @@ process h fn (DoProofSearch updatefile l n hints)

658658 ctxt <- getContext

659659 i <- getIState

660660 return $ show (stripNS

661− (dropCtxt envlen

661+ (dropCtxt envlen

662662 (delab i (specialise ctxt [] [(mn, 1)] tm)))))

663663 (\e -> return ("?" ++ show n))

664664 if updatefile then

665665 do let fb = fn ++ "~"

666− runIO $ writeFile fb (unlines before ++

666+ runIO $ writeFile fb (unlines before ++

667667 updateMeta tyline (show n) newmv ++ "\n"

668668 ++ unlines later)

669669 runIO $ copyFile fb fn

@@ -673,8 +673,8 @@ process h fn (DoProofSearch updatefile l n hints)

673673 dropCtxt i (PLet _ _ _ sc) = dropCtxt (i - 1) sc

674674 dropCtxt i (PLam _ _ sc) = dropCtxt (i - 1) sc

675675 dropCtxt _ t = t

676−

677− stripNS tm = mapPT dens tm where

676+

677+ stripNS tm = mapPT dens tm where

678678 dens (PRef fc n) = PRef fc (nsroot n)

679679 dens t = t

680680

@@ -689,7 +689,7 @@ process h fn (DoProofSearch updatefile l n hints)

689689 if (isSpace c && mv == n)

690690 then new ++ (c : cs)

691691 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

693693 updateMeta (c:cs) n new = c : updateMeta cs n new

694694 updateMeta [] n new = ""

695695

@@ -767,13 +767,13 @@ process h fn (Prove n')

767767 mapM_ (\ (f,n) -> setTotality n Unchecked) (idris_totcheck i)

768768 mapM_ checkDeclTotality (idris_totcheck i)

769769

770−process h fn (HNF t)

770+process h fn (HNF t)

771771 = do (tm, ty) <- elabVal toplevel False t

772772 ctxt <- getContext

773773 ist <- getIState

774774 let tm' = hnf ctxt [] tm

775775 iPrintResult (show (delab ist tm'))

776−process h fn (TestInline t)

776+process h fn (TestInline t)

777777 = do (tm, ty) <- elabVal toplevel False t

778778 ctxt <- getContext

779779 ist <- getIState

@@ -781,12 +781,12 @@ process h fn (TestInline t)

781781 imp <- impShow

782782 c <- colourise

783783 iPrintResult (showImp (Just ist) imp c (delab ist tm'))

784−process h fn TTShell

784+process h fn TTShell

785785 = do ist <- getIState

786786 let shst = initState (tt_ctxt ist)

787787 runShell shst

788788 return ()

789−process h fn Execute

789+process h fn Execute

790790 = do (m, _) <- elabVal toplevel False

791791 (PApp fc

792792 (PRef fc (UN "run__IO"))

@@ -819,7 +819,7 @@ process h fn (Missing n)

819819 [(_, tms)] ->

820820 iPrintResult (showSep "\n" (map (showImp (Just i) True c) tms))

821821 _ -> iPrintError $ "Ambiguous name"

822−process h fn (DynamicLink l)

822+process h fn (DynamicLink l)

823823 = do i <- getIState

824824 let lib = trim l

825825 handle <- lift . lift $ tryLoadLib lib

@@ -831,7 +831,7 @@ process h fn (DynamicLink l)

831831 return ()

832832 else putIState $ i { idris_dynamic_libs = x:libs }

833833 where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace

834−process h fn ListDynamic

834+process h fn ListDynamic

835835 = do i <- getIState

836836 iputStrLn "Dynamic libraries:"

837837 showLibs $ idris_dynamic_libs i

@@ -856,7 +856,7 @@ process h fn (SetColour ty c) = setColour ty c

856856process h fn ColourOn

857857 = do ist <- getIState

858858 putIState $ ist { idris_colourRepl = True }

859−process h fn ColourOff

859+process h fn ColourOff

860860 = do ist <- getIState

861861 putIState $ ist { idris_colourRepl = False }

862862

@@ -890,9 +890,9 @@ displayHelp = let vstr = showVersion version in

890890 "--------------" ++ map (\x -> '-') vstr ++ "\n\n" ++

891891 concatMap cmdInfo helphead ++

892892 concatMap cmdInfo help

893− where cmdInfo (cmds, args, text) = " " ++ col 16 12 (showSep " " cmds) (show args) text

894− col c1 c2 l m r =

895− l ++ take (c1 - length l) (repeat ' ') ++

893+ where cmdInfo (cmds, args, text) = " " ++ col 16 12 (showSep " " cmds) (show args) text

894+ col c1 c2 l m r =

895+ l ++ take (c1 - length l) (repeat ' ') ++

896896 m ++ take (c2 - length m) (repeat ' ') ++ r ++ "\n"

897897

898898parseCodegen :: String -> Codegen

@@ -982,27 +982,27 @@ loadInputs :: Handle -> [FilePath] -> Idris ()

982982loadInputs h inputs

983983 = do ist <- getIState

984984 -- 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

986986 -- a package (instead, reload all at the end to check for

987987 -- consistency only)

988988 opts <- getCmdLine

989989

990990 let loadCode = case opt getOutput opts of

991− [] -> not (NoREPL `elem` opts)

991+ [] -> not (NoREPL `elem` opts)

992992 _ -> True

993993

994994 -- For each ifile list, check it and build ibcs in the same clean IState

995995 -- so that they don't interfere with each other when checking

996996

997997 let ninputs = zip [1..] inputs

998− ifiles <- mapM (\(num, input) ->

998+ ifiles <- mapM (\(num, input) ->

999999 do putIState ist

10001000 v <- verbose

1001−-- when v $ iputStrLn $ "(" ++ show num ++ "/" ++

1001+-- when v $ iputStrLn $ "(" ++ show num ++ "/" ++

10021002-- show (length inputs) ++

1003−-- ") " ++ input

1004− modTree <- buildTree

1005− (map snd (take (num-1) ninputs))

1003+-- ") " ++ input

1004+ modTree <- buildTree

1005+ (map snd (take (num-1) ninputs))

10061006 input

10071007 let ifiles = getModuleFiles modTree

10081008 iLOG ("MODULE TREE : " ++ show modTree)

@@ -1093,11 +1093,11 @@ idrisMain opts =

10931093 -- if we have the --fovm flag, drop into the first order VM testing

10941094 case vm of

10951095 [] -> return ()

1096− xs -> runIO $ mapM_ (fovm cgn outty) xs

1096+ xs -> runIO $ mapM_ (fovm cgn outty) xs

10971097 -- if we have the --bytecode flag, drop into the bytecode assembler

10981098 case bcs of

10991099 [] -> return ()

1100− xs -> return () -- runIO $ mapM_ bcAsm xs

1100+ xs -> return () -- runIO $ mapM_ bcAsm xs

11011101 case ibcsubdir of

11021102 [] -> setIBCSubDir ""

11031103 (d:_) -> setIBCSubDir d

@@ -1272,10 +1272,10 @@ opt = mapMaybe

12721272

12731273ver = showVersion version

12741274

1275−banner = " ____ __ _ \n" ++

1275+banner = " ____ __ _ \n" ++

12761276 " / _/___/ /____(_)____ \n" ++

12771277 " / // __ / ___/ / ___/ Version " ++ ver ++ "\n" ++

12781278 " _/ // /_/ / / / (__ ) http://www.idris-lang.org/ \n" ++

1279− " /___/\\__,_/_/ /_/____/ Type :? for help \n"

1279+ " /___/\\__,_/_/ /_/____/ Type :? for help \n"

12801280

12811281

src/Idris/REPLParser.hs+12−12

@@ -65,29 +65,29 @@ pCmd = do P.whiteSpace; try (do cmd ["q", "quit"]; eof; return Quit)

6565 <|> try (do cmd ["set"]; o <-pOption; return (SetOpt o))

6666 <|> try (do cmd ["unset"]; o <-pOption; return (UnsetOpt o))

6767 <|> 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;

6969 upd <- option False (do P.lchar '!'; return True)

70− l <- P.natural; n <- P.name;

70+ l <- P.natural; n <- P.name;

7171 return (CaseSplitAt upd (fromInteger l) n))

72− <|> try (do cmd ["apc", "addproofclause"]; P.whiteSpace;

72+ <|> try (do cmd ["apc", "addproofclause"]; P.whiteSpace;

7373 upd <- option False (do P.lchar '!'; return True)

74− l <- P.natural; n <- P.name;

74+ l <- P.natural; n <- P.name;

7575 return (AddProofClauseFrom upd (fromInteger l) n))

76− <|> try (do cmd ["ac", "addclause"]; P.whiteSpace;

76+ <|> try (do cmd ["ac", "addclause"]; P.whiteSpace;

7777 upd <- option False (do P.lchar '!'; return True)

78− l <- P.natural; n <- P.name;

78+ l <- P.natural; n <- P.name;

7979 return (AddClauseFrom upd (fromInteger l) n))

80− <|> try (do cmd ["am", "addmissing"]; P.whiteSpace;

80+ <|> try (do cmd ["am", "addmissing"]; P.whiteSpace;

8181 upd <- option False (do P.lchar '!'; return True)

82− l <- P.natural; n <- P.name;

82+ l <- P.natural; n <- P.name;

8383 return (AddMissing upd (fromInteger l) n))

84− <|> try (do cmd ["mw", "makewith"]; P.whiteSpace;

84+ <|> try (do cmd ["mw", "makewith"]; P.whiteSpace;

8585 upd <- option False (do P.lchar '!'; return True)

86− l <- P.natural; n <- P.name;

86+ l <- P.natural; n <- P.name;

8787 return (MakeWith upd (fromInteger l) n))

88− <|> try (do cmd ["ps", "proofsearch"]; P.whiteSpace;

88+ <|> try (do cmd ["ps", "proofsearch"]; P.whiteSpace;

8989 upd <- option False (do P.lchar '!'; return True)

90− l <- P.natural; n <- P.name;

90+ l <- P.natural; n <- P.name;

9191 hints <- many P.name

9292 return (DoProofSearch upd (fromInteger l) n hints))

9393 <|> 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

4040natTrans = [TermTrans zero, TermTrans suc, CaseTrans natcase]

4141

4242zname = NS (UN "Z") ["Nat","Prelude"]

43−sname = NS (UN "S") ["Nat","Prelude"]

43+sname = NS (UN "S") ["Nat","Prelude"]

4444

4545zero :: TT Name -> TT Name

4646zero (P _ n _) | n == zname

@@ -53,5 +53,5 @@ suc (App (P _ s _) a) | s == sname

5353suc x = x

5454

5555natcase :: SC -> SC

56−natcase = undefined

56+natcase = undefined

5757

src/Idris/Unlit.hs+1−1

@@ -15,7 +15,7 @@ ulLine ('>':' ':xs) = (Prog, xs)

1515ulLine ('>':xs) = (Prog, xs)

1616ulLine xs | all isSpace xs = (Blank, "")

1717-- make sure it's not a doc comment

18− | otherwise = (Comm, '-':'-':' ':'>':xs)

18+ | otherwise = (Comm, '-':'-':' ':'>':xs)

1919

2020check :: FilePath -> Int -> [(LineType, String)] -> TC ()

2121check 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 ()

1313findUnusedArgs ns = mapM_ traceUnused ns

1414

1515traceUnused :: Name -> Idris ()

16−traceUnused n

16+traceUnused n

1717 = do i <- getIState

18− case lookupCtxt n (idris_callgraph i) of

18+ case lookupCtxt n (idris_callgraph i) of

1919 [CGInfo args calls scg usedns _] ->

2020 do let argpos = zip args [0..]

2121 let fargs = concatMap (getFargpos calls) argpos

2222 logLvl 3 $ show n ++ " used TRACE: " ++ show fargs

23− recused <- mapM (\ (argn, i, (g, j)) ->

23+ recused <- mapM (\ (argn, i, (g, j)) ->

2424 do u <- used [(n, i)] g j

2525 return (argn, u)) fargs

2626 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

2828 let unusedpos = mapMaybe (getUnused fused) (zip [0..] args)

2929 logLvl 1 $ show n ++ " unused args: " ++ show (args, unusedpos)

3030 addToCG n (CGInfo args calls scg usedns unusedpos) -- updates

@@ -34,14 +34,14 @@ traceUnused n

3434 | otherwise = Just i

3535

3636used :: [(Name, Int)] -> Name -> Int -> Idris Bool

37−used path g j

37+used path g j

3838 | (g, j) `elem` path = return False -- cycle, never used on the way

39− | otherwise

40− = do logLvl 5 $ (show ((g, j) : path))

39+ | otherwise

40+ = do logLvl 5 $ (show ((g, j) : path))

4141 i <- getIState

4242 case lookupCtxt g (idris_callgraph i) of

4343 [CGInfo args calls scg usedns unused] ->

44− if (j >= length args)

44+ if (j >= length args)

4545 then -- overapplied, assume used

4646 return True

4747 else do let directuse = args!!j `elem` usedns

@@ -50,7 +50,7 @@ used path g j

5050 recused <- mapM (\ (argn, j, (g', j')) ->

5151 used ((g,j):path) g' j') garg

5252 -- used on any route from here, or not used recursively

53− return (directuse || null recused || or recused)

53+ return (directuse || null recused || or recused)

5454 _ -> return True -- no definition, assume used

5555

5656getFargpos :: [(Name, [[Name]])] -> (Name, Int) -> [(Name, Int, (Name, Int))]

src/Pkg/PParser.hs+4−4

@@ -58,10 +58,10 @@ parseDesc fp = do p <- readFile fp

5858 Right x -> return x

5959

6060pPkg :: PParser PkgDesc

61−pPkg = do reserved "package"; p <- identifier

61+pPkg = do reserved "package"; p <- identifier

6262 st <- getState

6363 setState (st { pkgname = p })

64− many1 pClause

64+ many1 pClause

6565 st <- getState

6666 return st

6767

@@ -84,7 +84,7 @@ pClause = do reserved "executable"; lchar '=';

8484 let args = parseArgs (words opts)

8585 setState (st { idris_opts = args })

8686 <|> do reserved "modules"; lchar '=';

87− ms <- sepBy1 (iName []) (lchar ',')

87+ ms <- sepBy1 (iName []) (lchar ',')

8888 st <- getState

8989 setState (st { modules = modules st ++ ms })

9090 <|> do reserved "libs"; lchar '=';

@@ -99,4 +99,4 @@ pClause = do reserved "executable"; lchar '=';

9999 mk <- iName []

100100 st <- getState

101101 setState (st { makefile = Just (show mk) })

102−

102+

src/Pkg/Package.hs+9−9

@@ -30,7 +30,7 @@ import Paths_idris (getDataDir)

3030-- * install everything into datadir/pname, if install flag is set

3131

3232buildPkg :: Bool -> (Bool, FilePath) -> IO ()

33−buildPkg warnonly (install, fp)

33+buildPkg warnonly (install, fp)

3434 = do pkgdesc <- parseDesc fp

3535 ok <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)

3636 when (and ok) $

@@ -42,17 +42,17 @@ buildPkg warnonly (install, fp)

4242 (modules pkgdesc)

4343 Just o -> do let exec = dir </> o

4444 buildMods

45− (NoREPL : Verbose : Output exec : idris_opts pkgdesc)

45+ (NoREPL : Verbose : Output exec : idris_opts pkgdesc)

4646 [idris_main pkgdesc]

4747 setCurrentDirectory dir

4848 when install $ installPkg pkgdesc

4949

5050cleanPkg :: FilePath -> IO ()

51−cleanPkg fp

51+cleanPkg fp

5252 = do pkgdesc <- parseDesc fp

5353 dir <- getCurrentDirectory

5454 setCurrentDirectory $ dir </> sourcedir pkgdesc

55− clean (makefile pkgdesc)

55+ clean (makefile pkgdesc)

5656 mapM_ rmIBC (modules pkgdesc)

5757 case execout pkgdesc of

5858 Nothing -> return ()

@@ -75,7 +75,7 @@ buildMods opts ns = do let f = map (toPath . show) ns

7575 where toPath n = foldl1' (</>) $ splitOn "." n

7676

7777testLib :: Bool -> String -> String -> IO Bool

78−testLib warn p f

78+testLib warn p f

7979 = do d <- getDataDir

8080 gcc <- getCC

8181 (tmpf, tmph) <- tempfile

@@ -84,15 +84,15 @@ testLib warn p f

8484 e <- system $ gcc ++ " " ++ libtest ++ " -l" ++ f ++ " -o " ++ tmpf

8585 case e of

8686 ExitSuccess -> return True

87− _ -> do if warn

88− then do putStrLn $ "Not building " ++ p ++

87+ _ -> do if warn

88+ then do putStrLn $ "Not building " ++ p ++

8989 " due to missing library " ++ f

9090 return False

9191 else fail $ "Missing library " ++ f

9292

9393rmIBC :: Name -> IO ()

94−rmIBC m = rmFile $ toIBCFile m

95−

94+rmIBC m = rmFile $ toIBCFile m

95+

9696toIBCFile (UN n) = n ++ ".ibc"

9797toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns))

9898

src/Util/LLVMStubs.hs+2−2

@@ -1,6 +1,6 @@

1−{--

1+{--

22

3−Things needed to build without LLVM

3+Things needed to build without LLVM

44Replaces stuff from LLVM.General.Target and IRTS.CodegenLLVM.

55

66--}

src/Util/System.hs+6−6

@@ -48,17 +48,17 @@ tempfile = do dir <- getTemporaryDirectory

4848 openTempFile (normalise dir) "idris"

4949

5050withTempdir :: String -> (FilePath -> IO a) -> IO a

51−withTempdir subdir callback

51+withTempdir subdir callback

5252 = do dir <- getTemporaryDirectory

5353 let tmpDir = (normalise dir) </> subdir

5454 removeLater <- catchIO (createDirectoryIfMissing True tmpDir >> return True)

55− (\ ioError -> if isAlreadyExistsError ioError then return False

55+ (\ ioError -> if isAlreadyExistsError ioError then return False

5656 else throw ioError

5757 )

5858 result <- callback tmpDir

5959 when removeLater $ removeDirectoryRecursive tmpDir

6060 return result

61−

61+

6262environment :: String -> IO (Maybe String)

6363environment x = catchIO (do e <- getEnv x

6464 return (Just e))

@@ -70,13 +70,13 @@ getTargetDir = environment "TARGET" >>= maybe getDataDir return

7070rmFile :: FilePath -> IO ()

7171rmFile f = do putStrLn $ "Removing " ++ f

7272 catchIO (removeFile f)

73− (\ioerr -> putStrLn $ "WARNING: Cannot remove file "

73+ (\ioerr -> putStrLn $ "WARNING: Cannot remove file "

7474 ++ f ++ ", Error msg:" ++ show ioerr)

7575

76−

76+

7777getLibFlags = do dir <- getDataDir

7878 return $ "-L" ++ (dir </> "rts") ++ " -lidris_rts -lgmp -lpthread"

79−

79+

8080getIdrisLibDir = do dir <- getDataDir

8181 return $ addTrailingPathSeparator dir

8282

test/mktest.pl+1−1

@@ -2,7 +2,7 @@

22

33if ($#ARGV>=0) {

44 $test=shift(@ARGV);

5−} else {

5+} else {

66 print "What's its name?\n";

77 exit;

88}

test/reg001/reg001.idr+3−3

@@ -1,10 +1,10 @@

11apply : (a -> b) -> a -> b

22apply f x = f x

33

4−class Functor f => VerifiedFunctor (f : Type -> Type) where

5− identity : (fa : f a) -> map id fa = fa

4+class Functor f => VerifiedFunctor (f : Type -> Type) where

5+ identity : (fa : f a) -> map id fa = fa

66

7−data Imp : Type where

7+data Imp : Type where

88 MkImp : {any : Type} -> any -> Imp

99

1010testVal : Imp

test/reg002/reg002.idr+2−2

@@ -2,7 +2,7 @@ module Main

22

33%default total

44

5−data CoNat

5+data CoNat

66 = Co Nat

77 | Infinity

88

@@ -11,7 +11,7 @@ S (Co n) = Co (S n)

1111S Infinity = Infinity

1212

1313Sn_notzero : Main.S n = Co 0 -> _|_

14−Sn_notzero = believe_me

14+Sn_notzero = believe_me

1515

1616S_Co_not_Inf : Main.S (Co n) = Infinity -> _|_

1717S_Co_not_Inf = believe_me

test/reg003/reg003.idr+1−1

@@ -7,7 +7,7 @@ mutual

77

88 namespace Odd

99 data OddList : Type where

10− (::) : Nat -> EvenList -> OddList

10+ (::) : Nat -> EvenList -> OddList

1111

1212test : EvenList

1313test = [1, 2, 3, 4, 5, 6]

test/reg003/reg003a.idr+2−2

@@ -4,7 +4,7 @@ data EvenList : Type where

44 ECons : Nat -> OddList -> EvenList

55

66data OddList : Type where

7− OCons : Nat -> EvenList -> OddList

7+ OCons : Nat -> EvenList -> OddList

88

99test : EvenList

10−test = ECons 1 ENil

10+test = ECons 1 ENil

test/reg003/run+2−2

@@ -1,4 +1,4 @@

11#!/bin/bash

2−idris --check reg003.idr

3−idris --check reg003a.idr

2+idris --check reg003.idr

3+idris --check reg003a.idr

44rm -f *.ibc

test/reg005/reg005.idr+3−3

@@ -7,7 +7,7 @@ rep (S k) x = x :: rep k x

77data RLE : Vect n Char -> Type where

88 REnd : RLE []

99 RChar : {xs : Vect k Char} ->

10− (n : Nat) -> (x : Char) -> RLE xs ->

10+ (n : Nat) -> (x : Char) -> RLE xs ->

1111 RLE (rep (S n) x ++ xs)

1212

1313eq : (x : Char) -> (y : Char) -> Maybe (x = y)

@@ -22,13 +22,13 @@ rle (x :: xs) with (rle xs)

2222 rle (x :: rep (S n) yvar ++ ys) | RChar n yvar rs with (eq x yvar)

2323 rle (x :: rep (S n) x ++ ys) | RChar n x rs | Just refl

2424 = 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

2626 = RChar Z x (RChar n y rs)

2727

2828compress : Vect n Char -> String

2929compress xs with (rle xs)

3030 compress Nil | REnd = ""

31− compress (rep (S n) x ++ xs) | RChar _ _ rs

31+ compress (rep (S n) x ++ xs) | RChar _ _ rs

3232 = let ni : Integer = cast (S n) in

3333 show ni ++ show x ++ compress xs

3434

test/reg006/reg006.idr+4−4

@@ -1,17 +1,17 @@

11module RBTree

2−

2+

33data Colour = Red | Black

44

55data RBTree : Type -> Type -> Nat -> Colour -> Type where

66 Leaf : RBTree k v Z Black

77 RedBranch : k -> v -> RBTree k v n Black -> RBTree k v n Black -> RBTree k v n Red

88 BlackBranch : k -> v -> RBTree k v n x -> RBTree k v n y -> RBTree k v (S n) Black

9−

9+

1010toBlack : RBTree k v n c -> (m ** (RBTree k v m Black, Either (m = n) (m = (S n))))

1111toBlack (RedBranch k v l r) = (_ ** (BlackBranch k v l r, Right refl))

1212toBlack Leaf = (_ ** (Leaf, Left refl))

1313toBlack (BlackBranch k v l r) = (_ ** (BlackBranch k v l r, Left refl))

14−

14+

1515total

1616lookup : Ord k => k -> RBTree k v n Black -> Maybe v

1717lookup k Leaf = Nothing

@@ -23,5 +23,5 @@ lookup k (BlackBranch k0 v0 l r) =

2323 lookup k t

2424 GT =>

2525 let (_ ** (t, _)) = toBlack r in

26− lookup k t

26+ lookup k t

2727

test/reg007/run+1−1

@@ -1,3 +1,3 @@

11#!/bin/bash

2−idris --check $@ reg007.lidr

2+idris --check $@ reg007.lidr

33rm -f *.ibc

test/reg009/reg009.lidr+5−5

@@ -2,15 +2,15 @@

22> isAnyBy _ (_ ** Nil) = False

33> isAnyBy p (_ ** (a :: as)) = p a || isAnyBy p (_ ** as)

44

5−> filterTagP : (p : alpha -> Bool) ->

6−> (as : Vect n alpha) ->

5+> filterTagP : (p : alpha -> Bool) ->

6+> (as : Vect n alpha) ->

77> so (isAnyBy p (n ** as)) ->

88> (m : Nat ** (Vect m (a : alpha ** so (p a)), so (m > Z)))

99> filterTagP {n = S m} p (a :: as) q with (p a)

1010> | True = (_

11−> **

12−> ((a ** believe_me oh)

13−> ::

11+> **

12+> ((a ** believe_me oh)

13+> ::

1414> (fst (getProof (filterTagP p as (believe_me oh)))),

1515> oh

1616> )

test/reg011/reg011.idr+4−4

@@ -1,9 +1,9 @@

1−vfoldl : (P : Nat -> Type) ->

1+vfoldl : (P : Nat -> Type) ->

22 ((x : Nat) -> P x -> a -> P (S x)) -> P Z

33 -> Vect m a -> P m

4−-- vfoldl P cons nil []

4+-- vfoldl P cons nil []

55-- = nil

6−vfoldl P cons nil (x :: xs)

6+vfoldl P cons nil (x :: xs)

77 = 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)

99-- = vfoldl (\n => P (S n)) (\ n => cons _) (cons _ nil x) xs

test/reg012/reg012.lidr+7−7

@@ -13,22 +13,22 @@

1313> soTrue : so b -> b = True

1414> soTrue {b = False} x = soFalseElim x

1515> soTrue {b = True} x = refl

16−

16+

1717> class Eq alpha => ReflEqEq alpha where

1818> reflexive_eqeq : (a : alpha) -> so (a == a)

1919

20−> modifyFun : (Eq alpha) =>

21−> (alpha -> beta) ->

22−> (alpha, beta) ->

20+> modifyFun : (Eq alpha) =>

21+> (alpha -> beta) ->

22+> (alpha, beta) ->

2323> (alpha -> beta)

2424> modifyFun f (a, b) a' = if a' == a then b else f a'

2525

26−> modifyFunLemma : (ReflEqEq alpha) =>

26+> modifyFunLemma : (ReflEqEq alpha) =>

2727> (f : alpha -> beta) ->

2828> (ab : (alpha, beta)) ->

2929> modifyFun f ab (fst ab) = snd ab

30−> modifyFunLemma f (a,b) =

30+> modifyFunLemma f (a,b) =

3131> rewrite soTrue (reflexive_eqeq a) in refl

3232

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)}

3434 (soTrue (reflexive_eqeq a)) refl

test/reg014/reg014.idr+2−2

@@ -6,7 +6,7 @@ Matrix a n m = Vect n (Vect m a)

66transpose : Matrix a (S n) (S m) -> Matrix a (S m) (S n)

77transpose ((x:: []) :: []) = [[x]]

88transpose [x :: y :: xs] = [x] :: (transpose [y :: xs])

9−transpose (x :: y :: xs)

10− = let tx = transpose [x] in

9+transpose (x :: y :: xs)

10+ = let tx = transpose [x] in

1111 let ux = transpose (y :: xs) in zipWith (++) tx ux

1212

test/reg018/reg018b.idr+2−2

@@ -1,4 +1,4 @@

1−module A

1+module A

22

33%default total

44

@@ -8,7 +8,7 @@ showB : B -> String

88showB (I x) = "I" ++ showB x

99showB (Z x) = "Z" ++ showB x

1010

11−instance Show B where show = showB

11+instance Show B where show = showB

1212

1313os : B

1414os = Z os

test/reg018/reg018c.idr+1−1

@@ -2,7 +2,7 @@ module CodataTest

22%default total

33

44codata InfStream a = (::) a (InfStream a)

5−--

5+--

66-- natStream : InfStream Nat

77-- natStream = natFromStream 0 where

88-- 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) ->

22 Maybe (Either Bool Int)

33m_add x y = do x' <- x -- Extract value from x

44 y' <- y -- Extract value from y

test/reg022/reg022.idr+1−1

@@ -9,7 +9,7 @@ instance Functor (Result str) where

99ParserT : (Type -> Type) -> Type -> Type -> Type

1010ParserT m str a = str -> m (Result str a)

1111

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 ->

1313 ParserT m str b

1414ap f x = \s => do f' <- f s

1515 case f' of

test/runtest.pl+3−3

@@ -24,7 +24,7 @@ sub runtest {

2424 $got =~ s/\r\n/\n/g;

2525 $exp =~ s/\r\n/\n/g;

2626

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

2828 # change between platforms

2929 while($got =~ /(^|.*?\n)(.*?)\\(.*?):(\d+):(.*)/ms) {

3030 $got = "$1$2/$3:$4:$5";

@@ -35,7 +35,7 @@ sub runtest {

3535

3636 if ($got eq $exp) {

3737 print "Ran $test...success\n";

38− }

38+ }

3939 else {

4040 if ($update == 0) {

4141 $exitstatus = 1;

@@ -66,7 +66,7 @@ if ($#ARGV>=0) {

6666 push @tests, $test;

6767 }

6868 @opts = @ARGV;

69−}

69+}

7070else {

7171 print "Give a test name, or 'all' to run all.\n";

7272 exit;

test/test001/test001.idr+9−9

@@ -27,11 +27,11 @@ using (G : Vect n Ty)

2727 Val : (x : Int) -> Expr G TyInt

2828 Lam : Expr (a :: G) t -> Expr G (TyFun a t)

2929 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 ->

3131 Expr G c

3232 If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a

3333 Bind : Expr G a -> (interpTy a -> Expr G b) -> Expr G b

34−

34+

3535 dsl expr

3636 lambda = Lam

3737 variable = Var

@@ -46,7 +46,7 @@ using (G : Vect n Ty)

4646 interp env (Op op x y) = op (interp env x) (interp env y)

4747 interp env (If x t e) = if interp env x then interp env t else interp env e

4848 interp env (Bind v f) = interp env (f (interp env v))

49−

49+

5050 eId : Expr G (TyFun TyInt TyInt)

5151 eId = expr (\x => x)

5252

@@ -55,25 +55,25 @@ using (G : Vect n Ty)

5555

5656 eAdd : Expr G (TyFun TyInt (TyFun TyInt TyInt))

5757 eAdd = expr (\x, y => Op (+) x y)

58−

58+

5959-- eDouble : Expr G (TyFun TyInt TyInt)

6060-- eDouble = Lam (App (App (Lam (Lam (Op' (+) (Var fZ) (Var (fS fZ))))) (Var fZ)) (Var fZ))

61−

61+

6262 eDouble : Expr G (TyFun TyInt TyInt)

6363 eDouble = expr (\x => App (App eAdd x) (Var stop))

64−

64+

6565 app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t

6666 app = \f, a => App f a

6767

6868 eFac : Expr G (TyFun TyInt TyInt)

6969 eFac = expr (\x => If (Op (==) x (Val 0))

70− (Val 1)

70+ (Val 1)

7171 (Op (*) (app eFac (Op (-) x (Val 1))) x))

7272

7373 -- Exercise elaborator: Complicated way of doing \x y => x*4 + y*2

74−

74+

7575 eProg : Expr G (TyFun TyInt (TyFun TyInt TyInt))

76− eProg = Lam (Lam

76+ eProg = Lam (Lam

7777 (Bind (App eDouble (Var (pop stop)))

7878 (\x => Bind (App eDouble (Var stop))

7979 (\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

44

55> st : String

66> st = "abcdefg"

7−

7+

88Literate main program

99

1010> main : IO ()

1111> main = do { putStrLn (show (strHead st))

1212> putStrLn (show (strIndex st 3))

1313> putStrLn (strCons 'z' st)

14−> putStrLn (reverse st)

14+> putStrLn (reverse st)

1515> let x = unpack st

1616> putStrLn (show (reverse x))

1717> putStrLn (pack x)

test/test004/test004.idr+2−2

@@ -20,10 +20,10 @@ main : IO ()

2020main = do { h <- openFile "testfile" Write

2121 fwrite h "Hello!\nWorld!\n...\n3\n4\nLast line\n"

2222 closeFile h

23− putStrLn "Reading testfile"

23+ putStrLn "Reading testfile"

2424 f <- readFile "testfile"

2525 putStrLn f

26− putStrLn "---"

26+ putStrLn "---"

2727 dumpFile "testfile"

2828 putStrLn "---"

2929 }

test/test007/test007.idr+1−1

@@ -16,7 +16,7 @@ fetch x = MkEval (\e => fetchVal e) where

1616instance Functor Eval where

1717 map f (MkEval g) = MkEval (\e => map f (g e))

1818

19−instance Applicative Eval where

19+instance Applicative Eval where

2020 pure x = MkEval (\e => Just x)

2121

2222 (<$>) (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")

1414

1515

1616ioVals : IO (String, String)

17−ioVals = do { return ("First", "second") }

17+ioVals = do { return ("First", "second") }

1818

1919main : IO ()

2020main = 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],

66

77main : IO ()

88main = putStrLn (show (pythag 50))

9−

9+

test/test011/test011.idr+1−1

@@ -16,7 +16,7 @@ person : Person

1616person = MkPerson "Fred" 30

1717

1818main : IO ()

19−main = do let x = record { name = "foo",

19+main = do let x = record { name = "foo",

2020 more_things = reverse ["a","b"] } testFoo

2121 print $ name x

2222 print $ name person

test/test012/test012a.idr+3−3

@@ -1,10 +1,10 @@

11module Main

2−

2+

33f : Nat -> Nat

44f x = x + 1

5−

5+

66foo : Nat -> Nat

77foo (f x) = x

8−

8+

99main : IO ()

1010main = putStrLn (show (foo 1))

test/test013/test013.idr+1−1

@@ -9,7 +9,7 @@ syntax for {x} "in" [xs] ":" [body] = forLoop xs (\x => body)

99

1010main : IO ()

1111main = do putStrLn "Counting:"

12− for x in [1..10]:

12+ for x in [1..10]:

1313 putStrLn $ "Number " ++ show x

1414 putStrLn "Done!"

1515

test/test014/Resimp.idr+18−18

@@ -29,7 +29,7 @@ getCreator (MkCreator x) = x

2929

3030ioc : IO a -> Creator a

3131ioc = MkCreator

32−

32+

3333infixr 5 :->

3434

3535using (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)

6363 update Nil stop _ impossible

6464

6565 total

66− envUpdate : (p:HasType gam i a) -> (val:interpTy b) ->

66+ envUpdate : (p:HasType gam i a) -> (val:interpTy b) ->

6767 Env gam -> Env (update gam p b)

6868 envUpdate stop val (x :: xs) = val :: xs

6969 envUpdate (pop k) val (x :: xs) = x :: envUpdate k val xs

7070 envUpdate stop _ Nil impossible

7171

7272 total

73− envUpdateVal : (p:HasType gam i a) -> (val:b) ->

73+ envUpdateVal : (p:HasType gam i a) -> (val:b) ->

7474 Env gam -> Env (update gam p (Val b))

7575 envUpdateVal stop val (x :: xs) = val :: xs

7676 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)

8181

8282 data Args : Vect n Ty -> List Type -> Type where

8383 ANil : Args gam []

84− ACons : HasType gam i a ->

84+ ACons : HasType gam i a ->

8585 Args gam as -> Args gam (interpTy a :: as)

8686

8787 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)

9595 it goes out of scope, where "consumed" simply means that it has been

9696 replaced with a value of type '()'. --}

9797

98− Let : Creator (interpTy a) ->

99− Res (a :: gam) (Val () :: gam') (R t) ->

98+ Let : Creator (interpTy a) ->

99+ Res (a :: gam) (Val () :: gam') (R t) ->

100100 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)) ->

102102 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) ->

104104 Res gam gam (R b)

105105

106106{-- Control structures --}

107107

108108 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))) ->

110110 (failure:Res (update gam p a) (update gam p c) t) ->

111111 (success:Res (update gam p b) (update gam p c) t) ->

112112 Res gam (update gam p c) t

113− While : Res gam gam (R Bool) ->

113+ While : Res gam gam (R Bool) ->

114114 Res gam gam (R ()) -> Res gam gam (R ())

115115 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)) ->

117117 Res gam gam'' (R t)

118118

119119 ioret : a -> IO a

120120 ioret = return

121121

122− interp : Env gam -> {static} Res gam gam' t ->

122+ interp : Env gam -> {static} Res gam gam' t ->

123123 (Env gam' -> interpTy t -> IO u) -> IO u

124124

125125 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)

128128 (\env', scope' => k (envTail env') scope')

129129 interp env (Update method x) k

130130 = do x' <- getUpdater (method (envLookup x env))

131− k (envUpdateVal x x' env) (return ())

131+ k (envUpdateVal x x' env) (return ())

132132 interp env (Use method x) k

133133 = do x' <- getReader (method (envLookup x env))

134134 k env (return x')

135− interp env (Lift io) k

135+ interp env (Lift io) k

136136 = k env io

137137 interp env (Check x left right) k =

138− either (envLookup x env)

138+ either (envLookup x env)

139139 (\a => interp (envUpdate x a env) left k)

140140 (\b => interp (envUpdate x b env) right k)

141141 interp env (While test body) k

142142 = interp env test

143143 (\env', result =>

144144 do r <- result

145− if (not r)

145+ if (not r)

146146 then (k env' (return ()))

147− else (interp env' body

148− (\env'', body' =>

147+ else (interp env' body

148+ (\env'', body' =>

149149 do v <- body' -- make sure it's evalled

150150 interp env'' (While test body) k )))

151151 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]

1616

1717open : String -> (p:Purpose) -> Creator (Either () (FILE p))

1818open fn p = ioc (do h <- fopen fn (pstring p)

19− ifM validFile h

19+ ifM validFile h

2020 then return (Right (OpenH h))

2121 else return (Left ()))

2222

test/test015/test015.idr+10−10

@@ -24,7 +24,7 @@ instance Show (Binary w k) where

2424 show (bin # bit) = show bin ++ show bit

2525

2626pad : Binary w n -> Binary (S w) n

27−pad zero = zero # b0

27+pad zero = zero # b0

2828pad (num # x) = pad num # x

2929

3030natToBin : (width : Nat) -> (n : Nat) ->

@@ -47,21 +47,21 @@ testBin = natToBin _ _

4747pattern syntax bitpair [x] [y] = (_ ** (_ ** (x, y, _)))

4848term syntax bitpair [x] [y] = (_ ** (_ ** (x, y, refl)))

4949

50−addBit : Bit x -> Bit y -> Bit c ->

50+addBit : Bit x -> Bit y -> Bit c ->

5151 (bX ** (bY ** (Bit bX, Bit bY, c + x + y = bY + 2 * bX)))

5252addBit b0 b0 b0 = bitpair b0 b0

53−addBit b0 b0 b1 = bitpair b0 b1

53+addBit b0 b0 b1 = bitpair b0 b1

5454addBit b0 b1 b0 = bitpair b0 b1

5555addBit b0 b1 b1 = bitpair b1 b0

56−addBit b1 b0 b0 = bitpair b0 b1

57−addBit b1 b0 b1 = bitpair b1 b0

58−addBit b1 b1 b0 = bitpair b1 b0

59−addBit b1 b1 b1 = bitpair b1 b1

56+addBit b1 b0 b0 = bitpair b0 b1

57+addBit b1 b0 b1 = bitpair b1 b0

58+addBit b1 b1 b0 = bitpair b1 b0

59+addBit b1 b1 b1 = bitpair b1 b1

6060

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)

6262adc zero zero carry ?= zero # carry

6363adc (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

6565 adc numx numy carry0 # lsb

6666

6767readNum : IO Nat

@@ -82,7 +82,7 @@ main = do let Just bin1 = natToBin 8 42

8282

8383

8484

85−

85+

8686---------- Proofs ----------

8787

8888Main.ntbOdd = proof {

test/test017/test017.idr+2−2

@@ -13,7 +13,7 @@ ordElim : (x : Ord) ->

1313 (P : Ord -> Type) ->

1414 (P Zero) ->

1515 ((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)) ->

1717 P (Sup f)) -> P x

1818ordElim Zero P mZ mSuc mSup = mZ

1919ordElim (Suc o) P mZ mSuc mSup = mSuc o (ordElim o P mZ mSuc mSup)

@@ -56,7 +56,7 @@ even (S k) = odd k

5656ack : Nat -> Nat -> Nat

5757ack Z n = S n

5858ack (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)

6060

6161data Bin = eps | c0 Bin | c1 Bin

6262

test/test018/test018.idr+2−2

@@ -17,10 +17,10 @@ ping : Ptr -> IO ()

1717ping thread = sendToThread thread (prim__vm, "Hello!")

1818

1919pingpong : IO ()

20−pingpong

20+pingpong

2121 = do th <- fork pong

2222 putStrLn "Sending"

23− ping th

23+ ping th

2424 reply <- getMsg

2525 putStrLn reply

2626 usleep 100000

test/test018/test018a.idr+3−3

@@ -3,7 +3,7 @@ module Main

33import System.Concurrency.Process

44

55ping : ProcID String -> ProcID String -> Process String ()

6−ping main proc

6+ping main proc

77 = do lift (usleep 1000)

88 send proc "Hello!"

99 lift (putStrLn "Sent ping")

@@ -14,7 +14,7 @@ ping main proc

1414pong : Process String ()

1515pong = do -- lift (putStrLn "Waiting for message")

1616 (sender, m) <- recvWithSender

17− lift $ putStrLn ("Received " ++ m)

17+ lift $ putStrLn ("Received " ++ m)

1818 send sender ("Hello back!")

1919

2020mainProc : Process String ()

@@ -27,7 +27,7 @@ mainProc = do mainID <- myID

2727repeatIO : Int -> IO ()

2828repeatIO 0 = return ()

2929repeatIO n = do print n

30− run mainProc

30+ run mainProc

3131 repeatIO (n - 1)

3232

3333main : IO ()

test/test020/test020.idr+2−2

@@ -1,10 +1,10 @@

11module Main

22

3−implicit

3+implicit

44natInt : Nat -> Integer

55natInt x = cast x

66

7−implicit

7+implicit

88forget : Vect n a -> List a

99forget [] = []

1010forget (x :: xs) = x :: forget xs

test/test020/test020a.idr+1−1

@@ -1,6 +1,6 @@

11module Main

22

3−implicit

3+implicit

44forget : Vect n a -> List a

55forget [] = []

66forget (x :: xs) = x :: forget xs

test/test021/test021.idr+5−5

@@ -1,4 +1,4 @@

1−module Main

1+module Main

22

33import Effect.File

44import Effect.State

@@ -8,20 +8,20 @@ import Control.IOExcept

88data FName = Count | NotCount

99

1010FileIO : Type -> Type -> Type

11−FileIO st t

11+FileIO st t

1212 = Eff (IOExcept String) [FILE_IO st, STDIO, Count ::: STATE Int] t

1313

1414readFile : FileIO (OpenFile Read) (List String)

1515readFile = readAcc [] where

16− readAcc : List String -> FileIO (OpenFile Read) (List String)

16+ readAcc : List String -> FileIO (OpenFile Read) (List String)

1717 readAcc acc = do e <- eof

18− if (not e)

18+ if (not e)

1919 then do str <- readLine

2020 Count :- put (!(Count :- get) + 1)

2121 readAcc (str :: acc)

2222 else return (reverse acc)

2323

24−testFile : FileIO () ()

24+testFile : FileIO () ()

2525testFile = do open "testFile" Read

2626 if_valid then do putStrLn (show !readFile)

2727 close

test/test021/test021a.idr+1−1

@@ -14,7 +14,7 @@ Env : Type

1414Env = List (String, Integer)

1515

1616-- Evaluator : Type -> Type

17−-- Evaluator t

17+-- Evaluator t

1818-- = Eff m [EXCEPTION String, RND, STATE Env] t

1919

2020eval : 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

2626 res <- Dst :- peek 1 (S(S(S(S Z)))) oh

2727 Dst :- free

2828 return (map (prim__zextB8_Int) res)

29−

29+

3030main : IO ()

3131main = do ioe_run (run [Dst := (), Src := ()] testMemory)

3232 (\err => print err) (\ok => print ok)

test/test029/test029.idr+2−2

@@ -1,10 +1,10 @@

1−module simple

1+module simple

22

33plus_comm : (n : Nat) -> (m : Nat) -> (n + m = m + n)

44

55-- Base case

66(Z + m = m + Z) <== plus_comm =

7− rewrite ((m + Z = m) <== plusZeroRightNeutral) ==>

7+ rewrite ((m + Z = m) <== plusZeroRightNeutral) ==>

88 (Z + m = m) in refl

99

1010-- Step case

test/test030/Reflect.idr+7−7

@@ -41,7 +41,7 @@ using (xs : List a, ys : List a, G : List (List a))

4141 expr_r (App ex ey) = let (xl ** (xr, xprf)) = expr_r ex in

4242 let (yl ** (yr, yprf)) = expr_r ey in

4343 appRExpr _ _ xr yr xprf yprf

44− where

44+ where

4545 appRExpr : (xs', ys' : List a) ->

4646 RExpr G xs -> RExpr G ys -> (xs' = xs) -> (ys' = ys) ->

4747 (ws' ** (RExpr G ws', xs' ++ ys' = ws'))

@@ -80,13 +80,13 @@ using (xs : List a, ys : List a, G : List (List a))

8080

8181 buildProof : {xs : List a} -> {ys : List a} ->

8282 Expr G ln -> Expr G rn ->

83− (xs = ln) -> (ys = rn) -> Maybe (xs = ys)

83+ (xs = ln) -> (ys = rn) -> Maybe (xs = ys)

8484 buildProof e e' lp rp with (eqExpr e e')

8585 buildProof e e lp rp | Just refl = ?bp1

8686 buildProof e e' lp rp | Nothing = Nothing

8787

8888 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

9090 let (rn ** (r', rPrf)) = reduce r in

9191 buildProof l' r' lPrf rPrf

9292

@@ -129,7 +129,7 @@ using (xs : List a, ys : List a, G : List (List a))

129129-- reduction will work the right way.

130130

131131%reflection

132−reflectList : (G : List (List a)) ->

132+reflectList : (G : List (List a)) ->

133133 (xs : List a) -> (G' ** Expr (G' ++ G) xs)

134134reflectList G [] = ([] ** ENil)

135135

@@ -140,7 +140,7 @@ reflectList G (x :: xs) with (reflectList G xs)

140140

141141reflectList G (xs ++ ys) with (reflectList G xs)

142142 | (G' ** xs') with (reflectList (G' ++ G) ys)

143− | (G'' ** ys') = ((G'' ++ G') **

143+ | (G'' ** ys') = ((G'' ++ G') **

144144 rewrite (sym (appendAssociative G'' G' G)) in

145145 App (weaken G'' xs') ys')

146146reflectList G t with (isElem t G)

@@ -157,7 +157,7 @@ reflectList G t with (isElem t G)

157157

158158%reflection

159159reflectEq : (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)

161161 | (G' ** xs') with (reflectList (G' ++ G) ys)

162162 | (G'' ** ys') = ((G'' ++ G') **

163163 rewrite (sym (appendAssociative G'' G' G)) in

@@ -197,7 +197,7 @@ Reflect.bp1 = proof {

197197-- The effect is to bind x to p applied to the current goal. If 'p' is a

198198-- reflection function (which is the most likely thing to be useful...)

199199-- 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.

201201

202202-- The syntax declaration below just gives us an easy way to invoke the

203203-- prover.

test/test030/test030.idr+2−2

@@ -7,7 +7,7 @@ testReflect0 : (xs, ys : List a) -> ((xs ++ (ys ++ xs)) = ((xs ++ ys) ++ xs))

77testReflect0 {a} xs ys = AssocProof a

88

99total

10−testReflect1 : (xs, ys : List a) ->

10+testReflect1 : (xs, ys : List a) ->

1111 ((xs ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs)))

12−testReflect1 {a} xs ys = AssocProof a

12+testReflect1 {a} xs ys = AssocProof a

1313

test/test030/test030a.idr+2−2

@@ -7,7 +7,7 @@ testReflect0 : (xs, ys : List a) -> ((xs ++ (ys ++ xs)) = ((xs ++ ys) ++ xs))

77testReflect0 {a} xs ys = AssocProof a

88

99total

10−testReflect1 : (xs, ys : List a) ->

10+testReflect1 : (xs, ys : List a) ->

1111 ((ys ++ (x :: ys ++ xs)) = ((xs ++ [x]) ++ (ys ++ xs)))

12−testReflect1 {a} xs ys = AssocProof a

12+testReflect1 {a} xs ys = AssocProof a

1313

test/test032/expected+2−2

@@ -2,8 +2,8 @@ Type checking ./test032.idr

22isElem x [] = ?isElem_rhs_1

33isElem x (_ :: _) = ?isElem_rhs_3

44

5− localZipWith f (_ :: _) ys = ?localZipWith_rhs_1

6− localZipWith f (_ :: _) ys = ?localZipWith_rhs_2

5+ localZipWith f (_ :: _) ys = ?localZipWith_rhs_1

6+ localZipWith f (_ :: _) ys = ?localZipWith_rhs_2

77

88f x :: (map f xs)

99isElem2 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

1414vadd xs ys = localZipWith (+) xs ys where

1515 localZipWith : (a -> b -> c) -> Vect n a -> Vect n b -> Vect n c

1616 localZipWith f [] [] = []

17− localZipWith f (_ :: _) ys = ?localZipWith_rhs

17+ localZipWith f (_ :: _) ys = ?localZipWith_rhs

1818

1919map : (a -> b) -> Vect n a -> Vect n b

2020map f [] = []

tutorial/examples/bmain.idr+1−1

@@ -3,6 +3,6 @@ module Main

33import btree

44

55main : 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]

77 print (btree.toList t)

88

tutorial/examples/classes.idr+1−1

@@ -1,7 +1,7 @@

11m_add : Maybe Int -> Maybe Int -> Maybe Int

22m_add x y = do x' <- x -- Extract value from x

33 y' <- y -- Extract value from y

4− return (x' + y') -- Add them

4+ return (x' + y') -- Add them

55

66m_add' : Maybe Int -> Maybe Int -> Maybe Int

77m_add' x y = [ x' + y' | x' <- x, y' <- y ]

tutorial/examples/foo.idr+1−1

@@ -6,5 +6,5 @@ namespace x

66

77namespace y

88 test : String -> String

9− test x = x ++ x

9+ test x = x ++ x

1010

tutorial/examples/idiom.idr+1−1

@@ -16,7 +16,7 @@ fetch x = MkEval (\e => fetchVal e) where

1616instance Functor Eval where

1717 map f (MkEval g) = MkEval (\e => map f (g e))

1818

19−instance Applicative Eval where

19+instance Applicative Eval where

2020 pure x = MkEval (\e => Just x)

2121

2222 (<$>) (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

77interpTy TyBool = Bool

88interpTy (TyFun s t) = interpTy s -> interpTy t

99

10−using (G : Vect n Ty)

10+using (G : Vect n Ty)

1111

1212 data Env : Vect n Ty -> Type where

1313 Nil : Env Nil

@@ -26,17 +26,17 @@ using (G : Vect n Ty)

2626 Val : (x : Int) -> Expr G TyInt

2727 Lam : Expr (a :: G) t -> Expr G (TyFun a t)

2828 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 ->

3030 Expr G c

3131 If : Expr G TyBool -> Expr G a -> Expr G a -> Expr G a

32−

32+

3333 interp : Env G -> {static} Expr G t -> interpTy t

3434 interp env (Var i) = lookup i env

3535 interp env (Val x) = x

3636 interp env (Lam sc) = \x => interp (x :: env) sc

3737 interp env (App f s) = interp env f (interp env s)

3838 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

4040 else interp env e

4141

4242 eId : Expr G (TyFun TyInt TyInt)

@@ -47,10 +47,10 @@ using (G : Vect n Ty)

4747

4848 eEq : Expr G (TyFun TyInt (TyFun TyInt TyBool))

4949 eEq = Lam (Lam (Op (==) (Var stop) (Var (pop stop))))

50−

50+

5151 eDouble : Expr G (TyFun TyInt TyInt)

5252 eDouble = Lam (App (App eAdd (Var stop)) (Var stop))

53−

53+

5454 app : |(f : Expr G (TyFun a t)) -> Expr G a -> Expr G t

5555 app = \f, a => App f a

5656

@@ -67,5 +67,5 @@ unitTestFac = oh

6767main : IO ()

6868main = do putStr "Enter a number: "

6969 x <- getLine

70− print (interp [] fact (cast x))

70+ print (interp [] fact (cast x))

7171

tutorial/examples/wheres.idr+3−3

@@ -1,10 +1,10 @@

11module wheres

22

3−even : Nat -> Bool

3+even : Nat -> Bool

44even Z = True

5−even (S k) = odd k where

5+even (S k) = odd k where

66 odd Z = False

7− odd (S k) = even k

7+ odd (S k) = even k

88

99test : List Nat

1010test = [c (S 1), c Z, d (S Z)]