39ec051 · Idris-dev · git.iko.soy

.gitignore+4

@@ -3,6 +3,9 @@ cabal-dev/

33*.ibc

44*.o

55*.a

6+*.so

7+*.dll

8+*.dylib

69*.swp

710*~

811custom.mk

@@ -11,3 +14,4 @@ test/test???/output

1114test/reg???/output

1215test/test???/*.exe

1316test/reg???/*.exe

17+

.travis.yml+1−2

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

11language: haskell

22script:

3− - cd test

4− - ./runtest.pl all

3+ - cabal configure && cabal install && make test

CHANGELOG+5

@@ -4,15 +4,20 @@ New in 0.9.8:

44User visible changes:

55

66* Added "rewrite ... in ..." construct

7+* Allow type class constraints in 'using' clauses

78* Renamed EFF to EFFECT in Effect package

89* Experimental Java backend

910* Tab completion in REPL

1011* Dynamic loading of C libraries in the interpreter

1112* Testing IO actions at the REPL with :x command

13+* Improve rendering of :t

14+* Fixed some INTERNAL ERROR messages

1215

1316Internal changes:

1417

18+* Fix non-linear pattern checking

1519* Improved name disambiguation

20+* More flexible unification and elaboration of lambdas

1621* Various unification and totality checking bug fixes

1722

1823New in 0.9.7:

Makefile+4−3

@@ -14,11 +14,12 @@ build: dist/setup-config

1414 $(CABAL) build $(CABALFLAGS)

1515

1616test:

17− make -C test

17+ make -C test IDRIS=../dist/build/idris

1818

1919relib:

20− make -C lib IDRIS=../dist/build/idris/idris clean

21− make -C effects IDRIS=../dist/build/idris/idris clean

20+ make -C lib IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts clean

21+ make -C effects IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts DIST=../dist/build clean

22+ make -C javascript IDRIS=../dist/build/idris/idris RTS=../dist/build/rts/libidris_rts DIST=../dist/build clean

2223 $(CABAL) install $(CABALFLAGS)

2324

2425linecount:

Setup.hs+16−3

@@ -28,13 +28,17 @@ mvn verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "mv

2828(<//>) = (Px.</>)

2929idrisCmd local = Px.joinPath $ splitDirectories $

3030 ".." <//> buildDir local <//> "idris" <//> "idris"

31+rtsDir local = Px.joinPath $ splitDirectories $

32+ ".." <//> buildDir local <//> "rts" <//> "libidris_rts"

3133#else

3234idrisCmd local = ".." </> buildDir local </> "idris" </> "idris"

35+rtsDir local = ".." </> buildDir local </> "rts" </> "libidris_rts"

3336#endif

3437

3538cleanStdLib verbosity

3639 = do make verbosity [ "-C", "lib", "clean", "IDRIS=idris" ]

3740 make verbosity [ "-C", "effects", "clean", "IDRIS=idris" ]

41+ make verbosity [ "-C", "javascript", "clean", "IDRIS=idris" ]

3842

3943cleanJavaLib verbosity

4044 = do dirty <- doesDirectoryExist ("java" </> "target")

@@ -60,6 +64,11 @@ installStdLib pkg local withoutEffects verbosity copy

6064 , "TARGET=" ++ idir

6165 , "IDRIS=" ++ icmd

6266 ]

67+ make verbosity

68+ [ "-C", "javascript", "install"

69+ , "TARGET=" ++ idir

70+ , "IDRIS=" ++ icmd

71+ ]

6372 let idirRts = idir </> "rts"

6473 putStrLn $ "Installing run time system in " ++ idirRts

6574 make verbosity

@@ -103,9 +112,13 @@ checkStdLib local withoutEffects verbosity

103112 ]

104113 unless withoutEffects $

105114 make verbosity

106− [ "-C", "effects", "check"

107− , "IDRIS=" ++ icmd

108− ]

115+ [ "-C", "effects", "check"

116+ , "IDRIS=" ++ icmd

117+ ]

118+ make verbosity

119+ [ "-C", "javascript", "check"

120+ , "IDRIS=" ++ icmd

121+ ]

109122 make verbosity

110123 [ "-C", "rts", "check"

111124 , "IDRIS=" ++ icmd

config.mk+27−1

@@ -5,5 +5,31 @@ CABAL :=cabal

55## Enable Java RTS:

66#CABALFLAGS :=-f Java

77## Disable building of Effects

8−CABALFLAGS :=-f NoEffects

8+#CABALFLAGS :=-f NoEffects

9+

10+

11+MACHINE := $(shell $(CC) -dumpmachine)

12+ifneq (, $(findstring darwin, $(MACHINE)))

13+ OS :=darwin

14+else

15+ifneq (, $(findstring cygwin, $(MACHINE)))

16+ OS :=windows

17+else

18+ifneq (, $(findstring mingw, $(MACHINE)))

19+ OS :=windows

20+else

21+ OS :=unix

22+endif

23+endif

24+endif

25+

26+ifeq ($(OS),darwin)

27+ SHLIB_SUFFIX :=.dylib

28+else

29+ifeq ($(OS),windows)

30+ SHLIB_SUFFIX :=.DLL

31+else

32+ SHLIB_SUFFIX :=.so

33+endif

34+endif

935

contribs/lib/SQLite3/Makefile+5−2

@@ -3,11 +3,14 @@

33

44.PHONY: all

55

6−sqltest : testunit.idr sqlite3.idr sqlite3api.o

6+sqltest : testunit.idr Sqlite3.idr sqlite3api.o

77 idris testunit.idr -o sqltest

88

99sqlite3api.o : sqlite3api.c

1010 gcc -c sqlite3api.c

11−

11+

12+sqlite3api.so: sqlite3api.c

13+ gcc -fPIC -o sqlite3api.so -shared sqlite3api.c

14+

1215all : sqltest sqlite3api.o

1316

contribs/lib/SQLite3/Sqlexpr.idrnew file+278

@@ -0,0 +1,278 @@

1+module Sqlexpr

2+import Prelude.List

3+

4+-----------------------------------------------------------------------------

5+-- |

6+-- Module : sqlexpr

7+-- Copyright : (c) The University of St Andrews, 2012

8+--

9+-- Implementations for SQLite query data type.

10+--

11+-----------------------------------------------------------------------------

12+

13+

14+-----------------------------------------------------------

15+-- | SQL data type

16+-----------------------------------------------------------

17+

18+data Value = VInt Int

19+ | VStr String

20+ | VFloat Float

21+ | VCol String

22+ | VNULL

23+

24+--Perhaps could extend this by adding

25+-- a dot operator to allow mapping

26+-- between table and column and

27+-- comparing different table columns.

28+

29+data Cond = Equals Value Value

30+ | MkGT Value Value

31+ | MkGTE Value Value

32+ | MkLT Value Value

33+ | MkLTE Value Value

34+ | MkNULL Value

35+

36+data SelVar = Cols (List String)

37+ | ALL

38+

39+data ColType = CInt String -- parsed as string "int"

40+ | Varchar String

41+

42+

43+

44+mutual

45+ data Clause = MkCond Cond

46+ | AND Clause Clause

47+ | OR Clause Clause

48+ | Empty

49+ | MkSQL SQL

50+

51+ data condClause = SET Clause

52+ | WHERE condClause Clause

53+

54+ data Constr = NOTNULL

55+ | UNIQUE Constr

56+ | None

57+ | PRIMARYKEY

58+ | FOREIGNKEY

59+ | CHECK

60+ | DEFAULT

61+

62+

63+ data SQL = SELECT SelVar SQL Clause

64+ | TBL (List String)

65+ | INSERT SQL (List Value)

66+ | INSERTC SQL (List Value) (List Value)

67+ | UPDATE SQL condClause

68+ | CREATE SQL (List (Value, ColType , Constr))

69+

70+-- remember to remove these funcs later

71+-- foldr1 : (a -> a -> a) -> List a -> a

72+-- foldr1 f [x] = x

73+-- foldr1 f (x::xs) = f x (foldr1 f xs)

74+

75+

76+-- unwords' : List (List Char) -> List Char

77+-- unwords' [] = []

78+-- unwords' ws = (foldr1 addSpace ws)

79+-- where

80+-- addSpace : List Char -> List Char -> List Char

81+-- addSpace w s = w ++ (' ' :: s)

82+--

83+--

84+-- unwords : List String -> String

85+-- unwords = pack . unwords' . map unpack

86+

87+-----------------------------------------------------------

88+-- | This function replaces values with question mark

89+-- following by an index number. It then puts the value

90+-- replaced, in the list.

91+-----------------------------------------------------------

92+

93+valString : List (Maybe (Int, Value)) -> Value -> (String, List (Maybe (Int, Value)))

94+valString xs (VInt x) = ("?" ++ show (cast (length xs) + 1), xs ++ [Just (cast ((length xs) + 1), (VInt x))])

95+valString xs (VStr x) = ("?" ++ show (cast (length xs) + 1), xs ++ [Just (cast ((length xs) + 1), (VStr x))])

96+valString xs (VFloat x) = ("?" ++ show (cast (length xs) + 1), xs ++ [Just (cast ((length xs) + 1), (VFloat x))])

97+valString xs (VCol n) = (n, xs)

98+

99+-----------------------------------------------------------

100+-- | This function calls valString on a list of Values

101+-- and separates the values by commas.

102+-----------------------------------------------------------

103+

104+listVal : List (Maybe (Int, Value)) -> List Value -> (String, List (Maybe (Int, Value)))

105+listVal xs [] = ("", xs)

106+listVal xs (v::vs) = let (str, newxs) = (valString xs v) in

107+ let (str', newxs') = listVal newxs vs in

108+ (unwords (intersperse "," (words (str) ++ words (str'))), newxs')

109+

110+-----------------------------------------------------------

111+-- | Parses the type of column to be created.

112+-----------------------------------------------------------

113+

114+getColType : List (Maybe (Int, Value)) -> ColType -> (String, List (Maybe (Int, Value)))

115+getColType xs (CInt x) = ("int", xs)

116+getColType xs (Varchar str) = ("varchar(255)", xs)

117+

118+-----------------------------------------------------------

119+-- | CREATE Constraints

120+-----------------------------------------------------------

121+

122+getConstr : List (Maybe (Int, Value)) -> Constr -> (String, List (Maybe (Int, Value)))

123+getConstr xs (NOTNULL) = ("NOT NULL", xs)

124+getConstr xs (UNIQUE constr) = ("NOT NULL UNIQUE", xs)

125+getConstr xs (PRIMARYKEY) = ("PRIMARY KEY", xs)

126+getConstr xs (FOREIGNKEY) = ("FOREIGN KEY", xs)

127+getConstr xs (CHECK) = ("CHECK", xs)

128+getConstr xs (DEFAULT) = ("DEFAULT", xs)

129+getConstr xs (None) = ("", xs)

130+

131+putBrackets : String -> String

132+putBrackets str = "(" ++ str ++ ")"

133+

134+-----------------------------------------------------------

135+-- | Used to detect a complex type in a nested SQLite query

136+-- This function is used for bracketing the nested queries.

137+-----------------------------------------------------------

138+complexType : SQL -> Bool

139+complexType (TBL tbl) = False

140+complexType (SELECT vars sql c) = True

141+

142+-----------------------------------------------------------

143+-- | Used in CREATE

144+-----------------------------------------------------------

145+

146+listValType : List (Maybe (Int, Value)) -> List (Value, ColType , Constr) -> (String, List (Maybe (Int, Value)))

147+listValType xs [] = ("", xs)

148+listValType xs ((val, types, constr) :: vs) =

149+ let (str , newxs) = valString xs val in

150+ let (str' , newxs') = getColType newxs types in

151+ let (str'', newxs'') = getConstr newxs' constr in

152+ let (finalstr, finalxs) = listValType newxs'' vs in

153+ (unwords (intersperse " " (words str ++ words str' ++ words str'' ++ words finalstr)) , finalxs)

154+

155+

156+-----------------------------------------------------------

157+-- | Evaluates a conditional WHERE clause

158+-----------------------------------------------------------

159+

160+evalCond : List (Maybe (Int, Value)) -> Cond -> (String, List (Maybe (Int, Value)))

161+evalCond xs (Equals val1 val2) = let (restring , newxs ) = valString xs val1 in

162+ let (restring2, newxs') = valString newxs val2 in

163+ (restring ++ " = " ++ restring2, newxs')

164+

165+evalCond xs (MkGT val1 val2) = let (restring , newxs ) = valString xs val1 in

166+ let (restring2, newxs') = valString newxs val2 in

167+ (restring ++ " > " ++ restring2, newxs')

168+

169+evalCond xs (MkGTE val1 val2) = let (restring , newxs ) = valString xs val1 in

170+ let (restring2, newxs') = valString newxs val2 in

171+ (restring ++ " >= " ++ restring2, newxs')

172+

173+evalCond xs (MkLT val1 val2) = let (restring , newxs ) = valString xs val1 in

174+ let (restring2, newxs') = valString newxs val2 in

175+ (restring ++ " < " ++ restring2, newxs')

176+

177+evalCond xs (MkLTE val1 val2) = let (restring , newxs ) = valString xs val1 in

178+ let (restring2, newxs') = valString newxs val2 in

179+ (restring ++ " =< " ++ restring2, newxs')

180+

181+evalCond xs (MkNULL val) = let (restring , newxs ) = valString xs val in

182+ (restring ++ " IS NULL " , newxs)

183+

184+

185+-----------------------------------------------------------

186+-- | Evaluates clauses

187+-- Supports WHERE Clause

188+-- WHERE Clause And Another-Clause

189+-- WHERE Clause Or Another-Clause

190+-----------------------------------------------------------

191+clauseString : List (Maybe (Int, Value)) -> Clause -> (String, List (Maybe (Int, Value)))

192+

193+clauseString xs (Empty) = ("" , []) -- No condition

194+clauseString xs (MkCond cond') = let (condstr, newxs) = evalCond xs cond' in

195+ (condstr , newxs)

196+

197+clauseString xs (AND c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

198+ let (clausestr2, newxs') = clauseString newxs c2 in

199+ (clausestr ++ " AND " ++ clausestr2 , newxs')

200+

201+clauseString xs (OR c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

202+ let (clausestr2, newxs') = clauseString newxs c2 in

203+ (clausestr ++ " OR " ++ clausestr2 , newxs')

204+

205+

206+-----------------------------------------------------------

207+-- | Evaluates conditional clauses.

208+-----------------------------------------------------------

209+

210+condClauseStr : List (Maybe (Int, Value)) -> condClause -> (String, List (Maybe (Int, Value)))

211+condClauseStr xs (SET setcl) = let (condstr, newxs) = clauseString xs setcl in

212+ (" SET " ++ condstr, newxs)

213+

214+condClauseStr xs (WHERE setcl1 setcl2) = let (condstr, newxs) = condClauseStr xs setcl1 in

215+ let (condstr', newxs') = clauseString newxs setcl2 in

216+ ( condstr ++ " WHERE " ++ condstr', newxs')

217+

218+

219+-----------------------------------------------------------

220+-- | Evaluates queries by calling the other functions

221+-- on each part of the query

222+-----------------------------------------------------------

223+evalSQL : List (Maybe (Int, Value)) -> SQL -> (String, List (Maybe (Int, Value)))

224+-- SELECT data from tbl1 where num > (SELECT num from tbl1 where num = 24)

225+-- evalSQL [] ((SELECT ALL)(TBL "tbl")(MkSQL ((SELECT ALL) (TBL "tbl")(MkCond (VCol "))))

226+-- NTBF

227+--clauseString xs (MkSQL sql) = (evalSQL xs sql)

228+

229+-- Separate list of tables

230+-- For complex type, return list returned by evalSQL

231+-- And add brackets

232+evalSQL xs (TBL tbl) = (unwords (intersperse "," ( tbl)), xs)

233+evalSQL xs (SELECT vars sql' c) =

234+ let (sqlstring, newxs) = evalSQL xs sql' in

235+ let (csstring, newxs') = clauseString newxs c in

236+ case c of

237+ Empty => case vars of

238+ ALL => if complexType sql'

239+ then ("SELECT " ++ "*" ++ " FROM " ++

240+ putBrackets sqlstring ++ csstring, newxs)

241+ else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring ++

242+ csstring, newxs')

243+ Cols selvar => if complexType sql'

244+ then ("SELECT " ++ unwords selvar ++

245+ " FROM " ++ putBrackets sqlstring ++ csstring, newxs)

246+ else ("SELECT " ++ unwords selvar ++ " FROM " ++ sqlstring ++

247+ csstring, newxs')

248+ _ => case vars of

249+ ALL => if complexType sql'

250+ then ("SELECT " ++ "*" ++ " FROM " ++

251+ " WHERE " ++ csstring, newxs)

252+ else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring

253+ ++ " WHERE " ++ csstring, newxs')

254+ Cols selvar => if complexType sql'

255+ then ("SELECT " ++ (unwords selvar) ++ " FROM " ++

256+ putBrackets sqlstring ++ " WHERE " ++

257+ csstring , newxs)

258+ else ("SELECT " ++ (unwords selvar) ++ " FROM " ++ sqlstring ++

259+ " WHERE " ++ csstring, newxs')

260+

261+

262+evalSQL xs (INSERT sql vals) = let (tblname, newvals) = evalSQL xs sql in

263+ let (str, newxs ) = listVal newvals vals in

264+ ("INSERT INTO " ++ tblname ++ " VALUES (" ++ str ++ ")", newxs)

265+

266+evalSQL xs (INSERTC sql cols vals) = let (tblname, newvals) = evalSQL xs sql in

267+ let (strcol, newcol) = listVal newvals cols in

268+ let (strval, newcolval) = listVal newcol vals in

269+ ("INSERT INTO " ++ tblname ++ "(" ++ strcol ++ ")" ++ "VALUES (" ++ strval ++ ")", newcolval)

270+

271+

272+evalSQL xs (UPDATE sql cl) = let (tblname, newxs) = evalSQL xs sql in

273+ let (csstring, newxs') = condClauseStr newxs cl in

274+ ("UPDATE " ++ tblname ++ csstring, newxs')

275+

276+evalSQL xs (CREATE sql details) = let (sqlstring, newxs) = evalSQL xs sql in

277+ let (csstring, newxs') = listValType newxs details in

278+ ("CREATE TABLE " ++ sqlstring ++ "(" ++ csstring ++ ")", newxs')

contribs/lib/SQLite3/sqlite3.idr → contribs/lib/SQLite3/Sqlite3.idrrenamed+172−155

@@ -22,7 +22,7 @@ data DBVal = DBInt Int

2222 | DBText String

2323 | DBFloat Float

2424 | DBNull

25−

25+

2626-- Database pointer

2727data DBPointer = MkDBPointer Ptr

2828-- Table pointer

@@ -30,16 +30,29 @@ data TBPointer = MkTBPointer Ptr

3030-- Statement pointer

3131data StmtPtr = MkStmtPtr Ptr

3232

33−Table : Set

33+Table : Type

3434Table = List (List DBVal)

3535

3636-- ForMap used in to_list_v1

37−forM : Monad m => List a -> (a -> m b) -> m (List b)

38−forM f xs = mapM xs f

37+forM : Applicative f => List a -> (a -> f b) -> f (List b)

38+forM xs f = (sequence (map f xs))

3939

4040-- Neater error handling done using DB

4141data DB a = MkDB (IO (Either String a))

4242

43+instance Functor DB where

44+ fmap f (MkDB action) = MkDB (do res <- action

45+ return (fmap f res))

46+

47+

48+instance Applicative DB where

49+ pure = MkDB . return . Right

50+ (MkDB f) <$> (MkDB x) = MkDB (do f' <- f

51+ case f' of

52+ Left err => return (Left err)

53+ Right op => x >>= (return . fmap op))

54+

55+

4356instance Monad DB where

4457 (MkDB l) >>= k = MkDB (do c <- l

4558 case c of

@@ -63,14 +76,14 @@ runDB : DB a -> IO a

6376runDB (MkDB f) = do f' <- f

6477 case f' of

6578 Right v => return v

66− Left str => ioError str

67−

79+ Left str => ioError str

80+

6881-----------------------------------------------------------------------------

6982-- | Opens an SQLite database file as specified by the String name argument.

7083-----------------------------------------------------------------------------

71−

84+

7285open_db : String -> DB DBPointer

73−open_db name = do x <- liftIO(mkForeign (FFun "sqlite3_open_idr" [FString] FPtr) name)

86+open_db name = do x <- liftIO (mkForeign (FFun "sqlite3_open_idr" [FString] FPtr) name)

7487 return (MkDBPointer x)

7588

7689-----------------------------------------------------------------------------

@@ -78,38 +91,38 @@ open_db name = do x <- liftIO(mkForeign (FFun "sqlite3_open_idr" [FString] FPtr)

7891-----------------------------------------------------------------------------

7992

8093close_db : DBPointer -> DB Int

81−close_db (MkDBPointer pointer) = liftIO (mkForeign (FFun "sqlite3_close_idr" [FPtr] FInt)pointer)

94+close_db (MkDBPointer pointer) = liftIO (mkForeign (FFun "sqlite3_close_idr" [FPtr] FInt) pointer)

8295

8396-----------------------------------------------------------------------------

8497-- | Wrapper around prepare, step and finalize.

8598-----------------------------------------------------------------------------

86−

99+

87100exec_db : DBPointer -> String -> DB Int

88−exec_db (MkDBPointer pointer) stmt = do

89− x <- liftIO(mkForeign (FFun "sqlite3_exec_idr" [FPtr, FString] FInt)pointer stmt)

101+exec_db (MkDBPointer pointer) stmt = do

102+ x <- liftIO (mkForeign (FFun "sqlite3_exec_idr" [FPtr, FString] FInt) pointer stmt)

90103 if (x == 1)

91− then fail "Could not execute."

92− else return x

104+ then fail "Could not execute."

105+ else return x

93106

94107-----------------------------------------------------------------------------

95108-- | Executes a prepared query. Use of this version is recommended.

96109-----------------------------------------------------------------------------

97110

98111exec_db_v2 : StmtPtr -> DB Int

99−exec_db_v2 (MkStmtPtr pointer) = do

112+exec_db_v2 (MkStmtPtr pointer) = do

100113 x <- liftIO (mkForeign (FFun "exec_db" [FPtr] FInt) pointer)

101114 if (x == 21)

102− then fail "No data returned."

103− else return x

104−

115+ then fail "No data returned."

116+ else return x

117+

105118-----------------------------------------------------------------------------

106119-- | Returns the error stored in the buffer by exec_db function.

107120-- This function can only be used with exec_db and get_table.

108121-- Only these functions store any occured error in the buffer array.

109122-----------------------------------------------------------------------------

110−

123+

111124get_error : DBPointer -> IO String

112−get_error (MkDBPointer pointer) =mkForeign (FFun "sqlite3_get_error" [FPtr] FString)pointer

125+get_error (MkDBPointer pointer) = mkForeign (FFun "sqlite3_get_error" [FPtr] FString) pointer

113126

114127

115128-----------------------------------------------------------------------------

@@ -117,14 +130,14 @@ get_error (MkDBPointer pointer) =mkForeign (FFun "sqlite3_get_error" [FPtr] FStr

117130-- Returns a pointer to a Statement pointer on a successful call.

118131-- Returns a null pointer on a failure.

119132-----------------------------------------------------------------------------

120−

133+

121134prepare_db : DBPointer -> String -> DB StmtPtr

122135prepare_db (MkDBPointer pointer) cmd = do

123− result <- liftIO(mkForeign (FFun "sqlite3_prepare_idr" [FPtr, FString] FPtr)pointer cmd)

124− flag <- liftIO(nullPtr result)

136+ result <- liftIO (mkForeign (FFun "sqlite3_prepare_idr" [FPtr, FString] FPtr) pointer cmd)

137+ flag <- liftIO (nullPtr result)

125138 if flag

126− then fail "Error occured while preparing"

127− else return (MkStmtPtr result)

139+ then fail "Error occured while preparing"

140+ else return (MkStmtPtr result)

128141

129142-----------------------------------------------------------------------------

130143-- | Returns the error stored in the buffer by exec_db function.

@@ -136,81 +149,92 @@ step_db : StmtPtr -> DB Int

136149step_db (MkStmtPtr pointer)= do

137150 x <- liftIO (mkForeign (FFun "sqlite3_step_idr" [FPtr] FInt)pointer)

138151 if ( x == 101)

139− then fail "SQLITE_DONE"

140− else return x

152+ then fail "SQLITE_DONE"

153+ else return x

141154

142155-----------------------------------------------------------------------------

143−-- | Deletes a prepared statement. This function must be called after

156+-- | Deletes a prepared statement. This function must be called after

144157-- prepare function.

145158-----------------------------------------------------------------------------

146159

147160finalize_db : StmtPtr -> DB Int

148−finalize_db (MkStmtPtr pointer) = do

149− x <- liftIO (mkForeign (FFun "sqlite3_finalize_idr" [FPtr] FInt)pointer)

161+finalize_db (MkStmtPtr pointer) = do

162+ x <- liftIO (mkForeign (FFun "sqlite3_finalize_idr" [FPtr] FInt) pointer)

150163 if (x /= 0)

151− then fail "Could not finalize"

152− else return x

164+ then fail "Could not finalize"

165+ else return x

153166

154167-----------------------------------------------------------------------------

155168-- | Resets a prepared statement pointer back to its initial state.

156169-----------------------------------------------------------------------------

157170

158171reset_db : StmtPtr -> DB Int

159−reset_db (MkStmtPtr pointer) = do

160− x <- liftIO(mkForeign (FFun "sqlite3_reset_idr" [FPtr] FInt)pointer)

161− if (x /=0)

162− then fail "Could not reset"

163− else return x

172+reset_db (MkStmtPtr pointer) = do

173+ x <- liftIO (mkForeign (FFun "sqlite3_reset_idr" [FPtr] FInt) pointer)

174+ if (x /= 0)

175+ then fail "Could not reset"

176+ else return x

164177

165178-----------------------------------------------------------------------------

166179-- | These routines obtain column information.

167180-----------------------------------------------------------------------------

168181

169182column_count : DBPointer -> IO (Either String Int)

170−column_count (MkDBPointer pointer) = do

171− x <- mkForeign (FFun "sqlite3_column_count_idr" [FPtr] FInt)pointer

172− if (x == 0 )

173− then return (Left "No Data")

174− else return (Right x)

183+column_count (MkDBPointer pointer) = do

184+ x <- mkForeign (FFun "sqlite3_column_count_idr" [FPtr] FInt) pointer

185+ return $ if (x == 0 )

186+ then Left "No Data"

187+ else (Right x)

175188

176189column_name : DBPointer -> Int -> IO String

177−column_name (MkDBPointer pointer) iCol =mkForeign (FFun "sqlite3_column_name_idr" [FPtr, FInt] FString)pointer iCol

178−

190+column_name (MkDBPointer pointer) iCol =

191+ mkForeign (FFun "sqlite3_column_name_idr" [FPtr, FInt] FString) pointer iCol

192+

179193column_decltype : DBPointer -> Int -> IO String

180−column_decltype (MkDBPointer pointer) iCol =mkForeign (FFun "sqlite3_column_decltype_idr" [FPtr, FInt] FString)pointer iCol

194+column_decltype (MkDBPointer pointer) iCol =

195+ mkForeign (FFun "sqlite3_column_decltype_idr" [FPtr, FInt] FString) pointer iCol

181196

182197

183198column_bytes : DBPointer -> Int -> IO Int

184−column_bytes (MkDBPointer pointer) iCol =mkForeign (FFun "sqlite3_column_bytes_idr" [FPtr, FInt] FInt)pointer iCol

199+column_bytes (MkDBPointer pointer) iCol =

200+ mkForeign (FFun "sqlite3_column_bytes_idr" [FPtr, FInt] FInt) pointer iCol

185201

186202

187203column_blob : DBPointer -> Int -> IO String

188−column_blob (MkDBPointer pointer) iCol =mkForeign (FFun "sqlite3_column_bytes_idr" [FPtr, FInt] FString)pointer iCol

204+column_blob (MkDBPointer pointer) iCol =

205+ mkForeign (FFun "sqlite3_column_bytes_idr" [FPtr, FInt] FString) pointer iCol

189206

190207

191208column_text : DBPointer -> Int -> IO String

192−column_text (MkDBPointer pointer) iCol =mkForeign (FFun "sqlite3_column_text_idr" [FPtr, FInt] FString)pointer iCol

209+column_text (MkDBPointer pointer) iCol =

210+ mkForeign (FFun "sqlite3_column_text_idr" [FPtr, FInt] FString) pointer iCol

193211

194212

195213column_Int : DBPointer -> Int -> IO Int

196−column_Int (MkDBPointer pointer) iCol =mkForeign (FFun "sqlite3_column_int_idr" [FPtr, FInt] FInt)pointer iCol

214+column_Int (MkDBPointer pointer) iCol =

215+ mkForeign (FFun "sqlite3_column_int_idr" [FPtr, FInt] FInt) pointer iCol

197216

198217-----------------------------------------------------------------------------

199218-- | These routines support some of SQLite backup functions.

200219-----------------------------------------------------------------------------

201220

202−backup_init : DBPointer -> String -> DBPointer -> String -> IO DBPointer

203−backup_init (MkDBPointer des_pointer) destName (MkDBPointer src_pointer) srcName = do x <- mkForeign (FFun "sqlite3_backup_init_idr" [FPtr,FString, FPtr, FString] FPtr)des_pointer destName src_pointer srcName

204− return (MkDBPointer x)

221+backup_init : DBPointer -> String -> DBPointer -> String -> IO DBPointer

222+backup_init (MkDBPointer des_pointer) destName (MkDBPointer src_pointer) srcName =

223+ do x <- mkForeign (FFun "sqlite3_backup_init_idr" [FPtr,FString, FPtr, FString] FPtr)

224+ des_pointer destName src_pointer srcName

225+ return (MkDBPointer x)

205226

206227backup_step : DBPointer -> Int -> IO Int

207−backup_step (MkDBPointer pointer) nPage =mkForeign (FFun "sqlite3_backup_step_idr" [FPtr, FInt] FInt)pointer nPage

228+backup_step (MkDBPointer pointer) nPage =

229+ mkForeign (FFun "sqlite3_backup_step_idr" [FPtr, FInt] FInt) pointer nPage

208230

209231backup_finish : DBPointer -> IO Int

210−backup_finish (MkDBPointer pointer) =mkForeign (FFun "sqlite3_backup_finish_idr" [FPtr] FInt)pointer

232+backup_finish (MkDBPointer pointer) =

233+ mkForeign (FFun "sqlite3_backup_finish_idr" [FPtr] FInt) pointer

211234

212235backup_remaining : DBPointer -> IO Int

213−backup_remaining (MkDBPointer pointer) =mkForeign (FFun "sqlite3_backup_remaining_idr" [FPtr] FInt)pointer

236+backup_remaining (MkDBPointer pointer) =

237+ mkForeign (FFun "sqlite3_backup_remaining_idr" [FPtr] FInt) pointer

214238

215239

216240-----------------------------------------------------------------------------

@@ -221,104 +245,98 @@ backup_remaining (MkDBPointer pointer) =mkForeign (FFun "sqlite3_backup_remainin

221245-----------------------------------------------------------------------------

222246

223247get_table : DBPointer -> String -> DB TBPointer

224−get_table (MkDBPointer pointer) name = do

225− x <- liftIO(mkForeign (FFun "sqlite3_get_table_idr" [FPtr, FString] FPtr)pointer name)

226− flag <- liftIO(nullPtr x)

248+get_table (MkDBPointer pointer) name = do

249+ x <- liftIO(mkForeign (FFun "sqlite3_get_table_idr" [FPtr, FString] FPtr) pointer name)

250+ flag <- liftIO (nullPtr x)

227251 if flag

228− then do x <- liftIO(get_error_table pointer) ; fail x

229− else return (MkTBPointer x)

252+ then do x <- liftIO(get_error_table pointer) ; fail x

253+ else return (MkTBPointer x)

230254 where

231255 get_error_table : Ptr-> IO String

232− get_error_table pointer = do x <- mkForeign (FFun "sqlite3_get_error" [FPtr] FString)pointer

256+ get_error_table pointer = do x <- mkForeign (FFun "sqlite3_get_error" [FPtr] FString) pointer

233257 return x

234258

235259

236260free_table : TBPointer -> IO ()

237−free_table (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_free_table_idr" [FPtr] FUnit)pointer

261+free_table (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_free_table_idr" [FPtr] FUnit) pointer

238262 return ()

239−

263+

240264-----------------------------------------------------------------------------

241265-- | This version of these function obtain the row and column number

242266-- from the Table struct. These functions are only used with get_table.

243267-----------------------------------------------------------------------------

244268

245269num_row : TBPointer -> IO Int

246−num_row (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_row" [FPtr] FInt)pointer

247− return (x)

270+num_row (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_row" [FPtr] FInt) pointer

271+ return x

248272

249273num_col : TBPointer -> IO Int

250−num_col (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_col" [FPtr] FInt)pointer

251− return (x)

252−

274+num_col (MkTBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_col" [FPtr] FInt) pointer

275+ return x

276+

253277-----------------------------------------------------------------------------

254278-- | This version of these function obtain the row and column number

255279-- from the Database struct.

256280-----------------------------------------------------------------------------

257281

258282num_row_v2 : DBPointer -> IO Int

259−num_row_v2 (MkDBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_row_v2" [FPtr] FInt)pointer

260− return (x)

283+num_row_v2 (MkDBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_row_v2" [FPtr] FInt) pointer

284+ return x

261285

262286num_col_v2 : DBPointer -> IO Int

263−num_col_v2 (MkDBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_col_v2" [FPtr] FInt)pointer

264− return (x)

265−

287+num_col_v2 (MkDBPointer pointer) = do x <- mkForeign (FFun "sqlite3_get_num_col_v2" [FPtr] FInt) pointer

288+ return x

289+

266290-----------------------------------------------------------------------------

267291-- | This function prints the result of a query by checking the type

268292-- of each value returned, it then calls the appropriate function.

269293-- Ther result is one of the DBVal variants.

270294-----------------------------------------------------------------------------

271−

295+

272296get_data : DBPointer -> Int -> Int -> IO DBVal

273297get_data (MkDBPointer pointer) row col = do

274298 ty <- get_data_type pointer row col

275299 helper ty

276− where

277− get_data_type : Ptr ->Int -> Int -> IO Int

278− get_data_type pointer row col =mkForeign (FFun "sqlite3_get_data_type" [FPtr, FInt, FInt] FInt)pointer row col

279−

280− get_data_val_int : Ptr -> Int -> IO Int

281− get_data_val_int pointer col =mkForeign (FFun "sqlite3_get_val_int" [FPtr,FInt] FInt)pointer col

282−

283− get_data_val_text : Ptr -> Int -> IO String

284− get_data_val_text pointer col =mkForeign (FFun "sqlite3_get_val_text" [FPtr, FInt] FString)pointer col

285−

286−

287−

288− get_data_val_float : Ptr -> Int -> IO Float

289− get_data_val_float pointer col =mkForeign (FFun "sqlite3_get_float" [FPtr, FInt] FFloat)pointer col

290−

291− helper : Int -> IO DBVal

292− helper 1 = do i <- get_data_val_int pointer col ; return (DBInt i)

293− helper 2 = do i <- get_data_val_float pointer col ; return (DBFloat i)

294− helper 3 = do i <- get_data_val_text pointer col; return (DBText i)

295− helper _ =return (DBNull)

296−

300+ where get_data_type : Ptr ->Int -> Int -> IO Int

301+ get_data_type pointer row col =

302+ mkForeign (FFun "sqlite3_get_data_type" [FPtr, FInt, FInt] FInt) pointer row col

303+ get_data_val_int : Ptr -> Int -> IO Int

304+ get_data_val_int pointer col =

305+ mkForeign (FFun "sqlite3_get_val_int" [FPtr,FInt] FInt) pointer col

306+

307+ get_data_val_text : Ptr -> Int -> IO String

308+ get_data_val_text pointer col =

309+ mkForeign (FFun "sqlite3_get_val_text" [FPtr, FInt] FString) pointer col

310+

311+ get_data_val_float : Ptr -> Int -> IO Float

312+ get_data_val_float pointer col =

313+ mkForeign (FFun "sqlite3_get_float" [FPtr, FInt] FFloat) pointer col

314+

315+ helper : Int -> IO DBVal

316+ helper 1 = do i <- get_data_val_int pointer col ; return (DBInt i)

317+ helper 2 = do i <- get_data_val_float pointer col ; return (DBFloat i)

318+ helper 3 = do i <- get_data_val_text pointer col; return (DBText i)

319+ helper _ = return DBNull

320+

297321-----------------------------------------------------------------------------

298322-- | This function makes use of get_data to get all the result.

299323-----------------------------------------------------------------------------

300324

301−toList_v1 : DBPointer -> DB Table

302−toList_v1 db = do

303− nbR <- liftIO (num_row_v2 db)

304− nmC <- liftIO (num_col_v2 db)

305− res <- forM [0..(nbR-1)] (\ i =>

306− forM [0..(nmC-1)] (\ j =>

307− liftIO(get_data db i j)

308−

309− )

310− )

311− return res

312−

313−

325+toList_v1 : DBPointer -> DB Table

326+toList_v1 db = do nbR <- liftIO (num_row_v2 db)

327+ nmC <- liftIO (num_col_v2 db)

328+ res <- liftIO $ forM [0..(nbR-1)] $ \ i =>

329+ forM [0..(nmC-1)] $ \ j => get_data db i j

330+ return (the (List (List DBVal)) res)

331+

314332strcat : String -> String-> String

315−strcat str1 str2 = (str1 ++ str2)

333+strcat str1 str2 = str1 ++ str2

316334

317335-----------------------------------------------------------------------------

318336-- | This version of toList retunrs result from get_table

319337-- This could be removed if not needed in the future.

320338-----------------------------------------------------------------------------

321−

339+

322340--toList_v2 : String -> String -> DBPointer -> DB Table

323341--toList_v2 name stmt x = do

324342-- ptr <- (get_table x (stmt))

@@ -327,12 +345,12 @@ strcat str1 str2 = (str1 ++ str2)

327345-- res <- forM [0..(nbR-1)] (\ i =>

328346-- forM [0..(nmC-1)] (\ j =>

329347-- liftIO(get_data x name i j)

330−--

348+--

331349-- )

332350-- )

333351-- liftIO (free_table ptr)

334−-- return res

335−

352+-- return res

353+

336354

337355-----------------------------------------------------------------------------

338356-- | These routines support binding the types supported by Idris.

@@ -341,68 +359,67 @@ strcat str1 str2 = (str1 ++ str2)

341359-----------------------------------------------------------------------------

342360

343361bind_int : StmtPtr -> Int -> Int -> DB StmtPtr

344−bind_int (MkStmtPtr pointer) indexval val = do

345− x <- liftIO(mkForeign (FFun "sqlite3_bind_int_idr" [FPtr, FInt, FInt] FPtr)pointer indexval val)

346− flag <- liftIO(nullPtr x)

362+bind_int (MkStmtPtr pointer) indexval val = do

363+ x <- liftIO (mkForeign (FFun "sqlite3_bind_int_idr" [FPtr, FInt, FInt] FPtr) pointer indexval val)

364+ flag <- liftIO (nullPtr x)

347365 if flag

348− then fail "Could not bind int."

349− else return (MkStmtPtr x)

350−

351−

366+ then fail "Could not bind int."

367+ else return (MkStmtPtr x)

368+

369+

352370bind_float : StmtPtr -> Int -> Float -> DB StmtPtr

353−bind_float (MkStmtPtr pointer) indexval val = do

354− x <- liftIO(mkForeign (FFun "sqlite3_bind_float_idr" [FPtr, FInt, FFloat] FPtr)pointer indexval val)

355− flag <- liftIO(nullPtr x)

371+bind_float (MkStmtPtr pointer) indexval val = do

372+ x <- liftIO (mkForeign (FFun "sqlite3_bind_float_idr" [FPtr, FInt, FFloat] FPtr) pointer indexval val)

373+ flag <- liftIO (nullPtr x)

356374 if flag

357− then fail "Could not bind float."

358− else return (MkStmtPtr x)

375+ then fail "Could not bind float."

376+ else return (MkStmtPtr x)

359377

360378bind_text : StmtPtr -> String -> Int -> Int -> DB StmtPtr

361379bind_text (MkStmtPtr pointer) text indexval lengthval = do

362− x <- liftIO(mkForeign (FFun "sqlite3_bind_text_idr" [FPtr, FString, FInt, FInt] FPtr)pointer text indexval lengthval)

363− flag <- liftIO(nullPtr x)

380+ x <- liftIO (mkForeign (FFun "sqlite3_bind_text_idr" [FPtr, FString, FInt, FInt] FPtr)

381+ pointer text indexval lengthval)

382+ flag <- liftIO(nullPtr x)

364383 if flag

365− then fail "Could not bind text."

366− else return (MkStmtPtr x)

384+ then fail "Could not bind text."

385+ else return (MkStmtPtr x)

367386

368387bind_null : StmtPtr -> Int -> DB StmtPtr

369−bind_null (MkStmtPtr pointer) indexval = do

370− x <- liftIO(mkForeign (FFun "sqlite3_bind_null_idr" [FPtr, FInt] FPtr)pointer indexval)

371− flag <- liftIO(nullPtr x)

388+bind_null (MkStmtPtr pointer) indexval = do

389+ x <- liftIO (mkForeign (FFun "sqlite3_bind_null_idr" [FPtr, FInt] FPtr) pointer indexval)

390+ flag <- liftIO (nullPtr x)

372391 if flag

373− then fail "Could not bind null."

374− else return (MkStmtPtr x)

392+ then fail "Could not bind null."

393+ else return (MkStmtPtr x)

375394

376395-----------------------------------------------------------------------------

377396-- | String Length

378397-----------------------------------------------------------------------------

379−

398+

380399strlen : String -> DB Int

381−strlen str = liftIO(mkForeign (FFun "strLength" [FString] FInt) str)

382−

400+strlen str = liftIO (mkForeign (FFun "strLength" [FString] FInt) str)

401+

383402instance Show DBVal where

384− show (DBInt i) = "Int val: " ++ show i ++ "\n"

385− show (DBText i) = "Text val: " ++ show i ++ "\n"

386− show (DBFloat i) = "Float val: " ++ show i ++ "\n"

387− show (DBNull ) = "NULL"

403+ show (DBInt i) = "Int val: " ++ show i ++ "\n"

404+ show (DBText i) = "Text val: " ++ show i ++ "\n"

405+ show (DBFloat i) = "Float val: " ++ show i ++ "\n"

406+ show (DBNull ) = "NULL"

388407

389408-----------------------------------------------------------------------------

390409-- | Multi bind a list of values.

391410-----------------------------------------------------------------------------

392411

393412bindMulti : StmtPtr-> List (Maybe (Int, Value)) -> DB StmtPtr

394−bindMulti pointer [] = return pointer

395−bindMulti pointer (Nothing :: vs) = bindMulti pointer vs

396−bindMulti pointer ((Just (indexs, val))::vs) = case val of

397− (VInt intval) => do x <- bind_int pointer indexs intval

398− bindMulti(x) vs

399−

400− (VStr strval) => do len <- strlen strval

401− x <- bind_text pointer strval indexs len

402− bindMulti(x) vs

403−

404−

405− (VFloat floatval) => do x <- bind_float pointer indexs floatval

406−

407− bindMulti(x) vs

413+bindMulti pointer [] = return pointer

414+bindMulti pointer (Nothing :: vs) = bindMulti pointer vs

415+bindMulti pointer ((Just (indexs, (VInt i)))::vs) =

416+ do x <- bind_int pointer indexs i

417+ bindMulti x vs

418+bindMulti pointer ((Just (indexs, (VStr s)))::vs) =

419+ do len <- strlen s

420+ x <- bind_text pointer s indexs len

421+ bindMulti x vs

422+bindMulti pointer ((Just (indexs, (VFloat f)))::vs) =

423+ do x <- bind_float pointer indexs f

424+ bindMulti x vs

408425

contribs/lib/SQLite3/sqlexpr.idrdeleted−274

@@ -1,274 +0,0 @@

1−module Sqlexpr

2−import Prelude.List

3−

4−-----------------------------------------------------------------------------

5−-- |

6−-- Module : sqlexpr

7−-- Copyright : (c) The University of St Andrews, 2012

8−--

9−-- Implementations for SQLite query data type.

10−--

11−-----------------------------------------------------------------------------

12−

13−

14−-----------------------------------------------------------

15−-- | SQL data type

16−-----------------------------------------------------------

17−

18−data Value = VInt Int

19− |VStr String

20− |VFloat Float

21− |VCol String

22− |VNULL

23−

24−--Perhaps could extend this by adding

25−-- a dot operator to allow mapping

26−-- between table and column and

27−-- comparing different table columns.

28−

29−data Cond = Equals Value Value

30− |MkGT Value Value

31− |MkGTE Value Value

32− |MkLT Value Value

33− |MkLTE Value Value

34− |MkNULL Value

35−

36−

37−data Clause = MkCond Cond

38− | AND Clause Clause

39− | OR Clause Clause

40− | Empty

41− | MkSQL SQL

42−

43−data condClause = SET Clause

44− |WHERE condClause Clause

45−

46−data SelVar = Cols (List String)

47− |ALL

48−

49−data ColType = CInt String -- parsed as string "int"

50− |Varchar String

51−

52−data Constr = NOTNULL

53− | UNIQUE Constr

54− | None

55− | PRIMARYKEY

56− | FOREIGNKEY

57− | CHECK

58− | DEFAULT

59−

60−

61−data SQL = SELECT SelVar SQL Clause

62− | TBL (List String)

63− | INSERT SQL (List Value)

64− | INSERTC SQL (List Value) (List Value)

65− | UPDATE SQL condClause

66− | CREATE SQL (List (Value, ColType , Constr))

67−

68−-- remember to remove these funcs later

69−-- foldr1 : (a -> a -> a) -> List a -> a

70−-- foldr1 f [x] = x

71−-- foldr1 f (x::xs) = f x (foldr1 f xs)

72−

73−

74−-- unwords' : List (List Char) -> List Char

75−-- unwords' [] = []

76−-- unwords' ws = (foldr1 addSpace ws)

77−-- where

78−-- addSpace : List Char -> List Char -> List Char

79−-- addSpace w s = w ++ (' ' :: s)

80−--

81−--

82−-- unwords : List String -> String

83−-- unwords = pack . unwords' . map unpack

84−

85−-----------------------------------------------------------

86−-- | This function replaces values with question mark

87−-- following by an index number. It then puts the value

88−-- replaced, in the list.

89−-----------------------------------------------------------

90−

91−valString : List (Maybe(Int, Value)) -> Value -> (String, List (Maybe(Int, Value)))

92−valString xs (VInt x) = ("?" ++ show (cast(length xs)+1), xs ++ [Just (cast((length xs)+1),(VInt x))])

93−valString xs (VStr x) = ("?" ++ show (cast(length xs)+1), xs ++ [Just (cast((length xs)+1),(VStr x))])

94−valString xs (VFloat x) = ("?" ++ show (cast(length xs)+1), xs ++ [Just (cast((length xs)+1),(VFloat x))])

95−valString xs (VCol n) = (n, xs)

96−

97−-----------------------------------------------------------

98−-- | This function calls valString on a list of Values

99−-- and separates the values by commas.

100−-----------------------------------------------------------

101−

102−listVal : List (Maybe(Int, Value)) -> List Value -> (String, List (Maybe(Int, Value)))

103−listVal xs [] = ("", xs)

104−listVal xs (v::vs) = let (str, newxs) = (valString xs v) in

105− let (str', newxs') = listVal newxs vs in

106− ((unwords(intersperse "," (words(str) ++ words (str')))), newxs')

107−

108−-----------------------------------------------------------

109−-- | Parses the type of column to be created.

110−-----------------------------------------------------------

111−

112−getColType : List (Maybe(Int, Value)) -> ColType -> (String, List (Maybe(Int, Value)))

113−getColType xs (CInt x) = ("int", xs)

114−getColType xs (Varchar str) = ("varchar(255)", xs)

115−

116−-----------------------------------------------------------

117−-- | CREATE Constraints

118−-----------------------------------------------------------

119−

120−getConstr : List (Maybe(Int, Value)) -> Constr -> (String, List (Maybe(Int, Value)))

121−getConstr xs (NOTNULL) = ("NOT NULL", xs)

122−getConstr xs (UNIQUE constr) = ("NOT NULL UNIQUE", xs)

123−getConstr xs (PRIMARYKEY) = ("PRIMARY KEY", xs)

124−getConstr xs (FOREIGNKEY) = ("FOREIGN KEY", xs)

125−getConstr xs (CHECK) = ("CHECK", xs)

126−getConstr xs (DEFAULT) = ("DEFAULT", xs)

127−getConstr xs (None) = ("", xs)

128−

129−putBrackets : String -> String

130−putBrackets str = "(" ++ str ++ ")"

131−

132−-----------------------------------------------------------

133−-- | Used to detect a complex type in a nested SQLite query

134−-- This function is used for bracketing the nested queries.

135−-----------------------------------------------------------

136−complexType : SQL -> Bool

137−complexType (TBL tbl) = False

138−complexType (SELECT vars sql c) = True

139−

140−-----------------------------------------------------------

141−-- | Used in CREATE

142−-----------------------------------------------------------

143−

144−listValType : List (Maybe(Int, Value)) -> List (Value, ColType , Constr) -> (String, List (Maybe(Int, Value)))

145−listValType xs [] = ("", xs)

146−listValType xs ((val, types, constr) :: vs) = let (str , newxs) = valString xs val in

147− let (str' , newxs') = getColType newxs types in

148− let (str'', newxs'') = getConstr newxs' constr in

149− let (finalstr, finalxs) = listValType newxs'' vs in

150− ((unwords(intersperse " " (words(str) ++ words(str') ++ words(str'') ++ words(finalstr)))) , finalxs)

151−

152−

153−-----------------------------------------------------------

154−-- | Evaluates a conditional WHERE clause

155−-----------------------------------------------------------

156−

157−evalCond : List (Maybe(Int, Value)) -> Cond -> (String, List (Maybe(Int, Value)))

158−evalCond xs (Equals val1 val2) = let (restring , newxs ) = valString xs val1 in

159− let (restring2, newxs') = valString newxs val2 in

160− (restring ++ " = " ++ restring2, newxs')

161−

162−evalCond xs (MkGT val1 val2) = let (restring , newxs ) = valString xs val1 in

163− let (restring2, newxs') = valString newxs val2 in

164− (restring ++ " > " ++ restring2, newxs')

165−

166−evalCond xs (MkGTE val1 val2) = let (restring , newxs ) = valString xs val1 in

167− let (restring2, newxs') = valString newxs val2 in

168− (restring ++ " >= " ++ restring2, newxs')

169−

170−evalCond xs (MkLT val1 val2) = let (restring , newxs ) = valString xs val1 in

171− let (restring2, newxs') = valString newxs val2 in

172− (restring ++ " < " ++ restring2, newxs')

173−

174−evalCond xs (MkLTE val1 val2) = let (restring , newxs ) = valString xs val1 in

175− let (restring2, newxs') = valString newxs val2 in

176− (restring ++ " =< " ++ restring2, newxs')

177−

178−evalCond xs (MkNULL val) = let (restring , newxs ) = valString xs val in

179− (restring ++ " IS NULL " , newxs)

180−

181−-----------------------------------------------------------

182−-- | Evaluates queries by calling the other functions

183−-- on each part of the query

184−-----------------------------------------------------------

185−evalSQL : List (Maybe(Int, Value)) -> SQL -> ( String, List (Maybe(Int, Value)))

186−-----------------------------------------------------------

187−-- | Evaluates clauses

188−-- Supports WHERE Clause

189−-- WHERE Clause And Another-Clause

190−-- WHERE Clause Or Another-Clause

191−-----------------------------------------------------------

192−clauseString : List (Maybe(Int, Value)) -> Clause -> (String, List (Maybe(Int, Value)))

193−

194−clauseString xs (Empty) = ("" , []) -- No condition

195−clauseString xs (MkCond cond') = let (condstr, newxs) = evalCond xs cond' in

196− (condstr , newxs)

197−

198−clauseString xs (AND c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

199− let (clausestr2, newxs') = clauseString newxs c2 in

200− (clausestr ++ " AND " ++clausestr2 , newxs')

201−

202−clauseString xs (OR c1 c2) = let (clausestr, newxs) = clauseString xs c1 in

203− let (clausestr2, newxs') = clauseString newxs c2 in

204− (clausestr ++ " OR " ++clausestr2 , newxs')

205−

206−

207−-----------------------------------------------------------

208−-- | Evaluates conditional clauses.

209−-----------------------------------------------------------

210−

211−condClauseStr : List (Maybe(Int, Value)) -> condClause -> (String, List (Maybe(Int, Value)))

212−condClauseStr xs (SET setcl) = let (condstr, newxs) = clauseString xs setcl in

213− (" SET " ++ condstr, newxs)

214−

215−condClauseStr xs (WHERE setcl1 setcl2) = let (condstr, newxs) = condClauseStr xs setcl1 in

216− let (condstr', newxs') = clauseString newxs setcl2 in

217− ( condstr ++ " WHERE " ++ condstr', newxs')

218−

219−-- SELECT data from tbl1 where num > (SELECT num from tbl1 where num = 24)

220−-- evalSQL [] ((SELECT ALL)(TBL "tbl")(MkSQL ((SELECT ALL) (TBL "tbl")(MkCond (VCol "))))

221−-- NTBF

222−--clauseString xs (MkSQL sql) = (evalSQL xs sql)

223−

224−-- Separate list of tables

225−-- For complex type, return list returned by evalSQL

226−-- And add brackets

227−evalSQL xs (TBL tbl) = ((unwords (intersperse "," ( tbl))), xs)

228−evalSQL xs (SELECT vars sql' c) = let (sqlstring, newxs) = evalSQL xs sql' in

229− let (csstring, newxs') = clauseString newxs c in

230− case c of

231− Empty => case vars of

232− (ALL ) => if complexType sql' then ("SELECT " ++ "*" ++ " FROM "

233− ++ (putBrackets sqlstring) ++ csstring, newxs)

234−

235− else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring

236− ++ csstring, newxs')

237−

238− (Cols selvar) => if complexType sql' then ("SELECT " ++ (unwords selvar) ++

239− " FROM " ++ (putBrackets sqlstring) ++ csstring, newxs)

240−

241− else ("SELECT " ++ (unwords selvar )++ " FROM " ++ sqlstring

242− ++ csstring, newxs')

243−

244− _ => case vars of

245− (ALL ) => if complexType sql' then ("SELECT " ++ "*" ++ " FROM "

246− ++ " WHERE " ++ csstring , newxs)

247− else ("SELECT " ++ "*" ++ " FROM " ++ sqlstring

248− ++ " WHERE " ++ csstring , newxs')

249−

250− (Cols selvar) => if complexType sql' then ("SELECT " ++ (unwords selvar) ++ " FROM " ++

251− (putBrackets sqlstring) ++ " WHERE "

252− ++ csstring , newxs)

253−

254− else ("SELECT " ++ (unwords selvar) ++ " FROM " ++ sqlstring

255− ++ " WHERE " ++ csstring , newxs')

256−

257−

258−evalSQL xs (INSERT sql vals) = let (tblname, newvals) = evalSQL xs sql in

259− let (str, newxs ) = listVal newvals vals in

260− ("INSERT INTO " ++ tblname ++ " VALUES (" ++ str ++ ")" , newxs)

261−

262−evalSQL xs (INSERTC sql cols vals) = let (tblname, newvals) = evalSQL xs sql in

263− let (strcol, newcol) = listVal newvals cols in

264− let (strval, newcolval) = listVal newcol vals in

265− ("INSERT INTO " ++ tblname ++ "(" ++ strcol ++ ")" ++ "VALUES (" ++ strval ++ ")", newcolval)

266−

267−

268−evalSQL xs (UPDATE sql cl) = let (tblname, newxs) = evalSQL xs sql in

269− let (csstring, newxs') = condClauseStr newxs cl in

270− ("UPDATE " ++ tblname ++ csstring, newxs')

271−

272−evalSQL xs (CREATE sql details) = let (sqlstring, newxs) = evalSQL xs sql in

273− let (csstring, newxs') = listValType newxs details in

274− ("CREATE TABLE " ++ sqlstring ++ "(" ++ csstring ++ ")", newxs')

contribs/tool-support/vim/ftplugin/idris.vim+3−3

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

1−set shiftwidth=2

2−set tabstop=2

3−set expandtab

1+setlocal shiftwidth=2

2+setlocal tabstop=2

3+setlocal expandtab

contribs/tool-support/vim/syntax/idris.vim+8−10

@@ -4,7 +4,7 @@

44" highlighter to support idris.

55"

66" author: raichoo (raichoo@googlemail.com)

7−" date: Mar 20 2013

7+" date: May 24 2013

88

99syn match idrisModule "\<$module\|namespace$\>"

1010syn match idrisImport "\<import\>"

1515syn match idrisStatement "\<$do\|case\|of\|rewrite\|let\|in\|with$\>"

1616syn match idrisSyntax "$pattern \+\|term \+$\?syntax"

1717syn match idrisConditional "\<$if\|then\|else$\>"

1919syn match idrisNumber "\<[0-9]\+\>\|\<0[xX][0-9a-fA-F]\+\>\|\<0[oO][0-7]\+\>"

2020syn match idrisFloat "\<[0-9]\+\.[0-9]\+$[eE][-+]\=[0-9]\+$\=\>"

2121syn match idrisDelimiter "(\|)\|\[\|\]\|,\|;\|_\|{\|}"

@@ -27,16 +27,12 @@ syn match idrisMetaVar "?[a-z][A-Za-z0-9_]\+"

2727syn match idrisLink "%$lib\|link\|include$"

2828syn match idrisDirective "%$access\|default\|assert_total$"

2929syn match idrisDSL "$lambda\|variable\|\index_first\|index_next$"

30+syn match idrisChar "'[^'\\]'\|'\\.'\|'\\u[0-9a-fA-F]\{4}'"

31+syn match idrisBacktick "`[A-Za-z][A-Za-z0-9_]*`"

3032syn region idrisString start=+"+ skip=+\\\\\|\\"+ end=+"+

3133syn region idrisBlockComment start="{-" end="-}" contains=idrisBlockComment

3234syn region idrisProofBlock start="$default\s\+$\?$proof\|tactics$ *{" end="}" contains=idrisTactic

3335

34−syn match idrisBadLeadingWhiteSpace "^\s*\t\+"

35−syn match idrisBadTrailingWhiteSpace "\s\+$"

36−

37−highlight idrisBadLeadingWhiteSpace ctermbg=red

38−highlight idrisBadTrailingWhiteSpace ctermbg=red

39−

4036highlight def link idrisImport Structure

4137highlight def link idrisModule Structure

4238highlight def link idrisStructure Structure

@@ -48,7 +44,7 @@ highlight def link idrisSyntax Statement

4844highlight def link idrisVisibility Statement

4945highlight def link idrisConditional Conditional

5046highlight def link idrisProofBlock Macro

51−highlight idrisTactic ctermfg=cyan

47+highlight def link idrisTactic Identifier

5248highlight def link idrisLink Statement

5349highlight def link idrisDirective Statement

5450highlight def link idrisNumber Number

@@ -59,5 +55,7 @@ highlight def link idrisOperators Operator

5955highlight def link idrisType Include

6056highlight def link idrisLineComment Comment

6157highlight def link idrisBlockComment Comment

62−highlight idrisMetaVar ctermfg=red

58+highlight def link idrisMetaVar Identifier

6359highlight def link idrisString String

60+highlight def link idrisChar String

61+highlight def link idrisBacktick Operator

effects/Effect/Memory.idrnew file+168

@@ -0,0 +1,168 @@

1+module Effect.Memory

2+

3+import Effects

4+import Control.IOExcept

5+

6+%access public

7+

8+abstract

9+data MemoryChunk : Nat -> Nat -> Type where

10+ CH : Ptr -> MemoryChunk size initialized

11+

12+abstract

13+data RawMemory : Effect where

14+ Allocate : (n : Nat) ->

15+ RawMemory () (MemoryChunk n 0) ()

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

17+ Initialize : Bits8 ->

18+ (size : Nat) ->

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

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

21+ Peek : (offset : Nat) ->

22+ (size : Nat) ->

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

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

25+ Poke : (offset : Nat) ->

26+ (Vect Bits8 size) ->

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

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

29+ Move : (src : MemoryChunk src_size src_init) ->

30+ (dst_offset : Nat) ->

31+ (src_offset : Nat) ->

32+ (size : Nat) ->

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

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

35+ RawMemory (MemoryChunk dst_size dst_init)

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

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

38+

39+private

40+do_malloc : Nat -> IOExcept String Ptr

41+do_malloc size with (fromInteger (cast size) == size)

42+ | True = do ptr <- ioe_lift $ mkForeign (FFun "malloc" [FInt] FPtr) (cast size)

43+ fail <- ioe_lift $ nullPtr ptr

44+ if fail then ioe_fail "Cannot allocate memory"

45+ else return ptr

46+ | False = ioe_fail "The target architecture does not support adressing enough memory"

47+

48+private

49+do_memset : Ptr -> Nat -> Bits8 -> Nat -> IO ()

50+do_memset ptr offset c size

51+ = mkForeign (FFun "idris_memset" [FPtr, FInt, FChar, FInt] FUnit)

52+ ptr (cast offset) c (cast size)

53+

54+private

55+do_free : Ptr -> IO ()

56+do_free ptr = mkForeign (FFun "free" [FPtr] FUnit) ptr

57+

58+private

59+do_memmove : Ptr -> Ptr -> Nat -> Nat -> Nat -> IO ()

60+do_memmove dest src dest_offset src_offset size

61+ = mkForeign (FFun "idris_memmove" [FPtr, FPtr, FInt, FInt, FInt] FUnit)

62+ dest src (cast dest_offset) (cast src_offset) (cast size)

63+

64+private

65+do_peek : Ptr -> Nat -> (size : Nat) -> IO (Vect Bits8 size)

66+do_peek _ _ O = return (Prelude.Vect.Nil)

67+do_peek ptr offset (S n)

68+ = do b <- mkForeign (FFun "idris_peek" [FPtr, FInt] FChar) ptr (cast offset)

69+ bs <- do_peek ptr (S offset) n

70+ Prelude.Monad.return (Prelude.Vect.(::) b bs)

71+

72+private

73+do_poke : Ptr -> Nat -> Vect Bits8 size -> IO ()

74+do_poke _ _ [] = return ()

75+do_poke ptr offset (b::bs)

76+ = do mkForeign (FFun "idris_poke" [FPtr, FInt, FChar] FUnit) ptr (cast offset) b

77+ do_poke ptr (S offset) bs

78+

79+instance Handler RawMemory (IOExcept String) where

80+ handle () (Allocate n) k

81+ = do ptr <- do_malloc n

82+ k (CH ptr) ()

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

84+ = ioe_lift (do_memset ptr offset c size) $> k (CH ptr) ()

85+ handle (CH ptr) (Free) k

86+ = ioe_lift (do_free ptr) $> k () ()

87+ handle (CH ptr) (Peek offset size _) k

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

89+ k (CH ptr) res

90+ handle (CH ptr) (Poke offset content _) k

91+ = do ioe_lift (do_poke ptr offset content)

92+ k (CH ptr) ()

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

94+ = do ioe_lift (do_memmove dest_ptr src_ptr dest_offset src_offset size)

95+ k (CH dest_ptr) ()

96+ handle chunk (GetRawPtr) k

97+ = k chunk chunk

98+

99+RAW_MEMORY : Type -> EFFECT

100+RAW_MEMORY t = MkEff t RawMemory

101+

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

103+allocate size = Allocate size

104+

105+initialize : {i : Nat} ->

106+ {n : Nat} ->

107+ Bits8 ->

108+ (size : Nat) ->

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

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

111+initialize c size prf = Initialize c size prf

112+

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

114+free = Free

115+

116+peek : {i : Nat} ->

117+ (offset : Nat) ->

118+ (size : Nat) ->

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

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

121+peek offset size prf = Peek offset size prf

122+

123+poke : {n : Nat} ->

124+ {i : Nat} ->

125+ (offset : Nat) ->

126+ Vect Bits8 size ->

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

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

129+poke offset content prf = Poke offset content prf

130+

131+private

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

133+getRawPtr = GetRawPtr

134+

135+private

136+move' : {dst_size : Nat} ->

137+ {dst_init : Nat} ->

138+ {src_init : Nat} ->

139+ (src_ptr : MemoryChunk src_size src_init) ->

140+ (dst_offset : Nat) ->

141+ (src_offset : Nat) ->

142+ (size : Nat) ->

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

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

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

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

147+move' src_ptr dst_offset src_offset size dst_bounds src_bounds

148+ = Move src_ptr dst_offset src_offset size dst_bounds src_bounds

149+

150+data MoveDescriptor = Dst | Src

151+

152+move : {dst_size : Nat} ->

153+ {dst_init : Nat} ->

154+ {src_size : Nat} ->

155+ {src_init : Nat} ->

156+ (dst_offset : Nat) ->

157+ (src_offset : Nat) ->

158+ (size : Nat) ->

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

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

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

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

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

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

165+move dst_offset src_offset size dst_bounds src_bounds

166+ = do src_ptr <- Src :- getRawPtr

167+ Dst :- move' src_ptr dst_offset src_offset size dst_bounds src_bounds

168+ return ()

effects/Effect/Random.idr+7−7

@@ -3,19 +3,19 @@ module Effect.Random

33import Effects

44

55data Random : Type -> Type -> Type -> Type where

6− getRandom : Random Int Int Int

6+ getRandom : Random Integer Integer Integer

77

88using (m : Type -> Type)

99 instance Handler Random m where

1010 handle seed getRandom k

11− = let seed' = 1664525 * seed + 1013904223 in

11+ = let seed' = (1664525 * seed + 1013904223) `prim__sremBigInt` (pow 2 32) in

1212 k seed' seed'

13−

13+

1414RND : EFFECT

15−RND = MkEff Int Random

15+RND = MkEff Integer Random

1616

17−rndInt : Int -> Int -> Eff m [RND] Int

18−rndInt lower upper = do v <- getRandom

19− return (v `mod` (upper - lower) + lower)

17+rndInt : Integer -> Integer -> Eff m [RND] Integer

18+rndInt lower upper = do v <- getRandom

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

2020

2121

effects/Effects.idr+21−12

@@ -48,6 +48,8 @@ updateWith : (ys' : List a) -> (xs : List a) ->

4848updateWith (y :: ys) (x :: xs) (Keep rest) = y :: updateWith ys xs rest

4949updateWith ys (x :: xs) (Drop rest) = x :: updateWith ys xs rest

5050updateWith [] [] SubNil = []

51+updateWith (y :: ys) [] SubNil = y :: ys

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

5153

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

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

@@ -55,23 +57,24 @@ rebuildEnv : Env m ys' -> (prf : SubList ys xs) ->

5557rebuildEnv [] SubNil env = env

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

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

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

5861

5962---- The Effect EDSL itself ----

6063

6164-- some proof automation

62−findEffElem : Nat -> Tactic -- Nat is maximum search depth

63−findEffElem O = Refine "Here" `Seq` Solve

64−findEffElem (S n) = GoalType "EffElem"

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

66+findEffElem O ctxt goal = Refine "Here" `Seq` Solve

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

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

66− (Refine "There" `Seq` (Solve `Seq` findEffElem n)))

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

6770

68−findSubList : Nat -> Tactic

69−findSubList O = Refine "SubNil" `Seq` Solve

70−findSubList (S n)

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

72+findSubList O ctxt goal = Refine "SubNil" `Seq` Solve

73+findSubList (S n) ctxt goal

7174 = GoalType "SubList"

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

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

74− (Refine "Drop" `Seq` Solve)) `Seq` findSubList n))

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

7578

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

7780 List EFFECT

@@ -116,14 +119,14 @@ data EffM : (m : Type -> Type) ->

116119-- Eff : List (EFFECT m) -> Type -> Type

117120

118121implicit

119−lift' : {default tactics { reflect findSubList 100; solve; }

122+lift' : {default tactics { applyTactic findSubList 100; solve; }

120123 prf : SubList ys xs} ->

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

122125lift' {prf} e = lift prf e

123126

124127implicit

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

126− {default tactics { reflect findEffElem 100; solve; }

129+ {default tactics { applyTactic findEffElem 100; solve; }

127130 prf : EffElem e a xs} ->

128131 (eff : e a b t) ->

129132 EffM m xs (updateResTy xs prf eff) t

@@ -161,6 +164,9 @@ execEff (val :: env) Here eff' k

161164execEff (val :: env) (There p) eff k

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

163166

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

168+-- updates can be propagated even through failing computations?

169+

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

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

166172eff env (prog `ebind` c) k

@@ -175,8 +181,12 @@ eff env (new r prog) k

175181eff env (catch prog handler) k

176182 = catch (eff env prog k)

177183 (\e => eff env (handler e) k)

184+-- FIXME:

185+-- xs is needed explicitly because otherwise the pattern binding for

186+-- 'l' appears too late. Solution seems to be to reorder patterns at the

187+-- end so that everything is in scope when it needs to be.

178188eff {xs = [l ::: x]} env (l :- prog) k

179− = let env' = unlabel {l} env in

189+ = let env' = unlabel env in

180190 eff env' prog (\envk, p' => k (relabel l envk) p')

181191

182192run : Applicative m => Env m xs -> EffM m xs xs' a -> m a

@@ -206,4 +216,3 @@ mapE f (x :: xs) = [| f x :: mapE f xs |]

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

207217when True e = e

208218when False e = pure ()

209−

effects/Makefile+1−1

@@ -4,7 +4,7 @@ check: .PHONY

44

55recheck: clean check

66

7−install:

7+install:

88 $(IDRIS) --install effects.ipkg

99

1010clean: .PHONY

effects/effects.ipkg+3−1

@@ -3,4 +3,6 @@ package effects

33opts = "-i ../lib"

44modules = Effects,

55 Effect.Exception, Effect.File, Effect.State,

6− Effect.Random, Effect.StdIO, Effect.Select

6+ Effect.Random, Effect.StdIO, Effect.Select,

7+ Effect.Memory

8+

idris.cabal+13−4

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

11Name: idris

2−Version: 0.9.7

2+Version: 0.9.8.1

33License: BSD3

44License-file: LICENSE

55Author: Edwin Brady

@@ -56,16 +56,21 @@ Data-files: rts/libidris_rts.a rts/idris_rts.h rts/idris_gc.h

5656Extra-source-files: lib/Makefile lib/*.idr lib/Prelude/*.idr

5757 lib/Network/*.idr lib/Control/*.idr

5858 lib/Control/Monad/*.idr lib/Language/*.idr

59+ lib/Language/Reflection/*.idr

5960 lib/System/Concurrency/*.idr

6061 lib/Data/*.idr lib/Debug/*.idr

62+ lib/Data/Vect/*.idr

6163 lib/Decidable/*.idr

6264 tutorial/examples/*.idr lib/base.ipkg

6365 effects/Makefile effects/*.idr effects/Effect/*.idr

6466 effects/effects.ipkg

67+ javascript/Makefile

68+ javascript/*.idr

69+ javascript/javascript.ipkg

6570 config.mk

6671 rts/*.c rts/*.h rts/Makefile

6772 js/*.js

68− java/org/idris/rts/*.java

73+ java/src/main/java/org/idris/rts/*.java

6974

7075source-repository head

7176 type: git

@@ -88,13 +93,14 @@ Executable idris

8893 Core.CaseTree, Core.Constraints,

8994

9095 Idris.AbsSyntax, Idris.AbsSyntaxTree,

91− Idris.Parser, Idris.Help, Idris.REPL,

96+ Idris.Parser, Idris.Help, Idris.IdeSlave, Idris.REPL,

9297 Idris.REPLParser, Idris.ElabDecls, Idris.Error,

9398 Idris.Delaborate, Idris.Primitives, Idris.Imports,

9499 Idris.Compiler, Idris.Prover, Idris.ElabTerm,

95100 Idris.Coverage, Idris.IBC, Idris.Unlit,

96101 Idris.DataOpts, Idris.Transforms, Idris.DSL,

97102 Idris.UnusedArgs, Idris.Docs, Idris.Completion,

103+ Idris.Providers,

98104

99105 Util.Pretty, Util.System, Util.DynamicLinker,

100106 Pkg.Package, Pkg.PParser,

@@ -111,7 +117,7 @@ Executable idris

111117 haskeline>=0.7, split, directory,

112118 containers, process, transformers, filepath,

113119 directory, binary, bytestring, text, pretty,

114− language-java>=0.2.2, libffi, unix

120+ language-java>=0.2.2, libffi

115121

116122 Extensions: MultiParamTypeClasses, FunctionalDependencies,

117123 FlexibleInstances, TemplateHaskell

@@ -119,7 +125,10 @@ Executable idris

119125 ghc-options: -rtsopts

120126 if os(linux)

121127 cpp-options: -DLINUX

128+ build-depends: unix

122129 if os(darwin)

123130 cpp-options: -DMACOSX

131+ build-depends: unix

124132 if os(windows)

125133 cpp-options: -DWINDOWS

134+ build-depends: Win32

java/src/main/java/org/idris/rts/ForeignPrimitives.java+42

@@ -191,6 +191,48 @@ public class ForeignPrimitives {

191191 return (o == null ? 1 : 0);

192192 }

193193

194+ public static Object malloc(int size) {

195+ return ByteBuffer.allocate(size);

196+ }

197+

198+ public static void idris_memset(Object buf, int offset, Object c, int size) {

199+ ByteBuffer buffer = (ByteBuffer)buf;

200+ buffer.rewind();

201+ buffer.position(offset);

202+ byte init[] = new byte[size];

203+ Arrays.fill(init, (Byte)c);

204+ buffer.put(init, offset, size);

205+ buffer.rewind();

206+ }

207+

208+ public static void free(Object buf) {

209+ buf = null;

210+ }

211+

212+ public static Integer idris_peek(Object buf, int offset) {

213+ ByteBuffer buffer = (ByteBuffer)buf;

214+ return Integer.valueOf(buffer.get(offset));

215+ }

216+

217+ public static void idris_poke(Object buf, int offset, Object data) {

218+ ByteBuffer buffer = (ByteBuffer)buf;

219+ buffer.put(offset, (Byte)data);

220+ }

221+

222+ public static void idris_memmove(Object dstBuf, Object srcBuf, int dstOffset, int srcOffset, int size) {

223+ ByteBuffer dst = (ByteBuffer)dstBuf;

224+ ByteBuffer src = (ByteBuffer)srcBuf;

225+ byte [] srcData = new byte[size];

226+ src.rewind();

227+ src.position(srcOffset);

228+ src.get(srcData, 0, size);

229+ src.rewind();

230+ dst.rewind();

231+ dst.position(dstOffset);

232+ dst.put(srcData, 0, size);

233+ dst.rewind();

234+ }

235+

194236 public final static Object idris_K(final Object result, final Object drop) {

195237 return result;

196238 }

javascript/JavaScript.idrnew file+101

@@ -0,0 +1,101 @@

1+module JavaScript

2+

3+%access public

4+

5+-- TODO: Get rid of this hack, and find a better way.

6+private

7+isUndefined : Ptr -> IO Bool

8+isUndefined p = do

9+ res <- mkForeign (

10+ FFun "(function(arg) { return arg === undefined;})" [FPtr] FString) p

11+ if res == "false"

12+ then (return False)

13+ else (return True)

14+

15+--------------------------------------------------------------------------------

16+-- Events

17+--------------------------------------------------------------------------------

18+abstract

19+data Event : Type where

20+ MkEvent : Ptr -> Event

21+

22+--------------------------------------------------------------------------------

23+-- Elements

24+--------------------------------------------------------------------------------

25+abstract

26+data Element : Type where

27+ MkElem : Ptr -> Element

28+

29+setText : Element -> String -> IO ()

30+setText (MkElem p) s =

31+ mkForeign (FFun ".textContent=" [FPtr, FString] FUnit) p s

32+

33+

34+setOnClick : Element -> (Event -> IO Bool) -> IO ()

35+setOnClick (MkElem e) f =

36+ mkForeign (

37+ FFun "['onclick']=" [ FPtr

38+ , FFunction (FAny Event) (FAny (IO Bool))

39+ ] FUnit) e f

40+--------------------------------------------------------------------------------

41+-- Nodelists

42+--------------------------------------------------------------------------------

43+abstract

44+data NodeList : Type where

45+ MkNodeList : Ptr -> NodeList

46+

47+elemAt : NodeList -> Nat -> IO (Maybe Element)

48+elemAt (MkNodeList p) i = do

49+ e <- mkForeign (FFun ".item" [FPtr, FInt] FPtr) p (cast i)

50+ d <- isUndefined e

51+ if d

52+ then return $ Just (MkElem e)

53+ else return Nothing

54+

55+--------------------------------------------------------------------------------

56+-- Intervals

57+--------------------------------------------------------------------------------

58+abstract

59+data Interval : Type where

60+ MkInterval : Ptr -> Interval

61+

62+setInterval : (() -> IO ()) -> Float -> IO Interval

63+setInterval f t = do

64+ e <- mkForeign (

65+ FFun "setInterval" [FFunction FUnit (FAny (IO ())), FFloat] FPtr) f t

66+ return (MkInterval e)

67+

68+clearInterval : Interval -> IO ()

69+clearInterval (MkInterval p) =

70+ mkForeign (FFun "clearInterval" [FPtr] FUnit) p

71+

72+--------------------------------------------------------------------------------

73+-- Timeouts

74+--------------------------------------------------------------------------------

75+data Timeout : Type where

76+ MkTimeout : Ptr -> Timeout

77+

78+setTimeout : (() -> IO ()) -> Float -> IO Timeout

79+setTimeout f t = do

80+ e <- mkForeign (

81+ FFun "setTimeout" [FFunction FUnit (FAny (IO ())), FFloat] FPtr) f t

82+ return (MkTimeout e)

83+

84+clearTimeout : Timeout -> IO ()

85+clearTimeout (MkTimeout p) =

86+ mkForeign (FFun "clearTimeout" [FPtr] FUnit) p

87+

88+--------------------------------------------------------------------------------

89+-- Basic IO

90+--------------------------------------------------------------------------------

91+alert : String -> IO ()

92+alert msg =

93+ mkForeign (FFun "alert" [FString] FUnit) msg

94+

95+--------------------------------------------------------------------------------

96+-- DOM

97+--------------------------------------------------------------------------------

98+query : String -> IO NodeList

99+query q = do

100+ e <- mkForeign (FFun "document.querySelectorAll" [FString] FPtr) q

101+ return (MkNodeList e)

javascript/JavaScript/JSON.idrnew file+46

@@ -0,0 +1,46 @@

1+module JSON

2+

3+import Data.SortedMap

4+

5+data JSONType : Type where

6+ JSONArray : (n : Nat) -> Vect JSONType n -> JSONType

7+ JSONString : JSONType

8+ JSONNumber : JSONType

9+ JSONBool : JSONType

10+ JSONObject : SortedMap String JSONType -> JSONType

11+ JSONNull : JSONType

12+

13+mutual

14+ using (ts : Vect JSONType n, fs : SortedMap String JSONType)

15+ namespace JArray

16+ data JArray : (n : Nat) -> Vect JSONType n -> Type where

17+ Nil : JArray 0 []

18+ (::) : JSON t -> JArray n ts -> JArray (S n) (t :: ts)

19+

20+ namespace JObject

21+ data JObject : SortedMap String JSONType -> Type where

22+ Nil : JObject empty

23+ (::) : (f : (String, JSON t)) ->

24+ JObject fs ->

25+ JObject (insert (fst f) t fs)

26+

27+ data JSON : JSONType -> Type where

28+ JSString : String -> JSON JSONString

29+ JSNumber : Float -> JSON JSONNumber

30+ JSBool : Bool -> JSON JSONBool

31+ JSNull : JSON JSONNull

32+ JSArray : JArray n ts -> JSON (JSONArray n ts)

33+ JSObject : JObject fs -> JSON (JSONObject fs)

34+

35+index : (i : Fin n) -> JSON (JSONArray n ts) -> JSON (index i ts)

36+index fO (JSArray (x :: xs)) = x

37+index (fS i) (JSArray (x :: xs)) = index i (JSArray xs)

38+

39+infixl 8 ++

40+

41+(++) : JSON (JSONArray m ts1) ->

42+ JSON (JSONArray n ts2) ->

43+ JSON (JSONArray (m + n) (ts1 ++ ts2))

44+(++) (JSArray []) ys = ys

45+(++) (JSArray (x :: xs)) ys with ((JSArray xs) ++ ys)

46+ | (JSArray as) = JSArray (x :: as)

javascript/Makefilenew file+13

@@ -0,0 +1,13 @@

1+

2+check: .PHONY

3+ $(IDRIS) --build javascript.ipkg

4+

5+recheck: clean check

6+

7+install:

8+ $(IDRIS) --install javascript.ipkg

9+

10+clean: .PHONY

11+ $(IDRIS) --clean javascript.ipkg

12+

13+.PHONY:

javascript/javascript.ipkgnew file+5

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

1+package javascript

2+

3+opts = "-i ../lib"

4+modules = JavaScript, JavaScript.JSON

5+

js/Runtime-common.js+9

@@ -10,10 +10,19 @@ __IDRRT__.Char = new __IDRRT__.Type('Char');

1010__IDRRT__.String = new __IDRRT__.Type('String');

1111__IDRRT__.Integer = new __IDRRT__.Type('Integer');

1212__IDRRT__.Float = new __IDRRT__.Type('Float');

13+__IDRRT__.Ptr = new __IDRRT__.Type('Pointer');

1314__IDRRT__.Forgot = new __IDRRT__.Type('Forgot');

1415

16+

1517/** @constructor */

1618__IDRRT__.Tailcall = function(f) { this.f = f };

19+__IDRRT__.ffiWrap = function(fid) {

20+ return function(arg) {

21+ return __IDRRT__.tailcall(function(){

22+ return __IDR__.APPLY0(fid, arg);

23+ });

24+ };

25+};

1726

1827/** @constructor */

1928__IDRRT__.Con = function(i,vars) {

lib/Builtins.idr+7−4

@@ -44,6 +44,9 @@ really_believe_me x = prim__believe_me _ _ x

4444

4545namespace Builtins {

4646

47+Not : Type -> Type

48+Not a = a -> _|_

49+

4750id : a -> a

4851id x = x

4952

@@ -248,7 +251,7 @@ instance Num Integer where

248251 (*) = prim__mulBigInt

249252

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

251− fromInteger = prim__intToBigInt

254+ fromInteger = prim__sextInt_BigInt

252255

253256

254257instance Num Float where

@@ -257,15 +260,15 @@ instance Num Float where

257260 (*) = prim__mulFloat

258261

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

260− fromInteger = prim__intToFloat

263+ fromInteger = prim__toFloatInt

261264

262265partial

263266div : Int -> Int -> Int

264−div = prim__divInt

267+div = prim__sdivInt

265268

266269partial

267270mod : Int -> Int -> Int

268−mod = prim__modInt

271+mod = prim__sremInt

269272

270273

271274(/) : Float -> Float -> Float

lib/Control/IOExcept.idr−1

@@ -16,7 +16,6 @@ instance Applicative (IOExcept e) where

1616 return (f' <$> a'))

1717

1818instance Monad (IOExcept e) where

19− return = pure

2019 (ioM x) >>= k = ioM (do x' <- x;

2120 case x' of

2221 Right a => let (ioM ka) = k a in

lib/Control/Monad/Identity.idr−1

@@ -16,5 +16,4 @@ instance Applicative Identity where

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

1717

1818instance Monad Identity where

19− return x = Id x

2019 (Id x) >>= k = k x

lib/Control/Monad/State.idr−2

@@ -27,8 +27,6 @@ instance Monad f => Applicative (StateT s f) where

2727 return (g b, t))

2828

2929instance Monad m => Monad (StateT s m) where

30− return x = ST (\st => return (x, st))

31−

3230 (ST f) >>= k = ST (\st => do (v, st') <- f st

3331 let ST kv = k v

3432 kv st')

lib/Data/Bits.idr+69−66

@@ -31,17 +31,18 @@ bitsUsed n = 8 * (2 `power` n)

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

3232natToBits' a O = a

3333natToBits' {n=n} a x with n

34− natToBits' a (S x') | O = natToBits' (prim__addB8 a (prim__intToB8 1)) x'

35− natToBits' a (S x') | S O = natToBits' (prim__addB16 a (prim__intToB16 1)) x'

36− natToBits' a (S x') | S (S O) = natToBits' (prim__addB32 a (prim__intToB32 1)) x'

37− natToBits' a (S x') | S (S (S _)) = natToBits' (prim__addB64 a (prim__intToB64 1)) x'

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

35+ natToBits' a (S x') | O = natToBits' {n=0} (prim__addB8 a (prim__truncInt_B8 1)) x'

36+ natToBits' a (S x') | S O = natToBits' {n=1} (prim__addB16 a (prim__truncInt_B16 1)) x'

37+ natToBits' a (S x') | S (S O) = natToBits' {n=2} (prim__addB32 a (prim__truncInt_B32 1)) x'

38+ natToBits' a (S x') | S (S (S _)) = natToBits' {n=3} (prim__addB64 a (prim__truncInt_B64 1)) x'

3839

3940natToBits : Nat -> machineTy n

4041natToBits {n=n} x with n

41− | O = natToBits' (prim__intToB8 0) x

42− | S O = natToBits' (prim__intToB16 0) x

43− | S (S O) = natToBits' (prim__intToB32 0) x

44− | S (S (S _)) = natToBits' (prim__intToB64 0) x

42+ | O = natToBits' {n=0} (prim__truncInt_B8 0) x

43+ | S O = natToBits' {n=1} (prim__truncInt_B16 0) x

44+ | S (S O) = natToBits' {n=2} (prim__truncInt_B32 0) x

45+ | S (S (S _)) = natToBits' {n=3} (prim__truncInt_B64 0) x

4546

4647getPad : Nat -> machineTy n

4748getPad n = natToBits ((bitsUsed (nextBytes n)) - n)

@@ -111,7 +112,8 @@ shiftRightLogical' {n=n} x c with n

111112

112113public

113114shiftRightLogical : Bits n -> Bits n -> Bits n

114−shiftRightLogical (MkBits x) (MkBits y) = MkBits (shiftRightLogical' x y)

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

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

115117

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

117119shiftRightArithmetic' {n=n} x c with (nextBytes n)

@@ -133,7 +135,7 @@ and' {n=n} x y with n

133135

134136public

135137and : Bits n -> Bits n -> Bits n

136−and (MkBits x) (MkBits y) = MkBits (and' x y)

138+and {n} (MkBits x) (MkBits y) = MkBits (and' {n=nextBytes n} x y)

137139

138140or' : machineTy n -> machineTy n -> machineTy n

139141or' {n=n} x y with n

@@ -144,7 +146,7 @@ or' {n=n} x y with n

144146

145147public

146148or : Bits n -> Bits n -> Bits n

147−or (MkBits x) (MkBits y) = MkBits (or' x y)

149+or {n} (MkBits x) (MkBits y) = MkBits (or' {n=nextBytes n} x y)

148150

149151xor' : machineTy n -> machineTy n -> machineTy n

150152xor' {n=n} x y with n

@@ -155,7 +157,7 @@ xor' {n=n} x y with n

155157

156158public

157159xor : Bits n -> Bits n -> Bits n

158−xor (MkBits x) (MkBits y) = MkBits (xor' x y)

160+xor {n} (MkBits x) (MkBits y) = MkBits {n} (xor' {n=nextBytes n} x y)

159161

160162plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

161163plus' {n=n} x y with (nextBytes n)

@@ -239,36 +241,36 @@ urem : Bits n -> Bits n -> Bits n

239241urem (MkBits x) (MkBits y) = MkBits (urem' x y)

240242

241243-- TODO: Proofy comparisons via postulates

242−lt : machineTy n -> machineTy n -> Int

243−lt {n=n} x y with n

244+lt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

245+lt {n=n} x y with (nextBytes n)

244246 | O = prim__ltB8 x y

245247 | S O = prim__ltB16 x y

246248 | S (S O) = prim__ltB32 x y

247249 | S (S (S _)) = prim__ltB64 x y

248250

249−lte : machineTy n -> machineTy n -> Int

250−lte {n=n} x y with n

251+lte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

252+lte {n=n} x y with (nextBytes n)

251253 | O = prim__lteB8 x y

252254 | S O = prim__lteB16 x y

253255 | S (S O) = prim__lteB32 x y

254256 | S (S (S _)) = prim__lteB64 x y

255257

256−eq : machineTy n -> machineTy n -> Int

257−eq {n=n} x y with n

258+eq : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

259+eq {n=n} x y with (nextBytes n)

258260 | O = prim__eqB8 x y

259261 | S O = prim__eqB16 x y

260262 | S (S O) = prim__eqB32 x y

261263 | S (S (S _)) = prim__eqB64 x y

262264

263−gte : machineTy n -> machineTy n -> Int

264−gte {n=n} x y with n

265+gte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

266+gte {n=n} x y with (nextBytes n)

265267 | O = prim__gteB8 x y

266268 | S O = prim__gteB16 x y

267269 | S (S O) = prim__gteB32 x y

268270 | S (S (S _)) = prim__gteB64 x y

269271

270−gt : machineTy n -> machineTy n -> Int

271−gt {n=n} x y with n

272+gt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

273+gt {n=n} x y with (nextBytes n)

272274 | O = prim__gtB8 x y

273275 | S O = prim__gtB16 x y

274276 | S (S O) = prim__gtB32 x y

@@ -308,14 +310,14 @@ complement (MkBits x) = MkBits (complement' x)

308310zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))

309311zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

310312 | (O, O) = believe_me x

311− | (O, S O) = believe_me (prim__zextB8_16 (believe_me x))

312− | (O, S (S O)) = believe_me (prim__zextB8_32 (believe_me x))

313− | (O, S (S (S _))) = believe_me (prim__zextB8_64 (believe_me x))

313+ | (O, S O) = believe_me (prim__zextB8_B16 (believe_me x))

314+ | (O, S (S O)) = believe_me (prim__zextB8_B32 (believe_me x))

315+ | (O, S (S (S _))) = believe_me (prim__zextB8_B64 (believe_me x))

314316 | (S O, S O) = believe_me x

315− | (S O, S (S O)) = believe_me (prim__zextB16_32 (believe_me x))

316− | (S O, S (S (S _))) = believe_me (prim__zextB16_64 (believe_me x))

317+ | (S O, S (S O)) = believe_me (prim__zextB16_B32 (believe_me x))

318+ | (S O, S (S (S _))) = believe_me (prim__zextB16_B64 (believe_me x))

317319 | (S (S O), S (S O)) = believe_me x

318− | (S (S O), S (S (S _))) = believe_me (prim__zextB32_64 (believe_me x))

320+ | (S (S O), S (S (S _))) = believe_me (prim__zextB32_B64 (believe_me x))

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

320322

321323public

@@ -326,13 +328,13 @@ zeroExtend (MkBits x) = MkBits (zext' x)

326328intToBits' : Int -> machineTy (nextBytes n)

327329intToBits' {n=n} x with (nextBytes n)

328330 | O = let pad = getPad {n=0} n in

329− prim__lshrB8 (prim__shlB8 (prim__intToB8 x) pad) pad

331+ prim__lshrB8 (prim__shlB8 (prim__truncInt_B8 x) pad) pad

330332 | S O = let pad = getPad {n=1} n in

331− prim__lshrB16 (prim__shlB16 (prim__intToB16 x) pad) pad

333+ prim__lshrB16 (prim__shlB16 (prim__truncInt_B16 x) pad) pad

332334 | S (S O) = let pad = getPad {n=2} n in

333− prim__lshrB32 (prim__shlB32 (prim__intToB32 x) pad) pad

335+ prim__lshrB32 (prim__shlB32 (prim__truncInt_B32 x) pad) pad

334336 | S (S (S _)) = let pad = getPad {n=3} n in

335− prim__lshrB64 (prim__shlB64 (prim__intToB64 x) pad) pad

337+ prim__lshrB64 (prim__shlB64 (prim__truncInt_B64 x) pad) pad

336338

337339public

338340intToBits : Int -> Bits n

@@ -341,23 +343,23 @@ intToBits n = MkBits (intToBits' n)

341343instance Cast Int (Bits n) where

342344 cast = intToBits

343345

344−bitsToInt' : machineTy n -> Int

345−bitsToInt' {n=n} x with n

346− | O = prim__B32ToInt (prim__zextB8_32 x)

347− | S O = prim__B32ToInt (prim__zextB16_32 x)

348− | S (S O) = prim__B32ToInt x

349− | S (S (S _)) = prim__B32ToInt (prim__truncB64_32 x)

346+bitsToInt' : machineTy (nextBytes n) -> Int

347+bitsToInt' {n=n} x with (nextBytes n)

348+ | O = prim__zextB8_Int x

349+ | S O = prim__zextB16_Int x

350+ | S (S O) = prim__zextB32_Int x

351+ | S (S (S _)) = prim__truncB64_Int x

350352

351353public

352354bitsToInt : Bits n -> Int

353355bitsToInt (MkBits x) = bitsToInt' x

354356

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

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

357−zeroUnused x = x `and'` complement' (intToBits' 0)

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

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

358360

359−instance Cast Nat (Bits n) where

360− cast x = MkBits (zeroUnused (natToBits n))

361+--instance Cast Nat (Bits n) where

362+-- cast x = MkBits (zeroUnused (natToBits n))

361363

362364-- TODO: Prove

363365sext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))

@@ -365,51 +367,51 @@ sext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

365367 | (O, O) = let pad = getPad {n=0} n in

366368 believe_me (prim__ashrB8 (prim__shlB8 (believe_me x) pad) pad)

367369 | (O, S O) = let pad = getPad {n=0} n in

368− believe_me (prim__ashrB16 (prim__sextB8_16 (prim__shlB8 (believe_me x) pad))

369− (prim__zextB8_16 pad))

370+ believe_me (prim__ashrB16 (prim__sextB8_B16 (prim__shlB8 (believe_me x) pad))

371+ (prim__zextB8_B16 pad))

370372 | (O, S (S O)) = let pad = getPad {n=0} n in

371− believe_me (prim__ashrB32 (prim__sextB8_32 (prim__shlB8 (believe_me x) pad))

372− (prim__zextB8_32 pad))

373+ believe_me (prim__ashrB32 (prim__sextB8_B32 (prim__shlB8 (believe_me x) pad))

374+ (prim__zextB8_B32 pad))

373375 | (O, S (S (S _))) = let pad = getPad {n=0} n in

374− believe_me (prim__ashrB64 (prim__sextB8_64 (prim__shlB8 (believe_me x) pad))

375− (prim__zextB8_64 pad))

376+ believe_me (prim__ashrB64 (prim__sextB8_B64 (prim__shlB8 (believe_me x) pad))

377+ (prim__zextB8_B64 pad))

376378 | (S O, S O) = let pad = getPad {n=1} n in

377379 believe_me (prim__ashrB16 (prim__shlB16 (believe_me x) pad) pad)

378380 | (S O, S (S O)) = let pad = getPad {n=1} n in

379− believe_me (prim__ashrB32 (prim__sextB16_32 (prim__shlB16 (believe_me x) pad))

380− (prim__zextB16_32 pad))

381+ believe_me (prim__ashrB32 (prim__sextB16_B32 (prim__shlB16 (believe_me x) pad))

382+ (prim__zextB16_B32 pad))

381383 | (S O, S (S (S _))) = let pad = getPad {n=1} n in

382− believe_me (prim__ashrB64 (prim__sextB16_64 (prim__shlB16 (believe_me x) pad))

383− (prim__zextB16_64 pad))

384+ believe_me (prim__ashrB64 (prim__sextB16_B64 (prim__shlB16 (believe_me x) pad))

385+ (prim__zextB16_B64 pad))

384386 | (S (S O), S (S O)) = let pad = getPad {n=2} n in

385387 believe_me (prim__ashrB32 (prim__shlB32 (believe_me x) pad) pad)

386388 | (S (S O), S (S (S _))) = let pad = getPad {n=2} n in

387− believe_me (prim__ashrB64 (prim__sextB32_64 (prim__shlB32 (believe_me x) pad))

388− (prim__zextB32_64 pad))

389+ believe_me (prim__ashrB64 (prim__sextB32_B64 (prim__shlB32 (believe_me x) pad))

390+ (prim__zextB32_B64 pad))

389391 | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in

390392 believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad)

391393

392−public

393−signExtend : Bits n -> Bits (n+m)

394−signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x))

394+--public

395+--signExtend : Bits n -> Bits (n+m)

396+--signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x))

395397

396398-- TODO: Prove

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

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

399401 | (O, O) = believe_me x

400− | (O, S O) = believe_me (prim__truncB16_8 (believe_me x))

401− | (O, S (S O)) = believe_me (prim__truncB32_8 (believe_me x))

402− | (O, S (S (S _))) = believe_me (prim__truncB64_8 (believe_me x))

402+ | (O, S O) = believe_me (prim__truncB16_B8 (believe_me x))

403+ | (O, S (S O)) = believe_me (prim__truncB32_B8 (believe_me x))

404+ | (O, S (S (S _))) = believe_me (prim__truncB64_B8 (believe_me x))

403405 | (S O, S O) = believe_me x

404− | (S O, S (S O)) = believe_me (prim__truncB32_16 (believe_me x))

405− | (S O, S (S (S _))) = believe_me (prim__truncB64_16 (believe_me x))

406+ | (S O, S (S O)) = believe_me (prim__truncB32_B16 (believe_me x))

407+ | (S O, S (S (S _))) = believe_me (prim__truncB64_B16 (believe_me x))

406408 | (S (S O), S (S O)) = believe_me x

407− | (S (S O), S (S (S _))) = believe_me (prim__truncB64_32 (believe_me x))

409+ | (S (S O), S (S (S _))) = believe_me (prim__truncB64_B32 (believe_me x))

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

409411

410−public

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

412−truncate (MkBits x) = MkBits (zeroUnused (trunc' x))

412+--public

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

414+--truncate (MkBits x) = MkBits (zeroUnused (trunc' x))

413415

414416public

415417bitAt : Fin n -> Bits n

@@ -437,3 +439,4 @@ bitsToStr x = pack (helper last x)

437439

438440instance Show (Bits n) where

439441 show = bitsToStr

442+

lib/Data/BoundedList.idrnew file+93

@@ -0,0 +1,93 @@

1+module Data.BoundedList

2+

3+%access public

4+%default total

5+

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

7+ Nil : BoundedList a n

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

9+

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

11+length [] = fO

12+length (x :: xs) = fS (length xs)

13+

14+--------------------------------------------------------------------------------

15+-- Indexing into bounded lists

16+--------------------------------------------------------------------------------

17+

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

19+index _ [] = Nothing

20+index fO (x :: _) = Just x

21+index (fS f) (_ :: xs) = index f xs

22+

23+--------------------------------------------------------------------------------

24+-- Adjusting bounds

25+--------------------------------------------------------------------------------

26+

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

28+weaken [] = []

29+weaken (x :: xs) = x :: weaken xs

30+

31+--------------------------------------------------------------------------------

32+-- Conversions to and from list

33+--------------------------------------------------------------------------------

34+

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

36+take _ [] = []

37+take O _ = []

38+take (S n') (x :: xs) = x :: take n' xs

39+

40+toList : BoundedList a n -> List a

41+toList [] = []

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

43+

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

45+fromList [] = []

46+fromList (x :: xs) = x :: fromList xs

47+

48+--------------------------------------------------------------------------------

49+-- Building (bigger) bounded lists

50+--------------------------------------------------------------------------------

51+

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

53+replicate O _ = []

54+replicate (S n) x = x :: replicate n x

55+

56+--------------------------------------------------------------------------------

57+-- Folds

58+--------------------------------------------------------------------------------

59+

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

61+foldl f e [] = e

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

63+

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

65+foldr f e [] = e

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

67+

68+--------------------------------------------------------------------------------

69+-- Maps

70+--------------------------------------------------------------------------------

71+

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

73+map f [] = []

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

75+

76+--------------------------------------------------------------------------------

77+-- Misc

78+--------------------------------------------------------------------------------

79+

80+%assert_total -- not sure why this isn't accepted - clearly decreasing on n

81+pad : (xs : BoundedList a n) -> (padding : a) -> BoundedList a n

82+pad {n=O} [] _ = []

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

84+pad {n=S n'} (x :: xs) padding = x :: pad {n=n'} xs padding

85+

86+

87+--------------------------------------------------------------------------------

88+-- Simple properties

89+--------------------------------------------------------------------------------

90+

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

92+zeroBoundIsEmpty [] = refl

93+zeroBoundIsEmpty (_ :: _) impossible

lib/Data/Morphisms.idr−1

@@ -30,7 +30,6 @@ instance Applicative (Morphism r) where

3030 (Mor f) <$> (Mor a) = Mor $ \r => f r $ a r

3131

3232instance Monad (Morphism r) where

33− return a = Mor $ const a

3433 (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r

3534

3635instance Semigroup (Endomorphism a) where

lib/Data/SortedMap.idrnew file+235

@@ -0,0 +1,235 @@

1+module Data.SortedMap

2+

3+-- TODO: write merge and split

4+

5+data Tree : Nat -> Type -> Type -> Type where

6+ Leaf : k -> v -> Tree O k v

7+ Branch2 : Tree n k v -> k -> Tree n k v -> Tree (S n) k v

8+ Branch3 : Tree n k v -> k -> Tree n k v -> k -> Tree n k v -> Tree (S n) k v

9+

10+branch4 :

11+ Tree n k v -> k ->

12+ Tree n k v -> k ->

13+ Tree n k v -> k ->

14+ Tree n k v ->

15+ Tree (S (S n)) k v

16+branch4 a b c d e f g =

17+ Branch2 (Branch2 a b c) d (Branch2 e f g)

18+

19+branch5 :

20+ Tree n k v -> k ->

21+ Tree n k v -> k ->

22+ Tree n k v -> k ->

23+ Tree n k v -> k ->

24+ Tree n k v ->

25+ Tree (S (S n)) k v

26+branch5 a b c d e f g h i =

27+ Branch2 (Branch2 a b c) d (Branch3 e f g h i)

28+

29+branch6 :

30+ Tree n k v -> k ->

31+ Tree n k v -> k ->

32+ Tree n k v -> k ->

33+ Tree n k v -> k ->

34+ Tree n k v -> k ->

35+ Tree n k v ->

36+ Tree (S (S n)) k v

37+branch6 a b c d e f g h i j k =

38+ Branch3 (Branch2 a b c) d (Branch2 e f g) h (Branch2 i j k)

39+

40+branch7 :

41+ Tree n k v -> k ->

42+ Tree n k v -> k ->

43+ Tree n k v -> k ->

44+ Tree n k v -> k ->

45+ Tree n k v -> k ->

46+ Tree n k v -> k ->

47+ Tree n k v ->

48+ Tree (S (S n)) k v

49+branch7 a b c d e f g h i j k l m =

50+ Branch3 (Branch3 a b c d e) f (Branch2 g h i) j (Branch2 k l m)

51+

52+merge1 : Tree n k v -> k -> Tree (S n) k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v

53+merge1 a b (Branch2 c d e) f (Branch2 g h i) = branch5 a b c d e f g h i

54+merge1 a b (Branch2 c d e) f (Branch3 g h i j k) = branch6 a b c d e f g h i j k

55+merge1 a b (Branch3 c d e f g) h (Branch2 i j k) = branch6 a b c d e f g h i j k

56+merge1 a b (Branch3 c d e f g) h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

57+

58+merge2 : Tree (S n) k v -> k -> Tree n k v -> k -> Tree (S n) k v -> Tree (S (S n)) k v

59+merge2 (Branch2 a b c) d e f (Branch2 g h i) = branch5 a b c d e f g h i

60+merge2 (Branch2 a b c) d e f (Branch3 g h i j k) = branch6 a b c d e f g h i j k

61+merge2 (Branch3 a b c d e) f g h (Branch2 i j k) = branch6 a b c d e f g h i j k

62+merge2 (Branch3 a b c d e) f g h (Branch3 i j k l m) = branch7 a b c d e f g h i j k l m

63+

64+merge3 : Tree (S n) k v -> k -> Tree (S n) k v -> k -> Tree n k v -> Tree (S (S n)) k v

65+merge3 (Branch2 a b c) d (Branch2 e f g) h i = branch5 a b c d e f g h i

66+merge3 (Branch2 a b c) d (Branch3 e f g h i) j k = branch6 a b c d e f g h i j k

67+merge3 (Branch3 a b c d e) f (Branch2 g h i) j k = branch6 a b c d e f g h i j k

68+merge3 (Branch3 a b c d e) f (Branch3 g h i j k) l m = branch7 a b c d e f g h i j k l m

69+

70+treeLookup : Ord k => k -> Tree n k v -> Maybe v

71+treeLookup k (Leaf k' v) =

72+ if k == k' then

73+ Just v

74+ else

75+ Nothing

76+treeLookup k (Branch2 t1 k' t2) =

77+ if k <= k' then

78+ treeLookup k t1

79+ else

80+ treeLookup k t2

81+treeLookup k (Branch3 t1 k1 t2 k2 t3) =

82+ if k <= k1 then

83+ treeLookup k t1

84+ else if k <= k2 then

85+ treeLookup k t2

86+ else

87+ treeLookup k t3

88+

89+treeInsert' : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree n k v, k, Tree n k v)

90+treeInsert' k v (Leaf k' v') =

91+ case compare k k' of

92+ LT => Right (Leaf k v, k, Leaf k' v')

93+ EQ => Left (Leaf k v)

94+ GT => Right (Leaf k' v', k', Leaf k v)

95+treeInsert' k v (Branch2 t1 k' t2) =

96+ if k <= k' then

97+ case treeInsert' k v t1 of

98+ Left t1' => Left (Branch2 t1' k' t2)

99+ Right (a, b, c) => Left (Branch3 a b c k' t2)

100+ else

101+ case treeInsert' k v t2 of

102+ Left t2' => Left (Branch2 t1 k' t2')

103+ Right (a, b, c) => Left (Branch3 t1 k' a b c)

104+treeInsert' k v (Branch3 t1 k1 t2 k2 t3) =

105+ if k <= k1 then

106+ case treeInsert' k v t1 of

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

108+ Right (a, b, c) => Right (Branch2 a b c, k1, Branch2 t2 k2 t3)

109+ else

110+ if k <= k2 then

111+ case treeInsert' k v t2 of

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

113+ Right (a, b, c) => Right (Branch2 t1 k1 a, b, Branch2 c k2 t3)

114+ else

115+ case treeInsert' k v t3 of

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

117+ Right (a, b, c) => Right (Branch2 t1 k2 t2, k2, Branch2 a b c)

118+

119+treeInsert : Ord k => k -> v -> Tree n k v -> Either (Tree n k v) (Tree (S n) k v)

120+treeInsert k v t =

121+ case treeInsert' k v t of

122+ Left t' => Left t'

123+ Right (a, b, c) => Right (Branch2 a b c)

124+

125+delType : Nat -> Type -> Type -> Type

126+delType O k v = ()

127+delType (S n) k v = Tree n k v

128+

129+treeDelete : Ord k => k -> Tree n k v -> Either (Tree n k v) (delType n k v)

130+treeDelete k (Leaf k' v) =

131+ if k == k' then

132+ Right ()

133+ else

134+ Left (Leaf k' v)

135+treeDelete {n=S O} k (Branch2 t1 k' t2) =

136+ if k <= k' then

137+ case treeDelete k t1 of

138+ Left t1' => Left (Branch2 t1' k' t2)

139+ Right () => Right t2

140+ else

141+ case treeDelete k t2 of

142+ Left t2' => Left (Branch2 t1 k' t2')

143+ Right () => Right t1

144+treeDelete {n=S O} k (Branch3 t1 k1 t2 k2 t3) =

145+ if k <= k1 then

146+ case treeDelete k t1 of

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

148+ Right () => Left (Branch2 t2 k2 t3)

149+ else if k <= k2 then

150+ case treeDelete k t2 of

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

152+ Right () => Left (Branch2 t1 k1 t3)

153+ else

154+ case treeDelete k t3 of

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

156+ Right () => Left (Branch2 t1 k1 t2)

157+treeDelete {n=S (S _)} k (Branch2 t1 k' t2) =

158+ if k <= k' then

159+ case treeDelete k t1 of

160+ Left t1' => Left (Branch2 t1' k' t2)

161+ Right t1' =>

162+ case t2 of

163+ Branch2 a b c => Right (Branch3 t1' k' a b c)

164+ Branch3 a b c d e => Left (branch4 t1' k' a b c d e)

165+ else

166+ case treeDelete k t2 of

167+ Left t2' => Left (Branch2 t1 k' t2')

168+ Right t2' =>

169+ case t1 of

170+ Branch2 a b c => Right (Branch3 a b c k' t2')

171+ Branch3 a b c d e => Left (branch4 a b c d e k' t2')

172+treeDelete {n=(S (S _))} k (Branch3 t1 k1 t2 k2 t3) =

173+ if k <= k1 then

174+ case treeDelete k t1 of

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

176+ Right t1' => Left (merge1 t1' k1 t2 k2 t3)

177+ else if k <= k2 then

178+ case treeDelete k t2 of

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

180+ Right t2' => Left (merge2 t1 k1 t2' k2 t3)

181+ else

182+ case treeDelete k t3 of

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

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

185+

186+-- FIXME: this is very inefficient

187+treeToList : Ord k => Tree n k v -> List (k, v)

188+treeToList (Leaf k v) = [(k, v)]

189+treeToList (Branch2 t1 _ t2) = treeToList t1 ++ treeToList t2

190+treeToList (Branch3 t1 _ t2 _ t3) = treeToList t1 ++ treeToList t2 ++ treeToList t3

191+

192+data SortedMap : Type -> Type -> Type where

193+ Empty : SortedMap k v

194+ M : (n:Nat) -> Tree n k v -> SortedMap k v

195+

196+empty : SortedMap k v

197+empty = Empty

198+

199+lookup : Ord k => k -> SortedMap k v -> Maybe v

200+lookup _ Empty = Nothing

201+lookup k (M _ t) = treeLookup k t

202+

203+insert : Ord k => k -> v -> SortedMap k v -> SortedMap k v

204+insert k v Empty = M O (Leaf k v)

205+insert k v (M _ t) =

206+ case treeInsert k v t of

207+ Left t' => (M _ t')

208+ Right t' => (M _ t')

209+

210+delete : Ord k => k -> SortedMap k v -> SortedMap k v

211+delete _ Empty = Empty

212+delete k (M O t) =

213+ case treeDelete k t of

214+ Left t' => (M _ t')

215+ Right () => Empty

216+delete k (M (S _) t) =

217+ case treeDelete k t of

218+ Left t' => (M _ t')

219+ Right t' => (M _ t')

220+

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

222+fromList l = foldl (flip (uncurry insert)) empty l

223+

224+toList : Ord k => SortedMap k v -> List (k, v)

225+toList Empty = []

226+toList (M _ t) = treeToList t

227+

228+instance Functor (Tree n k) where

229+ fmap f (Leaf k v) = Leaf k (f v)

230+ fmap f (Branch2 t1 k t2) = Branch2 (fmap f t1) k (fmap f t2)

231+ fmap f (Branch3 t1 k1 t2 k2 t3) = Branch3 (fmap f t1) k1 (fmap f t2) k2 (fmap f t3)

232+

233+instance Functor (SortedMap k) where

234+ fmap _ Empty = Empty

235+ fmap f (M n t) = M _ (fmap f t)

lib/Data/SortedSet.idrnew file+25

@@ -0,0 +1,25 @@

1+module Data.SortedSet

2+

3+import Data.SortedMap

4+

5+-- TODO: add intersection, union, difference

6+

7+data SortedSet k = SetWrapper (Data.SortedMap.SortedMap k ())

8+

9+empty : SortedSet k

10+empty = SetWrapper Data.SortedMap.empty

11+

12+insert : Ord k => k -> SortedSet k -> SortedSet k

13+insert k (SetWrapper m) = SetWrapper (Data.SortedMap.insert k () m)

14+

15+delete : Ord k => k -> SortedSet k -> SortedSet k

16+delete k (SetWrapper m) = SetWrapper (Data.SortedMap.delete k m)

17+

18+contains : Ord k => k -> SortedSet k -> Bool

19+contains k (SetWrapper m) = isJust (Data.SortedMap.lookup k m)

20+

21+fromList : Ord k => List k -> SortedSet k

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

23+

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

25+toList (SetWrapper m) = map (\(i, _) => i) (Data.SortedMap.toList m)

lib/Data/Vect/Quantifiers.idrnew file+47

@@ -0,0 +1,47 @@

1+module Data.Vect.Quantifiers

2+

3+data Any : (P : a -> Type) -> Vect a n -> Type where

4+ Here : {P : a -> Type} -> {xs : Vect a n} -> P x -> Any P (x :: xs)

5+ There : {P : a -> Type} -> {xs : Vect a n} -> Any P xs -> Any P (x :: xs)

6+

7+anyNilAbsurd : {P : a -> Type} -> Any P Nil -> _|_

8+anyNilAbsurd Here impossible

9+anyNilAbsurd There impossible

10+

11+anyElim : {xs : Vect a n} -> {P : a -> Type} -> (Any P xs -> b) -> (P x -> b) -> Any P (x :: xs) -> b

12+anyElim _ f (Here p) = f p

13+anyElim f _ (There p) = f p

14+

15+any : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect a n) -> Dec (Any P xs)

16+any _ Nil = No anyNilAbsurd

17+any p (x::xs) with (p x)

18+ | Yes prf = Yes (Here prf)

19+ | No prf =

20+ case any p xs of

21+ Yes prf' => Yes (There prf')

22+ No prf' => No (anyElim prf' prf)

23+

24+data All : (P : a -> Type) -> Vect a n -> Type where

25+ Nil : {P : a -> Type} -> All P Nil

26+ (::) : {P : a -> Type} -> {xs : Vect a n} -> P x -> All P xs -> All P (x :: xs)

27+

28+negAnyAll : {P : a -> Type} -> {xs : Vect a n} -> Not (Any P xs) -> All (\x => Not (P x)) xs

29+negAnyAll {xs=Nil} _ = Nil

30+negAnyAll {xs=(x::xs)} f = (\x => f (Here x)) :: negAnyAll (\x => f (There x))

31+

32+notAllHere : {P : a -> Type} -> {xs : Vect a n} -> Not (P x) -> All P (x :: xs) -> _|_

33+notAllHere _ Nil impossible

34+notAllHere np (p :: _) = np p

35+

36+notAllThere : {P : a -> Type} -> {xs : Vect a n} -> Not (All P xs) -> All P (x :: xs) -> _|_

37+notAllThere _ Nil impossible

38+notAllThere np (_ :: ps) = np ps

39+

40+all : {P : a -> Type} -> ((x : a) -> Dec (P x)) -> (xs : Vect a n) -> Dec (All P xs)

41+all _ Nil = Yes Nil

42+all d (x::xs) with (d x)

43+ | No prf = No (notAllHere prf)

44+ | Yes prf =

45+ case all d xs of

46+ Yes prf' => Yes (prf :: prf')

47+ No prf' => No (notAllThere prf')

lib/Decidable/Decidable.idrnew file+24

@@ -0,0 +1,24 @@

1+module Decidable.Decidable

2+

3+%access public

4+

5+--------------------------------------------------------------------------------

6+-- Typeclass for decidable n-ary Relations

7+--------------------------------------------------------------------------------

8+

9+{-

10+This can't work yet! The class parameters must appear in the method type

11+signatures otherwise when defining the instances class resolution doesn't

12+have any clues...

13+

14+using (t : Type)

15+ class Rel (p : t) where

16+ total liftRel : (Type -> Type) -> Type

17+

18+ class (Rel p) => Decidable (p : t) where

19+ total decide : liftRel Dec

20+

21+using (P : Type, p : P)

22+ data Given : Dec P -> Type where

23+ always : Given (Yes p)

24+-}

lib/Decidable/Equality.idr+1−1

@@ -75,7 +75,7 @@ total leftNotRight : {x : a} -> {y : b} -> Left {b = b} x = Right {a = a} y -> _

7575leftNotRight refl impossible

7676

7777instance (DecEq a, DecEq b) => DecEq (Either a b) where

78− decEq {b=b} (Left x') (Left y') with (decEq x' y')

78+ decEq (Left x') (Left y') with (decEq x' y')

7979 | Yes p = Yes $ cong p

8080 | No p = No $ \h : Left x' = Left y' => p $ leftInjective {b = b} h

8181 decEq (Right x') (Right y') with (decEq x' y')

lib/Decidable/Order.idrnew file+87

@@ -0,0 +1,87 @@

1+module Decidable.Order

2+

3+%access public

4+

5+{-

6+Doesn't work yet, see note in Decidable.idr

7+

8+import Decidable.Decidable

9+import Decidable.Equality

10+

11+--------------------------------------------------------------------------------

12+-- Utility Lemmas

13+--------------------------------------------------------------------------------

14+

15+--------------------------------------------------------------------------------

16+-- Preorders and Posets

17+--------------------------------------------------------------------------------

18+

19+class Preorder t (po : t -> t -> Type) where

20+ total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c

21+ total reflexive : (a : t) -> po a a

22+

23+class (Preorder t po) => Poset t (po : t -> t -> Type) where

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

25+

26+--------------------------------------------------------------------------------

27+-- Natural numbers

28+--------------------------------------------------------------------------------

29+

30+data NatLTE : Nat -> Nat -> Type where

31+ nEqn : NatLTE n n

32+ nLTESm : NatLTE n m -> NatLTE n (S m)

33+

34+total NatLTEIsTransitive : (m : Nat) -> (n : Nat) -> (o : Nat) ->

35+ NatLTE m n -> NatLTE n o ->

36+ NatLTE m o

37+NatLTEIsTransitive m n n mLTEn (nEqn) = mLTEn

38+NatLTEIsTransitive m n (S o) mLTEn (nLTESm nLTEo)

39+ = nLTESm (NatLTEIsTransitive m n o mLTEn nLTEo)

40+

41+total NatLTEIsReflexive : (n : Nat) -> NatLTE n n

42+NatLTEIsReflexive _ = nEqn

43+

44+instance Preorder Nat NatLTE where

45+ transitive = NatLTEIsTransitive

46+ reflexive = NatLTEIsReflexive

47+

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

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

50+NatLTEIsAntisymmetric n n nEqn nEqn = refl

51+NatLTEIsAntisymmetric n m nEqn (nLTESm _) impossible

52+NatLTEIsAntisymmetric n m (nLTESm _) nEqn impossible

53+NatLTEIsAntisymmetric n m (nLTESm _) (nLTESm _) impossible

54+

55+instance Poset Nat NatLTE where

56+ antisymmetric = NatLTEIsAntisymmetric

57+

58+total zeroNeverGreater : {n : Nat} -> NatLTE (S n) O -> _|_

59+zeroNeverGreater {n} (nLTESm _) impossible

60+zeroNeverGreater {n} nEqn impossible

61+

62+total

63+nGTSm : {n : Nat} -> {m : Nat} -> (NatLTE n m -> _|_) -> NatLTE n (S m) -> _|_

64+nGTSm disprf (nLTESm nLTEm) = FalseElim (disprf nLTEm)

65+nGTSm {n} {m} disprf (nEqn) impossible

66+

67+total

68+decideNatLTE : (n : Nat) -> (m : Nat) -> Dec (NatLTE n m)

69+decideNatLTE O O = Yes nEqn

70+decideNatLTE (S x) O = No zeroNeverGreater

71+decideNatLTE x (S y) with (decEq x (S y))

72+ | Yes eq = rewrite eq in Yes nEqn

73+ | No _ with (decideNatLTE x y)

74+ | Yes nLTEm = Yes (nLTESm nLTEm)

75+ | No nGTm = No (nGTSm nGTm)

76+

77+instance Rel NatLTE where

78+ liftRel P = (n : Nat) -> (m : Nat) -> P (NatLTE n m)

79+

80+instance Decidable NatLTE where

81+ decide = decideNatLTE

82+

83+lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n)

84+lte m n = decide {p = NatLTE} m n

85+

86+-}

87+

lib/IO.idr+32−8

@@ -21,16 +21,40 @@ io_return x = prim__IO x

2121run__IO : IO () -> IO ()

2222run__IO v = io_bind v (\v' => io_return v')

2323

24+data IntTy = ITNative | IT8 | IT16 | IT32 | IT64

25+data FTy = FIntT IntTy

26+ | FFunction FTy FTy

27+ | FFloat

28+ | FString

29+ | FPtr

30+ | FAny Type

31+ | FUnit

32+

33+FInt : FTy

34+FInt = FIntT ITNative

35+

36+FChar : FTy

37+FChar = FIntT IT8

38+

39+FShort : FTy

40+FShort = FIntT IT16

41+

42+FLong : FTy

43+FLong = FIntT IT64

2544

2645interpFTy : FTy -> Type

27−interpFTy FInt = Int

28−interpFTy FFloat = Float

29−interpFTy FChar = Char

30−interpFTy FString = String

31−interpFTy FPtr = Ptr

32−interpFTy (FAny t) = t

33−interpFTy FUnit = ()

46+interpFTy (FIntT ITNative) = Int

47+interpFTy (FIntT IT8) = Bits8

48+interpFTy (FIntT IT16) = Bits16

49+interpFTy (FIntT IT32) = Bits32

50+interpFTy (FIntT IT64) = Bits64

51+interpFTy (FAny t) = t

52+interpFTy FFloat = Float

53+interpFTy FString = String

54+interpFTy FPtr = Ptr

55+interpFTy FUnit = ()

56+

57+interpFTy (FFunction a b) = interpFTy a -> interpFTy b

3458

3559ForeignTy : (xs:List FTy) -> (t:FTy) -> Type

3660ForeignTy Nil rt = IO (interpFTy rt)

lib/Language/Reflection/Utils.idrnew file+185

@@ -0,0 +1,185 @@

1+module Language.Reflection.Utils

2+

3+--------------------------------------------------------

4+-- Tactic construction conveniences

5+--------------------------------------------------------

6+

7+seq : List Tactic -> Tactic

8+seq [] = GoalType "This is an impossible case" Trivial

9+seq [t] = t

10+seq (t::ts) = t `Seq` seq ts

11+

12+try : List Tactic -> Tactic

13+try [] = GoalType "This is an impossible case" Trivial

14+try [t] = t

15+try (t::ts) = t `Try` seq ts

16+

17+

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

19+-- For use in tactic scripts

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

21+mkPair : a -> b -> (a, b)

22+mkPair a b = (a, b)

23+

24+

25+--------------------------------------------------------

26+-- Tools for constructing proof terms directly

27+--------------------------------------------------------

28+

29+getUName : TTName -> Maybe String

30+getUName (UN n) = Just n

31+getUName (NS n ns) = getUName n

32+getUName _ = Nothing

33+

34+unApply : TT -> (TT, List TT)

35+unApply t = unA t []

36+ where unA : TT -> List TT -> (TT, List TT)

37+ unA (App fn arg) args = unA fn (arg::args)

38+ unA tm args = (tm, args)

39+

40+mkApp : TT -> List TT -> TT

41+mkApp tm [] = tm

42+mkApp tm (a::as) = mkApp (App tm a) as

43+

44+binderTy : (Eq t) => Binder t -> t

45+binderTy (Lam t) = t

46+binderTy (Pi t) = t

47+binderTy (Let t1 t2) = t1

48+binderTy (NLet t1 t2) = t1

49+binderTy (Hole t) = t

50+binderTy (GHole t) = t

51+binderTy (Guess t1 t2) = t1

52+binderTy (PVar t) = t

53+binderTy (PVTy t) = t

54+

55+instance Show TTName where

56+ show (UN str) = "(UN " ++ str ++ ")"

57+ show (NS n ns) = "(NS " ++ show n ++ " " ++ show ns ++ ")"

58+ show (MN i str) = "(MN " ++ show i ++ " " ++ show str ++ ")"

59+ show NErased = "NErased"

60+

61+instance Eq TTName where

62+ (UN str1) == (UN str2) = str1 == str2

63+ (NS n ns) == (NS n' ns') = n == n' && ns == ns'

64+ (MN i str) == (MN i' str') = i == i' && str == str'

65+ NErased == NErased = True

66+ x == y = False

67+

68+instance Show TTUExp where

69+ show (UVar i) = "(UVar " ++ show i ++ ")"

70+ show (UVal i) = "(UVal " ++ show i ++ ")"

71+

72+instance Eq TTUExp where

73+ (UVar i) == (UVar j) = i == j

74+ (UVal i) == (UVal j) = i == j

75+ x == y = False

76+

77+instance Show Const where

78+ show (I i) = "(I " ++ show i ++ ")"

79+ show (BI n) = "(BI " ++ show n ++ ")"

80+ show (Fl f) = "(Fl " ++ show f ++ ")"

81+ show (Ch c) = "(Ch " ++ show c ++ ")"

82+ show (Str str) = "(Str " ++ show str ++ ")"

83+ show IType = "IType"

84+ show BIType = "BIType"

85+ show FlType = "FlType"

86+ show ChType = "ChType"

87+ show StrType = "StrType"

88+ show (B8 b) = "(B8 ...)"

89+ show (B16 b) = "(B16 ...)"

90+ show (B32 b) = "(B32 ...)"

91+ show (B64 b) = "(B64 ...)"

92+ show B8Type = "B8Type"

93+ show B16Type = "B16Type"

94+ show B32Type = "B32Type"

95+ show B64Type = "B64Type"

96+ show PtrType = "PtrType"

97+ show VoidType = "VoidType"

98+ show Forgot = "Forgot"

99+

100+instance Eq Const where

101+ (I i) == (I i') = i == i'

102+ (BI n) == (BI n') = n == n'

103+ (Fl f) == (Fl f') = f == f'

104+ (Ch c) == (Ch c') = c == c'

105+ (Str str) == (Str str') = str == str'

106+ IType == IType = True

107+ BIType == BIType = True

108+ FlType == FlType = True

109+ ChType == ChType = True

110+ StrType == StrType = True

111+ (B8 b) == (B8 b') = False -- FIXME: b == b'

112+ (B16 b) == (B16 b') = False -- FIXME: b == b'

113+ (B32 b) == (B32 b') = False -- FIXME: b == b'

114+ (B64 b) == (B64 b') = False -- FIXME: b == b'

115+ B8Type == B8Type = True

116+ B16Type == B16Type = True

117+ B32Type == B32Type = True

118+ B64Type == B64Type = True

119+ PtrType == PtrType = True

120+ VoidType == VoidType = True

121+ Forgot == Forgot = True

122+ x == y = False

123+

124+instance Show NameType where

125+ show Bound = "Bound"

126+ show Ref = "Ref"

127+ show (DCon t ar) = "(DCon " ++ show t ++ " " ++ show ar ++ ")"

128+ show (TCon t ar) = "(TCon " ++ show t ++ " " ++ show ar ++ ")"

129+

130+instance Eq NameType where

131+ Bound == Bound = True

132+ Ref == Ref = True

133+ (DCon t ar) == (DCon t' ar') = t == t' && ar == ar'

134+ (TCon t ar) == (TCon t' ar') = t == t' && ar == ar'

135+ x == y = False

136+

137+instance (Show a) => Show (Binder a) where

138+ show (Lam t) = "(Lam " ++ show t ++ ")"

139+ show (Pi t) = "(Pi " ++ show t ++ ")"

140+ show (Let t1 t2) = "(Let " ++ show t1 ++ " " ++ show t2 ++ ")"

141+ show (NLet t1 t2) = "(NLet " ++ show t1 ++ " " ++ show t2 ++ ")"

142+ show (Hole t) = "(Hole " ++ show t ++ ")"

143+ show (GHole t) = "(GHole " ++ show t ++ ")"

144+ show (Guess t1 t2) = "(Guess " ++ show t1 ++ " " ++ show t2 ++ ")"

145+ show (PVar t) = "(PVar " ++ show t ++ ")"

146+ show (PVTy t) = "(PVTy " ++ show t ++ ")"

147+

148+instance (Eq a) => Eq (Binder a) where

149+ (Lam t) == (Lam t') = t == t'

150+ (Pi t) == (Pi t') = t == t'

151+ (Let t1 t2) == (Let t1' t2') = t1 == t1' && t2 == t2'

152+ (NLet t1 t2) == (NLet t1' t2') = t1 == t1' && t2 == t2'

153+ (Hole t) == (Hole t') = t == t'

154+ (GHole t) == (GHole t') = t == t'

155+ (Guess t1 t2) == (Guess t1' t2') = t1 == t1' && t2 == t2'

156+ (PVar t) == (PVar t') = t == t'

157+ (PVTy t) == (PVTy t') = t == t'

158+ x == y = False

159+

160+instance Show TT where

161+ show = my_show

162+ where %assert_total my_show : TT -> String

163+ my_show (P nt n t) = "(P " ++ show nt ++ " " ++ show n ++ " " ++ show t ++ ")"

164+ my_show (V i) = "(V " ++ show i ++ ")"

165+ my_show (Bind n b t) = "(Bind " ++ show n ++ " " ++ show b ++ " " ++ show t ++ ")"

166+ my_show (App t1 t2) = "(App " ++ show t1 ++ " " ++ show t2 ++ ")"

167+ my_show (TConst c) = "(TConst " ++ show c ++ ")"

168+ my_show (Proj tm i) = "(Proj " ++ show tm ++ " " ++ show i ++ ")"

169+ my_show Erased = "Erased"

170+ my_show Impossible = "Impossible"

171+ my_show (TType u) = "(TType " ++ show u ++ ")"

172+

173+instance Eq TT where

174+ a == b = equalp a b

175+ where %assert_total equalp : TT -> TT -> Bool

176+ equalp (P nt n t) (P nt' n' t') = nt == nt' && n == n' && t == t'

177+ equalp (V i) (V i') = i == i'

178+ equalp (Bind n b t) (Bind n' b' t') = n == n' && b == b' && t == t'

179+ equalp (App t1 t2) (App t1' t2') = t1 == t1' && t2 == t2'

180+ equalp (TConst c) (TConst c') = c == c'

181+ equalp (Proj tm i) (Proj tm' i') = tm == tm' && i == i'

182+ equalp Erased Erased = True

183+ equalp Impossible Impossible = True

184+ equalp (TType u) (TType u') = u == u'

185+ equalp x y = False

lib/Network/Cgi.idr+1−3

@@ -41,8 +41,6 @@ instance Applicative CGI where

4141instance Monad CGI where {

4242 (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s

4343 getAction (k (fst v)) (snd v))

44−

45− return v = MkCGI (\s => return (v, s))

4644}

4745

4846setInfo : CGIInfo -> CGI ()

@@ -121,7 +119,7 @@ abstract

121119runCGI : CGI a -> IO a

122120runCGI prog = do

123121 clen_in <- getEnv "CONTENT_LENGTH"

124− let clen = prim__strToInt clen_in

122+ let clen = prim__fromStrInt clen_in

125123 content <- getContent clen

126124 query <- getEnv "QUERY_STRING"

127125 cookie <- getEnv "HTTP_COOKIE"

lib/Prelude.idr+20−13

@@ -29,10 +29,10 @@ instance Show Nat where

2929 show (S k) = "s" ++ show k

3030

3131instance Show Int where

32− show = prim__intToStr

32+ show = prim__toStrInt

3333

3434instance Show Integer where

35− show = prim__bigIntToStr

35+ show = prim__toStrBigInt

3636

3737instance Show Float where

3838 show = prim__floatToStr

@@ -124,23 +124,17 @@ instance Alternative List where

124124---- Monad instances

125125

126126instance Monad IO where

127− return t = io_return t

128127 b >>= k = io_bind b k

129128

130129instance Monad Maybe where

131− return t = Just t

132−

133130 Nothing >>= k = Nothing

134131 (Just x) >>= k = k x

135132

136133instance Monad (Either e) where

137− return = Right

138−

139134 (Left n) >>= _ = Left n

140135 (Right r) >>= f = f r

141136

142137instance Monad List where

143− return x = [x]

144138 m >>= f = concatMap f m

145139

146140---- some mathematical operations

@@ -148,6 +142,10 @@ instance Monad List where

148142%include "math.h"

149143%lib "m"

150144

145+pow : (Num a) => a -> Nat -> a

146+pow x O = 1

147+pow x (S n) = x * (pow x n)

148+

151149exp : Float -> Float

152150exp x = prim__floatExp x

153151

@@ -178,6 +176,15 @@ atan x = prim__floatATan x

178176atan2 : Float -> Float -> Float

179177atan2 y x = atan (y/x)

180178

179+sinh : Float -> Float

180+sinh x = (exp x - exp (-x)) / 2

181+

182+cosh : Float -> Float

183+cosh x = (exp x + exp (-x)) / 2

184+

185+tanh : Float -> Float

186+tanh x = sinh x / cosh x

187+

181188sqrt : Float -> Float

182189sqrt x = prim__floatSqrt x

183190

@@ -189,12 +196,12 @@ ceiling x = prim__floatCeil x

189196

190197---- Ranges

191198

192−%assert_total

199+partial abstract

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

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

195202 else []

196203

197−partial

204+partial abstract

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

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

200207

@@ -242,11 +249,11 @@ getLine = return (prim__readString prim__stdin)

242249

243250partial

244251putChar : Char -> IO ()

245−putChar c = mkForeign (FFun "putchar" [FChar] FUnit) c

252+putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)

246253

247254partial

248255getChar : IO Char

249−getChar = mkForeign (FFun "getchar" [] FChar)

256+getChar = fmap cast $ mkForeign (FFun "getchar" [] FInt)

250257

251258---- some basic file handling

252259

@@ -314,7 +321,7 @@ ferror (FHandle h) = do err <- do_ferror h

314321

315322partial

316323nullPtr : Ptr -> IO Bool

317−nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

324+nullPtr p = do ok <- mkForeign (FFun "isNull" [FPtr] FInt) p

318325 return (ok /= 0);

319326

320327partial

lib/Prelude/Cast.idr+7−7

@@ -6,24 +6,24 @@ class Cast from to where

66-- String casts

77

88instance Cast String Int where

9− cast = prim__strToInt

9+ cast = prim__fromStrInt

1010

1111instance Cast String Float where

1212 cast = prim__strToFloat

1313

1414instance Cast String Integer where

15− cast = prim__strToBigInt

15+ cast = prim__fromStrBigInt

1616

1717-- Int casts

1818

1919instance Cast Int String where

20− cast = prim__intToStr

20+ cast = prim__toStrInt

2121

2222instance Cast Int Float where

23− cast = prim__intToFloat

23+ cast = prim__toFloatInt

2424

2525instance Cast Int Integer where

26− cast = prim__intToBigInt

26+ cast = prim__sextInt_BigInt

2727

2828instance Cast Int Char where

2929 cast = prim__intToChar

@@ -34,12 +34,12 @@ instance Cast Float String where

3434 cast = prim__floatToStr

3535

3636instance Cast Float Int where

37− cast = prim__floatToInt

37+ cast = prim__fromFloatInt

3838

3939-- Integer casts

4040

4141instance Cast Integer String where

42− cast = prim__bigIntToStr

42+ cast = prim__toStrBigInt

4343

4444-- Char casts

4545

lib/Prelude/List.idr+1

@@ -399,6 +399,7 @@ span p (x::xs) =

399399break : (a -> Bool) -> List a -> (List a, List a)

400400break p = span (not . p)

401401

402+%assert_total

402403split : (a -> Bool) -> List a -> List (List a)

403404split p [] = []

404405split p xs =

lib/Prelude/Maybe.idr+1−1

@@ -66,7 +66,7 @@ instance (Eq a) => Eq (Maybe a) where

6666-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to

6767-- <http://en.wikipedia.org/wiki/Monoid>: "Any semigroup S may be

6868-- turned into a monoid simply by adjoining an element i not in S

69−-- and defining i+i = i and i+s = s = s+i for all s ∈ S."

69+-- and defining i+i = i and i+s = s = s+i for all s in S."

7070

7171instance (Semigroup a) => Semigroup (Maybe a) where

7272 Nothing <+> m = m

lib/Prelude/Monad.idr+3−1

@@ -11,8 +11,10 @@ import Prelude.Applicative

1111infixl 5 >>=

1212

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

14− return : a -> m a

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

1615

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

1817flatten a = a >>= id

18+

19+return : Monad m => a -> m a

20+return = pure

lib/Providers.idr+1−4

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

11module Providers

22

33public

4−data Provider a = Provide (IO a) | Error (IO String)

4+data Provider a = Provide a | Error String

55

6−partial public

7−unProv : Provider a -> a

8−unProv (Provide x) = unsafePerformIO x

lib/System/Concurrency/Process.idr−1

@@ -23,7 +23,6 @@ instance Applicative (Process msg) where

2323 (lift f) <$> (lift a) = lift (f <$> a)

2424

2525instance Monad (Process msg) where

26− return = lift . return

2726 (lift io) >>= k = lift (do x <- io

2827 case k x of

2928 lift v => v)

lib/base.ipkg+7−3

@@ -13,15 +13,19 @@ modules = Builtins, Prelude, IO, System,

1313

1414 System.Concurrency.Raw, System.Concurrency.Process,

1515

16− Decidable.Equality,

16+ Decidable.Equality, Decidable.Decidable, Decidable.Order,

1717

1818 Uninhabited,

1919

2020 Providers,

2121

22− Language.Reflection,

22+ Language.Reflection, Language.Reflection.Utils,

2323

24− Data.Morphisms, Data.Bits, Data.Mod2, Data.Z, Data.Sign,

24+ Data.Morphisms,

25+ Data.Bits, Data.Mod2,

26+ Data.Z, Data.Sign,

27+ Data.SortedMap, Data.SortedSet, Data.BoundedList,

28+ Data.Vect.Quantifiers,

2529

2630 Control.Monad.Identity, Control.Monad.State, Control.Category,

2731 Control.Arrow,

rts/Makefile+4−4

@@ -2,15 +2,15 @@ include ../config.mk

22

33OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_stdfgn.o idris_bitstring.o idris_opts.o idris_stats.o

44HDRS = idris_rts.h idris_heap.h idris_gc.h idris_gmp.h idris_stdfgn.h idris_bitstring.h idris_opts.h idris_stats.h

5−CFLAGS = -O2 -Wall

5+CFLAGS = -O2 -Wall -fPIC

66

77ifneq ($(GMP_INCLUDE_DIR),)

8− CFLAGS += -isystem $(GMP_INCLUDE_DIR)

8+ CFLAGS += -isystem $(GMP_INCLUDE_DIR)

99endif

1010

1111LIBTARGET = libidris_rts.a

1212

13−check : $(LIBTARGET)

13+check : $(LIBTARGET) $(DYLIBTARGET)

1414

1515$(LIBTARGET) : $(OBJS)

1616 ar r $(LIBTARGET) $(OBJS)

@@ -21,7 +21,7 @@ install : .PHONY

2121 install $(LIBTARGET) $(HDRS) $(TARGET)

2222

2323clean : .PHONY

24− rm -f $(OBJS) $(LIBTARGET)

24+ rm -f $(OBJS) $(LIBTARGET) $(DYLIBTARGET)

2525

2626idris_rts.o: idris_rts.h

2727

rts/idris_bitstring.c+28

@@ -60,6 +60,34 @@ VAL idris_castB32Int(VM *vm, VAL a) {

6060 return MKINT((i_int)a->info.bits32);

6161}

6262

63+VAL idris_b8const(VM *vm, uint8_t a) {

64+ VAL cl = allocate(vm, sizeof(Closure), 0);

65+ SETTY(cl, BITS8);

66+ cl->info.bits8 = a;

67+ return cl;

68+}

69+

70+VAL idris_b16const(VM *vm, uint16_t a) {

71+ VAL cl = allocate(vm, sizeof(Closure), 0);

72+ SETTY(cl, BITS16);

73+ cl->info.bits16 = a;

74+ return cl;

75+}

76+

77+VAL idris_b32const(VM *vm, uint32_t a) {

78+ VAL cl = allocate(vm, sizeof(Closure), 0);

79+ SETTY(cl, BITS32);

80+ cl->info.bits32 = a;

81+ return cl;

82+}

83+

84+VAL idris_b64const(VM *vm, uint64_t a) {

85+ VAL cl = allocate(vm, sizeof(Closure), 0);

86+ SETTY(cl, BITS64);

87+ cl->info.bits64 = a;

88+ return cl;

89+}

90+

6391VAL idris_b8Plus(VM *vm, VAL a, VAL b) {

6492 VAL cl = allocate(vm, sizeof(Closure), 0);

6593 SETTY(cl, BITS8);

rts/idris_bitstring.h+4

@@ -11,6 +11,10 @@ VAL idris_b16(VM *vm, VAL a);

1111VAL idris_b32(VM *vm, VAL a);

1212VAL idris_b64(VM *vm, VAL a);

1313VAL idris_castB32Int(VM *vm, VAL a);

14+VAL idris_b8const(VM *vm, uint8_t a);

15+VAL idris_b16const(VM *vm, uint16_t a);

16+VAL idris_b32const(VM *vm, uint32_t a);

17+VAL idris_b64const(VM *vm, uint64_t a);

1418

1519VAL idris_b8Plus(VM *vm, VAL a, VAL b);

1620VAL idris_b8Minus(VM *vm, VAL a, VAL b);

rts/idris_gmp.c+52

@@ -52,6 +52,34 @@ VAL MKBIGMc(VM* vm, void* big) {

5252 return cl;

5353}

5454

55+VAL MKBIGUI(VM* vm, unsigned long val) {

56+ mpz_t* bigint;

57+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +

58+ sizeof(mpz_t), 0);

59+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));

60+

61+ mpz_init_set_ui(*bigint, val);

62+

63+ SETTY(cl, BIGINT);

64+ cl -> info.ptr = (void*)bigint;

65+

66+ return cl;

67+}

68+

69+VAL MKBIGSI(VM* vm, signed long val) {

70+ mpz_t* bigint;

71+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +

72+ sizeof(mpz_t), 0);

73+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));

74+

75+ mpz_init_set_si(*bigint, val);

76+

77+ SETTY(cl, BIGINT);

78+ cl -> info.ptr = (void*)bigint;

79+

80+ return cl;

81+}

82+

5583VAL GETBIG(VM * vm, VAL x) {

5684 if (ISINT(x)) {

5785 mpz_t* bigint;

@@ -280,6 +308,30 @@ VAL idris_castBigInt(VM* vm, VAL i) {

280308 }

281309}

282310

311+VAL idris_castBigFloat(VM* vm, VAL i) {

312+ if (ISINT(i)) {

313+ return MKFLOAT(vm, GETINT(i));

314+ } else {

315+ return MKFLOAT(vm, mpz_get_d(GETMPZ(i)));

316+ }

317+}

318+

319+VAL idris_castFloatBig(VM* vm, VAL f) {

320+ double val = GETFLOAT(f);

321+

322+ mpz_t* bigint;

323+ VAL cl = allocate(vm, sizeof(ClosureType) + sizeof(void*) +

324+ sizeof(mpz_t), 0);

325+ bigint = (mpz_t*)(((char*)cl) + sizeof(ClosureType) + sizeof(void*));

326+

327+ mpz_init_set_d(*bigint, val);

328+

329+ SETTY(cl, BIGINT);

330+ cl -> info.ptr = (void*)bigint;

331+

332+ return cl;

333+}

334+

283335VAL idris_castStrBig(VM* vm, VAL i) {

284336 return MKBIGC(vm, GETSTR(i));

285337}

rts/idris_gmp.h+4

@@ -5,6 +5,8 @@ VAL MKBIGI(int val);

55VAL MKBIGC(VM* vm, char* bigint);

66VAL MKBIGM(VM* vm, void* bigint);

77VAL MKBIGMc(VM* vm, void* bigint);

8+VAL MKBIGUI(VM* vm, unsigned long val);

9+VAL MKBIGSI(VM* vm, signed long val);

810

911VAL idris_bigPlus(VM*, VAL x, VAL y);

1012VAL idris_bigMinus(VM*, VAL x, VAL y);

@@ -22,6 +24,8 @@ VAL idris_bigGe(VM*, VAL x, VAL y);

2224

2325VAL idris_castIntBig(VM* vm, VAL i);

2426VAL idris_castBigInt(VM* vm, VAL i);

27+VAL idris_castFloatBig(VM* vm, VAL i);

28+VAL idris_castBigFloat(VM* vm, VAL i);

2529VAL idris_castStrBig(VM* vm, VAL i);

2630VAL idris_castBigStr(VM* vm, VAL i);

2731

rts/idris_rts.c+44

@@ -186,6 +186,34 @@ VAL MKPTRc(VM* vm, void* ptr) {

186186 return cl;

187187}

188188

189+VAL MKB8(VM* vm, uint8_t bits8) {

190+ Closure* cl = allocate(vm, sizeof(Closure), 1);

191+ SETTY(cl, BITS8);

192+ cl -> info.bits8 = bits8;

193+ return cl;

194+}

195+

196+VAL MKB16(VM* vm, uint16_t bits16) {

197+ Closure* cl = allocate(vm, sizeof(Closure), 1);

198+ SETTY(cl, BITS16);

199+ cl -> info.bits16 = bits16;

200+ return cl;

201+}

202+

203+VAL MKB32(VM* vm, uint32_t bits32) {

204+ Closure* cl = allocate(vm, sizeof(Closure), 1);

205+ SETTY(cl, BITS32);

206+ cl -> info.bits32 = bits32;

207+ return cl;

208+}

209+

210+VAL MKB64(VM* vm, uint64_t bits64) {

211+ Closure* cl = allocate(vm, sizeof(Closure), 1);

212+ SETTY(cl, BITS64);

213+ cl -> info.bits64 = bits64;

214+ return cl;

215+}

216+

189217void PROJECT(VM* vm, VAL r, int loc, int arity) {

190218 int i;

191219 for(i = 0; i < arity; ++i) {

@@ -243,6 +271,22 @@ void dumpVal(VAL v) {

243271

244272}

245273

274+void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size) {

275+ memset(((uint8_t*)ptr) + offset, c, size);

276+}

277+

278+uint8_t idris_peek(void* ptr, i_int offset) {

279+ return *(((uint8_t*)ptr) + offset);

280+}

281+

282+void idris_poke(void* ptr, i_int offset, uint8_t data) {

283+ *(((uint8_t*)ptr) + offset) = data;

284+}

285+

286+void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {

287+ memmove(dest + dest_offset, src + src_offset, size);

288+}

289+

246290VAL idris_castIntStr(VM* vm, VAL i) {

247291 Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0);

248292 SETTY(cl, STRING);

rts/idris_rts.h+11

@@ -125,6 +125,7 @@ typedef intptr_t i_int;

125125#define ISINT(x) ((((i_int)x)&1) == 1)

126126

127127#define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1)))

128+#define UINTOP(op,x,y) MKINT((i_int)((((uintptr_t)x)>>1) op (((uintptr_t)y)>>1)))

128129#define FLOATOP(op,x,y) MKFLOAT(vm, ((GETFLOAT(x)) op (GETFLOAT(y))))

129130#define FLOATBOP(op,x,y) MKINT((i_int)(((GETFLOAT(x)) op (GETFLOAT(y)))))

130131#define ADD(x,y) (void*)(((i_int)x)+(((i_int)y)-1))

@@ -147,6 +148,10 @@ typedef intptr_t i_int;

147148VAL MKFLOAT(VM* vm, double val);

148149VAL MKSTR(VM* vm, char* str);

149150VAL MKPTR(VM* vm, void* ptr);

151+VAL MKB8(VM* vm, uint8_t b);

152+VAL MKB16(VM* vm, uint16_t b);

153+VAL MKB32(VM* vm, uint32_t b);

154+VAL MKB64(VM* vm, uint64_t b);

150155

151156// following versions don't take a lock when allocating

152157VAL MKFLOATc(VM* vm, double val);

@@ -202,6 +207,12 @@ VAL idris_castStrInt(VM* vm, VAL i);

202207VAL idris_castFloatStr(VM* vm, VAL i);

203208VAL idris_castStrFloat(VM* vm, VAL i);

204209

210+// Raw memory manipulation

211+void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size);

212+uint8_t idris_peek(void* ptr, i_int offset);

213+void idris_poke(void* ptr, i_int offset, uint8_t data);

214+void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);

215+

205216// String primitives

206217

207218VAL idris_concat(VM* vm, VAL l, VAL r);

rts/idris_stdfgn.h−1

@@ -8,7 +8,6 @@ void putStr(char* str);

88

99void* fileOpen(char* f, char* mode);

1010void fileClose(void* h);

11−//char* freadStr(void* h);

1211void fputStr(void*h, char* str);

1312

1413int isNull(void* ptr);

samples/reflection.idr+25−14

@@ -60,33 +60,44 @@ intEq x y = case x == y of

6060

6161-- | A tactic script to run intEq on two let-bound or introduced

6262-- arguments of the current (otherwise empty) proof context

63−firstEq : List (TTName, Binder TT) -> Tactic

64−firstEq ((_, (Let _ y))::(_, (Let _ x))::(_, Let _ f)::Nil) = Exact (App (App f x) y)

65−firstEq ((y, Lam yt)::(x, Lam xt)::(_, Let _ f)::Nil) = Exact (App (App f (P (Bound) x xt)) (P Bound y yt))

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

67−

68−-- | Skip 3 arguments of the proof context and return the fourth one which

69−-- has to be introduced.

70−-- Used for the tactical dispatch example, which will push dispatch,

71−-- its current proof context and the result of dispatch applied to it

72−-- first.

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

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

63+firstEq : List (TTName, Binder TT) -> TT -> Tactic

64+firstEq ((_, (Let _ y))::(_, (Let _ x))::(_, Let _ f)::Nil) _ = Exact (App (App f x) y)

65+firstEq ((y, Lam yt)::(x, Lam xt)::(_, Let _ f)::Nil) _ = Exact (App (App f (P (Bound) x xt)) (P Bound y yt))

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

67+

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

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

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

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

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

7573

7674-- | Returns the reflected representation of innerTac

7775innerTacTT : TT

7876innerTacTT = ?innerTacTTPrf

7977

8078-- | Dispatch to the reflected rep. of innerTac

81−dispatch : List (TTName, Binder TT) -> Tactic

82−dispatch xs = ApplyTactic (innerTacTT)

79+dispatch : List (TTName, Binder TT) -> TT -> Tactic

80+dispatch xs _ = ApplyTactic (innerTacTT)

8381

8482-- | Call dispatch which will then dispatch to innerTac.

8583tacticalDispatch : Int -> Int

8684tacticalDispatch = ?tacticalDispatchPrf

8785

86+-- | A tactic to get the representation of its goal

87+studyGoalTac : List (TTName, Binder TT) -> TT -> Tactic

88+studyGoalTac _ goal = Reflect goal

89+

90+-- | Returns the representation of its goal, TT

91+-- (so this is reflect on the type TT)

92+studyGoal : TT

93+studyGoal = ?studyGoalPrf

94+

8895---------- Proofs ----------

8996

97+ReflectionExamples.studyGoalPrf = proof {

98+ applyTactic studyGoalTac;

99+}

100+

90101ReflectionExamples.envTuplePrf = proof {

91102 let x = tupleType;

92103 fill x;

src/Core/CaseTree.hs+16−10

@@ -14,11 +14,11 @@ import Debug.Trace

1414data CaseDef = CaseDef [Name] SC [Term]

1515 deriving Show

1616

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

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

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

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

1919 | STerm t

20− | UnmatchedCase String -- error message

21− | ImpossibleCase -- already checked to be impossible

20+ | UnmatchedCase String -- ^ error message

21+ | ImpossibleCase -- ^ already checked to be impossible

2222 deriving (Eq, Ord, Functor)

2323{-!

2424deriving instance Binary SC

@@ -351,10 +351,13 @@ argsToAlt rs@((r, m) : rest)

351351 return (newArgs, addRs rs)

352352 where

353353 getNewVars [] = return []

354− getNewVars ((PV n) : ns) = do v <- getVar

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

355355 nsv <- getNewVars ns

356356 return (v : nsv)

357− getNewVars (_ : ns) = do v <- getVar

357+ getNewVars (PAny : ns) = do v <- getVar "i"

358+ nsv <- getNewVars ns

359+ return (v : nsv)

360+ getNewVars (_ : ns) = do v <- getVar "e"

358361 nsv <- getNewVars ns

359362 return (v : nsv)

360363 addRs [] = []

@@ -363,8 +366,8 @@ argsToAlt rs@((r, m) : rest)

363366 uniq i (UN n) = MN i n

364367 uniq i n = n

365368

366−getVar :: State CS Name

367−getVar = do (t, v) <- get; put (t, v+1); return (MN v "e")

369+getVar :: String -> State CS Name

370+getVar b = do (t, v) <- get; put (t, v+1); return (MN v b)

368371

369372groupCons :: [Clause] -> State CS [Group]

370373groupCons cs = gc [] cs

@@ -393,10 +396,12 @@ varRule (v : vs) alts err =

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

394397 match vs alts' err

395398 where

396− repVar v (PV p : ps , (lhs, res)) = (ps, (lhs, subst p (P Bound v Erased) res))

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

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

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

398402

399403-- fix: case e of S k -> f (S k) ==> case e of S k -> f e

404+

400405depatt :: [Name] -> SC -> SC

401406depatt ns tm = dp [] tm

402407 where

@@ -419,8 +424,9 @@ depatt ns tm = dp [] tm

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

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

421426 | otherwise = applyMap ms nt cn pty args'

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

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

423428 same _ _ = False

429+

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

425431 applyMaps ms t = t

426432

src/Core/CoreParser.hs+1−1

@@ -466,7 +466,7 @@ idrisMakeTokenParser languageDef

466466

467467 number base baseDigit

468468 = do{ digits <- many1 baseDigit

469− ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits

469+ ; let n = foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 digits

470470 ; seq n (return n)

471471 }

472472

src/Core/Elaborate.hs+39−6

@@ -171,7 +171,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context

171171 if isInj ctxt tm then return ()

172172 else lift $ tfail (NotInjective tm l r)

173173 where isInj ctxt (P _ n _)

174− | isConName Nothing n ctxt = True

174+ | isConName n ctxt = True

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

176176 isInj ctxt (Constant _) = True

177177 isInj ctxt (TType _) = True

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

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

211211uniqueNameCtxt ctxt n hs

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

213− | [_] <- lookupTy Nothing n ctxt = uniqueNameCtxt ctxt (nextName n) hs

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

214214 | otherwise = return n

215215

216216elog :: String -> Elab' aux ()

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

356356 mkClaims _ _ _ _

357357 | Var n <- fn

358358 = do ctxt <- get_context

359− case lookupTy Nothing n ctxt of

359+ case lookupTy n ctxt of

360360 [] -> lift $ tfail $ NoSuchVariable n

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

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

@@ -391,10 +391,13 @@ apply fn imps =

391391 else

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

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

394− unified p

394+ unified p

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

396− dropGiven dont hunis hs

397− put (ES (p { dontunify = dont, unified = (n, unify) }, a) s prev)

396+ dropGiven dont hunis hs

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

398+ keepGiven dont hunis hs

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

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

398401 ptm <- get_term

399402 g <- goal

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

@@ -469,6 +472,23 @@ apply_elab n args =

469472 mkMN n@(UN x) = MN 1000 x

470473 mkMN (NS n ns) = NS (mkMN n) ns

471474

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

476+checkPiGoal :: Elab' aux ()

477+checkPiGoal = do g <- goal

478+ case g of

479+ Bind _ (Pi _) _ -> return ()

480+ _ -> do a <- unique_hole (MN 0 "argTy")

481+ b <- unique_hole (MN 0 "retTy")

482+ f <- unique_hole (MN 0 "f")

483+ claim a RType

484+ claim b RType

485+ claim f (RBind (MN 0 "aX") (Pi (Var a)) (Var b))

486+ movelast a

487+ movelast b

488+ fill (Var f)

489+ solve

490+ focus f

491+

472492simple_app :: Elab' aux () -> Elab' aux () -> Elab' aux ()

473493simple_app fun arg =

474494 do a <- unique_hole (MN 0 "argTy")

@@ -508,6 +528,19 @@ arg n tyhole = do ty <- unique_hole tyhole

508528 claim ty RType

509529 forall n (Var ty)

510530

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

532+no_errors :: Elab' aux () -> Elab' aux ()

533+no_errors tac

534+ = do ps <- get_probs

535+ tac

536+ ps' <- get_probs

537+ if (length ps' > length ps) then

538+ case reverse ps' of

539+ ((x,y,env,err) : _) ->

540+ let env' = map (\(x, b) -> (x, binderTy b)) env in

541+ lift $ tfail $ CantUnify False x y err env' 0

542+ else return ()

543+

511544-- Try a tactic, if it fails, try another

512545try :: Elab' aux a -> Elab' aux a -> Elab' aux a

513546try t1 t2 = try' t1 t2 False

src/Core/Evaluate.hs+92−70

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

99 addDatatype, addCasedef, simplifyCasedef, addOperator,

1010 lookupNames, lookupTy, lookupP, lookupDef, lookupVal,

1111 lookupTotal, lookupTyEnv, isConName, isFnName,

12− Value(..)) where

12+ Value(..), Quote(..), evalState, initEval) where

1313

1414import Debug.Trace

1515import Control.Monad.State

@@ -19,20 +19,24 @@ import Data.Binary hiding (get, put)

1919import Core.TT

2020import Core.CaseTree

2121

22−data EvalState = ES { limited :: [(Name, Int)] }

22+data EvalState = ES { limited :: [(Name, Int)],

23+ nexthole :: Int }

2324

2425type Eval a = State EvalState a

2526

2627data EvalOpt = Spec | HNF | Simplify Bool | AtREPL

2728 deriving (Show, Eq)

2829

29−initEval = ES []

30+initEval = ES [] 0

3031

3132-- VALUES (as HOAS) ---------------------------------------------------------

3233-- | A HOAS representation of values

3334data Value = VP NameType Name Value

3435 | VV Int

35− | VBind Name (Binder Value) (Value -> Eval Value)

36+ -- True for Bool indicates safe to reduce

37+ | VBind Bool Name (Binder Value) (Value -> Eval Value)

38+ -- For frozen let bindings when simplifying

39+ | VBLet Int Name Value Value Value

3640 | VApp Value Value

3741 | VType UExp

3842 | VErased

@@ -91,8 +95,9 @@ specialise ctxt env limits t

9195simplify :: Context -> Bool -> Env -> TT Name -> TT Name

9296simplify ctxt runtime env t

9397 = evalState (do val <- eval False ctxt [(UN "lazy", 0),

94− (UN "par", 0),

95− (UN "fork", 0)]

98+ (UN "assert_smaller", 0),

99+ (UN "par", 0),

100+ (UN "fork", 0)]

96101 (map finalEntry env) (finalise t)

97102 [Simplify runtime]

98103 quote 0 val) initEval

@@ -149,7 +154,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

149154 ev ntimes_in stk top env (P Ref n ty)

150155 | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty)

151156 | (True, ntimes) <- usable simpl n ntimes_in

152− = do let val = lookupDefAcc Nothing n atRepl ctxt

157+ = do let val = lookupDefAcc n atRepl ctxt

153158 case val of

154159 [(Function _ tm, Public)] ->

155160 ev ntimes (n:stk) True env tm

@@ -165,28 +170,33 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

165170 (Just v, _) -> return v

166171 _ -> liftM (VP Ref n) (ev ntimes stk top env ty)

167172 ev ntimes stk top env (P nt n ty) = liftM (VP nt n) (ev ntimes stk top env ty)

168− ev ntimes stk top env (V i) | i < length env = return $ env !! i

173+ ev ntimes stk top env (V i)

174+ | i < length env && i >= 0 = return $ env !! i

169175 | otherwise = return $ VV i

170176 ev ntimes stk top env (Bind n (Let t v) sc)

171−-- | not simpl || vinstances 0 sc < 2

177+ | not simpl -- || vinstances 0 sc < 2

172178 = do v' <- ev ntimes stk top env v --(finalise v)

173179 sc' <- ev ntimes stk top (v' : env) sc

174180 wknV (-1) sc'

175−{- | otherwise -- put this back when the Bind works properly

181+ | otherwise -- put this back when the Bind works properly

176182 = do t' <- ev ntimes stk top env t

177183 v' <- ev ntimes stk top env v --(finalise v)

178184 -- use Tmp as a placeholder, then make it a variable reference

179185 -- again when evaluation finished

180− sc' <- ev ntimes stk top (v' : env) sc

181− return $ VBind n (Let t' v') (\x -> return sc') -}

186+ hs <- get

187+ let vd = nexthole hs

188+ put (hs { nexthole = vd + 1 })

189+ sc' <- ev ntimes stk top (VP Bound (MN vd "vlet") VErased : env) sc

190+ return $ VBLet vd n t' v' sc'

182191 ev ntimes stk top env (Bind n (NLet t v) sc)

183192 = do t' <- ev ntimes stk top env (finalise t)

184193 v' <- ev ntimes stk top env (finalise v)

185194 sc' <- ev ntimes stk top (v' : env) sc

186− return $ VBind n (Let t' v') (\x -> return sc')

195+ return $ VBind True n (Let t' v') (\x -> return sc')

187196 ev ntimes stk top env (Bind n b sc)

188197 = do b' <- vbind env b

189− return $ VBind n b' (\x -> ev ntimes stk False (x:env) sc)

198+ return $ VBind (not simpl || vinstances 0 sc < 2)

199+ n b' (\x -> ev ntimes stk False (x:env) sc)

190200 where vbind env t

191201 | simpl

192202 = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

@@ -208,10 +218,10 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

208218 evApply ntimes stk top env (a:args) f

209219 evApply ntimes stk top env args f = apply ntimes stk top env f args

210220

211− apply ntimes stk top env (VBind n (Lam t) sc) (a:as)

212− = do a' <- sc a

213− app <- apply ntimes stk top env a' as

214− wknV (-1) app

221+ apply ntimes stk top env (VBind True n (Lam t) sc) (a:as)

222+ = do a' <- sc a

223+ app <- apply ntimes stk top env a' as

224+ wknV (-1) app

215225-- apply ntimes stk False env f args

216226-- | spec = specApply ntimes stk env f args

217227 apply ntimes_in stk top env f@(VP Ref n ty) args

@@ -220,7 +230,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

220230 _ -> return $ unload env f args

221231 | (True, ntimes) <- usable simpl n ntimes_in

222232 = traceWhen traceon (show stk) $

223− do let val = lookupDefAcc Nothing n atRepl ctxt

233+ do let val = lookupDefAcc n atRepl ctxt

224234 case val of

225235 [(CaseOp inl inr _ _ _ ns tree _ _, acc)]

226236 | acc == Public -> -- unoptimised version

@@ -243,7 +253,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

243253 apply ntimes stk top env f [] = return f

244254

245255-- specApply stk env f@(VP Ref n ty) args

246−-- = case lookupCtxt Nothing n statics of

256+-- = case lookupCtxt n statics of

247257-- [as] -> if or as

248258-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $

249259-- return $ unload env f args

@@ -330,15 +340,14 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

330340 getValArgs' (VApp f a) as = getValArgs' f (a:as)

331341 getValArgs' f as = (f, as)

332342

333−tmpToV i (VTmp 0) = return $ VV i

334−tmpToV i (VP nt n v) = liftM (VP nt n) (tmpToV i v)

335−

336−tmpToV i (VBind n b sc) = do b' <- fmapMB (tmpToV i) b

337− let sc' = \x -> do x' <- sc x

338− tmpToV (i + 1) x'

339− return (VBind n b' sc')

340−tmpToV i (VApp f a) = liftM2 VApp (tmpToV i f) (tmpToV i a)

341−tmpToV i x = return x

343+-- tmpToV i vd (VLetHole j) | vd == j = return $ VV i

344+-- tmpToV i vd (VP nt n v) = liftM (VP nt n) (tmpToV i vd v)

345+-- tmpToV i vd (VBind n b sc) = do b' <- fmapMB (tmpToV i vd) b

346+-- let sc' = \x -> do x' <- sc x

347+-- tmpToV (i + 1) vd x'

348+-- return (VBind n b' sc')

349+-- tmpToV i vd (VApp f a) = liftM2 VApp (tmpToV i vd f) (tmpToV i vd a)

350+-- tmpToV i vd x = return x

342351

343352class Quote a where

344353 quote :: Int -> a -> Eval (TT Name)

@@ -346,10 +355,16 @@ class Quote a where

346355instance Quote Value where

347356 quote i (VP nt n v) = liftM (P nt n) (quote i v)

348357 quote i (VV x) = return $ V x

349− quote i (VBind n b sc) = do sc' <- sc (VTmp i)

350− b' <- quoteB b

351− liftM (Bind n b') (quote (i+1) sc')

358+ quote i (VBind _ n b sc) = do sc' <- sc (VTmp i)

359+ b' <- quoteB b

360+ liftM (Bind n b') (quote (i+1) sc')

352361 where quoteB t = fmapMB (quote i) t

362+ quote i (VBLet vd n t v sc)

363+ = do sc' <- quote i sc

364+ t' <- quote i t

365+ v' <- quote i v

366+ let sc'' = pToV (MN vd "vlet") (addBinder sc')

367+ return (Bind n (Let t' v') sc'')

353368 quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

354369 quote i (VType u) = return $ TType u

355370 quote i VErased = return $ Erased

@@ -375,9 +390,9 @@ instance Quote HNF where

375390

376391wknV :: Int -> Value -> Eval Value

377392wknV i (VV x) = return $ VV (x + i)

378−wknV i (VBind n b sc) = do b' <- fmapMB (wknV i) b

379− return $ VBind n b' (\x -> do x' <- sc x

380− wknV i x')

393+wknV i (VBind red n b sc) = do b' <- fmapMB (wknV i) b

394+ return $ VBind red n b' (\x -> do x' <- sc x

395+ wknV i x')

381396wknV i (VApp f a) = liftM2 VApp (wknV i f) (wknV i a)

382397wknV i t = return t

383398

@@ -397,7 +412,7 @@ eval_hnf ctxt statics genv tm = ev [] tm where

397412 ev :: [HNF] -> TT Name -> Eval HNF

398413 ev env (P _ n ty)

399414 | Just (Let t v) <- lookup n genv = ev env v

400− ev env (P Ref n ty) = case lookupDef Nothing n ctxt of

415+ ev env (P Ref n ty) = case lookupDef n ctxt of

401416 [Function _ t] -> ev env t

402417 [TyDecl nt ty] -> return $ HP nt n ty

403418 [CaseOp inl _ _ _ _ [] tree _ _] ->

@@ -430,7 +445,7 @@ eval_hnf ctxt statics genv tm = ev [] tm where

430445 app <- apply env sc' as

431446 wknH (-1) app

432447 apply env (HP Ref n ty) args

433− | [CaseOp _ _ _ _ _ ns tree _ _] <- lookupDef Nothing n ctxt

448+ | [CaseOp _ _ _ _ _ ns tree _ _] <- lookupDef n ctxt

434449 = do c <- evCase env ns args tree

435450 case c of

436451 (Nothing, _, env') -> return $ unload env' (HP Ref n ty) args

@@ -525,6 +540,12 @@ convEq ctxt = ceq [] where

525540 ceq ps (P xt x _) (P yt y _)

526541 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

527542 | otherwise = sameDefs ps x y

543+ ceq ps x (Bind n (Lam t) (App y (V 0))) = ceq ps x y

544+ ceq ps (Bind n (Lam t) (App x (V 0))) y = ceq ps x y

545+ ceq ps x (Bind n (Lam t) (App y (P Bound n' _)))

546+ | n == n' = ceq ps x y

547+ ceq ps (Bind n (Lam t) (App x (P Bound n' _))) y

548+ | n == n' = ceq ps x y

528549 ceq ps (V x) (V y) = return (x == y)

529550 ceq ps (Bind _ xb xs) (Bind _ yb ys)

530551 = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys)

@@ -559,7 +580,7 @@ convEq ctxt = ceq [] where

559580 caseeq ps (UnmatchedCase _) (UnmatchedCase _) = return True

560581 caseeq ps _ _ = return False

561582

562− sameDefs ps x y = case (lookupDef Nothing x ctxt, lookupDef Nothing y ctxt) of

583+ sameDefs ps x y = case (lookupDef x ctxt, lookupDef y ctxt) of

563584 ([Function _ xdef], [Function _ ydef])

564585 -> ceq ((x,y):ps) xdef ydef

565586 ([CaseOp _ _ _ _ _ _ xdef _ _],

@@ -663,7 +684,7 @@ data Context = MkContext {

663684 uconstraints :: [UConstraint],

664685 next_tvar :: Int,

665686 definitions :: Ctxt (Def, Accessibility, Totality)

666− }

687+ } deriving Show

667688

668689-- | The initial empty context

669690initContext = MkContext [] 0 emptyContext

@@ -697,10 +718,10 @@ addCtxtDef n d c = let ctxt = definitions c

697718 ctxt' = addDef n (d, Public, Unchecked) ctxt in

698719 c { definitions = ctxt' }

699720

700−addTyDecl :: Name -> Type -> Context -> Context

701−addTyDecl n ty uctxt

721+addTyDecl :: Name -> NameType -> Type -> Context -> Context

722+addTyDecl n nt ty uctxt

702723 = let ctxt = definitions uctxt

703− ctxt' = addDef n (TyDecl Ref ty, Public, Unchecked) ctxt in

724+ ctxt' = addDef n (TyDecl nt ty, Public, Unchecked) ctxt in

704725 uctxt { definitions = ctxt' }

705726

706727addDatatype :: Datatype Name -> Context -> Context

@@ -724,7 +745,7 @@ addCasedef :: Name -> Bool -> Bool -> Bool -> Bool ->

724745 Type -> Context -> Context

725746addCasedef n alwaysInline tcase covering asserted ps_in ps psrt ty uctxt

726747 = let ctxt = definitions uctxt

727− access = case lookupDefAcc Nothing n False uctxt of

748+ access = case lookupDefAcc n False uctxt of

728749 [(_, acc)] -> acc

729750 _ -> Public

730751 ctxt' = case (simpleCase tcase covering CompileTime (FC "" 0) ps,

@@ -741,15 +762,16 @@ addCasedef n alwaysInline tcase covering asserted ps_in ps psrt ty uctxt

741762simplifyCasedef :: Name -> Context -> Context

742763simplifyCasedef n uctxt

743764 = let ctxt = definitions uctxt

744− ctxt' = case lookupCtxt Nothing n ctxt of

765+ ctxt' = case lookupCtxt n ctxt of

745766 [(CaseOp inl inr ty [] ps args sc args' sc', acc, tot)] ->

746767 ctxt -- nothing to simplify (or already done...)

747768 [(CaseOp inl inr ty ps_in ps args sc args' sc', acc, tot)] ->

748− let pdef = map debind $ map simpl ps_in in

769+ let ps_in' = map simpl ps_in

770+ pdef = map debind ps_in' in

749771 case simpleCase False True CompileTime (FC "" 0) pdef of

750772 OK (CaseDef args sc _) ->

751773 addDef n (CaseOp inl inr

752− ty ps_in ps args sc args' sc',

774+ ty ps_in' ps args sc args' sc',

753775 acc, tot) ctxt

754776 _ -> ctxt in

755777 uctxt { definitions = ctxt' }

@@ -774,40 +796,40 @@ addOperator n ty a op uctxt

774796

775797tfst (a, _, _) = a

776798

777−lookupNames :: Maybe [String] -> Name -> Context -> [Name]

778−lookupNames root n ctxt

779− = let ns = lookupCtxtName root n (definitions ctxt) in

799+lookupNames :: Name -> Context -> [Name]

800+lookupNames n ctxt

801+ = let ns = lookupCtxtName n (definitions ctxt) in

780802 map fst ns

781803

782−lookupTy :: Maybe [String] -> Name -> Context -> [Type]

783−lookupTy root n ctxt

784− = do def <- lookupCtxt root n (definitions ctxt)

804+lookupTy :: Name -> Context -> [Type]

805+lookupTy n ctxt

806+ = do def <- lookupCtxt n (definitions ctxt)

785807 case tfst def of

786808 (Function ty _) -> return ty

787809 (TyDecl _ ty) -> return ty

788810 (Operator ty _ _) -> return ty

789811 (CaseOp _ _ ty _ _ _ _ _ _) -> return ty

790812

791−isConName :: Maybe [String] -> Name -> Context -> Bool

792−isConName root n ctxt

793− = or $ do def <- lookupCtxt root n (definitions ctxt)

813+isConName :: Name -> Context -> Bool

814+isConName n ctxt

815+ = or $ do def <- lookupCtxt n (definitions ctxt)

794816 case tfst def of

795817 (TyDecl (DCon _ _) _) -> return True

796818 (TyDecl (TCon _ _) _) -> return True

797819 _ -> return False

798820

799−isFnName :: Maybe [String] -> Name -> Context -> Bool

800−isFnName root n ctxt

801− = or $ do def <- lookupCtxt root n (definitions ctxt)

821+isFnName :: Name -> Context -> Bool

822+isFnName n ctxt

823+ = or $ do def <- lookupCtxt n (definitions ctxt)

802824 case tfst def of

803825 (Function _ _) -> return True

804826 (Operator _ _ _) -> return True

805827 (CaseOp _ _ _ _ _ _ _ _ _) -> return True

806828 _ -> return False

807829

808−lookupP :: Maybe [String] -> Name -> Context -> [Term]

809−lookupP root n ctxt

810− = do def <- lookupCtxt root n (definitions ctxt)

830+lookupP :: Name -> Context -> [Term]

831+lookupP n ctxt

832+ = do def <- lookupCtxt n (definitions ctxt)

811833 p <- case def of

812834 (Function ty tm, a, _) -> return (P Ref n ty, a)

813835 (TyDecl nt ty, a, _) -> return (P nt n ty, a)

@@ -817,22 +839,22 @@ lookupP root n ctxt

817839 Hidden -> []

818840 _ -> return (fst p)

819841

820−lookupDef :: Maybe [String] -> Name -> Context -> [Def]

821−lookupDef root n ctxt = map tfst $ lookupCtxt root n (definitions ctxt)

842+lookupDef :: Name -> Context -> [Def]

843+lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt)

822844

823−lookupDefAcc :: Maybe [String] -> Name -> Bool -> Context ->

845+lookupDefAcc :: Name -> Bool -> Context ->

824846 [(Def, Accessibility)]

825−lookupDefAcc root n mkpublic ctxt

826− = map mkp $ lookupCtxt root n (definitions ctxt)

847+lookupDefAcc n mkpublic ctxt

848+ = map mkp $ lookupCtxt n (definitions ctxt)

827849 where mkp (d, a, _) = if mkpublic then (d, Public) else (d, a)

828850

829851lookupTotal :: Name -> Context -> [Totality]

830−lookupTotal n ctxt = map mkt $ lookupCtxt Nothing n (definitions ctxt)

852+lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt)

831853 where mkt (d, a, t) = t

832854

833−lookupVal :: Maybe [String] -> Name -> Context -> [Value]

834−lookupVal root n ctxt

835− = do def <- lookupCtxt root n (definitions ctxt)

855+lookupVal :: Name -> Context -> [Value]

856+lookupVal n ctxt

857+ = do def <- lookupCtxt n (definitions ctxt)

836858 case tfst def of

837859 (Function _ htm) -> return (veval ctxt [] htm)

838860 (TyDecl nt ty) -> return (VP nt n (veval ctxt [] ty))

src/Core/Execute.hs+506−83

@@ -1,108 +1,522 @@

1+{-# LANGUAGE PatternGuards, ExistentialQuantification #-}

12module Core.Execute (execute) where

23

34import Idris.AbsSyntax

45import Idris.AbsSyntaxTree

6+import IRTS.Lang( IntTy(..)

7+ , intTyToConst

8+ , FType(..))

59

610import Core.TT

711import Core.Evaluate

12+import Core.CaseTree

813

914import Debug.Trace

1015

1116import Util.DynamicLinker

17+import Util.System

1218

1319import Control.Applicative hiding (Const)

1420import Control.Monad.Trans

21+import Control.Monad.Trans.State.Strict

22+import Control.Monad.Trans.Error

1523import Control.Monad

1624import Data.Maybe

25+import Data.Bits

26+import qualified Data.Map as M

1727

1828import Foreign.LibFFI

1929import Foreign.C.String

2030import Foreign.Marshal.Alloc (free)

31+import Foreign.Ptr

2132

22−-- | Attempt to perform a side effect. Return either Just the next step in

23−-- evaluation (after performing the side effect through IO), or Nothing if no

24−-- IO was performed.

25−--

26−-- This function is exceedingly generous about what it will accept in order to

27−-- enable convenient testing at the REPL.

28−step :: TT Name -> Idris (Maybe (TT Name))

29−step tm = step' (unApply tm)

30− where step' (P _ (UN "unsafePerformIO") _, [_, arg] ) = step arg -- Only step if arg can be stepped

31− step' (P _ (UN "mkForeign") _, args) = stepForeign args

32− step' (P _ (UN "prim__IO") _, [_, arg]) = step arg

33− step' (P _ (UN "prim__readString") _, [(P _ (UN "prim__stdin") _)]) =

34− do line <- lift $ getLine

35− return . Just . Constant . Str $ line

36− step' _ = return Nothing

37−

38−-- | Perform side effects until no more can be performed, then return the

39−-- resulting term (possibly the argument).

40−execute :: TT Name -> Idris (TT Name)

41−execute tm = case unApply tm of

42− (P _ (UN "unsafePerformIO") _, [_, arg] ) -> execute' arg

43− _ -> return tm

44− where execute' tm = do stepped <- step tm

45− case stepped of

46− Nothing -> return tm

47− Just tm' -> execute' tm'

48−

49−

50−

52−

53−data Foreign = FFun String [FTy] FTy deriving Show

54−

55−call :: Foreign -> [TT Name] -> Idris (Maybe (TT Name))

56−call (FFun name argTypes retType) args = do fn <- findForeign name

57− case fn of

58− Nothing -> return Nothing

59− Just f -> return . Just =<< call' f args retType

60− where call' :: ForeignFun -> [TT Name] -> FTy -> Idris (TT Name)

61− call' (Fun _ h) args FInt = do res <- lift $ callFFI h retCInt (prepArgs args)

62− return (Constant (I (fromIntegral res)))

63− call' (Fun _ h) args FFloat = do res <- lift $ callFFI h retCDouble (prepArgs args)

64− return (Constant (Fl (realToFrac res)))

65− call' (Fun _ h) args FChar = do res <- lift $ callFFI h retCChar (prepArgs args)

66− return (Constant (Ch (castCCharToChar res)))

67− call' (Fun _ h) args FString = do res <- lift $ callFFI h retCString (prepArgs args)

68− hStr <- lift $ peekCString res

33+import System.IO

34+

35+

36+data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show

37+

38+data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs

39+ , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness

40+ , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad

41+ , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad

42+ }

43+

44+data ExecVal = EP NameType Name ExecVal

45+ | EV Int

46+ | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal)

47+ | EApp ExecVal ExecVal

48+ | EType UExp

49+ | EErased

50+ | EConstant Const

51+ | forall a. EPtr (Ptr a)

52+ | EThunk Int

53+ | EHandle Handle

54+

55+instance Show ExecVal where

56+ show (EP _ n _) = show n

57+ show (EV i) = "!!V" ++ show i ++ "!!"

58+ show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

59+ show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

60+ show (EType _) = "Type"

61+ show EErased = "[__]"

62+ show (EConstant c) = show c

63+ show (EPtr p) = "<<ptr " ++ show p ++ ">>"

64+ show (EThunk i) = "<<thunk " ++ show i ++ ">>"

65+ show (EHandle h) = "<<handle " ++ show h ++ ">>"

66+

67+toTT :: ExecVal -> Exec Term

68+toTT (EP nt n ty) = (P nt n) <$> (toTT ty)

69+toTT (EV i) = return $ V i

70+toTT (EBind n b body) = do body' <- body $ EP Bound n EErased

71+ b' <- fixBinder b

72+ Bind n b' <$> toTT body'

73+ where fixBinder (Lam t) = Lam <$> toTT t

74+ fixBinder (Pi t) = Pi <$> toTT t

75+ fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

76+ fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

77+ fixBinder (Hole t) = Hole <$> toTT t

78+ fixBinder (GHole t) = GHole <$> toTT t

79+ fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2

80+ fixBinder (PVar t) = PVar <$> toTT t

81+ fixBinder (PVTy t) = PVTy <$> toTT t

82+toTT (EApp e1 e2) = do e1' <- toTT e1

83+ e2' <- toTT e2

84+ return $ App e1' e2'

85+toTT (EType u) = return $ TType u

86+toTT EErased = return Erased

87+toTT (EConstant c) = return (Constant c)

88+toTT (EThunk i) = return (P (DCon 0 0) (MN i "THUNK") Erased) --(force i) >>= toTT

89+toTT (EHandle _) = return Erased

90+

91+unApplyV :: ExecVal -> (ExecVal, [ExecVal])

92+unApplyV tm = ua [] tm

93+ where ua args (EApp f a) = ua (a:args) f

94+ ua args t = (t, args)

95+

96+mkEApp :: ExecVal -> [ExecVal] -> ExecVal

97+mkEApp f [] = f

98+mkEApp f (a:args) = mkEApp (EApp f a) args

99+

100+initState :: Idris ExecState

101+initState = do ist <- getIState

102+ return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)

103+

104+type Exec = ErrorT String (StateT ExecState IO)

105+

106+runExec :: Exec a -> ExecState -> IO (Either String a)

107+runExec ex st = fst <$> runStateT (runErrorT ex) st

108+

109+getExecState :: Exec ExecState

110+getExecState = lift get

111+

112+putExecState :: ExecState -> Exec ()

113+putExecState = lift . put

114+

115+execFail :: String -> Exec a

116+execFail = throwError

117+

118+execIO :: IO a -> Exec a

119+execIO = lift . lift

120+

121+delay :: ExecEnv -> Context -> Term -> Exec ExecVal

122+delay env ctxt tm =

123+ do st <- getExecState

124+ let i = exec_next_thunk st

125+ putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)

126+ , exec_next_thunk = exec_next_thunk st + 1

127+ }

128+ return $ EThunk i

129+

130+force :: Int -> Exec ExecVal

131+force i = do st <- getExecState

132+ case M.lookup i (exec_thunks st) of

133+ Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm

134+ case tm' of

135+ EThunk i ->

136+ do res <- force i

137+ update res i

138+ return res

139+ _ -> do update tm' i

140+ return tm'

141+ Just (Forced tm) -> return tm

142+ Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"

143+ where update :: ExecVal -> Int -> Exec ()

144+ update tm i = do est <- getExecState

145+ putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }

146+

147+tryForce :: ExecVal -> Exec ExecVal

148+tryForce (EThunk i) = force i

149+tryForce tm = return tm

150+

151+debugThunks :: Exec ()

152+debugThunks = do st <- getExecState

153+ execIO $ putStrLn (take 4000 (show (exec_thunks st)))

154+

155+execute :: Term -> Idris Term

156+execute tm = do est <- initState

157+ ctxt <- getContext

158+ res <- lift $ flip runExec est $ do res <- doExec [] ctxt tm

159+ toTT res

160+ case res of

161+ Left err -> fail err

162+ Right tm' -> return tm'

163+

164+ioWrap :: ExecVal -> ExecVal

165+ioWrap tm = mkEApp (EP (DCon 0 2) (UN "prim__IO") EErased) [EErased, tm]

166+

167+ioUnit :: ExecVal

168+ioUnit = ioWrap (EP Ref unitCon EErased)

169+

170+type ExecEnv = [(Name, ExecVal)]

171+

172+doExec :: ExecEnv -> Context -> Term -> Exec ExecVal

173+doExec env ctxt p@(P Ref n ty) | Just v <- lookup n env = return v

174+doExec env ctxt p@(P Ref n ty) =

175+ do let val = lookupDef n ctxt

176+ case val of

177+ [Function _ tm] -> doExec env ctxt tm

178+ [TyDecl _ _] -> return (EP Ref n EErased) -- abstract def

179+ [Operator tp arity op] -> return (EP Ref n EErased) -- will be special-cased later

180+ [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun

181+ doExec env ctxt tm

182+ [CaseOp _ _ _ _ _ ns sc _ _] -> return (EP Ref n EErased)

183+ [] -> execFail $ "Could not find " ++ show n ++ " in definitions."

184+ thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined

185+doExec env ctxt p@(P Bound n ty) =

186+ case lookup n env of

187+ Nothing -> execFail "not found"

188+ Just tm -> return tm

189+doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)

190+doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)

191+doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))

192+ | otherwise = execFail "env too small"

193+doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v

194+ doExec ((n, v'):env) ctxt body

195+doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined

196+doExec env ctxt tm@(Bind n b body) = return $

197+ EBind n (fmap (\_->EErased) b)

198+ (\arg -> doExec ((n, arg):env) ctxt body)

199+doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)

200+doExec env ctxt (Constant c) = return (EConstant c)

201+doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in

202+ doExec env ctxt ((x:xs) !! i)

203+doExec env ctxt Erased = return EErased

204+doExec env ctxt Impossible = fail "Tried to execute an impossible case"

205+doExec env ctxt (TType u) = return (EType u)

206+

207+execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal

208+execApp env ctxt (f, args) = do newF <- doExec env ctxt f

209+ laziness <- (++ repeat False) <$> (getLaziness newF)

210+ newArgs <- mapM argExec (zip args laziness)

211+ execApp' env ctxt newF newArgs

212+ where getLaziness (EP _ (UN "lazy") _) = return [False, True]

213+ getLaziness (EP _ n _) = do est <- getExecState

214+ let argInfo = exec_implicits est

215+ case lookupCtxtName n argInfo of

216+ [] -> return (repeat False)

217+ [ps] -> return $ map lazyarg (snd ps)

218+ many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)

219+ getLaziness _ = return (repeat False) -- ok due to zip above

220+ argExec :: (Term, Bool) -> Exec ExecVal

221+ argExec (tm, False) = doExec env ctxt tm

222+ argExec (tm, True) = delay env ctxt tm

223+

224+

225+execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal

226+execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls

227+execApp' env ctxt (EP _ (UN "unsafePerformIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action =

228+ execApp' env ctxt v rest

229+

230+execApp' env ctxt (EP _ (UN "io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =

231+ do v'' <- tryForce v'

232+ res <- execApp' env ctxt k [v''] >>= tryForce

233+ execApp' env ctxt res rest

234+execApp' env ctxt con@(EP _ (UN "io_return") _) args@(tp:v:rest) =

235+ do v' <- tryForce v

236+ execApp' env ctxt (mkEApp con [tp, v']) rest

237+

238+-- Special cases arising from not having access to the C RTS in the interpreter

239+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str arg):rest)

240+ | Just (FFun "putStr" _ _) <- foreignFromTT fn = do execIO (putStr arg)

241+ execApp' env ctxt ioUnit rest

242+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)

243+ | Just (FFun "fileOpen" _ _) <- foreignFromTT fn = do m <- case mode of

244+ "r" -> return ReadMode

245+ "w" -> return WriteMode

246+ "a" -> return AppendMode

247+ "rw" -> return ReadWriteMode

248+ "wr" -> return ReadWriteMode

249+ "r+" -> return ReadWriteMode

250+ _ -> execFail ("Invalid mode for " ++ f ++ ": " ++ mode)

251+ h <- execIO $ openFile f m

252+ execApp' env ctxt (ioWrap (EHandle h)) rest

253+

254+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)

255+ | Just (FFun "fileEOF" _ _) <- foreignFromTT fn = do eofp <- execIO $ hIsEOF h

256+ let res = ioWrap (EConstant (I $ if eofp then 1 else 0))

257+ execApp' env ctxt res rest

258+

259+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)

260+ | Just (FFun "fileClose" _ _) <- foreignFromTT fn = do execIO $ hClose h

261+ execApp' env ctxt ioUnit rest

262+

263+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EPtr p):rest)

264+ | Just (FFun "isNull" _ _) <- foreignFromTT fn = let res = ioWrap . EConstant . I $

265+ if p == nullPtr then 1 else 0

266+ in execApp' env ctxt res rest

267+

268+execApp' env ctxt f@(EP _ (UN "mkForeign") _) args@(ty:fn:xs) | Just (FFun f argTs retT) <- foreignFromTT fn

269+ , length xs >= length argTs =

270+ do res <- stepForeign (ty:fn:take (length argTs) xs)

271+ case res of

272+ Nothing -> fail $ "Could not call foreign function \"" ++ f ++

273+ "\" with args " ++ show (take (length argTs) xs)

274+ Just r -> return (mkEApp r (drop (length argTs) xs))

275+ | otherwise = return (mkEApp f args)

276+

277+execApp' env ctxt f@(EP _ n _) args =

278+ do let val = lookupDef n ctxt

279+ case val of

280+ [Function _ tm] -> fail "should already have been eval'd"

281+ [TyDecl nt ty] -> return $ mkEApp f args

282+ [Operator tp arity op] ->

283+ if length args >= arity

284+ then do args' <- mapM tryForce $ take arity args

285+ case getOp n args' of

286+ Just res -> do r <- res

287+ execApp' env ctxt r (drop arity args)

288+ Nothing -> return (mkEApp f args)

289+ else return (mkEApp f args)

290+ [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun

291+ do rhs <- doExec env ctxt tm

292+ execApp' env ctxt rhs args

293+ [CaseOp _ _ _ _ _ ns sc _ _] ->

294+ do res <- execCase env ctxt ns sc args

295+ return $ fromMaybe (mkEApp f args) res

296+ thing -> return $ mkEApp f args

297+ where getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)

298+ getOp (UN "prim__addInt") [EConstant (I i1), EConstant (I i2)] =

299+ primRes I (i1 + i2)

300+ getOp (UN "prim__andInt") [EConstant (I i1), EConstant (I i2)] =

301+ primRes I (i1 .&. i2)

302+ getOp (UN "prim__charToInt") [EConstant (Ch c)] =

303+ primRes I (fromEnum c)

304+ getOp (UN "prim__complInt") [EConstant (I i)] =

305+ primRes I (complement i)

306+ getOp (UN "prim__concat") [EConstant (Str s1), EConstant (Str s2)] =

307+ primRes Str (s1 ++ s2)

308+ getOp (UN "prim__divInt") [EConstant (I i1), EConstant (I i2)] =

309+ primRes I (i1 `div` i2)

310+ getOp (UN "prim__eqChar") [EConstant (Ch c1), EConstant (Ch c2)] =

311+ primResBool (c1 == c2)

312+ getOp (UN "prim__eqInt") [EConstant (I i1), EConstant (I i2)] =

313+ primResBool (i1 == i2)

314+ getOp (UN "prim__eqString") [EConstant (Str s1), EConstant (Str s2)] =

315+ primResBool (s1 == s2)

316+ getOp (UN "prim__gtChar") [EConstant (Ch i1), EConstant (Ch i2)] =

317+ primResBool (i1 > i2)

318+ getOp (UN "prim__gteChar") [EConstant (Ch i1), EConstant (Ch i2)] =

319+ primResBool (i1 >= i2)

320+ getOp (UN "prim__gtInt") [EConstant (I i1), EConstant (I i2)] =

321+ primResBool (i1 > i2)

322+ getOp (UN "prim__gteInt") [EConstant (I i1), EConstant (I i2)] =

323+ primResBool (i1 >= i2)

324+ getOp (UN "prim__intToFloat") [EConstant (I i)] =

325+ primRes Fl (fromRational (toRational i))

326+ getOp (UN "prim__intToStr") [EConstant (I i)] =

327+ primRes Str (show i)

328+ getOp (UN "prim_lenString") [EConstant (Str s)] =

329+ primRes I (length s)

330+ getOp (UN "prim__ltChar") [EConstant (Ch i1), EConstant (Ch i2)] =

331+ primResBool (i1 < i2)

332+ getOp (UN "prim__lteChar") [EConstant (Ch i1), EConstant (Ch i2)] =

333+ primResBool (i1 <= i2)

334+ getOp (UN "prim__lteInt") [EConstant (I i1), EConstant (I i2)] =

335+ primResBool (i1 <= i2)

336+ getOp (UN "prim__ltInt") [EConstant (I i1), EConstant (I i2)] =

337+ primResBool (i1 < i2)

338+ getOp (UN "prim__modInt") [EConstant (I i1), EConstant (I i2)] =

339+ primRes I (i1 `mod` i2)

340+ getOp (UN "prim__mulBigInt") [EConstant (BI i1), EConstant (BI i2)] =

341+ primRes BI (i1 * i2)

342+ getOp (UN "prim__mulFloat") [EConstant (Fl i1), EConstant (Fl i2)] =

343+ primRes Fl (i1 * i2)

344+ getOp (UN "prim__mulInt") [EConstant (I i1), EConstant (I i2)] =

345+ primRes I (i1 * i2)

346+ getOp (UN "prim__orInt") [EConstant (I i1), EConstant (I i2)] =

347+ primRes I (i1 .|. i2)

348+ getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =

349+ Just $ do line <- execIO getLine

350+ return (EConstant (Str line))

351+ getOp (UN "prim__readString") [EHandle h] =

352+ Just $ do contents <- execIO $ hGetLine h

353+ return (EConstant (Str contents))

354+ getOp (UN "prim__shLInt") [EConstant (I i1), EConstant (I i2)] =

355+ primRes I (shiftL i1 i2)

356+ getOp (UN "prim__shRInt") [EConstant (I i1), EConstant (I i2)] =

357+ primRes I (shiftR i1 i2)

358+ getOp (UN "prim__strCons") [EConstant (Ch c), EConstant (Str s)] =

359+ primRes Str (c:s)

360+ getOp (UN "prim__strHead") [EConstant (Str (c:s))] =

361+ primRes Ch c

362+ getOp (UN "prim__strRev") [EConstant (Str s)] =

363+ primRes Str (reverse s)

364+ getOp (UN "prim__strTail") [EConstant (Str (c:s))] =

365+ primRes Str s

366+ getOp (UN "prim__subFloat") [EConstant (Fl i1), EConstant (Fl i2)] =

367+ primRes Fl (i1 - i2)

368+ getOp (UN "prim__subInt") [EConstant (I i1), EConstant (I i2)] =

369+ primRes I (i1 - i2)

370+ getOp (UN "prim__xorInt") [EConstant (I i1), EConstant (I i2)] =

371+ primRes I (i1 `xor` i2)

372+ getOp n args = trace ("No prim " ++ show n ++ " for " ++ take 1000 (show args)) Nothing

373+

374+ primRes :: (a -> Const) -> a -> Maybe (Exec ExecVal)

375+ primRes constr = Just . return . EConstant . constr

376+

377+ primResBool :: Bool -> Maybe (Exec ExecVal)

378+ primResBool b = primRes I (if b then 1 else 0)

379+

380+execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg

381+ let (f', as) = unApplyV ret

382+ execApp' env ctxt f' (as ++ args)

383+execApp' env ctxt (EThunk i) args = do f <- force i

384+ execApp' env ctxt f args

385+execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)

386+execApp' env ctxt f args = return (mkEApp f args)

387+

388+

389+

390+

391+

392+-- | Overall wrapper for case tree execution. If there are enough arguments, it takes them,

393+-- evaluates them, then begins the checks for matching cases.

394+execCase :: ExecEnv -> Context -> [Name] -> SC -> [ExecVal] -> Exec (Maybe ExecVal)

395+execCase env ctxt ns sc args =

396+ let arity = length ns in

397+ if arity <= length args

398+ then do let amap = zip ns args

399+-- trace ("Case " ++ show sc ++ "\n in " ++ show amap ++"\n in env " ++ show env ++ "\n\n" ) $ return ()

400+ caseRes <- execCase' env ctxt amap sc

401+ case caseRes of

402+ Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)

403+ Nothing -> return Nothing

404+ else return Nothing

405+

406+-- | Take bindings and a case tree and examines them, executing the matching case if possible.

407+execCase' :: ExecEnv -> Context -> [(Name, ExecVal)] -> SC -> Exec (Maybe ExecVal)

408+execCase' env ctxt amap (UnmatchedCase _) = return Nothing

409+execCase' env ctxt amap (STerm tm) =

410+ Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm

411+execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =

412+ do tm' <- tryForce tm

413+ case chooseAlt tm' alts of

414+ Just (newCase, newBindings) ->

415+ let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in

416+ execCase' env ctxt amap' newCase

417+ Nothing -> return Nothing

418+

419+chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)])

420+chooseAlt _ (DefaultCase sc : alts) = Just (sc, [])

421+chooseAlt (EConstant c) (ConstCase c' sc : alts) | c == c' = Just (sc, [])

422+chooseAlt tm (ConCase n i ns sc : alts) | ((EP _ cn _), args) <- unApplyV tm

423+ , cn == n = Just (sc, zip ns args)

424+ | otherwise = chooseAlt tm alts

425+chooseAlt tm (_:alts) = chooseAlt tm alts

426+chooseAlt _ [] = Nothing

427+

428+

429+

430+

431+idrisType :: FType -> ExecVal

432+idrisType FUnit = EP Ref unitTy EErased

433+idrisType ft = EConstant (idr ft)

434+ where idr (FInt ty) = intTyToConst ty

435+ idr FDouble = FlType

436+ idr FChar = ChType

437+ idr FString = StrType

438+ idr FPtr = PtrType

439+

440+data Foreign = FFun String [FType] FType deriving Show

441+

442+

443+call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)

444+call (FFun name argTypes retType) args =

445+ do fn <- findForeign name

446+ case fn of

447+ Nothing -> return Nothing

448+ Just f -> do res <- call' f args retType

449+ return . Just . ioWrap $ res

450+ where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal

451+ call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args)

452+ return (EConstant (I (fromIntegral res)))

453+ call' (Fun _ h) args (FInt IT8) = do res <- execIO $ callFFI h retCChar (prepArgs args)

454+ return (EConstant (B8 (fromIntegral res)))

455+ call' (Fun _ h) args (FInt IT16) = do res <- execIO $ callFFI h retCWchar (prepArgs args)

456+ return (EConstant (B16 (fromIntegral res)))

457+ call' (Fun _ h) args (FInt IT32) = do res <- execIO $ callFFI h retCInt (prepArgs args)

458+ return (EConstant (B32 (fromIntegral res)))

459+ call' (Fun _ h) args (FInt IT64) = do res <- execIO $ callFFI h retCLong (prepArgs args)

460+ return (EConstant (B64 (fromIntegral res)))

461+ call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args)

462+ return (EConstant (Fl (realToFrac res)))

463+ call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)

464+ return (EConstant (Ch (castCCharToChar res)))

465+ call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)

466+ hStr <- execIO $ peekCString res

69467-- lift $ free res

70− return (Constant (Str hStr))

71−-- awaiting Const constructor for pointers

72−-- call' (Fun _ h) args FPtr = do res <- lift $ callFFI h retPtr (prepArgs args)

73−-- return (Constant (Ch (castCCharToChar res)))

74− call' (Fun _ h) args FUnit = do res <- lift $ callFFI h retVoid (prepArgs args)

75− return (P Ref unitCon (P Ref unitTy (TType (UVal 0)))) -- FIXME check universe level

468+ return (EConstant (Str hStr))

469+

470+ call' (Fun _ h) args FPtr = do res <- execIO $ callFFI h (retPtr retVoid) (prepArgs args)

471+ return (EPtr res)

472+ call' (Fun _ h) args FUnit = do res <- execIO $ callFFI h retVoid (prepArgs args)

473+ return (EP Ref unitCon EErased)

474+-- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other)

475+

76476

77477 prepArgs = map prepArg

78− prepArg (Constant (I i)) = argCInt (fromIntegral i)

79− prepArg (Constant (Fl f)) = argCDouble (realToFrac f)

80− prepArg (Constant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars

81− prepArg (Constant (Str s)) = argString s

478+ prepArg (EConstant (I i)) = argCInt (fromIntegral i)

479+ prepArg (EConstant (B8 i)) = argCChar (fromIntegral i)

480+ prepArg (EConstant (B16 i)) = argCWchar (fromIntegral i)

481+ prepArg (EConstant (B32 i)) = argCInt (fromIntegral i)

482+ prepArg (EConstant (B64 i)) = argCLong (fromIntegral i)

483+ prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)

484+ prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars

485+ prepArg (EConstant (Str s)) = argString s

486+ prepArg (EPtr p) = argPtr p

487+ prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined

82488

83489

84490

85−foreignFromTT :: TT Name -> Maybe Foreign

86−foreignFromTT t = case (unApply t) of

87− (_, [(Constant (Str name)), args, ret]) ->

88− do argTy <- unList args

491+foreignFromTT :: ExecVal -> Maybe Foreign

492+foreignFromTT t = case (unApplyV t) of

493+ (_, [(EConstant (Str name)), args, ret]) ->

494+ do argTy <- unEList args

89495 argFTy <- sequence $ map getFTy argTy

90496 retFTy <- getFTy ret

91497 return $ FFun name argFTy retFTy

92− _ -> Nothing

93−

94−getFTy :: TT Name -> Maybe FTy

95−getFTy (P _ (UN t) _) = case t of

96− "FInt" -> Just FInt

97− "FFloat" -> Just FFloat

98− "FChar" -> Just FChar

99− "FString" -> Just FString

100− "FPtr" -> Just FPtr

101− "FUnit" -> Just FUnit

102− _ -> Nothing

498+ _ -> trace "failed to construct ffun" Nothing

499+

500+getFTy :: ExecVal -> Maybe FType

501+getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

502+ case intTy of

503+ "ITNative" -> Just $ FInt ITNative

504+ "IT8" -> Just $ FInt IT8

505+ "IT16" -> Just $ FInt IT16

506+ "IT32" -> Just $ FInt IT32

507+ "IT64" -> Just $ FInt IT64

508+ _ -> Nothing

509+getFTy (EP _ (UN t) _) =

510+ case t of

511+ "FFloat" -> Just FDouble

512+ "FChar" -> Just FChar

513+ "FString" -> Just FString

514+ "FPtr" -> Just FPtr

515+ "FUnit" -> Just FUnit

516+ _ -> Nothing

103517getFTy _ = Nothing

104518

105−unList :: TT Name -> Maybe [TT Name]

519+unList :: Term -> Maybe [Term]

106520unList tm = case unApply tm of

107521 (nil, [_]) -> Just []

108522 (cons, ([_, x, xs])) ->

@@ -110,11 +524,20 @@ unList tm = case unApply tm of

110524 return $ x:rest

111525 (f, args) -> Nothing

112526

113−toConst :: TT Name -> Maybe Const

527+unEList :: ExecVal -> Maybe [ExecVal]

528+unEList tm = case unApplyV tm of

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

530+ (cons, ([_, x, xs])) ->

531+ do rest <- unEList xs

532+ return $ x:rest

533+ (f, args) -> Nothing

534+

535+

536+toConst :: Term -> Maybe Const

114537toConst (Constant c) = Just c

115538toConst _ = Nothing

116539

117−stepForeign :: [TT Name] -> Idris (Maybe (TT Name))

540+stepForeign :: [ExecVal] -> Exec (Maybe ExecVal)

118541stepForeign (ty:fn:args) = do let ffun = foreignFromTT fn

119542 f' <- case (call <$> ffun) of

120543 Just f -> f args

@@ -130,15 +553,15 @@ mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs

130553 Just x'' -> return (x'':rest)

131554 Nothing -> return rest

132555

133−findForeign :: String -> Idris (Maybe ForeignFun)

134−findForeign fn = do i <- getIState

135− let libs = idris_dynamic_libs i

136− fns <- mapMaybeM (lift . tryLoadFn fn) libs

556+findForeign :: String -> Exec (Maybe ForeignFun)

557+findForeign fn = do est <- getExecState

558+ let libs = exec_dynamic_libs est

559+ fns <- mapMaybeM getFn libs

137560 case fns of

138561 [f] -> return (Just f)

139− [] -> do iputStrLn $ "Symbol \"" ++ fn ++ "\" not found"

562+ [] -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" not found"

140563 return Nothing

141− fs -> do iputStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++

142− show (length fs) ++ " occurrences."

564+ fs -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++

565+ show (length fs) ++ " occurrences."

143566 return Nothing

144−

567+ where getFn lib = execIO $ catchIO (tryLoadFn fn lib) (\_ -> return Nothing)

src/Core/ProofShell.hs+1−1

@@ -41,7 +41,7 @@ processCommand (Eval t) state =

4141 (state, show nf ++ " : " ++ show ty)

4242 err -> (state, show err)

4343processCommand (Print n) state =

44− case lookupDef Nothing n (ctxt state) of

44+ case lookupDef n (ctxt state) of

4545 [tm] -> (state, show tm)

4646 _ -> (state, "No such name")

4747processCommand (Tac e) state

src/Core/ProofState.hs+31−12

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

55 evaluation/checking inside the proof system, etc. --}

66

77module Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,

8− Tactic(..), Goal(..), processTactic, dropGiven) where

8+ Tactic(..), Goal(..), processTactic,

9+ dropGiven, keepGiven) where

910

1011import Core.Typecheck

1112import Core.Evaluate

@@ -27,6 +28,7 @@ data ProofState = PS { thname :: Name,

2728 ptype :: Type, -- original goal

2829 dontunify :: [Name], -- explicitly given by programmer, leave it

2930 unified :: (Name, [(Name, Term)]),

31+ notunified :: [(Name, Term)],

3032 solved :: Maybe (Name, Term),

3133 problems :: Fails,

3234 injective :: [Name],

@@ -78,8 +80,8 @@ data Tactic = Attack

7880-- Some utilites on proof and tactic states

7981

8082instance Show ProofState where

81− show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals"

82− show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ i _ _ ctxt _ _)

83+ show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals"

84+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _)

8385 = let OK g = goal (Just h) tm

8486 wkenv = premises g in

8587 "Other goals: " ++ show hs ++ "\n" ++

@@ -102,12 +104,12 @@ instance Show ProofState where

102104 showG ps b = showEnv ps (binderTy b)

103105

104106instance Pretty ProofState where

105− pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _) =

107+ pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _) =

106108 if size nm > breakingSize then

107109 pretty nm <> colon $$ nest nestingSize (text " no more goals.")

108110 else

109111 pretty nm <> colon <+> text " no more goals."

110− pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ i _ _ ctxt _ _) =

112+ pretty p@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _) =

111113 let OK g = goal (Just h) tm in

112114 let wkEnv = premises g in

113115 text "Other goals" <+> colon <+> pretty hs $$

@@ -159,7 +161,7 @@ unify' ctxt env topx topy =

159161 (u, fails) <- -- trace ("Trying " ++ show (topx, topy)) $

160162 lift $ unify ctxt env topx topy dont (holes ps)

161163-- trace ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

162−-- -- " in " ++ show env ++

164+-- " in " ++ show env ++

163165-- "\n" ++ show u ++ "\n" ++ qshow fails ++ "\nCurrent problems:\n"

164166-- ++ qshow (problems ps) ++ "\n" ++ show (holes ps) ++ "\n"

165167-- -- ++ show (pterm ps)

@@ -194,7 +196,7 @@ newProof :: Name -> Context -> Type -> ProofState

194196newProof n ctxt ty = let h = holeName 0

195197 ty' = vToP ty in

196198 PS n [h] [] 1 (Bind h (Hole ty')

197− (P Bound h ty')) ty [] (h, [])

199+ (P Bound h ty')) ty [] (h, []) []

198200 Nothing [] []

199201 [] []

200202 Nothing ctxt "" False

@@ -358,9 +360,8 @@ exact _ _ _ _ = fail "Can't fill here."

358360-- As exact, but attempts to solve other goals by unification

359361

360362fill :: Raw -> RunTactic

361−fill guess ctxt env (Bind x (Hole ty) sc) =

363+fill guess ctxt env (Bind x (Hole ty) sc) =

362364 do (val, valty) <- lift $ check ctxt env guess

363− s <- get

364365-- let valtyn = normalise ctxt env valty

365366-- let tyn = normalise ctxt env ty

366367 ns <- unify' ctxt env valty ty

@@ -388,10 +389,19 @@ complete_fill ctxt env (Bind x (Guess ty val) sc) =

388389 return $ Bind x (Guess ty val) sc

389390complete_fill ctxt env t = fail $ "Can't complete fill at " ++ show t

390391

392+-- When solving something in the 'dont unify' set, we should check

393+-- that the guess we are solving it with unifies with the thing unification

394+-- found for it, if anything.

395+

391396solve :: RunTactic

392397solve ctxt env (Bind x (Guess ty val) sc)

393398 | True = do ps <- get

394399 let (uh, uns) = unified ps

400+ case lookup x (notunified ps) of

401+ Just tm -> do -- trace ("AVOIDED " ++ show (x, tm, val)) $

402+ -- return []

403+ unify' ctxt env tm val

404+ _ -> return []

395405 action (\ps -> ps { holes = holes ps \\ [x],

396406 solved = Just (x, val),

397407-- problems = solveInProblems

@@ -423,7 +433,7 @@ introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

423433 let (uh, uns) = unified ps

424434-- put (ps { unified = (uh, uns ++ ns) })

425435 return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t'))

426− _ -> fail "Nothing to introduce"

436+ _ -> lift $ tfail $ CantIntroduce t'

427437introTy ty n ctxt env _ = fail "Can't introduce here."

428438

429439intro :: Maybe Name -> RunTactic

@@ -438,7 +448,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

438448 Bind y (Pi s) t -> -- trace ("in type " ++ show t') $

439449 let t' = instantiate (P Bound n s) (pToV y t) in

440450 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

441− _ -> fail "Nothing to introduce"

451+ _ -> lift $ tfail $ CantIntroduce t'

442452intro n ctxt env _ = fail "Can't introduce here."

443453

444454forall :: Name -> Raw -> RunTactic

@@ -566,6 +576,15 @@ dropGiven du (u@(n, _) : us) hs

566576-- dropGiven du (u@(_, P a n ty) : us) | n `elem` du = dropGiven du us

567577dropGiven du (u : us) hs = u : dropGiven du us hs

568578

579+keepGiven du [] hs = []

580+keepGiven du ((n, P Bound t ty) : us) hs

581+ | n `elem` du && not (t `elem` du)

582+ && n `elem` hs && t `elem` hs

583+ = keepGiven du us hs

584+keepGiven du (u@(n, _) : us) hs

585+ | n `elem` du = u : keepGiven du us hs

586+keepGiven du (u : us) hs = keepGiven du us hs

587+

569588updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

570589 updateSolved' xs x

571590updateSolved' xs (Bind n (Hole ty) t)

@@ -619,7 +638,7 @@ processTactic EndUnify ps

619638 ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

620639 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

621640 (injective ps) (holes ps)

622− tm' = -- trace ("Updating " ++ show ns' ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $

641+ tm' = -- trace ("Updating " ++ show ns_in ++ "\n" ++ show ns'') $ -- ++ " in " ++ show (pterm ps)) $

623642 updateSolved ns'' (pterm ps) in

624643 return (ps { pterm = tm',

625644 unified = (h, []),

src/Core/TT.hs+28−7

@@ -57,6 +57,8 @@ data Err = Msg String

5757 -- unification succeed

5858 | InfiniteUnify Name Term [(Name, Type)]

5959 | CantConvert Term Term [(Name, Type)]

60+ | NonFunctionType Term Term

61+ | CantIntroduce Term

6062 | NoSuchVariable Name

6163 | NoTypeDecl Name

6264 | NotInjective Term Term Term

@@ -71,6 +73,7 @@ data Err = Msg String

7173 | ProofSearchFail Err

7274 | NoRewriting Term

7375 | At FC Err

76+ | ProviderError String

7477 deriving Eq

7578

7679instance Sized Err where

@@ -89,6 +92,7 @@ instance Sized Err where

8992 size UniverseError = 1

9093 size ProgramLineComment = 1

9194 size (At fc err) = size fc + size err

95+ size (ProviderError msg) = length msg

9296 size _ = 1

9397

9498score :: Err -> Int

@@ -104,6 +108,7 @@ instance Show Err where

104108 show (CantUnify _ l r e sc i) = "CantUnify " ++ show l ++ " " ++ show r ++ " "

105109 ++ show e ++ " in " ++ show sc ++ " " ++ show i

106110 show (Inaccessible n) = show n ++ " is not an accessible pattern variable"

111+ show (ProviderError msg) = "Type provider error: " ++ msg

107112 show _ = "Error"

108113

109114instance Pretty Err where

@@ -116,6 +121,7 @@ instance Pretty Err where

116121 else

117122 text "Cannot unify" <+> colon <+> pretty l <+> text "and" <+> pretty r $$

118123 nest nestingSize (text "where" <+> pretty e <+> text "with" <+> (text . show $ i))

124+ pretty (ProviderError msg) = text msg

119125 pretty _ = text "Error"

120126

121127data TC a = OK a

@@ -238,8 +244,8 @@ addDef n v ctxt = case Map.lookup (nsroot n) ctxt of

238244

239245-}

240246

241−lookupCtxtName :: Maybe [String] -> Name -> Ctxt a -> [(Name, a)]

242−lookupCtxtName nspace n ctxt = case Map.lookup (nsroot n) ctxt of

247+lookupCtxtName :: Name -> Ctxt a -> [(Name, a)]

248+lookupCtxtName n ctxt = case Map.lookup (nsroot n) ctxt of

243249 Just xs -> filterNS (Map.toList xs)

244250 Nothing -> []

245251 where

@@ -252,12 +258,12 @@ lookupCtxtName nspace n ctxt = case Map.lookup (nsroot n) ctxt of

252258 nsmatch (NS _ _) _ = False

253259 nsmatch looking found = True

254260

255−lookupCtxt :: Maybe [String] -> Name -> Ctxt a -> [a]

256−lookupCtxt ns n ctxt = map snd (lookupCtxtName ns n ctxt)

261+lookupCtxt :: Name -> Ctxt a -> [a]

262+lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt)

257263

258264updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a

259265updateDef n f ctxt

260− = let ds = lookupCtxtName Nothing n ctxt in

266+ = let ds = lookupCtxtName n ctxt in

261267 foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds

262268

263269toAlist :: Ctxt a -> [(Name, a)]

@@ -424,7 +430,10 @@ instance Show UConstraint where

424430

425431type UCs = (Int, [UConstraint])

426432

427−data NameType = Bound | Ref | DCon Int Int | TCon Int Int

433+data NameType = Bound

434+ | Ref

435+ | DCon Int Int -- ^ Data constructor; Ints are tag and arity

436+ | TCon Int Int -- ^ Type constructor; Ints are tag and arity

428437 deriving (Show, Ord)

429438{-!

430439deriving instance Binary NameType

@@ -560,6 +569,17 @@ pToV' n i (App f a) = App (pToV' n i f) (pToV' n i a)

560569pToV' n i (Proj t idx) = Proj (pToV' n i t) idx

561570pToV' n i t = t

562571

572+-- increase de Bruijn indices, as if a binder has been added

573+addBinder :: TT n -> TT n

574+addBinder t = ab 0 t

575+ where

576+ ab top (V i) | i >= top = V (i + 1)

577+ | otherwise = V i

578+ ab top (Bind x b sc) = Bind x (fmap (ab top) b) (ab (top + 1) sc)

579+ ab top (App f a) = App (ab top f) (ab top a)

580+ ab top (Proj t idx) = Proj (ab top t) idx

581+ ab top t = t

582+

563583-- | Convert several names. First in the list comes out as V 0

564584pToVs :: Eq n => [n] -> TT n -> TT n

565585pToVs ns tm = pToVs' ns tm 0 where

@@ -778,7 +798,8 @@ prettyEnv env t = prettyEnv' env t False

778798showEnv' env t dbg = se 10 env t where

779799 se p env (P nt n t) = show n

780800 ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else ""

781− se p env (V i) | i < length env = (show $ fst $ env!!i) ++

801+ se p env (V i) | i < length env && i >= 0

802+ = (show $ fst $ env!!i) ++

782803 if dbg then "{" ++ show i ++ "}" else ""

783804 | otherwise = "!!V " ++ show i ++ "!!"

784805 se p env (Bind n b@(Pi t) sc)

src/Core/Typecheck.hs+3−3

@@ -60,7 +60,7 @@ check' :: Bool -> Context -> Env -> Raw -> StateT UCs TC (Term, Type)

6060check' holes ctxt env top = chk env top where

6161 chk env (Var n)

6262 | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty)

63− | (P nt n' ty : _) <- lookupP Nothing n ctxt = return (P nt n' ty, ty)

63+ | (P nt n' ty : _) <- lookupP n ctxt = return (P nt n' ty, ty)

6464 | otherwise = do lift $ tfail $ NoSuchVariable n

6565 chk env (RApp f a)

6666 = do (fv, fty) <- chk env f

@@ -81,7 +81,7 @@ check' holes ctxt env top = chk env top where

8181 let apty = simplify initContext False env

8282 (Bind x (Let aty av) t)

8383 return (App fv av, apty)

84− t -> fail "Can't apply a non-function type"

84+ t -> lift $ tfail $ NonFunctionType fv fty -- "Can't apply a non-function type"

8585 -- This rather unpleasant hack is needed because during incomplete

8686 -- proofs, variables are locally bound with an explicit name. If we just

8787 -- make sure bound names in function types are locally unique, machine

@@ -227,7 +227,7 @@ checkProgram ctxt [] = return ctxt

227227checkProgram ctxt ((n, RConst t) : xs)

228228 = do (t', tt') <- trace (show n) $ check ctxt [] t

229229 isType ctxt [] tt'

230− checkProgram (addTyDecl n t' ctxt) xs

230+ checkProgram (addTyDecl n Ref t' ctxt) xs

231231checkProgram ctxt ((n, RFunction (RawFun ty val)) : xs)

232232 = do (ty', tyt') <- trace (show n) $ check ctxt [] ty

233233 (val', valt') <- check ctxt [] val

src/Core/Unify.hs+27−15

@@ -54,9 +54,9 @@ unify ctxt env topx topy dont holes =

5454

5555 injective (P (DCon _ _) _ _) = True

5656 injective (P (TCon _ _) _ _) = True

57− injective (App f (P _ _ _)) = injective f

58− injective (App f (Constant _)) = injective f

59− injective (App f a) = injective f && injective a

57+-- injective (App f (P _ _ _)) = injective f

58+-- injective (App f (Constant _)) = injective f

59+ injective (App f a) = injective f -- && injective a

6060 injective _ = False

6161

6262 notP (P _ _ _) = False

@@ -133,10 +133,11 @@ unify ctxt env topx topy dont holes =

133133 | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []

134134

135135 un' fn bnames appx@(App fx ax) appy@(App fy ay)

136− | injective fx && sameArgStruct appx appy && metavarApp appy

137− || injective fy && sameArgStruct appx appy && metavarApp appx

138− || injective fx && injective fy

139− || fx == fy

136+ | (injective fx && injective fy)

137+ || (injective fx && rigid appx && metavarApp appy)

138+ || (injective fy && rigid appy && metavarApp appx)

139+ || (injective fx && metavarApp fy && ax == ay)

140+ || (injective fy && metavarApp fx && ax == ay)

140141 = do let (headx, _) = unApply fx

141142 let (heady, _) = unApply fy

142143 -- fail quickly if the heads are disjoint

@@ -158,17 +159,19 @@ unify ctxt env topx topy dont holes =

158159 hf <- un' False bnames fx' fy'

159160 sc 1

160161 combine bnames hf ha)

161− | otherwise

162− = do let (headx, argsx) = unApply appx

162+ | otherwise = -- trace (show (appx, appy, injective fx, metavarApp appy, sameArgStruct appx appy)) $

163+ do let (headx, argsx) = unApply appx

163164 let (heady, argsy) = unApply appy

165+ -- traceWhen (headx == heady) (show (appx, appy)) $

164166 if (length argsx == length argsy &&

165− ((headx == heady) || (argsx == argsy) ||

167+ ((headx == heady && inenv headx) || (argsx == argsy) ||

166168 (and (zipWith sameStruct (headx:argsx) (heady:argsy)))))

167169 then

168170-- (notFn headx && notFn heady))) then

169171 do uf <- un' True bnames headx heady

170172 unArgs uf argsx argsy

171− else unifyTmpFail appx appy

173+ else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $

174+ unifyTmpFail appx appy

172175 where hnormalise [] _ _ t = t

173176 hnormalise ns ctxt env t = normalise ctxt env t

174177 checkHeads (P (DCon _ _) x _) (P (DCon _ _) y _)

@@ -190,15 +193,17 @@ unify ctxt env topx topy dont holes =

190193 unArgs vs xs ys

191194

192195 metavarApp tm = let (f, args) = unApply tm in

193− all (\x -> metavar x || inenv x) (f : args)

196+ all (\x -> metavar x) (f : args)

194197 metavarArgs tm = let (f, args) = unApply tm in

195198 all (\x -> metavar x || inenv x) args

196199 metavarApp' tm = let (f, args) = unApply tm in

197200 all (\x -> pat x || metavar x) (f : args)

198201

199− sameArgStruct appx appy = let (_, ax) = unApply appx

200− (_, ay) = unApply appy in

201− and (zipWith sameStruct ax ay)

202+ sameArgStruct appx appy

203+ = let (_, ax) = unApply appx

204+ (_, ay) = unApply appy in

205+ length ax == length ay &&

206+ and (zipWith sameStruct ax ay)

202207

203208 sameStruct fapp@(App f x) gapp@(App g y)

204209 = let (f',a') = unApply fapp

@@ -216,6 +221,13 @@ unify ctxt env topx topy dont holes =

216221 sameStruct (Bind n t sc) (Bind n' t' sc') = sameStruct sc sc'

217222 sameStruct _ _ = False

218223

224+ rigid (P (DCon _ _) _ _) = True

225+ rigid (P (TCon _ _) _ _) = True

226+ rigid t@(P Ref _ _) = inenv t

227+ rigid (Constant _) = True

228+ rigid (App f a) = rigid f && rigid a

229+ rigid t = not (metavar t)

230+

219231 metavar t = case t of

220232 P _ x _ -> (x `elem` holes || holeIn env x) &&

221233 not (x `elem` dont)

src/IRTS/CodegenC.hs+113−189

@@ -10,6 +10,7 @@ import Paths_idris

1010import Util.System

1111

1212import Data.Char

13+import Data.List (intercalate)

1314import System.Process

1415import System.Exit

1516import System.IO

@@ -47,7 +48,7 @@ codegenC defs out exec incs objs libs dbg

4748 incFlags <- getIncFlags

4849 let gcc = comp ++ " " ++

4950 gccDbg dbg ++

50− " -I. " ++ objs ++ " -x c " ++

51+ " -I. " ++ objs ++ " -x c " ++

5152 (if (exec == Executable) then "" else " -c ") ++

5253 " " ++ tmpn ++

5354 " " ++ libFlags ++

@@ -105,6 +106,10 @@ bcc i (ASSIGNCONST l c)

105106 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

106107 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

107108 mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"

109+ mkConst (B8 x) = "idris_b8const(vm, " ++ show x ++ ")"

110+ mkConst (B16 x) = "idris_b16const(vm, " ++ show x ++ ")"

111+ mkConst (B32 x) = "idris_b32const(vm, " ++ show x ++ ")"

112+ mkConst (B64 x) = "idris_b64const(vm, " ++ show x ++ ")"

108113 mkConst _ = "MKINT(42424242)"

109114bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

110115bcc i (MKCON l tag args)

@@ -222,7 +227,10 @@ bcc i (NULL r) = indent i ++ creg r ++ " = NULL;\n" -- clear, so it'll be GCed

222227bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"

223228-- bcc i _ = indent i ++ "// not done yet\n"

224229

225−c_irts FInt l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

230+

231+

232+c_irts (FInt ITNative) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

233+c_irts (FInt ty) l x = l ++ "idris_b" ++ show (intTyWidth ty) ++ "const(vm, " ++ x ++ ")"

226234c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

227235c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"

228236c_irts FUnit l x = x

@@ -230,7 +238,8 @@ c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

230238c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

231239c_irts FAny l x = l ++ x

232240

233−irts_c FInt x = "GETINT(" ++ x ++ ")"

241+irts_c (FInt ITNative) x = "GETINT(" ++ x ++ ")"

242+irts_c (FInt ty) x = "(" ++ x ++ "->info.bits" ++ show (intTyWidth ty) ++ ")"

234243irts_c FChar x = "GETINT(" ++ x ++ ")"

235244irts_c FString x = "GETSTR(" ++ x ++ ")"

236245irts_c FUnit x = x

@@ -238,22 +247,33 @@ irts_c FPtr x = "GETPTR(" ++ x ++ ")"

238247irts_c FDouble x = "GETFLOAT(" ++ x ++ ")"

239248irts_c FAny x = x

240249

241−doOp v LPlus [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"

242−doOp v LMinus [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

243−doOp v LTimes [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"

244−doOp v LDiv [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

245−doOp v LMod [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

246−doOp v LAnd [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"

247−doOp v LOr [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"

248−doOp v LXOr [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"

249−doOp v LSHL [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"

250−doOp v LSHR [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

251−doOp v LCompl [x] = v ++ "INTOP(~," ++ creg x ++ ")"

252−doOp v LEq [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

253−doOp v LLt [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

254−doOp v LLe [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

255−doOp v LGt [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

256−doOp v LGe [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

250+bitOp v op ty args = v ++ "idris_b" ++ show (intTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"

251+

252+bitCoerce v op input output arg

253+ = v ++ "idris_b" ++ show (intTyWidth input) ++ op ++ show (intTyWidth output) ++ "(vm, " ++ creg arg ++ ")"

254+

255+signedTy :: IntTy -> String

256+signedTy t = "int" ++ show (intTyWidth t) ++ "_t"

257+

258+doOp v (LPlus ITNative) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"

259+doOp v (LMinus ITNative) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

260+doOp v (LTimes ITNative) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"

261+doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

262+doOp v (LSDiv ITNative) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"

263+doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

264+doOp v (LSRem ITNative) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

265+doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"

266+doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"

267+doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"

268+doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++ ")"

269+doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

270+doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

271+doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"

272+doOp v (LEq ITNative) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

273+doOp v (LLt ITNative) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

274+doOp v (LLe ITNative) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

275+doOp v (LGt ITNative) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

276+doOp v (LGe ITNative) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

257277

258278doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"

259279doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

@@ -265,31 +285,32 @@ doOp v LFLe [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

265285doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

266286doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

267287

268−doOp v LBPlus [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

269−doOp v LBMinus [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

270−doOp v LBDec [l] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", MKINT(1))"

271−doOp v LBTimes [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

272−doOp v LBDiv [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

273−doOp v LBMod [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

274−doOp v LBEq [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

275−doOp v LBLt [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

276−doOp v LBLe [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

277−doOp v LBGt [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

278−doOp v LBGe [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

288+doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"

289+doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"

290+doOp v (LPlus ITBig) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

291+doOp v (LMinus ITBig) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

292+doOp v (LTimes ITBig) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

293+doOp v (LSDiv ITBig) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

294+doOp v (LSRem ITBig) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

295+doOp v (LEq ITBig) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

296+doOp v (LLt ITBig) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

297+doOp v (LLe ITBig) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

298+doOp v (LGt ITBig) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

299+doOp v (LGe ITBig) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

279300

280301doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

281302doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

282303doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

283304doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"

284305

285−doOp v LIntFloat [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"

286−doOp v LFloatInt [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"

287−doOp v LIntStr [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"

288−doOp v LStrInt [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"

289−doOp v LIntBig [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"

290−doOp v LBigInt [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"

291−doOp v LStrBig [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"

292−doOp v LBigStr [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"

306+doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"

307+doOp v (LFloatInt ITNative) [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"

308+doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"

309+doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"

310+doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"

311+doOp v (LIntStr ITBig) [x] = v ++ "idris_castBigStr(vm, " ++ creg x ++ ")"

312+doOp v (LIntStr ITNative) [x] = v ++ "idris_castIntStr(vm, " ++ creg x ++ ")"

313+doOp v (LStrInt ITNative) [x] = v ++ "idris_castStrInt(vm, " ++ creg x ++ ")"

293314doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"

294315doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"

295316

@@ -297,155 +318,55 @@ doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

297318doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"

298319doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"

299320

300−doOp v LIntB8 [x] = v ++ "idris_b8(vm, " ++ creg x ++ ")"

301−doOp v LIntB16 [x] = v ++ "idris_b16(vm, " ++ creg x ++ ")"

302−doOp v LIntB32 [x] = v ++ "idris_b32(vm, " ++ creg x ++ ")"

303−doOp v LIntB64 [x] = v ++ "idris_b64(vm, " ++ creg x ++ ")"

304−

305−doOp v LB32Int [x] = v ++ "idris_castB32Int(vm, " ++ creg x ++ ")"

306−

307−doOp v LB8Lt [x, y] = v ++ "idris_b8Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

308−doOp v LB8Lte [x, y] = v ++ "idris_b8Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

309−doOp v LB8Eq [x, y] = v ++ "idris_b8Eq(vm, " ++ creg x ++ "," ++ creg y ++ ")"

310−doOp v LB8Gte [x, y] = v ++ "idris_b8Gte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

311−doOp v LB8Gt [x, y] = v ++ "idris_b8Gt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

312−

313−doOp v LB8Shl [x, y] = v ++ "idris_b8Shl(vm, " ++ creg x ++ "," ++ creg y ++ ")"

314−doOp v LB8LShr [x, y] = v ++ "idris_b8Shr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

315−doOp v LB8AShr [x, y] = v ++ "idris_b8AShr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

316−doOp v LB8And [x, y] = v ++ "idris_b8And(vm, " ++ creg x ++ "," ++ creg y ++ ")"

317−doOp v LB8Or [x, y] = v ++ "idris_b8Or(vm, " ++ creg x ++ "," ++ creg y ++ ")"

318−doOp v LB8Xor [x, y] = v ++ "idris_b8Xor(vm, " ++ creg x ++ "," ++ creg y ++ ")"

319−doOp v LB8Compl [x] = v ++ "idris_b8Compl(vm, " ++ creg x ++ ")"

320−

321−doOp v LB8Plus [x, y] = v ++ "idris_b8Plus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

322−doOp v LB8Minus [x, y] = v ++ "idris_b8Minus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

323−doOp v LB8Times [x, y] = v ++ "idris_b8Times(vm, " ++ creg x ++ "," ++ creg y ++ ")"

324−doOp v LB8UDiv [x, y] = v ++ "idris_b8UDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

325−doOp v LB8SDiv [x, y] = v ++ "idris_b8SDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

326−doOp v LB8URem [x, y] = v ++ "idris_b8URem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

327−doOp v LB8SRem [x, y] = v ++ "idris_b8SRem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

328−

329−doOp v LB8Z16 [x] = v ++ "idris_b8Z16(vm, " ++ creg x ++ ")"

330−doOp v LB8Z32 [x] = v ++ "idris_b8Z32(vm, " ++ creg x ++ ")"

331−doOp v LB8Z64 [x] = v ++ "idris_b8Z64(vm, " ++ creg x ++ ")"

332−doOp v LB8S16 [x] = v ++ "idris_b8S16(vm, " ++ creg x ++ ")"

333−doOp v LB8S32 [x] = v ++ "idris_b8S32(vm, " ++ creg x ++ ")"

334−doOp v LB8S64 [x] = v ++ "idris_b8S64(vm, " ++ creg x ++ ")"

335−

336−doOp v LB16Lt [x, y] = v ++ "idris_b16Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

337−doOp v LB16Lte [x, y] = v ++ "idris_b16Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

338−doOp v LB16Eq [x, y] = v ++ "idris_b16Eq(vm, " ++ creg x ++ "," ++ creg y ++ ")"

339−doOp v LB16Gte [x, y] = v ++ "idris_b16Gte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

340−doOp v LB16Gt [x, y] = v ++ "idris_b16Gt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

341−

342−doOp v LB16Shl [x, y] = v ++ "idris_b16Shl(vm, " ++ creg x ++ "," ++ creg y ++ ")"

343−doOp v LB16LShr [x, y] = v ++ "idris_b16Shr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

344−doOp v LB16AShr [x, y] = v ++ "idris_b16AShr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

345−doOp v LB16And [x, y] = v ++ "idris_b16And(vm, " ++ creg x ++ "," ++ creg y ++ ")"

346−doOp v LB16Or [x, y] = v ++ "idris_b16Or(vm, " ++ creg x ++ "," ++ creg y ++ ")"

347−doOp v LB16Xor [x, y] = v ++ "idris_b16Xor(vm, " ++ creg x ++ "," ++ creg y ++ ")"

348−doOp v LB16Compl [x] = v ++ "idris_b16Compl(vm, " ++ creg x ++ ")"

349−

350−doOp v LB16Plus [x, y] =

351− v ++ "idris_b16Plus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

352−doOp v LB16Minus [x, y] =

353− v ++ "idris_b16Minus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

354−doOp v LB16Times [x, y] =

355− v ++ "idris_b16Times(vm, " ++ creg x ++ "," ++ creg y ++ ")"

356−doOp v LB16UDiv [x, y] =

357− v ++ "idris_b16UDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

358−doOp v LB16SDiv [x, y] =

359− v ++ "idris_b16SDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

360−doOp v LB16URem [x, y] =

361− v ++ "idris_b16URem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

362−doOp v LB16SRem [x, y] =

363− v ++ "idris_b16SRem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

364−

365−doOp v LB16Z32 [x] = v ++ "idris_b16Z32(vm, " ++ creg x ++ ")"

366−doOp v LB16Z64 [x] = v ++ "idris_b16Z64(vm, " ++ creg x ++ ")"

367−doOp v LB16S32 [x] = v ++ "idris_b16S32(vm, " ++ creg x ++ ")"

368−doOp v LB16S64 [x] = v ++ "idris_b16S64(vm, " ++ creg x ++ ")"

369−doOp v LB16T8 [x] = v ++ "idris_b16T8(vm, " ++ creg x ++ ")"

370−

371−doOp v LB32Lt [x, y] = v ++ "idris_b32Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

372−doOp v LB32Lte [x, y] = v ++ "idris_b32Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

373−doOp v LB32Eq [x, y] = v ++ "idris_b32Eq(vm, " ++ creg x ++ "," ++ creg y ++ ")"

374−doOp v LB32Gte [x, y] = v ++ "idris_b32Gte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

375−doOp v LB32Gt [x, y] = v ++ "idris_b32Gt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

376−

377−doOp v LB32Shl [x, y] = v ++ "idris_b32Shl(vm, " ++ creg x ++ "," ++ creg y ++ ")"

378−doOp v LB32LShr [x, y] = v ++ "idris_b32Shr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

379−doOp v LB32AShr [x, y] = v ++ "idris_b32AShr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

380−doOp v LB32And [x, y] = v ++ "idris_b32And(vm, " ++ creg x ++ "," ++ creg y ++ ")"

381−doOp v LB32Or [x, y] = v ++ "idris_b32Or(vm, " ++ creg x ++ "," ++ creg y ++ ")"

382−doOp v LB32Xor [x, y] = v ++ "idris_b32Xor(vm, " ++ creg x ++ "," ++ creg y ++ ")"

383−doOp v LB32Compl [x] = v ++ "idris_b32Compl(vm, " ++ creg x ++ ")"

384−

385−doOp v LB32Plus [x, y] =

386− v ++ "idris_b32Plus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

387−doOp v LB32Minus [x, y] =

388− v ++ "idris_b32Minus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

389−doOp v LB32Times [x, y] =

390− v ++ "idris_b32Times(vm, " ++ creg x ++ "," ++ creg y ++ ")"

391−doOp v LB32UDiv [x, y] =

392− v ++ "idris_b32UDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

393−doOp v LB32SDiv [x, y] =

394− v ++ "idris_b32SDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

395−doOp v LB32URem [x, y] =

396− v ++ "idris_b32URem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

397−doOp v LB32SRem [x, y] =

398− v ++ "idris_b32SRem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

399−

400−doOp v LB32Z64 [x] = v ++ "idris_b32Z64(vm, " ++ creg x ++ ")"

401−doOp v LB32S64 [x] = v ++ "idris_b32S64(vm, " ++ creg x ++ ")"

402−doOp v LB32T8 [x] = v ++ "idris_b32T8(vm, " ++ creg x ++ ")"

403−doOp v LB32T16 [x] = v ++ "idris_b32T16(vm, " ++ creg x ++ ")"

404−

405−doOp v LB64Lt [x, y] = v ++ "idris_b64Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

406−doOp v LB64Lte [x, y] = v ++ "idris_b64Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

407−doOp v LB64Eq [x, y] = v ++ "idris_b64Eq(vm, " ++ creg x ++ "," ++ creg y ++ ")"

408−doOp v LB64Gte [x, y] = v ++ "idris_b64Gte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

409−doOp v LB64Gt [x, y] = v ++ "idris_b64Gt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

410−

411−doOp v LB64Shl [x, y] = v ++ "idris_b64Shl(vm, " ++ creg x ++ "," ++ creg y ++ ")"

412−doOp v LB64LShr [x, y] = v ++ "idris_b64Shr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

413−doOp v LB64AShr [x, y] = v ++ "idris_b64AShr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

414−doOp v LB64And [x, y] = v ++ "idris_b64And(vm, " ++ creg x ++ "," ++ creg y ++ ")"

415−doOp v LB64Or [x, y] = v ++ "idris_b64Or(vm, " ++ creg x ++ "," ++ creg y ++ ")"

416−doOp v LB64Xor [x, y] = v ++ "idris_b64Xor(vm, " ++ creg x ++ "," ++ creg y ++ ")"

417−doOp v LB64Compl [x] = v ++ "idris_b64Compl(vm, " ++ creg x ++ ")"

418−

419−doOp v LB64Plus [x, y] =

420− v ++ "idris_b64Plus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

421−doOp v LB64Minus [x, y] =

422− v ++ "idris_b64Minus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

423−doOp v LB64Times [x, y] =

424− v ++ "idris_b64Times(vm, " ++ creg x ++ "," ++ creg y ++ ")"

425−doOp v LB64UDiv [x, y] =

426− v ++ "idris_b64UDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

427−doOp v LB64SDiv [x, y] =

428− v ++ "idris_b64SDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

429−doOp v LB64URem [x, y] =

430− v ++ "idris_b64URem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

431−doOp v LB64SRem [x, y] =

432− v ++ "idris_b64SRem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

433−

434−doOp v LB64T8 [x] = v ++ "idris_b64T8(vm, " ++ creg x ++ ")"

435−doOp v LB64T16 [x] = v ++ "idris_b64T16(vm, " ++ creg x ++ ")"

436−doOp v LB64T32 [x] = v ++ "idris_b64T32(vm, " ++ creg x ++ ")"

437−

438−doOp v LFExp [x] = v ++ "MKFLOAT(exp(GETFLOAT(" ++ creg x ++ ")))"

439−doOp v LFLog [x] = v ++ "MKFLOAT(log(GETFLOAT(" ++ creg x ++ ")))"

440−doOp v LFSin [x] = v ++ "MKFLOAT(sin(GETFLOAT(" ++ creg x ++ ")))"

441−doOp v LFCos [x] = v ++ "MKFLOAT(cos(GETFLOAT(" ++ creg x ++ ")))"

442−doOp v LFTan [x] = v ++ "MKFLOAT(tan(GETFLOAT(" ++ creg x ++ ")))"

443−doOp v LFASin [x] = v ++ "MKFLOAT(asin(GETFLOAT(" ++ creg x ++ ")))"

444−doOp v LFACos [x] = v ++ "MKFLOAT(acos(GETFLOAT(" ++ creg x ++ ")))"

445−doOp v LFATan [x] = v ++ "MKFLOAT(atan(GETFLOAT(" ++ creg x ++ ")))"

446−doOp v LFSqrt [x] = v ++ "MKFLOAT(floor(GETFLOAT(" ++ creg x ++ ")))"

447−doOp v LFFloor [x] = v ++ "MKFLOAT(ceil(GETFLOAT(" ++ creg x ++ ")))"

448−doOp v LFCeil [x] = v ++ "MKFLOAT(sqrt(GETFLOAT(" ++ creg x ++ ")))"

321+doOp v (LLt ty) [x, y] = bitOp v "Lt" ty [x, y]

322+doOp v (LLe ty) [x, y] = bitOp v "Lte" ty [x, y]

323+doOp v (LEq ty) [x, y] = bitOp v "Eq" ty [x, y]

324+doOp v (LGe ty) [x, y] = bitOp v "Gte" ty [x, y]

325+doOp v (LGt ty) [x, y] = bitOp v "Gt" ty [x, y]

326+

327+doOp v (LSHL ty) [x, y] = bitOp v "Shl" ty [x, y]

328+doOp v (LLSHR ty) [x, y] = bitOp v "LShr" ty [x, y]

329+doOp v (LASHR ty) [x, y] = bitOp v "AShr" ty [x, y]

330+doOp v (LAnd ty) [x, y] = bitOp v "And" ty [x, y]

331+doOp v (LOr ty) [x, y] = bitOp v "Or" ty [x, y]

332+doOp v (LXOr ty) [x, y] = bitOp v "Xor" ty [x, y]

333+doOp v (LCompl ty) [x] = bitOp v "Compl" ty [x]

334+

335+doOp v (LPlus ty) [x, y] = bitOp v "Plus" ty [x, y]

336+doOp v (LMinus ty) [x, y] = bitOp v "Minus" ty [x, y]

337+doOp v (LTimes ty) [x, y] = bitOp v "Times" ty [x, y]

338+doOp v (LUDiv ty) [x, y] = bitOp v "UDiv" ty [x, y]

339+doOp v (LSDiv ty) [x, y] = bitOp v "SDiv" ty [x, y]

340+doOp v (LURem ty) [x, y] = bitOp v "URem" ty [x, y]

341+doOp v (LSRem ty) [x, y] = bitOp v "SRem" ty [x, y]

342+

343+doOp v (LSExt from ITBig) [x] = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

344+doOp v (LSExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"

345+doOp v (LSExt from ITNative) [x] = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ "))"

346+doOp v (LSExt from to) [x]

347+ | intTyWidth from < intTyWidth to = bitCoerce v "S" from to x

348+doOp v (LZExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"

349+doOp v (LZExt from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

350+doOp v (LZExt from ITBig) [x] = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

351+doOp v (LZExt from to) [x]

352+ | intTyWidth from < intTyWidth to = bitCoerce v "Z" from to x

353+doOp v (LTrunc ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"

354+doOp v (LTrunc from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

355+doOp v (LTrunc ITBig to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, mpz_get_ui(GETMPZ(" ++ creg x ++ "))"

356+doOp v (LTrunc from to) [x]

357+ | intTyWidth from > intTyWidth to = bitCoerce v "T" from to x

358+

359+doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)

360+doOp v LFLog [x] = v ++ flUnOp "log" (creg x)

361+doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)

362+doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)

363+doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)

364+doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)

365+doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)

366+doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)

367+doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)

368+doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)

369+doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)

449370

450371doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"

451372doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"

@@ -460,7 +381,10 @@ doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"

460381doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

461382doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

462383doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

463−doOp v LChInt args = v ++ creg (last args)

464−doOp v LIntCh args = v ++ creg (last args)

384+doOp v (LChInt ITNative) args = v ++ creg (last args)

385+doOp v (LIntCh ITNative) args = v ++ creg (last args)

465386doOp v LNoOp args = v ++ creg (last args)

466387doOp _ op _ = "FAIL /* " ++ show op ++ " */"

388+

389+flUnOp :: String -> String -> String

390+flUnOp name val = "MKFLOAT(vm, " ++ name ++ "(GETFLOAT(" ++ val ++ ")))"

src/IRTS/CodegenJava.hs+152−219

@@ -15,7 +15,8 @@ import qualified Control.Monad.Trans as T

1515import Control.Monad.Trans.State

1616import Data.Char

1717import Data.Maybe (fromJust)

18−import Data.List (isPrefixOf, isSuffixOf, intercalate)

18+import Data.List (isPrefixOf, isSuffixOf, intercalate, foldl')

19+import Data.Int

1920import qualified Data.Text as T

2021import qualified Data.Text.IO as TIO

2122import Language.Java.Parser

@@ -255,7 +256,7 @@ mkMainMethod =

255256 )

256257

257258mergeInnerClasses :: [Decl] -> [Decl]

258−mergeInnerClasses = foldl mergeInner []

259+mergeInnerClasses = foldl' mergeInner []

259260 where

260261 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)

261262 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))

@@ -418,6 +419,12 @@ mkIdentifier (UN name) =

418419 cleanReserved "idris_K" = "_idris_K"

419420 cleanReserved "idris_flipK" = "_idris_flipK"

420421 cleanReserved "idris_assignStack" = "_idris_assignStack"

422+ cleanReserved "free" = "_free"

423+ cleanReserved "malloc" = "_malloc"

424+ cleanReserved "idris_memset" = "_idris_memset"

425+ cleanReserved "idris_peek" = "_idris_peek"

426+ cleanReserved "idris_poke" = "_idris_poke"

427+ cleanReserved "idris_memmove" = "_idris_memmove"

421428

422429 cleanReserved x = x

423430

@@ -462,7 +469,39 @@ integerType :: ClassType

462469integerType = ClassType [(Ident "Integer", [])]

463470

464471longType :: ClassType

465−longType = ClassType [(Ident "Integer", [])]

472+longType = ClassType [(Ident "Long", [])]

473+

474+nextIntTy :: IntTy -> IntTy

475+nextIntTy IT8 = IT16

476+nextIntTy IT16 = IT32

477+nextIntTy IT32 = IT64

478+nextIntTy IT64 = IT64

479+nextIntTy ITNative = IT64

480+

481+intTyToIdent :: IntTy -> Ident

482+intTyToIdent IT8 = Ident "Byte"

483+intTyToIdent IT16 = Ident "Short"

484+intTyToIdent IT32 = Ident "Integer"

485+intTyToIdent IT64 = Ident "Long"

486+intTyToIdent ITNative = Ident "Integer"

487+intTyToIdent ITBig = Ident "BigInteger"

488+

489+intTyToClass :: IntTy -> ClassType

490+intTyToClass ty = ClassType [(intTyToIdent ty, [])]

491+

492+intTyToMethod :: IntTy -> String

493+intTyToMethod IT8 = "byteValue"

494+intTyToMethod IT16 = "shortValue"

495+intTyToMethod IT32 = "intValue"

496+intTyToMethod IT64 = "longValue"

497+intTyToMethod ITNative = "intValue"

498+

499+intTyToPrimTy :: IntTy -> PrimType

500+intTyToPrimTy IT8 = ByteT

501+intTyToPrimTy IT16 = ShortT

502+intTyToPrimTy IT32 = IntT

503+intTyToPrimTy IT64 = LongT

504+intTyToPrimTy ITNative = IntT

466505

467506bigIntegerType :: ClassType

468507bigIntegerType = ClassType [(Ident "BigInteger", [])]

@@ -956,7 +995,7 @@ mkStringAtIndex var indexExp =

956995 <$> mkVarAccess (Just stringType) var

957996

958997mkForeignType :: FType -> Maybe ClassType

959−mkForeignType FInt = return integerType

998+mkForeignType (FInt ty) = return (intTyToClass ty)

960999mkForeignType FChar = return integerType

9611000mkForeignType FString = return stringType

9621001mkForeignType FPtr = return objectType

@@ -965,14 +1004,14 @@ mkForeignType FAny = return objectType

9651004mkForeignType FUnit = Nothing

9661005

9671006mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp

968−mkForeignVarAccess FInt var =

969− (\ var -> MethodInv $ PrimaryMethodCall (var)

1007+mkForeignVarAccess (FInt ty) var =

1008+ (\ var -> MethodInv $ PrimaryMethodCall var

9701009 []

971− (Ident "intValue")

1010+ (Ident (intTyToMethod ty))

9721011 []

9731012 )

974− <$> mkVarAccess (Just integerType) var

975−mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess FInt var

1013+ <$> mkVarAccess (Just $ intTyToClass ty) var

1014+mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var

9761015mkForeignVarAccess FDouble var =

9771016 (\ var -> MethodInv $ PrimaryMethodCall (var)

9781017 []

@@ -983,12 +1022,12 @@ mkForeignVarAccess FDouble var =

9831022mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var

9841023

9851024mkFromForeignType :: FType -> Exp -> Exp

986−mkFromForeignType FInt from =

987− MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])

1025+mkFromForeignType (FInt ty) from =

1026+ MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])

9881027 []

9891028 (Ident "valueOf")

9901029 [from]

991−mkFromForeignType FChar from = mkFromForeignType FInt from

1030+mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from

9921031mkFromForeignType FDouble from =

9931032 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])

9941033 []

@@ -1219,7 +1258,9 @@ mkExp (SCon conId name args) =

12191258mkExp (SCase var alts) = mkCase False var alts

12201259mkExp (SChkCase var alts) = mkCase True var alts

12211260mkExp (SProj var i) = mkProjection var i

1222−mkExp (SConst (I x)) = return $ mkPrimitive "Integer" (Int (toInteger x))

1261+mkExp (SConst (I x)) =

1262+ let x' :: Int32; x' = fromInteger (toInteger x) in

1263+ return $ mkPrimitive "Integer" (Int (fromInteger (toInteger x')))

12231264mkExp (SConst (BI x)) =

12241265 return $ InstanceCreation []

12251266 (ClassType [(Ident "BigInteger", [])])

@@ -1233,10 +1274,10 @@ mkExp (SConst BIType) = return $ mkClass bigIntegerType

12331274mkExp (SConst FlType) = return $ mkClass doubleType

12341275mkExp (SConst ChType) = return $ mkClass charType

12351276mkExp (SConst StrType) = return $ mkClass stringType

1236−mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (Int (toInteger x))

1237−mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (Int (toInteger x))

1277+mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))

1278+mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))

12381279mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))

1239−mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (Int (toInteger x))

1280+mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))

12401281mkExp (SConst (B8Type))= return $ mkClass byteType

12411282mkExp (SConst (B16Type)) = return $ mkClass shortType

12421283mkExp (SConst (B32Type)) = return $ mkClass integerType

@@ -1245,24 +1286,22 @@ mkExp (SConst (PtrType)) = return $ mkClass objectType

12451286mkExp (SConst (VoidType)) = return $ mkClass voidType

12461287mkExp (SConst (Forgot)) = return $ mkClass objectType

12471288mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args

1248−mkExp (SOp LPlus args) = mkBinOpExp integerType Add args

1249−mkExp (SOp LMinus args) = mkBinOpExp integerType Sub args

1250−mkExp (SOp LTimes args) = mkBinOpExp integerType Mult args

1251−mkExp (SOp LDiv args) = mkBinOpExp integerType Div args

1252−mkExp (SOp LMod args) = mkBinOpExp integerType Rem args

1253−mkExp (SOp LAnd args) = mkBinOpExp integerType And args

1254−mkExp (SOp LOr args) = mkBinOpExp integerType Or args

1255−mkExp (SOp LXOr args) = mkBinOpExp integerType Xor args

1256−mkExp (SOp LCompl [var]) =

1257− PreBitCompl <$> mkVarAccess (Just $ integerType) var

1258−mkExp (SOp LSHL args) = mkBinOpExp integerType LShift args

1259−mkExp (SOp LSHR args) = mkBinOpExp integerType RShift args

1260−mkExp (SOp LEq args) =

1261− mkMethodOpChain1 (mkBoolToNumber integerType) objectType "equals" args

1262−mkExp (SOp LLt args) = mkLogicalBinOpExp integerType LThan args

1263−mkExp (SOp LLe args) = mkLogicalBinOpExp integerType LThanE args

1264−mkExp (SOp LGt args) = mkLogicalBinOpExp integerType GThan args

1265−mkExp (SOp LGe args) = mkLogicalBinOpExp integerType GThanE args

1289+mkExp (SOp (LPlus ITNative) args) = mkExp (SOp (LPlus IT32) args)

1290+mkExp (SOp (LMinus ITNative) args) = mkExp (SOp (LMinus IT32) args)

1291+mkExp (SOp (LTimes ITNative) args) = mkExp (SOp (LTimes IT32) args)

1292+mkExp (SOp (LSDiv ITNative) args) = mkExp (SOp (LSDiv IT32) args)

1293+mkExp (SOp (LSRem ITNative) args) = mkExp (SOp (LSRem IT32) args)

1294+mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd IT32) args)

1295+mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr IT32) args)

1296+mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr IT32) args)

1297+mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl IT32) args)

1298+mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL IT32) args)

1299+mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR IT32) args)

1300+mkExp (SOp (LEq ITNative) args) = mkExp (SOp (LEq IT32) args)

1301+mkExp (SOp (LLt ITNative) args) = mkExp (SOp (LLt IT32) args)

1302+mkExp (SOp (LLe ITNative) args) = mkExp (SOp (LLe IT32) args)

1303+mkExp (SOp (LGt ITNative) args) = mkExp (SOp (LGt IT32) args)

1304+mkExp (SOp (LGe ITNative) args) = mkExp (SOp (LGe IT32) args)

12661305mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args

12671306mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args

12681307mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args

@@ -1273,40 +1312,40 @@ mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args

12731312mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args

12741313mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args

12751314mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args

1276−mkExp (SOp LBPlus args) = mkMethodOpChain1 id bigIntegerType "add" args

1277−mkExp (SOp LBMinus args) = mkMethodOpChain1 id bigIntegerType "subtract" args

1278−mkExp (SOp LBTimes args) = mkMethodOpChain1 id bigIntegerType "multiply" args

1279−mkExp (SOp LBDiv args) = mkMethodOpChain1 id bigIntegerType "divide" args

1280−mkExp (SOp LBMod args) = mkMethodOpChain1 id bigIntegerType "mod" args

1281−mkExp (SOp LBEq args) =

1315+mkExp (SOp (LPlus ITBig) args) = mkMethodOpChain1 id bigIntegerType "add" args

1316+mkExp (SOp (LMinus ITBig) args) = mkMethodOpChain1 id bigIntegerType "subtract" args

1317+mkExp (SOp (LTimes ITBig) args) = mkMethodOpChain1 id bigIntegerType "multiply" args

1318+mkExp (SOp (LSDiv ITBig) args) = mkMethodOpChain1 id bigIntegerType "divide" args

1319+mkExp (SOp (LSRem ITBig) args) = mkMethodOpChain1 id bigIntegerType "mod" args

1320+mkExp (SOp (LEq ITBig) args) =

12821321 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args

1283−mkExp (SOp LBLt args) =

1322+mkExp (SOp (LLt ITBig) args) =

12841323 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

12851324 . mkPartialOrder SLt

12861325 )

12871326 bigIntegerType

1288− "compare"

1327+ "compareTo"

12891328 args

1290−mkExp (SOp LBLe args) =

1329+mkExp (SOp (LLe ITBig) args) =

12911330 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

12921331 . mkPartialOrder SLe

12931332 )

12941333 bigIntegerType

1295− "compare"

1334+ "compareTo"

12961335 args

1297−mkExp (SOp LBGt args) =

1336+mkExp (SOp (LGt ITBig) args) =

12981337 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

12991338 . mkPartialOrder SGt

13001339 )

13011340 bigIntegerType

1302− "compare"

1341+ "compareTo"

13031342 args

1304−mkExp (SOp LBGe args) =

1343+mkExp (SOp (LGe ITBig) args) =

13051344 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

13061345 . mkPartialOrder SGe

13071346 )

13081347 bigIntegerType

1309− "compare"

1348+ "compareTo"

13101349 args

13111350mkExp (SOp LStrConcat args) =

13121351 mkMethodOpChain (\ exp -> InstanceCreation []

@@ -1323,156 +1362,54 @@ mkExp (SOp LStrLt args@[_, _]) =

13231362 . mkPartialOrder SLt

13241363 )

13251364 stringType

1326− "compare"

1365+ "compareTo"

13271366 args

13281367mkExp (SOp LStrEq args@[_, _]) =

13291368 mkMethodOpChain1 ( mkBoolToNumber integerType)

13301369 stringType

13311370 "equals"

13321371 args

1333−mkExp (SOp LStrLen [arg]) =

1372+mkExp (SOp LStrLen [arg]) =

13341373 (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])

13351374 <$> mkVarAccess (Just stringType) arg

1336−mkExp (SOp LIntFloat [arg]) =

1337− mkPrimitiveCast integerType doubleType arg

1338−mkExp (SOp LFloatInt [arg]) =

1339− mkPrimitiveCast doubleType integerType arg

1340−mkExp (SOp LIntStr [arg]) =

1341− mkToString integerType arg

1342−mkExp (SOp LStrInt [arg]) =

1343− mkPrimitiveCast stringType integerType arg

1375+mkExp (SOp (LIntFloat ity) [arg]) =

1376+ mkPrimitiveCast (intTyToClass ity) doubleType arg

1377+mkExp (SOp (LFloatInt ity) [arg]) =

1378+ mkPrimitiveCast doubleType (intTyToClass ity) arg

1379+mkExp (SOp (LIntStr ITBig) [arg]) =

1380+ (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)

1381+ <$> mkVarAccess (Just stringType) arg

1382+mkExp (SOp (LIntStr ity) [arg]) =

1383+ mkToString (intTyToClass ity) arg

1384+mkExp (SOp (LStrInt ity) [arg]) =

1385+ mkPrimitiveCast stringType (intTyToClass ity) arg

13441386mkExp (SOp LFloatStr [arg]) =

13451387 mkToString doubleType arg

13461388mkExp (SOp LStrFloat [arg]) =

13471389 mkPrimitiveCast doubleType stringType arg

1348−mkExp (SOp LIntBig [arg]) =

1390+mkExp (SOp (LSExt ITNative ITBig) [arg]) =

13491391 mkPrimitiveCast integerType bigIntegerType arg

1350−mkExp (SOp LBigInt [arg]) =

1392+mkExp (SOp (LTrunc ITBig ITNative) [arg]) =

13511393 mkPrimitiveCast bigIntegerType integerType arg

1352−mkExp (SOp LStrBig [arg]) =

1353− (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)

1354− <$> mkVarAccess (Just stringType) arg

1355−mkExp (SOp LBigStr [arg]) =

1356− mkToString bigIntegerType arg

1357−mkExp (SOp LChInt [arg]) =

1394+mkExp (SOp (LChInt ITNative) [arg]) =

13581395 mkVarAccess (Just integerType) arg

1359−mkExp (SOp LIntCh [arg]) =

1396+mkExp (SOp (LIntCh ITNative) [arg]) =

13601397 mkVarAccess (Just integerType) arg

13611398mkExp (SOp LPrintNum [arg]) =

13621399 mkSystemOutPrint <$> (mkVarAccess Nothing arg)

13631400mkExp (SOp LPrintStr [arg]) =

13641401 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)

13651402mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])

1366−mkExp (SOp LB8Lt args) = mkLogicalBinOpExp byteType LThan args

1367−mkExp (SOp LB8Lte args) = mkLogicalBinOpExp byteType LThanE args

1368−mkExp (SOp LB8Eq args) =

1369− mkMethodOpChain1 (mkBoolToNumber byteType) byteType "equals" args

1370−mkExp (SOp LB8Gt args) = mkLogicalBinOpExp byteType GThan args

1371−mkExp (SOp LB8Gte args) = mkLogicalBinOpExp byteType GThanE args

1372−mkExp (SOp LB8Plus args) = mkBinOpExp byteType Add args

1373−mkExp (SOp LB8Minus args) = mkBinOpExp byteType Sub args

1374−mkExp (SOp LB8Times args) = mkBinOpExp byteType Mult args

1375−mkExp (SOp LB8UDiv args) = mkBinOpExpConv "shortValue" ShortT byteType Div args

1376−mkExp (SOp LB8SDiv args) = mkBinOpExp byteType Div args

1377−mkExp (SOp LB8URem args) = mkBinOpExpConv "shortValue" ShortT byteType Rem args

1378−mkExp (SOp LB8SRem args) = mkBinOpExp byteType Rem args

1379−mkExp (SOp LB8Shl args) = mkBinOpExp byteType LShift args

1380−mkExp (SOp LB8LShr args) = mkBinOpExp byteType RRShift args

1381−mkExp (SOp LB8AShr args) = mkBinOpExp byteType RShift args

1382−mkExp (SOp LB8And args) = mkBinOpExp byteType And args

1383−mkExp (SOp LB8Or args) = mkBinOpExp byteType Or args

1384−mkExp (SOp LB8Xor args) = mkBinOpExp byteType Xor args

1385−mkExp (SOp LB8Compl [var]) =

1386− PreBitCompl <$> mkVarAccess (Just $ byteType) var

1387−mkExp (SOp LB8Z16 [var]) = mkZeroExt "shortValue" 8 byteType shortType var

1388−mkExp (SOp LB8Z32 [var]) = mkZeroExt "intValue" 8 byteType integerType var

1389−mkExp (SOp LB8Z64 [var]) = mkZeroExt "longValue" 8 byteType longType var

1390−mkExp (SOp LB8S16 [var]) = mkSignedExt "shortValue" byteType shortType var

1391−mkExp (SOp LB8S32 [var]) = mkSignedExt "intValue" byteType integerType var

1392−mkExp (SOp LB8S64 [var]) = mkSignedExt "longValue" byteType longType var

1393−mkExp (SOp LB16Lt args) = mkLogicalBinOpExp shortType LThan args

1394−mkExp (SOp LB16Lte args) = mkLogicalBinOpExp shortType LThanE args

1395−mkExp (SOp LB16Eq args) =

1396− mkMethodOpChain1 (mkBoolToNumber shortType) shortType "equals" args

1397−mkExp (SOp LB16Gt args) = mkLogicalBinOpExp shortType GThan args

1398−mkExp (SOp LB16Gte args) = mkLogicalBinOpExp shortType GThanE args

1399−mkExp (SOp LB16Plus args) = mkBinOpExp shortType Add args

1400−mkExp (SOp LB16Minus args) = mkBinOpExp shortType Sub args

1401−mkExp (SOp LB16Times args) = mkBinOpExp shortType Mult args

1402−mkExp (SOp LB16UDiv args) = mkBinOpExpConv "intValue" IntT shortType Div args

1403−mkExp (SOp LB16SDiv args) = mkBinOpExp shortType Div args

1404−mkExp (SOp LB16URem args) = mkBinOpExpConv "intValue" IntT shortType Rem args

1405−mkExp (SOp LB16SRem args) = mkBinOpExp shortType Rem args

1406−mkExp (SOp LB16Shl args) = mkBinOpExp shortType LShift args

1407−mkExp (SOp LB16LShr args) = mkBinOpExp shortType RRShift args

1408−mkExp (SOp LB16AShr args) = mkBinOpExp shortType RShift args

1409−mkExp (SOp LB16And args) = mkBinOpExp shortType And args

1410−mkExp (SOp LB16Or args) = mkBinOpExp shortType Or args

1411−mkExp (SOp LB16Xor args) = mkBinOpExp shortType Xor args

1412−mkExp (SOp LB16Compl [var]) =

1413− PreBitCompl <$> mkVarAccess (Just $ shortType) var

1414−mkExp (SOp LB16Z32 [var]) = mkZeroExt "intValue" 16 shortType integerType var

1415−mkExp (SOp LB16Z64 [var]) = mkZeroExt "longValue" 16 shortType longType var

1416−mkExp (SOp LB16S32 [var]) = mkSignedExt "intValue" shortType integerType var

1417−mkExp (SOp LB16S64 [var]) = mkSignedExt "longValue" shortType longType var

1418−mkExp (SOp LB16T8 [var]) =

1419− (\ var -> MethodInv $

1420− TypeMethodCall (J.Name [Ident "Byte"])

1421− []

1422− (Ident "valueOf")

1423− [ MethodInv

1424− $ PrimaryMethodCall var [] (Ident "byteValue") [] ]

1425− )

1426− <$> mkVarAccess (Just $ shortType) var

1427−mkExp (SOp LB32Lt args) = mkLogicalBinOpExp integerType LThan args

1428−mkExp (SOp LB32Lte args) = mkLogicalBinOpExp integerType LThanE args

1429−mkExp (SOp LB32Eq args) =

1430− mkMethodOpChain1 (mkBoolToNumber integerType) integerType "equals" args

1431−mkExp (SOp LB32Gt args) = mkLogicalBinOpExp integerType GThan args

1432−mkExp (SOp LB32Gte args) = mkLogicalBinOpExp integerType GThanE args

1433−mkExp (SOp LB32Plus args) = mkBinOpExp integerType Add args

1434−mkExp (SOp LB32Minus args) = mkBinOpExp integerType Sub args

1435−mkExp (SOp LB32Times args) = mkBinOpExp integerType Mult args

1436−mkExp (SOp LB32UDiv args) = mkBinOpExpConv "longValue" LongT integerType Div args

1437−mkExp (SOp LB32SDiv args) = mkBinOpExp integerType Div args

1438−mkExp (SOp LB32URem args) = mkBinOpExpConv "longValue" LongT integerType Rem args

1439−mkExp (SOp LB32SRem args) = mkBinOpExp integerType Rem args

1440−mkExp (SOp LB32Shl args) = mkBinOpExp integerType LShift args

1441−mkExp (SOp LB32LShr args) = mkBinOpExp integerType RRShift args

1442−mkExp (SOp LB32AShr args) = mkBinOpExp integerType RShift args

1443−mkExp (SOp LB32And args) = mkBinOpExp integerType And args

1444−mkExp (SOp LB32Or args) = mkBinOpExp integerType Or args

1445−mkExp (SOp LB32Xor args) = mkBinOpExp integerType Xor args

1446−mkExp (SOp LB32Compl [var]) =

1447− PreBitCompl <$> mkVarAccess (Just $ integerType) var

1448−mkExp (SOp LB32Z64 [var]) = mkZeroExt "longValue" 32 integerType longType var

1449−mkExp (SOp LB32S64 [var]) = mkSignedExt "longValue" integerType longType var

1450−mkExp (SOp LB32T8 [var]) =

1451− (\ var -> MethodInv

1452− $ TypeMethodCall (J.Name [Ident "Byte"])

1453− []

1454− (Ident "valueOf")

1455− [ MethodInv $ PrimaryMethodCall var [] (Ident "byteValue") [] ]

1456− )

1457− <$> mkVarAccess (Just $ integerType) var

1458−mkExp (SOp LB32T16 [var]) =

1459− (\ var -> MethodInv

1460− $ TypeMethodCall (J.Name [Ident "Short"])

1461− []

1462− (Ident "valueOf")

1463− [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]

1464− )

1465− <$> mkVarAccess (Just $ integerType) var

1466−mkExp (SOp LB64Lt args) = mkLogicalBinOpExp longType LThan args

1467−mkExp (SOp LB64Lte args) = mkLogicalBinOpExp longType LThanE args

1468−mkExp (SOp LB64Eq args) =

1469− mkMethodOpChain1 (mkBoolToNumber longType) longType "equals" args

1470−mkExp (SOp LB64Gt args) = mkLogicalBinOpExp longType GThan args

1471−mkExp (SOp LB64Gte args) = mkLogicalBinOpExp longType GThanE args

1472−mkExp (SOp LB64Plus args) = mkBinOpExp longType Add args

1473−mkExp (SOp LB64Minus args) = mkBinOpExp longType Sub args

1474−mkExp (SOp LB64Times args) = mkBinOpExp longType Mult args

1475−mkExp (SOp LB64UDiv (arg:args)) = do

1403+mkExp (SOp (LLt ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args

1404+mkExp (SOp (LLe ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args

1405+mkExp (SOp (LEq ty) args) =

1406+ mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args

1407+mkExp (SOp (LGt ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args

1408+mkExp (SOp (LGe ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args

1409+mkExp (SOp (LPlus ty) args) = mkBinOpExp (intTyToClass ty) Add args

1410+mkExp (SOp (LMinus ty) args) = mkBinOpExp (intTyToClass ty) Sub args

1411+mkExp (SOp (LTimes ty) args) = mkBinOpExp (intTyToClass ty) Mult args

1412+mkExp (SOp (LUDiv IT64) (arg:args)) = do

14761413 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)

14771414 return $ foldl (\ exp arg ->

14781415 MethodInv $ PrimaryMethodCall

@@ -1496,8 +1433,14 @@ mkExp (SOp LB64UDiv (arg:args)) = do

14961433 )

14971434 arg

14981435 args

1499−mkExp (SOp LB64SDiv args) = mkBinOpExp longType Div args

1500−mkExp (SOp LB64URem (arg:args)) = do

1436+mkExp (SOp (LUDiv ty) args) =

1437+ mkBinOpExpConv (intTyToMethod $ nextIntTy ty)

1438+ (intTyToPrimTy $ nextIntTy ty)

1439+ (intTyToClass ty)

1440+ Div

1441+ args

1442+mkExp (SOp (LSDiv ty) args) = mkBinOpExp (intTyToClass ty) Div args

1443+mkExp (SOp (LURem IT64) (arg:args)) = do

15011444 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)

15021445 return $ foldl (\ exp arg ->

15031446 MethodInv $ PrimaryMethodCall

@@ -1521,46 +1464,36 @@ mkExp (SOp LB64URem (arg:args)) = do

15211464 )

15221465 arg

15231466 args

1524−mkExp (SOp LB64SRem args) = mkBinOpExp longType Rem args

1525−mkExp (SOp LB64Shl args) = mkBinOpExp longType LShift args

1526−mkExp (SOp LB64LShr args) = mkBinOpExp longType RRShift args

1527−mkExp (SOp LB64AShr args) = mkBinOpExp longType RShift args

1528−mkExp (SOp LB64And args) = mkBinOpExp longType And args

1529−mkExp (SOp LB64Or args) = mkBinOpExp longType Or args

1530−mkExp (SOp LB64Xor args) = mkBinOpExp longType Xor args

1531−mkExp (SOp LB64Compl [var]) =

1532− PreBitCompl <$> mkVarAccess (Just $ longType) var

1533−mkExp (SOp LB64T8 [var]) =

1534− (\ var -> MethodInv

1535− $ TypeMethodCall (J.Name [Ident "Byte"])

1536− []

1537− (Ident "valueOf")

1538− [ MethodInv

1539− $ PrimaryMethodCall var [] (Ident "byteValue") []

1540− ]

1541− )

1542− <$> mkVarAccess (Just $ longType) var

1543−mkExp (SOp LB64T16 [var]) =

1544− (\ var -> MethodInv

1545− $ TypeMethodCall (J.Name [Ident "Short"])

1546− []

1547− (Ident "valueOf")

1548− [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]

1549− )

1550− <$> mkVarAccess (Just $ longType) var

1551−mkExp (SOp LB64T32 [var]) =

1552− (\ var -> MethodInv

1553− $ TypeMethodCall (J.Name [Ident "Integer"])

1554− []

1555− (Ident "valueOf")

1556− [ MethodInv $ PrimaryMethodCall var [] (Ident "intValue") [] ]

1467+mkExp (SOp (LURem ty) args) =

1468+ mkBinOpExpConv (intTyToMethod $ nextIntTy ty)

1469+ (intTyToPrimTy $ nextIntTy ty)

1470+ (intTyToClass ty)

1471+ Rem

1472+ args

1473+mkExp (SOp (LSRem ty) args) = mkBinOpExp (intTyToClass ty) Rem args

1474+mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args

1475+mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args

1476+mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args

1477+mkExp (SOp (LAnd ty) args) = mkBinOpExp (intTyToClass ty) And args

1478+mkExp (SOp (LOr ty) args) = mkBinOpExp (intTyToClass ty) Or args

1479+mkExp (SOp (LXOr ty) args) = mkBinOpExp (intTyToClass ty) Xor args

1480+mkExp (SOp (LCompl ty) [var]) = PreBitCompl <$> mkVarAccess (Just $ intTyToClass ty) var

1481+mkExp (SOp (LZExt from to) [var])

1482+ | intTyWidth from < intTyWidth to

1483+ = mkZeroExt (intTyToMethod to) (intTyWidth from) (intTyToClass from) (intTyToClass to) var

1484+mkExp (SOp (LSExt from to) [var])

1485+ | intTyWidth from < intTyWidth to

1486+ = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var

1487+mkExp (SOp (LTrunc from to) [var])

1488+ | intTyWidth from > intTyWidth to

1489+ = (\ var -> MethodInv $

1490+ TypeMethodCall (J.Name [intTyToIdent to])

1491+ []

1492+ (Ident "valueOf")

1493+ [ MethodInv

1494+ $ PrimaryMethodCall var [] (Ident (intTyToMethod to)) [] ]

15571495 )

1558− <$> mkVarAccess (Just $ longType) var

1559−mkExp (SOp LIntB8 [arg]) = mkExp (SOp LB32T8 [arg])

1560−mkExp (SOp LIntB16 [arg]) = mkExp (SOp LB32T16 [arg])

1561−mkExp (SOp LIntB32 [arg]) = mkExp (SV arg)

1562−mkExp (SOp LIntB64 [arg]) = mkExp (SOp LB32S64 [arg])

1563−mkExp (SOp LB32Int [arg]) = mkExp (SV arg)

1496+ <$> mkVarAccess (Just $ intTyToClass from) var

15641497mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg

15651498mkExp (SOp LFLog [arg]) = mkMathFun "log" arg

15661499mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg

@@ -1652,4 +1585,4 @@ mkExp (SError err) =

16521585 []

16531586 (Ident "throwSelf")

16541587 []

1655−mkExp other = error (show other)

1588+mkExp other = error (show other)

src/IRTS/CodegenJavaScript.hs+62−46

@@ -139,6 +139,7 @@ translateConstant ChType = "__IDRRT__.Char"

139139translateConstant StrType = "__IDRRT__.String"

140140translateConstant BIType = "__IDRRT__.Integer"

141141translateConstant FlType = "__IDRRT__.Float"

142+translateConstant PtrType = "__IDRRT__.Ptr"

142143translateConstant Forgot = "__IDRRT__.Forgot"

143144translateConstant c =

144145 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"

@@ -199,61 +200,61 @@ translateExpression (SApp True name vars) =

199200 "new __IDRRT__.Tailcall("

200201 ++ "function(){\n"

201202 ++ "return " ++ translateFunctionCall name vars

202− ++ ";\n});"

203+ ++ ";\n})"

203204

204205translateExpression (SOp op vars)

205− | LPlus <- op

206+ | (LPlus _) <- op

206207 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

207− | LMinus <- op

208+ | (LMinus _) <- op

208209 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs

209− | LTimes <- op

210+ | (LTimes _) <- op

210211 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs

211− | LDiv <- op

212+ | (LSDiv _) <- op

212213 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs

213− | LMod <- op

214+ | (LSRem _) <- op

214215 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs

215− | LEq <- op

216+ | (LEq _) <- op

216217 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs

217− | LLt <- op

218+ | (LLt _) <- op

218219 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs

219− | LLe <- op

220+ | (LLe _) <- op

220221 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs

221− | LGt <- op

222+ | (LGt _) <- op

222223 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs

223− | LGe <- op

224+ | (LGe _) <- op

224225 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs

225− | LAnd <- op

226+ | (LAnd _) <- op

226227 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs

227− | LOr <- op

228+ | (LOr _) <- op

228229 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs

229− | LXOr <- op

230+ | (LXOr _) <- op

230231 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs

231− | LSHL <- op

232+ | (LSHL _) <- op

232233 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs

233− | LSHR <- op

234+ | (LASHR _) <- op

234235 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs

235− | LCompl <- op

236+ | (LCompl _) <- op

236237 , (arg:_) <- vars = '~' : translateVariableName arg

237238

238− | LBPlus <- op

239+ | (LPlus ITBig) <- op

239240 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"

240− | LBMinus <- op

241+ | (LMinus ITBig) <- op

241242 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"

242− | LBTimes <- op

243+ | (LTimes ITBig) <- op

243244 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"

244− | LBDiv <- op

245+ | (LSDiv ITBig) <- op

245246 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"

246− | LBMod <- op

247+ | (LSRem ITBig) <- op

247248 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"

248− | LBEq <- op

249+ | (LEq ITBig) <- op

249250 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"

250− | LBLt <- op

251+ | (LLt ITBig) <- op

251252 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"

252− | LBLe <- op

253+ | (LLe ITBig) <- op

253254 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"

254− | LBGt <- op

255+ | (LGt ITBig) <- op

255256 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"

256− | LBGe <- op

257+ | (LGe ITBig) <- op

257258 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"

258259

259260 | LFPlus <- op

@@ -284,29 +285,29 @@ translateExpression (SOp op vars)

284285 | LStrLen <- op

285286 , (arg:_) <- vars = translateVariableName arg ++ ".length"

286287

287− | LStrInt <- op

288+ | (LStrInt ITNative) <- op

288289 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"

289− | LIntStr <- op

290+ | (LIntStr ITNative) <- op

290291 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"

291− | LIntBig <- op

292+ | (LSExt ITNative ITBig) <- op

292293 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"

293− | LBigInt <- op

294+ | (LTrunc ITBig ITNative) <- op

294295 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"

295− | LBigStr <- op

296+ | (LIntStr ITBig) <- op

296297 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"

297− | LStrBig <- op

298+ | (LStrInt ITBig) <- op

298299 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"

299300 | LFloatStr <- op

300301 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"

301302 | LStrFloat <- op

302303 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"

303− | LIntFloat <- op

304+ | (LIntFloat ITNative) <- op

304305 , (arg:_) <- vars = translateVariableName arg

305− | LFloatInt <- op

306+ | (LFloatInt ITNative) <- op

306307 , (arg:_) <- vars = translateVariableName arg

307− | LChInt <- op

308+ | (LChInt ITNative) <- op

308309 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"

309− | LIntCh <- op

310+ | (LIntCh ITNative) <- op

310311 , (arg:_) <- vars =

311312 "String.fromCharCode(" ++ translateVariableName arg ++ ")"

312313

@@ -355,19 +356,27 @@ translateExpression (SOp op vars)

355356 ++ translateVariableName rhs

356357

357358translateExpression (SError msg) =

358− "(function(){throw \'" ++ msg ++ "\';})();"

359+ "(function(){throw \'" ++ msg ++ "\';})()"

359360

360361translateExpression (SForeign _ _ "putStr" [(FString, var)]) =

361− "__IDRRT__.print(" ++ translateVariableName var ++ ");"

362+ "__IDRRT__.print(" ++ translateVariableName var ++ ")"

362363

363364translateExpression (SForeign _ _ fun args)

364− | "." `isPrefixOf` fun, "[]=" `isSuffixOf` fun

365+ | "[]=" `isSuffixOf` fun

365366 , (obj:idx:val:[]) <- args =

366− concat [object obj, field, index idx, assign val]

367+ concat [object obj, index idx, assign val]

367368

368− | "." `isPrefixOf` fun, "[]" `isSuffixOf` fun

369+ | "[]" `isSuffixOf` fun

369370 , (obj:idx:[]) <- args =

370− concat [object obj, field, index idx]

371+ object obj ++ index idx

372+

373+ | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun

374+ , (obj:val:[]) <- args =

375+ concat [object obj, '[' : name ++ "]", assign val]

376+

377+ | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun

378+ , (obj:[]) <- args =

379+ object obj ++ '[' : name ++ "]"

371380

372381 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun

373382 , (obj:val:[]) <- args =

@@ -401,9 +410,16 @@ translateExpression (SForeign _ _ fun args)

401410 array = name

402411 object o = translateVariableName (snd o)

403412 index i = "[" ++ translateVariableName (snd i) ++ "]"

404− assign v = '=' : translateVariableName (snd v)

413+ assign v = '=' : generateWrapper v

405414 arguments as =

406− '(' : intercalate "," (map (translateVariableName . snd) as) ++ ")"

415+ '(' : intercalate "," (map generateWrapper as) ++ ")"

416+

417+ generateWrapper (ffunc, name)

418+ | FFunction <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"

419+ | FFunctionIO <- ffunc = "__IDRRT__.ffiWrap(" ++ translateVariableName name ++ ")"

420+

421+ generateWrapper (_, name) =

422+ translateVariableName name

407423

408424translateExpression (SChkCase var cases) =

409425 "(function(e){\n"

@@ -450,7 +466,7 @@ translateCase var (SConstCase ty e)

450466 | IType <- ty = matchHelper "Int"

451467 | BIType <- ty = matchHelper "Integer"

452468 | FlType <- ty = matchHelper "Float"

453− | PtrType <- ty = matchHelper "Pointer"

469+ | PtrType <- ty = matchHelper "Ptr"

454470 | Forgot <- ty = matchHelper "Forgot"

455471 where

456472 matchHelper tyName = translateTypeMatch var tyName e

src/IRTS/Compiler.hs+22−10

@@ -98,7 +98,7 @@ irMain tm = do i <- ir tm

9898allNames :: [Name] -> Name -> Idris [Name]

9999allNames ns n | n `elem` ns = return []

100100allNames ns n = do i <- getIState

101− case lookupCtxt Nothing n (idris_callgraph i) of

101+ case lookupCtxt n (idris_callgraph i) of

102102 [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))

103103 return (nub (n : concat more))

104104 _ -> return [n]

@@ -169,6 +169,8 @@ instance ToIR (TT Name) where

169169 | (P _ (UN "lazy") _, [_, arg]) <- unApply tm

170170 = do arg' <- ir' env arg

171171 return $ LLazyExp arg'

172+ | (P _ (UN "assert_smaller") _, [_, _, _, arg]) <- unApply tm

173+ = ir' env arg

172174 | (P _ (UN "par") _, [_, arg]) <- unApply tm

173175 = do arg' <- ir' env arg

174176 return $ LOp LPar [LLazyExp arg']

@@ -205,12 +207,12 @@ instance ToIR (TT Name) where

205207 Just tm -> return tm

206208 _ -> do

207209 let collapse

208− = case lookupCtxt Nothing n

210+ = case lookupCtxt n

209211 (idris_optimisation i) of

210212 [oi] -> collapsible oi

211213 _ -> False

212214 let unused

213− = case lookupCtxt Nothing n

215+ = case lookupCtxt n

214216 (idris_callgraph i) of

215217 [CGInfo _ _ _ _ unusedpos] ->

216218 unusedpos

@@ -229,7 +231,7 @@ instance ToIR (TT Name) where

229231-- ir' env (P _ (NS (UN "O") ["Nat", "Prelude"]) _)

230232-- = return $ LConst (BI 0)

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

232− ir' env (V i) | i < length env = return $ LV (Glob (env!!i))

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

233235 | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm

234236 ir' env (Bind n (Lam _) sc)

235237 = do let n' = uniqueName n env

@@ -284,14 +286,24 @@ getFTypes tm = case unApply tm of

284286 _ -> Nothing

285287

286288mkIty' (P _ (UN ty) _) = mkIty ty

289+mkIty' (App (P _ (UN "FIntT") _) (P _ (UN intTy) _)) = mkIntIty intTy

290+mkIty' (App (App (P _ (UN "FFunction") _) _) (App (P _ (UN "FAny") _) (App (P _ (UN "IO") _) _))) = FFunctionIO

291+mkIty' (App (App (P _ (UN "FFunction") _) _) _) = FFunction

287292mkIty' _ = FAny

288293

289−mkIty "FInt" = FInt

290−mkIty "FFloat" = FDouble

291−mkIty "FChar" = FChar

292−mkIty "FString" = FString

293−mkIty "FPtr" = FPtr

294−mkIty "FUnit" = FUnit

294+mkIty "FFloat" = FDouble

295+mkIty "FChar" = FChar

296+mkIty "FString" = FString

297+mkIty "FPtr" = FPtr

298+mkIty "FUnit" = FUnit

299+mkIty "FFunction" = FFunction

300+mkIty "FFunctionIO" = FFunctionIO

301+

302+mkIntIty "ITNative" = FInt ITNative

303+mkIntIty "IT8" = FInt IT8

304+mkIntIty "IT16" = FInt IT16

305+mkIntIty "IT32" = FInt IT32

306+mkIntIty "IT64" = FInt IT64

295307

296308zname = NS (UN "O") ["Nat","Prelude"]

297309sname = NS (UN "S") ["Nat","Prelude"]

src/IRTS/Defunctionalise.hs+2−2

@@ -80,14 +80,14 @@ addApps defs (n, LFun _ _ args e)

8080-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e

8181 aa env (LApp tc (LV (Glob n)) args)

8282 = do args' <- mapM (aa env) args

83− case lookupCtxt Nothing n defs of

83+ case lookupCtxt n defs of

8484 [LConstructor _ i ar] -> return $ DApp tc n args'

8585 [LFun _ _ as _] -> let arity = length as in

8686 fixApply tc n args' arity

8787 [] -> return $ chainAPPLY (DV (Glob n)) args'

8888 aa env (LLazyApp n args)

8989 = do args' <- mapM (aa env) args

90− case lookupCtxt Nothing n defs of

90+ case lookupCtxt n defs of

9191 [LConstructor _ i ar] -> return $ DApp False n args'

9292 [LFun _ _ as _] -> let arity = length as in

9393 fixLazyApply n args' arity

src/IRTS/LParser.hs+27−27

@@ -92,39 +92,39 @@ pLDecl = do reserved "data"

9292

9393pLExp = buildExpressionParser optable pLExp'

9494

95−optable = [[binary "*" (\x y -> LOp LTimes [x,y]) AssocLeft,

96− binary "/" (\x y -> LOp LDiv [x,y]) AssocLeft,

95+optable = [[binary "*" (\x y -> LOp (LTimes ITNative) [x,y]) AssocLeft,

96+ binary "/" (\x y -> LOp (LSDiv ITNative) [x,y]) AssocLeft,

9797 binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft,

9898 binary "/." (\x y -> LOp LFDiv [x,y]) AssocLeft,

99− binary "*:" (\x y -> LOp LBTimes [x,y]) AssocLeft,

100− binary "/:" (\x y -> LOp LBDiv [x,y]) AssocLeft

99+ binary "*:" (\x y -> LOp (LTimes ITBig) [x,y]) AssocLeft,

100+ binary "/:" (\x y -> LOp (LSDiv ITBig) [x,y]) AssocLeft

101101 ],

102102 [

103− binary "+" (\x y -> LOp LPlus [x,y]) AssocLeft,

104− binary "-" (\x y -> LOp LMinus [x,y]) AssocLeft,

103+ binary "+" (\x y -> LOp (LPlus ITNative) [x,y]) AssocLeft,

104+ binary "-" (\x y -> LOp (LMinus ITNative) [x,y]) AssocLeft,

105105 binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,

106106 binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft,

107107 binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft,

108− binary "+:" (\x y -> LOp LBPlus [x,y]) AssocLeft,

109− binary "-:" (\x y -> LOp LBMinus [x,y]) AssocLeft

108+ binary "+:" (\x y -> LOp (LPlus ITBig) [x,y]) AssocLeft,

109+ binary "-:" (\x y -> LOp (LMinus ITBig) [x,y]) AssocLeft

110110 ],

111111 [

112− binary "==" (\x y -> LOp LEq [x, y]) AssocNone,

112+ binary "==" (\x y -> LOp (LEq ITNative) [x, y]) AssocNone,

113113 binary "==." (\x y -> LOp LFEq [x, y]) AssocNone,

114− binary "<" (\x y -> LOp LLt [x, y]) AssocNone,

114+ binary "<" (\x y -> LOp (LLt ITNative) [x, y]) AssocNone,

115115 binary "<." (\x y -> LOp LFLt [x, y]) AssocNone,

116− binary ">" (\x y -> LOp LGt [x, y]) AssocNone,

116+ binary ">" (\x y -> LOp (LGt ITNative) [x, y]) AssocNone,

117117 binary ">." (\x y -> LOp LFGt [x, y]) AssocNone,

118− binary "<=" (\x y -> LOp LLe [x, y]) AssocNone,

118+ binary "<=" (\x y -> LOp (LLe ITNative) [x, y]) AssocNone,

119119 binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone,

120− binary ">=" (\x y -> LOp LGe [x, y]) AssocNone,

120+ binary ">=" (\x y -> LOp (LGe ITNative) [x, y]) AssocNone,

121121 binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone,

122122

123− binary "==:" (\x y -> LOp LBEq [x, y]) AssocNone,

124− binary "<:" (\x y -> LOp LBLt [x, y]) AssocNone,

125− binary ">:" (\x y -> LOp LBGt [x, y]) AssocNone,

126− binary "<=:" (\x y -> LOp LBLe [x, y]) AssocNone,

127− binary ">=:" (\x y -> LOp LBGe [x, y]) AssocNone

123+ binary "==:" (\x y -> LOp (LEq ITBig) [x, y]) AssocNone,

124+ binary "<:" (\x y -> LOp (LLt ITBig) [x, y]) AssocNone,

125+ binary ">:" (\x y -> LOp (LGt ITBig) [x, y]) AssocNone,

126+ binary "<=:" (\x y -> LOp (LLe ITBig) [x, y]) AssocNone,

127+ binary ">=:" (\x y -> LOp (LGe ITBig) [x, y]) AssocNone

128128 ]]

129129

130130binary name f assoc = Infix (do reservedOp name; return f) assoc

@@ -164,7 +164,7 @@ pLExp' = try (do lchar '%'; pCast)

164164

165165pLang = do reserved "C"; return LANG_C

166166

167−pType = do reserved "Int"; return FInt

167+pType = do reserved "Int"; return (FInt ITNative)

168168 <|> do reserved "Float"; return FDouble

169169 <|> do reserved "String"; return FString

170170 <|> do reserved "Unit"; return FUnit

@@ -184,21 +184,21 @@ pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'

184184 <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')'

185185 return (LOp LStrFloat [e])

186186 <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'

187− return (LOp LFloatInt [e])

187+ return (LOp (LFloatInt ITNative) [e])

188188 <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'

189− return (LOp LIntFloat [e])

189+ return (LOp (LIntFloat ITNative) [e])

190190 <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'

191− return (LOp LStrInt [e])

191+ return (LOp (LStrInt ITNative) [e])

192192 <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'

193− return (LOp LIntStr [e])

193+ return (LOp (LIntStr ITNative) [e])

194194 <|> do reserved "BigInt"; lchar '('; e <- pLExp; lchar ')'

195− return (LOp LBigInt [e])

195+ return (LOp (LTrunc ITBig ITNative) [e])

196196 <|> do reserved "IntBig"; lchar '('; e <- pLExp; lchar ')'

197− return (LOp LIntBig [e])

197+ return (LOp (LSExt ITNative ITBig) [e])

198198 <|> do reserved "BigString"; lchar '('; e <- pLExp; lchar ')'

199− return (LOp LBigStr [e])

199+ return (LOp (LIntStr ITBig) [e])

200200 <|> do reserved "StringBig"; lchar '('; e <- pLExp; lchar ')'

201− return (LOp LStrBig [e])

201+ return (LOp (LStrInt ITBig) [e])

202202

203203pPrim :: LParser LExp

204204pPrim = do reserved "StrEq"; lchar '(';

src/IRTS/Lang.hs+37−26

@@ -3,6 +3,7 @@ module IRTS.Lang where

33import Core.TT

44import Control.Monad.State hiding(lift)

55import Data.List

6+import Foreign.Storable (sizeOf)

67import Debug.Trace

78

89data LVar = Loc Int | Glob Name

@@ -28,36 +29,38 @@ data LExp = LV LVar

2829-- Primitive operators. Backends are not *required* to implement all

2930-- of these, but should report an error if they are unable

3031

31−data PrimFn = LPlus | LMinus | LTimes | LDiv | LMod

33− | LEq | LLt | LLe | LGt | LGe

32+data IntTy = ITNative | IT8 | IT16 | IT32 | IT64 | ITBig

33+ deriving (Show, Eq)

34+

35+intTyWidth :: IntTy -> Int

36+intTyWidth IT8 = 8

37+intTyWidth IT16 = 16

38+intTyWidth IT32 = 32

39+intTyWidth IT64 = 64

40+intTyWidth ITNative = 8 * sizeOf (0 :: Int)

41+intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width"

42+

43+intTyToConst :: IntTy -> Const

44+intTyToConst IT8 = B8Type

45+intTyToConst IT16 = B16Type

46+intTyToConst IT32 = B32Type

47+intTyToConst IT64 = B64Type

48+intTyToConst ITBig = BIType

49+intTyToConst ITNative = IType

50+

51+data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy

52+ | LUDiv IntTy | LSDiv IntTy | LURem IntTy | LSRem IntTy

53+ | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy

54+ | LSHL IntTy | LLSHR IntTy | LASHR IntTy

56+ | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy

3457 | LFPlus | LFMinus | LFTimes | LFDiv

3859 | LStrConcat | LStrLt | LStrEq | LStrLen

60+ | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy

61+ | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy

4162 | LPrintNum | LPrintStr | LReadStr

4263

46− | LB8Z16 | LB8Z32 | LB8Z64 | LB8S16 | LB8S32 | LB8S64 -- Zero/Sign extension

50− | LB16Z32 | LB16Z64 | LB16S32 | LB16S64 | LB16T8 -- and Truncation

54− | LB32Z64 | LB32S64 | LB32T8 | LB32T16

58− | LB64T8 | LB64T16 | LB64T32

60−

6265 | LFSqrt | LFFloor | LFCeil

6366

@@ -76,7 +79,15 @@ data PrimFn = LPlus | LMinus | LTimes | LDiv | LMod

7679data FLang = LANG_C

7780 deriving (Show, Eq)

7881

82+data FType = FInt IntTy

83+ | FFunction

84+ | FFunctionIO

85+ | FChar

86+ | FString

87+ | FUnit

88+ | FPtr

89+ | FDouble

90+ | FAny

8091 deriving (Show, Eq)

8192

8293data LAlt = LConCase Int Name [Name] LExp

src/IRTS/Simplified.hs+7−7

@@ -46,7 +46,7 @@ simplify :: Bool -> DExp -> State (DDefs, Int) SExp

4646simplify tl (DV (Loc i)) = return (SV (Loc i))

4747simplify tl (DV (Glob x))

4848 = do ctxt <- ldefs

49− case lookupCtxt Nothing x ctxt of

49+ case lookupCtxt 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

@@ -88,7 +88,7 @@ simplify tl (DError str) = return $ SError str

8888

8989sVar (DV (Glob x))

9090 = do ctxt <- ldefs

91− case lookupCtxt Nothing x ctxt of

91+ case lookupCtxt x ctxt of

9292 [DConstructor _ t 0] -> sVar (DC t x [])

9393 _ -> return (Glob x, Nothing)

9494sVar (DV x) = return (x, Nothing)

@@ -136,7 +136,7 @@ scopecheck 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))

139− Nothing -> case lookupCtxt Nothing n ctxt of

139+ Nothing -> case lookupCtxt n ctxt of

140140 [DConstructor _ i ar] ->

141141 if True -- ar == 0

142142 then return (SCon i n [])

@@ -146,7 +146,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

146146 [] -> fail $ "Codegen error: No such variable " ++ show n

147147 sc env (SApp tc f args)

148148 = do args' <- mapM (scVar env) args

149− case lookupCtxt Nothing f ctxt of

149+ case lookupCtxt f ctxt of

150150 [DConstructor n tag ar] ->

151151 if True -- (ar == length args)

152152 then return $ SCon tag n args'

@@ -160,7 +160,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

160160 return $ SForeign l ty f args'

161161 sc env (SCon tag f args)

162162 = do args' <- mapM (scVar env) args

163− case lookupCtxt Nothing f ctxt of

163+ case lookupCtxt f ctxt of

164164 [DConstructor n tag ar] ->

165165 if True -- (ar == length args)

166166 then return $ SCon tag n args'

@@ -197,7 +197,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

197197 scVar env (Glob n) =

198198 case lookup n (reverse env) of -- most recent first

199199 Just i -> do lvar i; return (Loc i)

200− Nothing -> case lookupCtxt Nothing n ctxt of

200+ Nothing -> case lookupCtxt n ctxt of

201201 [DConstructor _ i ar] ->

202202 fail $ "Codegen error : can't pass constructor here"

203203 [_] -> return (Glob n)

@@ -207,7 +207,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

207207

208208 scalt env (SConCase _ i n args e)

209209 = do let env' = env ++ zip args [length env..]

210− tag <- case lookupCtxt Nothing n ctxt of

210+ tag <- case lookupCtxt n ctxt of

211211 [DConstructor _ i ar] ->

212212 if True -- (length args == ar)

213213 then return i

src/Idris/AbsSyntax.hs+117−27

@@ -8,6 +8,7 @@ import Core.Evaluate

88import Core.Elaborate hiding (Tactic(..))

99import Core.Typecheck

1010import Idris.AbsSyntaxTree

11+import Idris.IdeSlave

1112import IRTS.CodegenCommon

1213import Util.DynamicLinker

1314

@@ -24,7 +25,7 @@ import Data.Either

2425import Debug.Trace

2526

2627import Util.Pretty

27−

28+import Util.System

2829

2930getContext :: Idris Context

3031getContext = do i <- getIState; return (tt_ctxt i)

@@ -41,13 +42,15 @@ getLibs = do i <- getIState; return (idris_libs i)

4142addLib :: String -> Idris ()

4243addLib f = do i <- getIState; putIState $ i { idris_libs = f : idris_libs i }

4344

44−addDyLib :: String -> Idris ()

45−addDyLib lib = do i <- getIState

46− handle <- lift $ tryLoadLib lib

47− case handle of

48− Nothing -> fail $ "Could not load dynamic lib \"" ++ lib ++ "\""

49− Just x -> do let libs = idris_dynamic_libs i

50− putIState $ i { idris_dynamic_libs = x:libs }

45+addDyLib :: [String] -> Idris (Either DynamicLib String)

46+addDyLib libs = do i <- getIState

47+ handle <- lift $ mapM (\l -> catchIO (tryLoadLib l) (\_ -> return Nothing)) libs

48+ case msum handle of

49+ Nothing -> return (Right $ "Could not load dynamic alternatives \"" ++

50+ concat (intersperse "," libs) ++ "\"")

51+ Just x -> do let ls = idris_dynamic_libs i

52+ putIState $ i { idris_dynamic_libs = x:ls }

53+ return (Left x)

5154

5255addHdr :: String -> Idris ()

5356addHdr f = do i <- getIState; putIState $ i { idris_hdrs = f : idris_hdrs i }

@@ -88,7 +91,7 @@ getCoercionsTo i ty =

8891 findCoercions fn cs

8992 where findCoercions t [] = []

9093 findCoercions t (n : ns) =

91− let ps = case lookupTy Nothing n (tt_ctxt i) of

94+ let ps = case lookupTy n (tt_ctxt i) of

9295 [ty] -> case unApply (getRetTy ty) of

9396 (t', _) ->

9497 if t == t' then [n] else []

@@ -119,7 +122,7 @@ addToCalledG n ns = return () -- TODO

119122addInstance :: Bool -> Name -> Name -> Idris ()

120123addInstance int n i

121124 = do ist <- getIState

122− case lookupCtxt Nothing n (idris_classes ist) of

125+ case lookupCtxt n (idris_classes ist) of

123126 [CI a b c d ins] ->

124127 do let cs = addDef n (CI a b c d (addI i ins)) (idris_classes ist)

125128 putIState $ ist { idris_classes = cs }

@@ -139,7 +142,7 @@ addInstance int n i

139142addClass :: Name -> ClassInfo -> Idris ()

140143addClass n i

141144 = do ist <- getIState

142− let i' = case lookupCtxt Nothing n (idris_classes ist) of

145+ let i' = case lookupCtxt n (idris_classes ist) of

143146 [c] -> c { class_instances = class_instances i }

144147 _ -> i

145148 putIState $ ist { idris_classes = addDef n i' (idris_classes ist) }

@@ -193,7 +196,7 @@ getName = do i <- getIState;

193196checkUndefined :: FC -> Name -> Idris ()

194197checkUndefined fc n

195198 = do i <- getContext

196− case lookupTy Nothing n i of

199+ case lookupTy n i of

197200 (_:_) -> fail $ show fc ++ ":" ++

198201 show n ++ " already defined"

199202 _ -> return ()

@@ -201,7 +204,7 @@ checkUndefined fc n

201204isUndefined :: FC -> Name -> Idris Bool

202205isUndefined fc n

203206 = do i <- getContext

204− case lookupTy Nothing n i of

207+ case lookupTy n i of

205208 (_:_) -> return False

206209 _ -> return True

207210

@@ -220,10 +223,14 @@ addConstraints fc (v, cs)

220223 let ics = zip cs (repeat fc) ++ idris_constraints i

221224 putIState $ i { tt_ctxt = ctxt', idris_constraints = ics }

222225

223−addDeferred :: [(Name, Type)] -> Idris ()

224−addDeferred ns = do mapM_ (\(n, t) -> updateContext (addTyDecl n (tidyNames [] t))) ns

225− i <- getIState

226− putIState $ i { idris_metavars = map fst ns ++ idris_metavars i }

226+addDeferred = addDeferred' Ref

227+addDeferredTyCon = addDeferred' (TCon 0 0)

228+

229+addDeferred' :: NameType -> [(Name, Type)] -> Idris ()

230+addDeferred' nt ns

231+ = do mapM_ (\(n, t) -> updateContext (addTyDecl n nt (tidyNames [] t))) ns

232+ i <- getIState

233+ putIState $ i { idris_metavars = map fst ns ++ idris_metavars i }

227234 where tidyNames used (Bind (MN i x) b sc)

228235 = let n' = uniqueName (UN x) used in

229236 Bind n' b $ tidyNames (n':used) sc

@@ -236,11 +243,44 @@ solveDeferred :: Name -> Idris ()

236243solveDeferred n = do i <- getIState

237244 putIState $ i { idris_metavars = idris_metavars i \\ [n] }

238245

246+iResult :: String -> Idris ()

247+iResult s = do i <- getIState

248+ case idris_outputmode i of

249+ RawOutput -> case s of

250+ "" -> return ()

251+ s -> liftIO $ putStrLn s

252+ IdeSlave n ->

253+ let good = SexpList [SymbolAtom "ok", toSExp s] in

254+ liftIO $ putStrLn $ convSExp "return" good n

255+

256+iFail :: String -> Idris ()

257+iFail s = do i <- getIState

258+ case idris_outputmode i of

259+ RawOutput -> case s of

260+ "" -> return ()

261+ s -> liftIO $ putStrLn s

262+ IdeSlave n ->

263+ let good = SexpList [SymbolAtom "error", toSExp s] in

264+ liftIO $ putStrLn $ convSExp "return" good n

265+

239266iputStrLn :: String -> Idris ()

240−iputStrLn = liftIO . putStrLn

267+iputStrLn s = do i <- getIState

268+ case idris_outputmode i of

269+ RawOutput -> liftIO $ putStrLn s

270+ IdeSlave n ->

271+ case span (/=':') s of

272+ (fn, ':':rest) -> case span isDigit rest of

273+ ([], ':':msg) -> write

274+ ([], msg) -> write

275+ (num, ':':msg) -> iWarn (FC fn (read num)) msg

276+ _ -> write

277+ where write = liftIO $ putStrLn $ convSExp "write-string" s n

241278

242279iWarn :: FC -> String -> Idris ()

243−iWarn fc err = liftIO $ putStrLn (show fc ++ ":" ++ err)

280+iWarn fc err = do i <- getIState

281+ case idris_outputmode i of

282+ RawOutput -> liftIO $ putStrLn (show fc ++ ":" ++ err)

283+ IdeSlave n -> liftIO $ putStrLn $ convSExp "warning" (fc_fname fc, fc_line fc, err) n

244284

245285setLogLevel :: Int -> Idris ()

246286setLogLevel l = do i <- getIState

@@ -317,6 +357,11 @@ outputTy :: Idris OutputType

317357outputTy = do i <- getIState

318358 return $ opt_outputTy $ idris_options i

319359

360+setIdeSlave :: Bool -> Idris ()

361+setIdeSlave True = do i <- getIState

362+ putIState $ i { idris_outputmode = (IdeSlave 0) }

363+setIdeSlave False = return ()

364+

320365verbose :: Idris Bool

321366verbose = do i <- getIState

322367 return (opt_verbose (idris_options i))

@@ -641,7 +686,7 @@ getPriority :: IState -> PTerm -> Int

641686getPriority i tm = 1 -- pri tm

642687 where

643688 pri (PRef _ n) =

644− case lookupP Nothing n (tt_ctxt i) of

689+ case lookupP n (tt_ctxt i) of

645690 ((P (DCon _ _) _ _):_) -> 1

646691 ((P (TCon _ _) _ _):_) -> 1

647692 ((P Ref _ _):_) -> 1

@@ -688,6 +733,45 @@ addStatics n tm ptm =

688733

689734-- Dealing with implicit arguments

690735

736+-- Add constraint bindings from using block

737+

738+addUsingConstraints :: SyntaxInfo -> FC -> PTerm -> Idris PTerm

739+addUsingConstraints syn fc t

740+ = do ist <- get

741+ let ns = namesIn [] ist t

742+ let cs = getConstraints t -- check declared constraints

743+ let addconsts = uconsts \\ cs

744+ -- if all names in the arguments of addconsts appear in ns,

745+ -- add the constraint implicitly

746+ return (doAdd addconsts ns t)

747+ where uconsts = filter uconst (using syn)

748+ uconst (UConstraint _ _) = True

749+ uconst _ = False

750+

751+ doAdd [] _ t = t

752+ -- if all of args in ns, then add it

753+ doAdd (UConstraint c args : cs) ns t

754+ | all (\n -> elem n ns) args

755+ = PPi (Constraint False Dynamic "") (MN 0 "cu")

756+ (mkConst c args) (doAdd cs ns t)

757+ | otherwise = doAdd cs ns t

758+

759+ mkConst c args = PApp fc (PRef fc c)

760+ (map (\n -> PExp 0 False (PRef fc n) "") args)

761+

762+ getConstraints (PPi (Constraint _ _ _) _ c sc)

763+ = getcapp c ++ getConstraints sc

764+ getConstraints (PPi _ _ c sc) = getConstraints sc

765+ getConstraints _ = []

766+

767+ getcapp (PApp _ (PRef _ c) args)

768+ = do ns <- mapM getName args

769+ return (UConstraint c ns)

770+ getcapp _ = []

771+

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

773+ getName _ = []

774+

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

692776-- argument position.

693777

@@ -717,9 +801,13 @@ implicitise syn ignore ist tm

717801 then (tm, reverse declimps)

718802 else implicitise syn ignore ist (pibind uvars ns tm)

719803 where

720− uvars = using syn

804+ uvars = map ipair (filter uimplicit (using syn))

721805 pvars = syn_params syn

722806

807+ ipair (UImplicit x y) = (x, y)

808+ uimplicit (UImplicit _ _) = True

809+ uimplicit _ = False

810+

723811 dropAll (x:xs) ys | x `elem` ys = dropAll xs ys

724812 | otherwise = x : dropAll xs ys

725813 dropAll [] ys = []

@@ -882,9 +970,9 @@ addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

882970

883971aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm

884972aiFn inpat True ist fc f []

885− = case lookupDef Nothing f (tt_ctxt ist) of

973+ = case lookupDef f (tt_ctxt ist) of

886974 [] -> Right $ PPatvar fc f

887− alts -> let ialts = lookupCtxt Nothing f (idris_implicits ist) in

975+ alts -> let ialts = lookupCtxt f (idris_implicits ist) in

888976 -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

889977 if (not (vname f) || tcname f

890978 || any constructor alts || any allImp ialts)

@@ -904,7 +992,7 @@ aiFn inpat expat ist fc f as

904992 | f `elem` primNames = Right $ PApp fc (PRef fc f) as

905993aiFn inpat expat ist fc f as

906994 -- This is where namespaces get resolved by adding PAlternative

907− = case lookupCtxtName Nothing f (idris_implicits ist) of

995+ = case lookupCtxtName f (idris_implicits ist) of

908996 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)

909997 [] -> if f `elem` idris_metavars ist

910998 then Right $ PApp fc (PRef fc f) as

@@ -949,7 +1037,7 @@ stripLinear :: IState -> PTerm -> PTerm

9491037stripLinear i tm = evalState (sl tm) [] where

9501038 sl :: PTerm -> State [Name] PTerm

9511039 sl (PRef fc f)

952− | (_:_) <- lookupTy Nothing f (tt_ctxt i)

1040+ | (_:_) <- lookupTy f (tt_ctxt i)

9531041 = return $ PRef fc f

9541042 | otherwise = do ns <- get

9551043 if (f `elem` ns)

@@ -1074,14 +1162,16 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

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

10751163-- | otherwise = Nothing

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

1165+ match (PPatvar f n) xr = match (PRef f n) xr

1166+ match xr (PPatvar f n) = match xr (PRef f n)

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

10781168 match (PRef _ n) tm@(PRef _ n')

10791169 | n == n' && not names &&

1080− (not (isConName Nothing n (tt_ctxt i)) || tm == Placeholder)

1170+ (not (isConName n (tt_ctxt i)) || tm == Placeholder)

10811171 = return [(n, tm)]

10821172 | n == n' = return []

10831173 match (PRef _ n) tm

1084− | not names && (not (isConName Nothing n (tt_ctxt i)) || tm == Placeholder)

1174+ | not names && (not (isConName n (tt_ctxt i)) || tm == Placeholder)

10851175 = return [(n, tm)]

10861176 match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l'

10871177 mr <- match' r r'

src/Idris/AbsSyntaxTree.hs+73−10

@@ -41,10 +41,27 @@ data IOption = IOption { opt_logLevel :: Int,

4141 }

4242 deriving (Show, Eq)

4343

44−defaultOpts = IOption 0 False False True False False True True False ViaC Executable "" [] []

44+defaultOpts = IOption { opt_logLevel = 0

45+ , opt_typecase = False

46+ , opt_typeintype = False

47+ , opt_coverage = True

48+ , opt_showimp = False

49+ , opt_errContext = False

50+ , opt_repl = True

51+ , opt_verbose = True

52+ , opt_quiet = False

53+ , opt_target = ViaC

54+ , opt_outputTy = Executable

55+ , opt_ibcsubdir = ""

56+ , opt_importdirs = []

57+ , opt_cmdline = []

58+ }

4559

4660data LanguageExt = TypeProviders deriving (Show, Eq, Read, Ord)

4761

62+-- | The output mode in use

63+data OutputMode = RawOutput | IdeSlave Integer deriving Show

64+

4865-- TODO: Add 'module data' to IState, which can be saved out and reloaded quickly (i.e

4966-- without typechecking).

5067-- This will include all the functions and data declarations, plus fixity declarations

@@ -62,7 +79,8 @@ data IState = IState {

6279 idris_dsls :: Ctxt DSL,

6380 idris_optimisation :: Ctxt OptInfo,

6481 idris_datatypes :: Ctxt TypeInfo,

65− idris_patdefs :: Ctxt [([Name], Term, Term)], -- not exported

82+ idris_patdefs :: Ctxt ([([Name], Term, Term)], [PTerm]), -- not exported

83+ -- ^ list of lhs/rhs, and a list of missing clauses

6684 idris_flags :: Ctxt [FnOpt],

6785 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

6886 idris_calledgraph :: Ctxt [Name],

@@ -91,7 +109,8 @@ data IState = IState {

91109 ibc_write :: [IBCWrite],

92110 compiled_so :: Maybe String,

93111 idris_dynamic_libs :: [DynamicLib],

94− idris_language_extensions :: [LanguageExt]

112+ idris_language_extensions :: [LanguageExt],

113+ idris_outputmode :: OutputMode

95114 }

96115

97116data SizeChange = Smaller | Same | Bigger | Unknown

@@ -143,10 +162,11 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

143162 emptyContext emptyContext emptyContext emptyContext

144163 emptyContext emptyContext emptyContext emptyContext

145164 [] "" defaultOpts 6 [] [] [] [] [] [] [] [] []

146− [] Nothing Nothing [] [] [] Hidden False [] Nothing [] []

165+ [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

147166

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

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

169+--type Idris = WriterT [Either String (IO ())] (State IState a))

150170type Idris = StateT IState IO

151171

152172-- Commands in the REPL

@@ -167,6 +187,7 @@ data Command = Quit

167187 | TotCheck Name

168188 | Reload

169189 | Load FilePath

190+ | ChangeDirectory FilePath

170191 | ModImport String

171192 | Edit

172193 | Compile Target String

@@ -200,6 +221,7 @@ data Opt = Filename String

200221 | Ver

201222 | Usage

202223 | Quiet

224+ | Ideslave

203225 | ShowLibs

204226 | ShowLibdir

205227 | ShowIncs

@@ -701,7 +723,14 @@ initDSL = DSL (PRef f (UN ">>="))

701723 Nothing

702724 where f = FC "(builtin)" 0

703725

704−data SyntaxInfo = Syn { using :: [(Name, PTerm)],

726+data Using = UImplicit Name PTerm

727+ | UConstraint Name [Name]

728+ deriving (Show, Eq)

729+{-!

730+deriving instance Binary Using

731+!-}

732+

733+data SyntaxInfo = Syn { using :: [Using],

705734 syn_params :: [(Name, PTerm)],

706735 syn_namespace :: [String],

707736 no_imp :: [Name],

@@ -886,10 +915,10 @@ prettyImp impl = prettySe 10

886915 bracket p 1 $

887916 prettySe 1 f <+>

888917 if impl then

889− foldl fS empty as

918+ foldl' fS empty as

890919 -- foldr (<+>) empty $ map prettyArgS as

891920 else

892− foldl fSe empty args

921+ foldl' fSe empty args

893922 -- foldr (<+>) empty $ map prettyArgSe args

894923 where

895924 fS l r =

@@ -978,7 +1007,7 @@ prettyImp impl = prettySe 10

9781007showImp :: Bool -> PTerm -> String

9791008showImp impl tm = se 10 tm where

9801009 se p (PQuote r) = "![" ++ show r ++ "]"

981− se p (PPatvar fc n) = show n

1010+ se p (PPatvar fc n) = if impl then show n ++ "[p]" else show n

9821011 se p (PInferRef fc n) = "!" ++ show n -- ++ "[" ++ show fc ++ "]"

9831012 se p (PRef fc n) = if impl then show n -- ++ "[" ++ show fc ++ "]"

9841013 else showbasic n

@@ -1013,6 +1042,9 @@ showImp impl tm = se 10 tm where

10131042 = bracket p 2 $ se 10 ty ++ " => " ++ se 10 sc

10141043 se p (PPi (TacImp _ _ s _) n ty sc)

10151044 = bracket p 2 $ "{tacimp " ++ show n ++ " : " ++ se 10 ty ++ "} -> " ++ se 10 sc

1045+ se p e

1046+ | Just str <- slist p e = str

1047+ | Just num <- snat p e = show num

10161048 se p (PApp _ (PRef _ f) [])

10171049 | not impl = show f

10181050 se p (PApp _ (PRef _ op@(UN (f:_))) args)

@@ -1051,6 +1083,37 @@ showImp impl tm = se 10 tm where

10511083 se p (PCoerced t) = se p t

10521084-- se p x = "Not implemented"

10531085

1086+ slist' p (PApp _ (PRef _ nil) _)

1087+ | nsroot nil == UN "Nil" = Just []

1088+ slist' p (PApp _ (PRef _ cons) args)

1089+ | nsroot cons == UN "::",

1090+ (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,

1091+ all isImp imps,

1092+ Just tl' <- slist' p tl

1093+ = Just (hd:tl')

1094+ where

1095+ isImp (PImp {}) = True

1096+ isImp _ = False

1097+ slist' _ _ = Nothing

1098+

1099+ slist p e | Just es <- slist' p e = Just $

1100+ case es of [] -> "[]"

1101+ [x] -> "[" ++ se p x ++ "]"

1102+ xs -> "[" ++ intercalate "," (map (se p) xs) ++ "]"

1103+ slist _ _ = Nothing

1104+

1105+ -- since Prelude is always imported, S & O are unqualified iff they're the

1106+ -- Nat ones.

1107+ snat p (PRef _ o)

1108+ | show o == (natns++"O") || show o == "O" = Just 0

1109+ snat p (PApp _ s [PExp {getTm=n}])

1110+ | show s == (natns++"S") || show s == "S",

1111+ Just n' <- snat p n

1112+ = Just $ 1 + n'

1113+ snat _ _ = Nothing

1114+

1115+ natns = "Prelude.Nat."

1116+

10541117 sArg (PImp _ _ n tm _) = siArg (n, tm)

10551118 sArg (PExp _ _ tm _) = seArg tm

10561119 sArg (PConstraint _ _ tm _) = scArg tm

@@ -1127,7 +1190,7 @@ namesIn uvars ist tm = nub $ ni [] tm

11271190 where

11281191 ni env (PRef _ n)

11291192 | not (n `elem` env)

1130− = case lookupTy Nothing n (tt_ctxt ist) of

1193+ = case lookupTy n (tt_ctxt ist) of

11311194 [] -> [n]

11321195 _ -> if n `elem` (map fst uvars) then [n] else []

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

@@ -1151,7 +1214,7 @@ usedNamesIn vars ist tm = nub $ ni [] tm

11511214 where

11521215 ni env (PRef _ n)

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

1154− = case lookupTy Nothing n (tt_ctxt ist) of

1217+ = case lookupTy n (tt_ctxt ist) of

11551218 [] -> [n]

11561219 _ -> []

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

src/Idris/Completion.hs+5−1

@@ -59,7 +59,11 @@ nameString _ = Nothing

5959names :: Idris [String]

6060names = do i <- get

6161 let ctxt = tt_ctxt i

62− return $ nub $ mapMaybe (nameString . fst) $ ctxtAlist ctxt

62+ return . nub $

63+ mapMaybe (nameString . fst) (ctxtAlist ctxt) ++

64+ -- Explicitly add primitive types, as these are special-cased in the parser

65+ ["Int", "Integer", "Float", "Char", "String", "Type",

66+ "Ptr", "Bits8", "Bits16", "Bits32", "Bits64"]

6367

6468metavars :: Idris [String]

6569metavars = do i <- get

src/Idris/Coverage.hs+148−170

@@ -17,28 +17,13 @@ import Debug.Trace

1717

1818import Control.Monad.State

1919

20−-- Generate the LHSes which are missing from a case tree

21−-- Eliminate the ones which cannot be well typed

22−

23−genMissing :: Name -> [Name] -> SC -> Idris [PTerm]

24−genMissing fn args sc

25− = do sc' <- expandTree sc

26− logLvl 5 $ "Checking missing cases for " ++

27− show fn ++ "\n" ++ (show sc')

28− (got, missing) <- gm fn (map (\x -> P Bound x Erased) args) sc'

29− return $ filter (\x -> not (x `elem` got)) missing

30−

31−-- Make a term to feed to the pattern matcher from a LHS declared impossible

32−-- (we can't type check it, but we need the case analysis to check for

33−-- covering...)

34−

3520mkPatTm :: PTerm -> Idris Term

3621mkPatTm t = do i <- getIState

3722 let timp = addImpl' True [] [] i t

3823 evalStateT (toTT timp) 0

3924 where

4025 toTT (PRef _ n) = do i <- lift getIState

41− case lookupDef Nothing n (tt_ctxt i) of

26+ case lookupDef n (tt_ctxt i) of

4227 [TyDecl nt _] -> return $ P nt n Erased

4328 _ -> return $ P Ref n Erased

4429 toTT (PApp _ t args) = do t' <- toTT t

@@ -48,101 +33,6 @@ mkPatTm t = do i <- getIState

4833 put (v + 1)

4934 return (P Bound (MN v "imp") Erased)

5035

51−mkPTerm :: Name -> [TT Name] -> Idris PTerm

52−mkPTerm f args = do i <- getIState

53− let fapp = mkApp (P Bound f Erased) (map eraseName args)

54− return $ delab i fapp

55− where eraseName (App f a) = App (eraseName f) (eraseName a)

56− eraseName (P _ (MN _ _) _) = Erased

57− eraseName t = t

58−

59−gm :: Name -> [TT Name] -> SC -> Idris ([PTerm], [PTerm])

60−gm fn args (Case n alts) = do m <- mapM (gmAlt fn args n) alts

61− let (got, missing) = unzip m

62− return (concat got, concat missing)

63−gm fn args (STerm tm) = do logLvl 3 ("Covered: " ++ show args)

64− t <- mkPTerm fn args

65− return ([t], [])

66−gm fn args ImpossibleCase = do logLvl 3 ("Impossible: " ++ show args)

67− t <- mkPTerm fn args

68− return ([], [])

69−gm fn args (UnmatchedCase _) = do logLvl 3 ("Missing: " ++ show args)

70− t <- mkPTerm fn args

71− return ([], [t])

72−

73−gmAlt fn args n (ConCase cn t cargs sc)

74− = do let args' = map (subst n (mkApp (P Bound cn Erased)

75− (map (\x -> P Bound x Erased) cargs)))

76− args

77− gm fn args' sc

78−gmAlt fn args n (ConstCase c sc)

79− = do let args' = map (subst n (Constant c)) args

80− gm fn args' sc

81−gmAlt fn args n (DefaultCase sc)

82− = do gm fn args sc

83−

84−getDefault (DefaultCase sc : _) = sc

85−getDefault (_ : cs) = getDefault cs

86−getDefault [] = UnmatchedCase ""

87−

88−dropDefault (DefaultCase sc : rest) = dropDefault rest

89−dropDefault (c : cs) = c : dropDefault cs

90−dropDefault [] = []

91−

92−expandTree :: SC -> Idris SC

93−expandTree (Case n alts) = do i <- getIState

94− as <- expandAlts i (dropDefault alts)

95− (getDefault alts)

96− alts' <- mapM expandTreeA as

97− return (Case n alts')

98− where expandTreeA (ConCase n i ns sc) = do sc' <- expandTree sc

99− return (ConCase n i ns sc')

100− expandTreeA (ConstCase i sc) = do sc' <- expandTree sc

101− return (ConstCase i sc')

102− expandTreeA (DefaultCase sc) = do sc' <- expandTree sc

103− return (DefaultCase sc')

104−expandTree t = return t

105−

106−expandAlts :: IState -> [CaseAlt] -> SC -> Idris [CaseAlt]

107−expandAlts i all@(ConstCase c _ : alts) def

108− = return $ all ++ [DefaultCase def]

109−expandAlts i all@(ConCase n _ _ _ : alts) def

110− | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef Nothing n (tt_ctxt i)

111− = do let tyn = getTy n (tt_ctxt i)

112− case lookupCtxt Nothing tyn (idris_datatypes i) of

113− (TI ns _ _: _) -> do let ps = map mkPat ns

114− return $ addAlts ps (altsFor all) all

115− _ -> return all

116− where

117− altsFor [] = []

118− altsFor (ConCase n _ _ _ : alts) = n : altsFor alts

119− altsFor (_ : alts) = altsFor alts

120−

121− addAlts [] got alts = alts

122− addAlts ((n, arity) : ps) got alts

123− | n `elem` got = addAlts ps got alts

124− | otherwise = addAlts ps got (alts ++

125− [ConCase n (-1) (argList arity) def])

126−

127− argList i = take i (map (\x -> (MN x "ign")) [0..])

128−

129− getTy n ctxt

130− = case lookupTy Nothing n ctxt of

131− (t : _) -> case unApply (getRetTy t) of

132− (P _ tyn _, _) -> tyn

133− x -> error $ "Can't happen getTy 1 " ++ show (n, x)

134− _ -> error "Can't happen getTy 2"

135−

136− mkPat x = case lookupCtxt Nothing x (idris_implicits i) of

137− (pargs : _)

138− -> (x, length pargs)

139− _ -> error "Can't happen - genAll"

140−expandAlts i alts def = return alts

141−

142−

143−

144−-- OLD STUFF: probably broken...

145−

14636-- Given a list of LHSs, generate a extra clauses which cover the remaining

14737-- cases. The ones which haven't been provided are marked 'absurd' so that the

14838-- checker will make sure they can't happen.

@@ -160,7 +50,7 @@ genClauses fc n xs given

16050 logLvl 10 $ show argss ++ "\n" ++ show all_args

16151 logLvl 10 $ "Original: \n" ++

16252 showSep "\n" (map (\t -> showImp True (delab' i t True)) xs)

163− let parg = case lookupCtxt Nothing n (idris_implicits i) of

53+ let parg = case lookupCtxt n (idris_implicits i) of

16454 (p : _) -> p

16555 _ -> repeat (pexp Placeholder)

16656 let tryclauses = mkClauses parg all_args

@@ -217,8 +107,8 @@ genAll i args = case filter (/=Placeholder) $ concatMap otherPats (nub args) of

217107 [] -> [Placeholder]

218108 xs -> nub xs

219109 where

220− conForm (PApp _ (PRef fc n) _) = isConName Nothing n (tt_ctxt i)

221− conForm (PRef fc n) = isConName Nothing n (tt_ctxt i)

110+ conForm (PApp _ (PRef fc n) _) = isConName n (tt_ctxt i)

111+ conForm (PRef fc n) = isConName n (tt_ctxt i)

222112 conForm _ = False

223113

224114 otherPats :: PTerm -> [PTerm]

@@ -227,22 +117,22 @@ genAll i args = case filter (/=Placeholder) $ concatMap otherPats (nub args) of

227117 otherPats arg = return Placeholder

228118

229119 ops fc n xs o

230− | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef Nothing n (tt_ctxt i)

120+ | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i)

231121 = do xs' <- mapM otherPats (map getTm xs)

232122 let p = PApp fc (PRef fc n) (zipWith upd xs' xs)

233123 let tyn = getTy n (tt_ctxt i)

234− case lookupCtxt Nothing tyn (idris_datatypes i) of

124+ case lookupCtxt tyn (idris_datatypes i) of

235125 (TI ns _ _ : _) -> p : map (mkPat fc) (ns \\ [n])

236126 _ -> [p]

237127 ops fc n arg o = return Placeholder

238128

239− getTy n ctxt = case lookupTy Nothing n ctxt of

129+ getTy n ctxt = case lookupTy n ctxt of

240130 (t : _) -> case unApply (getRetTy t) of

241131 (P _ tyn _, _) -> tyn

242132 x -> error $ "Can't happen getTy 1 " ++ show (n, x)

243133 _ -> error "Can't happen getTy 2"

244134

245− mkPat fc x = case lookupCtxt Nothing x (idris_implicits i) of

135+ mkPat fc x = case lookupCtxt x (idris_implicits i) of

246136 (pargs : _)

247137 -> PApp fc (PRef fc x) (map (upd Placeholder) pargs)

248138 _ -> error "Can't happen - genAll"

@@ -272,50 +162,62 @@ checkPositive n (cn, ty)

272162 = n /= n' && posArg sc

273163 posArg t = True

274164

275−-- Totality checking - check for structural recursion

276−-- (no mutual definitions yet)

277−

278−data LexOrder = LexXX | LexEQ | LexLT

279− deriving (Show, Eq, Ord)

280−

281165calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality

282−calcProd i fc n pats = do patsprod <- mapM prodRec pats

283− if (and patsprod)

284− then return Productive

285− else return (Partial NotProductive)

166+calcProd i fc topn pats

167+ = cp topn pats []

286168 where

287169 -- every application of n must be in an argument of a coinductive

288− -- constructor

289−

290− prodRec :: ([Name], Term, Term) -> Idris Bool

291− prodRec (_, _, tm) = prod False tm

292−

293− prod ok ap@(App _ _)

294− | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod ok arg

295− | (P _ f ty, args) <- unApply ap

296− = let co = cotype ty in

297− if f == n

298− then do argsprod <- mapM (prod co) args

299− return (and (ok : argsprod) )

300− else do argsprod <- mapM (prod co) args

301− return (and argsprod)

302− prod ok (App f a) = liftM2 (&&) (prod False f) (prod False a)

303− prod ok (Bind _ (Let t v) sc) = liftM2 (&&) (prod False v) (prod False v)

304− prod ok (Bind _ b sc) = prod ok sc

305− prod ok t = return True

306−

307− cotype ty

170+ -- constructor, in every function reachable from here in the

171+ -- call graph.

172+ cp n pats done = do patsprod <- mapM (prodRec n done) pats

173+ if (and patsprod)

174+ then return Productive

175+ else return (Partial NotProductive)

176+

177+ prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

178+ prodRec n done _ | n `elem` done = return True

179+ prodRec n done (_, _, tm) = prod n done False tm

180+

181+ prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

182+ prod n done ok ap@(App _ _)

183+ | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod n done ok arg

184+ | (P nt f _, args) <- unApply ap

185+ = do recOK <- checkProdRec (n:done) f

186+ let ctxt = tt_ctxt i

187+ let [ty] = lookupTy f ctxt -- must exist!

188+ let co = cotype nt f ty in

189+ if (not recOK) then return False else

190+ if f == topn

191+ then do argsprod <- mapM (prod n done co) args

192+ return (and (ok : argsprod) )

193+ else do argsprod <- mapM (prod n done co) args

194+ return (and argsprod)

195+ prod n done ok (App f a) = liftM2 (&&) (prod n done False f)

196+ (prod n done False a)

197+ prod n done ok (Bind _ (Let t v) sc)

198+ = liftM2 (&&) (prod n done False v) (prod n done False v)

199+ prod n done ok (Bind _ b sc) = prod n done ok sc

200+ prod n done ok t = return True

201+

202+ checkProdRec :: [Name] -> Name -> Idris Bool

203+ checkProdRec done f

204+ = case lookupCtxt f (idris_patdefs i) of

205+ [(def, _)] -> do ok <- mapM (prodRec f done) def

206+ return (and ok)

207+ _ -> return True -- defined elsewhere, can't call topn

208+

209+ cotype (DCon _ _) n ty

308210 | (P _ t _, _) <- unApply (getRetTy ty)

309− = case lookupCtxt Nothing t (idris_datatypes i) of

211+ = case lookupCtxt t (idris_datatypes i) of

310212 [TI _ True _] -> True

311213 _ -> False

312− | otherwise = False

214+ cotype nt n ty = False

313215

314216calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]

315217 -> Idris Totality

316218calcTotality path fc n pats

317219 = do i <- getIState

318− let opts = case lookupCtxt Nothing n (idris_flags i) of

220+ let opts = case lookupCtxt n (idris_flags i) of

319221 [fs] -> fs

320222 _ -> []

321223 case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of

@@ -339,12 +241,12 @@ checkTotality path fc n

339241 updateContext (simplifyCasedef n)

340242 ctxt <- getContext

341243 i <- getIState

342− let opts = case lookupCtxt Nothing n (idris_flags i) of

244+ let opts = case lookupCtxt n (idris_flags i) of

343245 [fs] -> fs

344246 _ -> []

345247 t' <- case t of

346248 Unchecked ->

347− case lookupDef Nothing n ctxt of

249+ case lookupDef n ctxt of

348250 [CaseOp _ _ _ _ pats _ _ _ _] ->

349251 do t' <- if AssertTotal `elem` opts

350252 then return $ Total []

@@ -378,7 +280,7 @@ checkTotality path fc n

378280

379281 warnPartial n t

380282 = do i <- getIState

381− case lookupDef Nothing n (tt_ctxt i) of

283+ case lookupDef n (tt_ctxt i) of

382284 [x] -> do

383285 iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t

384286-- ++ "\n" ++ show x

@@ -407,17 +309,87 @@ checkDeclTotality (fc, n)

407309buildSCG :: (FC, Name) -> Idris ()

408310buildSCG (_, n) = do

409311 ist <- getIState

410− case lookupCtxt Nothing n (idris_callgraph ist) of

411− [cg] -> case lookupDef Nothing n (tt_ctxt ist) of

412− [CaseOp _ _ _ _ _ args sc _ _] ->

413− do logLvl 3 $ "Building SCG for " ++ show n ++ " from\n"

414− ++ show sc

415− let newscg = buildSCG' ist sc args

312+ case lookupCtxt n (idris_callgraph ist) of

313+ [cg] -> case lookupDef n (tt_ctxt ist) of

314+ [CaseOp _ _ _ pats _ args sc _ _] ->

315+ do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n"

316+ ++ show pats ++ "\n" ++ show sc

317+ let newscg = buildSCG' ist (rights pats) args

416318 logLvl 5 $ show newscg

417319 addToCG n ( cg { scg = newscg } )

418320 [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

419321 x -> error $ "buildSCG: " ++ show (n, x)

420322

323+buildSCG' :: IState -> [(Term, Term)] -> [Name] -> [SCGEntry]

324+buildSCG' ist pats args = nub $ concatMap scgPat pats where

325+ scgPat (lhs, rhs) = let (f, pargs) = unApply (dePat lhs) in

326+ findCalls (dePat rhs) (patvars lhs) pargs

327+

328+ findCalls ap@(App f a) pvs pargs

329+ | (P _ (UN "lazy") _, [_, arg]) <- unApply ap

330+ = findCalls arg pvs pargs

331+ | (P _ n _, args) <- unApply ap

332+ = mkChange n args pargs ++

333+ concatMap (\x -> findCalls x pvs pargs) args

334+ findCalls (App f a) pvs pargs

335+ = findCalls f pvs pargs ++ findCalls a pvs pargs

336+ findCalls (Bind n (Let t v) e) pvs pargs

337+ = findCalls v pvs pargs ++ findCalls e (n : pvs) pargs

338+ findCalls (Bind n _ e) pvs pargs

339+ = findCalls e (n : pvs) pargs

340+ findCalls (P _ f _ ) pvs pargs

341+ | not (f `elem` pvs) = [(f, [])]

342+ findCalls _ _ _ = []

343+

344+ mkChange n args pargs = [(n, sizes args)]

345+ where

346+ sizes [] = []

347+ sizes (a : as) = checkSize a pargs 0 : sizes as

348+

349+ -- find which argument in pargs <a> is smaller than, if any

350+ checkSize a (p : ps) i

351+ | a == p = Just (i, Same)

352+ | smaller Nothing a (p, Nothing) = Just (i, Smaller)

353+ | otherwise = checkSize a ps (i + 1)

354+ checkSize a [] i = Nothing

355+

356+ -- the smaller thing we find must be the same type as <a>, and

357+ -- not be coinductive - so carry the type of the constructor we've

358+ -- gone under.

359+

360+ smaller (Just tyn) a (t, Just tyt)

361+ | a == t = isInductive (fst (unApply (getRetTy tyn)))

362+ (fst (unApply (getRetTy tyt)))

363+ smaller ty a (ap@(App f s), _)

364+ | (P (DCon _ _) n _, args) <- unApply ap

365+ = let tyn = getType n in

366+ any (smaller (ty `mplus` Just tyn) a)

367+ (zip args (map toJust (getArgTys tyn)))

368+ -- check higher order recursive arguments

369+ smaller ty (App f s) a = smaller ty f a

370+ smaller _ _ _ = False

371+

372+ toJust (n, t) = Just t

373+

374+ getType n = case lookupTy n (tt_ctxt ist) of

375+ [ty] -> ty -- must exist

376+

377+ isInductive (P _ nty _) (P _ nty' _) =

378+ let co = case lookupCtxt nty (idris_datatypes ist) of

379+ [TI _ x _] -> x

380+ _ -> False in

381+ nty == nty' && not co

382+ isInductive _ _ = False

383+

384+-- getTypeFam t | (P _ n _, _) <- unApply t

385+

386+ dePat (Bind x (PVar ty) sc) = dePat (instantiate (P Bound x ty) sc)

387+ dePat t = t

388+

389+ patvars (Bind x (PVar _) sc) = x : patvars sc

390+ patvars _ = []

391+

392+{-

421393buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]

422394buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

423395 nub $ scg sc (zip args args)

@@ -442,17 +414,22 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

442414 -- how the arguments relate - either Smaller or Unknown

443415 argRels :: Name -> [(Name, SizeChange)]

444416 argRels n = let ctxt = tt_ctxt ist

445− [ty] = lookupTy Nothing n ctxt -- must exist!

417+ [ty] = lookupTy n ctxt -- must exist!

446418 P _ nty _ = fst (unApply (getRetTy ty))

419+ co = case lookupCtxt nty (idris_datatypes ist) of

420+ [TI _ x _] -> x

421+ _ -> False

447422 args = map snd (getArgTys ty) in

448− map (getRel nty) (map (fst . unApply . getRetTy) args)

423+ map (getRel co nty) (map (fst . unApply . getRetTy) args)

449424 where

450− getRel ty (P _ n' _) | n' == ty = (n, Smaller)

451− getRel ty t = (n, Unknown)

425+ getRel True _ _ = (n, Unknown) -- coinductive

426+ getRel _ ty (P _ n' _) | n' == ty = (n, Smaller)

427+ getRel _ ty t = (n, Unknown)

452428

453429 scgAlt x vars szs (ConCase n _ args sc)

454430 -- all args smaller than top variable of x in sc

455− -- (as long as they are in the same type family)

431+ -- (as long as they are in the same type family, and it's

432+ -- not coinductive)

456433 | Just tvar <- lookup x vars

457434 = let arel = argRels n

458435 szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel

@@ -499,11 +476,12 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

499476 getArgPos i n [] = Nothing

500477 getArgPos i n (x : xs) | n == x = Just i

501478 | otherwise = getArgPos (i + 1) n xs

479+-}

502480

503481checkSizeChange :: Name -> Idris Totality

504482checkSizeChange n = do

505483 ist <- getIState

506− case lookupCtxt Nothing n (idris_callgraph ist) of

484+ case lookupCtxt n (idris_callgraph ist) of

507485 [cg] -> do let ms = mkMultiPaths ist [] (scg cg)

508486 logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++

509487 "from " ++ show (scg cg) ++ "\n" ++

@@ -530,7 +508,7 @@ mkMultiPaths ist path cg

530508 where extend (nextf, args)

531509 | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ]

532510 | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)

533− = case lookupCtxt Nothing nextf (idris_callgraph ist) of

511+ = case lookupCtxt nextf (idris_callgraph ist) of

534512 [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

535513 _ -> [ reverse ((nextf, args) : path) ]

536514 | otherwise = [ reverse ((nextf, args) : path) ]

@@ -538,7 +516,7 @@ mkMultiPaths ist path cg

538516-- do (nextf, args) <- cg

539517-- if ((nextf, args) `elem` path)

540518-- then return (reverse ((nextf, args) : path))

541−-- else case lookupCtxt Nothing nextf (idris_callgraph ist) of

519+-- else case lookupCtxt nextf (idris_callgraph ist) of

542520-- [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

543521-- _ -> return (reverse ((nextf, args) : path))

544522

@@ -562,12 +540,12 @@ checkMP ist i mp = if i > 0

562540-- = Partial BelieveMe

563541 -- if we get to a constructor, it's fine as long as it's strictly positive

564542 tryPath desc path ((f, _) :es) arg

565− | [TyDecl (DCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)

543+ | [TyDecl (DCon _ _) _] <- lookupDef f (tt_ctxt ist)

566544 = case lookupTotal f (tt_ctxt ist) of

567545 [Total _] -> Unchecked -- okay so far

568546 [Partial _] -> Partial (Other [f])

569547 x -> error (show x)

570− | [TyDecl (TCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)

548+ | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)

571549 = Total []

572550 tryPath desc path (e@(f, args) : es) arg

573551 | e `elem` es && allNothing args = Partial (Mutual [f])

src/Idris/DataOpts.hs+10−10

@@ -17,7 +17,7 @@ import Debug.Trace

1717forceArgs :: Name -> Type -> Idris ()

1818forceArgs n t = do i <- getIState

1919 let fargs = force i 0 t

20− copt <- case lookupCtxt Nothing n (idris_optimisation i) of

20+ copt <- case lookupCtxt n (idris_optimisation i) of

2121 [] -> return $ Optimise False [] []

2222 (op:_) -> return op

2323 let opts = addDef n (copt { forceable = fargs }) (idris_optimisation i)

@@ -38,7 +38,7 @@ forceArgs n t = do i <- getIState

3838

3939 collapsibleIn i t

4040 | (P _ tn _, _) <- unApply t

41− = case lookupCtxt Nothing tn (idris_optimisation i) of

41+ = case lookupCtxt tn (idris_optimisation i) of

4242 [oi] -> collapsible oi

4343 _ -> False

4444 | otherwise = False

@@ -68,7 +68,7 @@ collapseCons ty cons =

6868 setCollapsible n

6969 = do i <- getIState

7070 iLOG $ show n ++ " collapsible"

71− case lookupCtxt Nothing n (idris_optimisation i) of

71+ case lookupCtxt n (idris_optimisation i) of

7272 (oi:_) -> do let oi' = oi { collapsible = True }

7373 let opts = addDef n oi' (idris_optimisation i)

7474 putIState (i { idris_optimisation = opts })

@@ -79,15 +79,15 @@ collapseCons ty cons =

7979

8080 forceRec :: IState -> (Name, [Type]) -> Idris Bool

8181 forceRec i (n, ts)

82− = case lookupCtxt Nothing n (idris_optimisation i) of

82+ = case lookupCtxt n (idris_optimisation i) of

8383 (oi:_) -> checkFR (forceable oi) 0 ts

8484 _ -> return False

8585 checkFR fs i [] = return True

8686 checkFR fs i (_ : xs) | i `elem` fs = checkFR fs (i + 1) xs

8787 checkFR fs i (t : xs)

8888 -- must be recursive or type is not collapsible

89− = do let rt = getRetTy t

90− if (ty `elem` freeNames rt)

89+ = do let (rtf, rta) = unApply $ getRetTy t

90+ if (ty `elem` freeNames rtf)

9191 then checkFR fs (i+1) xs

9292 else return False

9393

@@ -161,7 +161,7 @@ instance Optimisable Raw where

161161 | (Var n, args) <- raw_unapply t -- MAGIC HERE

162162 = do args' <- mapM applyOpts args

163163 i <- getIState

164− case lookupCtxt Nothing n (idris_optimisation i) of

164+ case lookupCtxt n (idris_optimisation i) of

165165 (oi:_) -> return $ applyDataOpt oi n args'

166166 _ -> return (raw_apply (Var n) args')

167167 | otherwise = do f' <- applyOpts f

@@ -202,14 +202,14 @@ applyDataOpt oi n args

202202instance Optimisable (TT Name) where

203203 applyOpts c@(P (DCon t arity) n _)

204204 = do i <- getIState

205− case lookupCtxt Nothing n (idris_optimisation i) of

205+ case lookupCtxt n (idris_optimisation i) of

206206 (oi:_) -> return $ applyDataOptRT oi n t arity []

207207 _ -> return c

208208 applyOpts t@(App f a)

209209 | (c@(P (DCon t arity) n _), args) <- unApply t -- MAGIC HERE

210210 = do args' <- mapM applyOpts args

211211 i <- getIState

212− case lookupCtxt Nothing n (idris_optimisation i) of

212+ case lookupCtxt n (idris_optimisation i) of

213213 (oi:_) -> do return $ applyDataOptRT oi n t arity args'

214214 _ -> return (mkApp c args')

215215 | otherwise = do f' <- applyOpts f

@@ -224,7 +224,7 @@ instance Optimisable (TT Name) where

224224

225225 stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x

226226 = do i <- getIState

227− case lookupCtxt Nothing ty (idris_optimisation i) of

227+ case lookupCtxt ty (idris_optimisation i) of

228228 [oi] -> if collapsible oi

229229 then do t' <- stripCollapsed t

230230 return (Bind n (PVar x) (instantiate Erased t'))

src/Idris/Delaborate.hs+64−34

@@ -7,6 +7,7 @@ module Idris.Delaborate where

77

88import Idris.AbsSyntax

99import Core.TT

10+import Core.Evaluate

1011

1112import Debug.Trace

1213

@@ -15,54 +16,75 @@ bugaddr = "https://github.com/edwinb/Idris-dev/issues"

1516delab :: IState -> Term -> PTerm

1617delab i tm = delab' i tm False

1718

19+delabTy :: IState -> Name -> PTerm

20+delabTy i n

21+ = case lookupTy n (tt_ctxt i) of

22+ (ty:_) -> case lookupCtxt n (idris_implicits i) of

23+ (imps:_) -> delabTy' i imps ty False

24+ _ -> delabTy' i [] ty False

25+

1826delab' :: IState -> Term -> Bool -> PTerm

19−delab' ist tm fullname = de [] tm

27+delab' i t f = delabTy' i [] t f

28+

29+delabTy' :: IState -> [PArg] -- ^ implicit arguments to type, if any

30+ -> Term -> Bool -> PTerm

31+delabTy' ist imps tm fullname = de [] imps tm

2032 where

2133 un = FC "(val)" 0

2234

23− de env (App f a) = deFn env f [a]

24− de env (V i) | i < length env = PRef un (snd (env!!i))

25− | otherwise = PRef un (UN ("v" ++ show i ++ ""))

26− de env (P _ n _) | n == unitTy = PTrue un

27− | n == unitCon = PTrue un

28− | n == falseTy = PFalse un

29− | Just n' <- lookup n env = PRef un n'

30− | otherwise = PRef un (dens n)

31− de env (Bind n (Lam ty) sc) = PLam n (de env ty) (de ((n,n):env) sc)

32− de env (Bind n (Pi ty) sc) = PPi expl n (de env ty) (de ((n,n):env) sc)

33− de env (Bind n (Let ty val) sc)

34− = PLet n (de env ty) (de env val) (de ((n,n):env) sc)

35− de env (Bind n (Hole ty) sc) = de ((n, UN "[__]"):env) sc

36− de env (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) sc

37− de env (Bind n _ sc) = de ((n,n):env) sc

38− de env (Constant i) = PConstant i

39− de env Erased = Placeholder

40− de env Impossible = Placeholder

41− de env (TType i) = PType

35+ de env _ (App f a) = deFn env f [a]

36+ de env _ (V i) | i < length env = PRef un (snd (env!!i))

37+ | otherwise = PRef un (UN ("v" ++ show i ++ ""))

38+ de env _ (P _ n _) | n == unitTy = PTrue un

39+ | n == unitCon = PTrue un

40+ | n == falseTy = PFalse un

41+ | Just n' <- lookup n env = PRef un n'

42+ | otherwise = PRef un (dens n)

43+ de env _ (Bind n (Lam ty) sc)

44+ = PLam n (de env [] ty) (de ((n,n):env) [] sc)

45+ de env (PImp _ _ _ _ _:is) (Bind n (Pi ty) sc)

46+ = PPi impl n (de env [] ty) (de ((n,n):env) is sc)

47+ de env (PConstraint _ _ _ _:is) (Bind n (Pi ty) sc)

48+ = PPi constraint n (de env [] ty) (de ((n,n):env) is sc)

49+ de env (PTacImplicit _ _ _ tac _ _:is) (Bind n (Pi ty) sc)

50+ = PPi (tacimpl tac) n (de env [] ty) (de ((n,n):env) is sc)

51+ de env _ (Bind n (Pi ty) sc)

52+ = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

53+ de env _ (Bind n (Let ty val) sc)

54+ = PLet n (de env [] ty) (de env [] val) (de ((n,n):env) [] sc)

55+ de env _ (Bind n (Hole ty) sc) = de ((n, UN "[__]"):env) [] sc

56+ de env _ (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) [] sc

57+ de env _ (Bind n _ sc) = de ((n,n):env) [] sc

58+ de env _ (Constant i) = PConstant i

59+ de env _ Erased = Placeholder

60+ de env _ Impossible = Placeholder

61+ de env _ (TType i) = PType

4262

4363 dens x | fullname = x

44− dens ns@(NS n _) = case lookupCtxt Nothing n (idris_implicits ist) of

64+ dens ns@(NS n _) = case lookupCtxt n (idris_implicits ist) of

4565 [_] -> n -- just one thing

4666 _ -> ns

4767 dens n = n

4868

4969 deFn env (App f a) args = deFn env f (a:args)

50− deFn env (P _ n _) [l,r] | n == pairTy = PPair un (de env l) (de env r)

51− | n == eqCon = PRefl un (de env r)

52− | n == UN "lazy" = de env r

70+ deFn env (P _ n _) [l,r]

71+ | n == pairTy = PPair un (de env [] l) (de env [] r)

72+ | n == eqCon = PRefl un (de env [] r)

73+ | n == UN "lazy" = de env [] r

5374 deFn env (P _ n _) [ty, Bind x (Lam _) r]

54− | n == UN "Exists"

55− = PDPair un (PRef un x) (de env ty)

56− (de ((x,x):env) (instantiate (P Bound x ty) r))

57− deFn env (P _ n _) [_,_,l,r] | n == pairCon = PPair un (de env l) (de env r)

58− | n == eqTy = PEq un (de env l) (de env r)

59− | n == UN "Ex_intro" = PDPair un (de env l) Placeholder

60− (de env r)

61− deFn env (P _ n _) args = mkPApp (dens n) (map (de env) args)

62− deFn env f args = PApp un (de env f) (map pexp (map (de env) args))

75+ | n == UN "Exists"

76+ = PDPair un (PRef un x) (de env [] ty)

77+ (de ((x,x):env) [] (instantiate (P Bound x ty) r))

78+ deFn env (P _ n _) [_,_,l,r]

79+ | n == pairCon = PPair un (de env [] l) (de env [] r)

80+ | n == eqTy = PEq un (de env [] l) (de env [] r)

81+ | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder

82+ (de env [] r)

83+ deFn env (P _ n _) args = mkPApp (dens n) (map (de env []) args)

84+ deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args))

6385

6486 mkPApp n args

65− | [imps] <- lookupCtxt Nothing n (idris_implicits ist)

87+ | [imps] <- lookupCtxt n (idris_implicits ist)

6688 = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)

6789 | otherwise = PApp un (PRef un n) (map pexp args)

6890

@@ -90,6 +112,13 @@ pshow i (CantConvert x y env)

90112 "Can't convert " ++ showImp imps (delab i x) ++ " with "

91113 ++ showImp imps (delab i y) ++

92114 if (opt_errContext (idris_options i)) then showSc i env else ""

115+pshow i (NonFunctionType f ty)

116+ = let imps = opt_showimp (idris_options i) in

117+ showImp imps (delab i f) ++ " does not have a function type ("

118+ ++ showImp imps (delab i ty) ++ ")"

119+pshow i (CantIntroduce ty)

120+ = let imps = opt_showimp (idris_options i) in

121+ "Can't use lambda here: type is " ++ showImp imps (delab i ty)

93122pshow i (InfiniteUnify x tm env)

94123 = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++

95124 " would lead to infinite value" ++

@@ -111,6 +140,7 @@ pshow i (AlreadyDefined n) = show n ++ " is already defined"

111140pshow i (ProofSearchFail e) = pshow i e

112141pshow i (NoRewriting tm) = "rewrite did not change type " ++ show (delab i tm)

113142pshow i (At f e) = show f ++ ":" ++ pshow i e

143+pshow i (ProviderError msg) = "Type provider error: " ++ msg

114144

115145showSc i [] = ""

116146showSc i xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs))

src/Idris/Docs.hs+6−6

@@ -65,9 +65,9 @@ instance Show Doc where

6565getDocs :: Name -> Idris Doc

6666getDocs n

6767 = do i <- getIState

68− case lookupCtxt Nothing n (idris_classes i) of

68+ case lookupCtxt n (idris_classes i) of

6969 [ci] -> docClass n ci

70− _ -> case lookupCtxt Nothing n (idris_datatypes i) of

70+ _ -> case lookupCtxt n (idris_datatypes i) of

7171 [ti] -> docData n ti

7272 _ -> do fd <- docFun n

7373 return (FunDoc fd)

@@ -81,7 +81,7 @@ docData n ti

8181docClass :: Name -> ClassInfo -> Idris Doc

8282docClass n ci

8383 = do i <- getIState

84− let docstr = case lookupCtxt Nothing n (idris_docstrings i) of

84+ let docstr = case lookupCtxt n (idris_docstrings i) of

8585 [str] -> str

8686 _ -> ""

8787 mdocs <- mapM docFun (map fst (class_methods ci))

@@ -90,13 +90,13 @@ docClass n ci

9090docFun :: Name -> Idris FunDoc

9191docFun n

9292 = do i <- getIState

93− let docstr = case lookupCtxt Nothing n (idris_docstrings i) of

93+ let docstr = case lookupCtxt n (idris_docstrings i) of

9494 [str] -> str

9595 _ -> ""

96− let ty = case lookupTy Nothing n (tt_ctxt i) of

96+ let ty = case lookupTy n (tt_ctxt i) of

9797 (t : _) -> t

9898 let argnames = map fst (getArgTys ty)

99− let args = case lookupCtxt Nothing n (idris_implicits i) of

99+ let args = case lookupCtxt n (idris_implicits i) of

100100 [args] -> zip argnames args

101101 _ -> []

102102 let infixes = idris_infixes i

src/Idris/ElabDecls.hs+141−75

@@ -49,6 +49,7 @@ elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in

4949 ctxt <- getContext

5050 i <- getIState

5151 logLvl 3 $ show n ++ " pre-type " ++ showImp True ty'

52+ ty' <- addUsingConstraints syn fc ty'

5253 ty' <- implicit syn n ty'

5354 let ty = addImpl i ty'

5455 logLvl 2 $ show n ++ " type " ++ showImp True ty

@@ -69,7 +70,7 @@ elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in

6970 let nty' = normalise ctxt [] nty

7071 let (t, _) = unApply (getRetTy nty')

7172 let corec = case t of

72− P _ rcty _ -> case lookupCtxt Nothing rcty (idris_datatypes i) of

73+ P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of

7374 [TI _ True _] -> True

7475 _ -> False

7576 _ -> False

@@ -93,14 +94,14 @@ elabPostulate info syn doc fc opts n ty

9394 -- make sure it's collapsible, so it is never needed at run time

9495 -- start by getting the elaborated type

9596 ctxt <- getContext

96− fty <- case lookupTy Nothing n ctxt of

97+ fty <- case lookupTy n ctxt of

9798 [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen!

9899 [ty] -> return ty

99100 ist <- getIState

100101 let (ap, _) = unApply (getRetTy (normalise ctxt [] fty))

101102 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

102103 let postOK = case ap of

103− P _ tn _ -> case lookupCtxt Nothing tn

104+ P _ tn _ -> case lookupCtxt tn

104105 (idris_optimisation ist) of

105106 [oi] -> collapsible oi

106107 _ -> False

@@ -121,11 +122,11 @@ elabData info syn doc fc codata (PLaterdecl n t_in)

121122 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

122123 (erun fc (build i info False n t))

123124 def' <- checkDef fc defer

124− addDeferred def'

125+ addDeferredTyCon def'

125126 mapM_ (elabCaseBlock info) is

126127 (cty, _) <- recheckC fc [] t'

127128 logLvl 2 $ "---> " ++ show cty

128− updateContext (addTyDecl n cty) -- temporary, to check cons

129+ updateContext (addTyDecl n (TCon 0 0) cty) -- temporary, to check cons

129130

130131elabData info syn doc fc codata (PDatadecl n t_in dcons)

131132 = do iLOG (show fc)

@@ -137,17 +138,17 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

137138 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

138139 (erun fc (build i info False n t))

139140 def' <- checkDef fc defer

140− addDeferred def'

141+ addDeferredTyCon def'

141142 mapM_ (elabCaseBlock info) is

142143 (cty, _) <- recheckC fc [] t'

143144 logLvl 2 $ "---> " ++ show cty

144145 -- temporary, to check cons

145− when undef $ updateContext (addTyDecl n cty)

146+ when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

146147 cons <- mapM (elabCon info syn n codata) dcons

147148 ttag <- getName

148149 i <- getIState

149150 let as = map (const Nothing) (getArgTys cty)

150− let params = findParams (zip as (repeat True)) (map snd cons)

151+ let params = findParams (map snd cons)

151152 logLvl 2 $ "Parameters : " ++ show params

152153 putIState (i { idris_datatypes = addDef n (TI (map fst cons) codata params)

153154 (idris_datatypes i) })

@@ -161,55 +162,102 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

161162 where

162163 -- parameters are names which are unchanged across the structure,

163164 -- which appear exactly once in the return type of a constructor

164− findParams :: [(Maybe Name, Bool)] -> [Type] -> [Int]

165− findParams ps [] = mapMaybe (\ ((x, y), n) ->

166− if y then Just n else Nothing)

167− (zip ps [0..])

168− findParams ps (t : ts) = findParams (updateParams ps t) ts

169−

170− updateParams ps (Bind n (Pi t) sc)

171− = updateParams (updateParams ps (instantiate (P Bound n t) sc)) t

172− updateParams ps tm@(App f a)

173− | (P _ fn _, args) <- unApply tm

174− = if fn == n

175− then updateParamsA ps args (tail args)

176− else updateParams (updateParams ps f) a

177− | otherwise = updateParams (updateParams ps f) a

178− updateParams ps _ = ps

179−

180− updateParamsA ((mn, _) : ns) (p@(P _ n' _) : args) all

181− | n' `elem` concatMap freeNames all

182− = (mn, False) : updateParamsA ns args (p : all)

183− updateParamsA ((Nothing, b) : ns) (p@(P _ n' _) : args) all

184− = (Just n', b) : updateParamsA ns args (p : all)

185− updateParamsA ((Just p, b) : ns) (tm@(P _ n' _) : args) all

186− = (Just n', b && p == n') : updateParamsA ns args (tm : all)

187− updateParamsA ((mn, _) : ns) (p : args) all

188− = (mn, False) : updateParamsA ns args (p : all)

189− updateParamsA ps args all = ps

165+

166+ -- First, find all applications of the constructor, then check over

167+ -- them for repeated arguments

168+

169+ findParams :: [Type] -> [Int]

170+ findParams ts = let allapps = concatMap getDataApp ts in

171+ paramPos allapps

172+

173+ paramPos [] = []

174+ paramPos (args : rest)

175+ = dropNothing $ keepSame (zip [0..] args) rest

176+

177+ dropNothing [] = []

178+ dropNothing ((x, Nothing) : ts) = dropNothing ts

179+ dropNothing ((x, _) : ts) = x : dropNothing ts

180+

181+ keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] ->

182+ [(Int, Maybe Name)]

183+ keepSame as [] = as

184+ keepSame as (args : rest) = keepSame (update as args) rest

185+ where

186+ update [] _ = []

187+ update _ [] = []

188+ update ((n, Just x) : as) (Just x' : args)

189+ | x == x' = (n, Just x) : update as args

190+ update ((n, _) : as) (_ : args) = (n, Nothing) : update as args

191+

192+ getDataApp :: Type -> [[Maybe Name]]

193+ getDataApp f@(App _ _)

194+ | (P _ d _, args) <- unApply f

195+ = if (d == n) then [mParam args args] else []

196+ getDataApp (Bind n (Pi t) sc)

197+ = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc)

198+ getDataApp _ = []

199+

200+ -- keep the arguments which are single names, which don't appear

201+ -- elsewhere

202+

203+ mParam args [] = []

204+ mParam args (P Bound n _ : rest)

205+ | count n args == 1

206+ = Just n : mParam args rest

207+ where count n [] = 0

208+ count n (t : ts)

209+ | n `elem` freeNames t = 1 + count n ts

210+ | otherwise = count n ts

211+ mParam args (_ : rest) = Nothing : mParam args rest

190212

191213-- | Elaborate a type provider

192214elabProvider :: ElabInfo -> SyntaxInfo -> FC -> Name -> PTerm -> PTerm -> Idris ()

193215elabProvider info syn fc n ty tm

194216 = do i <- getIState

195− if not (TypeProviders `elem` idris_language_extensions i)

196− then fail $ "Failed to define type provider \"" ++ show n ++

197− "\".\nYou must turn on TypeProviders extension."

198− else do let expected = providerTy fc ty

199− let using = unProv fc tm

200− logLvl 1 $ "** Providing " ++

201− show n ++ " : " ++ show expected ++

202− " as " ++ show using

203− (e', et) <- elabVal toplevel False using

204− ctxt <- getContext

205− let e'' = normaliseAll ctxt [] e'

206− logLvl 1 $ "Term is " ++ show e''

207− let et' = normaliseAll ctxt [] et

208− elabType info syn "" fc [] n ty

209− rhs <- execute e''

210− elabClauses info fc [] n [PClause fc n (PRef fc $ n) [] (delab i rhs) []]

211− logLvl 1 $ "** Elaborated: " ++ show e' ++ " :as: " ++ show et

212− logLvl 1 $ "** Evaluated: " ++ show rhs ++ " :as: " ++ show et'

217+ -- Ensure that the experimental extension is enabled

218+ unless (TypeProviders `elem` idris_language_extensions i) $

219+ fail $ "Failed to define type provider \"" ++ show n ++

220+ "\".\nYou must turn on the TypeProviders extension."

221+

222+ ctxt <- getContext

223+

224+ -- First elaborate the expected type (and check that it's a type)

225+ (ty', typ) <- elabVal toplevel False ty

226+ unless (isTType typ) $

227+ fail ("Expected a type, got " ++ show ty' ++ " : " ++ show typ)

228+

229+ -- Elaborate the provider term to TT and check that the type matches

230+ (e, et) <- elabVal toplevel False tm

231+ unless (isProviderOf ty' et) $

232+ fail $ "Expected provider type IO (Provider (" ++

233+ show ty' ++ "))" ++ ", got " ++ show et ++ " instead."

234+

235+ -- Create the top-level type declaration

236+ elabType info syn "" fc [] n ty

237+

238+ -- Execute the type provider and normalise the result

239+ rhs <- execute e

240+ let rhs' = normalise ctxt [] rhs

241+ logLvl 1 $ "Normalised " ++ show n ++ "'s RHS to " ++ show rhs

242+

243+ -- Extract the provided term from the type provider

244+ tm <- getProvided rhs'

245+

246+ -- Finally add a top-level definition of the provided term

247+ elabClauses info fc [] n [PClause fc n (PRef fc n) [] (delab i tm) []]

248+ logLvl 1 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

249+

250+ where isTType :: TT Name -> Bool

251+ isTType (TType _) = True

252+ isTType _ = False

253+

254+ isProviderOf :: TT Name -> TT Name -> Bool

255+ isProviderOf tp prov

256+ | (P _ (UN "IO") _, [prov']) <- unApply prov

257+ , (P _ (NS (UN "Provider") ["Providers"]) _, [tp']) <- unApply prov'

258+ , tp == tp' = True

259+ isProviderOf _ _ = False

260+

213261

214262elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

215263 PTerm -> String -> Name -> PTerm -> Idris ()

@@ -217,10 +265,10 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

217265 = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)])

218266 cty' <- implicit syn cn cty

219267 i <- getIState

220− cty <- case lookupTy Nothing cn (tt_ctxt i) of

268+ cty <- case lookupTy cn (tt_ctxt i) of

221269 [t] -> return (delab i t)

222270 _ -> fail "Something went inexplicably wrong"

223− cimp <- case lookupCtxt Nothing cn (idris_implicits i) of

271+ cimp <- case lookupCtxt cn (idris_implicits i) of

224272 [imps] -> return imps

225273 let ptys = getProjs [] (renameBs cimp cty)

226274 let ptys_u = getProjs [] cty

@@ -361,7 +409,7 @@ elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

361409elabClauses info fc opts n_in cs = let n = liftname info n_in in

362410 do ctxt <- getContext

363411 -- Check n actually exists, with no definition yet

364− let tys = lookupTy Nothing n ctxt

412+ let tys = lookupTy n ctxt

365413 checkUndefined n ctxt

366414 unless (length tys > 1) $ do

367415 fty <- case tys of

@@ -378,7 +426,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

378426 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

379427 -- FIXME: Really ought to only do this for total functions!

380428 let doNothing = case ap of

381− P _ tn _ -> case lookupCtxt Nothing tn

429+ P _ tn _ -> case lookupCtxt tn

382430 (idris_optimisation ist) of

383431 [oi] -> collapsible oi

384432 _ -> False

@@ -386,7 +434,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

386434 solveDeferred n

387435 ist <- getIState

388436 when doNothing $

389− case lookupCtxt Nothing n (idris_optimisation ist) of

437+ case lookupCtxt n (idris_optimisation ist) of

390438 [oi] -> do let opts = addDef n (oi { collapsible = True })

391439 (idris_optimisation ist)

392440 putIState (ist { idris_optimisation = opts })

@@ -410,6 +458,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

410458 else stripCollapsed pats

411459

412460 logLvl 5 $ "Patterns:\n" ++ show pats

461+ logLvl 3 $ "SIMPLIFIED: \n" ++ show pdef

413462

414463 let optpdef = map debind $ map (simpl True (tt_ctxt ist)) optpats

415464 tree@(CaseDef scargs sc _) <- tclift $

@@ -420,14 +469,21 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

420469 then do missing <- genClauses fc n (map getLHS pdef) cs

421470 -- missing <- genMissing n scargs sc

422471 missing' <- filterM (checkPossible info fc True n) missing

472+ let clhs = map getLHS pdef

423473 logLvl 2 $ "Must be unreachable:\n" ++

424474 showSep "\n" (map (showImp True) missing') ++

425475 "\nAgainst: " ++

426476 showSep "\n" (map (\t -> showImp True (delab ist t)) (map getLHS pdef))

427− return missing'

477+ -- filter out anything in missing' which is

478+ -- matched by any of clhs. This might happen since

479+ -- unification may force a variable to take a

480+ -- particular form, rather than force a case

481+ -- to be impossible.

482+ return (filter (noMatch ist clhs) missing')

428483 else return []

429484 let pcover = null pmissing

430485 logLvl 2 $ "Optimising patterns"

486+ logLvl 5 $ show optpdef

431487 pdef' <- applyOpts optpdef

432488 logLvl 2 $ "Optimised patterns"

433489 logLvl 5 $ show pdef'

@@ -456,8 +512,9 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

456512 logLvl 3 $ "Optimised: " ++ show tree'

457513 ctxt <- getContext

458514 ist <- getIState

459− putIState (ist { idris_patdefs = addDef n pdef' (idris_patdefs ist) })

460− case lookupTy (namespace info) n ctxt of

515+ putIState (ist { idris_patdefs = addDef n (pdef', pmissing)

516+ (idris_patdefs ist) })

517+ case lookupTy n ctxt of

461518 [ty] -> do updateContext (addCasedef n (inlinable opts)

462519 tcase knowncovering

463520 (AssertTotal `elem` opts)

@@ -468,7 +525,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

468525 totcheck (fc, n)

469526 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

470527 i <- getIState

471− case lookupDef Nothing n (tt_ctxt i) of

528+ case lookupDef n (tt_ctxt i) of

472529 (CaseOp _ _ _ _ _ scargs sc scargs' sc' : _) ->

473530 do let calls = findCalls sc' scargs'

474531 let used = findUsedArgs sc' scargs'

@@ -484,7 +541,11 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

484541 [] -> return ()

485542 return ()

486543 where

487− checkUndefined n ctxt = case lookupDef Nothing n ctxt of

544+ noMatch i cs tm = all (\x -> case matchClause i (delab' i x True) tm of

545+ Right _ -> False

546+ Left miss -> True) cs

547+

548+ checkUndefined n ctxt = case lookupDef n ctxt of

488549 [] -> return ()

489550 [TyDecl _ _] -> return ()

490551 _ -> tclift $ tfail (At fc (AlreadyDefined n))

@@ -550,6 +611,7 @@ checkPossible info fc tcgen fname lhs_in

550611 case recheck ctxt [] (forget lhs_tm) lhs_tm of

551612 OK _ -> return True

552613 _ -> return False

614+

553615-- b <- inferredDiff fc (delab' i lhs_tm True) lhs

554616-- return (not b) -- then return (Just lhs_tm) else return Nothing

555617-- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)

@@ -569,10 +631,10 @@ elabClause info tcgen (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

569631 -- pattern bindings

570632 i <- getIState

571633 -- get the parameters first, to pass through to any where block

572− let fn_ty = case lookupTy Nothing fname (tt_ctxt i) of

634+ let fn_ty = case lookupTy fname (tt_ctxt i) of

573635 [t] -> t

574636 _ -> error "Can't happen (elabClause function type)"

575− let fn_is = case lookupCtxt Nothing fname (idris_implicits i) of

637+ let fn_is = case lookupCtxt fname (idris_implicits i) of

576638 [t] -> t

577639 _ -> []

578640 let params = getParamsInType i [] fn_is fn_ty

@@ -676,7 +738,7 @@ elabClause info tcgen (cnum, PClause fc fname lhs_in withs rhs_in whereblock)

676738 = getParamsInType i (n : env) is (instantiate (P Bound n t) sc)

677739 getParamsInType i env is tm@(App f a)

678740 | (P _ tn _, args) <- unApply tm

679− = case lookupCtxt Nothing tn (idris_datatypes i) of

741+ = case lookupCtxt tn (idris_datatypes i) of

680742 [t] -> nub $ paramNames args env (param_pos t) ++

681743 getParamsInType i env is f ++

682744 getParamsInType i env is a

@@ -709,7 +771,7 @@ elabClause info tcgen (_, PWith fc fname lhs_in withs wval_in withblock)

709771 -- Build the LHS as an "Infer", and pull out its type and

710772 -- pattern bindings

711773 i <- getIState

712− let lhs = addImpl i lhs_in

774+ let lhs = addImplPat i lhs_in

713775 logLvl 5 ("LHS: " ++ showImp True lhs)

714776 ((lhs', dlhs, []), _) <-

715777 tclift $ elaborate ctxt (MN 0 "patLHS") infP []

@@ -807,18 +869,18 @@ elabClause info tcgen (_, PWith fc fname lhs_in withs wval_in withblock)

807869

808870 mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)

809871 = do i <- getIState

810− let tm = addImpl i tm_in

872+ let tm = addImplPat i tm_in

811873 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++

812874 showImp True toplhs)

813875 case matchClause i toplhs tm of

814− Left _ -> fail $ show fc ++ "with clause does not match top level"

876+ Left f -> fail $ show fc ++ ":with clause does not match top level"

815877 Right mvars ->

816878 do logLvl 3 ("Match vars : " ++ show mvars)

817879 lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

818880 return $ PClause fc wname lhs ws rhs wheres

819881 mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs)

820882 = do i <- getIState

821− let tm = addImpl i tm_in

883+ let tm = addImplPat i tm_in

822884 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++

823885 showImp True toplhs)

824886 withs' <- mapM (mkAuxC wname toplhs ns ns') withs

@@ -877,6 +939,9 @@ elabClass info syn doc fc constraints tn ps ds

877939 -- build instance constructor type

878940 -- decorate names of functions to ensure they can't be referred

879941 -- to elsewhere in the class declaration

942+ -- TODO: Remove mdec to make it a dependent record, which would

943+ -- allow dependent type classes, but building instances will

944+ -- then need some attention.

880945 let cty = impbind ps $ conbind constraints

881946 $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods)

882947 constraint

@@ -886,7 +951,8 @@ elabClass info syn doc fc constraints tn ps ds

886951 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc False ddecl

887952 -- for each constraint, build a top level function to chase it

888953 logLvl 5 $ "Building functions"

889− let usyn = syn { using = ps ++ using syn }

954+ let usyn = syn { using = map (\ (x,y) -> UImplicit x y) ps

955+ ++ using syn }

890956 fns <- mapM (cfun cn constraint usyn (map fst imethods)) constraints

891957 mapM_ (elabDecl EAll info) (concat fns)

892958 -- for each method, build a top level function

@@ -952,7 +1018,7 @@ elabClass info syn doc fc constraints tn ps ds

9521018 let conn = case con of

9531019 PRef _ n -> n

9541020 PApp _ (PRef _ n) _ -> n

955− let conn' = case lookupCtxtName Nothing conn (idris_classes i) of

1021+ let conn' = case lookupCtxtName conn (idris_classes i) of

9561022 [(n, _)] -> n

9571023 _ -> conn

9581024 addInstance False conn' cfn

@@ -1013,7 +1079,7 @@ elabInstance :: ElabInfo -> SyntaxInfo ->

10131079 [PDecl] -> Idris ()

10141080elabInstance info syn fc cs n ps t expn ds

10151081 = do i <- getIState

1016− (n, ci) <- case lookupCtxtName (namespace info) n (idris_classes i) of

1082+ (n, ci) <- case lookupCtxtName n (idris_classes i) of

10171083 [c] -> return c

10181084 _ -> fail $ show fc ++ ":" ++ show n ++ " is not a type class"

10191085 let constraint = PApp fc (PRef fc n) (map pexp ps)

@@ -1073,7 +1139,7 @@ elabInstance info syn fc cs n ps t expn ds

10731139 checkNotOverlapping i t n

10741140 | take 2 (show n) == "@@" = return ()

10751141 | otherwise

1076− = case lookupTy Nothing n (tt_ctxt i) of

1142+ = case lookupTy n (tt_ctxt i) of

10771143 [t'] -> let tret = getRetType t

10781144 tret' = getRetType (delab i t') in

10791145 case matchClause i tret' tret of

@@ -1110,7 +1176,7 @@ elabInstance info syn fc cs n ps t expn ds

11101176 | PRef _ n <- getTm p

11111177 = do ps' <- getWParams ps

11121178 ctxt <- getContext

1113− case lookupP Nothing n ctxt of

1179+ case lookupP n ctxt of

11141180 [] -> return (pimp n (PRef fc n) : ps')

11151181 _ -> return ps'

11161182 getWParams (_ : ps) = getWParams ps

@@ -1245,7 +1311,7 @@ elabDecl' what info d@(PClauses f o n ps)

12451311 | what /= ETypes

12461312 = do iLOG $ "Elaborating clause " ++ show n

12471313 i <- getIState -- get the type options too

1248− let o' = case lookupCtxt Nothing n (idris_flags i) of

1314+ let o' = case lookupCtxt n (idris_flags i) of

12491315 [fs] -> fs

12501316 [] -> []

12511317 elabClauses info f (o ++ o') n ps

src/Idris/ElabTerm.hs+56−50

@@ -96,9 +96,10 @@ elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

9696 ElabD ()

9797elab ist info pattern tcgen fn tm

9898 = do elabE (False, False) tm -- (in argument, guarded)

99+ end_unify

99100 when pattern -- convert remaining holes to pattern vars

100101 (do update_term orderPats

101−-- tm <- get_term

102+ tm <- get_term

102103 mkPat)

103104 where

104105 isph arg = case getTm arg of

@@ -211,7 +212,7 @@ elab ist info pattern tcgen fn tm

211212 elab' ina (PPatvar fc n) | pattern = patvar n

212213 elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n)

213214 = do ctxt <- get_context

214− let defined = case lookupTy Nothing n ctxt of

215+ let defined = case lookupTy n ctxt of

215216 [] -> False

216217 _ -> True

217218 -- this is to stop us resolve type classes recursively

@@ -221,7 +222,7 @@ elab ist info pattern tcgen fn tm

221222 then do apply (Var n) []; solve

222223 else try (do apply (Var n) []; solve)

223224 (patvar n)

224− where inparamBlock n = case lookupCtxtName Nothing n (inblock info) of

225+ where inparamBlock n = case lookupCtxtName n (inblock info) of

225226 [] -> False

226227 _ -> True

227228 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])

@@ -231,6 +232,7 @@ elab ist info pattern tcgen fn tm

231232 -- let sc' = mapPT (repN n n') sc

232233 ptm <- get_term

233234 g <- goal

235+ checkPiGoal

234236 attack; intro (Just n);

235237 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

236238 elabE (True, a) sc; solve

@@ -240,6 +242,7 @@ elab ist info pattern tcgen fn tm

240242 = do hsin <- get_holes

241243 ptmin <- get_term

242244 tyn <- unique_hole (MN 0 "lamty")

245+ checkPiGoal

243246 claim tyn RType

244247 attack

245248 ptm <- get_term

@@ -332,7 +335,7 @@ elab ist info pattern tcgen fn tm

332335 elab' (ina, g) tm@(PApp fc (PRef _ f) args')

333336 = do let args = {- case lookupCtxt f (inblock info) of

334337 Just ps -> (map (pexp . (PRef fc)) ps ++ args')

335− _ ->-} args'

338+ _ -> -} args'

336339-- newtm <- mkSpecialised ist fc f (map getTm args') tm

337340 env <- get_env

338341 if (f `elem` map fst env && length args' == 1)

@@ -348,11 +351,11 @@ elab ist info pattern tcgen fn tm

348351 let isinf = f == inferCon || tcname f

349352 -- if f is a type class, we need to know its arguments so that

350353 -- we can unify with them

351− case lookupCtxt Nothing f (idris_classes ist) of

354+ case lookupCtxt f (idris_classes ist) of

352355 [] -> return ()

353356 _ -> mapM_ setInjective (map getTm args')

354357 ctxt <- get_context

355− let guarded = isConName Nothing f ctxt

358+ let guarded = isConName f ctxt

356359 ns <- apply (Var f) (map isph args)

357360 ptm <- get_term

358361 g <- goal

@@ -443,6 +446,8 @@ elab ist info pattern tcgen fn tm

443446 (caseBlock fc cname' (reverse args) opts)

444447 -- fail $ "Not implemented " ++ show c ++ "\n" ++ show args

445448 -- elaborate case

449+ env <- get_env

450+ g <- goal

446451 updateAux (newdef : )

447452 -- if we haven't got the type yet, hopefully we'll get it later!

448453 movelast tyn

@@ -545,7 +550,7 @@ pruneAlt xs = map prune xs

545550pruneByType :: Term -> Context -> [PTerm] -> [PTerm]

546551pruneByType (P _ n _) c as

547552-- if the goal type is polymorphic, keep e

548− | [] <- lookupTy Nothing n c = as

553+ | [] <- lookupTy n c = as

549554 | otherwise

550555 = let asV = filter (headIs True n) as

551556 as' = filter (headIs False n) as in

@@ -561,7 +566,7 @@ pruneByType (P _ n _) c as

561566 headIs _ _ _ = True -- keep if it's not an application

562567

563568 typeHead var f f'

564− = case lookupTy Nothing f' c of

569+ = case lookupTy f' c of

565570 [ty] -> let ty' = normalise c [] ty in

566571 case unApply (getRetTy ty') of

567572 (P _ ftyn _, _) -> ftyn == f

@@ -594,7 +599,7 @@ trivial ist = try' (do elab ist toplevel False False (MN 0 "tac")

594599findInstances :: IState -> Term -> [Name]

595600findInstances ist t

596601 | (P _ n _, _) <- unApply t

597− = case lookupCtxt Nothing n (idris_classes ist) of

602+ = case lookupCtxt n (idris_classes ist) of

598603 [CI _ _ _ _ ins] -> ins

599604 _ -> []

600605 | otherwise = []

@@ -610,9 +615,11 @@ resolveTC depth fn ist

610615 if True -- all (\n -> not (n `elem` hs)) (freeNames g)

611616 then try' (trivial ist)

612617 (do t <- goal

613− let insts = findInstances ist t

614618 let (tc, ttypes) = unApply t

615619 scopeOnly <- needsDefault t tc ttypes

620+ let insts_in = findInstances ist t

621+ let insts = if scopeOnly then filter chaser insts_in

622+ else insts_in

616623 tm <- get_term

617624-- traceWhen (depth > 6) ("GOAL: " ++ show t ++ "\nTERM: " ++ show tm) $

618625-- (tryAll (map elabTC (map fst (ctxtAlist (tt_ctxt ist)))))

@@ -628,6 +635,12 @@ resolveTC depth fn ist

628635 elabTC n | n /= fn && tcname n = (resolve n depth, show n)

629636 | otherwise = (fail "Can't resolve", show n)

630637

638+ -- HACK! Rather than giving a special name, better to have some kind

639+ -- of flag in ClassInfo structure

640+ chaser (UN ('@':'@':_)) = True

641+ chaser (NS n _) = chaser n

642+ chaser _ = False

643+

631644 needsDefault t num@(P _ (NS (UN "Num") ["Builtins"]) _) [P Bound a _]

632645 = do focus a

633646 fill (RConstant IType) -- default Int

@@ -656,7 +669,7 @@ resolveTC depth fn ist

656669-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist

657670-- else do

658671 -- if there's a hole in the goal, don't even try

659− let imps = case lookupCtxtName Nothing n (idris_implicits ist) of

672+ let imps = case lookupCtxtName n (idris_implicits ist) of

660673 [] -> []

661674 [args] -> map isImp (snd args) -- won't be overloaded!

662675 ps <- get_probs

@@ -693,10 +706,12 @@ collectDeferred (App f a) = liftM2 App (collectDeferred f) (collectDeferred a)

693706collectDeferred t = return t

694707

695708-- Running tactics directly

709+-- if a tactic adds unification problems, return an error

696710

697711runTac :: Bool -> IState -> PTactic -> ElabD ()

698−runTac autoSolve ist tac = do env <- get_env

699− runT (fmap (addImplBound ist (map fst env)) tac)

712+runTac autoSolve ist tac

713+ = do env <- get_env

714+ no_errors $ runT (fmap (addImplBound ist (map fst env)) tac)

700715 where

701716 runT (Intro []) = do g <- goal

702717 attack; intro (bname g)

@@ -714,7 +729,7 @@ runTac autoSolve ist tac = do env <- get_env

714729 runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm

715730 when autoSolve solveAll

716731 runT (Refine fn [])

717− = do (fn', imps) <- case lookupCtxtName Nothing fn (idris_implicits ist) of

732+ = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of

718733 [] -> do a <- envArgs fn

719734 return (fn, a)

720735 -- FIXME: resolve ambiguities

@@ -773,47 +788,38 @@ runTac autoSolve ist tac = do env <- get_env

773788 runT Solve = solve

774789 runT (Try l r) = do try' (runT l) (runT r) True

775790 runT (TSeq l r) = do runT l; runT r

776− runT (ApplyTactic tm) = do tenv <- get_env -- store the environment before it is loaded with junk

777− attack -- let f : List (TTName, Binder TT) -> Tactic = tm in ...

778− valn <- unique_hole (MN 0 "tacval")

779− claim valn (RBind (UN "__pi_arg")

780− (Pi (RApp listTy envTupleType)) tacticTy)

781− tacn <- unique_hole (MN 0 "tacn")

782− letbind tacn (RBind (UN "__pi_arg")

783− (Pi (RApp listTy envTupleType)) tacticTy)

784− (Var valn)

785− focus valn

791+ runT (ApplyTactic tm) = do tenv <- get_env -- store the environment

792+ tgoal <- goal -- store the goal

793+ attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...

794+ script <- unique_hole (MN 0 "script")

795+ claim script scriptTy

796+ scriptvar <- unique_hole (MN 0 "scriptvar" )

797+ letbind scriptvar scriptTy (Var script)

798+ focus script

786799 elab ist toplevel False False (MN 0 "tac") tm

787− (tm', ty') <- get_type_val (Var tacn)

788− ctxt <- get_context

789− env <- get_env

790− let tm'' = normalise ctxt env tm'

791− attack -- let x : List (TTName, Binder TT) = reflectEnv in ...

792− envval <- unique_hole (MN 0 "letval")

793− claim envval (RApp listTy envTupleType)

794− letn <- unique_hole (MN 0 "letvar")

795− letbind letn (RApp listTy envTupleType) (Var envval)

796− focus envval

797− env <- get_env

798− elab ist toplevel False False (MN 0 "tac") (PQuote (reflectEnv tenv))

799− (env', _) <- get_type_val (Var letn)

800− ctxt <- get_context

801− env <- get_env

802− let env'' = normalise ctxt env env'

803− attack -- let z : Tactic = f x

804− restac <- unique_hole (MN 0 "letval")

800+ (script', _) <- get_type_val (Var scriptvar)

801+ -- now that we have the script apply

802+ -- it to the reflected goal and context

803+ restac <- unique_hole (MN 0 "restac")

805804 claim restac tacticTy

806− letn <- unique_hole (MN 0 "letvar")

807− letbind letn tacticTy (Var restac)

808805 focus restac

809− elab ist toplevel False False (MN 0 "tac") (PQuote (RApp (forget tm'') (forget env'')))

810− (res, _) <- get_type_val (Var letn)

806+ fill (raw_apply (forget script')

807+ [reflectEnv tenv, reflect tgoal])

808+ restac' <- get_guess

809+ solve

810+ -- normalise the result in order to

811+ -- reify it

811812 ctxt <- get_context

812813 env <- get_env

813− let tactic = normalise ctxt env res

814+ let tactic = normalise ctxt env restac'

814815 runReflected tactic

815816 where tacticTy = Var (reflm "Tactic")

816817 listTy = Var (NS (UN "List") ["List", "Prelude"])

818+ scriptTy = (RBind (UN "__pi_arg")

819+ (Pi (RApp listTy envTupleType))

820+ (RBind (UN "__pi_arg1")

821+ (Pi (Var $ reflm "TT")) tacticTy))

822+

817823 runT (Reflect v) = do attack -- let x = reflect v in ...

818824 tyn <- unique_hole (MN 0 "letty")

819825 claim tyn RType

@@ -1207,7 +1213,7 @@ solveAll = try (do solve; solveAll) (return ())

12071213mkSpecialised :: IState -> FC -> Name -> [PTerm] -> PTerm -> ElabD PTerm

12081214mkSpecialised i fc n args def

12091215 = do let tm' = def

1210− case lookupCtxt Nothing n (idris_statics i) of

1216+ case lookupCtxt n (idris_statics i) of

12111217 [] -> return tm'

12121218 [as] -> if (not (or as)) then return tm' else

12131219 mkSpecDecl i n (zip args as) tm'

@@ -1234,8 +1240,8 @@ mkSpecDecl i n pargs tm'

12341240 cg = idris_callgraph i

12351241

12361242 staticFnNames tm | (P _ f _, as) <- unApply tm

1237− = if not (isFnName Nothing f ctxt) then []

1238− else case lookupCtxt Nothing f cg of

1243+ = if not (isFnName f ctxt) then []

1244+ else case lookupCtxt f cg of

12391245 [ns] -> f : f : [] --(ns \\ [f])

12401246 [] -> [f,f]

12411247 _ -> []

src/Idris/Error.hs+1−1

@@ -45,7 +45,7 @@ instance Exception IdrisErr

4545ifail :: String -> Idris ()

4646ifail str = throwIO (IErr str)

4747

48−ierror :: Err -> Idris ()

48+ierror :: Err -> Idris a

4949ierror err = do i <- getIState

5050 throwIO (IErr $ pshow i err)

5151

src/Idris/Help.hs+1

@@ -28,6 +28,7 @@ help =

2828 ([":total"], NameArg, "Check the totality of a name"),

2929 ([":r",":reload"], NoArg, "Reload current file"),

3030 ([":l",":load"], FileArg, "Load a new file"),

31+ ([":cd"], FileArg, "Change working directory"),

3132 ([":m",":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons

3233 ([":e",":edit"], NoArg, "Edit current file using $EDITOR or $VISUAL"),

3334 ([":m",":metavars"], MetaVarArg, "Show remaining proof obligations (metavariables)"),

src/Idris/IBC.hs+50−27

@@ -18,10 +18,12 @@ import Control.Monad.State hiding (get, put)

1818import System.FilePath

1919import System.Directory

2020

21+import Debug.Trace

22+

2123import Paths_idris

2224

2325ibcVersion :: Word8

24−ibcVersion = 28

26+ibcVersion = 29

2527

2628data IBCFile = IBCFile { ver :: Word8,

2729 sourcefile :: FilePath,

@@ -48,6 +50,7 @@ data IBCFile = IBCFile { ver :: Word8,

4850 ibc_docstrings :: [(Name, String)],

4951 ibc_coercions :: [Name]

5052 }

53+ deriving Show

5154{-!

5255deriving instance Binary IBCFile

5356!-}

@@ -82,28 +85,28 @@ mkIBC (i:is) f = do ist <- getIState

8285 mkIBC is f'

8386

8487ibc i (IBCFix d) f = return f { ibc_fixes = d : ibc_fixes f }

85−ibc i (IBCImp n) f = case lookupCtxt Nothing n (idris_implicits i) of

88+ibc i (IBCImp n) f = case lookupCtxt n (idris_implicits i) of

8689 [v] -> return f { ibc_implicits = (n,v): ibc_implicits f }

8790 _ -> fail "IBC write failed"

8891ibc i (IBCStatic n) f

89− = case lookupCtxt Nothing n (idris_statics i) of

92+ = case lookupCtxt n (idris_statics i) of

9093 [v] -> return f { ibc_statics = (n,v): ibc_statics f }

9194 _ -> fail "IBC write failed"

9295ibc i (IBCClass n) f

93− = case lookupCtxt Nothing n (idris_classes i) of

96+ = case lookupCtxt n (idris_classes i) of

9497 [v] -> return f { ibc_classes = (n,v): ibc_classes f }

9598 _ -> fail "IBC write failed"

9699ibc i (IBCInstance int n ins) f

97100 = return f { ibc_instances = (int,n,ins): ibc_instances f }

98101ibc i (IBCDSL n) f

99− = case lookupCtxt Nothing n (idris_dsls i) of

102+ = case lookupCtxt n (idris_dsls i) of

100103 [v] -> return f { ibc_dsls = (n,v): ibc_dsls f }

101104 _ -> fail "IBC write failed"

102105ibc i (IBCData n) f

103− = case lookupCtxt Nothing n (idris_datatypes i) of

106+ = case lookupCtxt n (idris_datatypes i) of

104107 [v] -> return f { ibc_datatypes = (n,v): ibc_datatypes f }

105108 _ -> fail "IBC write failed"

106−ibc i (IBCOpt n) f = case lookupCtxt Nothing n (idris_optimisation i) of

109+ibc i (IBCOpt n) f = case lookupCtxt n (idris_optimisation i) of

107110 [v] -> return f { ibc_optimise = (n,v): ibc_optimise f }

108111 _ -> fail "IBC write failed"

109112ibc i (IBCSyntax n) f = return f { ibc_syntax = n : ibc_syntax f }

@@ -113,13 +116,13 @@ ibc i (IBCObj n) f = return f { ibc_objs = n : ibc_objs f }

113116ibc i (IBCLib n) f = return f { ibc_libs = n : ibc_libs f }

114117ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

115118ibc i (IBCHeader n) f = return f { ibc_hdrs = n : ibc_hdrs f }

116−ibc i (IBCDef n) f = case lookupDef Nothing n (tt_ctxt i) of

119+ibc i (IBCDef n) f = case lookupDef n (tt_ctxt i) of

117120 [v] -> return f { ibc_defs = (n,v) : ibc_defs f }

118121 _ -> fail "IBC write failed"

119−ibc i (IBCDoc n) f = case lookupCtxt Nothing n (idris_docstrings i) of

122+ibc i (IBCDoc n) f = case lookupCtxt n (idris_docstrings i) of

120123 [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }

121124 _ -> fail "IBC write failed"

122−ibc i (IBCCG n) f = case lookupCtxt Nothing n (idris_callgraph i) of

125+ibc i (IBCCG n) f = case lookupCtxt n (idris_callgraph i) of

123126 [v] -> return f { ibc_cg = (n,v) : ibc_cg f }

124127 _ -> fail "IBC write failed"

125128ibc i (IBCCoercion n) f = return f { ibc_coercions = n : ibc_coercions f }

@@ -246,7 +249,11 @@ pLibs :: [String] -> Idris ()

246249pLibs ls = mapM_ addLib ls

247250

248251pDyLibs :: [String] -> Idris ()

249−pDyLibs ls = mapM_ addDyLib ls

252+pDyLibs ls = do res <- mapM (addDyLib . return) ls

253+ mapM_ checkLoad res

254+ return ()

255+ where checkLoad (Left _) = return ()

256+ checkLoad (Right err) = fail err

250257

251258pHdrs :: [String] -> Idris ()

252259pHdrs hs = mapM_ addHdr hs

@@ -327,16 +334,21 @@ instance Binary FC where

327334

328335instance Binary Name where

329336 put x

330− = case x of

331− UN x1 -> do putWord8 0

332− put x1

333− NS x1 x2 -> do putWord8 1

337+ = {-# SCC "putName" #-}

338+ case x of

339+ UN x1 -> {-# SCC "putUN" #-}

340+ do putWord8 0

341+ {-# SCC "putNString" #-} put x1

342+ NS x1 x2 -> {-# SCC "putNS" #-}

343+ do putWord8 1

334344 put x1

335345 put x2

336− MN x1 x2 -> do putWord8 2

346+ MN x1 x2 -> {-# SCC "putMN" #-}

347+ do putWord8 2

337348 put x1

338349 put x2

339− NErased -> putWord8 3

350+ NErased -> {-# SCC "putNErased" #-}

351+ putWord8 3

340352 get

341353 = do i <- getWord8

342354 case i of

@@ -528,9 +540,10 @@ instance Binary NameType where

528540 _ -> error "Corrupted binary data for NameType"

529541

530542

531−instance (Binary n) => Binary (TT n) where

543+instance {-(Binary n) =>-} Binary (TT Name) where

532544 put x

533− = case x of

545+ = {-# SCC "putTT" #-}

546+ case x of

534547 P x1 x2 x3 -> do putWord8 0

535548 put x1

536549 put x2

@@ -613,7 +626,8 @@ instance Binary SC where

613626

614627instance Binary CaseAlt where

615628 put x

616− = case x of

629+ = {-# SCC "putCaseAlt" #-}

630+ case x of

617631 ConCase x1 x2 x3 x4 -> do putWord8 0

618632 put x1

619633 put x2

@@ -642,17 +656,16 @@ instance Binary CaseAlt where

642656

643657instance Binary Def where

644658 put x

645− = case x of

659+ = {-# SCC "putDef" #-}

660+ case x of

646661 Function x1 x2 -> do putWord8 0

647662 put x1

648663 put x2

649664 TyDecl x1 x2 -> do putWord8 1

650665 put x1

651666 put x2

652− Operator x1 x2 x3 -> do putWord8 2

653− put x1

654− put x2

655− put x3

667+ -- all primitives just get added at the start, don't write

668+ Operator x1 x2 x3 -> do return ()

656669 CaseOp x1 x2 x3 x3a x4 x5 x6 x7 x8 ->

657670 do putWord8 3

658671 put x1

@@ -750,8 +763,9 @@ instance Binary Totality where

750763 _ -> error "Corrupted binary data for Totality"

751764

752765instance Binary IBCFile where

753− put (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)

754− = do put x1

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

767+ = {-# SCC "putIBCFile" #-}

768+ do put x1

755769 put x2

756770 put x3

757771 put x4

@@ -1082,6 +1096,15 @@ instance (Binary t) => Binary (PDecl' t) where

10821096 return (PPostulate x1 x2 x3 x4 x5 x6)

10831097 _ -> error "Corrupted binary data for PDecl'"

10841098

1099+instance Binary Using where

1100+ put (UImplicit x1 x2) = do putWord8 0; put x1; put x2

1101+ put (UConstraint x1 x2) = do putWord8 1; put x1; put x2

1102+

1103+ get = do i <- getWord8

1104+ case i of

1105+ 0 -> do x1 <- get; x2 <- get; return (UImplicit x1 x2)

1106+ 1 -> do x1 <- get; x2 <- get; return (UConstraint x1 x2)

1107+

10851108instance Binary SyntaxInfo where

10861109 put (Syn x1 x2 x3 x4 x5 x6 x7 x8)

10871110 = do put x1

src/Idris/IdeSlave.hsnew file+123

@@ -0,0 +1,123 @@

1+{-# LANGUAGE FlexibleInstances, IncoherentInstances #-}

2+

3+module Idris.IdeSlave(parseMessage, convSExp, IdeSlaveCommand(..), sexpToCommand, toSExp, SExp(..)) where

4+

5+import Text.Printf

6+import Numeric

7+import Data.List

8+-- import qualified Data.Text as T

9+import Text.Parsec

10+

11+data SExp = SexpList [SExp]

12+ | StringAtom String

13+ | BoolAtom Bool

14+ | IntegerAtom Integer

15+ | SymbolAtom String

16+ deriving ( Eq, Show )

17+

18+sExpToString :: SExp -> String

19+sExpToString (StringAtom s) = "\"" ++ escape s ++ "\""

20+sExpToString (BoolAtom True) = ":True"

21+sExpToString (BoolAtom False) = ":False"

22+sExpToString (IntegerAtom i) = printf "%d" i

23+sExpToString (SymbolAtom s) = ":" ++ s

24+sExpToString (SexpList l) = "(" ++ intercalate " " (map sExpToString l) ++ ")"

25+

26+class SExpable a where

27+ toSExp :: a -> SExp

28+

29+instance SExpable SExp where

30+ toSExp a = a

31+

32+instance SExpable Bool where

33+ toSExp True = BoolAtom True

34+ toSExp False = BoolAtom False

35+

36+instance SExpable String where

37+ toSExp s = StringAtom s

38+

39+instance SExpable Integer where

40+ toSExp n = IntegerAtom n

41+

42+instance SExpable Int where

43+ toSExp n = IntegerAtom (toInteger n)

44+

45+instance (SExpable a) => SExpable (Maybe a) where

46+ toSExp Nothing = SexpList [SymbolAtom "Nothing"]

47+ toSExp (Just a) = SexpList [SymbolAtom "Just", toSExp a]

48+

49+instance (SExpable a) => SExpable [a] where

50+ toSExp l = SexpList (map toSExp l)

51+

52+instance (SExpable a, SExpable b) => SExpable (a, b) where

53+ toSExp (l, r) = SexpList [toSExp l, toSExp r]

54+

55+instance (SExpable a, SExpable b, SExpable c) => SExpable (a, b, c) where

56+ toSExp (l, m, n) = SexpList [toSExp l, toSExp m, toSExp n]

57+

58+escape :: String -> String

59+escape = concatMap escapeChar

60+ where

61+ escapeChar '\\' = "\\\\"

62+ escapeChar '"' = "\\\""

63+ escapeChar c = [c]

64+

65+pSExp = do xs <- between (char '(') (char ')') (pSExp `sepBy` (char ' '))

66+ return (SexpList xs)

67+ <|> atom

68+

69+atom = do char ':'; x <- atomC; return x

70+ <|> do char '"'; xs <- many quotedChar; char '"'; return (StringAtom xs)

71+ <|> do ints <- many1 digit

72+ case readDec ints of

73+ ((num, ""):_) -> return (IntegerAtom (toInteger num))

74+ _ -> return (StringAtom ints)

75+

76+atomC = do string "True"; return (BoolAtom True)

77+ <|> do string "False"; return (BoolAtom False)

78+ <|> do xs <- many (noneOf " \n\t\r\"()"); return (SymbolAtom xs)

79+

80+quotedChar = try (string "\\\\" >> return '\\')

81+ <|> try (string "\\\"" >> return '"')

82+ <|> noneOf "\""

83+

84+parseSExp :: String -> Either ParseError SExp

85+parseSExp = parse pSExp "(unknown)"

86+

87+data IdeSlaveCommand = REPLCompletions String

88+ | Interpret String

89+ | LoadFile String

90+ deriving Show

91+

92+sexpToCommand :: SExp -> Maybe IdeSlaveCommand

93+sexpToCommand (SexpList (x:[])) = sexpToCommand x

94+sexpToCommand (SexpList [SymbolAtom "interpret", StringAtom cmd]) = Just (Interpret cmd)

95+sexpToCommand (SexpList [SymbolAtom "repl-completions", StringAtom prefix]) = Just (REPLCompletions prefix)

96+sexpToCommand (SexpList [SymbolAtom "load-file", StringAtom filename]) = Just (LoadFile filename)

97+sexpToCommand _ = Nothing

98+

99+parseMessage :: String -> (SExp, Integer)

100+parseMessage x = case receiveString x of

101+ (SexpList [cmd, (IntegerAtom id)]) ->

102+ (cmd, id)

103+

104+receiveString :: String -> SExp

105+receiveString x =

106+ case readHex (take 6 x) of

107+ ((num, ""):_) ->

108+ let msg = drop 6 x in

109+ if (length msg) /= (num - 1)

110+ then error "bad input length"

111+ else (case parseSExp msg of

112+ Left _ -> error "parse failure"

113+ Right r -> r)

114+ _ -> error "readHex failed"

115+

116+convSExp :: SExpable a => String -> a -> Integer -> String

117+convSExp pre s id =

118+ let sex = SexpList [SymbolAtom pre, toSExp s, IntegerAtom id] in

119+ let str = sExpToString sex in

120+ (getHexLength str) ++ str

121+

122+getHexLength :: String -> String

123+getHexLength s = printf "%06x" (1 + (length s))

src/Idris/Parser.hs+53−19

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

1−{-# LANGUAGE PatternGuards #-}

1+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}

22-- | Parse the full Idris language.

33module Idris.Parser where

44

@@ -30,6 +30,7 @@ import qualified Text.Parsec.Token as PTok

3030import Data.List

3131import Data.List.Split(splitOn)

3232import Control.Monad.State

33+import Control.Monad.Error

3334import Debug.Trace

3435import Data.Maybe

3536import System.FilePath

@@ -273,7 +274,7 @@ pfc = do s <- getPosition

273274pImport :: IParser String

274275pImport = do reserved "import"; f <- identifier; option ';' (lchar ';')

275276 return (toPath f)

276− where toPath n = foldl1 (</>) $ splitOn "." n

277+ where toPath n = foldl1' (</>) $ splitOn "." n

277278

278279-- | A program is a list of declarations, possibly with associated

279280-- documentation strings.

@@ -470,7 +471,7 @@ pPostulate syn = do doc <- option "" (pDocComment '|')

470471

471472pUsing :: SyntaxInfo -> IParser [PDecl]

472473pUsing syn =

473− do reserved "using"; lchar '('; ns <- tyDeclList syn; lchar ')'

474+ do reserved "using"; lchar '('; ns <- usingDeclList syn; lchar ')'

474475 openBlock

475476 let uvars = using syn

476477 ds <- many1 (pDecl (syn { using = uvars ++ ns }))

@@ -613,7 +614,6 @@ pNoExtExpr syn =

613614 <|> pRewriteTerm syn

614615 <|> pPi syn

615616 <|> pDoBlock syn

616− <|> pComprehension syn

617617

618618pExtensions :: SyntaxInfo -> [Syntax] -> IParser PTerm

619619pExtensions syn rules = choice (map (try . pExt syn) (filter valid rules))

@@ -763,6 +763,7 @@ pSimpleExpr syn =

763763 fc <- pfc

764764 return (PInferRef fc x))

765765 <|> try (pList syn)

766+ <|> try (pComprehension syn)

766767 <|> try (pAlt syn)

767768 <|> try (pIdiom syn)

768769 <|> try (do lchar '('

@@ -800,16 +801,30 @@ pCaseOpt syn = do lhs <- pExpr (syn { inPattern = True })

800801 symbol "=>"; rhs <- pExpr syn

801802 return (lhs, rhs)

802803

804+-- bit of a hack here. If the integer doesn't fit in an Int, treat it as a

805+-- big integer, otherwise try fromInteger and the constants as alternatives.

806+-- a better solution would be to fix fromInteger to work with Integer, as the

807+-- name suggests, rather than Int

808+

803809modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm

804−modifyConst syn fc (PConstant (I x))

810+modifyConst syn fc (PConstant (BI x))

811+ | not (fitsInt x) = PAlternative False

812+ [PConstant (BI x),

813+ PApp fc (PRef fc (UN "fromInteger"))

814+ [pexp (PConstant (I (fromInteger x)))]]

805815 | not (inPattern syn)

806816 = PAlternative False

807− [PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I x))],

808− PConstant (I x), PConstant (BI (toEnum x))]

817+ [PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I (fromInteger x)))],

818+ PConstant (I (fromInteger x)), PConstant (BI x)]

809819 | otherwise = PAlternative False

810− [PConstant (I x), PConstant (BI (toEnum x))]

820+ [PConstant (I (fromInteger x)), PConstant (BI x)]

811821modifyConst syn fc x = x

812822

823+fitsInt :: Integer -> Bool

824+fitsInt x = let xInt :: Int = fromInteger x

825+ xInteger :: Integer = toInteger xInt in

826+ x == xInteger

827+

813828pList syn = do lchar '['; fc <- pfc; xs <- sepBy (pExpr syn) (lchar ','); lchar ']'

814829 return (mkList fc xs)

815830 where

@@ -867,7 +882,7 @@ pApp syn = do f <- pSimpleExpr syn

867882 return (dslify i $ PApp fc f args)

868883 where

869884 dslify i (PApp fc (PRef _ f) [a])

870− | [d] <- lookupCtxt Nothing f (idris_dsls i)

885+ | [d] <- lookupCtxt f (idris_dsls i)

871886 = desugar (syn { dsl_info = d }) i (getTm a)

872887 dslify i t = t

873888

@@ -961,7 +976,9 @@ pLet syn = try (do reserved "let"; n <- pName;

961976 return (PCase fc v [(pat, sc)]))

962977

963978pPi syn =

964− try (do lazy <- option False (do lchar '|'; return True)

979+ try (do lazy <- if implicitAllowed syn -- laziness is top level only

980+ then option False (do lchar '|'; return True)

981+ else return False

965982 st <- pStatic

966983 lchar '('; xt <- tyDeclList syn; lchar ')'

967984 doc <- option "" (pDocComment '^')

@@ -1015,6 +1032,19 @@ pConstList syn = try (do lchar '('

10151032 return [t])

10161033 <|> return []

10171034

1035+usingDeclList syn

1036+ = try (sepBy1 (usingDecl syn) (lchar ','))

1037+ <|> do ns <- sepBy1 pName (lchar ',')

1038+ t <- pTSig (noImp syn)

1039+ return (map (\x -> UImplicit x t) ns)

1040+

1041+usingDecl syn = try (do x <- pfName

1042+ t <- pTSig (noImp syn)

1043+ return (UImplicit x t))

1044+ <|> do c <- pfName

1045+ xs <- many1 pfName

1046+ return (UConstraint c xs)

1047+

10181048tyDeclList syn = try (sepBy1 (do x <- pfName

10191049 t <- pTSig (noImp syn)

10201050 return (x,t))

@@ -1106,8 +1136,7 @@ pConstant = do reserved "Integer";return BIType

11061136 <|> do reserved "Bits32"; return B32Type

11071137 <|> do reserved "Bits64"; return B64Type

11081138 <|> try (do f <- float; return $ Fl f)

1109−-- <|> try (do i <- natural; lchar 'L'; return $ BI i)

1110− <|> try (do i <- natural; return $ I (fromInteger i))

1139+ <|> try (do i <- natural; return $ BI i)

11111140 <|> try (do s <- strlit; return $ Str s)

11121141 <|> try (do c <- chlit; return $ Ch c)

11131142

@@ -1348,7 +1377,8 @@ pClause syn

13481377 cargs <- many (pConstraintArg syn)

13491378 iargs <- many (pImplicitArg (syn { inPattern = True } ))

13501379 fc <- pfc

1351− args <- many (pArgExpr syn)

1380+ args <- many (try (pImplicitArg (syn { inPattern = True } ))

1381+ <|> (fmap pexp (pArgExpr syn)))

13521382 wargs <- many (pWExpr syn)

13531383 rhs <- pRHS syn n

13541384 ist <- getState

@@ -1360,7 +1390,7 @@ pClause syn

13601390 do pTerminator

13611391 return ([], [])]

13621392 let capp = PApp fc (PRef fc n)

1363− (iargs ++ cargs ++ map pexp args)

1393+ (iargs ++ cargs ++ args)

13641394 ist <- getState

13651395 setState (ist { lastParse = Just n })

13661396 return $ PClause fc n capp wargs rhs wheres)

@@ -1386,10 +1416,11 @@ pClause syn

13861416 cargs <- many (pConstraintArg syn)

13871417 iargs <- many (pImplicitArg (syn { inPattern = True } ))

13881418 fc <- pfc

1389− args <- many (pArgExpr syn)

1419+ args <- many (try (pImplicitArg (syn { inPattern = True } ))

1420+ <|> (fmap pexp (pArgExpr syn)))

13901421 wargs <- many (pWExpr syn)

13911422 let capp = PApp fc (PRef fc n)

1392− (iargs ++ cargs ++ map pexp args)

1423+ (iargs ++ cargs ++ args)

13931424 ist <- getState

13941425 setState (ist { lastParse = Just n })

13951426 reserved "with"

@@ -1497,9 +1528,12 @@ pDirective syn = try (do lchar '%'; reserved "lib"; lib <- strlit;

14971528 putIState (i { default_total = tot }))])

14981529 <|> try (do lchar '%'; reserved "logging"; i <- natural;

14991530 return [PDirective (setLogLevel (fromInteger i))])

1500− <|> try (do lchar '%'; reserved "dynamic"; lib <- strlit;

1501− return [PDirective (do addIBC (IBCDyLib lib)

1502− addDyLib lib)])

1531+ <|> try (do lchar '%'; reserved "dynamic"; libs <- sepBy1 strlit (lchar ',');

1532+ return [PDirective (do added <- addDyLib libs

1533+ case added of

1534+ Left lib -> addIBC (IBCDyLib (lib_name lib))

1535+ Right msg ->

1536+ fail $ msg)])

15031537 <|> try (do lchar '%'; reserved "language"; ext <- reserved "TypeProviders";

15041538 return [PDirective (addLangExt TypeProviders)])

15051539

src/Idris/Primitives.hs+225−445

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

1−{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

1+{-# LANGUAGE RankNTypes, ScopedTypeVariables, PatternGuards #-}

22

33module Idris.Primitives(elabPrims) where

44

@@ -34,280 +34,73 @@ partial = Partial NotCovering

3434

3535primitives =

3636 -- operators

37− [Prim (UN "prim__addInt") (ty [IType, IType] IType) 2 (iBin (+))

38− (2, LPlus) total,

39− Prim (UN "prim__subInt") (ty [IType, IType] IType) 2 (iBin (-))

40− (2, LMinus) total,

41− Prim (UN "prim__mulInt") (ty [IType, IType] IType) 2 (iBin (*))

42− (2, LTimes) total,

43− Prim (UN "prim__divInt") (ty [IType, IType] IType) 2 (iBin div)

44− (2, LDiv) partial,

45− Prim (UN "prim__modInt") (ty [IType, IType] IType) 2 (iBin mod)

46− (2, LMod) partial,

47− Prim (UN "prim__andInt") (ty [IType, IType] IType) 2 (iBin (.&.))

48− (2, LAnd) partial,

49− Prim (UN "prim__orInt") (ty [IType, IType] IType) 2 (iBin (.|.))

50− (2, LOr) partial,

51− Prim (UN "prim__xorInt") (ty [IType, IType] IType) 2 (iBin xor)

52− (2, LXOr) partial,

53− Prim (UN "prim__shLInt") (ty [IType, IType] IType) 2 (iBin shiftL)

54− (2, LSHL) partial,

55− Prim (UN "prim__shRInt") (ty [IType, IType] IType) 2 (iBin shiftR)

56− (2, LSHR) partial,

57− Prim (UN "prim__complInt") (ty [IType] IType) 1 (iUn complement)

58− (1, LCompl) partial,

59− Prim (UN "prim__eqInt") (ty [IType, IType] IType) 2 (biBin (==))

60− (2, LEq) total,

61− Prim (UN "prim__ltInt") (ty [IType, IType] IType) 2 (biBin (<))

62− (2, LLt) total,

63− Prim (UN "prim__lteInt") (ty [IType, IType] IType) 2 (biBin (<=))

64− (2, LLe) total,

65− Prim (UN "prim__gtInt") (ty [IType, IType] IType) 2 (biBin (>))

66− (2, LGt) total,

67− Prim (UN "prim__gteInt") (ty [IType, IType] IType) 2 (biBin (>=))

68− (2, LGe) total,

69− Prim (UN "prim__eqChar") (ty [ChType, ChType] IType) 2 (bcBin (==))

70− (2, LEq) total,

37+ [Prim (UN "prim__eqChar") (ty [ChType, ChType] IType) 2 (bcBin (==))

38+ (2, LEq ITNative) total,

7139 Prim (UN "prim__ltChar") (ty [ChType, ChType] IType) 2 (bcBin (<))

72− (2, LLt) total,

40+ (2, LLt ITNative) total,

7341 Prim (UN "prim__lteChar") (ty [ChType, ChType] IType) 2 (bcBin (<=))

74− (2, LLe) total,

42+ (2, LLe ITNative) total,

7543 Prim (UN "prim__gtChar") (ty [ChType, ChType] IType) 2 (bcBin (>))

76− (2, LGt) total,

44+ (2, LGt ITNative) total,

7745 Prim (UN "prim__gteChar") (ty [ChType, ChType] IType) 2 (bcBin (>=))

78− (2, LGe) total,

79−

80− Prim (UN "prim__ltB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (<))

81− (2, LB8Lt) total,

82− Prim (UN "prim__lteB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (<=))

83− (2, LB8Lte) total,

84− Prim (UN "prim__eqB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (==))

85− (2, LB8Eq) total,

86− Prim (UN "prim__gteB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (>))

87− (2, LB8Gte) total,

88− Prim (UN "prim__gtB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (>=))

89− (2, LB8Gt) total,

90− Prim (UN "prim__addB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (+))

91− (2, LB8Plus) total,

92− Prim (UN "prim__subB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (-))

93− (2, LB8Minus) total,

94− Prim (UN "prim__mulB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (*))

95− (2, LB8Times) total,

96− Prim (UN "prim__udivB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin div)

97− (2, LB8UDiv) partial,

98− Prim (UN "prim__sdivB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin s8div)

99− (2, LB8SDiv) partial,

100− Prim (UN "prim__uremB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin rem)

101− (2, LB8URem) partial,

102− Prim (UN "prim__sremB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin s8rem)

103− (2, LB8SRem) partial,

104− Prim (UN "prim__shlB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (\x y -> shiftL x (fromIntegral y)))

105− (2, LB8Shl) total,

106− Prim (UN "prim__lshrB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (\x y -> shiftR x (fromIntegral y)))

107− (2, LB8AShr) total,

108− Prim (UN "prim__ashrB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (\x y -> fromIntegral $

109− shiftR (fromIntegral x :: Int8)

110− (fromIntegral y)))

111− (2, LB8LShr) total,

112− Prim (UN "prim__andB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (.&.))

113− (2, LB8And) total,

114− Prim (UN "prim__orB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (.|.))

115− (2, LB8Or) total,

116− Prim (UN "prim__xorB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin xor)

117− (2, LB8Xor) total,

118− Prim (UN "prim__complB8") (ty [B8Type] B8Type) 1 (b8Un complement)

119− (1, LB8Compl) total,

120− Prim (UN "prim__zextB8_16") (ty [B8Type] B16Type) 1 zext8_16

121− (1, LB8Z16) total,

122− Prim (UN "prim__zextB8_32") (ty [B8Type] B32Type) 1 zext8_32

123− (1, LB8Z32) total,

124− Prim (UN "prim__zextB8_64") (ty [B8Type] B64Type) 1 zext8_64

125− (1, LB8Z64) total,

126− Prim (UN "prim__sextB8_16") (ty [B8Type] B16Type) 1 sext8_16

127− (1, LB8Z16) total,

128− Prim (UN "prim__sextB8_32") (ty [B8Type] B32Type) 1 sext8_32

129− (1, LB8Z32) total,

130− Prim (UN "prim__sextB8_64") (ty [B8Type] B64Type) 1 sext8_64

131− (1, LB8Z64) total,

132−

133− Prim (UN "prim__ltB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (<))

134− (2, LB16Lt) total,

135− Prim (UN "prim__lteB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (<=))

136− (2, LB16Lte) total,

137− Prim (UN "prim__eqB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (==))

138− (2, LB16Eq) total,

139− Prim (UN "prim__gteB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (>))

140− (2, LB16Gte) total,

141− Prim (UN "prim__gtB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (>=))

142− (2, LB16Gt) total,

143− Prim (UN "prim__addB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (+))

144− (2, LB16Plus) total,

145− Prim (UN "prim__subB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (-))

146− (2, LB16Minus) total,

147− Prim (UN "prim__mulB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (*))

148− (2, LB16Times) total,

149− Prim (UN "prim__udivB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin div)

150− (2, LB16UDiv) partial,

151− Prim (UN "prim__sdivB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin s16div)

152− (2, LB16SDiv) partial,

153− Prim (UN "prim__uremB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin rem)

154− (2, LB16URem) partial,

155− Prim (UN "prim__sremB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin s16rem)

156− (2, LB16SRem) partial,

157− Prim (UN "prim__shlB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (\x y -> shiftL x (fromIntegral y)))

158− (2, LB16Shl) total,

159− Prim (UN "prim__lshrB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (\x y -> shiftR x (fromIntegral y)))

160− (2, LB16AShr) total,

161− Prim (UN "prim__ashrB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (\x y -> fromIntegral $

162− shiftR (fromIntegral x :: Int16)

163− (fromIntegral y)))

164− (2, LB16LShr) total,

165− Prim (UN "prim__andB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (.&.))

166− (2, LB16And) total,

167− Prim (UN "prim__orB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin (.|.))

168− (2, LB16Or) total,

169− Prim (UN "prim__xorB16") (ty [B16Type, B16Type] B16Type) 2 (b16Bin xor)

170− (2, LB16Xor) total,

171− Prim (UN "prim__complB16") (ty [B16Type] B16Type) 1 (b16Un complement)

172− (1, LB16Compl) total,

173− Prim (UN "prim__zextB16_32") (ty [B16Type] B32Type) 1 zext16_32

174− (1, LB16Z32) total,

175− Prim (UN "prim__zextB16_64") (ty [B16Type] B64Type) 1 zext16_64

176− (1, LB16Z64) total,

177− Prim (UN "prim__sextB16_32") (ty [B16Type] B32Type) 1 sext16_32

178− (1, LB16Z32) total,

179− Prim (UN "prim__sextB16_64") (ty [B16Type] B64Type) 1 sext16_64

180− (1, LB16Z64) total,

181− Prim (UN "prim__truncB16_8") (ty [B16Type] B8Type) 1 trunc16_8

182− (1, LB16T8) total,

183−

184− Prim (UN "prim__ltB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (<))

185− (2, LB32Lt) total,

186− Prim (UN "prim__lteB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (<=))

187− (2, LB32Lte) total,

188− Prim (UN "prim__eqB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (==))

189− (2, LB32Eq) total,

190− Prim (UN "prim__gteB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (>))

191− (2, LB32Gte) total,

192− Prim (UN "prim__gtB32") (ty [B32Type, B32Type] IType) 2 (b32Cmp (>=))

193− (2, LB32Gt) total,

194− Prim (UN "prim__addB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (+))

195− (2, LB32Plus) total,

196− Prim (UN "prim__subB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (-))

197− (2, LB32Minus) total,

198− Prim (UN "prim__mulB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (*))

199− (2, LB32Times) total,

200− Prim (UN "prim__udivB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin div)

201− (2, LB32UDiv) partial,

202− Prim (UN "prim__sdivB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin s32div)

203− (2, LB32SDiv) partial,

204− Prim (UN "prim__uremB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin rem)

205− (2, LB32URem) partial,

206− Prim (UN "prim__sremB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin s32rem)

207− (2, LB32SRem) partial,

208− Prim (UN "prim__shlB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (\x y -> shiftL x (fromIntegral y)))

209− (2, LB32Shl) total,

210− Prim (UN "prim__lshrB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (\x y -> shiftR x (fromIntegral y)))

211− (2, LB32AShr) total,

212− Prim (UN "prim__ashrB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (\x y -> fromIntegral $

213− shiftR (fromIntegral x :: Int32)

214− (fromIntegral y)))

215− (2, LB32LShr) total,

216− Prim (UN "prim__andB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (.&.))

217− (2, LB32And) total,

218− Prim (UN "prim__orB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin (.|.))

219− (2, LB32Or) total,

220− Prim (UN "prim__xorB32") (ty [B32Type, B32Type] B32Type) 2 (b32Bin xor)

221− (2, LB32Xor) total,

222− Prim (UN "prim__complB32") (ty [B32Type] B32Type) 1 (b32Un complement)

223− (1, LB32Compl) total,

224− Prim (UN "prim__zextB32_64") (ty [B32Type] B64Type) 1 zext32_64

225− (1, LB32Z64) total,

226− Prim (UN "prim__sextB32_64") (ty [B32Type] B64Type) 1 sext32_64

227− (1, LB32Z64) total,

228− Prim (UN "prim__truncB32_8") (ty [B32Type] B8Type) 1 trunc32_8

229− (1, LB32T8) total,

230− Prim (UN "prim__truncB32_16") (ty [B32Type] B16Type) 1 trunc32_16

231− (1, LB32T16) total,

232−

233− Prim (UN "prim__ltB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (<))

234− (2, LB64Lt) total,

235− Prim (UN "prim__lteB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (<=))

236− (2, LB64Lte) total,

237− Prim (UN "prim__eqB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (==))

238− (2, LB64Eq) total,

239− Prim (UN "prim__gteB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (>))

240− (2, LB64Gte) total,

241− Prim (UN "prim__gtB64") (ty [B64Type, B64Type] IType) 2 (b64Cmp (>=))

242− (2, LB64Gt) total,

243− Prim (UN "prim__addB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (+))

244− (2, LB64Plus) total,

245− Prim (UN "prim__subB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (-))

246− (2, LB64Minus) total,

247− Prim (UN "prim__mulB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (*))

248− (2, LB64Times) total,

249− Prim (UN "prim__udivB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin div)

250− (2, LB64UDiv) partial,

251− Prim (UN "prim__sdivB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin s64div)

252− (2, LB64SDiv) partial,

253− Prim (UN "prim__uremB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin rem)

254− (2, LB64URem) partial,

255− Prim (UN "prim__sremB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin s64rem)

256− (2, LB64SRem) partial,

257− Prim (UN "prim__shlB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (\x y -> shiftL x (fromIntegral y)))

258− (2, LB64Shl) total,

259− Prim (UN "prim__lshrB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (\x y -> shiftR x (fromIntegral y)))

260− (2, LB64AShr) total,

261− Prim (UN "prim__ashrB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (\x y -> fromIntegral $

262− shiftR (fromIntegral x :: Int64)

263− (fromIntegral y)))

264− (2, LB64LShr) total,

265− Prim (UN "prim__andB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (.&.))

266− (2, LB64And) total,

267− Prim (UN "prim__orB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin (.|.))

268− (2, LB64Or) total,

269− Prim (UN "prim__xorB64") (ty [B64Type, B64Type] B64Type) 2 (b64Bin xor)

270− (2, LB64Xor) total,

271− Prim (UN "prim__complB64") (ty [B64Type] B64Type) 1 (b64Un complement)

272− (1, LB64Compl) total,

273− Prim (UN "prim__truncB64_8") (ty [B64Type] B8Type) 1 trunc64_8

274− (1, LB64T8) total,

275− Prim (UN "prim__truncB64_16") (ty [B64Type] B16Type) 1 trunc64_16

276− (1, LB64T16) total,

277− Prim (UN "prim__truncB64_32") (ty [B64Type] B32Type) 1 trunc64_32

278− (1, LB64T32) total,

279−

280− Prim (UN "prim__intToB8") (ty [IType] B8Type) 1 intToBits8

281− (1, LIntB8) total,

282− Prim (UN "prim__intToB16") (ty [IType] B16Type) 1 intToBits16

283− (1, LIntB16) total,

284− Prim (UN "prim__intToB32") (ty [IType] B32Type) 1 intToBits32

285− (1, LIntB32) total,

286− Prim (UN "prim__intToB64") (ty [IType] B64Type) 1 intToBits64

287− (1, LIntB64) total,

288− Prim (UN "prim__B32ToInt") (ty [B32Type] IType) 1 bits32ToInt

289− (1, LB32Int) total,

290−

291− Prim (UN "prim__addBigInt") (ty [BIType, BIType] BIType) 2 (bBin (+))

292− (2, LBPlus) total,

293− Prim (UN "prim__subBigInt") (ty [BIType, BIType] BIType) 2 (bBin (-))

294− (2, LBMinus) total,

295− Prim (UN "prim__mulBigInt") (ty [BIType, BIType] BIType) 2 (bBin (*))

296− (2, LBTimes) total,

297− Prim (UN "prim__divBigInt") (ty [BIType, BIType] BIType) 2 (bBin div)

298− (2, LBDiv) partial,

299− Prim (UN "prim__modBigInt") (ty [BIType, BIType] BIType) 2 (bBin mod)

300− (2, LBMod) partial,

301− Prim (UN "prim__eqBigInt") (ty [BIType, BIType] IType) 2 (bbBin (==))

302− (2, LBEq) total,

303− Prim (UN "prim__ltBigInt") (ty [BIType, BIType] IType) 2 (bbBin (<))

304− (2, LBLt) total,

305− Prim (UN "prim__lteBigInt") (ty [BIType, BIType] IType) 2 (bbBin (<=))

306− (2, LBLe) total,

307− Prim (UN "prim__gtBigInt") (ty [BIType, BIType] IType) 2 (bbBin (>))

308− (2, LBGt) total,

309− Prim (UN "prim__gtBigInt") (ty [BIType, BIType] IType) 2 (bbBin (>=))

310− (2, LBGe) total,

46+ (2, LGe ITNative) total,

47+

48+ iCoerce IT8 IT16 "zext" zext LZExt,

49+ iCoerce IT8 IT32 "zext" zext LZExt,

50+ iCoerce IT8 IT64 "zext" zext LZExt,

51+ iCoerce IT8 ITBig "zext" zext LZExt,

52+ iCoerce IT8 ITNative "zext" zext LZExt,

53+ iCoerce IT16 IT32 "zext" zext LZExt,

54+ iCoerce IT16 IT64 "zext" zext LZExt,

55+ iCoerce IT16 ITBig "zext" zext LZExt,

56+ iCoerce IT16 ITNative "zext" zext LZExt,

57+ iCoerce IT32 IT64 "zext" zext LZExt,

58+ iCoerce IT32 ITBig "zext" zext LZExt,

59+ iCoerce IT32 ITNative "zext" zext LZExt,

60+ iCoerce IT64 ITBig "zext" zext LZExt,

61+ iCoerce ITNative ITBig "zext" zext LZExt,

62+ iCoerce ITNative IT64 "zext" zext LZExt,

63+ iCoerce ITNative IT32 "zext" zext LZExt,

64+ iCoerce ITNative IT16 "zext" zext LZExt,

65+

66+ iCoerce IT8 IT16 "sext" sext LSExt,

67+ iCoerce IT8 IT32 "sext" sext LSExt,

68+ iCoerce IT8 IT64 "sext" sext LSExt,

69+ iCoerce IT8 ITBig "sext" sext LSExt,

70+ iCoerce IT8 ITNative "sext" sext LSExt,

71+ iCoerce IT16 IT32 "sext" sext LSExt,

72+ iCoerce IT16 IT64 "sext" sext LSExt,

73+ iCoerce IT16 ITBig "sext" sext LSExt,

74+ iCoerce IT16 ITNative "sext" sext LSExt,

75+ iCoerce IT32 IT64 "sext" sext LSExt,

76+ iCoerce IT32 ITBig "sext" sext LSExt,

77+ iCoerce IT32 ITNative "sext" sext LSExt,

78+ iCoerce IT64 ITBig "sext" sext LSExt,

79+ iCoerce ITNative ITBig "sext" sext LSExt,

80+ iCoerce ITNative ITBig "sext" sext LSExt,

81+ iCoerce ITNative IT64 "sext" sext LSExt,

82+ iCoerce ITNative IT32 "sext" sext LSExt,

83+ iCoerce ITNative IT16 "sext" sext LSExt,

84+

85+ iCoerce IT16 IT8 "trunc" trunc LTrunc,

86+ iCoerce IT32 IT8 "trunc" trunc LTrunc,

87+ iCoerce IT64 IT8 "trunc" trunc LTrunc,

88+ iCoerce ITBig IT8 "trunc" trunc LTrunc,

89+ iCoerce ITNative IT8 "trunc" trunc LTrunc,

90+ iCoerce IT32 IT16 "trunc" trunc LTrunc,

91+ iCoerce IT64 IT16 "trunc" trunc LTrunc,

92+ iCoerce ITBig IT16 "trunc" trunc LTrunc,

93+ iCoerce ITNative IT16 "trunc" trunc LTrunc,

94+ iCoerce IT64 IT32 "trunc" trunc LTrunc,

95+ iCoerce ITBig IT32 "trunc" trunc LTrunc,

96+ iCoerce ITNative IT32 "trunc" trunc LTrunc,

97+ iCoerce ITBig IT64 "trunc" trunc LTrunc,

98+ iCoerce IT16 ITNative "trunc" trunc LTrunc,

99+ iCoerce IT32 ITNative "trunc" trunc LTrunc,

100+ iCoerce IT64 ITNative "trunc" trunc LTrunc,

101+ iCoerce ITBig ITNative "trunc" trunc LTrunc,

102+ iCoerce ITNative IT64 "trunc" trunc LTrunc,

103+

311104 Prim (UN "prim__addFloat") (ty [FlType, FlType] FlType) 2 (fBin (+))

312105 (2, LFPlus) total,

313106 Prim (UN "prim__subFloat") (ty [FlType, FlType] FlType) 2 (fBin (-))

@@ -335,30 +128,14 @@ primitives =

335128 Prim (UN "prim_lenString") (ty [StrType] IType) 1 (p_strLen)

336129 (1, LStrLen) total,

337130 -- Conversions

338− Prim (UN "prim__strToInt") (ty [StrType] IType) 1 (c_strToInt)

339− (1, LStrInt) total,

340− Prim (UN "prim__intToStr") (ty [IType] StrType) 1 (c_intToStr)

341− (1, LIntStr) total,

342131 Prim (UN "prim__charToInt") (ty [ChType] IType) 1 (c_charToInt)

343− (1, LChInt) total,

132+ (1, LChInt ITNative) total,

344133 Prim (UN "prim__intToChar") (ty [IType] ChType) 1 (c_intToChar)

345− (1, LIntCh) total,

346− Prim (UN "prim__intToBigInt") (ty [IType] BIType) 1 (c_intToBigInt)

347− (1, LIntBig) total,

348− Prim (UN "prim__bigIntToInt") (ty [BIType] IType) 1 (c_bigIntToInt)

349− (1, LBigInt) total,

350− Prim (UN "prim__strToBigInt") (ty [StrType] BIType) 1 (c_strToBigInt)

351− (1, LStrBig) total,

352− Prim (UN "prim__bigIntToStr") (ty [BIType] StrType) 1 (c_bigIntToStr)

353− (1, LBigStr) total,

134+ (1, LIntCh ITNative) total,

354135 Prim (UN "prim__strToFloat") (ty [StrType] FlType) 1 (c_strToFloat)

355136 (1, LStrFloat) total,

356137 Prim (UN "prim__floatToStr") (ty [FlType] StrType) 1 (c_floatToStr)

357138 (1, LFloatStr) total,

358− Prim (UN "prim__intToFloat") (ty [IType] FlType) 1 (c_intToFloat)

359− (1, LIntFloat) total,

360− Prim (UN "prim__floatToInt") (ty [FlType] IType) 1 (c_floatToInt)

361− (1, LFloatInt) total,

362139

363140 Prim (UN "prim__floatExp") (ty [FlType] FlType) 1 (p_floatExp)

364141 (1, LFExp) total,

@@ -402,7 +179,49 @@ primitives =

402179 (0, LStdIn) partial,

403180 Prim (UN "prim__believe_me") believeTy 3 (p_believeMe)

404181 (3, LNoOp) partial -- ahem

405− ]

182+ ] ++ concatMap intOps [IT8, IT16, IT32, IT64, ITBig, ITNative]

183+

184+intOps ity =

185+ [ iCmp ity "lt" (bCmp ity (<)) LLt total

186+ , iCmp ity "lte" (bCmp ity (<=)) LLe total

187+ , iCmp ity "eq" (bCmp ity (==)) LEq total

188+ , iCmp ity "gte" (bCmp ity (>=)) LGe total

189+ , iCmp ity "gt" (bCmp ity (>)) LGt total

190+ , iBinOp ity "add" (bitBin ity (+)) LPlus total

191+ , iBinOp ity "sub" (bitBin ity (-)) LMinus total

192+ , iBinOp ity "mul" (bitBin ity (*)) LTimes total

193+ , iBinOp ity "udiv" (bitBin ity div) LUDiv partial

194+ , iBinOp ity "sdiv" (bsdiv ity) LSDiv partial

195+ , iBinOp ity "urem" (bitBin ity rem) LURem partial

196+ , iBinOp ity "srem" (bsrem ity) LSRem partial

197+ , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total

198+ , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total

199+ , iBinOp ity "ashr" (bashr ity) LASHR total

200+ , iBinOp ity "and" (bitBin ity (.&.)) LAnd total

201+ , iBinOp ity "or" (bitBin ity (.|.)) LOr total

202+ , iBinOp ity "xor" (bitBin ity (xor)) LXOr total

203+ , iUnOp ity "compl" (bUn ity complement) LCompl total

204+ , Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [intTyToConst ity] StrType) 1 intToStr

205+ (1, LIntStr ity) total

206+ , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (intTyToConst ity)) 1 (strToInt ity)

207+ (1, LStrInt ity) total

208+ , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [intTyToConst ity] FlType) 1 intToFloat

209+ (1, LIntFloat ity) total

210+ , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [FlType] (intTyToConst ity)) 1 (floatToInt ity)

211+ (1, LFloatInt ity) total

212+ ]

213+

214+intTyName :: IntTy -> String

215+intTyName ITNative = "Int"

216+intTyName ITBig = "BigInt"

217+intTyName sized = "B" ++ show (intTyWidth sized)

218+

219+iCmp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) IType) 2 impl (2, irop ity) totality

220+iBinOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) (intTyToConst ity)) 2 impl (2, irop ity) totality

221+iUnOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty [intTyToConst ity] (intTyToConst ity)) 1 impl (1, irop ity) totality

222+iCoerce from to op impl irop =

223+ Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)

224+ (ty [intTyToConst from] (intTyToConst to)) 1 (impl from to) (1, irop from to) total

406225

407226p_believeMe [_,_,x] = Just x

408227p_believeMe _ = Nothing

@@ -441,161 +260,127 @@ bsBin _ _ = Nothing

441260sBin op [VConstant (Str x), VConstant (Str y)] = Just $ VConstant (Str (op x y))

442261sBin _ _ = Nothing

443262

444−s8div :: Word8 -> Word8 -> Word8

445−s8div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int8)

446−

447−s16div :: Word16 -> Word16 -> Word16

448−s16div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int16)

449−

450−s32div :: Word32 -> Word32 -> Word32

451−s32div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int32)

452−

453−s64div :: Word64 -> Word64 -> Word64

454−s64div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int64)

455−

456−s8rem :: Word8 -> Word8 -> Word8

457−s8rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8)

458−

459−s16rem :: Word16 -> Word16 -> Word16

460−s16rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16)

461−

462−s32rem :: Word32 -> Word32 -> Word32

463−s32rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32)

464−

465−s64rem :: Word64 -> Word64 -> Word64

466−s64rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64)

467−

468−b8Bin op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (B8 (op x y))

469−b8Bin _ _ = Nothing

470−

471−b8Un op [VConstant (B8 x)] = Just $ VConstant (B8 (op x))

472−b8Un _ _ = Nothing

473−

474−b16Bin op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (B16 (op x y))

475−b16Bin _ _ = Nothing

476−

477−b16Un op [VConstant (B16 x)] = Just $ VConstant (B16 (op x))

478−b16Un _ _ = Nothing

479−

480−b32Bin op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (B32 (op x y))

481−b32Bin _ _ = Nothing

482−

483−b32Un op [VConstant (B32 x)] = Just $ VConstant (B32 (op x))

484−b32Un _ _ = Nothing

485−

486−b64Bin op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (B64 (op x y))

487−b64Bin _ _ = Nothing

488−

489−b64Un op [VConstant (B64 x)] = Just $ VConstant (B64 (op x))

490−b64Un _ _ = Nothing

491−

492−b8Cmp op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

493−b8Cmp _ _ = Nothing

494−

495−b16Cmp op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

496−b16Cmp _ _ = Nothing

497−

498−b32Cmp op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

499−b32Cmp _ _ = Nothing

500−

501−b64Cmp op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

502−b64Cmp _ _ = Nothing

503−

504−toB8 x = VConstant (B8 (fromIntegral x))

505−toB16 x = VConstant (B16 (fromIntegral x))

506−toB32 x = VConstant (B32 (fromIntegral x))

507−toB64 x = VConstant (B64 (fromIntegral x))

508−

509−zext8_16 [VConstant (B8 x)] = Just $ toB16 x

510−zext8_16 _ = Nothing

511−

512−zext8_32 [VConstant (B8 x)] = Just $ toB32 x

513−zext8_32 _ = Nothing

514−

515−zext8_64 [VConstant (B8 x)] = Just $ toB64 x

516−zext8_64 _ = Nothing

517−

518−sext8_16 [VConstant (B8 x)] = Just $ toB16 (fromIntegral x :: Int8)

519−sext8_16 _ = Nothing

520−

521−sext8_32 [VConstant (B8 x)] = Just $ toB32 (fromIntegral x :: Int8)

522−sext8_32 _ = Nothing

523−

524−sext8_64 [VConstant (B8 x)] = Just $ toB64 (fromIntegral x :: Int8)

525−sext8_64 _ = Nothing

526−

527−zext16_32 [VConstant (B16 x)] = Just $ toB32 x

528−zext16_32 _ = Nothing

529−

530−zext16_64 [VConstant (B16 x)] = Just $ toB64 x

531−zext16_64 _ = Nothing

532−

533−sext16_32 [VConstant (B16 x)] = Just $ toB32 (fromIntegral x :: Int16)

534−sext16_32 _ = Nothing

535−

536−sext16_64 [VConstant (B16 x)] = Just $ toB64 (fromIntegral x :: Int16)

537−sext16_64 _ = Nothing

538−

539−trunc16_8 [VConstant (B16 x)] = Just $ toB8 x

540−trunc16_8 _ = Nothing

541−

542−zext32_64 [VConstant (B32 x)] = Just $ toB64 x

543−zext32_64 _ = Nothing

544−

545−sext32_64 [VConstant (B32 x)] = Just $ toB64 (fromIntegral x :: Int32)

546−sext32_64 _ = Nothing

547−

548−trunc32_8 [VConstant (B32 x)] = Just $ toB8 x

549−trunc32_8 _ = Nothing

550−

551−trunc32_16 [VConstant (B32 x)] = Just $ toB16 x

552−trunc32_16 _ = Nothing

553−

554−trunc64_8 [VConstant (B64 x)] = Just $ toB8 x

555−trunc64_8 _ = Nothing

556−

557−trunc64_16 [VConstant (B64 x)] = Just $ toB16 x

558−trunc64_16 _ = Nothing

559−

560−trunc64_32 [VConstant (B64 x)] = Just $ toB32 x

561−trunc64_32 _ = Nothing

562−

563−intToBits8 [VConstant (I x)] = Just $ toB8 x

564−intToBits8 _ = Nothing

565−intToBits16 [VConstant (I x)] = Just $ toB16 x

566−intToBits16 _ = Nothing

567−intToBits32 [VConstant (I x)] = Just $ toB32 x

568−intToBits32 _ = Nothing

569−intToBits64 [VConstant (I x)] = Just $ toB64 x

570−intToBits64 _ = Nothing

571−

572−bits32ToInt [VConstant (B32 x)] = Just $ VConstant (I (fromIntegral x))

573−bits32ToInt _ = Nothing

574−

575−c_intToStr [VConstant (I x)] = Just $ VConstant (Str (show x))

576−c_intToStr _ = Nothing

577−c_strToInt [VConstant (Str x)] = case reads x of

578− [(n,"")] -> Just $ VConstant (I n)

579− _ -> Just $ VConstant (I 0)

580−c_strToInt _ = Nothing

263+bsrem IT8 [VConstant (B8 x), VConstant (B8 y)]

264+ = Just $ VConstant (B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8)))

265+bsrem IT16 [VConstant (B16 x), VConstant (B16 y)]

266+ = Just $ VConstant (B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16)))

267+bsrem IT32 [VConstant (B32 x), VConstant (B32 y)]

268+ = Just $ VConstant (B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32)))

269+bsrem IT64 [VConstant (B64 x), VConstant (B64 y)]

270+ = Just $ VConstant (B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64)))

271+bsrem ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `rem` y))

272+bsrem _ _ = Nothing

273+

274+bsdiv IT8 [VConstant (B8 x), VConstant (B8 y)]

275+ = Just $ VConstant (B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8)))

276+bsdiv IT16 [VConstant (B16 x), VConstant (B16 y)]

277+ = Just $ VConstant (B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16)))

278+bsdiv IT32 [VConstant (B32 x), VConstant (B32 y)]

279+ = Just $ VConstant (B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32)))

280+bsdiv IT64 [VConstant (B64 x), VConstant (B64 y)]

281+ = Just $ VConstant (B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64)))

282+bsdiv ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `div` y))

283+bsdiv _ _ = Nothing

284+

285+bashr IT8 [VConstant (B8 x), VConstant (B8 y)]

286+ = Just $ VConstant (B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8)))

287+bashr IT16 [VConstant (B16 x), VConstant (B16 y)]

288+ = Just $ VConstant (B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16)))

289+bashr IT32 [VConstant (B32 x), VConstant (B32 y)]

290+ = Just $ VConstant (B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32)))

291+bashr IT64 [VConstant (B64 x), VConstant (B64 y)]

292+ = Just $ VConstant (B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64)))

293+bashr ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `shiftR` y))

294+bashr _ _ = Nothing

295+

296+bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Value] -> Maybe Value

297+bUn IT8 op [VConstant (B8 x)] = Just $ VConstant (B8 (op x))

298+bUn IT16 op [VConstant (B16 x)] = Just $ VConstant (B16 (op x))

299+bUn IT32 op [VConstant (B32 x)] = Just $ VConstant (B32 (op x))

300+bUn IT64 op [VConstant (B64 x)] = Just $ VConstant (B64 (op x))

301+bUn ITBig op [VConstant (BI x)] = Just $ VConstant (BI (op x))

302+bUn ITNative op [VConstant (I x)] = Just $ VConstant (I (op x))

303+bUn _ _ _ = Nothing

304+

305+bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Value] -> Maybe Value

306+bitBin IT8 op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (B8 (op x y))

307+bitBin IT16 op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (B16 (op x y))

308+bitBin IT32 op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (B32 (op x y))

309+bitBin IT64 op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (B64 (op x y))

310+bitBin ITBig op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (BI (op x y))

311+bitBin ITNative op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (op x y))

312+bitBin _ _ _ = Nothing

313+

314+bCmp :: IntTy -> (forall a. Ord a => a -> a -> Bool) -> [Value] -> Maybe Value

315+bCmp IT8 op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

316+bCmp IT16 op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

317+bCmp IT32 op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

318+bCmp IT64 op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

319+bCmp ITBig op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

320+bCmp ITNative op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

321+bCmp _ _ _ = Nothing

322+

323+toInt IT8 x = VConstant (B8 (fromIntegral x))

324+toInt IT16 x = VConstant (B16 (fromIntegral x))

325+toInt IT32 x = VConstant (B32 (fromIntegral x))

326+toInt IT64 x = VConstant (B64 (fromIntegral x))

327+toInt ITBig x = VConstant (BI (fromIntegral x))

328+toInt ITNative x = VConstant (I (fromIntegral x))

329+

330+intToInt IT8 out [VConstant (B8 x)] = Just $ toInt out x

331+intToInt IT16 out [VConstant (B16 x)] = Just $ toInt out x

332+intToInt IT32 out [VConstant (B32 x)] = Just $ toInt out x

333+intToInt IT64 out [VConstant (B64 x)] = Just $ toInt out x

334+intToInt ITBig out [VConstant (BI x)] = Just $ toInt out x

335+intToInt ITNative out [VConstant (I x)] = Just $ toInt out x

336+intToInt _ _ _ = Nothing

337+

338+zext from ITBig val = intToInt from ITBig val

339+zext ITBig _ _ = Nothing

340+zext from to val

341+ | intTyWidth from < intTyWidth to = intToInt from to val

342+zext _ _ _ = Nothing

343+

344+sext IT8 out [VConstant (B8 x)] = Just $ toInt out (fromIntegral x :: Int8)

345+sext IT16 out [VConstant (B16 x)] = Just $ toInt out (fromIntegral x :: Int16)

346+sext IT32 out [VConstant (B32 x)] = Just $ toInt out (fromIntegral x :: Int32)

347+sext IT64 out [VConstant (B64 x)] = Just $ toInt out (fromIntegral x :: Int64)

348+sext ITBig _ _ = Nothing

349+sext from to val = intToInt from to val

350+

351+trunc ITBig to val = intToInt ITBig to val

352+trunc _ ITBig _ = Nothing

353+trunc from to val | intTyWidth from > intTyWidth to = intToInt from to val

354+trunc _ _ _ = Nothing

355+

356+getInt :: [Value] -> Maybe Integer

357+getInt [VConstant (B8 x)] = Just . toInteger $ x

358+getInt [VConstant (B16 x)] = Just . toInteger $ x

359+getInt [VConstant (B32 x)] = Just . toInteger $ x

360+getInt [VConstant (B64 x)] = Just . toInteger $ x

361+getInt [VConstant (I x)] = Just . toInteger $ x

362+getInt [VConstant (BI x)] = Just x

363+getInt _ = Nothing

364+

365+intToStr val | Just i <- getInt val = Just $ VConstant (Str (show i))

366+intToStr _ = Nothing

367+

368+strToInt ity [VConstant (Str x)] = case reads x of

369+ [(n,"")] -> Just $ toInt ity (n :: Integer)

370+ _ -> Just $ VConstant (I 0)

371+strToInt _ _ = Nothing

372+

373+intToFloat val | Just i <- getInt val = Just $ VConstant (Fl (fromIntegral i))

374+intToFloat _ = Nothing

375+

376+floatToInt ity [VConstant (Fl x)] = Just $ toInt ity (truncate x :: Integer)

377+floatToInt _ _ = Nothing

581378

582379c_intToChar [VConstant (I x)] = Just $ VConstant (Ch (toEnum x))

583380c_intToChar _ = Nothing

584381c_charToInt [VConstant (Ch x)] = Just $ VConstant (I (fromEnum x))

585382c_charToInt _ = Nothing

586383

587−c_intToBigInt [VConstant (I x)] = Just $ VConstant (BI (fromIntegral x))

588−c_intToBigInt _ = Nothing

589−c_bigIntToInt [VConstant (BI x)] = Just $ VConstant (I (fromInteger x))

590−c_bigIntToInt _ = Nothing

591−

592−c_bigIntToStr [VConstant (BI x)] = Just $ VConstant (Str (show x))

593−c_bigIntToStr _ = Nothing

594−c_strToBigInt [VConstant (Str x)] = case reads x of

595− [(n,"")] -> Just $ VConstant (BI n)

596− _ -> Just $ VConstant (BI 0)

597−c_strToBigInt _ = Nothing

598−

599384c_floatToStr [VConstant (Fl x)] = Just $ VConstant (Str (show x))

600385c_floatToStr _ = Nothing

601386c_strToFloat [VConstant (Str x)] = case reads x of

@@ -603,12 +388,6 @@ c_strToFloat [VConstant (Str x)] = case reads x of

603388 _ -> Just $ VConstant (Fl 0)

604389c_strToFloat _ = Nothing

605390

606−c_floatToInt [VConstant (Fl x)] = Just $ VConstant (I (truncate x))

607−c_floatToInt _ = Nothing

608−

609−c_intToFloat [VConstant (I x)] = Just $ VConstant (Fl (fromIntegral x))

610−c_intToFloat _ = Nothing

611−

612391p_fPrim f [VConstant (Fl x)] = Just $ VConstant (Fl (f x))

613392p_fPrim f _ = Nothing

614393

@@ -625,6 +404,7 @@ p_floatFloor = p_fPrim (fromInteger . floor)

625404p_floatCeil = p_fPrim (fromInteger . ceiling)

626405

627406p_strLen [VConstant (Str xs)] = Just $ VConstant (I (length xs))

407+p_strLen _ = Nothing

628408p_strHead [VConstant (Str (x:xs))] = Just $ VConstant (Ch x)

629409p_strHead _ = Nothing

630410p_strTail [VConstant (Str (x:xs))] = Just $ VConstant (Str xs)

src/Idris/Prover.hs+3−3

@@ -26,7 +26,7 @@ prover :: Bool -> Name -> Idris ()

2626prover lit x =

2727 do ctxt <- getContext

2828 i <- getIState

29− case lookupTy Nothing x ctxt of

29+ case lookupTy x ctxt of

3030 [t] -> if elem x (idris_metavars i)

3131 then prove ctxt lit x t

3232 else fail $ show x ++ " is not a metavariable"

@@ -78,9 +78,9 @@ elabStep st e = do case runStateT e st of

7878 fail (pshow i a)

7979

8080dumpState :: IState -> ProofState -> IO ()

81−dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _) =

81+dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _) =

8282 putStrLn . render $ pretty nm <> colon <+> text "No more goals."

83−dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ problems i _ _ ctxy _ _) = do

83+dumpState ist ps@(PS nm (h:hs) _ _ tm _ _ _ _ _ _ problems i _ _ ctxy _ _) = do

8484 let OK ty = goalAtFocus ps

8585 let OK env = envAtFocus ps

8686 putStrLn . render $

src/Idris/Providers.hs+18−4

@@ -1,14 +1,28 @@

1−module Idris.Providers where

1+{-# LANGUAGE PatternGuards #-}

2+module Idris.Providers (providerTy, getProvided) where

23

34import Core.TT

45import Core.Evaluate

6+import Core.Execute

57import Idris.AbsSyntax

68import Idris.AbsSyntaxTree

9+import Idris.Error

10+

11+import Debug.Trace

712

813-- | Wrap a type provider in the type of type providers

914providerTy :: FC -> PTerm -> PTerm

1015providerTy fc tm = PApp fc (PRef fc $ UN "Provider") [PExp 0 False tm ""]

1116

12−-- | Wrap the RHS of a type provider definition

13−unProv :: FC -> PTerm -> PTerm

14−unProv fc tm = PApp fc (PRef fc $ NS (UN "unProv") ["Providers"]) [PExp 0 False tm ""]

17+-- | Handle an error, if the type provider returned an error. Otherwise return the provided term.

18+getProvided :: TT Name -> Idris (TT Name)

19+getProvided tm | (P _ (UN "io_return") _, [tp, result]) <- unApply tm

20+ , (P _ (NS (UN "Error") ["Providers"]) _, [_, err]) <- unApply result =

21+ case err of

22+ Constant (Str msg) -> ierror . ProviderError $ msg

23+ _ -> fail "Internal error in type provider, non-normalised error"

24+ | (P _ (UN "io_return") _, [tp, result]) <- unApply tm

25+ , (P _ (NS (UN "Provide") ["Providers"]) _, [_, res]) <- unApply result =

26+ return res

27+ | otherwise = fail $ "Internal type provider error: result was not " ++

28+ "IO (Provider a), or perhaps missing normalisation."

src/Idris/REPL.hs+202−85

@@ -18,6 +18,7 @@ import Idris.UnusedArgs

1818import Idris.Docs

1919import Idris.Help

2020import Idris.Completion

21+import Idris.IdeSlave

2122

2223import Paths_idris

2324import Util.System

@@ -80,6 +81,104 @@ repl orig mods

8081 ctrlC e = do lift $ iputStrLn (show e)

8182 repl orig mods

8283

84+-- | Run the IdeSlave

85+ideslaveStart :: IState -> [FilePath] -> Idris ()

86+ideslaveStart orig mods

87+ = do i <- getIState

88+ case idris_outputmode i of

89+ IdeSlave n ->

90+ when (mods /= []) (do liftIO $ putStrLn $ convSExp "set-prompt" (mkPrompt mods) n)

91+ ideslave orig mods

92+

93+

94+ideslave :: IState -> [FilePath] -> Idris ()

95+ideslave orig mods

96+ = do idrisCatch

97+ (do l <- liftIO $ getLine

98+ let (sexp, id) = parseMessage l

99+ i <- getIState

100+ putIState $ i { idris_outputmode = (IdeSlave id) }

101+ case sexpToCommand sexp of

102+ Just (Interpret cmd) ->

103+ do let fn = case mods of

104+ (f:_) -> f

105+ _ -> ""

106+ case parseCmd i cmd of

107+ Left err -> iFail $ show err

108+ Right cmd -> idrisCatch

109+ (do ideslaveProcess fn cmd)

110+ (\e -> do iFail $ show e)

111+ Just (REPLCompletions str) ->

112+ do (unused, compls) <- replCompletion (reverse str, "")

113+ let good = SexpList [SymbolAtom "ok", toSExp (map replacement compls, reverse unused)]

114+ liftIO $ putStrLn $ convSExp "return" good id

115+ Just (LoadFile filename) ->

116+ do clearErr

117+ putIState (orig { idris_options = idris_options i,

118+ idris_outputmode = (IdeSlave id) })

119+ loadModule filename

120+ iucheck

121+ liftIO $ putStrLn $ convSExp "set-prompt" (mkPrompt [filename]) id

122+ -- report success! or failure!

123+ ideslave orig [filename]

124+ Nothing -> do iFail "did not understand")

125+ (\e -> do iFail $ show e)

126+ ideslave orig mods

127+

128+ideslaveProcess :: FilePath -> Command -> Idris ()

129+ideslaveProcess fn Help = process fn Help

130+ideslaveProcess fn (ChangeDirectory f) = do process fn (ChangeDirectory f)

131+ iResult "changed directory to"

132+ideslaveProcess fn (Eval t) = process fn (Eval t)

133+ideslaveProcess fn (ExecVal t) = process fn (ExecVal t)

134+ideslaveProcess fn (Check (PRef x n)) = process fn (Check (PRef x n))

135+ideslaveProcess fn (Check t) = process fn (Check t)

136+ideslaveProcess fn (DocStr n) = process fn (DocStr n)

137+ideslaveProcess fn Universes = process fn Universes

138+ideslaveProcess fn (Defn n) = do process fn (Defn n)

139+ iResult ""

140+ideslaveProcess fn (TotCheck n) = process fn (TotCheck n)

141+ideslaveProcess fn (DebugInfo n) = do process fn (DebugInfo n)

142+ iResult ""

143+ideslaveProcess fn (Info n) = process fn (Info n)

144+ideslaveProcess fn (Search t) = process fn (Search t)

145+ideslaveProcess fn (Spec t) = process fn (Spec t)

146+-- RmProof and AddProof not supported!

147+ideslaveProcess fn (ShowProof n') = process fn (ShowProof n')

148+ideslaveProcess fn (Prove n') = process fn (Prove n')

149+ideslaveProcess fn (HNF t) = process fn (HNF t)

150+--ideslaveProcess fn TTShell = process fn TTShell -- need some prove mode!

151+

152+--that most likely does not work, since we need to wrap

153+--input/output of the executed binary...

154+ideslaveProcess fn Execute = do process fn Execute

155+ iResult ""

156+ideslaveProcess fn (NewCompile f) = do process fn (NewCompile f)

157+ iResult ""

158+ideslaveProcess fn (Compile target f) = do process fn (Compile target f)

159+ iResult ""

160+ideslaveProcess fn (LogLvl i) = do process fn (LogLvl i)

161+ iResult ""

162+ideslaveProcess fn (Pattelab t) = process fn (Pattelab t)

163+ideslaveProcess fn (Missing n) = process fn (Missing n)

164+ideslaveProcess fn (DynamicLink l) = do process fn (DynamicLink l)

165+ iResult ""

166+ideslaveProcess fn ListDynamic = do process fn ListDynamic

167+ iResult ""

168+ideslaveProcess fn Metavars = process fn Metavars

169+ideslaveProcess fn (SetOpt ErrContext) = do process fn (SetOpt ErrContext)

170+ iResult ""

171+ideslaveProcess fn (UnsetOpt ErrContext) = do process fn (UnsetOpt ErrContext)

172+ iResult ""

173+ideslaveProcess fn (SetOpt ShowImpl) = do process fn (SetOpt ShowImpl)

174+ iResult ""

175+ideslaveProcess fn (UnsetOpt ShowImpl) = do process fn (UnsetOpt ShowImpl)

176+ iResult ""

177+ideslaveProcess fn (SetOpt x) = process fn (SetOpt x)

178+ideslaveProcess fn (UnsetOpt x) = process fn (UnsetOpt x)

179+ideslaveProcess fn _ = iFail "command not recognized or not supported"

180+

181+

83182-- | The prompt consists of the currently loaded modules, or "Idris" if there are none

84183mkPrompt [] = "Idris"

85184mkPrompt [x] = "*" ++ dropExtension x

@@ -129,7 +228,7 @@ resolveProof :: Name -> Idris Name

129228resolveProof n'

130229 = do i <- getIState

131230 ctxt <- getContext

132− n <- case lookupNames Nothing n' ctxt of

231+ n <- case lookupNames n' ctxt of

133232 [x] -> return x

134233 [] -> return n'

135234 ns -> fail $ pshow i (CantResolveAlts (map show ns))

@@ -173,112 +272,115 @@ proofs orig

173272

174273insertScript :: String -> [String] -> [String]

175274insertScript prf [] = "\n---------- Proofs ----------" : "" : [prf]

176−insertScript prf (p@"---------- Proofs ----------" : "" : xs)

275+insertScript prf (p@"---------- Proofs ----------" : "" : xs)

177276 = p : "" : prf : xs

178277insertScript prf (x : xs) = x : insertScript prf xs

179278

180279process :: FilePath -> Command -> Idris ()

181−process fn Help = iputStrLn displayHelp

182−process fn (Eval t)

280+process fn Help = iResult displayHelp

281+process fn (ChangeDirectory f)

282+ = do liftIO $ setCurrentDirectory f

283+ return ()

284+process fn (Eval t)

183285 = do (tm, ty) <- elabVal toplevel False t

184286 ctxt <- getContext

185− ist <- getIState

287+ ist <- getIState

186288 let tm' = normaliseAll ctxt [] tm

187289 let ty' = normaliseAll ctxt [] ty

188290 logLvl 3 $ "Raw: " ++ show (tm', ty')

189291 imp <- impShow

190− iputStrLn (showImp imp (delab ist tm') ++ " : " ++

191− showImp imp (delab ist ty'))

292+ iResult (showImp imp (delab ist tm') ++ " : " ++

293+ showImp imp (delab ist ty'))

192294process fn (ExecVal t)

193295 = do ctxt <- getContext

194296 ist <- getIState

195297 (tm, ty) <- elabVal toplevel False t

196− let tm' = normaliseAll ctxt [] tm

298+-- let tm' = normaliseAll ctxt [] tm

197299 let ty' = normaliseAll ctxt [] ty

198− res <- execute tm'

300+ res <- execute tm

199301 imp <- impShow

200− iputStrLn (showImp imp (delab ist res) ++ " : " ++

201− showImp imp (delab ist ty'))

202− return ()

302+ iResult (showImp imp (delab ist res) ++ " : " ++

303+ showImp imp (delab ist ty'))

203304process fn (Check (PRef _ n))

204− = do ctxt <- getContext

205− ist <- getIState

206− imp <- impShow

207− case lookupTy Nothing n ctxt of

208− ts@(_:_) -> mapM_ (\t -> iputStrLn $ show n ++ " : " ++

209− showImp imp (delab ist t)) ts

210− [] -> iputStrLn $ "No such variable " ++ show n

305+ = do ctxt <- getContext

306+ ist <- getIState

307+ imp <- impShow

308+ case lookupNames n ctxt of

309+ ts@(_:_) -> do mapM_ (\n -> iputStrLn $ show n ++ " : " ++

310+ showImp imp (delabTy ist n)) ts

311+ iResult ""

312+ [] -> iFail $ "No such variable " ++ show n

211313process fn (Check t) = do (tm, ty) <- elabVal toplevel False t

212314 ctxt <- getContext

213− ist <- getIState

315+ ist <- getIState

214316 imp <- impShow

215317 let ty' = normaliseC ctxt [] ty

216− iputStrLn (showImp imp (delab ist tm) ++ " : " ++

217− showImp imp (delab ist ty))

318+ iResult (showImp imp (delab ist tm) ++ " : " ++

319+ showImp imp (delab ist ty))

218320

219321process fn (DocStr n) = do i <- getIState

220− case lookupCtxtName Nothing n (idris_docstrings i) of

221− [] -> iputStrLn $ "No documentation for " ++ show n

222− ns -> mapM_ showDoc ns

223− where showDoc (n, d)

322+ case lookupCtxtName n (idris_docstrings i) of

323+ [] -> iFail $ "No documentation for " ++ show n

324+ ns -> do mapM_ showDoc ns

325+ iResult ""

326+ where showDoc (n, d)

224327 = do doc <- getDocs n

225328 iputStrLn $ show doc

226329process fn Universes = do i <- getIState

227330 let cs = idris_constraints i

228331-- iputStrLn $ showSep "\n" (map show cs)

229− liftIO $ print (map fst cs)

332+ iputStrLn $ show (map fst cs)

230333 let n = length cs

231334 iputStrLn $ "(" ++ show n ++ " constraints)"

232335 case ucheck cs of

233− Error e -> iputStrLn $ pshow i e

234− OK _ -> iputStrLn "Universes OK"

336+ Error e -> iFail $ pshow i e

337+ OK _ -> iResult "Universes OK"

235338process fn (Defn n) = do i <- getIState

236339 iputStrLn "Compiled patterns:\n"

237− liftIO $ print (lookupDef Nothing n (tt_ctxt i))

238− case lookupCtxt Nothing n (idris_patdefs i) of

340+ iputStrLn $ show (lookupDef n (tt_ctxt i))

341+ case lookupCtxt n (idris_patdefs i) of

239342 [] -> return ()

240− [d] -> do iputStrLn "Original definiton:\n"

241− mapM_ (printCase i) d

343+ [(d, _)] -> do iputStrLn "Original definiton:\n"

344+ mapM_ (printCase i) d

242345 case lookupTotal n (tt_ctxt i) of

243346 [t] -> iputStrLn (showTotal t i)

244347 _ -> return ()

245− where printCase i (_, lhs, rhs)

246− = do liftIO $ putStr $ showImp True (delab i lhs)

247− liftIO $ putStr " = "

248− liftIO $ putStrLn $ showImp True (delab i rhs)

348+ where printCase i (_, lhs, rhs)

349+ = do iputStrLn (showImp True (delab i lhs) ++ " = " ++

350+ showImp True (delab i rhs))

249351process fn (TotCheck n) = do i <- getIState

250352 case lookupTotal n (tt_ctxt i) of

251− [t] -> iputStrLn (showTotal t i)

252− _ -> return ()

253−process fn (DebugInfo n)

353+ [t] -> iResult (showTotal t i)

354+ _ -> do iFail ""

355+ return ()

356+process fn (DebugInfo n)

254357 = do i <- getIState

255− let oi = lookupCtxtName Nothing n (idris_optimisation i)

358+ let oi = lookupCtxtName n (idris_optimisation i)

256359 when (not (null oi)) $ iputStrLn (show oi)

257− let si = lookupCtxt Nothing n (idris_statics i)

360+ let si = lookupCtxt n (idris_statics i)

258361 when (not (null si)) $ iputStrLn (show si)

259− let di = lookupCtxt Nothing n (idris_datatypes i)

362+ let di = lookupCtxt n (idris_datatypes i)

260363 when (not (null di)) $ iputStrLn (show di)

261− let d = lookupDef Nothing n (tt_ctxt i)

262− when (not (null d)) $ liftIO $

263− do print (head d)

264− let cg = lookupCtxtName Nothing n (idris_callgraph i)

364+ let d = lookupDef n (tt_ctxt i)

365+ when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

366+ let cg = lookupCtxtName n (idris_callgraph i)

265367 findUnusedArgs (map fst cg)

266368 i <- getIState

267− let cg' = lookupCtxtName Nothing n (idris_callgraph i)

369+ let cg' = lookupCtxtName n (idris_callgraph i)

268370 sc <- checkSizeChange n

269371 iputStrLn $ "Size change: " ++ show sc

270372 when (not (null cg')) $ do iputStrLn "Call graph:\n"

271373 iputStrLn (show cg')

272374process fn (Info n) = do i <- getIState

273− case lookupCtxt Nothing n (idris_classes i) of

375+ case lookupCtxt n (idris_classes i) of

274376 [c] -> classInfo c

275− _ -> iputStrLn "Not a class"

276−process fn (Search t) = iputStrLn "Not implemented"

377+ _ -> iFail "Not a class"

378+process fn (Search t) = iFail "Not implemented"

277379process fn (Spec t) = do (tm, ty) <- elabVal toplevel False t

278380 ctxt <- getContext

279381 ist <- getIState

280382 let tm' = simplify ctxt True [] {- (idris_statics ist) -} tm

281− iputStrLn (show (delab ist tm'))

383+ iResult (show (delab ist tm'))

282384

283385process fn (RmProof n')

284386 = do i <- getIState

@@ -296,8 +398,17 @@ process fn (RmProof n')

296398 let ms = idris_metavars i

297399 putIState $ i { idris_metavars = n : ms }

298400

299−process fn (AddProof prf)

300− = do let fb = fn ++ "~"

401+process fn' (AddProof prf)

402+ = do fn <- do

403+ ex <- liftIO $ doesFileExist fn'

404+ let fnExt = fn' <.> "idr"

405+ exExt <- liftIO $ doesFileExist fnExt

406+ if ex

407+ then return fn'

408+ else if exExt

409+ then return fnExt

410+ else fail $ "Neither \""++fn'++"\" nor \""++fnExt++"\" exist"

411+ let fb = fn ++ "~"

301412 liftIO $ copyFile fn fb -- make a backup in case something goes wrong!

302413 prog <- liftIO $ readFile fb

303414 i <- getIState

@@ -321,13 +432,13 @@ process fn (ShowProof n')

321432 n <- resolveProof n'

322433 let proofs = proof_list i

323434 case lookup n proofs of

324− Nothing -> iputStrLn "No proof to show"

325− Just p -> iputStrLn $ showProof False n p

435+ Nothing -> iFail "No proof to show"

436+ Just p -> iResult $ showProof False n p

326437

327438process fn (Prove n')

328439 = do ctxt <- getContext

329440 ist <- getIState

330− n <- case lookupNames Nothing n' ctxt of

441+ n <- case lookupNames n' ctxt of

331442 [x] -> return x

332443 [] -> return n'

333444 ns -> fail $ pshow ist (CantResolveAlts (map show ns))

@@ -342,13 +453,13 @@ process fn (HNF t) = do (tm, ty) <- elabVal toplevel False t

342453 ctxt <- getContext

343454 ist <- getIState

344455 let tm' = hnf ctxt [] tm

345− iputStrLn (show (delab ist tm'))

456+ iResult (show (delab ist tm'))

346457process fn TTShell = do ist <- getIState

347458 let shst = initState (tt_ctxt ist)

348459 runShell shst

349460 return ()

350−process fn Execute = do (m, _) <- elabVal toplevel False

351− (PApp fc

461+process fn Execute = do (m, _) <- elabVal toplevel False

462+ (PApp fc

352463 (PRef fc (UN "run__IO"))

353464 [pexp $ PRef fc (NS (UN "main") ["Main"])])

354465-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

@@ -358,37 +469,37 @@ process fn Execute = do (m, _) <- elabVal toplevel False

358469 compile t tmpn m

359470 liftIO $ system tmpn

360471 return ()

361− where fc = FC "main" 0

362−process fn (NewCompile f)

472+ where fc = FC "main" 0

473+process fn (NewCompile f)

363474 = do (m, _) <- elabVal toplevel False

364475 (PApp fc (PRef fc (UN "run__IO"))

365476 [pexp $ PRef fc (NS (UN "main") ["Main"])])

366477 compileEpic f m

367− where fc = FC "main" 0

368−process fn (Compile target f)

478+ where fc = FC "main" 0

479+process fn (Compile target f)

369480 = do (m, _) <- elabVal toplevel False

370481 (PApp fc (PRef fc (UN "run__IO"))

371482 [pexp $ PRef fc (NS (UN "main") ["Main"])])

372483 compile target f m

373− where fc = FC "main" 0

374−process fn (LogLvl i) = setLogLevel i

484+ where fc = FC "main" 0

485+process fn (LogLvl i) = setLogLevel i

375486-- Elaborate as if LHS of a pattern (debug command)

376−process fn (Pattelab t)

487+process fn (Pattelab t)

377488 = do (tm, ty) <- elabVal toplevel True t

378− iputStrLn $ show tm ++ "\n\n : " ++ show ty

379−

380−process fn (Missing n) = do i <- getIState

381− case lookupDef Nothing n (tt_ctxt i) of

382− [CaseOp _ _ _ _ _ args t _ _]

383− -> do tms <- genMissing n args t

384− iputStrLn (showSep "\n" (map (showImp True) tms))

385− [] -> iputStrLn $ show n ++ " undefined"

386− _ -> iputStrLn $ "Ambiguous name"

489+ iResult $ show tm ++ "\n\n : " ++ show ty

490+

491+process fn (Missing n)

492+ = do i <- getIState

493+ case lookupCtxt n (idris_patdefs i) of

494+ [] -> return ()

495+ [(_, tms)] ->

496+ iResult (showSep "\n" (map (showImp True) tms))

497+ _ -> iFail $ "Ambiguous name"

387498process fn (DynamicLink l) = do i <- getIState

388499 let lib = trim l

389500 handle <- lift $ tryLoadLib lib

390501 case handle of

391− Nothing -> iputStrLn $ "Could not load dynamic lib \"" ++ l ++ "\""

502+ Nothing -> iFail $ "Could not load dynamic lib \"" ++ l ++ "\""

392503 Just x -> do let libs = idris_dynamic_libs i

393504 putIState $ i { idris_dynamic_libs = x:libs }

394505 where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace

@@ -401,8 +512,8 @@ process fn Metavars

401512 = do ist <- getIState

402513 let mvs = idris_metavars ist \\ primDefs

403514 case mvs of

404− [] -> iputStrLn "No global metavariables to solve"

405− _ -> iputStrLn $ "Global metavariables:\n\t" ++ show mvs

515+ [] -> iFail "No global metavariables to solve"

516+ _ -> iResult $ "Global metavariables:\n\t" ++ show mvs

406517process fn NOP = return ()

407518

408519process fn (SetOpt ErrContext) = setErrContext True

@@ -410,8 +521,8 @@ process fn (UnsetOpt ErrContext) = setErrContext False

410521process fn (SetOpt ShowImpl) = setImpShow True

411522process fn (UnsetOpt ShowImpl) = setImpShow False

412523

413−process fn (SetOpt _) = iputStrLn "Not a valid option"

414−process fn (UnsetOpt _) = iputStrLn "Not a valid option"

524+process fn (SetOpt _) = iFail "Not a valid option"

525+process fn (UnsetOpt _) = iFail "Not a valid option"

415526

416527

417528classInfo :: ClassInfo -> Idris ()

@@ -420,6 +531,7 @@ classInfo ci = do iputStrLn "Methods:\n"

420531 iputStrLn ""

421532 iputStrLn "Instances:\n"

422533 mapM_ dumpInstance (class_instances ci)

534+ iResult ""

423535

424536dumpMethod :: (Name, (FnOpts, PTerm)) -> Idris ()

425537dumpMethod (n, (_, t)) = iputStrLn $ show n ++ " : " ++ show t

@@ -428,7 +540,7 @@ dumpInstance :: Name -> Idris ()

428540dumpInstance n = do i <- getIState

429541 ctxt <- getContext

430542 imp <- impShow

431− case lookupTy Nothing n ctxt of

543+ case lookupTy n ctxt of

432544 ts -> mapM_ (\t -> iputStrLn $ showImp imp (delab i t)) ts

433545

434546showTotal t@(Partial (Other ns)) i

@@ -459,6 +571,7 @@ parseTarget _ = error "unknown target" -- FIXME: partial function

459571parseArgs :: [String] -> [Opt]

460572parseArgs [] = []

461573parseArgs ("--quiet":ns) = Quiet : (parseArgs ns)

574+parseArgs ("--ideslave":ns) = Ideslave : (parseArgs ns)

462575parseArgs ("--log":lvl:ns) = OLogging (read lvl) : (parseArgs ns)

463576parseArgs ("--noprelude":ns) = NoPrelude : (parseArgs ns)

464577parseArgs ("--check":ns) = NoREPL : (parseArgs ns)

@@ -512,6 +625,7 @@ idrisMain :: [Opt] -> Idris ()

512625idrisMain opts =

513626 do let inputs = opt getFile opts

514627 let quiet = Quiet `elem` opts

628+ let idesl = Ideslave `elem` opts

515629 let runrepl = not (NoREPL `elem` opts)

516630 let output = opt getOutput opts

517631 let newoutput = opt getNewOutput opts

@@ -531,6 +645,7 @@ idrisMain opts =

531645 mapM_ addLangExt (opt getLanguageExt opts)

532646 setREPL runrepl

533647 setQuiet quiet

648+ setIdeSlave idesl

534649 setVerbose runrepl

535650 setCmdLine opts

536651 setOutputTy outty

@@ -549,12 +664,13 @@ idrisMain opts =

549664 [] -> setIBCSubDir ""

550665 (d:_) -> setIBCSubDir d

551666 setImportDirs importdirs

667+

552668 addPkgDir "base"

553669 mapM_ addPkgDir pkgdirs

554670 elabPrims

555671 when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"

556672 return ()

557− when (runrepl && not quiet) $ iputStrLn banner

673+ when (runrepl && not quiet && not idesl) $ iputStrLn banner

558674 ist <- getIState

559675 mods <- mapM loadModule inputs

560676 ok <- noErrors

@@ -564,7 +680,8 @@ idrisMain opts =

564680 when ok $ case newoutput of

565681 [] -> return ()

566682 (o:_) -> process "" (NewCompile o)

567− when runrepl $ runInputT replSettings $ repl ist inputs

683+ when (runrepl && not idesl) $ runInputT replSettings $ repl ist inputs

684+ when (idesl) $ ideslaveStart ist inputs

568685 ok <- noErrors

569686 when (not ok) $ liftIO (exitWith (ExitFailure 1))

570687 where

@@ -633,7 +750,7 @@ getLanguageExt (Extension e) = Just e

633750getLanguageExt _ = Nothing

634751

635752opt :: (Opt -> Maybe a) -> [Opt] -> [a]

636−opt = mapMaybe

753+opt = mapMaybe

637754

638755ver = showVersion version

639756

src/Idris/REPLParser.hs+2−1

@@ -45,6 +45,7 @@ pCmd = try (do cmd ["q", "quit"]; eof; return Quit)

4545 <|> try (do cmd ["showproof"]; n <- pName; eof; return (ShowProof n))

4646 <|> try (do cmd ["log"]; i <- natural; eof; return (LogLvl (fromIntegral i)))

4747 <|> try (do cmd ["l", "load"]; f <- getInput; return (Load f))

48+ <|> try (do cmd ["cd"]; f <- getInput; return (ChangeDirectory f))

4849 <|> try (do cmd ["spec"]; t <- pFullExpr defaultSyntax; return (Spec t))

4950 <|> try (do cmd ["hnf"]; t <- pFullExpr defaultSyntax; return (HNF t))

5051 <|> try (do cmd ["doc"]; n <- pfName; eof; return (DocStr n))

@@ -65,7 +66,7 @@ pCmd = try (do cmd ["q", "quit"]; eof; return Quit)

6566 <|> do t <- pFullExpr defaultSyntax; return (Eval t)

6667 <|> do eof; return NOP

6768

68− where toPath n = foldl1 (</>) $ splitOn "." n

69+ where toPath n = foldl1' (</>) $ splitOn "." n

6970

7071pOption :: IParser Opt

7172pOption = do discard (symbol "errorcontext"); return ErrContext

src/Idris/UnusedArgs.hs+2−2

@@ -15,7 +15,7 @@ findUnusedArgs ns = mapM_ traceUnused ns

1515traceUnused :: Name -> Idris ()

1616traceUnused n

1717 = do i <- getIState

18− case lookupCtxt Nothing 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

@@ -39,7 +39,7 @@ used path g j

3939 | otherwise

4040 = do logLvl 5 $ (show ((g, j) : path))

4141 i <- getIState

42− case lookupCtxt Nothing g (idris_callgraph i) of

42+ case lookupCtxt g (idris_callgraph i) of

4343 [CGInfo args calls scg usedns unused] ->

4444 if (j >= length args)

4545 then -- overapplied, assume used

src/Main.hs+4

@@ -29,6 +29,7 @@ import Idris.Imports

2929import Idris.Error

3030

3131import Util.System ( getLibFlags, getIdrisLibDir, getIncFlags )

32+import Util.DynamicLinker

3233

3334import Pkg.Package

3435

@@ -90,7 +91,10 @@ usagemsg = "Idris version " ++ ver ++ "\n" ++

9091 "\t--log [level] Type debugging log level\n" ++

9192 "\t-S Do no further compilation of code generator output\n" ++

9293 "\t-c Compile to object files rather than an executable\n" ++

94+ "\t--ideslave Ideslave mode (for editors; in/ouput wrapped in s-expressions)\n" ++

9395 "\t--libdir Show library install directory and exit\n" ++

9496 "\t--link Show C library directories and exit (for C linking)\n" ++

9597 "\t--include Show C include directories and exit (for C linking)\n" ++

9698 "\t--target [target] Type the target: C, Java, bytecode, javascript, node\n"

99+

100+

src/Pkg/Package.hs+4−3

@@ -69,9 +69,10 @@ installPkg pkgdesc

6969

7070buildMods :: [Opt] -> [Name] -> IO ()

7171buildMods opts ns = do let f = map (toPath . show) ns

72+-- putStrLn $ "MODULE: " ++ show f

7273 idris (map Filename f ++ opts)

7374 return ()

74− where toPath n = foldl1 (</>) $ splitOn "." n

75+ where toPath n = foldl1' (</>) $ splitOn "." n

7576

7677testLib :: Bool -> String -> String -> IO Bool

7778testLib warn p f

@@ -93,7 +94,7 @@ rmIBC :: Name -> IO ()

9394rmIBC m = rmFile $ toIBCFile m

9495

9596toIBCFile (UN n) = n ++ ".ibc"

96−toIBCFile (NS n ns) = foldl1 (</>) (reverse (toIBCFile n : ns))

97+toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns))

9798

9899installIBC :: String -> Name -> IO ()

99100installIBC p m = do let f = toIBCFile m

@@ -105,7 +106,7 @@ installIBC p m = do let f = toIBCFile m

105106 copyFile f (destdir </> takeFileName f)

106107 return ()

107108 where getDest (UN n) = ""

108− getDest (NS n ns) = foldl1 (</>) (reverse (getDest n : ns))

109+ getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : ns))

109110

110111installObj :: String -> String -> IO ()

111112installObj p o = do d <- getDataDir

src/Util/DynamicLinker.hs+31−5

@@ -4,8 +4,15 @@

44module Util.DynamicLinker where

55

66import Foreign.LibFFI

7−import Foreign.Ptr (nullPtr, FunPtr, nullFunPtr)

7+import Foreign.Ptr (nullPtr, FunPtr, nullFunPtr,castPtrToFunPtr)

8+import System.Directory

9+#ifndef WINDOWS

810import System.Posix.DynamicLinker

11+#else

12+import System.Win32.DLL

13+import System.Win32.Types

14+type DL = HMODULE

15+#endif

916

1017hostDynamicLibExt :: String

1118#ifdef LINUX

@@ -16,22 +23,41 @@ hostDynamicLibExt = "dylib"

1623hostDynamicLibExt = "dll"

1724#endif

1825

26+data ForeignFun = forall a. Fun { fun_name :: String

27+ , fun_handle :: FunPtr a

28+ }

29+

1930data DynamicLib = Lib { lib_name :: String

2031 , lib_handle :: DL

2132 }

2233

34+#ifndef WINDOWS

2335tryLoadLib :: String -> IO (Maybe DynamicLib)

24−tryLoadLib lib = do handle <- dlopen (lib ++ "." ++ hostDynamicLibExt) [RTLD_NOW]

36+tryLoadLib lib = do exactName <- doesFileExist lib

37+ let filename = if exactName then lib else lib ++ "." ++ hostDynamicLibExt

38+ handle <- dlopen filename [RTLD_NOW, RTLD_GLOBAL]

2539 if undl handle == nullPtr

2640 then return Nothing

2741 else return . Just $ Lib lib handle

2842

29−data ForeignFun = forall a. Fun { fun_name :: String

30− , fun_handle :: FunPtr a

31− }

3243

3344tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)

3445tryLoadFn fn (Lib _ h) = do cFn <- dlsym h fn

3546 if cFn == nullFunPtr

3647 then return Nothing

3748 else return . Just $ Fun fn cFn

49+#else

50+tryLoadLib :: String -> IO (Maybe DynamicLib)

51+tryLoadLib lib = do exactName <- doesFileExist lib

52+ let filename = if exactName then lib else lib ++ "." ++ hostDynamicLibExt

53+ handle <- loadLibrary filename

54+ if handle == nullPtr

55+ then return Nothing

56+ else return . Just $ Lib lib handle

57+

58+tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)

59+tryLoadFn fn (Lib _ h) = do cFn <- getProcAddress h fn

60+ if cFn == nullPtr

61+ then return Nothing

62+ else return . Just $ Fun fn (castPtrToFunPtr cFn)

63+#endif

src/Util/System.hs+1−1

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

11{-# LANGUAGE CPP #-}

22module Util.System(tempfile,withTempdir,environment,getCC,

33 getLibFlags,getIdrisLibDir,getIncFlags,rmFile,

4− getMvn,getExecutablePom) where

4+ getMvn,getExecutablePom,catchIO) where

55

66-- System helper functions.

77import Control.Monad (when)

test/README+5

@@ -22,5 +22,10 @@ Tests:

2222020: implicit conversions

2323021: effects

2424022: dynamic C library loading and interpreter IO

25+023: trivial (non-I/O) type providers

26+024: interpreter I/O

27+025: memory effects

28+026: simple file-I/O-based type provider

29+027: class constraints in using block

2530

2631regxxx: various regression tests

test/reg011/reg011.idr+1−2

@@ -4,7 +4,6 @@ vfoldl : (P : Nat -> Type) ->

44-- vfoldl P cons nil []

55-- = nil

66vfoldl P cons nil (x :: xs)

7− = vfoldl (\n => P (S n)) (\ n => cons (S n)) (cons O nil x) xs

8−%logging 0

7+ = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons O nil x) xs

98-- vfoldl P cons nil (x :: xs)

109-- = vfoldl (\n => P (S n)) (\ n => cons _) (cons _ nil x) xs

test/reg015/expectednew file

No changes to the content.

test/reg015/reg015.idrnew file+3

@@ -0,0 +1,3 @@

1+using (A : Type, B : A->Type, C : Type)

2+ foo : ((x:A) -> B x -> C) -> ((x:A ** B x) -> C)

3+ foo f p = f (getWitness p) (getProof p)

test/reg015/runnew file+3

@@ -0,0 +1,3 @@

1+#!/bin/bash

2+idris $@ reg015.idr --check

3+rm -f *.ibc

test/reg016/expectednew file+6

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

1+4294967295

2+4294967296

3+4294967297

4+-1

5+0

6+1

test/reg016/reg016.idrnew file+11

@@ -0,0 +1,11 @@

1+module Main

2+

3+main : IO ()

4+main = do print $ the Integer 4294967295

5+ print $ the Integer 4294967296

6+ print $ the Integer 4294967297

7+ print $ the Int 4294967295

8+ print $ the Int 4294967296

9+ print $ the Int 4294967297

10+

11+

test/reg016/runnew file+4

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

1+#!/bin/bash

2+idris $@ reg016.idr -o reg016

3+./reg016

4+rm -f reg016 *.ibc

test/reg017/expectednew file+1

@@ -0,0 +1 @@

1+ssssO

test/reg017/reg017.idrnew file+13

@@ -0,0 +1,13 @@

1+module Main

2+

3+foo : { t : Type } ->

4+ (a : t) ->

5+ { default tactics { refine refl; solve; } prfA : a = a } ->

6+ (b : Nat) ->

7+ (c : Nat) ->

8+ { default tactics { refine refl; solve; } prfBC : b = c } ->

9+ Nat

10+foo {t} a {prfA = p} b c {prfBC} = b

11+

12+main : IO ()

13+main = print $ foo 3 4 4

test/reg017/runnew file+4

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

1+#!/bin/bash

2+idris $@ reg017.idr -o reg017

3+./reg017

4+rm -f reg017 *.ibc

test/reg018/expectednew file+4

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

1+reg018a.idr:16:conat.minusCoNat is not productive

2+reg018b.idr:8:A.showB is possibly not total due to recursive path A.showB

3+reg018c.idr:19:CodataTest.inf is not productive

4+reg018d.idr:5:Main.pull is not total as there are missing cases

test/reg018/reg018a.idrnew file+21

@@ -0,0 +1,21 @@

1+module conat

2+

3+%default total

4+

5+codata CoNat = Z | S CoNat

6+

7+infinity : CoNat

8+infinity = S infinity

9+

10+plusCoNat : CoNat -> CoNat -> CoNat

11+plusCoNat Z x = x

12+plusCoNat (S x) y = S (plusCoNat x y)

13+

14+--I don't think this should be definable

15+minusCoNat : CoNat -> CoNat -> CoNat

16+minusCoNat Z n = Z

17+minusCoNat (S n) Z = S n

18+minusCoNat (S n) (S m) = plusCoNat Z (minusCoNat n m)

19+

20+loopForever : CoNat

21+loopForever = minusCoNat infinity infinity

test/reg018/reg018b.idrnew file+14

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

1+module A

2+

3+%default total

4+

5+codata B = O B | I B

6+

7+showB : B -> String

8+showB (I x) = "I" ++ showB x

9+showB (O x) = "O" ++ showB x

10+

11+instance Show B where show = showB

12+

13+os : B

14+os = O os

test/reg018/reg018c.idrnew file+20

@@ -0,0 +1,20 @@

1+module CodataTest

2+%default total

3+

4+codata InfStream a = (::) a (InfStream a)

5+--

6+-- natStream : InfStream Nat

7+-- natStream = natFromStream 0 where

8+-- natFromStream : Nat -> InfStream Nat

9+-- natFromStream n = (::) n (natFromStream (S n))

10+

11+take : (n: Nat) -> InfStream a -> Vect a n

12+take O _ = []

13+take (S n) (x :: xs) = x :: take n xs

14+

15+hdtl : InfStream a -> (a, InfStream a)

16+hdtl (x :: xs) = (x, xs)

17+

18+inf : InfStream a -> InfStream a

19+inf (x :: xs) with (hdtl xs)

20+ | (hd, tl) = inf xs

test/reg018/reg018d.idrnew file+12

@@ -0,0 +1,12 @@

1+module Main

2+

3+total

4+pull : Fin (S n) -> Vect a (S n) -> (a, Vect a n)

5+pull {n=O} _ (x :: xs) = (x, xs)

6+-- pull {n=S q} fO (Vect.(::) {n=S _} x xs) = (x, xs)

7+pull {n=S _} (fS n) (x :: xs) =

8+ let (v, vs) = pull n xs in

9+ (v, x::vs)

10+

11+main : IO ()

12+main = print (pull fO [0, 1, 2])

test/reg018/runnew file+5

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

1+#!/bin/bash

2+idris $@ reg018a.idr --check

3+idris $@ reg018b.idr --check

4+idris $@ reg018c.idr --check

5+idris $@ reg018d.idr --check

test/reg019/expectednew file

No changes to the content.

test/reg019/reg019.idrnew file+7

@@ -0,0 +1,7 @@

1+m_add : Maybe (Either Bool Int) -> Maybe (Either Bool Int) ->

2+ Maybe (Either Bool Int)

3+m_add x y = do x' <- x -- Extract value from x

4+ y' <- y -- Extract value from y

5+ case x' of

6+ Left _ => Nothing

7+ Right _ => Nothing

test/reg019/runnew file+3

@@ -0,0 +1,3 @@

1+#!/bin/bash

2+idris $@ reg019.idr --check

3+rm -f *.ibc

test/runtest.pl+6

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

11#!/usr/bin/perl

22

3+use Cwd;

4+

35my $exitstatus = 0;

46

57sub runtest {

@@ -79,6 +81,10 @@ while ($opt=shift(@opts)) {

7981 else { push(@idrOpts, $opt); }

8082}

8183

84+my $idris = $ENV{IDRIS};

85+my $path = $ENV{PATH};

86+$ENV{PATH}=cwd() . "/" . $idris . ":" . $path;

87+

8288foreach $test (@tests) {

8389

8490 if ($diff == 0 && $show == 0) {

test/test008/test008.idr−1

@@ -26,4 +26,3 @@ main = do (a, b) <- ioVals

2626 case lookup x testlist of

2727 Just v => putStrLn (show v)

2828 Nothing => putStrLn "Not there!"

29−

test/test014/Resimp.idr+8−1

@@ -69,6 +69,13 @@ using (i: Fin n, gam : Vect Ty n, gam' : Vect Ty n, gam'' : Vect Ty n)

6969 envUpdate (pop k) val (x :: xs) = x :: envUpdate k val xs

7070 envUpdate stop _ Nil impossible

7171

72+ total

73+ envUpdateVal : (p:HasType gam i a) -> (val:b) ->

74+ Env gam -> Env (update gam p (Val b))

75+ envUpdateVal stop val (x :: xs) = val :: xs

76+ envUpdateVal (pop k) val (x :: xs) = x :: envUpdateVal k val xs

77+ envUpdateVal stop _ Nil impossible

78+

7279 envTail : Env (a :: gam) -> Env gam

7380 envTail (x :: xs) = xs

7481

@@ -121,7 +128,7 @@ using (i: Fin n, gam : Vect Ty n, gam' : Vect Ty n, gam'' : Vect Ty n)

121128 (\env', scope' => k (envTail env') scope')

122129 interp env (Update method x) k

123130 = do x' <- getUpdater (method (envLookup x env))

124− k (envUpdate x x' env) (return ())

131+ k (envUpdateVal x x' env) (return ())

125132 interp env (Use method x) k

126133 = do x' <- getReader (method (envLookup x env))

127134 k env (return x')

test/test016/test016.idr+4−7

@@ -7,14 +7,11 @@ codata Stream a = Nil | (::) a (Stream a)

77countFrom : Int -> Stream Int

88countFrom x = x :: countFrom (x + 1)

99

10−take : Int -> Stream a -> List a

11−take 0 _ = []

12−take n (x :: xs) = x :: take (n - 1) xs

10+take : Nat -> Stream a -> List a

11+take O _ = []

12+take (S n) (x :: xs) = x :: take n xs

1313take n [] = []

1414

15−-- foo : main.countFrom 4 = 4 :: main.countFrom 5

16−-- foo = refl

17−

18−partial main : IO ()

15+main : IO ()

1916main = do print (take 10 (Main.countFrom 10))

2017

test/test021/expected+2−2

@@ -2,5 +2,5 @@

22, WORLD!!!

33, ]

443

5−23

6−Answer: 107

5+15

6+Answer: 99

test/test021/test021a.idr+5−5

@@ -6,18 +6,18 @@ import Effect.Random

66import Effect.StdIO

77

88data Expr = Var String

9− | Val Int

9+ | Val Integer

1010 | Add Expr Expr

11− | Random Int

11+ | Random Integer

1212

1313Env : Type

14−Env = List (String, Int)

14+Env = List (String, Integer)

1515

1616-- Evaluator : Type -> Type

1717-- Evaluator t

1818-- = Eff m [EXCEPTION String, RND, STATE Env] t

1919

20−eval : Expr -> Eff IO [EXCEPTION String, STDIO, RND, STATE Env] Int

20+eval : Expr -> Eff IO [EXCEPTION String, STDIO, RND, STATE Env] Integer

2121eval (Var x) = do vs <- get

2222 case lookup x vs of

2323 Nothing => raise ("No such variable " ++ x)

@@ -31,7 +31,7 @@ eval (Random upper) = do val <- rndInt 0 upper

3131testExpr : Expr

3232testExpr = Add (Add (Var "foo") (Val 42)) (Random 100)

3333

34−runEval : List (String, Int) -> Expr -> IO Int

34+runEval : List (String, Integer) -> Expr -> IO Integer

3535runEval args expr = run [(), (), 123456, args] (eval expr)

3636

3737main : IO ()

test/test022/test022.idr+1−1

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

11module Main

22

3−%dynamic "libm"

3+%dynamic "dummy", "libm", "msvcrt"

44

55x : Float

66x = unsafePerformIO (mkForeign (FFun "sin" [FFloat] FFloat) 1.6)

test/test023/expectednew file+1

@@ -0,0 +1 @@

1+Type provider error: Always fails

test/test023/runnew file+3

@@ -0,0 +1,3 @@

1+#!/bin/bash

2+idris --quiet test023.idr -o test023

3+rm -f test023 *.ibc

test/test023/test023.idrnew file+23

@@ -0,0 +1,23 @@

1+module Main

2+

3+-- Simple test case for trivial type providers.

4+

5+import Providers

6+

7+%language TypeProviders

8+

9+-- Provide the Unit type

10+goodProvider : IO (Provider Type)

11+goodProvider = return (Provide (the Type ()))

12+

13+%provide (Unit : Type) with goodProvider

14+

15+foo : Unit

16+foo = ()

17+

18+-- Always fail

19+badProvider : IO (Provider Type)

20+badProvider = return (Error "Always fails")

21+

22+%provide (t : Type) with badProvider

23+

test/test024/expectednew file+3

@@ -0,0 +1,3 @@

1+Type checking ./test024.idr

2+testtest

3+() : ()

test/test024/inputnew file+2

@@ -0,0 +1,2 @@

1+:x unsafePerformIO main

2+test

test/test024/runnew file+3

@@ -0,0 +1,3 @@

1+#!/bin/bash

2+idris --quiet test024.idr < input

3+rm -f *.ibc

test/test024/test024.idrnew file+6

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

1+module Main

2+

3+main : IO ()

4+main = do l <- getLine

5+ let ll = l ++ l

6+ putStrLn ll

test/test025/expectednew file+1

@@ -0,0 +1 @@

1+[1, 2, 3, 4]

test/test025/runnew file+4

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

1+#!/bin/bash

2+idris -p effects $@ test025.idr -o test025

3+./test025

4+rm -f test025 *.ibc

test/test025/test025.idrnew file+34

@@ -0,0 +1,34 @@

1+module Main

2+

3+import Effects

4+import Effect.Memory

5+import Control.IOExcept

6+

7+MemoryIO : Type -> Type -> Type -> Type

8+MemoryIO td ts r = Eff (IOExcept String) [ Dst ::: RAW_MEMORY td

9+ , Src ::: RAW_MEMORY ts ] r

10+

11+inpVect : Vect Bits8 5

12+inpVect = map prim__truncInt_B8 [0, 1, 2, 3, 5]

13+

14+sub1 : Vect Bits8 n -> Vect Bits8 n

15+sub1 xs = map (prim__truncInt_B8 . (\ x => x - 1) . prim__zextB8_Int) xs

16+

17+testMemory : MemoryIO () () (Vect Int 4)

18+testMemory = do Src :- allocate 5

19+ Src :- poke 0 inpVect oh

20+ Dst :- allocate 5

21+ Dst :- initialize (prim__truncInt_B8 1) 2 oh

22+ move 2 2 3 oh oh

23+ Src :- free

24+ end <- Dst :- peek 4 1 oh

25+ Dst :- poke 4 (sub1 end) oh

26+ res <- Dst :- peek 1 4 oh

27+ Dst :- free

28+ return (map (prim__zextB8_Int) res)

29+

30+main : IO ()

31+main = do ioe_run (run [Dst := (), Src := ()] testMemory)

32+ (\err => print err) (\ok => print ok)

33+

34+

test/test026/expectednew file+3

@@ -0,0 +1,3 @@

1+Type checking ./test026.idr

2+2 : Int

3+2 : Nat

test/test026/inputnew file+2

@@ -0,0 +1,2 @@

1+foo

2+bar

test/test026/runnew file+3

@@ -0,0 +1,3 @@

1+#!/bin/bash

2+idris --quiet test026.idr < input

3+rm -f *.ibc

test/test026/test026.idrnew file+26

@@ -0,0 +1,26 @@

1+module Main

2+

3+-- Simple test case for trivial type providers.

4+

5+import Providers

6+

7+%language TypeProviders

8+

9+strToType : String -> Type

10+strToType "Int" = Int

11+strToType _ = Nat

12+

13+-- If the file contains "Int", provide Int as a type, otherwise provide Nat

14+fromFile : String -> IO (Provider Type)

15+fromFile fname = do str <- readFile fname

16+ return (Provide (strToType str))

17+

18+%provide (T1 : Type) with fromFile "theType"

19+%provide (T2 : Type) with fromFile "theOtherType"

20+

21+foo : T1

22+foo = 2

23+

24+bar : T2

25+bar = 2

26+

test/test026/theOtherTypenew file+1

@@ -0,0 +1 @@

1+Nat

test/test026/theTypenew file+1

@@ -0,0 +1 @@

1+Int

test/test027/expectednew file+3

@@ -0,0 +1,3 @@

1+[1, 1, 3, 5, 5, 8, 9]

2+55

3+3628800

test/test027/runnew file+4

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

1+#!/bin/bash

2+idris $@ test027.idr -o test027

3+./test027

4+rm -f test027 *.ibc

test/test027/test027.idrnew file+25

@@ -0,0 +1,25 @@

1+module Main

2+

3+using (Ord a, Num n)

4+

5+ isort : List a -> List a

6+ isort [] = []

7+ isort (x :: xs) = insert x (isort xs)

8+ where -- insert : a -> List a -> List a

9+ insert x [] = [x]

10+ insert x (y :: ys) = if x < y then x :: y :: ys

11+ else y :: insert x ys

12+

13+ msum : Num n => List n -> n

14+ msum [] = 0

15+ msum (x :: xs) = x + msum xs

16+

17+ mprod : List n -> n

18+ mprod [] = 1

19+ mprod (x :: xs) = x * mprod xs

20+

21+main : IO ()

22+main = do print $ isort [1,5,3,5,1,9,8]

23+ print $ msum [1..10]

24+ print $ mprod [1..10]

25+

tutorial/examples/wheres.idrnew file+14

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

1+module wheres

2+

3+even : Nat -> Bool

4+even O = True

5+even (S k) = odd k where

6+ odd O = False

7+ odd (S k) = even k

8+

9+test : List Nat

10+test = [c (S 1), c O, d (S O)]

11+ where c x = 42 + x

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

13+ where z w = y + w

14+

tutorial/idris-tutorial.tex+1

@@ -11,6 +11,7 @@

1111\input{library.ltx}

1212

1313\newcommand{\Idris}{\textsc{Idris}}

14+\newcommand{\version}{0.9.8}

1415

1516\title{Programming in \Idris{}: a tutorial}

1617\author{Edwin Brady \\ \url{eb@cs.st-andrews.ac.uk}}

tutorial/interp.tex+4−4

@@ -97,7 +97,7 @@ data HasType : (i : Fin n) -> Vect Ty n -> Ty -> Type where

9797\noindent

9898We can treat \remph{stop} as a proof that the most recently defined variable is well-typed,

9999and \remph{pop n} as a proof that, if the \texttt{n}th most recently defined variable is

100−well-typed, so is the \texttt{n+1}th. In practice, this means we use \texttt{pop} to

100+well-typed, so is the \texttt{n+1}th. In practice, this means we use \texttt{stop} to

101101refer to the most recently defined variable, \texttt{pop stop} to refer to the next, and so on,

102102via the \texttt{Var} constructor:

103103

@@ -339,12 +339,12 @@ type to another if possible. Here, it converts a string to

339339an integer, giving 0 if the input is invalid. An example run of this program

340340at the \Idris{} interactive environment is shown in Figure \ref{factrun}.

341341

342−\begin{SaveVerbatim}{factrun}

342+\begin{SaveVerbatim}[commandchars=^\{\}]{factrun}

343343

344344$ idris interp.idr

345345 ____ __ _

346346 / _/___/ /____(_)____

347− / // __ / ___/ / ___/ Version 0.9.7

347+ / // __ / ___/ / ___/ Version ^version{}

348348 _/ // /_/ / / / (__ ) http://www.idris-lang.org/

349349 /___/\__,_/_/ /_/____/ Type :? for help

350350

@@ -397,7 +397,7 @@ unitTestFac = oh

397397\useverb{unitTestFac}

398398

399399\noindent

400−For the program the compile, the test case must pass. If we change \texttt{24} to \texttt{25},

400+For the program to compile, the test case must pass. If we change \texttt{24} to \texttt{25},

401401say, we will get an error message like the following:

402402

403403\begin{SaveVerbatim}{unitTestErr}

tutorial/intro.tex+1−1

@@ -62,7 +62,7 @@ verifying systems software.

6262\subsection{Example Code}

6363

6464This tutorial includes some example code, which has been tested with \Idris{} version

65−0.9.7. The files are available in the \Idris{} distribution,

65+\version{}. The files are available in the \Idris{} distribution,

6666so that you can try them out easily,

6767under \texttt{tutorial/examples}. However, it is strongly recommended that you

6868type them in yourself, rather than simply loading and reading them.

tutorial/starting.tex+6−6

@@ -74,12 +74,12 @@ interactive environment.

7474Entering \texttt{idris} at the shell prompt starts up the interactive

7575environment. You should see something like the following:

7676

77−\begin{SaveVerbatim}{prompt1}

77+\begin{SaveVerbatim}[commandchars=^\{\}]{prompt1}

7878

7979$ idris

8080 ____ __ _

8181 / _/___/ /____(_)____

82− / // __ / ___/ / ___/ Version 0.9.7

82+ / // __ / ___/ / ___/ Version ^version{}

8383 _/ // /_/ / / / (__ ) http://www.idris-lang.org/

8484 /___/\__,_/_/ /_/____/ Type :? for help

8585

@@ -98,8 +98,8 @@ as shown in Figure \ref{cmds}. Figure \ref{run1} shows an example run in which

9898\texttt{hello.idr} is loaded, the type of \texttt{main} is checked and then

9999the program is compiled to the executable \texttt{hello}.

100100

101−\begin{SaveVerbatim}{cmds}

102−Idris version 0.9.7

101+\begin{SaveVerbatim}[commandchars=\\\{\}]{cmds}

102+Idris version \version{}

103103-------------------

104104

105105 Command Arguments Purpose

@@ -129,12 +129,12 @@ Idris version 0.9.7

129129\codefigs{cmds}{Interactive environment commands}

130130

131131

132−\begin{SaveVerbatim}{run1}

132+\begin{SaveVerbatim}[commandchars=^\{\}]{run1}

133133

134134$ idris hello.idr

135135 ____ __ _

136136 / _/___/ /____(_)____

137− / // __ / ___/ / ___/ Version 0.9.7

137+ / // __ / ___/ / ___/ Version ^version{}

138138 _/ // /_/ / / / (__ ) http://www.idris-lang.org/

139139 /___/\__,_/_/ /_/____/ Type :? for help

140140

tutorial/theorems.tex+1−1

@@ -412,7 +412,7 @@ function \texttt{f} must:

412412\item Cover all possible inputs

413413\item Be \emph{well-founded} --- i.e. by the time a sequence of

414414(possibly mutually) recursive calls reaches \texttt{f} again, it must

415−be possible to show that one its has decreased.

415+be possible to show that one of its arguments has decreased.

416416\item Not use any data types which are not \emph{strictly positive}

417417\item Not call any non-total functions

418418\end{itemize}

tutorial/typesfuns.tex+5−5

@@ -257,11 +257,11 @@ even (S k) = odd k where

257257 odd O = False

258258 odd (S k) = even k

259259

260−test : Num a => List a

261−test = [c 1, c 2, d 3]

262− where c x = 42 + x

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

264− where z w = y + w

260+test : List Nat

261+test = [c (S 1), c O, d (S O)]

262+ where c x = 42 + x

263+ d y = c (y + 1 + z y)

264+ where z w = y + w

265265

266266\end{SaveVerbatim}

267267\useverb{whereinfer}