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

.gitignore+4

compare with master

unifiedsplit

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

3*.ibc

4*.o

5*.a

6+*.so

7+*.dll

8+*.dylib

6*.swp

9*.swp

7*~

10*~

8custom.mk

11custom.mk

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

11test/reg???/output

14test/reg???/output

12test/test???/*.exe

15test/test???/*.exe

13test/reg???/*.exe

16test/reg???/*.exe

17+

.travis.yml+1−2

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

1language: haskell

2script:

3− - cd test

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

4− - ./runtest.pl all

CHANGELOG+5

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

4User visible changes:

5

6* Added "rewrite ... in ..." construct

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

7* Renamed EFF to EFFECT in Effect package

8* Renamed EFF to EFFECT in Effect package

8* Experimental Java backend

9* Experimental Java backend

9* Tab completion in REPL

10* Tab completion in REPL

10* Dynamic loading of C libraries in the interpreter

11* Dynamic loading of C libraries in the interpreter

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

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

13+* Improve rendering of :t

14+* Fixed some INTERNAL ERROR messages

12

15

13Internal changes:

16Internal changes:

14

17

18+* Fix non-linear pattern checking

15* Improved name disambiguation

19* Improved name disambiguation

20+* More flexible unification and elaboration of lambdas

16* Various unification and totality checking bug fixes

21* Various unification and totality checking bug fixes

17

22

18New in 0.9.7:

23New in 0.9.7:

Makefile+4−3

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

14 $(CABAL) build $(CABALFLAGS)

15

16test:

17− make -C test

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

18

19relib:

20− make -C lib 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 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

22 $(CABAL) install $(CABALFLAGS)

23 $(CABAL) install $(CABALFLAGS)

23

24

24linecount:

25linecount:

Setup.hs+16−3

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

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

29idrisCmd local = Px.joinPath $ splitDirectories $

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

31+rtsDir local = Px.joinPath $ splitDirectories $

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

31#else

33#else

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

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

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

33#endif

36#endif

34

37

35cleanStdLib verbosity

38cleanStdLib verbosity

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

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

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

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

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

38

42

39cleanJavaLib verbosity

43cleanJavaLib verbosity

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

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

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

60 , "TARGET=" ++ idir

64 , "TARGET=" ++ idir

61 , "IDRIS=" ++ icmd

65 , "IDRIS=" ++ icmd

62 ]

66 ]

67+ make verbosity

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

69+ , "TARGET=" ++ idir

70+ , "IDRIS=" ++ icmd

71+ ]

63 let idirRts = idir </> "rts"

72 let idirRts = idir </> "rts"

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

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

65 make verbosity

74 make verbosity

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

103 ]

112 ]

104 unless withoutEffects $

113 unless withoutEffects $

105 make verbosity

114 make verbosity

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

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

116+ , "IDRIS=" ++ icmd

117+ ]

118+ make verbosity

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

107− , "IDRIS=" ++ icmd

120+ , "IDRIS=" ++ icmd

108− ]

121+ ]

109 make verbosity

122 make verbosity

110 [ "-C", "rts", "check"

123 [ "-C", "rts", "check"

111 , "IDRIS=" ++ icmd

124 , "IDRIS=" ++ icmd

config.mk+27−1

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

5## Enable Java RTS:

6#CABALFLAGS :=-f Java

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

9

35

contribs/lib/SQLite3/Makefile+5−2

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

3

4.PHONY: all

5

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

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

7 idris testunit.idr -o sqltest

8

9sqlite3api.o : sqlite3api.c

10 gcc -c sqlite3api.c

11−

11+

12+sqlite3api.so: sqlite3api.c

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

14+

12all : sqltest sqlite3api.o

15all : sqltest sqlite3api.o

13

16

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

22 | DBText String

23 | DBFloat Float

24 | DBNull

25−

25+

26-- Database pointer

27data DBPointer = MkDBPointer Ptr

28-- Table pointer

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

30-- Statement pointer

31data StmtPtr = MkStmtPtr Ptr

32

33−Table : Set

33+Table : Type

34Table = List (List DBVal)

35

36-- ForMap used in to_list_v1

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

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

38−forM f xs = mapM xs f

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

39

40-- Neater error handling done using DB

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

42

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+

43instance Monad DB where

56instance Monad DB where

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

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

45 case c of

58 case c of

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

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

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

64 case f' of

77 case f' of

65 Right v => return v

78 Right v => return v

66− Left str => ioError str

79+ Left str => ioError str

67−

80+

68-----------------------------------------------------------------------------

81-----------------------------------------------------------------------------

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

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

70-----------------------------------------------------------------------------

83-----------------------------------------------------------------------------

71−

84+

72open_db : String -> DB DBPointer

85open_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)

74 return (MkDBPointer x)

87 return (MkDBPointer x)

75

88

76-----------------------------------------------------------------------------

89-----------------------------------------------------------------------------

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

78-----------------------------------------------------------------------------

91-----------------------------------------------------------------------------

79

92

80close_db : DBPointer -> DB Int

93close_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)

82

95

83-----------------------------------------------------------------------------

96-----------------------------------------------------------------------------

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

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

85-----------------------------------------------------------------------------

98-----------------------------------------------------------------------------

86−

99+

87exec_db : DBPointer -> String -> DB Int

100exec_db : DBPointer -> String -> DB Int

88−exec_db (MkDBPointer pointer) stmt = do

101+exec_db (MkDBPointer pointer) stmt = do

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

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

90 if (x == 1)

103 if (x == 1)

91− then fail "Could not execute."

104+ then fail "Could not execute."

92− else return x

105+ else return x

93

106

94-----------------------------------------------------------------------------

107-----------------------------------------------------------------------------

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

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

96-----------------------------------------------------------------------------

109-----------------------------------------------------------------------------

97

110

98exec_db_v2 : StmtPtr -> DB Int

111exec_db_v2 : StmtPtr -> DB Int

99−exec_db_v2 (MkStmtPtr pointer) = do

112+exec_db_v2 (MkStmtPtr pointer) = do

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

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

101 if (x == 21)

114 if (x == 21)

102− then fail "No data returned."

115+ then fail "No data returned."

103− else return x

116+ else return x

104−

117+

105-----------------------------------------------------------------------------

118-----------------------------------------------------------------------------

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

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

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

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

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

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

109-----------------------------------------------------------------------------

122-----------------------------------------------------------------------------

110−

123+

111get_error : DBPointer -> IO String

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

113

126

114

127

115-----------------------------------------------------------------------------

128-----------------------------------------------------------------------------

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

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

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

118-- Returns a null pointer on a failure.

131-- Returns a null pointer on a failure.

119-----------------------------------------------------------------------------

132-----------------------------------------------------------------------------

120−

133+

121prepare_db : DBPointer -> String -> DB StmtPtr

134prepare_db : DBPointer -> String -> DB StmtPtr

122prepare_db (MkDBPointer pointer) cmd = do

135prepare_db (MkDBPointer pointer) cmd = do

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

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

124− flag <- liftIO(nullPtr result)

137+ flag <- liftIO (nullPtr result)

125 if flag

138 if flag

126− then fail "Error occured while preparing"

139+ then fail "Error occured while preparing"

127− else return (MkStmtPtr result)

140+ else return (MkStmtPtr result)

128

141

129-----------------------------------------------------------------------------

142-----------------------------------------------------------------------------

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

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

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

136step_db (MkStmtPtr pointer)= do

149step_db (MkStmtPtr pointer)= do

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

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

138 if ( x == 101)

151 if ( x == 101)

139− then fail "SQLITE_DONE"

152+ then fail "SQLITE_DONE"

140− else return x

153+ else return x

141

154

142-----------------------------------------------------------------------------

155-----------------------------------------------------------------------------

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

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

144-- prepare function.

157-- prepare function.

145-----------------------------------------------------------------------------

158-----------------------------------------------------------------------------

146

159

147finalize_db : StmtPtr -> DB Int

160finalize_db : StmtPtr -> DB Int

148−finalize_db (MkStmtPtr pointer) = do

161+finalize_db (MkStmtPtr pointer) = do

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

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

150 if (x /= 0)

163 if (x /= 0)

151− then fail "Could not finalize"

164+ then fail "Could not finalize"

152− else return x

165+ else return x

153

166

154-----------------------------------------------------------------------------

167-----------------------------------------------------------------------------

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

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

156-----------------------------------------------------------------------------

169-----------------------------------------------------------------------------

157

170

158reset_db : StmtPtr -> DB Int

171reset_db : StmtPtr -> DB Int

159−reset_db (MkStmtPtr pointer) = do

172+reset_db (MkStmtPtr pointer) = do

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

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

161− if (x /=0)

174+ if (x /= 0)

162− then fail "Could not reset"

175+ then fail "Could not reset"

163− else return x

176+ else return x

164

177

165-----------------------------------------------------------------------------

178-----------------------------------------------------------------------------

166-- | These routines obtain column information.

179-- | These routines obtain column information.

167-----------------------------------------------------------------------------

180-----------------------------------------------------------------------------

168

181

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

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

170−column_count (MkDBPointer pointer) = do

183+column_count (MkDBPointer pointer) = do

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

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

172− if (x == 0 )

185+ return $ if (x == 0 )

173− then return (Left "No Data")

186+ then Left "No Data"

174− else return (Right x)

187+ else (Right x)

175

188

176column_name : DBPointer -> Int -> IO String

189column_name : DBPointer -> Int -> IO String

190+column_name (MkDBPointer pointer) iCol =

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

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

178−

192+

179column_decltype : DBPointer -> Int -> IO String

193column_decltype : DBPointer -> Int -> IO String

194+column_decltype (MkDBPointer pointer) iCol =

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

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

181

196

182

197

183column_bytes : DBPointer -> Int -> IO Int

198column_bytes : DBPointer -> Int -> IO Int

199+column_bytes (MkDBPointer pointer) iCol =

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

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

185

201

186

202

187column_blob : DBPointer -> Int -> IO String

203column_blob : DBPointer -> Int -> IO String

204+column_blob (MkDBPointer pointer) iCol =

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

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

189

206

190

207

191column_text : DBPointer -> Int -> IO String

208column_text : DBPointer -> Int -> IO String

209+column_text (MkDBPointer pointer) iCol =

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

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

193

211

194

212

195column_Int : DBPointer -> Int -> IO Int

213column_Int : DBPointer -> Int -> IO Int

214+column_Int (MkDBPointer pointer) iCol =

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

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

197

216

198-----------------------------------------------------------------------------

217-----------------------------------------------------------------------------

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

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

200-----------------------------------------------------------------------------

219-----------------------------------------------------------------------------

201

220

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

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

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

204− return (MkDBPointer x)

225+ return (MkDBPointer x)

205

226

206backup_step : DBPointer -> Int -> IO Int

227backup_step : DBPointer -> Int -> IO Int

228+backup_step (MkDBPointer pointer) nPage =

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

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

208

230

209backup_finish : DBPointer -> IO Int

231backup_finish : DBPointer -> IO Int

232+backup_finish (MkDBPointer pointer) =

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

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

211

234

212backup_remaining : DBPointer -> IO Int

235backup_remaining : DBPointer -> IO Int

236+backup_remaining (MkDBPointer pointer) =

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

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

214

238

215

239

216-----------------------------------------------------------------------------

240-----------------------------------------------------------------------------

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

221-----------------------------------------------------------------------------

245-----------------------------------------------------------------------------

222

246

223get_table : DBPointer -> String -> DB TBPointer

247get_table : DBPointer -> String -> DB TBPointer

224−get_table (MkDBPointer pointer) name = do

248+get_table (MkDBPointer pointer) name = do

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

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

226− flag <- liftIO(nullPtr x)

250+ flag <- liftIO (nullPtr x)

227 if flag

251 if flag

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

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

229− else return (MkTBPointer x)

253+ else return (MkTBPointer x)

230 where

254 where

231 get_error_table : Ptr-> IO String

255 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

233 return x

257 return x

234

258

235

259

236free_table : TBPointer -> IO ()

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

238 return ()

262 return ()

239−

263+

240-----------------------------------------------------------------------------

264-----------------------------------------------------------------------------

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

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

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

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

243-----------------------------------------------------------------------------

267-----------------------------------------------------------------------------

244

268

245num_row : TBPointer -> IO Int

269num_row : TBPointer -> IO Int

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

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

247− return (x)

271+ return x

248

272

249num_col : TBPointer -> IO Int

273num_col : TBPointer -> IO Int

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

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

251− return (x)

275+ return x

252−

276+

253-----------------------------------------------------------------------------

277-----------------------------------------------------------------------------

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

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

255-- from the Database struct.

279-- from the Database struct.

256-----------------------------------------------------------------------------

280-----------------------------------------------------------------------------

257

281

258num_row_v2 : DBPointer -> IO Int

282num_row_v2 : DBPointer -> IO Int

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

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

260− return (x)

284+ return x

261

285

262num_col_v2 : DBPointer -> IO Int

286num_col_v2 : DBPointer -> IO Int

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

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

264− return (x)

288+ return x

265−

289+

266-----------------------------------------------------------------------------

290-----------------------------------------------------------------------------

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

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

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

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

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

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

270-----------------------------------------------------------------------------

294-----------------------------------------------------------------------------

271−

295+

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

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

273get_data (MkDBPointer pointer) row col = do

297get_data (MkDBPointer pointer) row col = do

274 ty <- get_data_type pointer row col

298 ty <- get_data_type pointer row col

275 helper ty

299 helper ty

276− where

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

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

301+ get_data_type pointer row col =

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

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

279−

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

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

304+ get_data_val_int pointer col =

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

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

282−

306+

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

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

308+ get_data_val_text pointer col =

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

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

285−

310+

286−

287−

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

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

312+ get_data_val_float pointer col =

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

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

290−

314+

291− helper : Int -> IO DBVal

315+ helper : Int -> IO DBVal

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

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

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

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

295− helper _ =return (DBNull)

319+ helper _ = return DBNull

296−

320+

297-----------------------------------------------------------------------------

321-----------------------------------------------------------------------------

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

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

299-----------------------------------------------------------------------------

323-----------------------------------------------------------------------------

300

324

301−toList_v1 : DBPointer -> DB Table

325+toList_v1 : DBPointer -> DB Table

302−toList_v1 db = do

303− nbR <- liftIO (num_row_v2 db)

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

304− nmC <- liftIO (num_col_v2 db)

327+ nmC <- liftIO (num_col_v2 db)

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

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

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

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

307− liftIO(get_data db i j)

308−

309− )

310− )

311− return res

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

312−

331+

313−

314strcat : String -> String-> String

332strcat : String -> String-> String

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

333+strcat str1 str2 = str1 ++ str2

316

334

317-----------------------------------------------------------------------------

335-----------------------------------------------------------------------------

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

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

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

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

320-----------------------------------------------------------------------------

338-----------------------------------------------------------------------------

321−

339+

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

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

323--toList_v2 name stmt x = do

341--toList_v2 name stmt x = do

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

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

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

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

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

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

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

329-- liftIO(get_data x name i j)

347-- liftIO(get_data x name i j)

330−--

348+--

331-- )

349-- )

332-- )

350-- )

333-- liftIO (free_table ptr)

351-- liftIO (free_table ptr)

334−-- return res

352+-- return res

335−

353+

336

354

337-----------------------------------------------------------------------------

355-----------------------------------------------------------------------------

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

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

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

341-----------------------------------------------------------------------------

359-----------------------------------------------------------------------------

342

360

343bind_int : StmtPtr -> Int -> Int -> DB StmtPtr

361bind_int : StmtPtr -> Int -> Int -> DB StmtPtr

344−bind_int (MkStmtPtr pointer) indexval val = do

362+bind_int (MkStmtPtr pointer) indexval val = do

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

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

346− flag <- liftIO(nullPtr x)

364+ flag <- liftIO (nullPtr x)

347 if flag

365 if flag

348− then fail "Could not bind int."

366+ then fail "Could not bind int."

349− else return (MkStmtPtr x)

367+ else return (MkStmtPtr x)

350−

368+

351−

369+

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

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

353−bind_float (MkStmtPtr pointer) indexval val = do

371+bind_float (MkStmtPtr pointer) indexval val = do

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

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

355− flag <- liftIO(nullPtr x)

373+ flag <- liftIO (nullPtr x)

356 if flag

374 if flag

357− then fail "Could not bind float."

375+ then fail "Could not bind float."

358− else return (MkStmtPtr x)

376+ else return (MkStmtPtr x)

359

377

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

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

361bind_text (MkStmtPtr pointer) text indexval lengthval = do

379bind_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)

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

381+ pointer text indexval lengthval)

363− flag <- liftIO(nullPtr x)

382+ flag <- liftIO(nullPtr x)

364 if flag

383 if flag

365− then fail "Could not bind text."

384+ then fail "Could not bind text."

366− else return (MkStmtPtr x)

385+ else return (MkStmtPtr x)

367

386

368bind_null : StmtPtr -> Int -> DB StmtPtr

387bind_null : StmtPtr -> Int -> DB StmtPtr

369−bind_null (MkStmtPtr pointer) indexval = do

388+bind_null (MkStmtPtr pointer) indexval = do

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

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

371− flag <- liftIO(nullPtr x)

390+ flag <- liftIO (nullPtr x)

372 if flag

391 if flag

373− then fail "Could not bind null."

392+ then fail "Could not bind null."

374− else return (MkStmtPtr x)

393+ else return (MkStmtPtr x)

375

394

376-----------------------------------------------------------------------------

395-----------------------------------------------------------------------------

377-- | String Length

396-- | String Length

378-----------------------------------------------------------------------------

397-----------------------------------------------------------------------------

379−

398+

380strlen : String -> DB Int

399strlen : String -> DB Int

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

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

382−

401+

383instance Show DBVal where

402instance Show DBVal where

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

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

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

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

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

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

387− show (DBNull ) = "NULL"

406+ show (DBNull ) = "NULL"

388

407

389-----------------------------------------------------------------------------

408-----------------------------------------------------------------------------

390-- | Multi bind a list of values.

409-- | Multi bind a list of values.

391-----------------------------------------------------------------------------

410-----------------------------------------------------------------------------

392

411

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

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

394−bindMulti pointer [] = return pointer

413+bindMulti pointer [] = return pointer

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

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

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

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

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

416+ do x <- bind_int pointer indexs i

398− bindMulti(x) vs

417+ bindMulti x vs

399−

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

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

419+ do len <- strlen s

401− x <- bind_text pointer strval indexs len

420+ x <- bind_text pointer s indexs len

402− bindMulti(x) vs

421+ bindMulti x vs

403−

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

404−

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

423+ do x <- bind_float pointer indexs f

406−

407− bindMulti(x) vs

424+ bindMulti x vs

408

425

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

1+setlocal shiftwidth=2

2−set tabstop=2

2+setlocal tabstop=2

3−set expandtab

3+setlocal expandtab

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

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

4" highlighter to support idris.

5"

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

7−" date: Mar 20 2013

7+" date: May 24 2013

8

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

10syn match idrisImport "\<import\>"

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

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

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

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

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

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

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

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

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

29syn 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_]*`"

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

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

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

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

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

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

33

35

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

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

36−

37−highlight idrisBadLeadingWhiteSpace ctermbg=red

38−highlight idrisBadTrailingWhiteSpace ctermbg=red

39−

40highlight def link idrisImport Structure

36highlight def link idrisImport Structure

41highlight def link idrisModule Structure

37highlight def link idrisModule Structure

42highlight def link idrisStructure Structure

38highlight def link idrisStructure Structure

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

48highlight def link idrisVisibility Statement

44highlight def link idrisVisibility Statement

49highlight def link idrisConditional Conditional

45highlight def link idrisConditional Conditional

50highlight def link idrisProofBlock Macro

46highlight def link idrisProofBlock Macro

51−highlight idrisTactic ctermfg=cyan

47+highlight def link idrisTactic Identifier

52highlight def link idrisLink Statement

48highlight def link idrisLink Statement

53highlight def link idrisDirective Statement

49highlight def link idrisDirective Statement

54highlight def link idrisNumber Number

50highlight def link idrisNumber Number

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

59highlight def link idrisType Include

55highlight def link idrisType Include

60highlight def link idrisLineComment Comment

56highlight def link idrisLineComment Comment

61highlight def link idrisBlockComment Comment

57highlight def link idrisBlockComment Comment

62−highlight idrisMetaVar ctermfg=red

58+highlight def link idrisMetaVar Identifier

63highlight def link idrisString String

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

3import Effects

4

5data Random : Type -> Type -> Type -> Type where

6− getRandom : Random Int Int Int

6+ getRandom : Random Integer Integer Integer

7

8using (m : Type -> Type)

9 instance Handler Random m where

10 handle seed getRandom k

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

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

12 k seed' seed'

13−

13+

14RND : EFFECT

15−RND = MkEff Int Random

15+RND = MkEff Integer Random

16

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

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

18−rndInt lower upper = do v <- getRandom

18+rndInt lower upper = do v <- getRandom

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

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

20

21

effects/Effects.idr+21−12

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

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

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

50updateWith [] [] SubNil = []

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

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

51

53

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

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

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

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

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

55rebuildEnv [] SubNil env = env

57rebuildEnv [] SubNil env = env

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

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

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

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

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

58

61

59---- The Effect EDSL itself ----

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

60

63

61-- some proof automation

64-- some proof automation

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

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

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

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

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

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

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

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

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

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

67

70

68−findSubList : Nat -> Tactic

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

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

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

70−findSubList (S n)

73+findSubList (S n) ctxt goal

71 = GoalType "SubList"

74 = GoalType "SubList"

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

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

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

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

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

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

75

78

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

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

77 List EFFECT

80 List EFFECT

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

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

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

117

120

118implicit

121implicit

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

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

120 prf : SubList ys xs} ->

123 prf : SubList ys xs} ->

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

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

122lift' {prf} e = lift prf e

125lift' {prf} e = lift prf e

123

126

124implicit

127implicit

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

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

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

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

127 prf : EffElem e a xs} ->

130 prf : EffElem e a xs} ->

128 (eff : e a b t) ->

131 (eff : e a b t) ->

129 EffM m xs (updateResTy xs prf eff) t

132 EffM m xs (updateResTy xs prf eff) t

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

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

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

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

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

163

166

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+

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

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

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

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

166eff env (prog `ebind` c) k

172eff env (prog `ebind` c) k

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

175eff env (catch prog handler) k

181eff env (catch prog handler) k

176 = catch (eff env prog k)

182 = catch (eff env prog k)

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

183 (\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.

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

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

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

189+ = let env' = unlabel env in

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

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

181

191

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

192run : 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 |]

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

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

207when True e = e

217when True e = e

208when False e = pure ()

218when False e = pure ()

209−

effects/Makefile+1−1

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

4

5recheck: clean check

6

7−install:

7+install:

8 $(IDRIS) --install effects.ipkg

9

10clean: .PHONY

effects/effects.ipkg+3−1

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

3opts = "-i ../lib"

4modules = Effects,

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

1Name: idris

2−Version: 0.9.7

2+Version: 0.9.8.1

3License: BSD3

4License-file: LICENSE

5Author: Edwin Brady

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

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

57 lib/Network/*.idr lib/Control/*.idr

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

59+ lib/Language/Reflection/*.idr

59 lib/System/Concurrency/*.idr

60 lib/System/Concurrency/*.idr

60 lib/Data/*.idr lib/Debug/*.idr

61 lib/Data/*.idr lib/Debug/*.idr

62+ lib/Data/Vect/*.idr

61 lib/Decidable/*.idr

63 lib/Decidable/*.idr

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

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

63 effects/Makefile effects/*.idr effects/Effect/*.idr

65 effects/Makefile effects/*.idr effects/Effect/*.idr

64 effects/effects.ipkg

66 effects/effects.ipkg

67+ javascript/Makefile

68+ javascript/*.idr

69+ javascript/javascript.ipkg

65 config.mk

70 config.mk

66 rts/*.c rts/*.h rts/Makefile

71 rts/*.c rts/*.h rts/Makefile

67 js/*.js

72 js/*.js

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

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

69

74

70source-repository head

75source-repository head

71 type: git

76 type: git

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

88 Core.CaseTree, Core.Constraints,

93 Core.CaseTree, Core.Constraints,

89

94

90 Idris.AbsSyntax, Idris.AbsSyntaxTree,

95 Idris.AbsSyntax, Idris.AbsSyntaxTree,

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

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

92 Idris.REPLParser, Idris.ElabDecls, Idris.Error,

97 Idris.REPLParser, Idris.ElabDecls, Idris.Error,

93 Idris.Delaborate, Idris.Primitives, Idris.Imports,

98 Idris.Delaborate, Idris.Primitives, Idris.Imports,

94 Idris.Compiler, Idris.Prover, Idris.ElabTerm,

99 Idris.Compiler, Idris.Prover, Idris.ElabTerm,

95 Idris.Coverage, Idris.IBC, Idris.Unlit,

100 Idris.Coverage, Idris.IBC, Idris.Unlit,

96 Idris.DataOpts, Idris.Transforms, Idris.DSL,

101 Idris.DataOpts, Idris.Transforms, Idris.DSL,

97 Idris.UnusedArgs, Idris.Docs, Idris.Completion,

102 Idris.UnusedArgs, Idris.Docs, Idris.Completion,

103+ Idris.Providers,

98

104

99 Util.Pretty, Util.System, Util.DynamicLinker,

105 Util.Pretty, Util.System, Util.DynamicLinker,

100 Pkg.Package, Pkg.PParser,

106 Pkg.Package, Pkg.PParser,

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

111 haskeline>=0.7, split, directory,

117 haskeline>=0.7, split, directory,

112 containers, process, transformers, filepath,

118 containers, process, transformers, filepath,

113 directory, binary, bytestring, text, pretty,

119 directory, binary, bytestring, text, pretty,

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

120+ language-java>=0.2.2, libffi

115

121

116 Extensions: MultiParamTypeClasses, FunctionalDependencies,

122 Extensions: MultiParamTypeClasses, FunctionalDependencies,

117 FlexibleInstances, TemplateHaskell

123 FlexibleInstances, TemplateHaskell

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

119 ghc-options: -rtsopts

125 ghc-options: -rtsopts

120 if os(linux)

126 if os(linux)

121 cpp-options: -DLINUX

127 cpp-options: -DLINUX

128+ build-depends: unix

122 if os(darwin)

129 if os(darwin)

123 cpp-options: -DMACOSX

130 cpp-options: -DMACOSX

131+ build-depends: unix

124 if os(windows)

132 if os(windows)

125 cpp-options: -DWINDOWS

133 cpp-options: -DWINDOWS

134+ build-depends: Win32

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

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

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

192 }

193

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+

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

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

195 return result;

237 return result;

196 }

238 }

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');

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

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

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

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

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

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

14

15

16+

15/** @constructor */

17/** @constructor */

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

18__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+};

17

26

18/** @constructor */

27/** @constructor */

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

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

lib/Builtins.idr+7−4

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

44

45namespace Builtins {

46

47+Not : Type -> Type

48+Not a = a -> _|_

49+

47id : a -> a

50id : a -> a

48id x = x

51id x = x

49

52

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

248 (*) = prim__mulBigInt

251 (*) = prim__mulBigInt

249

252

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

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

251− fromInteger = prim__intToBigInt

254+ fromInteger = prim__sextInt_BigInt

252

255

253

256

254instance Num Float where

257instance Num Float where

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

257 (*) = prim__mulFloat

260 (*) = prim__mulFloat

258

261

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

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

260− fromInteger = prim__intToFloat

263+ fromInteger = prim__toFloatInt

261

264

262partial

265partial

263div : Int -> Int -> Int

266div : Int -> Int -> Int

264−div = prim__divInt

267+div = prim__sdivInt

265

268

266partial

269partial

267mod : Int -> Int -> Int

270mod : Int -> Int -> Int

268−mod = prim__modInt

271+mod = prim__sremInt

269

272

270

273

271(/) : Float -> Float -> Float

274(/) : Float -> Float -> Float

lib/Control/IOExcept.idr−1

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

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

17

18instance Monad (IOExcept e) where

19− return = pure

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

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

21 case x' of

20 case x' of

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

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

lib/Control/Monad/Identity.idr−1

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

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

17

18instance Monad Identity where

19− return x = Id x

20 (Id x) >>= k = k x

19 (Id x) >>= k = k x

lib/Control/Monad/State.idr−2

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

27 return (g b, t))

28

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

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

31−

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

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

33 let ST kv = k v

31 let ST kv = k v

34 kv st')

32 kv st')

lib/Data/Bits.idr+69−66

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

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

32natToBits' a O = a

33natToBits' {n=n} a x with n

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

34− natToBits' a (S x') | O = natToBits' (prim__addB8 a (prim__intToB8 1)) x'

35+ natToBits' a (S x') | O = natToBits' {n=0} (prim__addB8 a (prim__truncInt_B8 1)) x'

35− natToBits' a (S x') | S O = natToBits' (prim__addB16 a (prim__intToB16 1)) x'

36+ natToBits' a (S x') | S O = natToBits' {n=1} (prim__addB16 a (prim__truncInt_B16 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 O) = natToBits' {n=2} (prim__addB32 a (prim__truncInt_B32 1)) x'

37− natToBits' a (S x') | S (S (S _)) = natToBits' (prim__addB64 a (prim__intToB64 1)) x'

38+ natToBits' a (S x') | S (S (S _)) = natToBits' {n=3} (prim__addB64 a (prim__truncInt_B64 1)) x'

38

39

39natToBits : Nat -> machineTy n

40natToBits : Nat -> machineTy n

40natToBits {n=n} x with n

41natToBits {n=n} x with n

41− | O = natToBits' (prim__intToB8 0) x

42+ | O = natToBits' {n=0} (prim__truncInt_B8 0) x

42− | S O = natToBits' (prim__intToB16 0) x

43+ | S O = natToBits' {n=1} (prim__truncInt_B16 0) x

43− | S (S O) = natToBits' (prim__intToB32 0) x

44+ | S (S O) = natToBits' {n=2} (prim__truncInt_B32 0) x

44− | S (S (S _)) = natToBits' (prim__intToB64 0) x

45+ | S (S (S _)) = natToBits' {n=3} (prim__truncInt_B64 0) x

45

46

46getPad : Nat -> machineTy n

47getPad : Nat -> machineTy n

47getPad n = natToBits ((bitsUsed (nextBytes n)) - n)

48getPad n = natToBits ((bitsUsed (nextBytes n)) - n)

@@ -111,7 +112,8 @@ shiftRightLogical' {n=n} x c with n

111

112

112public

113public

113shiftRightLogical : Bits n -> Bits n -> Bits n

114shiftRightLogical : 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)

115

117

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

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

117shiftRightArithmetic' {n=n} x c with (nextBytes n)

119shiftRightArithmetic' {n=n} x c with (nextBytes n)

@@ -133,7 +135,7 @@ and' {n=n} x y with n

133

135

134public

136public

135and : Bits n -> Bits n -> Bits n

137and : 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)

137

139

138or' : machineTy n -> machineTy n -> machineTy n

140or' : machineTy n -> machineTy n -> machineTy n

139or' {n=n} x y with n

141or' {n=n} x y with n

@@ -144,7 +146,7 @@ or' {n=n} x y with n

144

146

145public

147public

146or : Bits n -> Bits n -> Bits n

148or : 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)

148

150

149xor' : machineTy n -> machineTy n -> machineTy n

151xor' : machineTy n -> machineTy n -> machineTy n

150xor' {n=n} x y with n

152xor' {n=n} x y with n

@@ -155,7 +157,7 @@ xor' {n=n} x y with n

155

157

156public

158public

157xor : Bits n -> Bits n -> Bits n

159xor : 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)

159

161

160plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

162plus' : machineTy (nextBytes n) -> machineTy (nextBytes n) -> machineTy (nextBytes n)

161plus' {n=n} x y with (nextBytes n)

163plus' {n=n} x y with (nextBytes n)

@@ -239,36 +241,36 @@ urem : Bits n -> Bits n -> Bits n

239urem (MkBits x) (MkBits y) = MkBits (urem' x y)

241urem (MkBits x) (MkBits y) = MkBits (urem' x y)

240

242

241-- TODO: Proofy comparisons via postulates

243-- TODO: Proofy comparisons via postulates

242−lt : machineTy n -> machineTy n -> Int

244+lt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

243−lt {n=n} x y with n

245+lt {n=n} x y with (nextBytes n)

244 | O = prim__ltB8 x y

246 | O = prim__ltB8 x y

245 | S O = prim__ltB16 x y

247 | S O = prim__ltB16 x y

246 | S (S O) = prim__ltB32 x y

248 | S (S O) = prim__ltB32 x y

247 | S (S (S _)) = prim__ltB64 x y

249 | S (S (S _)) = prim__ltB64 x y

248

250

249−lte : machineTy n -> machineTy n -> Int

251+lte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

250−lte {n=n} x y with n

252+lte {n=n} x y with (nextBytes n)

251 | O = prim__lteB8 x y

253 | O = prim__lteB8 x y

252 | S O = prim__lteB16 x y

254 | S O = prim__lteB16 x y

253 | S (S O) = prim__lteB32 x y

255 | S (S O) = prim__lteB32 x y

254 | S (S (S _)) = prim__lteB64 x y

256 | S (S (S _)) = prim__lteB64 x y

255

257

256−eq : machineTy n -> machineTy n -> Int

258+eq : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

257−eq {n=n} x y with n

259+eq {n=n} x y with (nextBytes n)

258 | O = prim__eqB8 x y

260 | O = prim__eqB8 x y

259 | S O = prim__eqB16 x y

261 | S O = prim__eqB16 x y

260 | S (S O) = prim__eqB32 x y

262 | S (S O) = prim__eqB32 x y

261 | S (S (S _)) = prim__eqB64 x y

263 | S (S (S _)) = prim__eqB64 x y

262

264

263−gte : machineTy n -> machineTy n -> Int

265+gte : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

264−gte {n=n} x y with n

266+gte {n=n} x y with (nextBytes n)

265 | O = prim__gteB8 x y

267 | O = prim__gteB8 x y

266 | S O = prim__gteB16 x y

268 | S O = prim__gteB16 x y

267 | S (S O) = prim__gteB32 x y

269 | S (S O) = prim__gteB32 x y

268 | S (S (S _)) = prim__gteB64 x y

270 | S (S (S _)) = prim__gteB64 x y

269

271

270−gt : machineTy n -> machineTy n -> Int

272+gt : machineTy (nextBytes n) -> machineTy (nextBytes n) -> Int

271−gt {n=n} x y with n

273+gt {n=n} x y with (nextBytes n)

272 | O = prim__gtB8 x y

274 | O = prim__gtB8 x y

273 | S O = prim__gtB16 x y

275 | S O = prim__gtB16 x y

274 | S (S O) = prim__gtB32 x y

276 | S (S O) = prim__gtB32 x y

@@ -308,14 +310,14 @@ complement (MkBits x) = MkBits (complement' x)

308zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))

310zext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))

309zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

311zext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

310 | (O, O) = believe_me x

312 | (O, O) = believe_me x

311− | (O, S O) = believe_me (prim__zextB8_16 (believe_me x))

313+ | (O, S O) = believe_me (prim__zextB8_B16 (believe_me x))

312− | (O, S (S O)) = believe_me (prim__zextB8_32 (believe_me x))

314+ | (O, S (S O)) = believe_me (prim__zextB8_B32 (believe_me x))

313− | (O, S (S (S _))) = believe_me (prim__zextB8_64 (believe_me x))

315+ | (O, S (S (S _))) = believe_me (prim__zextB8_B64 (believe_me x))

314 | (S O, S O) = believe_me x

316 | (S O, S O) = believe_me x

315− | (S O, S (S O)) = believe_me (prim__zextB16_32 (believe_me x))

317+ | (S O, S (S O)) = believe_me (prim__zextB16_B32 (believe_me x))

316− | (S O, S (S (S _))) = believe_me (prim__zextB16_64 (believe_me x))

318+ | (S O, S (S (S _))) = believe_me (prim__zextB16_B64 (believe_me x))

317 | (S (S O), S (S O)) = believe_me x

319 | (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))

319 | (S (S (S _)), S (S (S _))) = believe_me x

321 | (S (S (S _)), S (S (S _))) = believe_me x

320

322

321public

323public

@@ -326,13 +328,13 @@ zeroExtend (MkBits x) = MkBits (zext' x)

326intToBits' : Int -> machineTy (nextBytes n)

328intToBits' : Int -> machineTy (nextBytes n)

327intToBits' {n=n} x with (nextBytes n)

329intToBits' {n=n} x with (nextBytes n)

328 | O = let pad = getPad {n=0} n in

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

330 | S O = let pad = getPad {n=1} n in

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

332 | S (S O) = let pad = getPad {n=2} n in

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

334 | S (S (S _)) = let pad = getPad {n=3} n in

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

336

338

337public

339public

338intToBits : Int -> Bits n

340intToBits : Int -> Bits n

@@ -341,23 +343,23 @@ intToBits n = MkBits (intToBits' n)

341instance Cast Int (Bits n) where

343instance Cast Int (Bits n) where

342 cast = intToBits

344 cast = intToBits

343

345

344−bitsToInt' : machineTy n -> Int

346+bitsToInt' : machineTy (nextBytes n) -> Int

345−bitsToInt' {n=n} x with n

347+bitsToInt' {n=n} x with (nextBytes n)

346− | O = prim__B32ToInt (prim__zextB8_32 x)

348+ | O = prim__zextB8_Int x

347− | S O = prim__B32ToInt (prim__zextB16_32 x)

349+ | S O = prim__zextB16_Int x

348− | S (S O) = prim__B32ToInt x

350+ | S (S O) = prim__zextB32_Int x

349− | S (S (S _)) = prim__B32ToInt (prim__truncB64_32 x)

351+ | S (S (S _)) = prim__truncB64_Int x

350

352

351public

353public

352bitsToInt : Bits n -> Int

354bitsToInt : Bits n -> Int

353bitsToInt (MkBits x) = bitsToInt' x

355bitsToInt (MkBits x) = bitsToInt' x

354

356

355-- Zero out the high bits of a truncated bitstring

357-- Zero out the high bits of a truncated bitstring

356−zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n)

358+--zeroUnused : machineTy (nextBytes n) -> machineTy (nextBytes n)

357−zeroUnused x = x `and'` complement' (intToBits' 0)

359+--zeroUnused {n} x = x `and'` complement' (intToBits' {n=n} 0)

358

360

359−instance Cast Nat (Bits n) where

361+--instance Cast Nat (Bits n) where

360− cast x = MkBits (zeroUnused (natToBits n))

362+-- cast x = MkBits (zeroUnused (natToBits n))

361

363

362-- TODO: Prove

364-- TODO: Prove

363sext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))

365sext' : machineTy (nextBytes n) -> machineTy (nextBytes (n+m))

@@ -365,51 +367,51 @@ sext' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

365 | (O, O) = let pad = getPad {n=0} n in

367 | (O, O) = let pad = getPad {n=0} n in

366 believe_me (prim__ashrB8 (prim__shlB8 (believe_me x) pad) pad)

368 believe_me (prim__ashrB8 (prim__shlB8 (believe_me x) pad) pad)

367 | (O, S O) = let pad = getPad {n=0} n in

369 | (O, S O) = let pad = getPad {n=0} n in

368− believe_me (prim__ashrB16 (prim__sextB8_16 (prim__shlB8 (believe_me x) pad))

370+ believe_me (prim__ashrB16 (prim__sextB8_B16 (prim__shlB8 (believe_me x) pad))

369− (prim__zextB8_16 pad))

371+ (prim__zextB8_B16 pad))

370 | (O, S (S O)) = let pad = getPad {n=0} n in

372 | (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))

373+ believe_me (prim__ashrB32 (prim__sextB8_B32 (prim__shlB8 (believe_me x) pad))

372− (prim__zextB8_32 pad))

374+ (prim__zextB8_B32 pad))

373 | (O, S (S (S _))) = let pad = getPad {n=0} n in

375 | (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))

376+ believe_me (prim__ashrB64 (prim__sextB8_B64 (prim__shlB8 (believe_me x) pad))

375− (prim__zextB8_64 pad))

377+ (prim__zextB8_B64 pad))

376 | (S O, S O) = let pad = getPad {n=1} n in

378 | (S O, S O) = let pad = getPad {n=1} n in

377 believe_me (prim__ashrB16 (prim__shlB16 (believe_me x) pad) pad)

379 believe_me (prim__ashrB16 (prim__shlB16 (believe_me x) pad) pad)

378 | (S O, S (S O)) = let pad = getPad {n=1} n in

380 | (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))

381+ believe_me (prim__ashrB32 (prim__sextB16_B32 (prim__shlB16 (believe_me x) pad))

380− (prim__zextB16_32 pad))

382+ (prim__zextB16_B32 pad))

381 | (S O, S (S (S _))) = let pad = getPad {n=1} n in

383 | (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))

384+ believe_me (prim__ashrB64 (prim__sextB16_B64 (prim__shlB16 (believe_me x) pad))

383− (prim__zextB16_64 pad))

385+ (prim__zextB16_B64 pad))

384 | (S (S O), S (S O)) = let pad = getPad {n=2} n in

386 | (S (S O), S (S O)) = let pad = getPad {n=2} n in

385 believe_me (prim__ashrB32 (prim__shlB32 (believe_me x) pad) pad)

387 believe_me (prim__ashrB32 (prim__shlB32 (believe_me x) pad) pad)

386 | (S (S O), S (S (S _))) = let pad = getPad {n=2} n in

388 | (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))

389+ believe_me (prim__ashrB64 (prim__sextB32_B64 (prim__shlB32 (believe_me x) pad))

388− (prim__zextB32_64 pad))

390+ (prim__zextB32_B64 pad))

389 | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in

391 | (S (S (S _)), S (S (S _))) = let pad = getPad {n=3} n in

390 believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad)

392 believe_me (prim__ashrB64 (prim__shlB64 (believe_me x) pad) pad)

391

393

392−public

394+--public

393−signExtend : Bits n -> Bits (n+m)

395+--signExtend : Bits n -> Bits (n+m)

394−signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x))

396+--signExtend {m=m} (MkBits x) = MkBits (zeroUnused (sext' x))

395

397

396-- TODO: Prove

398-- TODO: Prove

397trunc' : machineTy (nextBytes (n+m)) -> machineTy (nextBytes n)

399trunc' : machineTy (nextBytes (n+m)) -> machineTy (nextBytes n)

398trunc' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

400trunc' {n=n} {m=m} x with (nextBytes n, nextBytes (n+m))

399 | (O, O) = believe_me x

401 | (O, O) = believe_me x

400− | (O, S O) = believe_me (prim__truncB16_8 (believe_me x))

402+ | (O, S O) = believe_me (prim__truncB16_B8 (believe_me x))

401− | (O, S (S O)) = believe_me (prim__truncB32_8 (believe_me x))

403+ | (O, S (S O)) = believe_me (prim__truncB32_B8 (believe_me x))

402− | (O, S (S (S _))) = believe_me (prim__truncB64_8 (believe_me x))

404+ | (O, S (S (S _))) = believe_me (prim__truncB64_B8 (believe_me x))

403 | (S O, S O) = believe_me x

405 | (S O, S O) = believe_me x

404− | (S O, S (S O)) = believe_me (prim__truncB32_16 (believe_me x))

406+ | (S O, S (S O)) = believe_me (prim__truncB32_B16 (believe_me x))

405− | (S O, S (S (S _))) = believe_me (prim__truncB64_16 (believe_me x))

407+ | (S O, S (S (S _))) = believe_me (prim__truncB64_B16 (believe_me x))

406 | (S (S O), S (S O)) = believe_me x

408 | (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))

408 | (S (S (S _)), S (S (S _))) = believe_me x

410 | (S (S (S _)), S (S (S _))) = believe_me x

409

411

410−public

412+--public

411−truncate : Bits (n+m) -> Bits n

413+--truncate : Bits (n+m) -> Bits n

412−truncate (MkBits x) = MkBits (zeroUnused (trunc' x))

414+--truncate (MkBits x) = MkBits (zeroUnused (trunc' x))

413

415

414public

416public

415bitAt : Fin n -> Bits n

417bitAt : Fin n -> Bits n

@@ -437,3 +439,4 @@ bitsToStr x = pack (helper last x)

437

439

438instance Show (Bits n) where

440instance Show (Bits n) where

439 show = bitsToStr

441 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

30 (Mor f) <$> (Mor a) = Mor $ \r => f r $ a r

31

32instance Monad (Morphism r) where

33− return a = Mor $ const a

34 (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r

33 (Mor h) >>= f = Mor $ \r => applyMor (f $ h r) r

35

34

36instance Semigroup (Endomorphism a) where

35instance 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 -> _

75leftNotRight refl impossible

76

77instance (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')

79 | Yes p = Yes $ cong p

80 | No p = No $ \h : Left x' = Left y' => p $ leftInjective {b = b} h

81 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

21run__IO : IO () -> IO ()

22run__IO v = io_bind v (\v' => io_return v')

23

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

25

44

26interpFTy : FTy -> Type

45interpFTy : FTy -> Type

27−interpFTy FInt = Int

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

28−interpFTy FFloat = Float

52+interpFTy FFloat = Float

29−interpFTy FChar = Char

30−interpFTy FString = String

53+interpFTy FString = String

31−interpFTy FPtr = Ptr

54+interpFTy FPtr = Ptr

32−interpFTy (FAny t) = t

55+interpFTy FUnit = ()

33−interpFTy FUnit = ()

56+

57+interpFTy (FFunction a b) = interpFTy a -> interpFTy b

34

58

35ForeignTy : (xs:List FTy) -> (t:FTy) -> Type

59ForeignTy : (xs:List FTy) -> (t:FTy) -> Type

36ForeignTy Nil rt = IO (interpFTy rt)

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

41instance Monad CGI where {

42 (>>=) (MkCGI f) k = MkCGI (\s => do v <- f s

43 getAction (k (fst v)) (snd v))

44−

45− return v = MkCGI (\s => return (v, s))

46}

44}

47

45

48setInfo : CGIInfo -> CGI ()

46setInfo : CGIInfo -> CGI ()

@@ -121,7 +119,7 @@ abstract

121runCGI : CGI a -> IO a

119runCGI : CGI a -> IO a

122runCGI prog = do

120runCGI prog = do

123 clen_in <- getEnv "CONTENT_LENGTH"

121 clen_in <- getEnv "CONTENT_LENGTH"

124− let clen = prim__strToInt clen_in

122+ let clen = prim__fromStrInt clen_in

125 content <- getContent clen

123 content <- getContent clen

126 query <- getEnv "QUERY_STRING"

124 query <- getEnv "QUERY_STRING"

127 cookie <- getEnv "HTTP_COOKIE"

125 cookie <- getEnv "HTTP_COOKIE"

lib/Prelude.idr+20−13

@@ -29,10 +29,10 @@ instance Show Nat where

29 show (S k) = "s" ++ show k

30

31instance Show Int where

32− show = prim__intToStr

32+ show = prim__toStrInt

33

34instance Show Integer where

35− show = prim__bigIntToStr

35+ show = prim__toStrBigInt

36

37instance Show Float where

38 show = prim__floatToStr

@@ -124,23 +124,17 @@ instance Alternative List where

124---- Monad instances

125

126instance Monad IO where

127− return t = io_return t

128 b >>= k = io_bind b k

127 b >>= k = io_bind b k

129

128

130instance Monad Maybe where

129instance Monad Maybe where

131− return t = Just t

132−

133 Nothing >>= k = Nothing

130 Nothing >>= k = Nothing

134 (Just x) >>= k = k x

131 (Just x) >>= k = k x

135

132

136instance Monad (Either e) where

133instance Monad (Either e) where

137− return = Right

138−

139 (Left n) >>= _ = Left n

134 (Left n) >>= _ = Left n

140 (Right r) >>= f = f r

135 (Right r) >>= f = f r

141

136

142instance Monad List where

137instance Monad List where

143− return x = [x]

144 m >>= f = concatMap f m

138 m >>= f = concatMap f m

145

139

146---- some mathematical operations

140---- some mathematical operations

@@ -148,6 +142,10 @@ instance Monad List where

148%include "math.h"

142%include "math.h"

149%lib "m"

143%lib "m"

150

144

145+pow : (Num a) => a -> Nat -> a

146+pow x O = 1

147+pow x (S n) = x * (pow x n)

148+

151exp : Float -> Float

149exp : Float -> Float

152exp x = prim__floatExp x

150exp x = prim__floatExp x

153

151

@@ -178,6 +176,15 @@ atan x = prim__floatATan x

178atan2 : Float -> Float -> Float

176atan2 : Float -> Float -> Float

179atan2 y x = atan (y/x)

177atan2 y x = atan (y/x)

180

178

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+

181sqrt : Float -> Float

188sqrt : Float -> Float

182sqrt x = prim__floatSqrt x

189sqrt x = prim__floatSqrt x

183

190

@@ -189,12 +196,12 @@ ceiling x = prim__floatCeil x

189

196

190---- Ranges

197---- Ranges

191

198

192−%assert_total

199+partial abstract

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

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

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

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

195 else []

202 else []

196

203

197−partial

204+partial abstract

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

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

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

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

200

207

@@ -242,11 +249,11 @@ getLine = return (prim__readString prim__stdin)

242

249

243partial

250partial

244putChar : Char -> IO ()

251putChar : Char -> IO ()

245−putChar c = mkForeign (FFun "putchar" [FChar] FUnit) c

252+putChar c = mkForeign (FFun "putchar" [FInt] FUnit) (cast c)

246

253

247partial

254partial

248getChar : IO Char

255getChar : IO Char

249−getChar = mkForeign (FFun "getchar" [] FChar)

256+getChar = fmap cast $ mkForeign (FFun "getchar" [] FInt)

250

257

251---- some basic file handling

258---- some basic file handling

252

259

@@ -314,7 +321,7 @@ ferror (FHandle h) = do err <- do_ferror h

314

321

315partial

322partial

316nullPtr : Ptr -> IO Bool

323nullPtr : 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

318 return (ok /= 0);

325 return (ok /= 0);

319

326

320partial

327partial

lib/Prelude/Cast.idr+7−7

@@ -6,24 +6,24 @@ class Cast from to where

6-- String casts

7

8instance Cast String Int where

9− cast = prim__strToInt

9+ cast = prim__fromStrInt

10

11instance Cast String Float where

12 cast = prim__strToFloat

13

14instance Cast String Integer where

15− cast = prim__strToBigInt

15+ cast = prim__fromStrBigInt

16

17-- Int casts

18

19instance Cast Int String where

20− cast = prim__intToStr

20+ cast = prim__toStrInt

21

22instance Cast Int Float where

23− cast = prim__intToFloat

23+ cast = prim__toFloatInt

24

25instance Cast Int Integer where

26− cast = prim__intToBigInt

26+ cast = prim__sextInt_BigInt

27

28instance Cast Int Char where

29 cast = prim__intToChar

@@ -34,12 +34,12 @@ instance Cast Float String where

34 cast = prim__floatToStr

35

36instance Cast Float Int where

37− cast = prim__floatToInt

37+ cast = prim__fromFloatInt

38

39-- Integer casts

40

41instance Cast Integer String where

42− cast = prim__bigIntToStr

42+ cast = prim__toStrBigInt

43

44-- Char casts

45

lib/Prelude/List.idr+1

@@ -399,6 +399,7 @@ span p (x::xs) =

399break : (a -> Bool) -> List a -> (List a, List a)

400break p = span (not . p)

401

402+%assert_total

402split : (a -> Bool) -> List a -> List (List a)

403split : (a -> Bool) -> List a -> List (List a)

403split p [] = []

404split p [] = []

404split p xs =

405split p xs =

lib/Prelude/Maybe.idr+1−1

@@ -66,7 +66,7 @@ instance (Eq a) => Eq (Maybe a) where

66-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to

67-- <http://en.wikipedia.org/wiki/Monoid>: "Any semigroup S may be

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

70

71instance (Semigroup a) => Semigroup (Maybe a) where

72 Nothing <+> m = m

lib/Prelude/Monad.idr+3−1

@@ -11,8 +11,10 @@ import Prelude.Applicative

11infixl 5 >>=

12

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

14− return : a -> m a

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

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

16

15

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

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

18flatten a = a >>= id

17flatten a = a >>= id

18+

19+return : Monad m => a -> m a

20+return = pure

lib/Providers.idr+1−4

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

1module Providers

2

3public

4−data Provider a = Provide (IO a) | Error (IO String)

4+data Provider a = Provide a | Error String

5

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

23 (lift f) <$> (lift a) = lift (f <$> a)

24

25instance Monad (Process msg) where

26− return = lift . return

27 (lift io) >>= k = lift (do x <- io

26 (lift io) >>= k = lift (do x <- io

28 case k x of

27 case k x of

29 lift v => v)

28 lift v => v)

lib/base.ipkg+7−3

@@ -13,15 +13,19 @@ modules = Builtins, Prelude, IO, System,

13

14 System.Concurrency.Raw, System.Concurrency.Process,

15

16− Decidable.Equality,

16+ Decidable.Equality, Decidable.Decidable, Decidable.Order,

17

18 Uninhabited,

19

20 Providers,

21

22− Language.Reflection,

22+ Language.Reflection, Language.Reflection.Utils,

23

24+ Data.Morphisms,

24− Data.Morphisms, Data.Bits, Data.Mod2, Data.Z, Data.Sign,

25+ Data.Bits, Data.Mod2,

26+ Data.Z, Data.Sign,

27+ Data.SortedMap, Data.SortedSet, Data.BoundedList,

28+ Data.Vect.Quantifiers,

25

29

26 Control.Monad.Identity, Control.Monad.State, Control.Category,

30 Control.Monad.Identity, Control.Monad.State, Control.Category,

27 Control.Arrow,

31 Control.Arrow,

rts/Makefile+4−4

@@ -2,15 +2,15 @@ include ../config.mk

2

3OBJS = idris_rts.o idris_heap.o idris_gc.o idris_gmp.o idris_stdfgn.o idris_bitstring.o idris_opts.o idris_stats.o

4HDRS = 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

6

7ifneq ($(GMP_INCLUDE_DIR),)

8− CFLAGS += -isystem $(GMP_INCLUDE_DIR)

8+ CFLAGS += -isystem $(GMP_INCLUDE_DIR)

9endif

10

11LIBTARGET = libidris_rts.a

12

13−check : $(LIBTARGET)

13+check : $(LIBTARGET) $(DYLIBTARGET)

14

15$(LIBTARGET) : $(OBJS)

16 ar r $(LIBTARGET) $(OBJS)

@@ -21,7 +21,7 @@ install : .PHONY

21 install $(LIBTARGET) $(HDRS) $(TARGET)

22

23clean : .PHONY

24− rm -f $(OBJS) $(LIBTARGET)

24+ rm -f $(OBJS) $(LIBTARGET) $(DYLIBTARGET)

25

26idris_rts.o: idris_rts.h

27

rts/idris_bitstring.c+28

@@ -60,6 +60,34 @@ VAL idris_castB32Int(VM *vm, VAL a) {

60 return MKINT((i_int)a->info.bits32);

61}

62

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+

63VAL idris_b8Plus(VM *vm, VAL a, VAL b) {

91VAL idris_b8Plus(VM *vm, VAL a, VAL b) {

64 VAL cl = allocate(vm, sizeof(Closure), 0);

92 VAL cl = allocate(vm, sizeof(Closure), 0);

65 SETTY(cl, BITS8);

93 SETTY(cl, BITS8);

rts/idris_bitstring.h+4

@@ -11,6 +11,10 @@ VAL idris_b16(VM *vm, VAL a);

11VAL idris_b32(VM *vm, VAL a);

12VAL idris_b64(VM *vm, VAL a);

13VAL 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);

14

18

15VAL idris_b8Plus(VM *vm, VAL a, VAL b);

19VAL idris_b8Plus(VM *vm, VAL a, VAL b);

16VAL idris_b8Minus(VM *vm, VAL a, VAL b);

20VAL idris_b8Minus(VM *vm, VAL a, VAL b);

rts/idris_gmp.c+52

@@ -52,6 +52,34 @@ VAL MKBIGMc(VM* vm, void* big) {

52 return cl;

53}

54

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+

55VAL GETBIG(VM * vm, VAL x) {

83VAL GETBIG(VM * vm, VAL x) {

56 if (ISINT(x)) {

84 if (ISINT(x)) {

57 mpz_t* bigint;

85 mpz_t* bigint;

@@ -280,6 +308,30 @@ VAL idris_castBigInt(VM* vm, VAL i) {

280 }

308 }

281}

309}

282

310

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+

283VAL idris_castStrBig(VM* vm, VAL i) {

335VAL idris_castStrBig(VM* vm, VAL i) {

284 return MKBIGC(vm, GETSTR(i));

336 return MKBIGC(vm, GETSTR(i));

285}

337}

rts/idris_gmp.h+4

@@ -5,6 +5,8 @@ VAL MKBIGI(int val);

5VAL MKBIGC(VM* vm, char* bigint);

6VAL MKBIGM(VM* vm, void* bigint);

7VAL MKBIGMc(VM* vm, void* bigint);

8+VAL MKBIGUI(VM* vm, unsigned long val);

9+VAL MKBIGSI(VM* vm, signed long val);

8

10

9VAL idris_bigPlus(VM*, VAL x, VAL y);

11VAL idris_bigPlus(VM*, VAL x, VAL y);

10VAL idris_bigMinus(VM*, VAL x, VAL y);

12VAL idris_bigMinus(VM*, VAL x, VAL y);

@@ -22,6 +24,8 @@ VAL idris_bigGe(VM*, VAL x, VAL y);

22

24

23VAL idris_castIntBig(VM* vm, VAL i);

25VAL idris_castIntBig(VM* vm, VAL i);

24VAL idris_castBigInt(VM* vm, VAL i);

26VAL idris_castBigInt(VM* vm, VAL i);

27+VAL idris_castFloatBig(VM* vm, VAL i);

28+VAL idris_castBigFloat(VM* vm, VAL i);

25VAL idris_castStrBig(VM* vm, VAL i);

29VAL idris_castStrBig(VM* vm, VAL i);

26VAL idris_castBigStr(VM* vm, VAL i);

30VAL idris_castBigStr(VM* vm, VAL i);

27

31

rts/idris_rts.c+44

@@ -186,6 +186,34 @@ VAL MKPTRc(VM* vm, void* ptr) {

186 return cl;

187}

188

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+

189void PROJECT(VM* vm, VAL r, int loc, int arity) {

217void PROJECT(VM* vm, VAL r, int loc, int arity) {

190 int i;

218 int i;

191 for(i = 0; i < arity; ++i) {

219 for(i = 0; i < arity; ++i) {

@@ -243,6 +271,22 @@ void dumpVal(VAL v) {

243

271

244}

272}

245

273

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+

246VAL idris_castIntStr(VM* vm, VAL i) {

290VAL idris_castIntStr(VM* vm, VAL i) {

247 Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0);

291 Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0);

248 SETTY(cl, STRING);

292 SETTY(cl, STRING);

rts/idris_rts.h+11

@@ -125,6 +125,7 @@ typedef intptr_t i_int;

125#define ISINT(x) ((((i_int)x)&1) == 1)

126

127#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)))

128#define FLOATOP(op,x,y) MKFLOAT(vm, ((GETFLOAT(x)) op (GETFLOAT(y))))

129#define FLOATOP(op,x,y) MKFLOAT(vm, ((GETFLOAT(x)) op (GETFLOAT(y))))

129#define FLOATBOP(op,x,y) MKINT((i_int)(((GETFLOAT(x)) op (GETFLOAT(y)))))

130#define FLOATBOP(op,x,y) MKINT((i_int)(((GETFLOAT(x)) op (GETFLOAT(y)))))

130#define ADD(x,y) (void*)(((i_int)x)+(((i_int)y)-1))

131#define ADD(x,y) (void*)(((i_int)x)+(((i_int)y)-1))

@@ -147,6 +148,10 @@ typedef intptr_t i_int;

147VAL MKFLOAT(VM* vm, double val);

148VAL MKFLOAT(VM* vm, double val);

148VAL MKSTR(VM* vm, char* str);

149VAL MKSTR(VM* vm, char* str);

149VAL MKPTR(VM* vm, void* ptr);

150VAL 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);

150

155

151// following versions don't take a lock when allocating

156// following versions don't take a lock when allocating

152VAL MKFLOATc(VM* vm, double val);

157VAL MKFLOATc(VM* vm, double val);

@@ -202,6 +207,12 @@ VAL idris_castStrInt(VM* vm, VAL i);

202VAL idris_castFloatStr(VM* vm, VAL i);

207VAL idris_castFloatStr(VM* vm, VAL i);

203VAL idris_castStrFloat(VM* vm, VAL i);

208VAL idris_castStrFloat(VM* vm, VAL i);

204

209

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+

205// String primitives

216// String primitives

206

217

207VAL idris_concat(VM* vm, VAL l, VAL r);

218VAL idris_concat(VM* vm, VAL l, VAL r);

rts/idris_stdfgn.h−1

@@ -8,7 +8,6 @@ void putStr(char* str);

8

9void* fileOpen(char* f, char* mode);

10void fileClose(void* h);

11−//char* freadStr(void* h);

12void fputStr(void*h, char* str);

11void fputStr(void*h, char* str);

13

12

14int isNull(void* ptr);

13int isNull(void* ptr);

samples/reflection.idr+25−14

@@ -60,33 +60,44 @@ intEq x y = case x == y of

60

61-- | A tactic script to run intEq on two let-bound or introduced

62-- arguments of the current (otherwise empty) proof context

63−firstEq : List (TTName, Binder TT) -> Tactic

63+firstEq : List (TTName, Binder TT) -> TT -> Tactic

64−firstEq ((_, (Let _ y))::(_, (Let _ x))::(_, Let _ f)::Nil) = Exact (App (App f x) y)

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

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

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

67−

67+

68−-- | Skip 3 arguments of the proof context and return the fourth one which

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

69−-- has to be introduced.

70−-- Used for the tactical dispatch example, which will push dispatch,

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

71−-- its current proof context and the result of dispatch applied to it

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

72−-- first.

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

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

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

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

75

73

76-- | Returns the reflected representation of innerTac

74-- | Returns the reflected representation of innerTac

77innerTacTT : TT

75innerTacTT : TT

78innerTacTT = ?innerTacTTPrf

76innerTacTT = ?innerTacTTPrf

79

77

80-- | Dispatch to the reflected rep. of innerTac

78-- | Dispatch to the reflected rep. of innerTac

81−dispatch : List (TTName, Binder TT) -> Tactic

79+dispatch : List (TTName, Binder TT) -> TT -> Tactic

82−dispatch xs = ApplyTactic (innerTacTT)

80+dispatch xs _ = ApplyTactic (innerTacTT)

83

81

84-- | Call dispatch which will then dispatch to innerTac.

82-- | Call dispatch which will then dispatch to innerTac.

85tacticalDispatch : Int -> Int

83tacticalDispatch : Int -> Int

86tacticalDispatch = ?tacticalDispatchPrf

84tacticalDispatch = ?tacticalDispatchPrf

87

85

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+

88---------- Proofs ----------

95---------- Proofs ----------

89

96

97+ReflectionExamples.studyGoalPrf = proof {

98+ applyTactic studyGoalTac;

99+}

100+

90ReflectionExamples.envTuplePrf = proof {

101ReflectionExamples.envTuplePrf = proof {

91 let x = tupleType;

102 let x = tupleType;

92 fill x;

103 fill x;

src/Core/CaseTree.hs+16−10

@@ -14,11 +14,11 @@ import Debug.Trace

14data CaseDef = CaseDef [Name] SC [Term]

15 deriving Show

16

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

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

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

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

19 | STerm t

20− | UnmatchedCase String -- error message

20+ | UnmatchedCase String -- ^ error message

21− | ImpossibleCase -- already checked to be impossible

21+ | ImpossibleCase -- ^ already checked to be impossible

22 deriving (Eq, Ord, Functor)

23{-!

24deriving instance Binary SC

@@ -351,10 +351,13 @@ argsToAlt rs@((r, m) : rest)

351 return (newArgs, addRs rs)

352 where

353 getNewVars [] = return []

354− getNewVars ((PV n) : ns) = do v <- getVar

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

355 nsv <- getNewVars ns

356 return (v : nsv)

357+ getNewVars (PAny : ns) = do v <- getVar "i"

358+ nsv <- getNewVars ns

359+ return (v : nsv)

357− getNewVars (_ : ns) = do v <- getVar

360+ getNewVars (_ : ns) = do v <- getVar "e"

358 nsv <- getNewVars ns

361 nsv <- getNewVars ns

359 return (v : nsv)

362 return (v : nsv)

360 addRs [] = []

363 addRs [] = []

@@ -363,8 +366,8 @@ argsToAlt rs@((r, m) : rest)

363 uniq i (UN n) = MN i n

366 uniq i (UN n) = MN i n

364 uniq i n = n

367 uniq i n = n

365

368

366−getVar :: State CS Name

369+getVar :: String -> State CS Name

367−getVar = do (t, v) <- get; put (t, v+1); return (MN v "e")

370+getVar b = do (t, v) <- get; put (t, v+1); return (MN v b)

368

371

369groupCons :: [Clause] -> State CS [Group]

372groupCons :: [Clause] -> State CS [Group]

370groupCons cs = gc [] cs

373groupCons cs = gc [] cs

@@ -393,10 +396,12 @@ varRule (v : vs) alts err =

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

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

394 match vs alts' err

397 match vs alts' err

395 where

398 where

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

396− repVar v (PV p : ps , (lhs, res)) = (ps, (lhs, subst p (P Bound v Erased) res))

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

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

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

398

402

399-- fix: case e of S k -> f (S k) ==> case e of S k -> f e

403-- fix: case e of S k -> f (S k) ==> case e of S k -> f e

404+

400depatt :: [Name] -> SC -> SC

405depatt :: [Name] -> SC -> SC

401depatt ns tm = dp [] tm

406depatt ns tm = dp [] tm

402 where

407 where

@@ -419,8 +424,9 @@ depatt ns tm = dp [] tm

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

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

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

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

421 | otherwise = applyMap ms nt cn pty args'

426 | otherwise = applyMap ms nt cn pty args'

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

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

423 same _ _ = False

428 same _ _ = False

429+

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

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

425 applyMaps ms t = t

431 applyMaps ms t = t

426

432

src/Core/CoreParser.hs+1−1

@@ -466,7 +466,7 @@ idrisMakeTokenParser languageDef

466

467 number base baseDigit

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

470 ; seq n (return n)

471 }

472

src/Core/Elaborate.hs+39−6

@@ -171,7 +171,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context

171 if isInj ctxt tm then return ()

172 else lift $ tfail (NotInjective tm l r)

173 where isInj ctxt (P _ n _)

174− | isConName Nothing n ctxt = True

174+ | isConName n ctxt = True

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

176 isInj ctxt (Constant _) = True

177 isInj ctxt (TType _) = True

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

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

211uniqueNameCtxt ctxt n hs

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

214 | otherwise = return n

215

216elog :: String -> Elab' aux ()

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

356 mkClaims _ _ _ _

357 | Var n <- fn

358 = do ctxt <- get_context

359− case lookupTy Nothing n ctxt of

359+ case lookupTy n ctxt of

360 [] -> lift $ tfail $ NoSuchVariable n

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

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

@@ -391,10 +391,13 @@ apply fn imps =

391 else

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

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

394− unified p

394+ unified p

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

396− dropGiven dont hunis hs

396+ dropGiven dont hunis hs

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

398+ keepGiven dont hunis hs

397− put (ES (p { dontunify = dont, unified = (n, unify) }, a) s prev)

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

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

398 ptm <- get_term

401 ptm <- get_term

399 g <- goal

402 g <- goal

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

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

@@ -469,6 +472,23 @@ apply_elab n args =

469 mkMN n@(UN x) = MN 1000 x

472 mkMN n@(UN x) = MN 1000 x

470 mkMN (NS n ns) = NS (mkMN n) ns

473 mkMN (NS n ns) = NS (mkMN n) ns

471

474

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+

472simple_app :: Elab' aux () -> Elab' aux () -> Elab' aux ()

492simple_app :: Elab' aux () -> Elab' aux () -> Elab' aux ()

473simple_app fun arg =

493simple_app fun arg =

474 do a <- unique_hole (MN 0 "argTy")

494 do a <- unique_hole (MN 0 "argTy")

@@ -508,6 +528,19 @@ arg n tyhole = do ty <- unique_hole tyhole

508 claim ty RType

528 claim ty RType

509 forall n (Var ty)

529 forall n (Var ty)

510

530

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+

511-- Try a tactic, if it fails, try another

544-- Try a tactic, if it fails, try another

512try :: Elab' aux a -> Elab' aux a -> Elab' aux a

545try :: Elab' aux a -> Elab' aux a -> Elab' aux a

513try t1 t2 = try' t1 t2 False

546try t1 t2 = try' t1 t2 False

src/Core/Evaluate.hs+92−70

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

9 addDatatype, addCasedef, simplifyCasedef, addOperator,

10 lookupNames, lookupTy, lookupP, lookupDef, lookupVal,

11 lookupTotal, lookupTyEnv, isConName, isFnName,

12− Value(..)) where

12+ Value(..), Quote(..), evalState, initEval) where

13

14import Debug.Trace

15import Control.Monad.State

@@ -19,20 +19,24 @@ import Data.Binary hiding (get, put)

19import Core.TT

20import Core.CaseTree

21

22−data EvalState = ES { limited :: [(Name, Int)] }

22+data EvalState = ES { limited :: [(Name, Int)],

23+ nexthole :: Int }

23

24

24type Eval a = State EvalState a

25type Eval a = State EvalState a

25

26

26data EvalOpt = Spec | HNF | Simplify Bool | AtREPL

27data EvalOpt = Spec | HNF | Simplify Bool | AtREPL

27 deriving (Show, Eq)

28 deriving (Show, Eq)

28

29

29−initEval = ES []

30+initEval = ES [] 0

30

31

31-- VALUES (as HOAS) ---------------------------------------------------------

32-- VALUES (as HOAS) ---------------------------------------------------------

32-- | A HOAS representation of values

33-- | A HOAS representation of values

33data Value = VP NameType Name Value

34data Value = VP NameType Name Value

34 | VV Int

35 | VV Int

36+ -- True for Bool indicates safe to reduce

35− | VBind Name (Binder Value) (Value -> Eval Value)

37+ | VBind Bool Name (Binder Value) (Value -> Eval Value)

38+ -- For frozen let bindings when simplifying

39+ | VBLet Int Name Value Value Value

36 | VApp Value Value

40 | VApp Value Value

37 | VType UExp

41 | VType UExp

38 | VErased

42 | VErased

@@ -91,8 +95,9 @@ specialise ctxt env limits t

91simplify :: Context -> Bool -> Env -> TT Name -> TT Name

95simplify :: Context -> Bool -> Env -> TT Name -> TT Name

92simplify ctxt runtime env t

96simplify ctxt runtime env t

93 = evalState (do val <- eval False ctxt [(UN "lazy", 0),

97 = evalState (do val <- eval False ctxt [(UN "lazy", 0),

98+ (UN "assert_smaller", 0),

94− (UN "par", 0),

99+ (UN "par", 0),

95− (UN "fork", 0)]

100+ (UN "fork", 0)]

96 (map finalEntry env) (finalise t)

101 (map finalEntry env) (finalise t)

97 [Simplify runtime]

102 [Simplify runtime]

98 quote 0 val) initEval

103 quote 0 val) initEval

@@ -149,7 +154,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

149 ev ntimes_in stk top env (P Ref n ty)

154 ev ntimes_in stk top env (P Ref n ty)

150 | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty)

155 | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty)

151 | (True, ntimes) <- usable simpl n ntimes_in

156 | (True, ntimes) <- usable simpl n ntimes_in

152− = do let val = lookupDefAcc Nothing n atRepl ctxt

157+ = do let val = lookupDefAcc n atRepl ctxt

153 case val of

158 case val of

154 [(Function _ tm, Public)] ->

159 [(Function _ tm, Public)] ->

155 ev ntimes (n:stk) True env tm

160 ev ntimes (n:stk) True env tm

@@ -165,28 +170,33 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

165 (Just v, _) -> return v

170 (Just v, _) -> return v

166 _ -> liftM (VP Ref n) (ev ntimes stk top env ty)

171 _ -> liftM (VP Ref n) (ev ntimes stk top env ty)

167 ev ntimes stk top env (P nt n ty) = liftM (VP nt n) (ev ntimes stk top env ty)

172 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

169 | otherwise = return $ VV i

175 | otherwise = return $ VV i

170 ev ntimes stk top env (Bind n (Let t v) sc)

176 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

172 = do v' <- ev ntimes stk top env v --(finalise v)

178 = do v' <- ev ntimes stk top env v --(finalise v)

173 sc' <- ev ntimes stk top (v' : env) sc

179 sc' <- ev ntimes stk top (v' : env) sc

174 wknV (-1) sc'

180 wknV (-1) sc'

175−{- | otherwise -- put this back when the Bind works properly

181+ | otherwise -- put this back when the Bind works properly

176 = do t' <- ev ntimes stk top env t

182 = do t' <- ev ntimes stk top env t

177 v' <- ev ntimes stk top env v --(finalise v)

183 v' <- ev ntimes stk top env v --(finalise v)

178 -- use Tmp as a placeholder, then make it a variable reference

184 -- use Tmp as a placeholder, then make it a variable reference

179 -- again when evaluation finished

185 -- again when evaluation finished

186+ hs <- get

187+ let vd = nexthole hs

188+ put (hs { nexthole = vd + 1 })

180− sc' <- ev ntimes stk top (v' : env) sc

189+ sc' <- ev ntimes stk top (VP Bound (MN vd "vlet") VErased : env) sc

181− return $ VBind n (Let t' v') (\x -> return sc') -}

190+ return $ VBLet vd n t' v' sc'

182 ev ntimes stk top env (Bind n (NLet t v) sc)

191 ev ntimes stk top env (Bind n (NLet t v) sc)

183 = do t' <- ev ntimes stk top env (finalise t)

192 = do t' <- ev ntimes stk top env (finalise t)

184 v' <- ev ntimes stk top env (finalise v)

193 v' <- ev ntimes stk top env (finalise v)

185 sc' <- ev ntimes stk top (v' : env) sc

194 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')

187 ev ntimes stk top env (Bind n b sc)

196 ev ntimes stk top env (Bind n b sc)

188 = do b' <- vbind env b

197 = do b' <- vbind env b

198+ return $ VBind (not simpl || vinstances 0 sc < 2)

189− return $ VBind n b' (\x -> ev ntimes stk False (x:env) sc)

199+ n b' (\x -> ev ntimes stk False (x:env) sc)

190 where vbind env t

200 where vbind env t

191 | simpl

201 | simpl

192 = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

202 = fmapMB (\tm -> ev ((MN 0 "STOP", 0) : ntimes)

@@ -208,10 +218,10 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

208 evApply ntimes stk top env (a:args) f

218 evApply ntimes stk top env (a:args) f

209 evApply ntimes stk top env args f = apply ntimes stk top env f args

219 evApply ntimes stk top env args f = apply ntimes stk top env f args

210

220

211− apply ntimes stk top env (VBind n (Lam t) sc) (a:as)

221+ apply ntimes stk top env (VBind True n (Lam t) sc) (a:as)

212− = do a' <- sc a

222+ = do a' <- sc a

213− app <- apply ntimes stk top env a' as

223+ app <- apply ntimes stk top env a' as

214− wknV (-1) app

224+ wknV (-1) app

215-- apply ntimes stk False env f args

225-- apply ntimes stk False env f args

216-- | spec = specApply ntimes stk env f args

226-- | spec = specApply ntimes stk env f args

217 apply ntimes_in stk top env f@(VP Ref n ty) args

227 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

220 _ -> return $ unload env f args

230 _ -> return $ unload env f args

221 | (True, ntimes) <- usable simpl n ntimes_in

231 | (True, ntimes) <- usable simpl n ntimes_in

222 = traceWhen traceon (show stk) $

232 = traceWhen traceon (show stk) $

223− do let val = lookupDefAcc Nothing n atRepl ctxt

233+ do let val = lookupDefAcc n atRepl ctxt

224 case val of

234 case val of

225 [(CaseOp inl inr _ _ _ ns tree _ _, acc)]

235 [(CaseOp inl inr _ _ _ ns tree _ _, acc)]

226 | acc == Public -> -- unoptimised version

236 | acc == Public -> -- unoptimised version

@@ -243,7 +253,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

243 apply ntimes stk top env f [] = return f

253 apply ntimes stk top env f [] = return f

244

254

245-- specApply stk env f@(VP Ref n ty) args

255-- specApply stk env f@(VP Ref n ty) args

246−-- = case lookupCtxt Nothing n statics of

256+-- = case lookupCtxt n statics of

247-- [as] -> if or as

257-- [as] -> if or as

248-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $

258-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $

249-- return $ unload env f args

259-- return $ unload env f args

@@ -330,15 +340,14 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where

330 getValArgs' (VApp f a) as = getValArgs' f (a:as)

340 getValArgs' (VApp f a) as = getValArgs' f (a:as)

331 getValArgs' f as = (f, as)

341 getValArgs' f as = (f, as)

332

342

333−tmpToV i (VTmp 0) = return $ VV i

343+-- tmpToV i vd (VLetHole j) | vd == j = return $ VV i

334−tmpToV i (VP nt n v) = liftM (VP nt n) (tmpToV i v)

344+-- tmpToV i vd (VP nt n v) = liftM (VP nt n) (tmpToV i vd v)

335−

336−tmpToV i (VBind n b sc) = do b' <- fmapMB (tmpToV i) b

345+-- tmpToV i vd (VBind n b sc) = do b' <- fmapMB (tmpToV i vd) b

337− let sc' = \x -> do x' <- sc x

346+-- let sc' = \x -> do x' <- sc x

338− tmpToV (i + 1) x'

347+-- tmpToV (i + 1) vd x'

339− return (VBind n b' sc')

348+-- return (VBind n b' sc')

340−tmpToV i (VApp f a) = liftM2 VApp (tmpToV i f) (tmpToV i a)

349+-- tmpToV i vd (VApp f a) = liftM2 VApp (tmpToV i vd f) (tmpToV i vd a)

341−tmpToV i x = return x

350+-- tmpToV i vd x = return x

342

351

343class Quote a where

352class Quote a where

344 quote :: Int -> a -> Eval (TT Name)

353 quote :: Int -> a -> Eval (TT Name)

@@ -346,10 +355,16 @@ class Quote a where

346instance Quote Value where

355instance Quote Value where

347 quote i (VP nt n v) = liftM (P nt n) (quote i v)

356 quote i (VP nt n v) = liftM (P nt n) (quote i v)

348 quote i (VV x) = return $ V x

357 quote i (VV x) = return $ V x

349− quote i (VBind n b sc) = do sc' <- sc (VTmp i)

358+ quote i (VBind _ n b sc) = do sc' <- sc (VTmp i)

350− b' <- quoteB b

359+ b' <- quoteB b

351− liftM (Bind n b') (quote (i+1) sc')

360+ liftM (Bind n b') (quote (i+1) sc')

352 where quoteB t = fmapMB (quote i) t

361 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'')

353 quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

368 quote i (VApp f a) = liftM2 App (quote i f) (quote i a)

354 quote i (VType u) = return $ TType u

369 quote i (VType u) = return $ TType u

355 quote i VErased = return $ Erased

370 quote i VErased = return $ Erased

@@ -375,9 +390,9 @@ instance Quote HNF where

375

390

376wknV :: Int -> Value -> Eval Value

391wknV :: Int -> Value -> Eval Value

377wknV i (VV x) = return $ VV (x + i)

392wknV i (VV x) = return $ VV (x + i)

378−wknV i (VBind n b sc) = do b' <- fmapMB (wknV i) b

393+wknV i (VBind red n b sc) = do b' <- fmapMB (wknV i) b

379− return $ VBind n b' (\x -> do x' <- sc x

394+ return $ VBind red n b' (\x -> do x' <- sc x

380− wknV i x')

395+ wknV i x')

381wknV i (VApp f a) = liftM2 VApp (wknV i f) (wknV i a)

396wknV i (VApp f a) = liftM2 VApp (wknV i f) (wknV i a)

382wknV i t = return t

397wknV i t = return t

383

398

@@ -397,7 +412,7 @@ eval_hnf ctxt statics genv tm = ev [] tm where

397 ev :: [HNF] -> TT Name -> Eval HNF

412 ev :: [HNF] -> TT Name -> Eval HNF

398 ev env (P _ n ty)

413 ev env (P _ n ty)

399 | Just (Let t v) <- lookup n genv = ev env v

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

401 [Function _ t] -> ev env t

416 [Function _ t] -> ev env t

402 [TyDecl nt ty] -> return $ HP nt n ty

417 [TyDecl nt ty] -> return $ HP nt n ty

403 [CaseOp inl _ _ _ _ [] tree _ _] ->

418 [CaseOp inl _ _ _ _ [] tree _ _] ->

@@ -430,7 +445,7 @@ eval_hnf ctxt statics genv tm = ev [] tm where

430 app <- apply env sc' as

445 app <- apply env sc' as

431 wknH (-1) app

446 wknH (-1) app

432 apply env (HP Ref n ty) args

447 apply env (HP Ref n ty) args

433− | [CaseOp _ _ _ _ _ ns tree _ _] <- lookupDef Nothing n ctxt

448+ | [CaseOp _ _ _ _ _ ns tree _ _] <- lookupDef n ctxt

434 = do c <- evCase env ns args tree

449 = do c <- evCase env ns args tree

435 case c of

450 case c of

436 (Nothing, _, env') -> return $ unload env' (HP Ref n ty) args

451 (Nothing, _, env') -> return $ unload env' (HP Ref n ty) args

@@ -525,6 +540,12 @@ convEq ctxt = ceq [] where

525 ceq ps (P xt x _) (P yt y _)

540 ceq ps (P xt x _) (P yt y _)

526 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

541 | x == y || (x, y) `elem` ps || (y,x) `elem` ps = return True

527 | otherwise = sameDefs ps x y

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

528 ceq ps (V x) (V y) = return (x == y)

549 ceq ps (V x) (V y) = return (x == y)

529 ceq ps (Bind _ xb xs) (Bind _ yb ys)

550 ceq ps (Bind _ xb xs) (Bind _ yb ys)

530 = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys)

551 = liftM2 (&&) (ceqB ps xb yb) (ceq ps xs ys)

@@ -559,7 +580,7 @@ convEq ctxt = ceq [] where

559 caseeq ps (UnmatchedCase _) (UnmatchedCase _) = return True

580 caseeq ps (UnmatchedCase _) (UnmatchedCase _) = return True

560 caseeq ps _ _ = return False

581 caseeq ps _ _ = return False

561

582

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

563 ([Function _ xdef], [Function _ ydef])

584 ([Function _ xdef], [Function _ ydef])

564 -> ceq ((x,y):ps) xdef ydef

585 -> ceq ((x,y):ps) xdef ydef

565 ([CaseOp _ _ _ _ _ _ xdef _ _],

586 ([CaseOp _ _ _ _ _ _ xdef _ _],

@@ -663,7 +684,7 @@ data Context = MkContext {

663 uconstraints :: [UConstraint],

684 uconstraints :: [UConstraint],

664 next_tvar :: Int,

685 next_tvar :: Int,

665 definitions :: Ctxt (Def, Accessibility, Totality)

686 definitions :: Ctxt (Def, Accessibility, Totality)

666− }

687+ } deriving Show

667

688

668-- | The initial empty context

689-- | The initial empty context

669initContext = MkContext [] 0 emptyContext

690initContext = MkContext [] 0 emptyContext

@@ -697,10 +718,10 @@ addCtxtDef n d c = let ctxt = definitions c

697 ctxt' = addDef n (d, Public, Unchecked) ctxt in

718 ctxt' = addDef n (d, Public, Unchecked) ctxt in

698 c { definitions = ctxt' }

719 c { definitions = ctxt' }

699

720

700−addTyDecl :: Name -> Type -> Context -> Context

721+addTyDecl :: Name -> NameType -> Type -> Context -> Context

701−addTyDecl n ty uctxt

722+addTyDecl n nt ty uctxt

702 = let ctxt = definitions uctxt

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

704 uctxt { definitions = ctxt' }

725 uctxt { definitions = ctxt' }

705

726

706addDatatype :: Datatype Name -> Context -> Context

727addDatatype :: Datatype Name -> Context -> Context

@@ -724,7 +745,7 @@ addCasedef :: Name -> Bool -> Bool -> Bool -> Bool ->

724 Type -> Context -> Context

745 Type -> Context -> Context

725addCasedef n alwaysInline tcase covering asserted ps_in ps psrt ty uctxt

746addCasedef n alwaysInline tcase covering asserted ps_in ps psrt ty uctxt

726 = let ctxt = definitions uctxt

747 = let ctxt = definitions uctxt

727− access = case lookupDefAcc Nothing n False uctxt of

748+ access = case lookupDefAcc n False uctxt of

728 [(_, acc)] -> acc

749 [(_, acc)] -> acc

729 _ -> Public

750 _ -> Public

730 ctxt' = case (simpleCase tcase covering CompileTime (FC "" 0) ps,

751 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

741simplifyCasedef :: Name -> Context -> Context

762simplifyCasedef :: Name -> Context -> Context

742simplifyCasedef n uctxt

763simplifyCasedef n uctxt

743 = let ctxt = definitions uctxt

764 = let ctxt = definitions uctxt

744− ctxt' = case lookupCtxt Nothing n ctxt of

765+ ctxt' = case lookupCtxt n ctxt of

745 [(CaseOp inl inr ty [] ps args sc args' sc', acc, tot)] ->

766 [(CaseOp inl inr ty [] ps args sc args' sc', acc, tot)] ->

746 ctxt -- nothing to simplify (or already done...)

767 ctxt -- nothing to simplify (or already done...)

747 [(CaseOp inl inr ty ps_in ps args sc args' sc', acc, tot)] ->

768 [(CaseOp inl inr ty ps_in ps args sc args' sc', acc, tot)] ->

769+ let ps_in' = map simpl ps_in

748− let pdef = map debind $ map simpl ps_in in

770+ pdef = map debind ps_in' in

749 case simpleCase False True CompileTime (FC "" 0) pdef of

771 case simpleCase False True CompileTime (FC "" 0) pdef of

750 OK (CaseDef args sc _) ->

772 OK (CaseDef args sc _) ->

751 addDef n (CaseOp inl inr

773 addDef n (CaseOp inl inr

752− ty ps_in ps args sc args' sc',

774+ ty ps_in' ps args sc args' sc',

753 acc, tot) ctxt

775 acc, tot) ctxt

754 _ -> ctxt in

776 _ -> ctxt in

755 uctxt { definitions = ctxt' }

777 uctxt { definitions = ctxt' }

@@ -774,40 +796,40 @@ addOperator n ty a op uctxt

774

796

775tfst (a, _, _) = a

797tfst (a, _, _) = a

776

798

777−lookupNames :: Maybe [String] -> Name -> Context -> [Name]

799+lookupNames :: Name -> Context -> [Name]

778−lookupNames root n ctxt

800+lookupNames n ctxt

779− = let ns = lookupCtxtName root n (definitions ctxt) in

801+ = let ns = lookupCtxtName n (definitions ctxt) in

780 map fst ns

802 map fst ns

781

803

782−lookupTy :: Maybe [String] -> Name -> Context -> [Type]

804+lookupTy :: Name -> Context -> [Type]

783−lookupTy root n ctxt

805+lookupTy n ctxt

784− = do def <- lookupCtxt root n (definitions ctxt)

806+ = do def <- lookupCtxt n (definitions ctxt)

785 case tfst def of

807 case tfst def of

786 (Function ty _) -> return ty

808 (Function ty _) -> return ty

787 (TyDecl _ ty) -> return ty

809 (TyDecl _ ty) -> return ty

788 (Operator ty _ _) -> return ty

810 (Operator ty _ _) -> return ty

789 (CaseOp _ _ ty _ _ _ _ _ _) -> return ty

811 (CaseOp _ _ ty _ _ _ _ _ _) -> return ty

790

812

791−isConName :: Maybe [String] -> Name -> Context -> Bool

813+isConName :: Name -> Context -> Bool

792−isConName root n ctxt

814+isConName n ctxt

793− = or $ do def <- lookupCtxt root n (definitions ctxt)

815+ = or $ do def <- lookupCtxt n (definitions ctxt)

794 case tfst def of

816 case tfst def of

795 (TyDecl (DCon _ _) _) -> return True

817 (TyDecl (DCon _ _) _) -> return True

796 (TyDecl (TCon _ _) _) -> return True

818 (TyDecl (TCon _ _) _) -> return True

797 _ -> return False

819 _ -> return False

798

820

799−isFnName :: Maybe [String] -> Name -> Context -> Bool

821+isFnName :: Name -> Context -> Bool

800−isFnName root n ctxt

822+isFnName n ctxt

801− = or $ do def <- lookupCtxt root n (definitions ctxt)

823+ = or $ do def <- lookupCtxt n (definitions ctxt)

802 case tfst def of

824 case tfst def of

803 (Function _ _) -> return True

825 (Function _ _) -> return True

804 (Operator _ _ _) -> return True

826 (Operator _ _ _) -> return True

805 (CaseOp _ _ _ _ _ _ _ _ _) -> return True

827 (CaseOp _ _ _ _ _ _ _ _ _) -> return True

806 _ -> return False

828 _ -> return False

807

829

808−lookupP :: Maybe [String] -> Name -> Context -> [Term]

830+lookupP :: Name -> Context -> [Term]

809−lookupP root n ctxt

831+lookupP n ctxt

810− = do def <- lookupCtxt root n (definitions ctxt)

832+ = do def <- lookupCtxt n (definitions ctxt)

811 p <- case def of

833 p <- case def of

812 (Function ty tm, a, _) -> return (P Ref n ty, a)

834 (Function ty tm, a, _) -> return (P Ref n ty, a)

813 (TyDecl nt ty, a, _) -> return (P nt n ty, a)

835 (TyDecl nt ty, a, _) -> return (P nt n ty, a)

@@ -817,22 +839,22 @@ lookupP root n ctxt

817 Hidden -> []

839 Hidden -> []

818 _ -> return (fst p)

840 _ -> return (fst p)

819

841

820−lookupDef :: Maybe [String] -> Name -> Context -> [Def]

842+lookupDef :: Name -> Context -> [Def]

821−lookupDef root n ctxt = map tfst $ lookupCtxt root n (definitions ctxt)

843+lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt)

822

844

823−lookupDefAcc :: Maybe [String] -> Name -> Bool -> Context ->

845+lookupDefAcc :: Name -> Bool -> Context ->

824 [(Def, Accessibility)]

846 [(Def, Accessibility)]

825−lookupDefAcc root n mkpublic ctxt

847+lookupDefAcc n mkpublic ctxt

826− = map mkp $ lookupCtxt root n (definitions ctxt)

848+ = map mkp $ lookupCtxt n (definitions ctxt)

827 where mkp (d, a, _) = if mkpublic then (d, Public) else (d, a)

849 where mkp (d, a, _) = if mkpublic then (d, Public) else (d, a)

828

850

829lookupTotal :: Name -> Context -> [Totality]

851lookupTotal :: Name -> Context -> [Totality]

830−lookupTotal n ctxt = map mkt $ lookupCtxt Nothing n (definitions ctxt)

852+lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt)

831 where mkt (d, a, t) = t

853 where mkt (d, a, t) = t

832

854

833−lookupVal :: Maybe [String] -> Name -> Context -> [Value]

855+lookupVal :: Name -> Context -> [Value]

834−lookupVal root n ctxt

856+lookupVal n ctxt

835− = do def <- lookupCtxt root n (definitions ctxt)

857+ = do def <- lookupCtxt n (definitions ctxt)

836 case tfst def of

858 case tfst def of

837 (Function _ htm) -> return (veval ctxt [] htm)

859 (Function _ htm) -> return (veval ctxt [] htm)

838 (TyDecl nt ty) -> return (VP nt n (veval ctxt [] ty))

860 (TyDecl nt ty) -> return (VP nt n (veval ctxt [] ty))

src/Core/Execute.hs+506−83

@@ -1,108 +1,522 @@

1+{-# LANGUAGE PatternGuards, ExistentialQuantification #-}

1module Core.Execute (execute) where

2module Core.Execute (execute) where

2

3

3import Idris.AbsSyntax

4import Idris.AbsSyntax

4import Idris.AbsSyntaxTree

5import Idris.AbsSyntaxTree

6+import IRTS.Lang( IntTy(..)

7+ , intTyToConst

8+ , FType(..))

5

9

6import Core.TT

10import Core.TT

7import Core.Evaluate

11import Core.Evaluate

12+import Core.CaseTree

8

13

9import Debug.Trace

14import Debug.Trace

10

15

11import Util.DynamicLinker

16import Util.DynamicLinker

17+import Util.System

12

18

13import Control.Applicative hiding (Const)

19import Control.Applicative hiding (Const)

14import Control.Monad.Trans

20import Control.Monad.Trans

21+import Control.Monad.Trans.State.Strict

22+import Control.Monad.Trans.Error

15import Control.Monad

23import Control.Monad

16import Data.Maybe

24import Data.Maybe

25+import Data.Bits

26+import qualified Data.Map as M

17

27

18import Foreign.LibFFI

28import Foreign.LibFFI

19import Foreign.C.String

29import Foreign.C.String

20import Foreign.Marshal.Alloc (free)

30import Foreign.Marshal.Alloc (free)

31+import Foreign.Ptr

21

32

22−-- | Attempt to perform a side effect. Return either Just the next step in

33+import System.IO

23−-- evaluation (after performing the side effect through IO), or Nothing if no

34+

24−-- IO was performed.

35+

25−--

36+data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show

26−-- This function is exceedingly generous about what it will accept in order to

37+

27−-- enable convenient testing at the REPL.

38+data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs

28−step :: TT Name -> Idris (Maybe (TT Name))

39+ , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness

29−step tm = step' (unApply tm)

40+ , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad

30− where step' (P _ (UN "unsafePerformIO") _, [_, arg] ) = step arg -- Only step if arg can be stepped

41+ , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad

31− step' (P _ (UN "mkForeign") _, args) = stepForeign args

42+ }

32− step' (P _ (UN "prim__IO") _, [_, arg]) = step arg

43+

33− step' (P _ (UN "prim__readString") _, [(P _ (UN "prim__stdin") _)]) =

44+data ExecVal = EP NameType Name ExecVal

34− do line <- lift $ getLine

45+ | EV Int

35− return . Just . Constant . Str $ line

46+ | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal)

36− step' _ = return Nothing

47+ | EApp ExecVal ExecVal

37−

48+ | EType UExp

38−-- | Perform side effects until no more can be performed, then return the

49+ | EErased

39−-- resulting term (possibly the argument).

50+ | EConstant Const

40−execute :: TT Name -> Idris (TT Name)

51+ | forall a. EPtr (Ptr a)

41−execute tm = case unApply tm of

52+ | EThunk Int

42− (P _ (UN "unsafePerformIO") _, [_, arg] ) -> execute' arg

53+ | EHandle Handle

43− _ -> return tm

54+

44− where execute' tm = do stepped <- step tm

55+instance Show ExecVal where

45− case stepped of

56+ show (EP _ n _) = show n

46− Nothing -> return tm

57+ show (EV i) = "!!V" ++ show i ++ "!!"

47− Just tm' -> execute' tm'

58+ show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"

48−

59+ show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"

49−

60+ show (EType _) = "Type"

50−

61+ show EErased = "[__]"

62+ show (EConstant c) = show c

52−

63+ show (EPtr p) = "<<ptr " ++ show p ++ ">>"

53−data Foreign = FFun String [FTy] FTy deriving Show

64+ show (EThunk i) = "<<thunk " ++ show i ++ ">>"

54−

65+ show (EHandle h) = "<<handle " ++ show h ++ ">>"

55−call :: Foreign -> [TT Name] -> Idris (Maybe (TT Name))

66+

56−call (FFun name argTypes retType) args = do fn <- findForeign name

67+toTT :: ExecVal -> Exec Term

57− case fn of

68+toTT (EP nt n ty) = (P nt n) <$> (toTT ty)

58− Nothing -> return Nothing

69+toTT (EV i) = return $ V i

59− Just f -> return . Just =<< call' f args retType

70+toTT (EBind n b body) = do body' <- body $ EP Bound n EErased

60− where call' :: ForeignFun -> [TT Name] -> FTy -> Idris (TT Name)

71+ b' <- fixBinder b

61− call' (Fun _ h) args FInt = do res <- lift $ callFFI h retCInt (prepArgs args)

72+ Bind n b' <$> toTT body'

62− return (Constant (I (fromIntegral res)))

73+ where fixBinder (Lam t) = Lam <$> toTT t

63− call' (Fun _ h) args FFloat = do res <- lift $ callFFI h retCDouble (prepArgs args)

74+ fixBinder (Pi t) = Pi <$> toTT t

64− return (Constant (Fl (realToFrac res)))

75+ fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2

65− call' (Fun _ h) args FChar = do res <- lift $ callFFI h retCChar (prepArgs args)

76+ fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2

66− return (Constant (Ch (castCCharToChar res)))

77+ fixBinder (Hole t) = Hole <$> toTT t

67− call' (Fun _ h) args FString = do res <- lift $ callFFI h retCString (prepArgs args)

78+ fixBinder (GHole t) = GHole <$> toTT t

68− hStr <- lift $ peekCString res

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

69-- lift $ free res

467-- lift $ free res

70− return (Constant (Str hStr))

468+ return (EConstant (Str hStr))

71−-- awaiting Const constructor for pointers

469+

72−-- call' (Fun _ h) args FPtr = do res <- lift $ callFFI h retPtr (prepArgs args)

470+ call' (Fun _ h) args FPtr = do res <- execIO $ callFFI h (retPtr retVoid) (prepArgs args)

73−-- return (Constant (Ch (castCCharToChar res)))

471+ return (EPtr res)

74− call' (Fun _ h) args FUnit = do res <- lift $ callFFI h retVoid (prepArgs args)

472+ call' (Fun _ h) args FUnit = do res <- execIO $ callFFI h retVoid (prepArgs args)

75− return (P Ref unitCon (P Ref unitTy (TType (UVal 0)))) -- FIXME check universe level

473+ return (EP Ref unitCon EErased)

474+-- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other)

475+

76

476

77 prepArgs = map prepArg

477 prepArgs = map prepArg

78− prepArg (Constant (I i)) = argCInt (fromIntegral i)

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)

79− prepArg (Constant (Fl f)) = argCDouble (realToFrac f)

483+ prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)

80− prepArg (Constant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars

484+ prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars

81− prepArg (Constant (Str s)) = argString s

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

82

488

83

489

84

490

85−foreignFromTT :: TT Name -> Maybe Foreign

491+foreignFromTT :: ExecVal -> Maybe Foreign

86−foreignFromTT t = case (unApply t) of

492+foreignFromTT t = case (unApplyV t) of

87− (_, [(Constant (Str name)), args, ret]) ->

493+ (_, [(EConstant (Str name)), args, ret]) ->

88− do argTy <- unList args

494+ do argTy <- unEList args

89 argFTy <- sequence $ map getFTy argTy

495 argFTy <- sequence $ map getFTy argTy

90 retFTy <- getFTy ret

496 retFTy <- getFTy ret

91 return $ FFun name argFTy retFTy

497 return $ FFun name argFTy retFTy

92− _ -> Nothing

498+ _ -> trace "failed to construct ffun" Nothing

93−

499+

94−getFTy :: TT Name -> Maybe FTy

500+getFTy :: ExecVal -> Maybe FType

501+getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =

95−getFTy (P _ (UN t) _) = case t of

502+ case intTy of

503+ "ITNative" -> Just $ FInt ITNative

504+ "IT8" -> Just $ FInt IT8

96− "FInt" -> Just FInt

505+ "IT16" -> Just $ FInt IT16

97− "FFloat" -> Just FFloat

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

98− "FChar" -> Just FChar

512+ "FChar" -> Just FChar

99− "FString" -> Just FString

513+ "FString" -> Just FString

100− "FPtr" -> Just FPtr

514+ "FPtr" -> Just FPtr

101− "FUnit" -> Just FUnit

515+ "FUnit" -> Just FUnit

102− _ -> Nothing

516+ _ -> Nothing

103getFTy _ = Nothing

517getFTy _ = Nothing

104

518

105−unList :: TT Name -> Maybe [TT Name]

519+unList :: Term -> Maybe [Term]

106unList tm = case unApply tm of

520unList tm = case unApply tm of

107 (nil, [_]) -> Just []

521 (nil, [_]) -> Just []

108 (cons, ([_, x, xs])) ->

522 (cons, ([_, x, xs])) ->

@@ -110,11 +524,20 @@ unList tm = case unApply tm of

110 return $ x:rest

524 return $ x:rest

111 (f, args) -> Nothing

525 (f, args) -> Nothing

112

526

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+

113−toConst :: TT Name -> Maybe Const

536+toConst :: Term -> Maybe Const

114toConst (Constant c) = Just c

537toConst (Constant c) = Just c

115toConst _ = Nothing

538toConst _ = Nothing

116

539

117−stepForeign :: [TT Name] -> Idris (Maybe (TT Name))

540+stepForeign :: [ExecVal] -> Exec (Maybe ExecVal)

118stepForeign (ty:fn:args) = do let ffun = foreignFromTT fn

541stepForeign (ty:fn:args) = do let ffun = foreignFromTT fn

119 f' <- case (call <$> ffun) of

542 f' <- case (call <$> ffun) of

120 Just f -> f args

543 Just f -> f args

@@ -130,15 +553,15 @@ mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs

130 Just x'' -> return (x'':rest)

553 Just x'' -> return (x'':rest)

131 Nothing -> return rest

554 Nothing -> return rest

132

555

133−findForeign :: String -> Idris (Maybe ForeignFun)

556+findForeign :: String -> Exec (Maybe ForeignFun)

134−findForeign fn = do i <- getIState

557+findForeign fn = do est <- getExecState

135− let libs = idris_dynamic_libs i

558+ let libs = exec_dynamic_libs est

136− fns <- mapMaybeM (lift . tryLoadFn fn) libs

559+ fns <- mapMaybeM getFn libs

137 case fns of

560 case fns of

138 [f] -> return (Just f)

561 [f] -> return (Just f)

139− [] -> do iputStrLn $ "Symbol \"" ++ fn ++ "\" not found"

562+ [] -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" not found"

140 return Nothing

563 return Nothing

141− fs -> do iputStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++

564+ fs -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++

142− show (length fs) ++ " occurrences."

565+ show (length fs) ++ " occurrences."

143 return Nothing

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

41 (state, show nf ++ " : " ++ show ty)

42 err -> (state, show err)

43processCommand (Print n) state =

44− case lookupDef Nothing n (ctxt state) of

44+ case lookupDef n (ctxt state) of

45 [tm] -> (state, show tm)

46 _ -> (state, "No such name")

47processCommand (Tac e) state

src/Core/ProofState.hs+31−12

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

5 evaluation/checking inside the proof system, etc. --}

6

7module Core.ProofState(ProofState(..), newProof, envAtFocus, goalAtFocus,

8− Tactic(..), Goal(..), processTactic, dropGiven) where

8+ Tactic(..), Goal(..), processTactic,

9+ dropGiven, keepGiven) where

9

10

10import Core.Typecheck

11import Core.Typecheck

11import Core.Evaluate

12import Core.Evaluate

@@ -27,6 +28,7 @@ data ProofState = PS { thname :: Name,

27 ptype :: Type, -- original goal

28 ptype :: Type, -- original goal

28 dontunify :: [Name], -- explicitly given by programmer, leave it

29 dontunify :: [Name], -- explicitly given by programmer, leave it

29 unified :: (Name, [(Name, Term)]),

30 unified :: (Name, [(Name, Term)]),

31+ notunified :: [(Name, Term)],

30 solved :: Maybe (Name, Term),

32 solved :: Maybe (Name, Term),

31 problems :: Fails,

33 problems :: Fails,

32 injective :: [Name],

34 injective :: [Name],

@@ -78,8 +80,8 @@ data Tactic = Attack

78-- Some utilites on proof and tactic states

80-- Some utilites on proof and tactic states

79

81

80instance Show ProofState where

82instance Show ProofState where

81− show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals"

83+ show (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _) = show nm ++ ": no more goals"

82− show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ i _ _ ctxt _ _)

84+ show (PS nm (h:hs) _ _ tm _ _ _ _ _ _ _ i _ _ ctxt _ _)

83 = let OK g = goal (Just h) tm

85 = let OK g = goal (Just h) tm

84 wkenv = premises g in

86 wkenv = premises g in

85 "Other goals: " ++ show hs ++ "\n" ++

87 "Other goals: " ++ show hs ++ "\n" ++

@@ -102,12 +104,12 @@ instance Show ProofState where

102 showG ps b = showEnv ps (binderTy b)

104 showG ps b = showEnv ps (binderTy b)

103

105

104instance Pretty ProofState where

106instance Pretty ProofState where

105− pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _) =

107+ pretty (PS nm [] _ _ trm _ _ _ _ _ _ _ _ _ _ _ _ _) =

106 if size nm > breakingSize then

108 if size nm > breakingSize then

107 pretty nm <> colon $$ nest nestingSize (text " no more goals.")

109 pretty nm <> colon $$ nest nestingSize (text " no more goals.")

108 else

110 else

109 pretty nm <> colon <+> text " no more goals."

111 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 _ _) =

111 let OK g = goal (Just h) tm in

113 let OK g = goal (Just h) tm in

112 let wkEnv = premises g in

114 let wkEnv = premises g in

113 text "Other goals" <+> colon <+> pretty hs $$

115 text "Other goals" <+> colon <+> pretty hs $$

@@ -159,7 +161,7 @@ unify' ctxt env topx topy =

159 (u, fails) <- -- trace ("Trying " ++ show (topx, topy)) $

161 (u, fails) <- -- trace ("Trying " ++ show (topx, topy)) $

160 lift $ unify ctxt env topx topy dont (holes ps)

162 lift $ unify ctxt env topx topy dont (holes ps)

161-- trace ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

163-- trace ("Unified " ++ show (topx, topy) ++ " without " ++ show dont ++

162−-- -- " in " ++ show env ++

164+-- " in " ++ show env ++

163-- "\n" ++ show u ++ "\n" ++ qshow fails ++ "\nCurrent problems:\n"

165-- "\n" ++ show u ++ "\n" ++ qshow fails ++ "\nCurrent problems:\n"

164-- ++ qshow (problems ps) ++ "\n" ++ show (holes ps) ++ "\n"

166-- ++ qshow (problems ps) ++ "\n" ++ show (holes ps) ++ "\n"

165-- -- ++ show (pterm ps)

167-- -- ++ show (pterm ps)

@@ -194,7 +196,7 @@ newProof :: Name -> Context -> Type -> ProofState

194newProof n ctxt ty = let h = holeName 0

196newProof n ctxt ty = let h = holeName 0

195 ty' = vToP ty in

197 ty' = vToP ty in

196 PS n [h] [] 1 (Bind h (Hole ty')

198 PS n [h] [] 1 (Bind h (Hole ty')

197− (P Bound h ty')) ty [] (h, [])

199+ (P Bound h ty')) ty [] (h, []) []

198 Nothing [] []

200 Nothing [] []

199 [] []

201 [] []

200 Nothing ctxt "" False

202 Nothing ctxt "" False

@@ -358,9 +360,8 @@ exact _ _ _ _ = fail "Can't fill here."

358-- As exact, but attempts to solve other goals by unification

360-- As exact, but attempts to solve other goals by unification

359

361

360fill :: Raw -> RunTactic

362fill :: Raw -> RunTactic

361−fill guess ctxt env (Bind x (Hole ty) sc) =

363+fill guess ctxt env (Bind x (Hole ty) sc) =

362 do (val, valty) <- lift $ check ctxt env guess

364 do (val, valty) <- lift $ check ctxt env guess

363− s <- get

364-- let valtyn = normalise ctxt env valty

365-- let valtyn = normalise ctxt env valty

365-- let tyn = normalise ctxt env ty

366-- let tyn = normalise ctxt env ty

366 ns <- unify' ctxt env valty ty

367 ns <- unify' ctxt env valty ty

@@ -388,10 +389,19 @@ complete_fill ctxt env (Bind x (Guess ty val) sc) =

388 return $ Bind x (Guess ty val) sc

389 return $ Bind x (Guess ty val) sc

389complete_fill ctxt env t = fail $ "Can't complete fill at " ++ show t

390complete_fill ctxt env t = fail $ "Can't complete fill at " ++ show t

390

391

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+

391solve :: RunTactic

396solve :: RunTactic

392solve ctxt env (Bind x (Guess ty val) sc)

397solve ctxt env (Bind x (Guess ty val) sc)

393 | True = do ps <- get

398 | True = do ps <- get

394 let (uh, uns) = unified ps

399 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 []

395 action (\ps -> ps { holes = holes ps \\ [x],

405 action (\ps -> ps { holes = holes ps \\ [x],

396 solved = Just (x, val),

406 solved = Just (x, val),

397-- problems = solveInProblems

407-- problems = solveInProblems

@@ -423,7 +433,7 @@ introTy ty mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

423 let (uh, uns) = unified ps

433 let (uh, uns) = unified ps

424-- put (ps { unified = (uh, uns ++ ns) })

434-- put (ps { unified = (uh, uns ++ ns) })

425 return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t'))

435 return $ Bind n (Lam tyv) (Bind x (Hole t') (P Bound x t'))

426− _ -> fail "Nothing to introduce"

436+ _ -> lift $ tfail $ CantIntroduce t'

427introTy ty n ctxt env _ = fail "Can't introduce here."

437introTy ty n ctxt env _ = fail "Can't introduce here."

428

438

429intro :: Maybe Name -> RunTactic

439intro :: Maybe Name -> RunTactic

@@ -438,7 +448,7 @@ intro mn ctxt env (Bind x (Hole t) (P _ x' _)) | x == x' =

438 Bind y (Pi s) t -> -- trace ("in type " ++ show t') $

448 Bind y (Pi s) t -> -- trace ("in type " ++ show t') $

439 let t' = instantiate (P Bound n s) (pToV y t) in

449 let t' = instantiate (P Bound n s) (pToV y t) in

440 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

450 return $ Bind n (Lam s) (Bind x (Hole t') (P Bound x t'))

441− _ -> fail "Nothing to introduce"

451+ _ -> lift $ tfail $ CantIntroduce t'

442intro n ctxt env _ = fail "Can't introduce here."

452intro n ctxt env _ = fail "Can't introduce here."

443

453

444forall :: Name -> Raw -> RunTactic

454forall :: Name -> Raw -> RunTactic

@@ -566,6 +576,15 @@ dropGiven du (u@(n, _) : us) hs

566-- dropGiven du (u@(_, P a n ty) : us) | n `elem` du = dropGiven du us

576-- dropGiven du (u@(_, P a n ty) : us) | n `elem` du = dropGiven du us

567dropGiven du (u : us) hs = u : dropGiven du us hs

577dropGiven du (u : us) hs = u : dropGiven du us hs

568

578

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+

569updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

588updateSolved xs x = -- trace ("Updating " ++ show xs ++ " in " ++ show x) $

570 updateSolved' xs x

589 updateSolved' xs x

571updateSolved' xs (Bind n (Hole ty) t)

590updateSolved' xs (Bind n (Hole ty) t)

@@ -619,7 +638,7 @@ processTactic EndUnify ps

619 ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

638 ns' = map (\ (n, t) -> (n, updateSolved ns t)) ns

620 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

639 (ns'', probs') = updateProblems (context ps) ns' (problems ps)

621 (injective ps) (holes ps)

640 (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)) $

623 updateSolved ns'' (pterm ps) in

642 updateSolved ns'' (pterm ps) in

624 return (ps { pterm = tm',

643 return (ps { pterm = tm',

625 unified = (h, []),

644 unified = (h, []),

src/Core/TT.hs+28−7

@@ -57,6 +57,8 @@ data Err = Msg String

57 -- unification succeed

58 | InfiniteUnify Name Term [(Name, Type)]

59 | CantConvert Term Term [(Name, Type)]

60+ | NonFunctionType Term Term

61+ | CantIntroduce Term

60 | NoSuchVariable Name

62 | NoSuchVariable Name

61 | NoTypeDecl Name

63 | NoTypeDecl Name

62 | NotInjective Term Term Term

64 | NotInjective Term Term Term

@@ -71,6 +73,7 @@ data Err = Msg String

71 | ProofSearchFail Err

73 | ProofSearchFail Err

72 | NoRewriting Term

74 | NoRewriting Term

73 | At FC Err

75 | At FC Err

76+ | ProviderError String

74 deriving Eq

77 deriving Eq

75

78

76instance Sized Err where

79instance Sized Err where

@@ -89,6 +92,7 @@ instance Sized Err where

89 size UniverseError = 1

92 size UniverseError = 1

90 size ProgramLineComment = 1

93 size ProgramLineComment = 1

91 size (At fc err) = size fc + size err

94 size (At fc err) = size fc + size err

95+ size (ProviderError msg) = length msg

92 size _ = 1

96 size _ = 1

93

97

94score :: Err -> Int

98score :: Err -> Int

@@ -104,6 +108,7 @@ instance Show Err where

104 show (CantUnify _ l r e sc i) = "CantUnify " ++ show l ++ " " ++ show r ++ " "

108 show (CantUnify _ l r e sc i) = "CantUnify " ++ show l ++ " " ++ show r ++ " "

105 ++ show e ++ " in " ++ show sc ++ " " ++ show i

109 ++ show e ++ " in " ++ show sc ++ " " ++ show i

106 show (Inaccessible n) = show n ++ " is not an accessible pattern variable"

110 show (Inaccessible n) = show n ++ " is not an accessible pattern variable"

111+ show (ProviderError msg) = "Type provider error: " ++ msg

107 show _ = "Error"

112 show _ = "Error"

108

113

109instance Pretty Err where

114instance Pretty Err where

@@ -116,6 +121,7 @@ instance Pretty Err where

116 else

121 else

117 text "Cannot unify" <+> colon <+> pretty l <+> text "and" <+> pretty r $$

122 text "Cannot unify" <+> colon <+> pretty l <+> text "and" <+> pretty r $$

118 nest nestingSize (text "where" <+> pretty e <+> text "with" <+> (text . show $ i))

123 nest nestingSize (text "where" <+> pretty e <+> text "with" <+> (text . show $ i))

124+ pretty (ProviderError msg) = text msg

119 pretty _ = text "Error"

125 pretty _ = text "Error"

120

126

121data TC a = OK a

127data TC a = OK a

@@ -238,8 +244,8 @@ addDef n v ctxt = case Map.lookup (nsroot n) ctxt of

238

244

239-}

245-}

240

246

241−lookupCtxtName :: Maybe [String] -> Name -> Ctxt a -> [(Name, a)]

247+lookupCtxtName :: Name -> Ctxt a -> [(Name, a)]

242−lookupCtxtName nspace n ctxt = case Map.lookup (nsroot n) ctxt of

248+lookupCtxtName n ctxt = case Map.lookup (nsroot n) ctxt of

243 Just xs -> filterNS (Map.toList xs)

249 Just xs -> filterNS (Map.toList xs)

244 Nothing -> []

250 Nothing -> []

245 where

251 where

@@ -252,12 +258,12 @@ lookupCtxtName nspace n ctxt = case Map.lookup (nsroot n) ctxt of

252 nsmatch (NS _ _) _ = False

258 nsmatch (NS _ _) _ = False

253 nsmatch looking found = True

259 nsmatch looking found = True

254

260

255−lookupCtxt :: Maybe [String] -> Name -> Ctxt a -> [a]

261+lookupCtxt :: Name -> Ctxt a -> [a]

256−lookupCtxt ns n ctxt = map snd (lookupCtxtName ns n ctxt)

262+lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt)

257

263

258updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a

264updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a

259updateDef n f ctxt

265updateDef n f ctxt

260− = let ds = lookupCtxtName Nothing n ctxt in

266+ = let ds = lookupCtxtName n ctxt in

261 foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds

267 foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds

262

268

263toAlist :: Ctxt a -> [(Name, a)]

269toAlist :: Ctxt a -> [(Name, a)]

@@ -424,7 +430,10 @@ instance Show UConstraint where

424

430

425type UCs = (Int, [UConstraint])

431type UCs = (Int, [UConstraint])

426

432

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

428 deriving (Show, Ord)

437 deriving (Show, Ord)

429{-!

438{-!

430deriving instance Binary NameType

439deriving instance Binary NameType

@@ -560,6 +569,17 @@ pToV' n i (App f a) = App (pToV' n i f) (pToV' n i a)

560pToV' n i (Proj t idx) = Proj (pToV' n i t) idx

569pToV' n i (Proj t idx) = Proj (pToV' n i t) idx

561pToV' n i t = t

570pToV' n i t = t

562

571

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+

563-- | Convert several names. First in the list comes out as V 0

583-- | Convert several names. First in the list comes out as V 0

564pToVs :: Eq n => [n] -> TT n -> TT n

584pToVs :: Eq n => [n] -> TT n -> TT n

565pToVs ns tm = pToVs' ns tm 0 where

585pToVs ns tm = pToVs' ns tm 0 where

@@ -778,7 +798,8 @@ prettyEnv env t = prettyEnv' env t False

778showEnv' env t dbg = se 10 env t where

798showEnv' env t dbg = se 10 env t where

779 se p env (P nt n t) = show n

799 se p env (P nt n t) = show n

780 ++ if dbg then "{" ++ show nt ++ " : " ++ se 10 env t ++ "}" else ""

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

782 if dbg then "{" ++ show i ++ "}" else ""

803 if dbg then "{" ++ show i ++ "}" else ""

783 | otherwise = "!!V " ++ show i ++ "!!"

804 | otherwise = "!!V " ++ show i ++ "!!"

784 se p env (Bind n b@(Pi t) sc)

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

60check' holes ctxt env top = chk env top where

61 chk env (Var n)

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

64 | otherwise = do lift $ tfail $ NoSuchVariable n

65 chk env (RApp f a)

66 = do (fv, fty) <- chk env f

@@ -81,7 +81,7 @@ check' holes ctxt env top = chk env top where

81 let apty = simplify initContext False env

82 (Bind x (Let aty av) t)

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

85 -- This rather unpleasant hack is needed because during incomplete

86 -- proofs, variables are locally bound with an explicit name. If we just

87 -- make sure bound names in function types are locally unique, machine

@@ -227,7 +227,7 @@ checkProgram ctxt [] = return ctxt

227checkProgram ctxt ((n, RConst t) : xs)

228 = do (t', tt') <- trace (show n) $ check ctxt [] t

229 isType ctxt [] tt'

230− checkProgram (addTyDecl n t' ctxt) xs

230+ checkProgram (addTyDecl n Ref t' ctxt) xs

231checkProgram ctxt ((n, RFunction (RawFun ty val)) : xs)

232 = do (ty', tyt') <- trace (show n) $ check ctxt [] ty

233 (val', valt') <- check ctxt [] val

src/Core/Unify.hs+27−15

@@ -54,9 +54,9 @@ unify ctxt env topx topy dont holes =

54

55 injective (P (DCon _ _) _ _) = True

56 injective (P (TCon _ _) _ _) = True

57− injective (App f (P _ _ _)) = injective f

57+-- injective (App f (P _ _ _)) = injective f

58− injective (App f (Constant _)) = injective f

58+-- injective (App f (Constant _)) = injective f

59− injective (App f a) = injective f && injective a

59+ injective (App f a) = injective f -- && injective a

60 injective _ = False

61

62 notP (P _ _ _) = False

@@ -133,10 +133,11 @@ unify ctxt env topx topy dont holes =

133 | fst (bnames!!i) == x || snd (bnames!!i) == x = do sc 1; return []

134

135 un' fn bnames appx@(App fx ax) appy@(App fy ay)

136− | injective fx && sameArgStruct appx appy && metavarApp appy

136+ | (injective fx && injective fy)

137+ || (injective fx && rigid appx && metavarApp appy)

137− || injective fy && sameArgStruct appx appy && metavarApp appx

138+ || (injective fy && rigid appy && metavarApp appx)

138− || injective fx && injective fy

139+ || (injective fx && metavarApp fy && ax == ay)

139− || fx == fy

140+ || (injective fy && metavarApp fx && ax == ay)

140 = do let (headx, _) = unApply fx

141 = do let (headx, _) = unApply fx

141 let (heady, _) = unApply fy

142 let (heady, _) = unApply fy

142 -- fail quickly if the heads are disjoint

143 -- fail quickly if the heads are disjoint

@@ -158,17 +159,19 @@ unify ctxt env topx topy dont holes =

158 hf <- un' False bnames fx' fy'

159 hf <- un' False bnames fx' fy'

159 sc 1

160 sc 1

160 combine bnames hf ha)

161 combine bnames hf ha)

161− | otherwise

162+ | otherwise = -- trace (show (appx, appy, injective fx, metavarApp appy, sameArgStruct appx appy)) $

162− = do let (headx, argsx) = unApply appx

163+ do let (headx, argsx) = unApply appx

163 let (heady, argsy) = unApply appy

164 let (heady, argsy) = unApply appy

165+ -- traceWhen (headx == heady) (show (appx, appy)) $

164 if (length argsx == length argsy &&

166 if (length argsx == length argsy &&

165− ((headx == heady) || (argsx == argsy) ||

167+ ((headx == heady && inenv headx) || (argsx == argsy) ||

166 (and (zipWith sameStruct (headx:argsx) (heady:argsy)))))

168 (and (zipWith sameStruct (headx:argsx) (heady:argsy)))))

167 then

169 then

168-- (notFn headx && notFn heady))) then

170-- (notFn headx && notFn heady))) then

169 do uf <- un' True bnames headx heady

171 do uf <- un' True bnames headx heady

170 unArgs uf argsx argsy

172 unArgs uf argsx argsy

173+ else -- trace ("TMPFAIL " ++ show (appx, appy, injective appx, injective appy)) $

171− else unifyTmpFail appx appy

174+ unifyTmpFail appx appy

172 where hnormalise [] _ _ t = t

175 where hnormalise [] _ _ t = t

173 hnormalise ns ctxt env t = normalise ctxt env t

176 hnormalise ns ctxt env t = normalise ctxt env t

174 checkHeads (P (DCon _ _) x _) (P (DCon _ _) y _)

177 checkHeads (P (DCon _ _) x _) (P (DCon _ _) y _)

@@ -190,15 +193,17 @@ unify ctxt env topx topy dont holes =

190 unArgs vs xs ys

193 unArgs vs xs ys

191

194

192 metavarApp tm = let (f, args) = unApply tm in

195 metavarApp tm = let (f, args) = unApply tm in

193− all (\x -> metavar x || inenv x) (f : args)

196+ all (\x -> metavar x) (f : args)

194 metavarArgs tm = let (f, args) = unApply tm in

197 metavarArgs tm = let (f, args) = unApply tm in

195 all (\x -> metavar x || inenv x) args

198 all (\x -> metavar x || inenv x) args

196 metavarApp' tm = let (f, args) = unApply tm in

199 metavarApp' tm = let (f, args) = unApply tm in

197 all (\x -> pat x || metavar x) (f : args)

200 all (\x -> pat x || metavar x) (f : args)

198

201

199− sameArgStruct appx appy = let (_, ax) = unApply appx

202+ sameArgStruct appx appy

203+ = let (_, ax) = unApply appx

200− (_, ay) = unApply appy in

204+ (_, ay) = unApply appy in

205+ length ax == length ay &&

201− and (zipWith sameStruct ax ay)

206+ and (zipWith sameStruct ax ay)

202

207

203 sameStruct fapp@(App f x) gapp@(App g y)

208 sameStruct fapp@(App f x) gapp@(App g y)

204 = let (f',a') = unApply fapp

209 = let (f',a') = unApply fapp

@@ -216,6 +221,13 @@ unify ctxt env topx topy dont holes =

216 sameStruct (Bind n t sc) (Bind n' t' sc') = sameStruct sc sc'

221 sameStruct (Bind n t sc) (Bind n' t' sc') = sameStruct sc sc'

217 sameStruct _ _ = False

222 sameStruct _ _ = False

218

223

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+

219 metavar t = case t of

231 metavar t = case t of

220 P _ x _ -> (x `elem` holes || holeIn env x) &&

232 P _ x _ -> (x `elem` holes || holeIn env x) &&

221 not (x `elem` dont)

233 not (x `elem` dont)

src/IRTS/CodegenC.hs+113−189

@@ -10,6 +10,7 @@ import Paths_idris

10import Util.System

11

12import Data.Char

13+import Data.List (intercalate)

13import System.Process

14import System.Process

14import System.Exit

15import System.Exit

15import System.IO

16import System.IO

@@ -47,7 +48,7 @@ codegenC defs out exec incs objs libs dbg

47 incFlags <- getIncFlags

48 incFlags <- getIncFlags

48 let gcc = comp ++ " " ++

49 let gcc = comp ++ " " ++

49 gccDbg dbg ++

50 gccDbg dbg ++

50− " -I. " ++ objs ++ " -x c " ++

51+ " -I. " ++ objs ++ " -x c " ++

51 (if (exec == Executable) then "" else " -c ") ++

52 (if (exec == Executable) then "" else " -c ") ++

52 " " ++ tmpn ++

53 " " ++ tmpn ++

53 " " ++ libFlags ++

54 " " ++ libFlags ++

@@ -105,6 +106,10 @@ bcc i (ASSIGNCONST l c)

105 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

106 mkConst (Fl f) = "MKFLOAT(vm, " ++ show f ++ ")"

106 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

107 mkConst (Ch c) = "MKINT(" ++ show (fromEnum c) ++ ")"

107 mkConst (Str s) = "MKSTR(vm, " ++ show s ++ ")"

108 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 ++ ")"

108 mkConst _ = "MKINT(42424242)"

113 mkConst _ = "MKINT(42424242)"

109bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

114bcc i (UPDATE l r) = indent i ++ creg l ++ " = " ++ creg r ++ ";\n"

110bcc i (MKCON l tag args)

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

222bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"

227bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0); exit(-1);"

223-- bcc i _ = indent i ++ "// not done yet\n"

228-- bcc i _ = indent i ++ "// not done yet\n"

224

229

230+

231+

225−c_irts FInt l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

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

226c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

234c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"

227c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"

235c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"

228c_irts FUnit l x = x

236c_irts FUnit l x = x

@@ -230,7 +238,8 @@ c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"

230c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

238c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"

231c_irts FAny l x = l ++ x

239c_irts FAny l x = l ++ x

232

240

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

234irts_c FChar x = "GETINT(" ++ x ++ ")"

243irts_c FChar x = "GETINT(" ++ x ++ ")"

235irts_c FString x = "GETSTR(" ++ x ++ ")"

244irts_c FString x = "GETSTR(" ++ x ++ ")"

236irts_c FUnit x = x

245irts_c FUnit x = x

@@ -238,22 +247,33 @@ irts_c FPtr x = "GETPTR(" ++ x ++ ")"

238irts_c FDouble x = "GETFLOAT(" ++ x ++ ")"

247irts_c FDouble x = "GETFLOAT(" ++ x ++ ")"

239irts_c FAny x = x

248irts_c FAny x = x

240

249

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+

241−doOp v LPlus [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"

258+doOp v (LPlus ITNative) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"

242−doOp v LMinus [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

259+doOp v (LMinus ITNative) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

243−doOp v LTimes [l, r] = v ++ "MULT(" ++ 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 ++ ")"

244−doOp v LDiv [l, r] = v ++ "INTOP(/," ++ 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 ++ ")"

245−doOp v LMod [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

264+doOp v (LSRem ITNative) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"

246−doOp v LAnd [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"

265+doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"

247−doOp v LOr [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"

266+doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"

248−doOp v LXOr [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"

267+doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"

249−doOp v LSHL [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 ++ ")"

250−doOp v LSHR [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

270+doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"

251−doOp v LCompl [x] = v ++ "INTOP(~," ++ creg x ++ ")"

271+doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"

252−doOp v LEq [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

272+doOp v (LEq ITNative) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"

253−doOp v LLt [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

273+doOp v (LLt ITNative) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"

254−doOp v LLe [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

274+doOp v (LLe ITNative) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"

255−doOp v LGt [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

275+doOp v (LGt ITNative) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

256−doOp v LGe [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

276+doOp v (LGe ITNative) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

257

277

258doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"

278doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"

259doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"

279doOp 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 ++ ")"

265doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

285doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"

266doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

286doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"

267

287

288+doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"

289+doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"

268−doOp v LBPlus [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

290+doOp v (LPlus ITBig) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

269−doOp v LBMinus [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

291+doOp v (LMinus ITBig) [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 ++ ")"

292+doOp v (LTimes ITBig) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

272−doOp v LBDiv [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

293+doOp v (LSDiv ITBig) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

273−doOp v LBMod [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

294+doOp v (LSRem ITBig) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

274−doOp v LBEq [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

295+doOp v (LEq ITBig) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

275−doOp v LBLt [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

296+doOp v (LLt ITBig) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

276−doOp v LBLe [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

297+doOp v (LLe ITBig) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

277−doOp v LBGt [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

298+doOp v (LGt ITBig) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

278−doOp v LBGe [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

299+doOp v (LGe ITBig) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

279

300

280doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

301doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

281doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

302doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

282doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

303doOp v LStrEq [l,r] = v ++ "idris_streq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"

283doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"

304doOp v LStrLen [x] = v ++ "idris_strlen(vm, " ++ creg x ++ ")"

284

305

285−doOp v LIntFloat [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"

306+doOp v (LIntFloat ITNative) [x] = v ++ "idris_castIntFloat(" ++ creg x ++ ")"

286−doOp v LFloatInt [x] = v ++ "idris_castFloatInt(" ++ creg x ++ ")"

307+doOp v (LFloatInt ITNative) [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 ++ ")"

308+doOp v (LSExt ITNative ITBig) [x] = v ++ "idris_castIntBig(vm, " ++ creg x ++ ")"

290−doOp v LBigInt [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"

309+doOp v (LTrunc ITBig ITNative) [x] = v ++ "idris_castBigInt(vm, " ++ creg x ++ ")"

291−doOp v LStrBig [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"

310+doOp v (LStrInt ITBig) [x] = v ++ "idris_castStrBig(vm, " ++ creg x ++ ")"

292−doOp v LBigStr [x] = v ++ "idris_castBigStr(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 ++ ")"

293doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"

314doOp v LFloatStr [x] = v ++ "idris_castFloatStr(vm, " ++ creg x ++ ")"

294doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"

315doOp v LStrFloat [x] = v ++ "idris_castStrFloat(vm, " ++ creg x ++ ")"

295

316

@@ -297,155 +318,55 @@ doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"

297doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"

318doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"

298doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"

319doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"

299

320

300−doOp v LIntB8 [x] = v ++ "idris_b8(vm, " ++ creg x ++ ")"

321+doOp v (LLt ty) [x, y] = bitOp v "Lt" ty [x, y]

301−doOp v LIntB16 [x] = v ++ "idris_b16(vm, " ++ creg x ++ ")"

322+doOp v (LLe ty) [x, y] = bitOp v "Lte" ty [x, y]

302−doOp v LIntB32 [x] = v ++ "idris_b32(vm, " ++ creg x ++ ")"

323+doOp v (LEq ty) [x, y] = bitOp v "Eq" ty [x, y]

303−doOp v LIntB64 [x] = v ++ "idris_b64(vm, " ++ creg x ++ ")"

324+doOp v (LGe ty) [x, y] = bitOp v "Gte" ty [x, y]

304−

325+doOp v (LGt ty) [x, y] = bitOp v "Gt" ty [x, y]

305−doOp v LB32Int [x] = v ++ "idris_castB32Int(vm, " ++ creg x ++ ")"

326+

306−

327+doOp v (LSHL ty) [x, y] = bitOp v "Shl" ty [x, y]

307−doOp v LB8Lt [x, y] = v ++ "idris_b8Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

328+doOp v (LLSHR ty) [x, y] = bitOp v "LShr" ty [x, y]

308−doOp v LB8Lte [x, y] = v ++ "idris_b8Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

329+doOp v (LASHR ty) [x, y] = bitOp v "AShr" ty [x, y]

309−doOp v LB8Eq [x, y] = v ++ "idris_b8Eq(vm, " ++ creg x ++ "," ++ creg y ++ ")"

330+doOp v (LAnd ty) [x, y] = bitOp v "And" ty [x, y]

310−doOp v LB8Gte [x, y] = v ++ "idris_b8Gte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

331+doOp v (LOr ty) [x, y] = bitOp v "Or" ty [x, y]

311−doOp v LB8Gt [x, y] = v ++ "idris_b8Gt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

332+doOp v (LXOr ty) [x, y] = bitOp v "Xor" ty [x, y]

312−

333+doOp v (LCompl ty) [x] = bitOp v "Compl" ty [x]

313−doOp v LB8Shl [x, y] = v ++ "idris_b8Shl(vm, " ++ creg x ++ "," ++ creg y ++ ")"

334+

314−doOp v LB8LShr [x, y] = v ++ "idris_b8Shr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

335+doOp v (LPlus ty) [x, y] = bitOp v "Plus" ty [x, y]

315−doOp v LB8AShr [x, y] = v ++ "idris_b8AShr(vm, " ++ creg x ++ "," ++ creg y ++ ")"

336+doOp v (LMinus ty) [x, y] = bitOp v "Minus" ty [x, y]

316−doOp v LB8And [x, y] = v ++ "idris_b8And(vm, " ++ creg x ++ "," ++ creg y ++ ")"

337+doOp v (LTimes ty) [x, y] = bitOp v "Times" ty [x, y]

317−doOp v LB8Or [x, y] = v ++ "idris_b8Or(vm, " ++ creg x ++ "," ++ creg y ++ ")"

338+doOp v (LUDiv ty) [x, y] = bitOp v "UDiv" ty [x, y]

318−doOp v LB8Xor [x, y] = v ++ "idris_b8Xor(vm, " ++ creg x ++ "," ++ creg y ++ ")"

339+doOp v (LSDiv ty) [x, y] = bitOp v "SDiv" ty [x, y]

319−doOp v LB8Compl [x] = v ++ "idris_b8Compl(vm, " ++ creg x ++ ")"

340+doOp v (LURem ty) [x, y] = bitOp v "URem" ty [x, y]

320−

341+doOp v (LSRem ty) [x, y] = bitOp v "SRem" ty [x, y]

321−doOp v LB8Plus [x, y] = v ++ "idris_b8Plus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

342+

322−doOp v LB8Minus [x, y] = v ++ "idris_b8Minus(vm, " ++ creg x ++ "," ++ creg y ++ ")"

343+doOp v (LSExt from ITBig) [x] = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

323−doOp v LB8Times [x, y] = v ++ "idris_b8Times(vm, " ++ creg x ++ "," ++ creg y ++ ")"

344+doOp v (LSExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"

324−doOp v LB8UDiv [x, y] = v ++ "idris_b8UDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

345+doOp v (LSExt from ITNative) [x] = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ "))"

325−doOp v LB8SDiv [x, y] = v ++ "idris_b8SDiv(vm, " ++ creg x ++ "," ++ creg y ++ ")"

346+doOp v (LSExt from to) [x]

326−doOp v LB8URem [x, y] = v ++ "idris_b8URem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

347+ | intTyWidth from < intTyWidth to = bitCoerce v "S" from to x

327−doOp v LB8SRem [x, y] = v ++ "idris_b8SRem(vm, " ++ creg x ++ "," ++ creg y ++ ")"

348+doOp v (LZExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"

328−

349+doOp v (LZExt from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

329−doOp v LB8Z16 [x] = v ++ "idris_b8Z16(vm, " ++ creg x ++ ")"

350+doOp v (LZExt from ITBig) [x] = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

330−doOp v LB8Z32 [x] = v ++ "idris_b8Z32(vm, " ++ creg x ++ ")"

351+doOp v (LZExt from to) [x]

331−doOp v LB8Z64 [x] = v ++ "idris_b8Z64(vm, " ++ creg x ++ ")"

352+ | intTyWidth from < intTyWidth to = bitCoerce v "Z" from to x

332−doOp v LB8S16 [x] = v ++ "idris_b8S16(vm, " ++ creg x ++ ")"

353+doOp v (LTrunc ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"

333−doOp v LB8S32 [x] = v ++ "idris_b8S32(vm, " ++ creg x ++ ")"

354+doOp v (LTrunc from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"

334−doOp v LB8S64 [x] = v ++ "idris_b8S64(vm, " ++ creg x ++ ")"

355+doOp v (LTrunc ITBig to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, mpz_get_ui(GETMPZ(" ++ creg x ++ "))"

335−

356+doOp v (LTrunc from to) [x]

336−doOp v LB16Lt [x, y] = v ++ "idris_b16Lt(vm, " ++ creg x ++ "," ++ creg y ++ ")"

357+ | intTyWidth from > intTyWidth to = bitCoerce v "T" from to x

337−doOp v LB16Lte [x, y] = v ++ "idris_b16Lte(vm, " ++ creg x ++ "," ++ creg y ++ ")"

358+

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

359+doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)

439−doOp v LFLog [x] = v ++ "MKFLOAT(log(GETFLOAT(" ++ creg x ++ ")))"

360+doOp v LFLog [x] = v ++ flUnOp "log" (creg x)

440−doOp v LFSin [x] = v ++ "MKFLOAT(sin(GETFLOAT(" ++ creg x ++ ")))"

361+doOp v LFSin [x] = v ++ flUnOp "sin" (creg x)

441−doOp v LFCos [x] = v ++ "MKFLOAT(cos(GETFLOAT(" ++ creg x ++ ")))"

362+doOp v LFCos [x] = v ++ flUnOp "cos" (creg x)

442−doOp v LFTan [x] = v ++ "MKFLOAT(tan(GETFLOAT(" ++ creg x ++ ")))"

363+doOp v LFTan [x] = v ++ flUnOp "tan" (creg x)

443−doOp v LFASin [x] = v ++ "MKFLOAT(asin(GETFLOAT(" ++ creg x ++ ")))"

364+doOp v LFASin [x] = v ++ flUnOp "asin" (creg x)

444−doOp v LFACos [x] = v ++ "MKFLOAT(acos(GETFLOAT(" ++ creg x ++ ")))"

365+doOp v LFACos [x] = v ++ flUnOp "acos" (creg x)

445−doOp v LFATan [x] = v ++ "MKFLOAT(atan(GETFLOAT(" ++ creg x ++ ")))"

366+doOp v LFATan [x] = v ++ flUnOp "atan" (creg x)

446−doOp v LFSqrt [x] = v ++ "MKFLOAT(floor(GETFLOAT(" ++ creg x ++ ")))"

367+doOp v LFSqrt [x] = v ++ flUnOp "sqrt" (creg x)

447−doOp v LFFloor [x] = v ++ "MKFLOAT(ceil(GETFLOAT(" ++ creg x ++ ")))"

368+doOp v LFFloor [x] = v ++ flUnOp "floor" (creg x)

448−doOp v LFCeil [x] = v ++ "MKFLOAT(sqrt(GETFLOAT(" ++ creg x ++ ")))"

369+doOp v LFCeil [x] = v ++ flUnOp "ceil" (creg x)

449

370

450doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"

371doOp v LStrHead [x] = v ++ "idris_strHead(vm, " ++ creg x ++ ")"

451doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"

372doOp v LStrTail [x] = v ++ "idris_strTail(vm, " ++ creg x ++ ")"

@@ -460,7 +381,10 @@ doOp v LStdErr [] = v ++ "MKPTR(vm, stderr)"

460doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

381doOp v LFork [x] = v ++ "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

461doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

382doOp v LPar [x] = v ++ creg x -- "MKPTR(vm, vmThread(vm, " ++ cname (MN 0 "EVAL") ++ ", " ++ creg x ++ "))"

462doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

383doOp v LVMPtr [] = v ++ "MKPTR(vm, vm)"

463−doOp v LChInt args = v ++ creg (last args)

384+doOp v (LChInt ITNative) args = v ++ creg (last args)

464−doOp v LIntCh args = v ++ creg (last args)

385+doOp v (LIntCh ITNative) args = v ++ creg (last args)

465doOp v LNoOp args = v ++ creg (last args)

386doOp v LNoOp args = v ++ creg (last args)

466doOp _ op _ = "FAIL /* " ++ show op ++ " */"

387doOp _ 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

15import Control.Monad.Trans.State

16import Data.Char

17import Data.Maybe (fromJust)

18−import Data.List (isPrefixOf, isSuffixOf, intercalate)

18+import Data.List (isPrefixOf, isSuffixOf, intercalate, foldl')

19+import Data.Int

19import qualified Data.Text as T

20import qualified Data.Text as T

20import qualified Data.Text.IO as TIO

21import qualified Data.Text.IO as TIO

21import Language.Java.Parser

22import Language.Java.Parser

@@ -255,7 +256,7 @@ mkMainMethod =

255 )

256 )

256

257

257mergeInnerClasses :: [Decl] -> [Decl]

258mergeInnerClasses :: [Decl] -> [Decl]

258−mergeInnerClasses = foldl mergeInner []

259+mergeInnerClasses = foldl' mergeInner []

259 where

260 where

260 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)

261 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)

261 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))

262 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))

@@ -418,6 +419,12 @@ mkIdentifier (UN name) =

418 cleanReserved "idris_K" = "_idris_K"

419 cleanReserved "idris_K" = "_idris_K"

419 cleanReserved "idris_flipK" = "_idris_flipK"

420 cleanReserved "idris_flipK" = "_idris_flipK"

420 cleanReserved "idris_assignStack" = "_idris_assignStack"

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

421

428

422 cleanReserved x = x

429 cleanReserved x = x

423

430

@@ -462,7 +469,39 @@ integerType :: ClassType

462integerType = ClassType [(Ident "Integer", [])]

469integerType = ClassType [(Ident "Integer", [])]

463

470

464longType :: ClassType

471longType :: 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

466

505

467bigIntegerType :: ClassType

506bigIntegerType :: ClassType

468bigIntegerType = ClassType [(Ident "BigInteger", [])]

507bigIntegerType = ClassType [(Ident "BigInteger", [])]

@@ -956,7 +995,7 @@ mkStringAtIndex var indexExp =

956 <$> mkVarAccess (Just stringType) var

995 <$> mkVarAccess (Just stringType) var

957

996

958mkForeignType :: FType -> Maybe ClassType

997mkForeignType :: FType -> Maybe ClassType

959−mkForeignType FInt = return integerType

998+mkForeignType (FInt ty) = return (intTyToClass ty)

960mkForeignType FChar = return integerType

999mkForeignType FChar = return integerType

961mkForeignType FString = return stringType

1000mkForeignType FString = return stringType

962mkForeignType FPtr = return objectType

1001mkForeignType FPtr = return objectType

@@ -965,14 +1004,14 @@ mkForeignType FAny = return objectType

965mkForeignType FUnit = Nothing

1004mkForeignType FUnit = Nothing

966

1005

967mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp

1006mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp

968−mkForeignVarAccess FInt var =

1007+mkForeignVarAccess (FInt ty) var =

969− (\ var -> MethodInv $ PrimaryMethodCall (var)

1008+ (\ var -> MethodInv $ PrimaryMethodCall var

970 []

1009 []

971− (Ident "intValue")

1010+ (Ident (intTyToMethod ty))

972 []

1011 []

973 )

1012 )

974− <$> mkVarAccess (Just integerType) var

1013+ <$> mkVarAccess (Just $ intTyToClass ty) var

975−mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess FInt var

1014+mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var

976mkForeignVarAccess FDouble var =

1015mkForeignVarAccess FDouble var =

977 (\ var -> MethodInv $ PrimaryMethodCall (var)

1016 (\ var -> MethodInv $ PrimaryMethodCall (var)

978 []

1017 []

@@ -983,12 +1022,12 @@ mkForeignVarAccess FDouble var =

983mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var

1022mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var

984

1023

985mkFromForeignType :: FType -> Exp -> Exp

1024mkFromForeignType :: FType -> Exp -> Exp

986−mkFromForeignType FInt from =

1025+mkFromForeignType (FInt ty) from =

987− MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])

1026+ MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])

988 []

1027 []

989 (Ident "valueOf")

1028 (Ident "valueOf")

990 [from]

1029 [from]

991−mkFromForeignType FChar from = mkFromForeignType FInt from

1030+mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from

992mkFromForeignType FDouble from =

1031mkFromForeignType FDouble from =

993 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])

1032 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])

994 []

1033 []

@@ -1219,7 +1258,9 @@ mkExp (SCon conId name args) =

1219mkExp (SCase var alts) = mkCase False var alts

1258mkExp (SCase var alts) = mkCase False var alts

1220mkExp (SChkCase var alts) = mkCase True var alts

1259mkExp (SChkCase var alts) = mkCase True var alts

1221mkExp (SProj var i) = mkProjection var i

1260mkExp (SProj var i) = mkProjection var i

1261+mkExp (SConst (I x)) =

1262+ let x' :: Int32; x' = fromInteger (toInteger x) in

1222−mkExp (SConst (I x)) = return $ mkPrimitive "Integer" (Int (toInteger x))

1263+ return $ mkPrimitive "Integer" (Int (fromInteger (toInteger x')))

1223mkExp (SConst (BI x)) =

1264mkExp (SConst (BI x)) =

1224 return $ InstanceCreation []

1265 return $ InstanceCreation []

1225 (ClassType [(Ident "BigInteger", [])])

1266 (ClassType [(Ident "BigInteger", [])])

@@ -1233,10 +1274,10 @@ mkExp (SConst BIType) = return $ mkClass bigIntegerType

1233mkExp (SConst FlType) = return $ mkClass doubleType

1274mkExp (SConst FlType) = return $ mkClass doubleType

1234mkExp (SConst ChType) = return $ mkClass charType

1275mkExp (SConst ChType) = return $ mkClass charType

1235mkExp (SConst StrType) = return $ mkClass stringType

1276mkExp (SConst StrType) = return $ mkClass stringType

1236−mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (Int (toInteger x))

1277+mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))

1237−mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (Int (toInteger x))

1278+mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))

1238mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))

1279mkExp (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))

1240mkExp (SConst (B8Type))= return $ mkClass byteType

1281mkExp (SConst (B8Type))= return $ mkClass byteType

1241mkExp (SConst (B16Type)) = return $ mkClass shortType

1282mkExp (SConst (B16Type)) = return $ mkClass shortType

1242mkExp (SConst (B32Type)) = return $ mkClass integerType

1283mkExp (SConst (B32Type)) = return $ mkClass integerType

@@ -1245,24 +1286,22 @@ mkExp (SConst (PtrType)) = return $ mkClass objectType

1245mkExp (SConst (VoidType)) = return $ mkClass voidType

1286mkExp (SConst (VoidType)) = return $ mkClass voidType

1246mkExp (SConst (Forgot)) = return $ mkClass objectType

1287mkExp (SConst (Forgot)) = return $ mkClass objectType

1247mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args

1288mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args

1248−mkExp (SOp LPlus args) = mkBinOpExp integerType Add args

1289+mkExp (SOp (LPlus ITNative) args) = mkExp (SOp (LPlus IT32) args)

1249−mkExp (SOp LMinus args) = mkBinOpExp integerType Sub args

1290+mkExp (SOp (LMinus ITNative) args) = mkExp (SOp (LMinus IT32) args)

1250−mkExp (SOp LTimes args) = mkBinOpExp integerType Mult args

1291+mkExp (SOp (LTimes ITNative) args) = mkExp (SOp (LTimes IT32) args)

1251−mkExp (SOp LDiv args) = mkBinOpExp integerType Div args

1292+mkExp (SOp (LSDiv ITNative) args) = mkExp (SOp (LSDiv IT32) args)

1252−mkExp (SOp LMod args) = mkBinOpExp integerType Rem args

1293+mkExp (SOp (LSRem ITNative) args) = mkExp (SOp (LSRem IT32) args)

1253−mkExp (SOp LAnd args) = mkBinOpExp integerType And args

1294+mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd IT32) args)

1254−mkExp (SOp LOr args) = mkBinOpExp integerType Or args

1295+mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr IT32) args)

1255−mkExp (SOp LXOr args) = mkBinOpExp integerType Xor args

1296+mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr IT32) args)

1256−mkExp (SOp LCompl [var]) =

1297+mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl IT32) args)

1257− PreBitCompl <$> mkVarAccess (Just $ integerType) var

1258−mkExp (SOp LSHL args) = mkBinOpExp integerType LShift args

1298+mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL IT32) args)

1259−mkExp (SOp LSHR args) = mkBinOpExp integerType RShift args

1299+mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR IT32) args)

1260−mkExp (SOp LEq args) =

1300+mkExp (SOp (LEq ITNative) args) = mkExp (SOp (LEq IT32) args)

1261− mkMethodOpChain1 (mkBoolToNumber integerType) objectType "equals" args

1262−mkExp (SOp LLt args) = mkLogicalBinOpExp integerType LThan args

1301+mkExp (SOp (LLt ITNative) args) = mkExp (SOp (LLt IT32) args)

1263−mkExp (SOp LLe args) = mkLogicalBinOpExp integerType LThanE args

1302+mkExp (SOp (LLe ITNative) args) = mkExp (SOp (LLe IT32) args)

1264−mkExp (SOp LGt args) = mkLogicalBinOpExp integerType GThan args

1303+mkExp (SOp (LGt ITNative) args) = mkExp (SOp (LGt IT32) args)

1265−mkExp (SOp LGe args) = mkLogicalBinOpExp integerType GThanE args

1304+mkExp (SOp (LGe ITNative) args) = mkExp (SOp (LGe IT32) args)

1266mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args

1305mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args

1267mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args

1306mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args

1268mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args

1307mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args

@@ -1273,40 +1312,40 @@ mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args

1273mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args

1312mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args

1274mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args

1313mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args

1275mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args

1314mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args

1276−mkExp (SOp LBPlus args) = mkMethodOpChain1 id bigIntegerType "add" args

1315+mkExp (SOp (LPlus ITBig) args) = mkMethodOpChain1 id bigIntegerType "add" args

1277−mkExp (SOp LBMinus args) = mkMethodOpChain1 id bigIntegerType "subtract" args

1316+mkExp (SOp (LMinus ITBig) args) = mkMethodOpChain1 id bigIntegerType "subtract" args

1278−mkExp (SOp LBTimes args) = mkMethodOpChain1 id bigIntegerType "multiply" args

1317+mkExp (SOp (LTimes ITBig) args) = mkMethodOpChain1 id bigIntegerType "multiply" args

1279−mkExp (SOp LBDiv args) = mkMethodOpChain1 id bigIntegerType "divide" args

1318+mkExp (SOp (LSDiv ITBig) args) = mkMethodOpChain1 id bigIntegerType "divide" args

1280−mkExp (SOp LBMod args) = mkMethodOpChain1 id bigIntegerType "mod" args

1319+mkExp (SOp (LSRem ITBig) args) = mkMethodOpChain1 id bigIntegerType "mod" args

1281−mkExp (SOp LBEq args) =

1320+mkExp (SOp (LEq ITBig) args) =

1282 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args

1321 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args

1283−mkExp (SOp LBLt args) =

1322+mkExp (SOp (LLt ITBig) args) =

1284 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1323 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1285 . mkPartialOrder SLt

1324 . mkPartialOrder SLt

1286 )

1325 )

1287 bigIntegerType

1326 bigIntegerType

1288− "compare"

1327+ "compareTo"

1289 args

1328 args

1290−mkExp (SOp LBLe args) =

1329+mkExp (SOp (LLe ITBig) args) =

1291 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1330 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1292 . mkPartialOrder SLe

1331 . mkPartialOrder SLe

1293 )

1332 )

1294 bigIntegerType

1333 bigIntegerType

1295− "compare"

1334+ "compareTo"

1296 args

1335 args

1297−mkExp (SOp LBGt args) =

1336+mkExp (SOp (LGt ITBig) args) =

1298 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1337 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1299 . mkPartialOrder SGt

1338 . mkPartialOrder SGt

1300 )

1339 )

1301 bigIntegerType

1340 bigIntegerType

1302− "compare"

1341+ "compareTo"

1303 args

1342 args

1304−mkExp (SOp LBGe args) =

1343+mkExp (SOp (LGe ITBig) args) =

1305 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1344 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType

1306 . mkPartialOrder SGe

1345 . mkPartialOrder SGe

1307 )

1346 )

1308 bigIntegerType

1347 bigIntegerType

1309− "compare"

1348+ "compareTo"

1310 args

1349 args

1311mkExp (SOp LStrConcat args) =

1350mkExp (SOp LStrConcat args) =

1312 mkMethodOpChain (\ exp -> InstanceCreation []

1351 mkMethodOpChain (\ exp -> InstanceCreation []

@@ -1323,156 +1362,54 @@ mkExp (SOp LStrLt args@[_, _]) =

1323 . mkPartialOrder SLt

1362 . mkPartialOrder SLt

1324 )

1363 )

1325 stringType

1364 stringType

1326− "compare"

1365+ "compareTo"

1327 args

1366 args

1328mkExp (SOp LStrEq args@[_, _]) =

1367mkExp (SOp LStrEq args@[_, _]) =

1329 mkMethodOpChain1 ( mkBoolToNumber integerType)

1368 mkMethodOpChain1 ( mkBoolToNumber integerType)

1330 stringType

1369 stringType

1331 "equals"

1370 "equals"

1332 args

1371 args

1333−mkExp (SOp LStrLen [arg]) =

1372+mkExp (SOp LStrLen [arg]) =

1334 (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])

1373 (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])

1335 <$> mkVarAccess (Just stringType) arg

1374 <$> mkVarAccess (Just stringType) arg

1336−mkExp (SOp LIntFloat [arg]) =

1375+mkExp (SOp (LIntFloat ity) [arg]) =

1337− mkPrimitiveCast integerType doubleType arg

1376+ mkPrimitiveCast (intTyToClass ity) doubleType arg

1338−mkExp (SOp LFloatInt [arg]) =

1377+mkExp (SOp (LFloatInt ity) [arg]) =

1339− mkPrimitiveCast doubleType integerType arg

1378+ mkPrimitiveCast doubleType (intTyToClass ity) arg

1379+mkExp (SOp (LIntStr ITBig) [arg]) =

1380+ (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)

1381+ <$> mkVarAccess (Just stringType) arg

1340−mkExp (SOp LIntStr [arg]) =

1382+mkExp (SOp (LIntStr ity) [arg]) =

1341− mkToString integerType arg

1383+ mkToString (intTyToClass ity) arg

1342−mkExp (SOp LStrInt [arg]) =

1384+mkExp (SOp (LStrInt ity) [arg]) =

1343− mkPrimitiveCast stringType integerType arg

1385+ mkPrimitiveCast stringType (intTyToClass ity) arg

1344mkExp (SOp LFloatStr [arg]) =

1386mkExp (SOp LFloatStr [arg]) =

1345 mkToString doubleType arg

1387 mkToString doubleType arg

1346mkExp (SOp LStrFloat [arg]) =

1388mkExp (SOp LStrFloat [arg]) =

1347 mkPrimitiveCast doubleType stringType arg

1389 mkPrimitiveCast doubleType stringType arg

1348−mkExp (SOp LIntBig [arg]) =

1390+mkExp (SOp (LSExt ITNative ITBig) [arg]) =

1349 mkPrimitiveCast integerType bigIntegerType arg

1391 mkPrimitiveCast integerType bigIntegerType arg

1350−mkExp (SOp LBigInt [arg]) =

1392+mkExp (SOp (LTrunc ITBig ITNative) [arg]) =

1351 mkPrimitiveCast bigIntegerType integerType arg

1393 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]) =

1358 mkVarAccess (Just integerType) arg

1395 mkVarAccess (Just integerType) arg

1359−mkExp (SOp LIntCh [arg]) =

1396+mkExp (SOp (LIntCh ITNative) [arg]) =

1360 mkVarAccess (Just integerType) arg

1397 mkVarAccess (Just integerType) arg

1361mkExp (SOp LPrintNum [arg]) =

1398mkExp (SOp LPrintNum [arg]) =

1362 mkSystemOutPrint <$> (mkVarAccess Nothing arg)

1399 mkSystemOutPrint <$> (mkVarAccess Nothing arg)

1363mkExp (SOp LPrintStr [arg]) =

1400mkExp (SOp LPrintStr [arg]) =

1364 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)

1401 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)

1365mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])

1402mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])

1366−mkExp (SOp LB8Lt args) = mkLogicalBinOpExp byteType LThan args

1403+mkExp (SOp (LLt ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args

1367−mkExp (SOp LB8Lte args) = mkLogicalBinOpExp byteType LThanE args

1404+mkExp (SOp (LLe ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args

1368−mkExp (SOp LB8Eq args) =

1405+mkExp (SOp (LEq ty) args) =

1369− mkMethodOpChain1 (mkBoolToNumber byteType) byteType "equals" args

1406+ mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args

1370−mkExp (SOp LB8Gt args) = mkLogicalBinOpExp byteType GThan args

1407+mkExp (SOp (LGt ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args

1371−mkExp (SOp LB8Gte args) = mkLogicalBinOpExp byteType GThanE args

1408+mkExp (SOp (LGe ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args

1372−mkExp (SOp LB8Plus args) = mkBinOpExp byteType Add args

1409+mkExp (SOp (LPlus ty) args) = mkBinOpExp (intTyToClass ty) Add args

1373−mkExp (SOp LB8Minus args) = mkBinOpExp byteType Sub args

1410+mkExp (SOp (LMinus ty) args) = mkBinOpExp (intTyToClass ty) Sub args

1374−mkExp (SOp LB8Times args) = mkBinOpExp byteType Mult args

1411+mkExp (SOp (LTimes ty) args) = mkBinOpExp (intTyToClass ty) Mult args

1375−mkExp (SOp LB8UDiv args) = mkBinOpExpConv "shortValue" ShortT byteType Div args

1412+mkExp (SOp (LUDiv IT64) (arg:args)) = do

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

1476 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)

1413 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)

1477 return $ foldl (\ exp arg ->

1414 return $ foldl (\ exp arg ->

1478 MethodInv $ PrimaryMethodCall

1415 MethodInv $ PrimaryMethodCall

@@ -1496,8 +1433,14 @@ mkExp (SOp LB64UDiv (arg:args)) = do

1496 )

1433 )

1497 arg

1434 arg

1498 args

1435 args

1436+mkExp (SOp (LUDiv ty) args) =

1437+ mkBinOpExpConv (intTyToMethod $ nextIntTy ty)

1438+ (intTyToPrimTy $ nextIntTy ty)

1439+ (intTyToClass ty)

1440+ Div

1441+ args

1499−mkExp (SOp LB64SDiv args) = mkBinOpExp longType Div args

1442+mkExp (SOp (LSDiv ty) args) = mkBinOpExp (intTyToClass ty) Div args

1500−mkExp (SOp LB64URem (arg:args)) = do

1443+mkExp (SOp (LURem IT64) (arg:args)) = do

1501 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)

1444 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)

1502 return $ foldl (\ exp arg ->

1445 return $ foldl (\ exp arg ->

1503 MethodInv $ PrimaryMethodCall

1446 MethodInv $ PrimaryMethodCall

@@ -1521,46 +1464,36 @@ mkExp (SOp LB64URem (arg:args)) = do

1521 )

1464 )

1522 arg

1465 arg

1523 args

1466 args

1524−mkExp (SOp LB64SRem args) = mkBinOpExp longType Rem args

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

1525−mkExp (SOp LB64Shl args) = mkBinOpExp longType LShift args

1474+mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args

1526−mkExp (SOp LB64LShr args) = mkBinOpExp longType RRShift args

1475+mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args

1527−mkExp (SOp LB64AShr args) = mkBinOpExp longType RShift args

1476+mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args

1528−mkExp (SOp LB64And args) = mkBinOpExp longType And args

1477+mkExp (SOp (LAnd ty) args) = mkBinOpExp (intTyToClass ty) And args

1529−mkExp (SOp LB64Or args) = mkBinOpExp longType Or args

1478+mkExp (SOp (LOr ty) args) = mkBinOpExp (intTyToClass ty) Or args

1530−mkExp (SOp LB64Xor args) = mkBinOpExp longType Xor args

1479+mkExp (SOp (LXOr ty) args) = mkBinOpExp (intTyToClass ty) Xor args

1531−mkExp (SOp LB64Compl [var]) =

1532− PreBitCompl <$> mkVarAccess (Just $ longType) var

1480+mkExp (SOp (LCompl ty) [var]) = PreBitCompl <$> mkVarAccess (Just $ intTyToClass ty) var

1533−mkExp (SOp LB64T8 [var]) =

1481+mkExp (SOp (LZExt from to) [var])

1534− (\ var -> MethodInv

1482+ | intTyWidth from < intTyWidth to

1535− $ TypeMethodCall (J.Name [Ident "Byte"])

1483+ = mkZeroExt (intTyToMethod to) (intTyWidth from) (intTyToClass from) (intTyToClass to) var

1536− []

1537− (Ident "valueOf")

1538− [ MethodInv

1539− $ PrimaryMethodCall var [] (Ident "byteValue") []

1540− ]

1541− )

1542− <$> mkVarAccess (Just $ longType) var

1543−mkExp (SOp LB64T16 [var]) =

1484+mkExp (SOp (LSExt from to) [var])

1544− (\ var -> MethodInv

1485+ | intTyWidth from < intTyWidth to

1545− $ TypeMethodCall (J.Name [Ident "Short"])

1486+ = mkSignedExt (intTyToMethod to) (intTyToClass from) (intTyToClass to) var

1546− []

1487+mkExp (SOp (LTrunc from to) [var])

1547− (Ident "valueOf")

1488+ | intTyWidth from > intTyWidth to

1548− [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]

1549− )

1550− <$> mkVarAccess (Just $ longType) var

1551−mkExp (SOp LB64T32 [var]) =

1552− (\ var -> MethodInv

1489+ = (\ var -> MethodInv $

1553− $ TypeMethodCall (J.Name [Ident "Integer"])

1490+ TypeMethodCall (J.Name [intTyToIdent to])

1554− []

1491+ []

1555− (Ident "valueOf")

1492+ (Ident "valueOf")

1493+ [ MethodInv

1556− [ MethodInv $ PrimaryMethodCall var [] (Ident "intValue") [] ]

1494+ $ PrimaryMethodCall var [] (Ident (intTyToMethod to)) [] ]

1557 )

1495 )

1558− <$> mkVarAccess (Just $ longType) var

1496+ <$> mkVarAccess (Just $ intTyToClass from) 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)

1564mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg

1497mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg

1565mkExp (SOp LFLog [arg]) = mkMathFun "log" arg

1498mkExp (SOp LFLog [arg]) = mkMathFun "log" arg

1566mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg

1499mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg

@@ -1652,4 +1585,4 @@ mkExp (SError err) =

1652 []

1585 []

1653 (Ident "throwSelf")

1586 (Ident "throwSelf")

1654 []

1587 []

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"

139translateConstant StrType = "__IDRRT__.String"

140translateConstant BIType = "__IDRRT__.Integer"

141translateConstant FlType = "__IDRRT__.Float"

142+translateConstant PtrType = "__IDRRT__.Ptr"

142translateConstant Forgot = "__IDRRT__.Forgot"

143translateConstant Forgot = "__IDRRT__.Forgot"

143translateConstant c =

144translateConstant c =

144 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"

145 "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"

@@ -199,61 +200,61 @@ translateExpression (SApp True name vars) =

199 "new __IDRRT__.Tailcall("

200 "new __IDRRT__.Tailcall("

200 ++ "function(){\n"

201 ++ "function(){\n"

201 ++ "return " ++ translateFunctionCall name vars

202 ++ "return " ++ translateFunctionCall name vars

202− ++ ";\n});"

203+ ++ ";\n})"

203

204

204translateExpression (SOp op vars)

205translateExpression (SOp op vars)

205− | LPlus <- op

206+ | (LPlus _) <- op

206 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

207 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs

207− | LMinus <- op

208+ | (LMinus _) <- op

208 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs

209 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs

209− | LTimes <- op

210+ | (LTimes _) <- op

210 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs

211 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs

211− | LDiv <- op

212+ | (LSDiv _) <- op

212 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs

213 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs

213− | LMod <- op

214+ | (LSRem _) <- op

214 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs

215 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs

215− | LEq <- op

216+ | (LEq _) <- op

216 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs

217 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs

217− | LLt <- op

218+ | (LLt _) <- op

218 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs

219 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs

219− | LLe <- op

220+ | (LLe _) <- op

220 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs

221 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs

221− | LGt <- op

222+ | (LGt _) <- op

222 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs

223 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs

223− | LGe <- op

224+ | (LGe _) <- op

224 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs

225 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs

225− | LAnd <- op

226+ | (LAnd _) <- op

226 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs

227 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs

227− | LOr <- op

228+ | (LOr _) <- op

228 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs

229 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs

229− | LXOr <- op

230+ | (LXOr _) <- op

230 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs

231 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs

231− | LSHL <- op

232+ | (LSHL _) <- op

232 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs

233 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs

233− | LSHR <- op

234+ | (LASHR _) <- op

234 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs

235 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs

235− | LCompl <- op

236+ | (LCompl _) <- op

236 , (arg:_) <- vars = '~' : translateVariableName arg

237 , (arg:_) <- vars = '~' : translateVariableName arg

237

238

238− | LBPlus <- op

239+ | (LPlus ITBig) <- op

239 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"

240 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"

240− | LBMinus <- op

241+ | (LMinus ITBig) <- op

241 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"

242 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"

242− | LBTimes <- op

243+ | (LTimes ITBig) <- op

243 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"

244 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"

244− | LBDiv <- op

245+ | (LSDiv ITBig) <- op

245 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"

246 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"

246− | LBMod <- op

247+ | (LSRem ITBig) <- op

247 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"

248 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"

248− | LBEq <- op

249+ | (LEq ITBig) <- op

249 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"

250 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"

250− | LBLt <- op

251+ | (LLt ITBig) <- op

251 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"

252 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"

252− | LBLe <- op

253+ | (LLe ITBig) <- op

253 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"

254 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"

254− | LBGt <- op

255+ | (LGt ITBig) <- op

255 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"

256 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"

256− | LBGe <- op

257+ | (LGe ITBig) <- op

257 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"

258 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"

258

259

259 | LFPlus <- op

260 | LFPlus <- op

@@ -284,29 +285,29 @@ translateExpression (SOp op vars)

284 | LStrLen <- op

285 | LStrLen <- op

285 , (arg:_) <- vars = translateVariableName arg ++ ".length"

286 , (arg:_) <- vars = translateVariableName arg ++ ".length"

286

287

287− | LStrInt <- op

288+ | (LStrInt ITNative) <- op

288 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"

289 , (arg:_) <- vars = "parseInt(" ++ translateVariableName arg ++ ")"

289− | LIntStr <- op

290+ | (LIntStr ITNative) <- op

290 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"

291 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"

291− | LIntBig <- op

292+ | (LSExt ITNative ITBig) <- op

292 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"

293 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"

293− | LBigInt <- op

294+ | (LTrunc ITBig ITNative) <- op

294 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"

295 , (arg:_) <- vars = translateVariableName arg ++ ".valueOf()"

295− | LBigStr <- op

296+ | (LIntStr ITBig) <- op

296 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"

297 , (arg:_) <- vars = translateVariableName arg ++ ".toString()"

297− | LStrBig <- op

298+ | (LStrInt ITBig) <- op

298 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"

299 , (arg:_) <- vars = "__IDRRT__.bigInt(" ++ translateVariableName arg ++ ")"

299 | LFloatStr <- op

300 | LFloatStr <- op

300 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"

301 , (arg:_) <- vars = "String(" ++ translateVariableName arg ++ ")"

301 | LStrFloat <- op

302 | LStrFloat <- op

302 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"

303 , (arg:_) <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"

303− | LIntFloat <- op

304+ | (LIntFloat ITNative) <- op

304 , (arg:_) <- vars = translateVariableName arg

305 , (arg:_) <- vars = translateVariableName arg

305− | LFloatInt <- op

306+ | (LFloatInt ITNative) <- op

306 , (arg:_) <- vars = translateVariableName arg

307 , (arg:_) <- vars = translateVariableName arg

307− | LChInt <- op

308+ | (LChInt ITNative) <- op

308 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"

309 , (arg:_) <- vars = translateVariableName arg ++ ".charCodeAt(0)"

309− | LIntCh <- op

310+ | (LIntCh ITNative) <- op

310 , (arg:_) <- vars =

311 , (arg:_) <- vars =

311 "String.fromCharCode(" ++ translateVariableName arg ++ ")"

312 "String.fromCharCode(" ++ translateVariableName arg ++ ")"

312

313

@@ -355,19 +356,27 @@ translateExpression (SOp op vars)

355 ++ translateVariableName rhs

356 ++ translateVariableName rhs

356

357

357translateExpression (SError msg) =

358translateExpression (SError msg) =

358− "(function(){throw \'" ++ msg ++ "\';})();"

359+ "(function(){throw \'" ++ msg ++ "\';})()"

359

360

360translateExpression (SForeign _ _ "putStr" [(FString, var)]) =

361translateExpression (SForeign _ _ "putStr" [(FString, var)]) =

361− "__IDRRT__.print(" ++ translateVariableName var ++ ");"

362+ "__IDRRT__.print(" ++ translateVariableName var ++ ")"

362

363

363translateExpression (SForeign _ _ fun args)

364translateExpression (SForeign _ _ fun args)

364− | "." `isPrefixOf` fun, "[]=" `isSuffixOf` fun

365+ | "[]=" `isSuffixOf` fun

365 , (obj:idx:val:[]) <- args =

366 , (obj:idx:val:[]) <- args =

366− concat [object obj, field, index idx, assign val]

367+ concat [object obj, index idx, assign val]

367

368

368− | "." `isPrefixOf` fun, "[]" `isSuffixOf` fun

369+ | "[]" `isSuffixOf` fun

369 , (obj:idx:[]) <- args =

370 , (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 ++ "]"

371

380

372 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun

381 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun

373 , (obj:val:[]) <- args =

382 , (obj:val:[]) <- args =

@@ -401,9 +410,16 @@ translateExpression (SForeign _ _ fun args)

401 array = name

410 array = name

402 object o = translateVariableName (snd o)

411 object o = translateVariableName (snd o)

403 index i = "[" ++ translateVariableName (snd i) ++ "]"

412 index i = "[" ++ translateVariableName (snd i) ++ "]"

404− assign v = '=' : translateVariableName (snd v)

413+ assign v = '=' : generateWrapper v

405 arguments as =

414 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

407

423

408translateExpression (SChkCase var cases) =

424translateExpression (SChkCase var cases) =

409 "(function(e){\n"

425 "(function(e){\n"

@@ -450,7 +466,7 @@ translateCase var (SConstCase ty e)

450 | IType <- ty = matchHelper "Int"

466 | IType <- ty = matchHelper "Int"

451 | BIType <- ty = matchHelper "Integer"

467 | BIType <- ty = matchHelper "Integer"

452 | FlType <- ty = matchHelper "Float"

468 | FlType <- ty = matchHelper "Float"

453− | PtrType <- ty = matchHelper "Pointer"

469+ | PtrType <- ty = matchHelper "Ptr"

454 | Forgot <- ty = matchHelper "Forgot"

470 | Forgot <- ty = matchHelper "Forgot"

455 where

471 where

456 matchHelper tyName = translateTypeMatch var tyName e

472 matchHelper tyName = translateTypeMatch var tyName e

src/IRTS/Compiler.hs+22−10

@@ -98,7 +98,7 @@ irMain tm = do i <- ir tm

98allNames :: [Name] -> Name -> Idris [Name]

99allNames ns n | n `elem` ns = return []

100allNames ns n = do i <- getIState

101− case lookupCtxt Nothing n (idris_callgraph i) of

101+ case lookupCtxt n (idris_callgraph i) of

102 [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))

103 return (nub (n : concat more))

104 _ -> return [n]

@@ -169,6 +169,8 @@ instance ToIR (TT Name) where

169 | (P _ (UN "lazy") _, [_, arg]) <- unApply tm

170 = do arg' <- ir' env arg

171 return $ LLazyExp arg'

172+ | (P _ (UN "assert_smaller") _, [_, _, _, arg]) <- unApply tm

173+ = ir' env arg

172 | (P _ (UN "par") _, [_, arg]) <- unApply tm

174 | (P _ (UN "par") _, [_, arg]) <- unApply tm

173 = do arg' <- ir' env arg

175 = do arg' <- ir' env arg

174 return $ LOp LPar [LLazyExp arg']

176 return $ LOp LPar [LLazyExp arg']

@@ -205,12 +207,12 @@ instance ToIR (TT Name) where

205 Just tm -> return tm

207 Just tm -> return tm

206 _ -> do

208 _ -> do

207 let collapse

209 let collapse

208− = case lookupCtxt Nothing n

210+ = case lookupCtxt n

209 (idris_optimisation i) of

211 (idris_optimisation i) of

210 [oi] -> collapsible oi

212 [oi] -> collapsible oi

211 _ -> False

213 _ -> False

212 let unused

214 let unused

213− = case lookupCtxt Nothing n

215+ = case lookupCtxt n

214 (idris_callgraph i) of

216 (idris_callgraph i) of

215 [CGInfo _ _ _ _ unusedpos] ->

217 [CGInfo _ _ _ _ unusedpos] ->

216 unusedpos

218 unusedpos

@@ -229,7 +231,7 @@ instance ToIR (TT Name) where

229-- ir' env (P _ (NS (UN "O") ["Nat", "Prelude"]) _)

231-- ir' env (P _ (NS (UN "O") ["Nat", "Prelude"]) _)

230-- = return $ LConst (BI 0)

232-- = return $ LConst (BI 0)

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

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

233 | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm

235 | otherwise = error $ "IR fail " ++ show i ++ " " ++ show tm

234 ir' env (Bind n (Lam _) sc)

236 ir' env (Bind n (Lam _) sc)

235 = do let n' = uniqueName n env

237 = do let n' = uniqueName n env

@@ -284,14 +286,24 @@ getFTypes tm = case unApply tm of

284 _ -> Nothing

286 _ -> Nothing

285

287

286mkIty' (P _ (UN ty) _) = mkIty ty

288mkIty' (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

287mkIty' _ = FAny

292mkIty' _ = FAny

288

293

289−mkIty "FInt" = FInt

294+mkIty "FFloat" = FDouble

290−mkIty "FFloat" = FDouble

295+mkIty "FChar" = FChar

291−mkIty "FChar" = FChar

296+mkIty "FString" = FString

292−mkIty "FString" = FString

297+mkIty "FPtr" = FPtr

293−mkIty "FPtr" = FPtr

298+mkIty "FUnit" = FUnit

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

295

307

296zname = NS (UN "O") ["Nat","Prelude"]

308zname = NS (UN "O") ["Nat","Prelude"]

297sname = NS (UN "S") ["Nat","Prelude"]

309sname = NS (UN "S") ["Nat","Prelude"]

src/IRTS/Defunctionalise.hs+2−2

@@ -80,14 +80,14 @@ addApps defs (n, LFun _ _ args e)

80-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e

81 aa env (LApp tc (LV (Glob n)) args)

82 = do args' <- mapM (aa env) args

83− case lookupCtxt Nothing n defs of

83+ case lookupCtxt n defs of

84 [LConstructor _ i ar] -> return $ DApp tc n args'

85 [LFun _ _ as _] -> let arity = length as in

86 fixApply tc n args' arity

87 [] -> return $ chainAPPLY (DV (Glob n)) args'

88 aa env (LLazyApp n args)

89 = do args' <- mapM (aa env) args

90− case lookupCtxt Nothing n defs of

90+ case lookupCtxt n defs of

91 [LConstructor _ i ar] -> return $ DApp False n args'

92 [LFun _ _ as _] -> let arity = length as in

93 fixLazyApply n args' arity

src/IRTS/LParser.hs+27−27

@@ -92,39 +92,39 @@ pLDecl = do reserved "data"

92

93pLExp = buildExpressionParser optable pLExp'

94

95−optable = [[binary "*" (\x y -> LOp LTimes [x,y]) AssocLeft,

95+optable = [[binary "*" (\x y -> LOp (LTimes ITNative) [x,y]) AssocLeft,

96− binary "/" (\x y -> LOp LDiv [x,y]) AssocLeft,

96+ binary "/" (\x y -> LOp (LSDiv ITNative) [x,y]) AssocLeft,

97 binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft,

98 binary "/." (\x y -> LOp LFDiv [x,y]) AssocLeft,

99− binary "*:" (\x y -> LOp LBTimes [x,y]) AssocLeft,

99+ binary "*:" (\x y -> LOp (LTimes ITBig) [x,y]) AssocLeft,

100− binary "/:" (\x y -> LOp LBDiv [x,y]) AssocLeft

100+ binary "/:" (\x y -> LOp (LSDiv ITBig) [x,y]) AssocLeft

101 ],

102 [

103− binary "+" (\x y -> LOp LPlus [x,y]) AssocLeft,

103+ binary "+" (\x y -> LOp (LPlus ITNative) [x,y]) AssocLeft,

104− binary "-" (\x y -> LOp LMinus [x,y]) AssocLeft,

104+ binary "-" (\x y -> LOp (LMinus ITNative) [x,y]) AssocLeft,

105 binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,

106 binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft,

107 binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft,

108− binary "+:" (\x y -> LOp LBPlus [x,y]) AssocLeft,

108+ binary "+:" (\x y -> LOp (LPlus ITBig) [x,y]) AssocLeft,

109− binary "-:" (\x y -> LOp LBMinus [x,y]) AssocLeft

109+ binary "-:" (\x y -> LOp (LMinus ITBig) [x,y]) AssocLeft

110 ],

111 [

112− binary "==" (\x y -> LOp LEq [x, y]) AssocNone,

112+ binary "==" (\x y -> LOp (LEq ITNative) [x, y]) AssocNone,

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

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

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

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

121 binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone,

122

123− binary "==:" (\x y -> LOp LBEq [x, y]) AssocNone,

123+ binary "==:" (\x y -> LOp (LEq ITBig) [x, y]) AssocNone,

124− binary "<:" (\x y -> LOp LBLt [x, y]) AssocNone,

124+ binary "<:" (\x y -> LOp (LLt ITBig) [x, y]) AssocNone,

125− binary ">:" (\x y -> LOp LBGt [x, y]) AssocNone,

125+ binary ">:" (\x y -> LOp (LGt ITBig) [x, y]) AssocNone,

126− binary "<=:" (\x y -> LOp LBLe [x, y]) AssocNone,

126+ binary "<=:" (\x y -> LOp (LLe ITBig) [x, y]) AssocNone,

127− binary ">=:" (\x y -> LOp LBGe [x, y]) AssocNone

127+ binary ">=:" (\x y -> LOp (LGe ITBig) [x, y]) AssocNone

128 ]]

129

130binary name f assoc = Infix (do reservedOp name; return f) assoc

@@ -164,7 +164,7 @@ pLExp' = try (do lchar '%'; pCast)

164

165pLang = do reserved "C"; return LANG_C

166

167−pType = do reserved "Int"; return FInt

167+pType = do reserved "Int"; return (FInt ITNative)

168 <|> do reserved "Float"; return FDouble

169 <|> do reserved "String"; return FString

170 <|> do reserved "Unit"; return FUnit

@@ -184,21 +184,21 @@ pCast = do reserved "FloatString"; lchar '('; e <- pLExp; lchar ')'

184 <|> do reserved "StringFloat"; lchar '('; e <- pLExp; lchar ')'

185 return (LOp LStrFloat [e])

186 <|> do reserved "FloatInt"; lchar '('; e <- pLExp; lchar ')'

187− return (LOp LFloatInt [e])

187+ return (LOp (LFloatInt ITNative) [e])

188 <|> do reserved "IntFloat"; lchar '('; e <- pLExp; lchar ')'

189− return (LOp LIntFloat [e])

189+ return (LOp (LIntFloat ITNative) [e])

190 <|> do reserved "StringInt"; lchar '('; e <- pLExp; lchar ')'

191− return (LOp LStrInt [e])

191+ return (LOp (LStrInt ITNative) [e])

192 <|> do reserved "IntString"; lchar '('; e <- pLExp; lchar ')'

193− return (LOp LIntStr [e])

193+ return (LOp (LIntStr ITNative) [e])

194 <|> do reserved "BigInt"; lchar '('; e <- pLExp; lchar ')'

195− return (LOp LBigInt [e])

195+ return (LOp (LTrunc ITBig ITNative) [e])

196 <|> do reserved "IntBig"; lchar '('; e <- pLExp; lchar ')'

197− return (LOp LIntBig [e])

197+ return (LOp (LSExt ITNative ITBig) [e])

198 <|> do reserved "BigString"; lchar '('; e <- pLExp; lchar ')'

199− return (LOp LBigStr [e])

199+ return (LOp (LIntStr ITBig) [e])

200 <|> do reserved "StringBig"; lchar '('; e <- pLExp; lchar ')'

201− return (LOp LStrBig [e])

201+ return (LOp (LStrInt ITBig) [e])

202

203pPrim :: LParser LExp

204pPrim = do reserved "StrEq"; lchar '(';

src/IRTS/Lang.hs+37−26

@@ -3,6 +3,7 @@ module IRTS.Lang where

3import Core.TT

4import Control.Monad.State hiding(lift)

5import Data.List

6+import Foreign.Storable (sizeOf)

6import Debug.Trace

7import Debug.Trace

7

8

8data LVar = Loc Int | Glob Name

9data LVar = Loc Int | Glob Name

@@ -28,36 +29,38 @@ data LExp = LV LVar

28-- Primitive operators. Backends are not *required* to implement all

29-- Primitive operators. Backends are not *required* to implement all

29-- of these, but should report an error if they are unable

30-- of these, but should report an error if they are unable

30

31

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+

31−data PrimFn = LPlus | LMinus | LTimes | LDiv | LMod

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

33− | LEq | LLt | LLe | LGt | LGe

56+ | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy

34 | LFPlus | LFMinus | LFTimes | LFDiv

57 | LFPlus | LFMinus | LFTimes | LFDiv

38 | LStrConcat | LStrLt | LStrEq | LStrLen

59 | LStrConcat | LStrLt | LStrEq | LStrLen

60+ | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy

61+ | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy

41 | LPrintNum | LPrintStr | LReadStr

62 | LPrintNum | LPrintStr | LReadStr

42

63

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−

62 | LFSqrt | LFFloor | LFCeil

65 | LFSqrt | LFFloor | LFCeil

63

66

@@ -76,7 +79,15 @@ data PrimFn = LPlus | LMinus | LTimes | LDiv | LMod

76data FLang = LANG_C

79data FLang = LANG_C

77 deriving (Show, Eq)

80 deriving (Show, Eq)

78

81

82+data FType = FInt IntTy

83+ | FFunction

84+ | FFunctionIO

85+ | FChar

86+ | FString

87+ | FUnit

88+ | FPtr

89+ | FDouble

90+ | FAny

80 deriving (Show, Eq)

91 deriving (Show, Eq)

81

92

82data LAlt = LConCase Int Name [Name] LExp

93data LAlt = LConCase Int Name [Name] LExp

src/IRTS/Simplified.hs+7−7

@@ -46,7 +46,7 @@ simplify :: Bool -> DExp -> State (DDefs, Int) SExp

46simplify tl (DV (Loc i)) = return (SV (Loc i))

47simplify tl (DV (Glob x))

48 = do ctxt <- ldefs

49− case lookupCtxt Nothing x ctxt of

49+ case lookupCtxt x ctxt of

50 [DConstructor _ t 0] -> return $ SCon t x []

51 _ -> return $ SV (Glob x)

52simplify tl (DApp tc n args) = do args' <- mapM sVar args

@@ -88,7 +88,7 @@ simplify tl (DError str) = return $ SError str

88

89sVar (DV (Glob x))

90 = do ctxt <- ldefs

91− case lookupCtxt Nothing x ctxt of

91+ case lookupCtxt x ctxt of

92 [DConstructor _ t 0] -> sVar (DC t x [])

93 _ -> return (Glob x, Nothing)

94sVar (DV x) = return (x, Nothing)

@@ -136,7 +136,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

136 sc env (SV (Glob n)) =

137 case lookup n (reverse env) of -- most recent first

138 Just i -> do lvar i; return (SV (Loc i))

139− Nothing -> case lookupCtxt Nothing n ctxt of

139+ Nothing -> case lookupCtxt n ctxt of

140 [DConstructor _ i ar] ->

141 if True -- ar == 0

142 then return (SCon i n [])

@@ -146,7 +146,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

146 [] -> fail $ "Codegen error: No such variable " ++ show n

147 sc env (SApp tc f args)

148 = do args' <- mapM (scVar env) args

149− case lookupCtxt Nothing f ctxt of

149+ case lookupCtxt f ctxt of

150 [DConstructor n tag ar] ->

151 if True -- (ar == length args)

152 then return $ SCon tag n args'

@@ -160,7 +160,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

160 return $ SForeign l ty f args'

161 sc env (SCon tag f args)

162 = do args' <- mapM (scVar env) args

163− case lookupCtxt Nothing f ctxt of

163+ case lookupCtxt f ctxt of

164 [DConstructor n tag ar] ->

165 if True -- (ar == length args)

166 then return $ SCon tag n args'

@@ -197,7 +197,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

197 scVar env (Glob n) =

198 case lookup n (reverse env) of -- most recent first

199 Just i -> do lvar i; return (Loc i)

200− Nothing -> case lookupCtxt Nothing n ctxt of

200+ Nothing -> case lookupCtxt n ctxt of

201 [DConstructor _ i ar] ->

202 fail $ "Codegen error : can't pass constructor here"

203 [_] -> return (Glob n)

@@ -207,7 +207,7 @@ scopecheck ctxt envTop tm = sc envTop tm where

207

208 scalt env (SConCase _ i n args e)

209 = do let env' = env ++ zip args [length env..]

210− tag <- case lookupCtxt Nothing n ctxt of

210+ tag <- case lookupCtxt n ctxt of

211 [DConstructor _ i ar] ->

212 if True -- (length args == ar)

213 then return i

src/Idris/AbsSyntax.hs+117−27

@@ -8,6 +8,7 @@ import Core.Evaluate

8import Core.Elaborate hiding (Tactic(..))

9import Core.Typecheck

10import Idris.AbsSyntaxTree

11+import Idris.IdeSlave

11import IRTS.CodegenCommon

12import IRTS.CodegenCommon

12import Util.DynamicLinker

13import Util.DynamicLinker

13

14

@@ -24,7 +25,7 @@ import Data.Either

24import Debug.Trace

25import Debug.Trace

25

26

26import Util.Pretty

27import Util.Pretty

27−

28+import Util.System

28

29

29getContext :: Idris Context

30getContext :: Idris Context

30getContext = do i <- getIState; return (tt_ctxt i)

31getContext = do i <- getIState; return (tt_ctxt i)

@@ -41,13 +42,15 @@ getLibs = do i <- getIState; return (idris_libs i)

41addLib :: String -> Idris ()

42addLib :: String -> Idris ()

42addLib f = do i <- getIState; putIState $ i { idris_libs = f : idris_libs i }

43addLib f = do i <- getIState; putIState $ i { idris_libs = f : idris_libs i }

43

44

44−addDyLib :: String -> Idris ()

45+addDyLib :: [String] -> Idris (Either DynamicLib String)

45−addDyLib lib = do i <- getIState

46+addDyLib libs = do i <- getIState

46− handle <- lift $ tryLoadLib lib

47+ handle <- lift $ mapM (\l -> catchIO (tryLoadLib l) (\_ -> return Nothing)) libs

47− case handle of

48+ case msum handle of

48− Nothing -> fail $ "Could not load dynamic lib \"" ++ lib ++ "\""

49+ Nothing -> return (Right $ "Could not load dynamic alternatives \"" ++

50+ concat (intersperse "," libs) ++ "\"")

49− Just x -> do let libs = idris_dynamic_libs i

51+ Just x -> do let ls = idris_dynamic_libs i

50− putIState $ i { idris_dynamic_libs = x:libs }

52+ putIState $ i { idris_dynamic_libs = x:ls }

53+ return (Left x)

51

54

52addHdr :: String -> Idris ()

55addHdr :: String -> Idris ()

53addHdr f = do i <- getIState; putIState $ i { idris_hdrs = f : idris_hdrs i }

56addHdr f = do i <- getIState; putIState $ i { idris_hdrs = f : idris_hdrs i }

@@ -88,7 +91,7 @@ getCoercionsTo i ty =

88 findCoercions fn cs

91 findCoercions fn cs

89 where findCoercions t [] = []

92 where findCoercions t [] = []

90 findCoercions t (n : ns) =

93 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

92 [ty] -> case unApply (getRetTy ty) of

95 [ty] -> case unApply (getRetTy ty) of

93 (t', _) ->

96 (t', _) ->

94 if t == t' then [n] else []

97 if t == t' then [n] else []

@@ -119,7 +122,7 @@ addToCalledG n ns = return () -- TODO

119addInstance :: Bool -> Name -> Name -> Idris ()

122addInstance :: Bool -> Name -> Name -> Idris ()

120addInstance int n i

123addInstance int n i

121 = do ist <- getIState

124 = do ist <- getIState

122− case lookupCtxt Nothing n (idris_classes ist) of

125+ case lookupCtxt n (idris_classes ist) of

123 [CI a b c d ins] ->

126 [CI a b c d ins] ->

124 do let cs = addDef n (CI a b c d (addI i ins)) (idris_classes ist)

127 do let cs = addDef n (CI a b c d (addI i ins)) (idris_classes ist)

125 putIState $ ist { idris_classes = cs }

128 putIState $ ist { idris_classes = cs }

@@ -139,7 +142,7 @@ addInstance int n i

139addClass :: Name -> ClassInfo -> Idris ()

142addClass :: Name -> ClassInfo -> Idris ()

140addClass n i

143addClass n i

141 = do ist <- getIState

144 = do ist <- getIState

142− let i' = case lookupCtxt Nothing n (idris_classes ist) of

145+ let i' = case lookupCtxt n (idris_classes ist) of

143 [c] -> c { class_instances = class_instances i }

146 [c] -> c { class_instances = class_instances i }

144 _ -> i

147 _ -> i

145 putIState $ ist { idris_classes = addDef n i' (idris_classes ist) }

148 putIState $ ist { idris_classes = addDef n i' (idris_classes ist) }

@@ -193,7 +196,7 @@ getName = do i <- getIState;

193checkUndefined :: FC -> Name -> Idris ()

196checkUndefined :: FC -> Name -> Idris ()

194checkUndefined fc n

197checkUndefined fc n

195 = do i <- getContext

198 = do i <- getContext

196− case lookupTy Nothing n i of

199+ case lookupTy n i of

197 (_:_) -> fail $ show fc ++ ":" ++

200 (_:_) -> fail $ show fc ++ ":" ++

198 show n ++ " already defined"

201 show n ++ " already defined"

199 _ -> return ()

202 _ -> return ()

@@ -201,7 +204,7 @@ checkUndefined fc n

201isUndefined :: FC -> Name -> Idris Bool

204isUndefined :: FC -> Name -> Idris Bool

202isUndefined fc n

205isUndefined fc n

203 = do i <- getContext

206 = do i <- getContext

204− case lookupTy Nothing n i of

207+ case lookupTy n i of

205 (_:_) -> return False

208 (_:_) -> return False

206 _ -> return True

209 _ -> return True

207

210

@@ -220,10 +223,14 @@ addConstraints fc (v, cs)

220 let ics = zip cs (repeat fc) ++ idris_constraints i

223 let ics = zip cs (repeat fc) ++ idris_constraints i

221 putIState $ i { tt_ctxt = ctxt', idris_constraints = ics }

224 putIState $ i { tt_ctxt = ctxt', idris_constraints = ics }

222

225

226+addDeferred = addDeferred' Ref

227+addDeferredTyCon = addDeferred' (TCon 0 0)

228+

223−addDeferred :: [(Name, Type)] -> Idris ()

229+addDeferred' :: NameType -> [(Name, Type)] -> Idris ()

230+addDeferred' nt ns

224−addDeferred ns = do mapM_ (\(n, t) -> updateContext (addTyDecl n (tidyNames [] t))) ns

231+ = do mapM_ (\(n, t) -> updateContext (addTyDecl n nt (tidyNames [] t))) ns

225− i <- getIState

232+ i <- getIState

226− putIState $ i { idris_metavars = map fst ns ++ idris_metavars i }

233+ putIState $ i { idris_metavars = map fst ns ++ idris_metavars i }

227 where tidyNames used (Bind (MN i x) b sc)

234 where tidyNames used (Bind (MN i x) b sc)

228 = let n' = uniqueName (UN x) used in

235 = let n' = uniqueName (UN x) used in

229 Bind n' b $ tidyNames (n':used) sc

236 Bind n' b $ tidyNames (n':used) sc

@@ -236,11 +243,44 @@ solveDeferred :: Name -> Idris ()

236solveDeferred n = do i <- getIState

243solveDeferred n = do i <- getIState

237 putIState $ i { idris_metavars = idris_metavars i \\ [n] }

244 putIState $ i { idris_metavars = idris_metavars i \\ [n] }

238

245

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+

239iputStrLn :: String -> Idris ()

266iputStrLn :: String -> Idris ()

267+iputStrLn s = do i <- getIState

268+ case idris_outputmode i of

240−iputStrLn = liftIO . putStrLn

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

241

278

242iWarn :: FC -> String -> Idris ()

279iWarn :: FC -> String -> Idris ()

280+iWarn fc err = do i <- getIState

281+ case idris_outputmode i of

243−iWarn fc err = liftIO $ putStrLn (show fc ++ ":" ++ err)

282+ RawOutput -> liftIO $ putStrLn (show fc ++ ":" ++ err)

283+ IdeSlave n -> liftIO $ putStrLn $ convSExp "warning" (fc_fname fc, fc_line fc, err) n

244

284

245setLogLevel :: Int -> Idris ()

285setLogLevel :: Int -> Idris ()

246setLogLevel l = do i <- getIState

286setLogLevel l = do i <- getIState

@@ -317,6 +357,11 @@ outputTy :: Idris OutputType

317outputTy = do i <- getIState

357outputTy = do i <- getIState

318 return $ opt_outputTy $ idris_options i

358 return $ opt_outputTy $ idris_options i

319

359

360+setIdeSlave :: Bool -> Idris ()

361+setIdeSlave True = do i <- getIState

362+ putIState $ i { idris_outputmode = (IdeSlave 0) }

363+setIdeSlave False = return ()

364+

320verbose :: Idris Bool

365verbose :: Idris Bool

321verbose = do i <- getIState

366verbose = do i <- getIState

322 return (opt_verbose (idris_options i))

367 return (opt_verbose (idris_options i))

@@ -641,7 +686,7 @@ getPriority :: IState -> PTerm -> Int

641getPriority i tm = 1 -- pri tm

686getPriority i tm = 1 -- pri tm

642 where

687 where

643 pri (PRef _ n) =

688 pri (PRef _ n) =

644− case lookupP Nothing n (tt_ctxt i) of

689+ case lookupP n (tt_ctxt i) of

645 ((P (DCon _ _) _ _):_) -> 1

690 ((P (DCon _ _) _ _):_) -> 1

646 ((P (TCon _ _) _ _):_) -> 1

691 ((P (TCon _ _) _ _):_) -> 1

647 ((P Ref _ _):_) -> 1

692 ((P Ref _ _):_) -> 1

@@ -688,6 +733,45 @@ addStatics n tm ptm =

688

733

689-- Dealing with implicit arguments

734-- Dealing with implicit arguments

690

735

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+

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

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

692-- argument position.

776-- argument position.

693

777

@@ -717,9 +801,13 @@ implicitise syn ignore ist tm

717 then (tm, reverse declimps)

801 then (tm, reverse declimps)

718 else implicitise syn ignore ist (pibind uvars ns tm)

802 else implicitise syn ignore ist (pibind uvars ns tm)

719 where

803 where

720− uvars = using syn

804+ uvars = map ipair (filter uimplicit (using syn))

721 pvars = syn_params syn

805 pvars = syn_params syn

722

806

807+ ipair (UImplicit x y) = (x, y)

808+ uimplicit (UImplicit _ _) = True

809+ uimplicit _ = False

810+

723 dropAll (x:xs) ys | x `elem` ys = dropAll xs ys

811 dropAll (x:xs) ys | x `elem` ys = dropAll xs ys

724 | otherwise = x : dropAll xs ys

812 | otherwise = x : dropAll xs ys

725 dropAll [] ys = []

813 dropAll [] ys = []

@@ -882,9 +970,9 @@ addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm

882

970

883aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm

971aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm

884aiFn inpat True ist fc f []

972aiFn inpat True ist fc f []

885− = case lookupDef Nothing f (tt_ctxt ist) of

973+ = case lookupDef f (tt_ctxt ist) of

886 [] -> Right $ PPatvar fc f

974 [] -> 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

888 -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

976 -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $

889 if (not (vname f) || tcname f

977 if (not (vname f) || tcname f

890 || any constructor alts || any allImp ialts)

978 || any constructor alts || any allImp ialts)

@@ -904,7 +992,7 @@ aiFn inpat expat ist fc f as

904 | f `elem` primNames = Right $ PApp fc (PRef fc f) as

992 | f `elem` primNames = Right $ PApp fc (PRef fc f) as

905aiFn inpat expat ist fc f as

993aiFn inpat expat ist fc f as

906 -- This is where namespaces get resolved by adding PAlternative

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

908 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)

996 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)

909 [] -> if f `elem` idris_metavars ist

997 [] -> if f `elem` idris_metavars ist

910 then Right $ PApp fc (PRef fc f) as

998 then Right $ PApp fc (PRef fc f) as

@@ -949,7 +1037,7 @@ stripLinear :: IState -> PTerm -> PTerm

949stripLinear i tm = evalState (sl tm) [] where

1037stripLinear i tm = evalState (sl tm) [] where

950 sl :: PTerm -> State [Name] PTerm

1038 sl :: PTerm -> State [Name] PTerm

951 sl (PRef fc f)

1039 sl (PRef fc f)

952− | (_:_) <- lookupTy Nothing f (tt_ctxt i)

1040+ | (_:_) <- lookupTy f (tt_ctxt i)

953 = return $ PRef fc f

1041 = return $ PRef fc f

954 | otherwise = do ns <- get

1042 | otherwise = do ns <- get

955 if (f `elem` ns)

1043 if (f `elem` ns)

@@ -1074,14 +1162,16 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where

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

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

1075-- | otherwise = Nothing

1163-- | otherwise = Nothing

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

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

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

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

1078 match (PRef _ n) tm@(PRef _ n')

1168 match (PRef _ n) tm@(PRef _ n')

1079 | n == n' && not names &&

1169 | n == n' && not names &&

1080− (not (isConName Nothing n (tt_ctxt i)) || tm == Placeholder)

1170+ (not (isConName n (tt_ctxt i)) || tm == Placeholder)

1081 = return [(n, tm)]

1171 = return [(n, tm)]

1082 | n == n' = return []

1172 | n == n' = return []

1083 match (PRef _ n) tm

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

1085 = return [(n, tm)]

1175 = return [(n, tm)]

1086 match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l'

1176 match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l'

1087 mr <- match' r r'

1177 mr <- match' r r'

src/Idris/AbsSyntaxTree.hs+73−10

@@ -41,10 +41,27 @@ data IOption = IOption { opt_logLevel :: Int,

41 }

42 deriving (Show, Eq)

43

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

45

59

46data LanguageExt = TypeProviders deriving (Show, Eq, Read, Ord)

60data LanguageExt = TypeProviders deriving (Show, Eq, Read, Ord)

47

61

62+-- | The output mode in use

63+data OutputMode = RawOutput | IdeSlave Integer deriving Show

64+

48-- TODO: Add 'module data' to IState, which can be saved out and reloaded quickly (i.e

65-- TODO: Add 'module data' to IState, which can be saved out and reloaded quickly (i.e

49-- without typechecking).

66-- without typechecking).

50-- This will include all the functions and data declarations, plus fixity declarations

67-- This will include all the functions and data declarations, plus fixity declarations

@@ -62,7 +79,8 @@ data IState = IState {

62 idris_dsls :: Ctxt DSL,

79 idris_dsls :: Ctxt DSL,

63 idris_optimisation :: Ctxt OptInfo,

80 idris_optimisation :: Ctxt OptInfo,

64 idris_datatypes :: Ctxt TypeInfo,

81 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

66 idris_flags :: Ctxt [FnOpt],

84 idris_flags :: Ctxt [FnOpt],

67 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

85 idris_callgraph :: Ctxt CGInfo, -- name, args used in each pos

68 idris_calledgraph :: Ctxt [Name],

86 idris_calledgraph :: Ctxt [Name],

@@ -91,7 +109,8 @@ data IState = IState {

91 ibc_write :: [IBCWrite],

109 ibc_write :: [IBCWrite],

92 compiled_so :: Maybe String,

110 compiled_so :: Maybe String,

93 idris_dynamic_libs :: [DynamicLib],

111 idris_dynamic_libs :: [DynamicLib],

94− idris_language_extensions :: [LanguageExt]

112+ idris_language_extensions :: [LanguageExt],

113+ idris_outputmode :: OutputMode

95 }

114 }

96

115

97data SizeChange = Smaller | Same | Bigger | Unknown

116data SizeChange = Smaller | Same | Bigger | Unknown

@@ -143,10 +162,11 @@ idrisInit = IState initContext [] [] emptyContext emptyContext emptyContext

143 emptyContext emptyContext emptyContext emptyContext

162 emptyContext emptyContext emptyContext emptyContext

144 emptyContext emptyContext emptyContext emptyContext

163 emptyContext emptyContext emptyContext emptyContext

145 [] "" defaultOpts 6 [] [] [] [] [] [] [] [] []

164 [] "" defaultOpts 6 [] [] [] [] [] [] [] [] []

146− [] Nothing Nothing [] [] [] Hidden False [] Nothing [] []

165+ [] Nothing Nothing [] [] [] Hidden False [] Nothing [] [] RawOutput

147

166

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

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

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

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

169+--type Idris = WriterT [Either String (IO ())] (State IState a))

150type Idris = StateT IState IO

170type Idris = StateT IState IO

151

171

152-- Commands in the REPL

172-- Commands in the REPL

@@ -167,6 +187,7 @@ data Command = Quit

167 | TotCheck Name

187 | TotCheck Name

168 | Reload

188 | Reload

169 | Load FilePath

189 | Load FilePath

190+ | ChangeDirectory FilePath

170 | ModImport String

191 | ModImport String

171 | Edit

192 | Edit

172 | Compile Target String

193 | Compile Target String

@@ -200,6 +221,7 @@ data Opt = Filename String

200 | Ver

221 | Ver

201 | Usage

222 | Usage

202 | Quiet

223 | Quiet

224+ | Ideslave

203 | ShowLibs

225 | ShowLibs

204 | ShowLibdir

226 | ShowLibdir

205 | ShowIncs

227 | ShowIncs

@@ -701,7 +723,14 @@ initDSL = DSL (PRef f (UN ">>="))

701 Nothing

723 Nothing

702 where f = FC "(builtin)" 0

724 where f = FC "(builtin)" 0

703

725

726+data Using = UImplicit Name PTerm

727+ | UConstraint Name [Name]

728+ deriving (Show, Eq)

729+{-!

730+deriving instance Binary Using

731+!-}

732+

704−data SyntaxInfo = Syn { using :: [(Name, PTerm)],

733+data SyntaxInfo = Syn { using :: [Using],

705 syn_params :: [(Name, PTerm)],

734 syn_params :: [(Name, PTerm)],

706 syn_namespace :: [String],

735 syn_namespace :: [String],

707 no_imp :: [Name],

736 no_imp :: [Name],

@@ -886,10 +915,10 @@ prettyImp impl = prettySe 10

886 bracket p 1 $

915 bracket p 1 $

887 prettySe 1 f <+>

916 prettySe 1 f <+>

888 if impl then

917 if impl then

889− foldl fS empty as

918+ foldl' fS empty as

890 -- foldr (<+>) empty $ map prettyArgS as

919 -- foldr (<+>) empty $ map prettyArgS as

891 else

920 else

892− foldl fSe empty args

921+ foldl' fSe empty args

893 -- foldr (<+>) empty $ map prettyArgSe args

922 -- foldr (<+>) empty $ map prettyArgSe args

894 where

923 where

895 fS l r =

924 fS l r =

@@ -978,7 +1007,7 @@ prettyImp impl = prettySe 10

978showImp :: Bool -> PTerm -> String

1007showImp :: Bool -> PTerm -> String

979showImp impl tm = se 10 tm where

1008showImp impl tm = se 10 tm where

980 se p (PQuote r) = "![" ++ show r ++ "]"

1009 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

982 se p (PInferRef fc n) = "!" ++ show n -- ++ "[" ++ show fc ++ "]"

1011 se p (PInferRef fc n) = "!" ++ show n -- ++ "[" ++ show fc ++ "]"

983 se p (PRef fc n) = if impl then show n -- ++ "[" ++ show fc ++ "]"

1012 se p (PRef fc n) = if impl then show n -- ++ "[" ++ show fc ++ "]"

984 else showbasic n

1013 else showbasic n

@@ -1013,6 +1042,9 @@ showImp impl tm = se 10 tm where

1013 = bracket p 2 $ se 10 ty ++ " => " ++ se 10 sc

1042 = bracket p 2 $ se 10 ty ++ " => " ++ se 10 sc

1014 se p (PPi (TacImp _ _ s _) n ty sc)

1043 se p (PPi (TacImp _ _ s _) n ty sc)

1015 = bracket p 2 $ "{tacimp " ++ show n ++ " : " ++ se 10 ty ++ "} -> " ++ se 10 sc

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

1016 se p (PApp _ (PRef _ f) [])

1048 se p (PApp _ (PRef _ f) [])

1017 | not impl = show f

1049 | not impl = show f

1018 se p (PApp _ (PRef _ op@(UN (f:_))) args)

1050 se p (PApp _ (PRef _ op@(UN (f:_))) args)

@@ -1051,6 +1083,37 @@ showImp impl tm = se 10 tm where

1051 se p (PCoerced t) = se p t

1083 se p (PCoerced t) = se p t

1052-- se p x = "Not implemented"

1084-- se p x = "Not implemented"

1053

1085

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+

1054 sArg (PImp _ _ n tm _) = siArg (n, tm)

1117 sArg (PImp _ _ n tm _) = siArg (n, tm)

1055 sArg (PExp _ _ tm _) = seArg tm

1118 sArg (PExp _ _ tm _) = seArg tm

1056 sArg (PConstraint _ _ tm _) = scArg tm

1119 sArg (PConstraint _ _ tm _) = scArg tm

@@ -1127,7 +1190,7 @@ namesIn uvars ist tm = nub $ ni [] tm

1127 where

1190 where

1128 ni env (PRef _ n)

1191 ni env (PRef _ n)

1129 | not (n `elem` env)

1192 | not (n `elem` env)

1130− = case lookupTy Nothing n (tt_ctxt ist) of

1193+ = case lookupTy n (tt_ctxt ist) of

1131 [] -> [n]

1194 [] -> [n]

1132 _ -> if n `elem` (map fst uvars) then [n] else []

1195 _ -> if n `elem` (map fst uvars) then [n] else []

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

1196 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

1151 where

1214 where

1152 ni env (PRef _ n)

1215 ni env (PRef _ n)

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

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

1154− = case lookupTy Nothing n (tt_ctxt ist) of

1217+ = case lookupTy n (tt_ctxt ist) of

1155 [] -> [n]

1218 [] -> [n]

1156 _ -> []

1219 _ -> []

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

1220 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

59names :: Idris [String]

60names = do i <- get

61 let ctxt = tt_ctxt i

62+ return . nub $

62− return $ nub $ mapMaybe (nameString . fst) $ ctxtAlist ctxt

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

63

67

64metavars :: Idris [String]

68metavars :: Idris [String]

65metavars = do i <- get

69metavars = do i <- get

src/Idris/Coverage.hs+148−170

@@ -17,28 +17,13 @@ import Debug.Trace

17

18import Control.Monad.State

19

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−

35mkPatTm :: PTerm -> Idris Term

20mkPatTm :: PTerm -> Idris Term

36mkPatTm t = do i <- getIState

21mkPatTm t = do i <- getIState

37 let timp = addImpl' True [] [] i t

22 let timp = addImpl' True [] [] i t

38 evalStateT (toTT timp) 0

23 evalStateT (toTT timp) 0

39 where

24 where

40 toTT (PRef _ n) = do i <- lift getIState

25 toTT (PRef _ n) = do i <- lift getIState

41− case lookupDef Nothing n (tt_ctxt i) of

26+ case lookupDef n (tt_ctxt i) of

42 [TyDecl nt _] -> return $ P nt n Erased

27 [TyDecl nt _] -> return $ P nt n Erased

43 _ -> return $ P Ref n Erased

28 _ -> return $ P Ref n Erased

44 toTT (PApp _ t args) = do t' <- toTT t

29 toTT (PApp _ t args) = do t' <- toTT t

@@ -48,101 +33,6 @@ mkPatTm t = do i <- getIState

48 put (v + 1)

33 put (v + 1)

49 return (P Bound (MN v "imp") Erased)

34 return (P Bound (MN v "imp") Erased)

50

35

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−

146-- Given a list of LHSs, generate a extra clauses which cover the remaining

36-- Given a list of LHSs, generate a extra clauses which cover the remaining

147-- cases. The ones which haven't been provided are marked 'absurd' so that the

37-- cases. The ones which haven't been provided are marked 'absurd' so that the

148-- checker will make sure they can't happen.

38-- checker will make sure they can't happen.

@@ -160,7 +50,7 @@ genClauses fc n xs given

160 logLvl 10 $ show argss ++ "\n" ++ show all_args

50 logLvl 10 $ show argss ++ "\n" ++ show all_args

161 logLvl 10 $ "Original: \n" ++

51 logLvl 10 $ "Original: \n" ++

162 showSep "\n" (map (\t -> showImp True (delab' i t True)) xs)

52 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

164 (p : _) -> p

54 (p : _) -> p

165 _ -> repeat (pexp Placeholder)

55 _ -> repeat (pexp Placeholder)

166 let tryclauses = mkClauses parg all_args

56 let tryclauses = mkClauses parg all_args

@@ -217,8 +107,8 @@ genAll i args = case filter (/=Placeholder) $ concatMap otherPats (nub args) of

217 [] -> [Placeholder]

107 [] -> [Placeholder]

218 xs -> nub xs

108 xs -> nub xs

219 where

109 where

220− conForm (PApp _ (PRef fc n) _) = isConName Nothing n (tt_ctxt i)

110+ conForm (PApp _ (PRef fc n) _) = isConName n (tt_ctxt i)

221− conForm (PRef fc n) = isConName Nothing n (tt_ctxt i)

111+ conForm (PRef fc n) = isConName n (tt_ctxt i)

222 conForm _ = False

112 conForm _ = False

223

113

224 otherPats :: PTerm -> [PTerm]

114 otherPats :: PTerm -> [PTerm]

@@ -227,22 +117,22 @@ genAll i args = case filter (/=Placeholder) $ concatMap otherPats (nub args) of

227 otherPats arg = return Placeholder

117 otherPats arg = return Placeholder

228

118

229 ops fc n xs o

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

231 = do xs' <- mapM otherPats (map getTm xs)

121 = do xs' <- mapM otherPats (map getTm xs)

232 let p = PApp fc (PRef fc n) (zipWith upd xs' xs)

122 let p = PApp fc (PRef fc n) (zipWith upd xs' xs)

233 let tyn = getTy n (tt_ctxt i)

123 let tyn = getTy n (tt_ctxt i)

234− case lookupCtxt Nothing tyn (idris_datatypes i) of

124+ case lookupCtxt tyn (idris_datatypes i) of

235 (TI ns _ _ : _) -> p : map (mkPat fc) (ns \\ [n])

125 (TI ns _ _ : _) -> p : map (mkPat fc) (ns \\ [n])

236 _ -> [p]

126 _ -> [p]

237 ops fc n arg o = return Placeholder

127 ops fc n arg o = return Placeholder

238

128

239− getTy n ctxt = case lookupTy Nothing n ctxt of

129+ getTy n ctxt = case lookupTy n ctxt of

240 (t : _) -> case unApply (getRetTy t) of

130 (t : _) -> case unApply (getRetTy t) of

241 (P _ tyn _, _) -> tyn

131 (P _ tyn _, _) -> tyn

242 x -> error $ "Can't happen getTy 1 " ++ show (n, x)

132 x -> error $ "Can't happen getTy 1 " ++ show (n, x)

243 _ -> error "Can't happen getTy 2"

133 _ -> error "Can't happen getTy 2"

244

134

245− mkPat fc x = case lookupCtxt Nothing x (idris_implicits i) of

135+ mkPat fc x = case lookupCtxt x (idris_implicits i) of

246 (pargs : _)

136 (pargs : _)

247 -> PApp fc (PRef fc x) (map (upd Placeholder) pargs)

137 -> PApp fc (PRef fc x) (map (upd Placeholder) pargs)

248 _ -> error "Can't happen - genAll"

138 _ -> error "Can't happen - genAll"

@@ -272,50 +162,62 @@ checkPositive n (cn, ty)

272 = n /= n' && posArg sc

162 = n /= n' && posArg sc

273 posArg t = True

163 posArg t = True

274

164

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−

281calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality

165calcProd :: IState -> FC -> Name -> [([Name], Term, Term)] -> Idris Totality

282−calcProd i fc n pats = do patsprod <- mapM prodRec pats

166+calcProd i fc topn pats

283− if (and patsprod)

167+ = cp topn pats []

284− then return Productive

285− else return (Partial NotProductive)

286 where

168 where

287 -- every application of n must be in an argument of a coinductive

169 -- every application of n must be in an argument of a coinductive

288− -- constructor

170+ -- constructor, in every function reachable from here in the

289−

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+

290− prodRec :: ([Name], Term, Term) -> Idris Bool

177+ prodRec :: Name -> [Name] -> ([Name], Term, Term) -> Idris Bool

178+ prodRec n done _ | n `elem` done = return True

291− prodRec (_, _, tm) = prod False tm

179+ prodRec n done (_, _, tm) = prod n done False tm

292−

180+

181+ prod :: Name -> [Name] -> Bool -> Term -> Idris Bool

293− prod ok ap@(App _ _)

182+ prod n done ok ap@(App _ _)

294− | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod ok arg

183+ | (P _ (UN "lazy") _, [_, arg]) <- unApply ap = prod n done ok arg

295− | (P _ f ty, args) <- unApply ap

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!

296− = let co = cotype ty in

188+ let co = cotype nt f ty in

189+ if (not recOK) then return False else

297− if f == n

190+ if f == topn

298− then do argsprod <- mapM (prod co) args

191+ then do argsprod <- mapM (prod n done co) args

299− return (and (ok : argsprod) )

192+ return (and (ok : argsprod) )

300− else do argsprod <- mapM (prod co) args

193+ else do argsprod <- mapM (prod n done co) args

301− return (and argsprod)

194+ return (and argsprod)

302− prod ok (App f a) = liftM2 (&&) (prod False f) (prod False a)

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)

303− prod ok (Bind _ (Let t v) sc) = liftM2 (&&) (prod False v) (prod False v)

198+ = liftM2 (&&) (prod n done False v) (prod n done False v)

304− prod ok (Bind _ b sc) = prod ok sc

199+ prod n done ok (Bind _ b sc) = prod n done ok sc

305− prod ok t = return True

200+ prod n done ok t = return True

306−

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+

307− cotype ty

209+ cotype (DCon _ _) n ty

308 | (P _ t _, _) <- unApply (getRetTy ty)

210 | (P _ t _, _) <- unApply (getRetTy ty)

309− = case lookupCtxt Nothing t (idris_datatypes i) of

211+ = case lookupCtxt t (idris_datatypes i) of

310 [TI _ True _] -> True

212 [TI _ True _] -> True

311 _ -> False

213 _ -> False

312− | otherwise = False

214+ cotype nt n ty = False

313

215

314calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]

216calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]

315 -> Idris Totality

217 -> Idris Totality

316calcTotality path fc n pats

218calcTotality path fc n pats

317 = do i <- getIState

219 = do i <- getIState

318− let opts = case lookupCtxt Nothing n (idris_flags i) of

220+ let opts = case lookupCtxt n (idris_flags i) of

319 [fs] -> fs

221 [fs] -> fs

320 _ -> []

222 _ -> []

321 case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of

223 case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of

@@ -339,12 +241,12 @@ checkTotality path fc n

339 updateContext (simplifyCasedef n)

241 updateContext (simplifyCasedef n)

340 ctxt <- getContext

242 ctxt <- getContext

341 i <- getIState

243 i <- getIState

342− let opts = case lookupCtxt Nothing n (idris_flags i) of

244+ let opts = case lookupCtxt n (idris_flags i) of

343 [fs] -> fs

245 [fs] -> fs

344 _ -> []

246 _ -> []

345 t' <- case t of

247 t' <- case t of

346 Unchecked ->

248 Unchecked ->

347− case lookupDef Nothing n ctxt of

249+ case lookupDef n ctxt of

348 [CaseOp _ _ _ _ pats _ _ _ _] ->

250 [CaseOp _ _ _ _ pats _ _ _ _] ->

349 do t' <- if AssertTotal `elem` opts

251 do t' <- if AssertTotal `elem` opts

350 then return $ Total []

252 then return $ Total []

@@ -378,7 +280,7 @@ checkTotality path fc n

378

280

379 warnPartial n t

281 warnPartial n t

380 = do i <- getIState

282 = do i <- getIState

381− case lookupDef Nothing n (tt_ctxt i) of

283+ case lookupDef n (tt_ctxt i) of

382 [x] -> do

284 [x] -> do

383 iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t

285 iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t

384-- ++ "\n" ++ show x

286-- ++ "\n" ++ show x

@@ -407,17 +309,87 @@ checkDeclTotality (fc, n)

407buildSCG :: (FC, Name) -> Idris ()

309buildSCG :: (FC, Name) -> Idris ()

408buildSCG (_, n) = do

310buildSCG (_, n) = do

409 ist <- getIState

311 ist <- getIState

410− case lookupCtxt Nothing n (idris_callgraph ist) of

312+ case lookupCtxt n (idris_callgraph ist) of

411− [cg] -> case lookupDef Nothing n (tt_ctxt ist) of

313+ [cg] -> case lookupDef n (tt_ctxt ist) of

412− [CaseOp _ _ _ _ _ args sc _ _] ->

314+ [CaseOp _ _ _ pats _ args sc _ _] ->

413− do logLvl 3 $ "Building SCG for " ++ show n ++ " from\n"

315+ do logLvl 2 $ "Building SCG for " ++ show n ++ " from\n"

414− ++ show sc

316+ ++ show pats ++ "\n" ++ show sc

415− let newscg = buildSCG' ist sc args

317+ let newscg = buildSCG' ist (rights pats) args

416 logLvl 5 $ show newscg

318 logLvl 5 $ show newscg

417 addToCG n ( cg { scg = newscg } )

319 addToCG n ( cg { scg = newscg } )

418 [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

320 [] -> logLvl 5 $ "Could not build SCG for " ++ show n ++ "\n"

419 x -> error $ "buildSCG: " ++ show (n, x)

321 x -> error $ "buildSCG: " ++ show (n, x)

420

322

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

421buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]

393buildSCG' :: IState -> SC -> [Name] -> [SCGEntry]

422buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

394buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

423 nub $ scg sc (zip args args)

395 nub $ scg sc (zip args args)

@@ -442,17 +414,22 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

442 -- how the arguments relate - either Smaller or Unknown

414 -- how the arguments relate - either Smaller or Unknown

443 argRels :: Name -> [(Name, SizeChange)]

415 argRels :: Name -> [(Name, SizeChange)]

444 argRels n = let ctxt = tt_ctxt ist

416 argRels n = let ctxt = tt_ctxt ist

445− [ty] = lookupTy Nothing n ctxt -- must exist!

417+ [ty] = lookupTy n ctxt -- must exist!

446 P _ nty _ = fst (unApply (getRetTy ty))

418 P _ nty _ = fst (unApply (getRetTy ty))

419+ co = case lookupCtxt nty (idris_datatypes ist) of

420+ [TI _ x _] -> x

421+ _ -> False

447 args = map snd (getArgTys ty) in

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

449 where

424 where

425+ getRel True _ _ = (n, Unknown) -- coinductive

450− getRel ty (P _ n' _) | n' == ty = (n, Smaller)

426+ getRel _ ty (P _ n' _) | n' == ty = (n, Smaller)

451− getRel ty t = (n, Unknown)

427+ getRel _ ty t = (n, Unknown)

452

428

453 scgAlt x vars szs (ConCase n _ args sc)

429 scgAlt x vars szs (ConCase n _ args sc)

454 -- all args smaller than top variable of x in sc

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

456 | Just tvar <- lookup x vars

433 | Just tvar <- lookup x vars

457 = let arel = argRels n

434 = let arel = argRels n

458 szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel

435 szs' = zipWith (\arg (_,t) -> (arg, (x, t))) args arel

@@ -499,11 +476,12 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $

499 getArgPos i n [] = Nothing

476 getArgPos i n [] = Nothing

500 getArgPos i n (x : xs) | n == x = Just i

477 getArgPos i n (x : xs) | n == x = Just i

501 | otherwise = getArgPos (i + 1) n xs

478 | otherwise = getArgPos (i + 1) n xs

479+-}

502

480

503checkSizeChange :: Name -> Idris Totality

481checkSizeChange :: Name -> Idris Totality

504checkSizeChange n = do

482checkSizeChange n = do

505 ist <- getIState

483 ist <- getIState

506− case lookupCtxt Nothing n (idris_callgraph ist) of

484+ case lookupCtxt n (idris_callgraph ist) of

507 [cg] -> do let ms = mkMultiPaths ist [] (scg cg)

485 [cg] -> do let ms = mkMultiPaths ist [] (scg cg)

508 logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++

486 logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++

509 "from " ++ show (scg cg) ++ "\n" ++

487 "from " ++ show (scg cg) ++ "\n" ++

@@ -530,7 +508,7 @@ mkMultiPaths ist path cg

530 where extend (nextf, args)

508 where extend (nextf, args)

531 | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ]

509 | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ]

532 | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)

510 | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)

533− = case lookupCtxt Nothing nextf (idris_callgraph ist) of

511+ = case lookupCtxt nextf (idris_callgraph ist) of

534 [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

512 [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

535 _ -> [ reverse ((nextf, args) : path) ]

513 _ -> [ reverse ((nextf, args) : path) ]

536 | otherwise = [ reverse ((nextf, args) : path) ]

514 | otherwise = [ reverse ((nextf, args) : path) ]

@@ -538,7 +516,7 @@ mkMultiPaths ist path cg

538-- do (nextf, args) <- cg

516-- do (nextf, args) <- cg

539-- if ((nextf, args) `elem` path)

517-- if ((nextf, args) `elem` path)

540-- then return (reverse ((nextf, args) : path))

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

542-- [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

520-- [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)

543-- _ -> return (reverse ((nextf, args) : path))

521-- _ -> return (reverse ((nextf, args) : path))

544

522

@@ -562,12 +540,12 @@ checkMP ist i mp = if i > 0

562-- = Partial BelieveMe

540-- = Partial BelieveMe

563 -- if we get to a constructor, it's fine as long as it's strictly positive

541 -- if we get to a constructor, it's fine as long as it's strictly positive

564 tryPath desc path ((f, _) :es) arg

542 tryPath desc path ((f, _) :es) arg

565− | [TyDecl (DCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)

543+ | [TyDecl (DCon _ _) _] <- lookupDef f (tt_ctxt ist)

566 = case lookupTotal f (tt_ctxt ist) of

544 = case lookupTotal f (tt_ctxt ist) of

567 [Total _] -> Unchecked -- okay so far

545 [Total _] -> Unchecked -- okay so far

568 [Partial _] -> Partial (Other [f])

546 [Partial _] -> Partial (Other [f])

569 x -> error (show x)

547 x -> error (show x)

570− | [TyDecl (TCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)

548+ | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)

571 = Total []

549 = Total []

572 tryPath desc path (e@(f, args) : es) arg

550 tryPath desc path (e@(f, args) : es) arg

573 | e `elem` es && allNothing args = Partial (Mutual [f])

551 | e `elem` es && allNothing args = Partial (Mutual [f])

src/Idris/DataOpts.hs+10−10

@@ -17,7 +17,7 @@ import Debug.Trace

17forceArgs :: Name -> Type -> Idris ()

18forceArgs n t = do i <- getIState

19 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

21 [] -> return $ Optimise False [] []

22 (op:_) -> return op

23 let opts = addDef n (copt { forceable = fargs }) (idris_optimisation i)

@@ -38,7 +38,7 @@ forceArgs n t = do i <- getIState

38

39 collapsibleIn i t

40 | (P _ tn _, _) <- unApply t

41− = case lookupCtxt Nothing tn (idris_optimisation i) of

41+ = case lookupCtxt tn (idris_optimisation i) of

42 [oi] -> collapsible oi

43 _ -> False

44 | otherwise = False

@@ -68,7 +68,7 @@ collapseCons ty cons =

68 setCollapsible n

69 = do i <- getIState

70 iLOG $ show n ++ " collapsible"

71− case lookupCtxt Nothing n (idris_optimisation i) of

71+ case lookupCtxt n (idris_optimisation i) of

72 (oi:_) -> do let oi' = oi { collapsible = True }

73 let opts = addDef n oi' (idris_optimisation i)

74 putIState (i { idris_optimisation = opts })

@@ -79,15 +79,15 @@ collapseCons ty cons =

79

80 forceRec :: IState -> (Name, [Type]) -> Idris Bool

81 forceRec i (n, ts)

82− = case lookupCtxt Nothing n (idris_optimisation i) of

82+ = case lookupCtxt n (idris_optimisation i) of

83 (oi:_) -> checkFR (forceable oi) 0 ts

84 _ -> return False

85 checkFR fs i [] = return True

86 checkFR fs i (_ : xs) | i `elem` fs = checkFR fs (i + 1) xs

87 checkFR fs i (t : xs)

88 -- must be recursive or type is not collapsible

89− = do let rt = getRetTy t

89+ = do let (rtf, rta) = unApply $ getRetTy t

90− if (ty `elem` freeNames rt)

90+ if (ty `elem` freeNames rtf)

91 then checkFR fs (i+1) xs

92 else return False

93

@@ -161,7 +161,7 @@ instance Optimisable Raw where

161 | (Var n, args) <- raw_unapply t -- MAGIC HERE

162 = do args' <- mapM applyOpts args

163 i <- getIState

164− case lookupCtxt Nothing n (idris_optimisation i) of

164+ case lookupCtxt n (idris_optimisation i) of

165 (oi:_) -> return $ applyDataOpt oi n args'

166 _ -> return (raw_apply (Var n) args')

167 | otherwise = do f' <- applyOpts f

@@ -202,14 +202,14 @@ applyDataOpt oi n args

202instance Optimisable (TT Name) where

203 applyOpts c@(P (DCon t arity) n _)

204 = do i <- getIState

205− case lookupCtxt Nothing n (idris_optimisation i) of

205+ case lookupCtxt n (idris_optimisation i) of

206 (oi:_) -> return $ applyDataOptRT oi n t arity []

207 _ -> return c

208 applyOpts t@(App f a)

209 | (c@(P (DCon t arity) n _), args) <- unApply t -- MAGIC HERE

210 = do args' <- mapM applyOpts args

211 i <- getIState

212− case lookupCtxt Nothing n (idris_optimisation i) of

212+ case lookupCtxt n (idris_optimisation i) of

213 (oi:_) -> do return $ applyDataOptRT oi n t arity args'

214 _ -> return (mkApp c args')

215 | otherwise = do f' <- applyOpts f

@@ -224,7 +224,7 @@ instance Optimisable (TT Name) where

224

225 stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x

226 = do i <- getIState

227− case lookupCtxt Nothing ty (idris_optimisation i) of

227+ case lookupCtxt ty (idris_optimisation i) of

228 [oi] -> if collapsible oi

229 then do t' <- stripCollapsed t

230 return (Bind n (PVar x) (instantiate Erased t'))

src/Idris/Delaborate.hs+64−34

@@ -7,6 +7,7 @@ module Idris.Delaborate where

7

8import Idris.AbsSyntax

9import Core.TT

10+import Core.Evaluate

10

11

11import Debug.Trace

12import Debug.Trace

12

13

@@ -15,54 +16,75 @@ bugaddr = "https://github.com/edwinb/Idris-dev/issues"

15delab :: IState -> Term -> PTerm

16delab :: IState -> Term -> PTerm

16delab i tm = delab' i tm False

17delab i tm = delab' i tm False

17

18

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+

18delab' :: IState -> Term -> Bool -> PTerm

26delab' :: IState -> Term -> Bool -> PTerm

27+delab' i t f = delabTy' i [] t f

28+

29+delabTy' :: IState -> [PArg] -- ^ implicit arguments to type, if any

30+ -> Term -> Bool -> PTerm

19−delab' ist tm fullname = de [] tm

31+delabTy' ist imps tm fullname = de [] imps tm

20 where

32 where

21 un = FC "(val)" 0

33 un = FC "(val)" 0

22

34

23− de env (App f a) = deFn env f [a]

35+ de env _ (App f a) = deFn env f [a]

24− de env (V i) | i < length env = PRef un (snd (env!!i))

36+ de env _ (V i) | i < length env = PRef un (snd (env!!i))

25− | otherwise = PRef un (UN ("v" ++ show i ++ ""))

37+ | otherwise = PRef un (UN ("v" ++ show i ++ ""))

26− de env (P _ n _) | n == unitTy = PTrue un

38+ de env _ (P _ n _) | n == unitTy = PTrue un

27− | n == unitCon = PTrue un

39+ | n == unitCon = PTrue un

28− | n == falseTy = PFalse un

40+ | n == falseTy = PFalse un

29− | Just n' <- lookup n env = PRef un n'

41+ | Just n' <- lookup n env = PRef un n'

30− | otherwise = PRef un (dens n)

42+ | otherwise = PRef un (dens n)

31− de env (Bind n (Lam ty) sc) = PLam n (de env ty) (de ((n,n):env) sc)

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)

32− de env (Bind n (Pi ty) sc) = PPi expl n (de env ty) (de ((n,n):env) sc)

52+ = PPi expl n (de env [] ty) (de ((n,n):env) [] sc)

33− de env (Bind n (Let ty val) sc)

53+ de env _ (Bind n (Let ty val) sc)

34− = PLet n (de env ty) (de env val) (de ((n,n):env) sc)

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

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

56+ de env _ (Bind n (Guess ty val) sc) = de ((n, UN "[__]"):env) [] sc

37− de env (Bind n _ sc) = de ((n,n):env) sc

57+ de env _ (Bind n _ sc) = de ((n,n):env) [] sc

38− de env (Constant i) = PConstant i

58+ de env _ (Constant i) = PConstant i

39− de env Erased = Placeholder

59+ de env _ Erased = Placeholder

40− de env Impossible = Placeholder

60+ de env _ Impossible = Placeholder

41− de env (TType i) = PType

61+ de env _ (TType i) = PType

42

62

43 dens x | fullname = x

63 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

45 [_] -> n -- just one thing

65 [_] -> n -- just one thing

46 _ -> ns

66 _ -> ns

47 dens n = n

67 dens n = n

48

68

49 deFn env (App f a) args = deFn env f (a:args)

69 deFn env (App f a) args = deFn env f (a:args)

70+ deFn env (P _ n _) [l,r]

50− deFn env (P _ n _) [l,r] | n == pairTy = PPair un (de env l) (de env r)

71+ | n == pairTy = PPair un (de env [] l) (de env [] r)

51− | n == eqCon = PRefl un (de env r)

72+ | n == eqCon = PRefl un (de env [] r)

52− | n == UN "lazy" = de env r

73+ | n == UN "lazy" = de env [] r

53 deFn env (P _ n _) [ty, Bind x (Lam _) r]

74 deFn env (P _ n _) [ty, Bind x (Lam _) r]

54− | n == UN "Exists"

75+ | n == UN "Exists"

55− = PDPair un (PRef un x) (de env ty)

76+ = PDPair un (PRef un x) (de env [] ty)

56− (de ((x,x):env) (instantiate (P Bound x ty) r))

77+ (de ((x,x):env) [] (instantiate (P Bound x ty) r))

78+ deFn env (P _ n _) [_,_,l,r]

57− deFn env (P _ n _) [_,_,l,r] | n == pairCon = PPair un (de env l) (de env r)

79+ | n == pairCon = PPair un (de env [] l) (de env [] r)

58− | n == eqTy = PEq un (de env l) (de env r)

80+ | n == eqTy = PEq un (de env [] l) (de env [] r)

59− | n == UN "Ex_intro" = PDPair un (de env l) Placeholder

81+ | n == UN "Ex_intro" = PDPair un (de env [] l) Placeholder

60− (de env r)

82+ (de env [] r)

61− deFn env (P _ n _) args = mkPApp (dens n) (map (de env) args)

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

84+ deFn env f args = PApp un (de env [] f) (map pexp (map (de env []) args))

63

85

64 mkPApp n args

86 mkPApp n args

65− | [imps] <- lookupCtxt Nothing n (idris_implicits ist)

87+ | [imps] <- lookupCtxt n (idris_implicits ist)

66 = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)

88 = PApp un (PRef un n) (zipWith imp (imps ++ repeat (pexp undefined)) args)

67 | otherwise = PApp un (PRef un n) (map pexp args)

89 | otherwise = PApp un (PRef un n) (map pexp args)

68

90

@@ -90,6 +112,13 @@ pshow i (CantConvert x y env)

90 "Can't convert " ++ showImp imps (delab i x) ++ " with "

112 "Can't convert " ++ showImp imps (delab i x) ++ " with "

91 ++ showImp imps (delab i y) ++

113 ++ showImp imps (delab i y) ++

92 if (opt_errContext (idris_options i)) then showSc i env else ""

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

93pshow i (InfiniteUnify x tm env)

122pshow i (InfiniteUnify x tm env)

94 = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++

123 = "Unifying " ++ showbasic x ++ " and " ++ show (delab i tm) ++

95 " would lead to infinite value" ++

124 " would lead to infinite value" ++

@@ -111,6 +140,7 @@ pshow i (AlreadyDefined n) = show n ++ " is already defined"

111pshow i (ProofSearchFail e) = pshow i e

140pshow i (ProofSearchFail e) = pshow i e

112pshow i (NoRewriting tm) = "rewrite did not change type " ++ show (delab i tm)

141pshow i (NoRewriting tm) = "rewrite did not change type " ++ show (delab i tm)

113pshow i (At f e) = show f ++ ":" ++ pshow i e

142pshow i (At f e) = show f ++ ":" ++ pshow i e

143+pshow i (ProviderError msg) = "Type provider error: " ++ msg

114

144

115showSc i [] = ""

145showSc i [] = ""

116showSc i xs = "\n\nIn context:\n" ++ showSep "\n" (map showVar (reverse xs))

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

65getDocs :: Name -> Idris Doc

66getDocs n

67 = do i <- getIState

68− case lookupCtxt Nothing n (idris_classes i) of

68+ case lookupCtxt n (idris_classes i) of

69 [ci] -> docClass n ci

70− _ -> case lookupCtxt Nothing n (idris_datatypes i) of

70+ _ -> case lookupCtxt n (idris_datatypes i) of

71 [ti] -> docData n ti

72 _ -> do fd <- docFun n

73 return (FunDoc fd)

@@ -81,7 +81,7 @@ docData n ti

81docClass :: Name -> ClassInfo -> Idris Doc

82docClass n ci

83 = do i <- getIState

84− let docstr = case lookupCtxt Nothing n (idris_docstrings i) of

84+ let docstr = case lookupCtxt n (idris_docstrings i) of

85 [str] -> str

86 _ -> ""

87 mdocs <- mapM docFun (map fst (class_methods ci))

@@ -90,13 +90,13 @@ docClass n ci

90docFun :: Name -> Idris FunDoc

91docFun n

92 = do i <- getIState

93− let docstr = case lookupCtxt Nothing n (idris_docstrings i) of

93+ let docstr = case lookupCtxt n (idris_docstrings i) of

94 [str] -> str

95 _ -> ""

96− let ty = case lookupTy Nothing n (tt_ctxt i) of

96+ let ty = case lookupTy n (tt_ctxt i) of

97 (t : _) -> t

98 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

100 [args] -> zip argnames args

101 _ -> []

102 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

49 ctxt <- getContext

50 i <- getIState

51 logLvl 3 $ show n ++ " pre-type " ++ showImp True ty'

52+ ty' <- addUsingConstraints syn fc ty'

52 ty' <- implicit syn n ty'

53 ty' <- implicit syn n ty'

53 let ty = addImpl i ty'

54 let ty = addImpl i ty'

54 logLvl 2 $ show n ++ " type " ++ showImp True ty

55 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

69 let nty' = normalise ctxt [] nty

70 let nty' = normalise ctxt [] nty

70 let (t, _) = unApply (getRetTy nty')

71 let (t, _) = unApply (getRetTy nty')

71 let corec = case t of

72 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

73 [TI _ True _] -> True

74 [TI _ True _] -> True

74 _ -> False

75 _ -> False

76 _ -> False

@@ -93,14 +94,14 @@ elabPostulate info syn doc fc opts n ty

93 -- make sure it's collapsible, so it is never needed at run time

94 -- make sure it's collapsible, so it is never needed at run time

94 -- start by getting the elaborated type

95 -- start by getting the elaborated type

95 ctxt <- getContext

96 ctxt <- getContext

96− fty <- case lookupTy Nothing n ctxt of

97+ fty <- case lookupTy n ctxt of

97 [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen!

98 [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen!

98 [ty] -> return ty

99 [ty] -> return ty

99 ist <- getIState

100 ist <- getIState

100 let (ap, _) = unApply (getRetTy (normalise ctxt [] fty))

101 let (ap, _) = unApply (getRetTy (normalise ctxt [] fty))

101 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

102 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

102 let postOK = case ap of

103 let postOK = case ap of

103− P _ tn _ -> case lookupCtxt Nothing tn

104+ P _ tn _ -> case lookupCtxt tn

104 (idris_optimisation ist) of

105 (idris_optimisation ist) of

105 [oi] -> collapsible oi

106 [oi] -> collapsible oi

106 _ -> False

107 _ -> False

@@ -121,11 +122,11 @@ elabData info syn doc fc codata (PLaterdecl n t_in)

121 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

122 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

122 (erun fc (build i info False n t))

123 (erun fc (build i info False n t))

123 def' <- checkDef fc defer

124 def' <- checkDef fc defer

124− addDeferred def'

125+ addDeferredTyCon def'

125 mapM_ (elabCaseBlock info) is

126 mapM_ (elabCaseBlock info) is

126 (cty, _) <- recheckC fc [] t'

127 (cty, _) <- recheckC fc [] t'

127 logLvl 2 $ "---> " ++ show cty

128 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

129

130

130elabData info syn doc fc codata (PDatadecl n t_in dcons)

131elabData info syn doc fc codata (PDatadecl n t_in dcons)

131 = do iLOG (show fc)

132 = do iLOG (show fc)

@@ -137,17 +138,17 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

137 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

138 ((t', defer, is), log) <- tclift $ elaborate ctxt n (TType (UVal 0)) []

138 (erun fc (build i info False n t))

139 (erun fc (build i info False n t))

139 def' <- checkDef fc defer

140 def' <- checkDef fc defer

140− addDeferred def'

141+ addDeferredTyCon def'

141 mapM_ (elabCaseBlock info) is

142 mapM_ (elabCaseBlock info) is

142 (cty, _) <- recheckC fc [] t'

143 (cty, _) <- recheckC fc [] t'

143 logLvl 2 $ "---> " ++ show cty

144 logLvl 2 $ "---> " ++ show cty

144 -- temporary, to check cons

145 -- temporary, to check cons

145− when undef $ updateContext (addTyDecl n cty)

146+ when undef $ updateContext (addTyDecl n (TCon 0 0) cty)

146 cons <- mapM (elabCon info syn n codata) dcons

147 cons <- mapM (elabCon info syn n codata) dcons

147 ttag <- getName

148 ttag <- getName

148 i <- getIState

149 i <- getIState

149 let as = map (const Nothing) (getArgTys cty)

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

151 logLvl 2 $ "Parameters : " ++ show params

152 logLvl 2 $ "Parameters : " ++ show params

152 putIState (i { idris_datatypes = addDef n (TI (map fst cons) codata params)

153 putIState (i { idris_datatypes = addDef n (TI (map fst cons) codata params)

153 (idris_datatypes i) })

154 (idris_datatypes i) })

@@ -161,55 +162,102 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)

161 where

162 where

162 -- parameters are names which are unchanged across the structure,

163 -- parameters are names which are unchanged across the structure,

163 -- which appear exactly once in the return type of a constructor

164 -- which appear exactly once in the return type of a constructor

164− findParams :: [(Maybe Name, Bool)] -> [Type] -> [Int]

165+

165− findParams ps [] = mapMaybe (\ ((x, y), n) ->

166+ -- First, find all applications of the constructor, then check over

166− if y then Just n else Nothing)

167+ -- them for repeated arguments

167− (zip ps [0..])

168+

168− findParams ps (t : ts) = findParams (updateParams ps t) ts

169+ findParams :: [Type] -> [Int]

169−

170+ findParams ts = let allapps = concatMap getDataApp ts in

170− updateParams ps (Bind n (Pi t) sc)

171+ paramPos allapps

171− = updateParams (updateParams ps (instantiate (P Bound n t) sc)) t

172+

172− updateParams ps tm@(App f a)

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

173− | (P _ fn _, args) <- unApply tm

194+ | (P _ d _, args) <- unApply f

174− = if fn == n

195+ = if (d == n) then [mParam args args] else []

175− then updateParamsA ps args (tail args)

196+ getDataApp (Bind n (Pi t) sc)

176− else updateParams (updateParams ps f) a

197+ = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc)

177− | otherwise = updateParams (updateParams ps f) a

198+ getDataApp _ = []

178− updateParams ps _ = ps

199+

179−

200+ -- keep the arguments which are single names, which don't appear

180− updateParamsA ((mn, _) : ns) (p@(P _ n' _) : args) all

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)

181− | n' `elem` concatMap freeNames all

209+ | n `elem` freeNames t = 1 + count n ts

182− = (mn, False) : updateParamsA ns args (p : all)

210+ | otherwise = count n ts

183− updateParamsA ((Nothing, b) : ns) (p@(P _ n' _) : args) all

211+ mParam args (_ : rest) = Nothing : mParam args rest

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

190

212

191-- | Elaborate a type provider

213-- | Elaborate a type provider

192elabProvider :: ElabInfo -> SyntaxInfo -> FC -> Name -> PTerm -> PTerm -> Idris ()

214elabProvider :: ElabInfo -> SyntaxInfo -> FC -> Name -> PTerm -> PTerm -> Idris ()

193elabProvider info syn fc n ty tm

215elabProvider info syn fc n ty tm

194 = do i <- getIState

216 = do i <- getIState

217+ -- Ensure that the experimental extension is enabled

195− if not (TypeProviders `elem` idris_language_extensions i)

218+ unless (TypeProviders `elem` idris_language_extensions i) $

196− then fail $ "Failed to define type provider \"" ++ show n ++

219+ fail $ "Failed to define type provider \"" ++ show n ++

197− "\".\nYou must turn on TypeProviders extension."

220+ "\".\nYou must turn on the TypeProviders extension."

198− else do let expected = providerTy fc ty

221+

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

222+ ctxt <- getContext

205− let e'' = normaliseAll ctxt [] e'

223+

206− logLvl 1 $ "Term is " ++ show e''

224+ -- First elaborate the expected type (and check that it's a type)

207− let et' = normaliseAll ctxt [] et

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

208− elabType info syn "" fc [] n ty

236+ elabType info syn "" fc [] n ty

237+

238+ -- Execute the type provider and normalise the result

209− rhs <- execute e''

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

210− elabClauses info fc [] n [PClause fc n (PRef fc $ n) [] (delab i rhs) []]

247+ elabClauses info fc [] n [PClause fc n (PRef fc n) [] (delab i tm) []]

211− logLvl 1 $ "** Elaborated: " ++ show e' ++ " :as: " ++ show et

248+ logLvl 1 $ "Elaborated provider " ++ show n ++ " as: " ++ show tm

212− logLvl 1 $ "** Evaluated: " ++ show rhs ++ " :as: " ++ show et'

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+

213

261

214elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

262elabRecord :: ElabInfo -> SyntaxInfo -> String -> FC -> Name ->

215 PTerm -> String -> Name -> PTerm -> Idris ()

263 PTerm -> String -> Name -> PTerm -> Idris ()

@@ -217,10 +265,10 @@ elabRecord info syn doc fc tyn ty cdoc cn cty

217 = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)])

265 = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)])

218 cty' <- implicit syn cn cty

266 cty' <- implicit syn cn cty

219 i <- getIState

267 i <- getIState

220− cty <- case lookupTy Nothing cn (tt_ctxt i) of

268+ cty <- case lookupTy cn (tt_ctxt i) of

221 [t] -> return (delab i t)

269 [t] -> return (delab i t)

222 _ -> fail "Something went inexplicably wrong"

270 _ -> fail "Something went inexplicably wrong"

223− cimp <- case lookupCtxt Nothing cn (idris_implicits i) of

271+ cimp <- case lookupCtxt cn (idris_implicits i) of

224 [imps] -> return imps

272 [imps] -> return imps

225 let ptys = getProjs [] (renameBs cimp cty)

273 let ptys = getProjs [] (renameBs cimp cty)

226 let ptys_u = getProjs [] cty

274 let ptys_u = getProjs [] cty

@@ -361,7 +409,7 @@ elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()

361elabClauses info fc opts n_in cs = let n = liftname info n_in in

409elabClauses info fc opts n_in cs = let n = liftname info n_in in

362 do ctxt <- getContext

410 do ctxt <- getContext

363 -- Check n actually exists, with no definition yet

411 -- Check n actually exists, with no definition yet

364− let tys = lookupTy Nothing n ctxt

412+ let tys = lookupTy n ctxt

365 checkUndefined n ctxt

413 checkUndefined n ctxt

366 unless (length tys > 1) $ do

414 unless (length tys > 1) $ do

367 fty <- case tys of

415 fty <- case tys of

@@ -378,7 +426,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

378 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

426 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)

379 -- FIXME: Really ought to only do this for total functions!

427 -- FIXME: Really ought to only do this for total functions!

380 let doNothing = case ap of

428 let doNothing = case ap of

381− P _ tn _ -> case lookupCtxt Nothing tn

429+ P _ tn _ -> case lookupCtxt tn

382 (idris_optimisation ist) of

430 (idris_optimisation ist) of

383 [oi] -> collapsible oi

431 [oi] -> collapsible oi

384 _ -> False

432 _ -> False

@@ -386,7 +434,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

386 solveDeferred n

434 solveDeferred n

387 ist <- getIState

435 ist <- getIState

388 when doNothing $

436 when doNothing $

389− case lookupCtxt Nothing n (idris_optimisation ist) of

437+ case lookupCtxt n (idris_optimisation ist) of

390 [oi] -> do let opts = addDef n (oi { collapsible = True })

438 [oi] -> do let opts = addDef n (oi { collapsible = True })

391 (idris_optimisation ist)

439 (idris_optimisation ist)

392 putIState (ist { idris_optimisation = opts })

440 putIState (ist { idris_optimisation = opts })

@@ -410,6 +458,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

410 else stripCollapsed pats

458 else stripCollapsed pats

411

459

412 logLvl 5 $ "Patterns:\n" ++ show pats

460 logLvl 5 $ "Patterns:\n" ++ show pats

461+ logLvl 3 $ "SIMPLIFIED: \n" ++ show pdef

413

462

414 let optpdef = map debind $ map (simpl True (tt_ctxt ist)) optpats

463 let optpdef = map debind $ map (simpl True (tt_ctxt ist)) optpats

415 tree@(CaseDef scargs sc _) <- tclift $

464 tree@(CaseDef scargs sc _) <- tclift $

@@ -420,14 +469,21 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

420 then do missing <- genClauses fc n (map getLHS pdef) cs

469 then do missing <- genClauses fc n (map getLHS pdef) cs

421 -- missing <- genMissing n scargs sc

470 -- missing <- genMissing n scargs sc

422 missing' <- filterM (checkPossible info fc True n) missing

471 missing' <- filterM (checkPossible info fc True n) missing

472+ let clhs = map getLHS pdef

423 logLvl 2 $ "Must be unreachable:\n" ++

473 logLvl 2 $ "Must be unreachable:\n" ++

424 showSep "\n" (map (showImp True) missing') ++

474 showSep "\n" (map (showImp True) missing') ++

425 "\nAgainst: " ++

475 "\nAgainst: " ++

426 showSep "\n" (map (\t -> showImp True (delab ist t)) (map getLHS pdef))

476 showSep "\n" (map (\t -> showImp True (delab ist t)) (map getLHS pdef))

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.

427− return missing'

482+ return (filter (noMatch ist clhs) missing')

428 else return []

483 else return []

429 let pcover = null pmissing

484 let pcover = null pmissing

430 logLvl 2 $ "Optimising patterns"

485 logLvl 2 $ "Optimising patterns"

486+ logLvl 5 $ show optpdef

431 pdef' <- applyOpts optpdef

487 pdef' <- applyOpts optpdef

432 logLvl 2 $ "Optimised patterns"

488 logLvl 2 $ "Optimised patterns"

433 logLvl 5 $ show pdef'

489 logLvl 5 $ show pdef'

@@ -456,8 +512,9 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

456 logLvl 3 $ "Optimised: " ++ show tree'

512 logLvl 3 $ "Optimised: " ++ show tree'

457 ctxt <- getContext

513 ctxt <- getContext

458 ist <- getIState

514 ist <- getIState

459− putIState (ist { idris_patdefs = addDef n pdef' (idris_patdefs ist) })

515+ putIState (ist { idris_patdefs = addDef n (pdef', pmissing)

516+ (idris_patdefs ist) })

460− case lookupTy (namespace info) n ctxt of

517+ case lookupTy n ctxt of

461 [ty] -> do updateContext (addCasedef n (inlinable opts)

518 [ty] -> do updateContext (addCasedef n (inlinable opts)

462 tcase knowncovering

519 tcase knowncovering

463 (AssertTotal `elem` opts)

520 (AssertTotal `elem` opts)

@@ -468,7 +525,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

468 totcheck (fc, n)

525 totcheck (fc, n)

469 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

526 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)

470 i <- getIState

527 i <- getIState

471− case lookupDef Nothing n (tt_ctxt i) of

528+ case lookupDef n (tt_ctxt i) of

472 (CaseOp _ _ _ _ _ scargs sc scargs' sc' : _) ->

529 (CaseOp _ _ _ _ _ scargs sc scargs' sc' : _) ->

473 do let calls = findCalls sc' scargs'

530 do let calls = findCalls sc' scargs'

474 let used = findUsedArgs sc' scargs'

531 let used = findUsedArgs sc' scargs'

@@ -484,7 +541,11 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in

484 [] -> return ()

541 [] -> return ()

485 return ()

542 return ()

486 where

543 where

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+

487− checkUndefined n ctxt = case lookupDef Nothing n ctxt of

548+ checkUndefined n ctxt = case lookupDef n ctxt of

488 [] -> return ()

549 [] -> return ()

489 [TyDecl _ _] -> return ()

550 [TyDecl _ _] -> return ()

490 _ -> tclift $ tfail (At fc (AlreadyDefined n))

551 _ -> tclift $ tfail (At fc (AlreadyDefined n))

@@ -550,6 +611,7 @@ checkPossible info fc tcgen fname lhs_in

550 case recheck ctxt [] (forget lhs_tm) lhs_tm of

611 case recheck ctxt [] (forget lhs_tm) lhs_tm of

551 OK _ -> return True

612 OK _ -> return True

552 _ -> return False

613 _ -> return False

614+

553-- b <- inferredDiff fc (delab' i lhs_tm True) lhs

615-- b <- inferredDiff fc (delab' i lhs_tm True) lhs

554-- return (not b) -- then return (Just lhs_tm) else return Nothing

616-- return (not b) -- then return (Just lhs_tm) else return Nothing

555-- trace (show (delab' i lhs_tm True) ++ "\n" ++ show lhs) $ return (not b)

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

569 -- pattern bindings

631 -- pattern bindings

570 i <- getIState

632 i <- getIState

571 -- get the parameters first, to pass through to any where block

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

573 [t] -> t

635 [t] -> t

574 _ -> error "Can't happen (elabClause function type)"

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

576 [t] -> t

638 [t] -> t

577 _ -> []

639 _ -> []

578 let params = getParamsInType i [] fn_is fn_ty

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

676 = getParamsInType i (n : env) is (instantiate (P Bound n t) sc)

738 = getParamsInType i (n : env) is (instantiate (P Bound n t) sc)

677 getParamsInType i env is tm@(App f a)

739 getParamsInType i env is tm@(App f a)

678 | (P _ tn _, args) <- unApply tm

740 | (P _ tn _, args) <- unApply tm

679− = case lookupCtxt Nothing tn (idris_datatypes i) of

741+ = case lookupCtxt tn (idris_datatypes i) of

680 [t] -> nub $ paramNames args env (param_pos t) ++

742 [t] -> nub $ paramNames args env (param_pos t) ++

681 getParamsInType i env is f ++

743 getParamsInType i env is f ++

682 getParamsInType i env is a

744 getParamsInType i env is a

@@ -709,7 +771,7 @@ elabClause info tcgen (_, PWith fc fname lhs_in withs wval_in withblock)

709 -- Build the LHS as an "Infer", and pull out its type and

771 -- Build the LHS as an "Infer", and pull out its type and

710 -- pattern bindings

772 -- pattern bindings

711 i <- getIState

773 i <- getIState

712− let lhs = addImpl i lhs_in

774+ let lhs = addImplPat i lhs_in

713 logLvl 5 ("LHS: " ++ showImp True lhs)

775 logLvl 5 ("LHS: " ++ showImp True lhs)

714 ((lhs', dlhs, []), _) <-

776 ((lhs', dlhs, []), _) <-

715 tclift $ elaborate ctxt (MN 0 "patLHS") infP []

777 tclift $ elaborate ctxt (MN 0 "patLHS") infP []

@@ -807,18 +869,18 @@ elabClause info tcgen (_, PWith fc fname lhs_in withs wval_in withblock)

807

869

808 mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)

870 mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)

809 = do i <- getIState

871 = do i <- getIState

810− let tm = addImpl i tm_in

872+ let tm = addImplPat i tm_in

811 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++

873 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++

812 showImp True toplhs)

874 showImp True toplhs)

813 case matchClause i toplhs tm of

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

815 Right mvars ->

877 Right mvars ->

816 do logLvl 3 ("Match vars : " ++ show mvars)

878 do logLvl 3 ("Match vars : " ++ show mvars)

817 lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

879 lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w

818 return $ PClause fc wname lhs ws rhs wheres

880 return $ PClause fc wname lhs ws rhs wheres

819 mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs)

881 mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs)

820 = do i <- getIState

882 = do i <- getIState

821− let tm = addImpl i tm_in

883+ let tm = addImplPat i tm_in

822 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++

884 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++

823 showImp True toplhs)

885 showImp True toplhs)

824 withs' <- mapM (mkAuxC wname toplhs ns ns') withs

886 withs' <- mapM (mkAuxC wname toplhs ns ns') withs

@@ -877,6 +939,9 @@ elabClass info syn doc fc constraints tn ps ds

877 -- build instance constructor type

939 -- build instance constructor type

878 -- decorate names of functions to ensure they can't be referred

940 -- decorate names of functions to ensure they can't be referred

879 -- to elsewhere in the class declaration

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

880 let cty = impbind ps $ conbind constraints

945 let cty = impbind ps $ conbind constraints

881 $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods)

946 $ pibind (map (\ (n, ty) -> (mdec n, ty)) methods)

882 constraint

947 constraint

@@ -886,7 +951,8 @@ elabClass info syn doc fc constraints tn ps ds

886 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc False ddecl

951 elabData info (syn { no_imp = no_imp syn ++ mnames }) doc fc False ddecl

887 -- for each constraint, build a top level function to chase it

952 -- for each constraint, build a top level function to chase it

888 logLvl 5 $ "Building functions"

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

890 fns <- mapM (cfun cn constraint usyn (map fst imethods)) constraints

956 fns <- mapM (cfun cn constraint usyn (map fst imethods)) constraints

891 mapM_ (elabDecl EAll info) (concat fns)

957 mapM_ (elabDecl EAll info) (concat fns)

892 -- for each method, build a top level function

958 -- for each method, build a top level function

@@ -952,7 +1018,7 @@ elabClass info syn doc fc constraints tn ps ds

952 let conn = case con of

1018 let conn = case con of

953 PRef _ n -> n

1019 PRef _ n -> n

954 PApp _ (PRef _ n) _ -> n

1020 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

956 [(n, _)] -> n

1022 [(n, _)] -> n

957 _ -> conn

1023 _ -> conn

958 addInstance False conn' cfn

1024 addInstance False conn' cfn

@@ -1013,7 +1079,7 @@ elabInstance :: ElabInfo -> SyntaxInfo ->

1013 [PDecl] -> Idris ()

1079 [PDecl] -> Idris ()

1014elabInstance info syn fc cs n ps t expn ds

1080elabInstance info syn fc cs n ps t expn ds

1015 = do i <- getIState

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

1017 [c] -> return c

1083 [c] -> return c

1018 _ -> fail $ show fc ++ ":" ++ show n ++ " is not a type class"

1084 _ -> fail $ show fc ++ ":" ++ show n ++ " is not a type class"

1019 let constraint = PApp fc (PRef fc n) (map pexp ps)

1085 let constraint = PApp fc (PRef fc n) (map pexp ps)

@@ -1073,7 +1139,7 @@ elabInstance info syn fc cs n ps t expn ds

1073 checkNotOverlapping i t n

1139 checkNotOverlapping i t n

1074 | take 2 (show n) == "@@" = return ()

1140 | take 2 (show n) == "@@" = return ()

1075 | otherwise

1141 | otherwise

1076− = case lookupTy Nothing n (tt_ctxt i) of

1142+ = case lookupTy n (tt_ctxt i) of

1077 [t'] -> let tret = getRetType t

1143 [t'] -> let tret = getRetType t

1078 tret' = getRetType (delab i t') in

1144 tret' = getRetType (delab i t') in

1079 case matchClause i tret' tret of

1145 case matchClause i tret' tret of

@@ -1110,7 +1176,7 @@ elabInstance info syn fc cs n ps t expn ds

1110 | PRef _ n <- getTm p

1176 | PRef _ n <- getTm p

1111 = do ps' <- getWParams ps

1177 = do ps' <- getWParams ps

1112 ctxt <- getContext

1178 ctxt <- getContext

1113− case lookupP Nothing n ctxt of

1179+ case lookupP n ctxt of

1114 [] -> return (pimp n (PRef fc n) : ps')

1180 [] -> return (pimp n (PRef fc n) : ps')

1115 _ -> return ps'

1181 _ -> return ps'

1116 getWParams (_ : ps) = getWParams ps

1182 getWParams (_ : ps) = getWParams ps

@@ -1245,7 +1311,7 @@ elabDecl' what info d@(PClauses f o n ps)

1245 | what /= ETypes

1311 | what /= ETypes

1246 = do iLOG $ "Elaborating clause " ++ show n

1312 = do iLOG $ "Elaborating clause " ++ show n

1247 i <- getIState -- get the type options too

1313 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

1249 [fs] -> fs

1315 [fs] -> fs

1250 [] -> []

1316 [] -> []

1251 elabClauses info f (o ++ o') n ps

1317 elabClauses info f (o ++ o') n ps

src/Idris/ElabTerm.hs+56−50

@@ -96,9 +96,10 @@ elab :: IState -> ElabInfo -> Bool -> Bool -> Name -> PTerm ->

96 ElabD ()

97elab ist info pattern tcgen fn tm

98 = do elabE (False, False) tm -- (in argument, guarded)

99+ end_unify

99 when pattern -- convert remaining holes to pattern vars

100 when pattern -- convert remaining holes to pattern vars

100 (do update_term orderPats

101 (do update_term orderPats

101−-- tm <- get_term

102+ tm <- get_term

102 mkPat)

103 mkPat)

103 where

104 where

104 isph arg = case getTm arg of

105 isph arg = case getTm arg of

@@ -211,7 +212,7 @@ elab ist info pattern tcgen fn tm

211 elab' ina (PPatvar fc n) | pattern = patvar n

212 elab' ina (PPatvar fc n) | pattern = patvar n

212 elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n)

213 elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n)

213 = do ctxt <- get_context

214 = do ctxt <- get_context

214− let defined = case lookupTy Nothing n ctxt of

215+ let defined = case lookupTy n ctxt of

215 [] -> False

216 [] -> False

216 _ -> True

217 _ -> True

217 -- this is to stop us resolve type classes recursively

218 -- this is to stop us resolve type classes recursively

@@ -221,7 +222,7 @@ elab ist info pattern tcgen fn tm

221 then do apply (Var n) []; solve

222 then do apply (Var n) []; solve

222 else try (do apply (Var n) []; solve)

223 else try (do apply (Var n) []; solve)

223 (patvar n)

224 (patvar n)

224− where inparamBlock n = case lookupCtxtName Nothing n (inblock info) of

225+ where inparamBlock n = case lookupCtxtName n (inblock info) of

225 [] -> False

226 [] -> False

226 _ -> True

227 _ -> True

227 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])

228 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])

@@ -231,6 +232,7 @@ elab ist info pattern tcgen fn tm

231 -- let sc' = mapPT (repN n n') sc

232 -- let sc' = mapPT (repN n n') sc

232 ptm <- get_term

233 ptm <- get_term

233 g <- goal

234 g <- goal

235+ checkPiGoal

234 attack; intro (Just n);

236 attack; intro (Just n);

235 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

237 -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)

236 elabE (True, a) sc; solve

238 elabE (True, a) sc; solve

@@ -240,6 +242,7 @@ elab ist info pattern tcgen fn tm

240 = do hsin <- get_holes

242 = do hsin <- get_holes

241 ptmin <- get_term

243 ptmin <- get_term

242 tyn <- unique_hole (MN 0 "lamty")

244 tyn <- unique_hole (MN 0 "lamty")

245+ checkPiGoal

243 claim tyn RType

246 claim tyn RType

244 attack

247 attack

245 ptm <- get_term

248 ptm <- get_term

@@ -332,7 +335,7 @@ elab ist info pattern tcgen fn tm

332 elab' (ina, g) tm@(PApp fc (PRef _ f) args')

335 elab' (ina, g) tm@(PApp fc (PRef _ f) args')

333 = do let args = {- case lookupCtxt f (inblock info) of

336 = do let args = {- case lookupCtxt f (inblock info) of

334 Just ps -> (map (pexp . (PRef fc)) ps ++ args')

337 Just ps -> (map (pexp . (PRef fc)) ps ++ args')

335− _ ->-} args'

338+ _ -> -} args'

336-- newtm <- mkSpecialised ist fc f (map getTm args') tm

339-- newtm <- mkSpecialised ist fc f (map getTm args') tm

337 env <- get_env

340 env <- get_env

338 if (f `elem` map fst env && length args' == 1)

341 if (f `elem` map fst env && length args' == 1)

@@ -348,11 +351,11 @@ elab ist info pattern tcgen fn tm

348 let isinf = f == inferCon || tcname f

351 let isinf = f == inferCon || tcname f

349 -- if f is a type class, we need to know its arguments so that

352 -- if f is a type class, we need to know its arguments so that

350 -- we can unify with them

353 -- we can unify with them

351− case lookupCtxt Nothing f (idris_classes ist) of

354+ case lookupCtxt f (idris_classes ist) of

352 [] -> return ()

355 [] -> return ()

353 _ -> mapM_ setInjective (map getTm args')

356 _ -> mapM_ setInjective (map getTm args')

354 ctxt <- get_context

357 ctxt <- get_context

355− let guarded = isConName Nothing f ctxt

358+ let guarded = isConName f ctxt

356 ns <- apply (Var f) (map isph args)

359 ns <- apply (Var f) (map isph args)

357 ptm <- get_term

360 ptm <- get_term

358 g <- goal

361 g <- goal

@@ -443,6 +446,8 @@ elab ist info pattern tcgen fn tm

443 (caseBlock fc cname' (reverse args) opts)

446 (caseBlock fc cname' (reverse args) opts)

444 -- fail $ "Not implemented " ++ show c ++ "\n" ++ show args

447 -- fail $ "Not implemented " ++ show c ++ "\n" ++ show args

445 -- elaborate case

448 -- elaborate case

449+ env <- get_env

450+ g <- goal

446 updateAux (newdef : )

451 updateAux (newdef : )

447 -- if we haven't got the type yet, hopefully we'll get it later!

452 -- if we haven't got the type yet, hopefully we'll get it later!

448 movelast tyn

453 movelast tyn

@@ -545,7 +550,7 @@ pruneAlt xs = map prune xs

545pruneByType :: Term -> Context -> [PTerm] -> [PTerm]

550pruneByType :: Term -> Context -> [PTerm] -> [PTerm]

546pruneByType (P _ n _) c as

551pruneByType (P _ n _) c as

547-- if the goal type is polymorphic, keep e

552-- if the goal type is polymorphic, keep e

548− | [] <- lookupTy Nothing n c = as

553+ | [] <- lookupTy n c = as

549 | otherwise

554 | otherwise

550 = let asV = filter (headIs True n) as

555 = let asV = filter (headIs True n) as

551 as' = filter (headIs False n) as in

556 as' = filter (headIs False n) as in

@@ -561,7 +566,7 @@ pruneByType (P _ n _) c as

561 headIs _ _ _ = True -- keep if it's not an application

566 headIs _ _ _ = True -- keep if it's not an application

562

567

563 typeHead var f f'

568 typeHead var f f'

564− = case lookupTy Nothing f' c of

569+ = case lookupTy f' c of

565 [ty] -> let ty' = normalise c [] ty in

570 [ty] -> let ty' = normalise c [] ty in

566 case unApply (getRetTy ty') of

571 case unApply (getRetTy ty') of

567 (P _ ftyn _, _) -> ftyn == f

572 (P _ ftyn _, _) -> ftyn == f

@@ -594,7 +599,7 @@ trivial ist = try' (do elab ist toplevel False False (MN 0 "tac")

594findInstances :: IState -> Term -> [Name]

599findInstances :: IState -> Term -> [Name]

595findInstances ist t

600findInstances ist t

596 | (P _ n _, _) <- unApply t

601 | (P _ n _, _) <- unApply t

597− = case lookupCtxt Nothing n (idris_classes ist) of

602+ = case lookupCtxt n (idris_classes ist) of

598 [CI _ _ _ _ ins] -> ins

603 [CI _ _ _ _ ins] -> ins

599 _ -> []

604 _ -> []

600 | otherwise = []

605 | otherwise = []

@@ -610,9 +615,11 @@ resolveTC depth fn ist

610 if True -- all (\n -> not (n `elem` hs)) (freeNames g)

615 if True -- all (\n -> not (n `elem` hs)) (freeNames g)

611 then try' (trivial ist)

616 then try' (trivial ist)

612 (do t <- goal

617 (do t <- goal

613− let insts = findInstances ist t

614 let (tc, ttypes) = unApply t

618 let (tc, ttypes) = unApply t

615 scopeOnly <- needsDefault t tc ttypes

619 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

616 tm <- get_term

623 tm <- get_term

617-- traceWhen (depth > 6) ("GOAL: " ++ show t ++ "\nTERM: " ++ show tm) $

624-- traceWhen (depth > 6) ("GOAL: " ++ show t ++ "\nTERM: " ++ show tm) $

618-- (tryAll (map elabTC (map fst (ctxtAlist (tt_ctxt ist)))))

625-- (tryAll (map elabTC (map fst (ctxtAlist (tt_ctxt ist)))))

@@ -628,6 +635,12 @@ resolveTC depth fn ist

628 elabTC n | n /= fn && tcname n = (resolve n depth, show n)

635 elabTC n | n /= fn && tcname n = (resolve n depth, show n)

629 | otherwise = (fail "Can't resolve", show n)

636 | otherwise = (fail "Can't resolve", show n)

630

637

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+

631 needsDefault t num@(P _ (NS (UN "Num") ["Builtins"]) _) [P Bound a _]

644 needsDefault t num@(P _ (NS (UN "Num") ["Builtins"]) _) [P Bound a _]

632 = do focus a

645 = do focus a

633 fill (RConstant IType) -- default Int

646 fill (RConstant IType) -- default Int

@@ -656,7 +669,7 @@ resolveTC depth fn ist

656-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist

669-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist

657-- else do

670-- else do

658 -- if there's a hole in the goal, don't even try

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

660 [] -> []

673 [] -> []

661 [args] -> map isImp (snd args) -- won't be overloaded!

674 [args] -> map isImp (snd args) -- won't be overloaded!

662 ps <- get_probs

675 ps <- get_probs

@@ -693,10 +706,12 @@ collectDeferred (App f a) = liftM2 App (collectDeferred f) (collectDeferred a)

693collectDeferred t = return t

706collectDeferred t = return t

694

707

695-- Running tactics directly

708-- Running tactics directly

709+-- if a tactic adds unification problems, return an error

696

710

697runTac :: Bool -> IState -> PTactic -> ElabD ()

711runTac :: Bool -> IState -> PTactic -> ElabD ()

698−runTac autoSolve ist tac = do env <- get_env

712+runTac autoSolve ist tac

713+ = do env <- get_env

699− runT (fmap (addImplBound ist (map fst env)) tac)

714+ no_errors $ runT (fmap (addImplBound ist (map fst env)) tac)

700 where

715 where

701 runT (Intro []) = do g <- goal

716 runT (Intro []) = do g <- goal

702 attack; intro (bname g)

717 attack; intro (bname g)

@@ -714,7 +729,7 @@ runTac autoSolve ist tac = do env <- get_env

714 runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm

729 runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm

715 when autoSolve solveAll

730 when autoSolve solveAll

716 runT (Refine fn [])

731 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

718 [] -> do a <- envArgs fn

733 [] -> do a <- envArgs fn

719 return (fn, a)

734 return (fn, a)

720 -- FIXME: resolve ambiguities

735 -- FIXME: resolve ambiguities

@@ -773,47 +788,38 @@ runTac autoSolve ist tac = do env <- get_env

773 runT Solve = solve

788 runT Solve = solve

774 runT (Try l r) = do try' (runT l) (runT r) True

789 runT (Try l r) = do try' (runT l) (runT r) True

775 runT (TSeq l r) = do runT l; runT r

790 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

791+ runT (ApplyTactic tm) = do tenv <- get_env -- store the environment

792+ tgoal <- goal -- store the goal

777− attack -- let f : List (TTName, Binder TT) -> Tactic = tm in ...

793+ attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...

778− valn <- unique_hole (MN 0 "tacval")

794+ script <- unique_hole (MN 0 "script")

779− claim valn (RBind (UN "__pi_arg")

795+ claim script scriptTy

780− (Pi (RApp listTy envTupleType)) tacticTy)

781− tacn <- unique_hole (MN 0 "tacn")

796+ scriptvar <- unique_hole (MN 0 "scriptvar" )

782− letbind tacn (RBind (UN "__pi_arg")

797+ letbind scriptvar scriptTy (Var script)

783− (Pi (RApp listTy envTupleType)) tacticTy)

784− (Var valn)

785− focus valn

798+ focus script

786 elab ist toplevel False False (MN 0 "tac") tm

799 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+ (script', _) <- get_type_val (Var scriptvar)

800− ctxt <- get_context

801+ -- now that we have the script apply

801− env <- get_env

802+ -- it to the reflected goal and context

802− let env'' = normalise ctxt env env'

803− attack -- let z : Tactic = f x

804− restac <- unique_hole (MN 0 "letval")

803+ restac <- unique_hole (MN 0 "restac")

805 claim restac tacticTy

804 claim restac tacticTy

806− letn <- unique_hole (MN 0 "letvar")

807− letbind letn tacticTy (Var restac)

808 focus restac

805 focus restac

809− elab ist toplevel False False (MN 0 "tac") (PQuote (RApp (forget tm'') (forget env'')))

806+ fill (raw_apply (forget script')

810− (res, _) <- get_type_val (Var letn)

807+ [reflectEnv tenv, reflect tgoal])

808+ restac' <- get_guess

809+ solve

810+ -- normalise the result in order to

811+ -- reify it

811 ctxt <- get_context

812 ctxt <- get_context

812 env <- get_env

813 env <- get_env

813− let tactic = normalise ctxt env res

814+ let tactic = normalise ctxt env restac'

814 runReflected tactic

815 runReflected tactic

815 where tacticTy = Var (reflm "Tactic")

816 where tacticTy = Var (reflm "Tactic")

816 listTy = Var (NS (UN "List") ["List", "Prelude"])

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

817 runT (Reflect v) = do attack -- let x = reflect v in ...

823 runT (Reflect v) = do attack -- let x = reflect v in ...

818 tyn <- unique_hole (MN 0 "letty")

824 tyn <- unique_hole (MN 0 "letty")

819 claim tyn RType

825 claim tyn RType

@@ -1207,7 +1213,7 @@ solveAll = try (do solve; solveAll) (return ())

1207mkSpecialised :: IState -> FC -> Name -> [PTerm] -> PTerm -> ElabD PTerm

1213mkSpecialised :: IState -> FC -> Name -> [PTerm] -> PTerm -> ElabD PTerm

1208mkSpecialised i fc n args def

1214mkSpecialised i fc n args def

1209 = do let tm' = def

1215 = do let tm' = def

1210− case lookupCtxt Nothing n (idris_statics i) of

1216+ case lookupCtxt n (idris_statics i) of

1211 [] -> return tm'

1217 [] -> return tm'

1212 [as] -> if (not (or as)) then return tm' else

1218 [as] -> if (not (or as)) then return tm' else

1213 mkSpecDecl i n (zip args as) tm'

1219 mkSpecDecl i n (zip args as) tm'

@@ -1234,8 +1240,8 @@ mkSpecDecl i n pargs tm'

1234 cg = idris_callgraph i

1240 cg = idris_callgraph i

1235

1241

1236 staticFnNames tm | (P _ f _, as) <- unApply tm

1242 staticFnNames tm | (P _ f _, as) <- unApply tm

1237− = if not (isFnName Nothing f ctxt) then []

1243+ = if not (isFnName f ctxt) then []

1238− else case lookupCtxt Nothing f cg of

1244+ else case lookupCtxt f cg of

1239 [ns] -> f : f : [] --(ns \\ [f])

1245 [ns] -> f : f : [] --(ns \\ [f])

1240 [] -> [f,f]

1246 [] -> [f,f]

1241 _ -> []

1247 _ -> []

src/Idris/Error.hs+1−1

@@ -45,7 +45,7 @@ instance Exception IdrisErr

45ifail :: String -> Idris ()

46ifail str = throwIO (IErr str)

47

48−ierror :: Err -> Idris ()

48+ierror :: Err -> Idris a

49ierror err = do i <- getIState

50 throwIO (IErr $ pshow i err)

51

src/Idris/Help.hs+1

@@ -28,6 +28,7 @@ help =

28 ([":total"], NameArg, "Check the totality of a name"),

29 ([":r",":reload"], NoArg, "Reload current file"),

30 ([":l",":load"], FileArg, "Load a new file"),

31+ ([":cd"], FileArg, "Change working directory"),

31 ([":m",":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons

32 ([":m",":module"], ModuleArg, "Import an extra module"), -- NOTE: dragons

32 ([":e",":edit"], NoArg, "Edit current file using $EDITOR or $VISUAL"),

33 ([":e",":edit"], NoArg, "Edit current file using $EDITOR or $VISUAL"),

33 ([":m",":metavars"], MetaVarArg, "Show remaining proof obligations (metavariables)"),

34 ([":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)

18import System.FilePath

19import System.Directory

20

21+import Debug.Trace

22+

21import Paths_idris

23import Paths_idris

22

24

23ibcVersion :: Word8

25ibcVersion :: Word8

24−ibcVersion = 28

26+ibcVersion = 29

25

27

26data IBCFile = IBCFile { ver :: Word8,

28data IBCFile = IBCFile { ver :: Word8,

27 sourcefile :: FilePath,

29 sourcefile :: FilePath,

@@ -48,6 +50,7 @@ data IBCFile = IBCFile { ver :: Word8,

48 ibc_docstrings :: [(Name, String)],

50 ibc_docstrings :: [(Name, String)],

49 ibc_coercions :: [Name]

51 ibc_coercions :: [Name]

50 }

52 }

53+ deriving Show

51{-!

54{-!

52deriving instance Binary IBCFile

55deriving instance Binary IBCFile

53!-}

56!-}

@@ -82,28 +85,28 @@ mkIBC (i:is) f = do ist <- getIState

82 mkIBC is f'

85 mkIBC is f'

83

86

84ibc i (IBCFix d) f = return f { ibc_fixes = d : ibc_fixes f }

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

86 [v] -> return f { ibc_implicits = (n,v): ibc_implicits f }

89 [v] -> return f { ibc_implicits = (n,v): ibc_implicits f }

87 _ -> fail "IBC write failed"

90 _ -> fail "IBC write failed"

88ibc i (IBCStatic n) f

91ibc i (IBCStatic n) f

89− = case lookupCtxt Nothing n (idris_statics i) of

92+ = case lookupCtxt n (idris_statics i) of

90 [v] -> return f { ibc_statics = (n,v): ibc_statics f }

93 [v] -> return f { ibc_statics = (n,v): ibc_statics f }

91 _ -> fail "IBC write failed"

94 _ -> fail "IBC write failed"

92ibc i (IBCClass n) f

95ibc i (IBCClass n) f

93− = case lookupCtxt Nothing n (idris_classes i) of

96+ = case lookupCtxt n (idris_classes i) of

94 [v] -> return f { ibc_classes = (n,v): ibc_classes f }

97 [v] -> return f { ibc_classes = (n,v): ibc_classes f }

95 _ -> fail "IBC write failed"

98 _ -> fail "IBC write failed"

96ibc i (IBCInstance int n ins) f

99ibc i (IBCInstance int n ins) f

97 = return f { ibc_instances = (int,n,ins): ibc_instances f }

100 = return f { ibc_instances = (int,n,ins): ibc_instances f }

98ibc i (IBCDSL n) f

101ibc i (IBCDSL n) f

99− = case lookupCtxt Nothing n (idris_dsls i) of

102+ = case lookupCtxt n (idris_dsls i) of

100 [v] -> return f { ibc_dsls = (n,v): ibc_dsls f }

103 [v] -> return f { ibc_dsls = (n,v): ibc_dsls f }

101 _ -> fail "IBC write failed"

104 _ -> fail "IBC write failed"

102ibc i (IBCData n) f

105ibc i (IBCData n) f

103− = case lookupCtxt Nothing n (idris_datatypes i) of

106+ = case lookupCtxt n (idris_datatypes i) of

104 [v] -> return f { ibc_datatypes = (n,v): ibc_datatypes f }

107 [v] -> return f { ibc_datatypes = (n,v): ibc_datatypes f }

105 _ -> fail "IBC write failed"

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

107 [v] -> return f { ibc_optimise = (n,v): ibc_optimise f }

110 [v] -> return f { ibc_optimise = (n,v): ibc_optimise f }

108 _ -> fail "IBC write failed"

111 _ -> fail "IBC write failed"

109ibc i (IBCSyntax n) f = return f { ibc_syntax = n : ibc_syntax f }

112ibc 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 }

113ibc i (IBCLib n) f = return f { ibc_libs = n : ibc_libs f }

116ibc i (IBCLib n) f = return f { ibc_libs = n : ibc_libs f }

114ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

117ibc i (IBCDyLib n) f = return f {ibc_dynamic_libs = n : ibc_dynamic_libs f }

115ibc i (IBCHeader n) f = return f { ibc_hdrs = n : ibc_hdrs f }

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

117 [v] -> return f { ibc_defs = (n,v) : ibc_defs f }

120 [v] -> return f { ibc_defs = (n,v) : ibc_defs f }

118 _ -> fail "IBC write failed"

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

120 [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }

123 [v] -> return f { ibc_docstrings = (n,v) : ibc_docstrings f }

121 _ -> fail "IBC write failed"

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

123 [v] -> return f { ibc_cg = (n,v) : ibc_cg f }

126 [v] -> return f { ibc_cg = (n,v) : ibc_cg f }

124 _ -> fail "IBC write failed"

127 _ -> fail "IBC write failed"

125ibc i (IBCCoercion n) f = return f { ibc_coercions = n : ibc_coercions f }

128ibc i (IBCCoercion n) f = return f { ibc_coercions = n : ibc_coercions f }

@@ -246,7 +249,11 @@ pLibs :: [String] -> Idris ()

246pLibs ls = mapM_ addLib ls

249pLibs ls = mapM_ addLib ls

247

250

248pDyLibs :: [String] -> Idris ()

251pDyLibs :: [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

250

257

251pHdrs :: [String] -> Idris ()

258pHdrs :: [String] -> Idris ()

252pHdrs hs = mapM_ addHdr hs

259pHdrs hs = mapM_ addHdr hs

@@ -327,16 +334,21 @@ instance Binary FC where

327

334

328instance Binary Name where

335instance Binary Name where

329 put x

336 put x

337+ = {-# SCC "putName" #-}

330− = case x of

338+ case x of

339+ UN x1 -> {-# SCC "putUN" #-}

331− UN x1 -> do putWord8 0

340+ do putWord8 0

332− put x1

341+ {-# SCC "putNString" #-} put x1

342+ NS x1 x2 -> {-# SCC "putNS" #-}

333− NS x1 x2 -> do putWord8 1

343+ do putWord8 1

334 put x1

344 put x1

335 put x2

345 put x2

346+ MN x1 x2 -> {-# SCC "putMN" #-}

336− MN x1 x2 -> do putWord8 2

347+ do putWord8 2

337 put x1

348 put x1

338 put x2

349 put x2

350+ NErased -> {-# SCC "putNErased" #-}

339− NErased -> putWord8 3

351+ putWord8 3

340 get

352 get

341 = do i <- getWord8

353 = do i <- getWord8

342 case i of

354 case i of

@@ -528,9 +540,10 @@ instance Binary NameType where

528 _ -> error "Corrupted binary data for NameType"

540 _ -> error "Corrupted binary data for NameType"

529

541

530

542

531−instance (Binary n) => Binary (TT n) where

543+instance {-(Binary n) =>-} Binary (TT Name) where

532 put x

544 put x

545+ = {-# SCC "putTT" #-}

533− = case x of

546+ case x of

534 P x1 x2 x3 -> do putWord8 0

547 P x1 x2 x3 -> do putWord8 0

535 put x1

548 put x1

536 put x2

549 put x2

@@ -613,7 +626,8 @@ instance Binary SC where

613

626

614instance Binary CaseAlt where

627instance Binary CaseAlt where

615 put x

628 put x

629+ = {-# SCC "putCaseAlt" #-}

616− = case x of

630+ case x of

617 ConCase x1 x2 x3 x4 -> do putWord8 0

631 ConCase x1 x2 x3 x4 -> do putWord8 0

618 put x1

632 put x1

619 put x2

633 put x2

@@ -642,17 +656,16 @@ instance Binary CaseAlt where

642

656

643instance Binary Def where

657instance Binary Def where

644 put x

658 put x

659+ = {-# SCC "putDef" #-}

645− = case x of

660+ case x of

646 Function x1 x2 -> do putWord8 0

661 Function x1 x2 -> do putWord8 0

647 put x1

662 put x1

648 put x2

663 put x2

649 TyDecl x1 x2 -> do putWord8 1

664 TyDecl x1 x2 -> do putWord8 1

650 put x1

665 put x1

651 put x2

666 put x2

667+ -- all primitives just get added at the start, don't write

652− Operator x1 x2 x3 -> do putWord8 2

668+ Operator x1 x2 x3 -> do return ()

653− put x1

654− put x2

655− put x3

656 CaseOp x1 x2 x3 x3a x4 x5 x6 x7 x8 ->

669 CaseOp x1 x2 x3 x3a x4 x5 x6 x7 x8 ->

657 do putWord8 3

670 do putWord8 3

658 put x1

671 put x1

@@ -750,8 +763,9 @@ instance Binary Totality where

750 _ -> error "Corrupted binary data for Totality"

763 _ -> error "Corrupted binary data for Totality"

751

764

752instance Binary IBCFile where

765instance 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)

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" #-}

754− = do put x1

768+ do put x1

755 put x2

769 put x2

756 put x3

770 put x3

757 put x4

771 put x4

@@ -1082,6 +1096,15 @@ instance (Binary t) => Binary (PDecl' t) where

1082 return (PPostulate x1 x2 x3 x4 x5 x6)

1096 return (PPostulate x1 x2 x3 x4 x5 x6)

1083 _ -> error "Corrupted binary data for PDecl'"

1097 _ -> error "Corrupted binary data for PDecl'"

1084

1098

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+

1085instance Binary SyntaxInfo where

1108instance Binary SyntaxInfo where

1086 put (Syn x1 x2 x3 x4 x5 x6 x7 x8)

1109 put (Syn x1 x2 x3 x4 x5 x6 x7 x8)

1087 = do put x1

1110 = 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 #-}

2-- | Parse the full Idris language.

3module Idris.Parser where

4

@@ -30,6 +30,7 @@ import qualified Text.Parsec.Token as PTok

30import Data.List

31import Data.List.Split(splitOn)

32import Control.Monad.State

33+import Control.Monad.Error

33import Debug.Trace

34import Debug.Trace

34import Data.Maybe

35import Data.Maybe

35import System.FilePath

36import System.FilePath

@@ -273,7 +274,7 @@ pfc = do s <- getPosition

273pImport :: IParser String

274pImport :: IParser String

274pImport = do reserved "import"; f <- identifier; option ';' (lchar ';')

275pImport = do reserved "import"; f <- identifier; option ';' (lchar ';')

275 return (toPath f)

276 return (toPath f)

276− where toPath n = foldl1 (</>) $ splitOn "." n

277+ where toPath n = foldl1' (</>) $ splitOn "." n

277

278

278-- | A program is a list of declarations, possibly with associated

279-- | A program is a list of declarations, possibly with associated

279-- documentation strings.

280-- documentation strings.

@@ -470,7 +471,7 @@ pPostulate syn = do doc <- option "" (pDocComment '|')

470

471

471pUsing :: SyntaxInfo -> IParser [PDecl]

472pUsing :: SyntaxInfo -> IParser [PDecl]

472pUsing syn =

473pUsing syn =

473− do reserved "using"; lchar '('; ns <- tyDeclList syn; lchar ')'

474+ do reserved "using"; lchar '('; ns <- usingDeclList syn; lchar ')'

474 openBlock

475 openBlock

475 let uvars = using syn

476 let uvars = using syn

476 ds <- many1 (pDecl (syn { using = uvars ++ ns }))

477 ds <- many1 (pDecl (syn { using = uvars ++ ns }))

@@ -613,7 +614,6 @@ pNoExtExpr syn =

613 <|> pRewriteTerm syn

614 <|> pRewriteTerm syn

614 <|> pPi syn

615 <|> pPi syn

615 <|> pDoBlock syn

616 <|> pDoBlock syn

616− <|> pComprehension syn

617

618pExtensions :: SyntaxInfo -> [Syntax] -> IParser PTerm

619pExtensions syn rules = choice (map (try . pExt syn) (filter valid rules))

@@ -763,6 +763,7 @@ pSimpleExpr syn =

763 fc <- pfc

764 return (PInferRef fc x))

765 <|> try (pList syn)

766+ <|> try (pComprehension syn)

766 <|> try (pAlt syn)

767 <|> try (pAlt syn)

767 <|> try (pIdiom syn)

768 <|> try (pIdiom syn)

768 <|> try (do lchar '('

769 <|> try (do lchar '('

@@ -800,16 +801,30 @@ pCaseOpt syn = do lhs <- pExpr (syn { inPattern = True })

800 symbol "=>"; rhs <- pExpr syn

801 symbol "=>"; rhs <- pExpr syn

801 return (lhs, rhs)

802 return (lhs, rhs)

802

803

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+

803modifyConst :: SyntaxInfo -> FC -> PTerm -> PTerm

809modifyConst :: 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)))]]

805 | not (inPattern syn)

815 | not (inPattern syn)

806 = PAlternative False

816 = PAlternative False

807− [PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I x))],

817+ [PApp fc (PRef fc (UN "fromInteger")) [pexp (PConstant (I (fromInteger x)))],

808− PConstant (I x), PConstant (BI (toEnum x))]

818+ PConstant (I (fromInteger x)), PConstant (BI x)]

809 | otherwise = PAlternative False

819 | otherwise = PAlternative False

810− [PConstant (I x), PConstant (BI (toEnum x))]

820+ [PConstant (I (fromInteger x)), PConstant (BI x)]

811modifyConst syn fc x = x

821modifyConst syn fc x = x

812

822

823+fitsInt :: Integer -> Bool

824+fitsInt x = let xInt :: Int = fromInteger x

825+ xInteger :: Integer = toInteger xInt in

826+ x == xInteger

827+

813pList syn = do lchar '['; fc <- pfc; xs <- sepBy (pExpr syn) (lchar ','); lchar ']'

828pList syn = do lchar '['; fc <- pfc; xs <- sepBy (pExpr syn) (lchar ','); lchar ']'

814 return (mkList fc xs)

829 return (mkList fc xs)

815 where

830 where

@@ -867,7 +882,7 @@ pApp syn = do f <- pSimpleExpr syn

867 return (dslify i $ PApp fc f args)

882 return (dslify i $ PApp fc f args)

868 where

883 where

869 dslify i (PApp fc (PRef _ f) [a])

884 dslify i (PApp fc (PRef _ f) [a])

870− | [d] <- lookupCtxt Nothing f (idris_dsls i)

885+ | [d] <- lookupCtxt f (idris_dsls i)

871 = desugar (syn { dsl_info = d }) i (getTm a)

886 = desugar (syn { dsl_info = d }) i (getTm a)

872 dslify i t = t

887 dslify i t = t

873

888

@@ -961,7 +976,9 @@ pLet syn = try (do reserved "let"; n <- pName;

961 return (PCase fc v [(pat, sc)]))

976 return (PCase fc v [(pat, sc)]))

962

977

963pPi syn =

978pPi syn =

979+ try (do lazy <- if implicitAllowed syn -- laziness is top level only

964− try (do lazy <- option False (do lchar '|'; return True)

980+ then option False (do lchar '|'; return True)

981+ else return False

965 st <- pStatic

982 st <- pStatic

966 lchar '('; xt <- tyDeclList syn; lchar ')'

983 lchar '('; xt <- tyDeclList syn; lchar ')'

967 doc <- option "" (pDocComment '^')

984 doc <- option "" (pDocComment '^')

@@ -1015,6 +1032,19 @@ pConstList syn = try (do lchar '('

1015 return [t])

1032 return [t])

1016 <|> return []

1033 <|> return []

1017

1034

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+

1018tyDeclList syn = try (sepBy1 (do x <- pfName

1048tyDeclList syn = try (sepBy1 (do x <- pfName

1019 t <- pTSig (noImp syn)

1049 t <- pTSig (noImp syn)

1020 return (x,t))

1050 return (x,t))

@@ -1106,8 +1136,7 @@ pConstant = do reserved "Integer";return BIType

1106 <|> do reserved "Bits32"; return B32Type

1136 <|> do reserved "Bits32"; return B32Type

1107 <|> do reserved "Bits64"; return B64Type

1137 <|> do reserved "Bits64"; return B64Type

1108 <|> try (do f <- float; return $ Fl f)

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

1111 <|> try (do s <- strlit; return $ Str s)

1140 <|> try (do s <- strlit; return $ Str s)

1112 <|> try (do c <- chlit; return $ Ch c)

1141 <|> try (do c <- chlit; return $ Ch c)

1113

1142

@@ -1348,7 +1377,8 @@ pClause syn

1348 cargs <- many (pConstraintArg syn)

1377 cargs <- many (pConstraintArg syn)

1349 iargs <- many (pImplicitArg (syn { inPattern = True } ))

1378 iargs <- many (pImplicitArg (syn { inPattern = True } ))

1350 fc <- pfc

1379 fc <- pfc

1380+ args <- many (try (pImplicitArg (syn { inPattern = True } ))

1351− args <- many (pArgExpr syn)

1381+ <|> (fmap pexp (pArgExpr syn)))

1352 wargs <- many (pWExpr syn)

1382 wargs <- many (pWExpr syn)

1353 rhs <- pRHS syn n

1383 rhs <- pRHS syn n

1354 ist <- getState

1384 ist <- getState

@@ -1360,7 +1390,7 @@ pClause syn

1360 do pTerminator

1390 do pTerminator

1361 return ([], [])]

1391 return ([], [])]

1362 let capp = PApp fc (PRef fc n)

1392 let capp = PApp fc (PRef fc n)

1363− (iargs ++ cargs ++ map pexp args)

1393+ (iargs ++ cargs ++ args)

1364 ist <- getState

1394 ist <- getState

1365 setState (ist { lastParse = Just n })

1395 setState (ist { lastParse = Just n })

1366 return $ PClause fc n capp wargs rhs wheres)

1396 return $ PClause fc n capp wargs rhs wheres)

@@ -1386,10 +1416,11 @@ pClause syn

1386 cargs <- many (pConstraintArg syn)

1416 cargs <- many (pConstraintArg syn)

1387 iargs <- many (pImplicitArg (syn { inPattern = True } ))

1417 iargs <- many (pImplicitArg (syn { inPattern = True } ))

1388 fc <- pfc

1418 fc <- pfc

1419+ args <- many (try (pImplicitArg (syn { inPattern = True } ))

1389− args <- many (pArgExpr syn)

1420+ <|> (fmap pexp (pArgExpr syn)))

1390 wargs <- many (pWExpr syn)

1421 wargs <- many (pWExpr syn)

1391 let capp = PApp fc (PRef fc n)

1422 let capp = PApp fc (PRef fc n)

1392− (iargs ++ cargs ++ map pexp args)

1423+ (iargs ++ cargs ++ args)

1393 ist <- getState

1424 ist <- getState

1394 setState (ist { lastParse = Just n })

1425 setState (ist { lastParse = Just n })

1395 reserved "with"

1426 reserved "with"

@@ -1497,9 +1528,12 @@ pDirective syn = try (do lchar '%'; reserved "lib"; lib <- strlit;

1497 putIState (i { default_total = tot }))])

1528 putIState (i { default_total = tot }))])

1498 <|> try (do lchar '%'; reserved "logging"; i <- natural;

1529 <|> try (do lchar '%'; reserved "logging"; i <- natural;

1499 return [PDirective (setLogLevel (fromInteger i))])

1530 return [PDirective (setLogLevel (fromInteger i))])

1500− <|> try (do lchar '%'; reserved "dynamic"; lib <- strlit;

1531+ <|> try (do lchar '%'; reserved "dynamic"; libs <- sepBy1 strlit (lchar ',');

1501− return [PDirective (do addIBC (IBCDyLib lib)

1532+ return [PDirective (do added <- addDyLib libs

1502− addDyLib lib)])

1533+ case added of

1534+ Left lib -> addIBC (IBCDyLib (lib_name lib))

1535+ Right msg ->

1536+ fail $ msg)])

1503 <|> try (do lchar '%'; reserved "language"; ext <- reserved "TypeProviders";

1537 <|> try (do lchar '%'; reserved "language"; ext <- reserved "TypeProviders";

1504 return [PDirective (addLangExt TypeProviders)])

1538 return [PDirective (addLangExt TypeProviders)])

1505

1539

src/Idris/Primitives.hs+225−445

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

1−{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

1+{-# LANGUAGE RankNTypes, ScopedTypeVariables, PatternGuards #-}

2

3module Idris.Primitives(elabPrims) where

4

@@ -34,280 +34,73 @@ partial = Partial NotCovering

34

35primitives =

36 -- 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 (==))

37+ [Prim (UN "prim__eqChar") (ty [ChType, ChType] IType) 2 (bcBin (==))

70− (2, LEq) total,

38+ (2, LEq ITNative) total,

71 Prim (UN "prim__ltChar") (ty [ChType, ChType] IType) 2 (bcBin (<))

39 Prim (UN "prim__ltChar") (ty [ChType, ChType] IType) 2 (bcBin (<))

72− (2, LLt) total,

40+ (2, LLt ITNative) total,

73 Prim (UN "prim__lteChar") (ty [ChType, ChType] IType) 2 (bcBin (<=))

41 Prim (UN "prim__lteChar") (ty [ChType, ChType] IType) 2 (bcBin (<=))

74− (2, LLe) total,

42+ (2, LLe ITNative) total,

75 Prim (UN "prim__gtChar") (ty [ChType, ChType] IType) 2 (bcBin (>))

43 Prim (UN "prim__gtChar") (ty [ChType, ChType] IType) 2 (bcBin (>))

76− (2, LGt) total,

44+ (2, LGt ITNative) total,

77 Prim (UN "prim__gteChar") (ty [ChType, ChType] IType) 2 (bcBin (>=))

45 Prim (UN "prim__gteChar") (ty [ChType, ChType] IType) 2 (bcBin (>=))

78− (2, LGe) total,

46+ (2, LGe ITNative) total,

79−

47+

80− Prim (UN "prim__ltB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (<))

48+ iCoerce IT8 IT16 "zext" zext LZExt,

81− (2, LB8Lt) total,

49+ iCoerce IT8 IT32 "zext" zext LZExt,

82− Prim (UN "prim__lteB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (<=))

50+ iCoerce IT8 IT64 "zext" zext LZExt,

83− (2, LB8Lte) total,

51+ iCoerce IT8 ITBig "zext" zext LZExt,

84− Prim (UN "prim__eqB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (==))

52+ iCoerce IT8 ITNative "zext" zext LZExt,

85− (2, LB8Eq) total,

53+ iCoerce IT16 IT32 "zext" zext LZExt,

86− Prim (UN "prim__gteB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (>))

54+ iCoerce IT16 IT64 "zext" zext LZExt,

87− (2, LB8Gte) total,

55+ iCoerce IT16 ITBig "zext" zext LZExt,

88− Prim (UN "prim__gtB8") (ty [B8Type, B8Type] IType) 2 (b8Cmp (>=))

56+ iCoerce IT16 ITNative "zext" zext LZExt,

89− (2, LB8Gt) total,

57+ iCoerce IT32 IT64 "zext" zext LZExt,

90− Prim (UN "prim__addB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (+))

58+ iCoerce IT32 ITBig "zext" zext LZExt,

91− (2, LB8Plus) total,

59+ iCoerce IT32 ITNative "zext" zext LZExt,

92− Prim (UN "prim__subB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (-))

60+ iCoerce IT64 ITBig "zext" zext LZExt,

93− (2, LB8Minus) total,

61+ iCoerce ITNative ITBig "zext" zext LZExt,

94− Prim (UN "prim__mulB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (*))

62+ iCoerce ITNative IT64 "zext" zext LZExt,

95− (2, LB8Times) total,

63+ iCoerce ITNative IT32 "zext" zext LZExt,

96− Prim (UN "prim__udivB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin div)

64+ iCoerce ITNative IT16 "zext" zext LZExt,

97− (2, LB8UDiv) partial,

65+

98− Prim (UN "prim__sdivB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin s8div)

66+ iCoerce IT8 IT16 "sext" sext LSExt,

99− (2, LB8SDiv) partial,

67+ iCoerce IT8 IT32 "sext" sext LSExt,

100− Prim (UN "prim__uremB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin rem)

68+ iCoerce IT8 IT64 "sext" sext LSExt,

101− (2, LB8URem) partial,

69+ iCoerce IT8 ITBig "sext" sext LSExt,

102− Prim (UN "prim__sremB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin s8rem)

70+ iCoerce IT8 ITNative "sext" sext LSExt,

103− (2, LB8SRem) partial,

71+ iCoerce IT16 IT32 "sext" sext LSExt,

104− Prim (UN "prim__shlB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (\x y -> shiftL x (fromIntegral y)))

72+ iCoerce IT16 IT64 "sext" sext LSExt,

105− (2, LB8Shl) total,

73+ iCoerce IT16 ITBig "sext" sext LSExt,

106− Prim (UN "prim__lshrB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (\x y -> shiftR x (fromIntegral y)))

74+ iCoerce IT16 ITNative "sext" sext LSExt,

107− (2, LB8AShr) total,

75+ iCoerce IT32 IT64 "sext" sext LSExt,

108− Prim (UN "prim__ashrB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (\x y -> fromIntegral $

76+ iCoerce IT32 ITBig "sext" sext LSExt,

109− shiftR (fromIntegral x :: Int8)

77+ iCoerce IT32 ITNative "sext" sext LSExt,

110− (fromIntegral y)))

78+ iCoerce IT64 ITBig "sext" sext LSExt,

111− (2, LB8LShr) total,

79+ iCoerce ITNative ITBig "sext" sext LSExt,

112− Prim (UN "prim__andB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (.&.))

80+ iCoerce ITNative ITBig "sext" sext LSExt,

113− (2, LB8And) total,

81+ iCoerce ITNative IT64 "sext" sext LSExt,

114− Prim (UN "prim__orB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin (.|.))

82+ iCoerce ITNative IT32 "sext" sext LSExt,

115− (2, LB8Or) total,

83+ iCoerce ITNative IT16 "sext" sext LSExt,

116− Prim (UN "prim__xorB8") (ty [B8Type, B8Type] B8Type) 2 (b8Bin xor)

84+

117− (2, LB8Xor) total,

85+ iCoerce IT16 IT8 "trunc" trunc LTrunc,

118− Prim (UN "prim__complB8") (ty [B8Type] B8Type) 1 (b8Un complement)

86+ iCoerce IT32 IT8 "trunc" trunc LTrunc,

119− (1, LB8Compl) total,

87+ iCoerce IT64 IT8 "trunc" trunc LTrunc,

120− Prim (UN "prim__zextB8_16") (ty [B8Type] B16Type) 1 zext8_16

88+ iCoerce ITBig IT8 "trunc" trunc LTrunc,

121− (1, LB8Z16) total,

89+ iCoerce ITNative IT8 "trunc" trunc LTrunc,

122− Prim (UN "prim__zextB8_32") (ty [B8Type] B32Type) 1 zext8_32

90+ iCoerce IT32 IT16 "trunc" trunc LTrunc,

123− (1, LB8Z32) total,

91+ iCoerce IT64 IT16 "trunc" trunc LTrunc,

124− Prim (UN "prim__zextB8_64") (ty [B8Type] B64Type) 1 zext8_64

92+ iCoerce ITBig IT16 "trunc" trunc LTrunc,

125− (1, LB8Z64) total,

93+ iCoerce ITNative IT16 "trunc" trunc LTrunc,

126− Prim (UN "prim__sextB8_16") (ty [B8Type] B16Type) 1 sext8_16

94+ iCoerce IT64 IT32 "trunc" trunc LTrunc,

127− (1, LB8Z16) total,

95+ iCoerce ITBig IT32 "trunc" trunc LTrunc,

128− Prim (UN "prim__sextB8_32") (ty [B8Type] B32Type) 1 sext8_32

96+ iCoerce ITNative IT32 "trunc" trunc LTrunc,

129− (1, LB8Z32) total,

97+ iCoerce ITBig IT64 "trunc" trunc LTrunc,

130− Prim (UN "prim__sextB8_64") (ty [B8Type] B64Type) 1 sext8_64

98+ iCoerce IT16 ITNative "trunc" trunc LTrunc,

131− (1, LB8Z64) total,

99+ iCoerce IT32 ITNative "trunc" trunc LTrunc,

132−

100+ iCoerce IT64 ITNative "trunc" trunc LTrunc,

133− Prim (UN "prim__ltB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (<))

101+ iCoerce ITBig ITNative "trunc" trunc LTrunc,

134− (2, LB16Lt) total,

102+ iCoerce ITNative IT64 "trunc" trunc LTrunc,

135− Prim (UN "prim__lteB16") (ty [B16Type, B16Type] IType) 2 (b16Cmp (<=))

103+

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,

311 Prim (UN "prim__addFloat") (ty [FlType, FlType] FlType) 2 (fBin (+))

104 Prim (UN "prim__addFloat") (ty [FlType, FlType] FlType) 2 (fBin (+))

312 (2, LFPlus) total,

105 (2, LFPlus) total,

313 Prim (UN "prim__subFloat") (ty [FlType, FlType] FlType) 2 (fBin (-))

106 Prim (UN "prim__subFloat") (ty [FlType, FlType] FlType) 2 (fBin (-))

@@ -335,30 +128,14 @@ primitives =

335 Prim (UN "prim_lenString") (ty [StrType] IType) 1 (p_strLen)

128 Prim (UN "prim_lenString") (ty [StrType] IType) 1 (p_strLen)

336 (1, LStrLen) total,

129 (1, LStrLen) total,

337 -- Conversions

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

342 Prim (UN "prim__charToInt") (ty [ChType] IType) 1 (c_charToInt)

131 Prim (UN "prim__charToInt") (ty [ChType] IType) 1 (c_charToInt)

343− (1, LChInt) total,

132+ (1, LChInt ITNative) total,

344 Prim (UN "prim__intToChar") (ty [IType] ChType) 1 (c_intToChar)

133 Prim (UN "prim__intToChar") (ty [IType] ChType) 1 (c_intToChar)

345− (1, LIntCh) total,

134+ (1, LIntCh ITNative) 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,

354 Prim (UN "prim__strToFloat") (ty [StrType] FlType) 1 (c_strToFloat)

135 Prim (UN "prim__strToFloat") (ty [StrType] FlType) 1 (c_strToFloat)

355 (1, LStrFloat) total,

136 (1, LStrFloat) total,

356 Prim (UN "prim__floatToStr") (ty [FlType] StrType) 1 (c_floatToStr)

137 Prim (UN "prim__floatToStr") (ty [FlType] StrType) 1 (c_floatToStr)

357 (1, LFloatStr) total,

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

362

139

363 Prim (UN "prim__floatExp") (ty [FlType] FlType) 1 (p_floatExp)

140 Prim (UN "prim__floatExp") (ty [FlType] FlType) 1 (p_floatExp)

364 (1, LFExp) total,

141 (1, LFExp) total,

@@ -402,7 +179,49 @@ primitives =

402 (0, LStdIn) partial,

179 (0, LStdIn) partial,

403 Prim (UN "prim__believe_me") believeTy 3 (p_believeMe)

180 Prim (UN "prim__believe_me") believeTy 3 (p_believeMe)

404 (3, LNoOp) partial -- ahem

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

406

225

407p_believeMe [_,_,x] = Just x

226p_believeMe [_,_,x] = Just x

408p_believeMe _ = Nothing

227p_believeMe _ = Nothing

@@ -441,161 +260,127 @@ bsBin _ _ = Nothing

441sBin op [VConstant (Str x), VConstant (Str y)] = Just $ VConstant (Str (op x y))

260sBin op [VConstant (Str x), VConstant (Str y)] = Just $ VConstant (Str (op x y))

442sBin _ _ = Nothing

261sBin _ _ = Nothing

443

262

444−s8div :: Word8 -> Word8 -> Word8

263+bsrem IT8 [VConstant (B8 x), VConstant (B8 y)]

445−s8div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int8)

264+ = Just $ VConstant (B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8)))

446−

265+bsrem IT16 [VConstant (B16 x), VConstant (B16 y)]

447−s16div :: Word16 -> Word16 -> Word16

266+ = Just $ VConstant (B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16)))

448−s16div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int16)

267+bsrem IT32 [VConstant (B32 x), VConstant (B32 y)]

449−

268+ = Just $ VConstant (B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32)))

450−s32div :: Word32 -> Word32 -> Word32

269+bsrem IT64 [VConstant (B64 x), VConstant (B64 y)]

451−s32div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int32)

270+ = Just $ VConstant (B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64)))

452−

271+bsrem ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `rem` y))

453−s64div :: Word64 -> Word64 -> Word64

272+bsrem _ _ = Nothing

454−s64div x y = fromIntegral (fromIntegral x `div` fromIntegral y :: Int64)

273+

455−

274+bsdiv IT8 [VConstant (B8 x), VConstant (B8 y)]

456−s8rem :: Word8 -> Word8 -> Word8

275+ = Just $ VConstant (B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8)))

457−s8rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8)

276+bsdiv IT16 [VConstant (B16 x), VConstant (B16 y)]

458−

277+ = Just $ VConstant (B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16)))

459−s16rem :: Word16 -> Word16 -> Word16

278+bsdiv IT32 [VConstant (B32 x), VConstant (B32 y)]

460−s16rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16)

279+ = Just $ VConstant (B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32)))

461−

280+bsdiv IT64 [VConstant (B64 x), VConstant (B64 y)]

462−s32rem :: Word32 -> Word32 -> Word32

281+ = Just $ VConstant (B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64)))

463−s32rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32)

282+bsdiv ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `div` y))

464−

283+bsdiv _ _ = Nothing

465−s64rem :: Word64 -> Word64 -> Word64

284+

466−s64rem x y = fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64)

285+bashr IT8 [VConstant (B8 x), VConstant (B8 y)]

467−

286+ = Just $ VConstant (B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8)))

468−b8Bin op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (B8 (op x y))

287+bashr IT16 [VConstant (B16 x), VConstant (B16 y)]

469−b8Bin _ _ = Nothing

288+ = Just $ VConstant (B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16)))

470−

289+bashr IT32 [VConstant (B32 x), VConstant (B32 y)]

471−b8Un op [VConstant (B8 x)] = Just $ VConstant (B8 (op x))

290+ = Just $ VConstant (B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32)))

472−b8Un _ _ = Nothing

291+bashr IT64 [VConstant (B64 x), VConstant (B64 y)]

473−

292+ = Just $ VConstant (B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64)))

474−b16Bin op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (B16 (op x y))

293+bashr ITNative [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (x `shiftR` y))

475−b16Bin _ _ = Nothing

294+bashr _ _ = Nothing

476−

295+

477−b16Un op [VConstant (B16 x)] = Just $ VConstant (B16 (op x))

296+bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Value] -> Maybe Value

478−b16Un _ _ = Nothing

297+bUn IT8 op [VConstant (B8 x)] = Just $ VConstant (B8 (op x))

479−

298+bUn IT16 op [VConstant (B16 x)] = Just $ VConstant (B16 (op x))

480−b32Bin op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (B32 (op x y))

299+bUn IT32 op [VConstant (B32 x)] = Just $ VConstant (B32 (op x))

481−b32Bin _ _ = Nothing

300+bUn IT64 op [VConstant (B64 x)] = Just $ VConstant (B64 (op x))

482−

301+bUn ITBig op [VConstant (BI x)] = Just $ VConstant (BI (op x))

483−b32Un op [VConstant (B32 x)] = Just $ VConstant (B32 (op x))

302+bUn ITNative op [VConstant (I x)] = Just $ VConstant (I (op x))

484−b32Un _ _ = Nothing

303+bUn _ _ _ = Nothing

485−

304+

486−b64Bin op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (B64 (op x y))

305+bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Value] -> Maybe Value

487−b64Bin _ _ = Nothing

306+bitBin IT8 op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (B8 (op x y))

488−

307+bitBin IT16 op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (B16 (op x y))

489−b64Un op [VConstant (B64 x)] = Just $ VConstant (B64 (op x))

308+bitBin IT32 op [VConstant (B32 x), VConstant (B32 y)] = Just $ VConstant (B32 (op x y))

490−b64Un _ _ = Nothing

309+bitBin IT64 op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (B64 (op x y))

491−

310+bitBin ITBig op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (BI (op x y))

492−b8Cmp op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

311+bitBin ITNative op [VConstant (I x), VConstant (I y)] = Just $ VConstant (I (op x y))

493−b8Cmp _ _ = Nothing

312+bitBin _ _ _ = Nothing

494−

313+

495−b16Cmp op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

314+bCmp :: IntTy -> (forall a. Ord a => a -> a -> Bool) -> [Value] -> Maybe Value

496−b16Cmp _ _ = Nothing

315+bCmp IT8 op [VConstant (B8 x), VConstant (B8 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

497−

316+bCmp IT16 op [VConstant (B16 x), VConstant (B16 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

498−b32Cmp op [VConstant (B32 x), VConstant (B32 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))

499−b32Cmp _ _ = Nothing

318+bCmp IT64 op [VConstant (B64 x), VConstant (B64 y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

500−

319+bCmp ITBig op [VConstant (BI x), VConstant (BI y)] = Just $ VConstant (I (if (op x y) then 1 else 0))

501−b64Cmp op [VConstant (B64 x), VConstant (B64 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))

502−b64Cmp _ _ = Nothing

321+bCmp _ _ _ = Nothing

503−

322+

504−toB8 x = VConstant (B8 (fromIntegral x))

323+toInt IT8 x = VConstant (B8 (fromIntegral x))

505−toB16 x = VConstant (B16 (fromIntegral x))

324+toInt IT16 x = VConstant (B16 (fromIntegral x))

506−toB32 x = VConstant (B32 (fromIntegral x))

325+toInt IT32 x = VConstant (B32 (fromIntegral x))

507−toB64 x = VConstant (B64 (fromIntegral x))

326+toInt IT64 x = VConstant (B64 (fromIntegral x))

508−

327+toInt ITBig x = VConstant (BI (fromIntegral x))

509−zext8_16 [VConstant (B8 x)] = Just $ toB16 x

328+toInt ITNative x = VConstant (I (fromIntegral x))

510−zext8_16 _ = Nothing

329+

511−

330+intToInt IT8 out [VConstant (B8 x)] = Just $ toInt out x

512−zext8_32 [VConstant (B8 x)] = Just $ toB32 x

331+intToInt IT16 out [VConstant (B16 x)] = Just $ toInt out x

513−zext8_32 _ = Nothing

332+intToInt IT32 out [VConstant (B32 x)] = Just $ toInt out x

514−

333+intToInt IT64 out [VConstant (B64 x)] = Just $ toInt out x

515−zext8_64 [VConstant (B8 x)] = Just $ toB64 x

334+intToInt ITBig out [VConstant (BI x)] = Just $ toInt out x

516−zext8_64 _ = Nothing

335+intToInt ITNative out [VConstant (I x)] = Just $ toInt out x

517−

336+intToInt _ _ _ = Nothing

518−sext8_16 [VConstant (B8 x)] = Just $ toB16 (fromIntegral x :: Int8)

337+

519−sext8_16 _ = Nothing

338+zext from ITBig val = intToInt from ITBig val

520−

339+zext ITBig _ _ = Nothing

521−sext8_32 [VConstant (B8 x)] = Just $ toB32 (fromIntegral x :: Int8)

340+zext from to val

522−sext8_32 _ = Nothing

341+ | intTyWidth from < intTyWidth to = intToInt from to val

523−

342+zext _ _ _ = Nothing

524−sext8_64 [VConstant (B8 x)] = Just $ toB64 (fromIntegral x :: Int8)

343+

525−sext8_64 _ = Nothing

344+sext IT8 out [VConstant (B8 x)] = Just $ toInt out (fromIntegral x :: Int8)

526−

345+sext IT16 out [VConstant (B16 x)] = Just $ toInt out (fromIntegral x :: Int16)

527−zext16_32 [VConstant (B16 x)] = Just $ toB32 x

346+sext IT32 out [VConstant (B32 x)] = Just $ toInt out (fromIntegral x :: Int32)

528−zext16_32 _ = Nothing

347+sext IT64 out [VConstant (B64 x)] = Just $ toInt out (fromIntegral x :: Int64)

529−

348+sext ITBig _ _ = Nothing

530−zext16_64 [VConstant (B16 x)] = Just $ toB64 x

349+sext from to val = intToInt from to val

531−zext16_64 _ = Nothing

350+

532−

351+trunc ITBig to val = intToInt ITBig to val

533−sext16_32 [VConstant (B16 x)] = Just $ toB32 (fromIntegral x :: Int16)

352+trunc _ ITBig _ = Nothing

534−sext16_32 _ = Nothing

353+trunc from to val | intTyWidth from > intTyWidth to = intToInt from to val

535−

354+trunc _ _ _ = Nothing

536−sext16_64 [VConstant (B16 x)] = Just $ toB64 (fromIntegral x :: Int16)

355+

537−sext16_64 _ = Nothing

356+getInt :: [Value] -> Maybe Integer

538−

357+getInt [VConstant (B8 x)] = Just . toInteger $ x

539−trunc16_8 [VConstant (B16 x)] = Just $ toB8 x

358+getInt [VConstant (B16 x)] = Just . toInteger $ x

540−trunc16_8 _ = Nothing

359+getInt [VConstant (B32 x)] = Just . toInteger $ x

541−

360+getInt [VConstant (B64 x)] = Just . toInteger $ x

542−zext32_64 [VConstant (B32 x)] = Just $ toB64 x

361+getInt [VConstant (I x)] = Just . toInteger $ x

543−zext32_64 _ = Nothing

362+getInt [VConstant (BI x)] = Just x

544−

363+getInt _ = Nothing

545−sext32_64 [VConstant (B32 x)] = Just $ toB64 (fromIntegral x :: Int32)

364+

546−sext32_64 _ = Nothing

365+intToStr val | Just i <- getInt val = Just $ VConstant (Str (show i))

547−

366+intToStr _ = Nothing

548−trunc32_8 [VConstant (B32 x)] = Just $ toB8 x

367+

549−trunc32_8 _ = Nothing

368+strToInt ity [VConstant (Str x)] = case reads x of

550−

369+ [(n,"")] -> Just $ toInt ity (n :: Integer)

551−trunc32_16 [VConstant (B32 x)] = Just $ toB16 x

370+ _ -> Just $ VConstant (I 0)

552−trunc32_16 _ = Nothing

371+strToInt _ _ = Nothing

553−

372+

554−trunc64_8 [VConstant (B64 x)] = Just $ toB8 x

373+intToFloat val | Just i <- getInt val = Just $ VConstant (Fl (fromIntegral i))

555−trunc64_8 _ = Nothing

374+intToFloat _ = Nothing

556−

375+

557−trunc64_16 [VConstant (B64 x)] = Just $ toB16 x

376+floatToInt ity [VConstant (Fl x)] = Just $ toInt ity (truncate x :: Integer)

558−trunc64_16 _ = Nothing

377+floatToInt _ _ = 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

581

378

582c_intToChar [VConstant (I x)] = Just $ VConstant (Ch (toEnum x))

379c_intToChar [VConstant (I x)] = Just $ VConstant (Ch (toEnum x))

583c_intToChar _ = Nothing

380c_intToChar _ = Nothing

584c_charToInt [VConstant (Ch x)] = Just $ VConstant (I (fromEnum x))

381c_charToInt [VConstant (Ch x)] = Just $ VConstant (I (fromEnum x))

585c_charToInt _ = Nothing

382c_charToInt _ = Nothing

586

383

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−

599c_floatToStr [VConstant (Fl x)] = Just $ VConstant (Str (show x))

384c_floatToStr [VConstant (Fl x)] = Just $ VConstant (Str (show x))

600c_floatToStr _ = Nothing

385c_floatToStr _ = Nothing

601c_strToFloat [VConstant (Str x)] = case reads x of

386c_strToFloat [VConstant (Str x)] = case reads x of

@@ -603,12 +388,6 @@ c_strToFloat [VConstant (Str x)] = case reads x of

603 _ -> Just $ VConstant (Fl 0)

388 _ -> Just $ VConstant (Fl 0)

604c_strToFloat _ = Nothing

389c_strToFloat _ = Nothing

605

390

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−

612p_fPrim f [VConstant (Fl x)] = Just $ VConstant (Fl (f x))

391p_fPrim f [VConstant (Fl x)] = Just $ VConstant (Fl (f x))

613p_fPrim f _ = Nothing

392p_fPrim f _ = Nothing

614

393

@@ -625,6 +404,7 @@ p_floatFloor = p_fPrim (fromInteger . floor)

625p_floatCeil = p_fPrim (fromInteger . ceiling)

404p_floatCeil = p_fPrim (fromInteger . ceiling)

626

405

627p_strLen [VConstant (Str xs)] = Just $ VConstant (I (length xs))

406p_strLen [VConstant (Str xs)] = Just $ VConstant (I (length xs))

407+p_strLen _ = Nothing

628p_strHead [VConstant (Str (x:xs))] = Just $ VConstant (Ch x)

408p_strHead [VConstant (Str (x:xs))] = Just $ VConstant (Ch x)

629p_strHead _ = Nothing

409p_strHead _ = Nothing

630p_strTail [VConstant (Str (x:xs))] = Just $ VConstant (Str xs)

410p_strTail [VConstant (Str (x:xs))] = Just $ VConstant (Str xs)

src/Idris/Prover.hs+3−3

@@ -26,7 +26,7 @@ prover :: Bool -> Name -> Idris ()

26prover lit x =

27 do ctxt <- getContext

28 i <- getIState

29− case lookupTy Nothing x ctxt of

29+ case lookupTy x ctxt of

30 [t] -> if elem x (idris_metavars i)

31 then prove ctxt lit x t

32 else fail $ show x ++ " is not a metavariable"

@@ -78,9 +78,9 @@ elabStep st e = do case runStateT e st of

78 fail (pshow i a)

79

80dumpState :: IState -> ProofState -> IO ()

81−dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _) =

81+dumpState ist (PS nm [] _ _ tm _ _ _ _ _ _ _ _ _ _ _ _ _) =

82 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

84 let OK ty = goalAtFocus ps

85 let OK env = envAtFocus ps

86 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

2

3

3import Core.TT

4import Core.TT

4import Core.Evaluate

5import Core.Evaluate

6+import Core.Execute

5import Idris.AbsSyntax

7import Idris.AbsSyntax

6import Idris.AbsSyntaxTree

8import Idris.AbsSyntaxTree

9+import Idris.Error

10+

11+import Debug.Trace

7

12

8-- | Wrap a type provider in the type of type providers

13-- | Wrap a type provider in the type of type providers

9providerTy :: FC -> PTerm -> PTerm

14providerTy :: FC -> PTerm -> PTerm

10providerTy fc tm = PApp fc (PRef fc $ UN "Provider") [PExp 0 False tm ""]

15providerTy fc tm = PApp fc (PRef fc $ UN "Provider") [PExp 0 False tm ""]

11

16

12−-- | Wrap the RHS of a type provider definition

17+-- | Handle an error, if the type provider returned an error. Otherwise return the provided term.

13−unProv :: FC -> PTerm -> PTerm

18+getProvided :: TT Name -> Idris (TT Name)

14−unProv fc tm = PApp fc (PRef fc $ NS (UN "unProv") ["Providers"]) [PExp 0 False tm ""]

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

18import Idris.Docs

19import Idris.Help

20import Idris.Completion

21+import Idris.IdeSlave

21

22

22import Paths_idris

23import Paths_idris

23import Util.System

24import Util.System

@@ -80,6 +81,104 @@ repl orig mods

80 ctrlC e = do lift $ iputStrLn (show e)

81 ctrlC e = do lift $ iputStrLn (show e)

81 repl orig mods

82 repl orig mods

82

83

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+

83-- | The prompt consists of the currently loaded modules, or "Idris" if there are none

182-- | The prompt consists of the currently loaded modules, or "Idris" if there are none

84mkPrompt [] = "Idris"

183mkPrompt [] = "Idris"

85mkPrompt [x] = "*" ++ dropExtension x

184mkPrompt [x] = "*" ++ dropExtension x

@@ -129,7 +228,7 @@ resolveProof :: Name -> Idris Name

129resolveProof n'

228resolveProof n'

130 = do i <- getIState

229 = do i <- getIState

131 ctxt <- getContext

230 ctxt <- getContext

132− n <- case lookupNames Nothing n' ctxt of

231+ n <- case lookupNames n' ctxt of

133 [x] -> return x

232 [x] -> return x

134 [] -> return n'

233 [] -> return n'

135 ns -> fail $ pshow i (CantResolveAlts (map show ns))

234 ns -> fail $ pshow i (CantResolveAlts (map show ns))

@@ -173,112 +272,115 @@ proofs orig

173

272

174insertScript :: String -> [String] -> [String]

273insertScript :: String -> [String] -> [String]

175insertScript prf [] = "\n---------- Proofs ----------" : "" : [prf]

274insertScript prf [] = "\n---------- Proofs ----------" : "" : [prf]

176−insertScript prf (p@"---------- Proofs ----------" : "" : xs)

275+insertScript prf (p@"---------- Proofs ----------" : "" : xs)

177 = p : "" : prf : xs

276 = p : "" : prf : xs

178insertScript prf (x : xs) = x : insertScript prf xs

277insertScript prf (x : xs) = x : insertScript prf xs

179

278

180process :: FilePath -> Command -> Idris ()

279process :: FilePath -> Command -> Idris ()

181−process fn Help = iputStrLn displayHelp

280+process fn Help = iResult displayHelp

182−process fn (Eval t)

281+process fn (ChangeDirectory f)

282+ = do liftIO $ setCurrentDirectory f

283+ return ()

284+process fn (Eval t)

183 = do (tm, ty) <- elabVal toplevel False t

285 = do (tm, ty) <- elabVal toplevel False t

184 ctxt <- getContext

286 ctxt <- getContext

185− ist <- getIState

287+ ist <- getIState

186 let tm' = normaliseAll ctxt [] tm

288 let tm' = normaliseAll ctxt [] tm

187 let ty' = normaliseAll ctxt [] ty

289 let ty' = normaliseAll ctxt [] ty

188 logLvl 3 $ "Raw: " ++ show (tm', ty')

290 logLvl 3 $ "Raw: " ++ show (tm', ty')

189 imp <- impShow

291 imp <- impShow

190− iputStrLn (showImp imp (delab ist tm') ++ " : " ++

292+ iResult (showImp imp (delab ist tm') ++ " : " ++

191− showImp imp (delab ist ty'))

293+ showImp imp (delab ist ty'))

192process fn (ExecVal t)

294process fn (ExecVal t)

193 = do ctxt <- getContext

295 = do ctxt <- getContext

194 ist <- getIState

296 ist <- getIState

195 (tm, ty) <- elabVal toplevel False t

297 (tm, ty) <- elabVal toplevel False t

196− let tm' = normaliseAll ctxt [] tm

298+-- let tm' = normaliseAll ctxt [] tm

197 let ty' = normaliseAll ctxt [] ty

299 let ty' = normaliseAll ctxt [] ty

198− res <- execute tm'

300+ res <- execute tm

199 imp <- impShow

301 imp <- impShow

200− iputStrLn (showImp imp (delab ist res) ++ " : " ++

302+ iResult (showImp imp (delab ist res) ++ " : " ++

201− showImp imp (delab ist ty'))

303+ showImp imp (delab ist ty'))

202− return ()

203process fn (Check (PRef _ n))

304process fn (Check (PRef _ n))

204− = do ctxt <- getContext

305+ = do ctxt <- getContext

205− ist <- getIState

306+ ist <- getIState

206− imp <- impShow

307+ imp <- impShow

207− case lookupTy Nothing n ctxt of

308+ case lookupNames n ctxt of

208− ts@(_:_) -> mapM_ (\t -> iputStrLn $ show n ++ " : " ++

309+ ts@(_:_) -> do mapM_ (\n -> iputStrLn $ show n ++ " : " ++

209− showImp imp (delab ist t)) ts

310+ showImp imp (delabTy ist n)) ts

210− [] -> iputStrLn $ "No such variable " ++ show n

311+ iResult ""

312+ [] -> iFail $ "No such variable " ++ show n

211process fn (Check t) = do (tm, ty) <- elabVal toplevel False t

313process fn (Check t) = do (tm, ty) <- elabVal toplevel False t

212 ctxt <- getContext

314 ctxt <- getContext

213− ist <- getIState

315+ ist <- getIState

214 imp <- impShow

316 imp <- impShow

215 let ty' = normaliseC ctxt [] ty

317 let ty' = normaliseC ctxt [] ty

216− iputStrLn (showImp imp (delab ist tm) ++ " : " ++

318+ iResult (showImp imp (delab ist tm) ++ " : " ++

217− showImp imp (delab ist ty))

319+ showImp imp (delab ist ty))

218

320

219process fn (DocStr n) = do i <- getIState

321process fn (DocStr n) = do i <- getIState

220− case lookupCtxtName Nothing n (idris_docstrings i) of

322+ case lookupCtxtName n (idris_docstrings i) of

221− [] -> iputStrLn $ "No documentation for " ++ show n

323+ [] -> iFail $ "No documentation for " ++ show n

222− ns -> mapM_ showDoc ns

324+ ns -> do mapM_ showDoc ns

223− where showDoc (n, d)

325+ iResult ""

326+ where showDoc (n, d)

224 = do doc <- getDocs n

327 = do doc <- getDocs n

225 iputStrLn $ show doc

328 iputStrLn $ show doc

226process fn Universes = do i <- getIState

329process fn Universes = do i <- getIState

227 let cs = idris_constraints i

330 let cs = idris_constraints i

228-- iputStrLn $ showSep "\n" (map show cs)

331-- iputStrLn $ showSep "\n" (map show cs)

229− liftIO $ print (map fst cs)

332+ iputStrLn $ show (map fst cs)

230 let n = length cs

333 let n = length cs

231 iputStrLn $ "(" ++ show n ++ " constraints)"

334 iputStrLn $ "(" ++ show n ++ " constraints)"

232 case ucheck cs of

335 case ucheck cs of

233− Error e -> iputStrLn $ pshow i e

336+ Error e -> iFail $ pshow i e

234− OK _ -> iputStrLn "Universes OK"

337+ OK _ -> iResult "Universes OK"

235process fn (Defn n) = do i <- getIState

338process fn (Defn n) = do i <- getIState

236 iputStrLn "Compiled patterns:\n"

339 iputStrLn "Compiled patterns:\n"

237− liftIO $ print (lookupDef Nothing n (tt_ctxt i))

340+ iputStrLn $ show (lookupDef n (tt_ctxt i))

238− case lookupCtxt Nothing n (idris_patdefs i) of

341+ case lookupCtxt n (idris_patdefs i) of

239 [] -> return ()

342 [] -> return ()

240− [d] -> do iputStrLn "Original definiton:\n"

343+ [(d, _)] -> do iputStrLn "Original definiton:\n"

241− mapM_ (printCase i) d

344+ mapM_ (printCase i) d

242 case lookupTotal n (tt_ctxt i) of

345 case lookupTotal n (tt_ctxt i) of

243 [t] -> iputStrLn (showTotal t i)

346 [t] -> iputStrLn (showTotal t i)

244 _ -> return ()

347 _ -> return ()

245− where printCase i (_, lhs, rhs)

348+ where printCase i (_, lhs, rhs)

246− = do liftIO $ putStr $ showImp True (delab i lhs)

349+ = do iputStrLn (showImp True (delab i lhs) ++ " = " ++

247− liftIO $ putStr " = "

350+ showImp True (delab i rhs))

248− liftIO $ putStrLn $ showImp True (delab i rhs)

249process fn (TotCheck n) = do i <- getIState

351process fn (TotCheck n) = do i <- getIState

250 case lookupTotal n (tt_ctxt i) of

352 case lookupTotal n (tt_ctxt i) of

251− [t] -> iputStrLn (showTotal t i)

353+ [t] -> iResult (showTotal t i)

252− _ -> return ()

354+ _ -> do iFail ""

253−process fn (DebugInfo n)

355+ return ()

356+process fn (DebugInfo n)

254 = do i <- getIState

357 = do i <- getIState

255− let oi = lookupCtxtName Nothing n (idris_optimisation i)

358+ let oi = lookupCtxtName n (idris_optimisation i)

256 when (not (null oi)) $ iputStrLn (show oi)

359 when (not (null oi)) $ iputStrLn (show oi)

257− let si = lookupCtxt Nothing n (idris_statics i)

360+ let si = lookupCtxt n (idris_statics i)

258 when (not (null si)) $ iputStrLn (show si)

361 when (not (null si)) $ iputStrLn (show si)

259− let di = lookupCtxt Nothing n (idris_datatypes i)

362+ let di = lookupCtxt n (idris_datatypes i)

260 when (not (null di)) $ iputStrLn (show di)

363 when (not (null di)) $ iputStrLn (show di)

261− let d = lookupDef Nothing n (tt_ctxt i)

364+ let d = lookupDef n (tt_ctxt i)

262− when (not (null d)) $ liftIO $

365+ when (not (null d)) $ iputStrLn $ "Definition: " ++ (show (head d))

263− do print (head d)

366+ let cg = lookupCtxtName n (idris_callgraph i)

264− let cg = lookupCtxtName Nothing n (idris_callgraph i)

265 findUnusedArgs (map fst cg)

367 findUnusedArgs (map fst cg)

266 i <- getIState

368 i <- getIState

267− let cg' = lookupCtxtName Nothing n (idris_callgraph i)

369+ let cg' = lookupCtxtName n (idris_callgraph i)

268 sc <- checkSizeChange n

370 sc <- checkSizeChange n

269 iputStrLn $ "Size change: " ++ show sc

371 iputStrLn $ "Size change: " ++ show sc

270 when (not (null cg')) $ do iputStrLn "Call graph:\n"

372 when (not (null cg')) $ do iputStrLn "Call graph:\n"

271 iputStrLn (show cg')

373 iputStrLn (show cg')

272process fn (Info n) = do i <- getIState

374process fn (Info n) = do i <- getIState

273− case lookupCtxt Nothing n (idris_classes i) of

375+ case lookupCtxt n (idris_classes i) of

274 [c] -> classInfo c

376 [c] -> classInfo c

275− _ -> iputStrLn "Not a class"

377+ _ -> iFail "Not a class"

276−process fn (Search t) = iputStrLn "Not implemented"

378+process fn (Search t) = iFail "Not implemented"

277process fn (Spec t) = do (tm, ty) <- elabVal toplevel False t

379process fn (Spec t) = do (tm, ty) <- elabVal toplevel False t

278 ctxt <- getContext

380 ctxt <- getContext

279 ist <- getIState

381 ist <- getIState

280 let tm' = simplify ctxt True [] {- (idris_statics ist) -} tm

382 let tm' = simplify ctxt True [] {- (idris_statics ist) -} tm

281− iputStrLn (show (delab ist tm'))

383+ iResult (show (delab ist tm'))

282

384

283process fn (RmProof n')

385process fn (RmProof n')

284 = do i <- getIState

386 = do i <- getIState

@@ -296,8 +398,17 @@ process fn (RmProof n')

296 let ms = idris_metavars i

398 let ms = idris_metavars i

297 putIState $ i { idris_metavars = n : ms }

399 putIState $ i { idris_metavars = n : ms }

298

400

299−process fn (AddProof prf)

401+process fn' (AddProof prf)

300− = do let fb = fn ++ "~"

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

301 liftIO $ copyFile fn fb -- make a backup in case something goes wrong!

412 liftIO $ copyFile fn fb -- make a backup in case something goes wrong!

302 prog <- liftIO $ readFile fb

413 prog <- liftIO $ readFile fb

303 i <- getIState

414 i <- getIState

@@ -321,13 +432,13 @@ process fn (ShowProof n')

321 n <- resolveProof n'

432 n <- resolveProof n'

322 let proofs = proof_list i

433 let proofs = proof_list i

323 case lookup n proofs of

434 case lookup n proofs of

324− Nothing -> iputStrLn "No proof to show"

435+ Nothing -> iFail "No proof to show"

325− Just p -> iputStrLn $ showProof False n p

436+ Just p -> iResult $ showProof False n p

326

437

327process fn (Prove n')

438process fn (Prove n')

328 = do ctxt <- getContext

439 = do ctxt <- getContext

329 ist <- getIState

440 ist <- getIState

330− n <- case lookupNames Nothing n' ctxt of

441+ n <- case lookupNames n' ctxt of

331 [x] -> return x

442 [x] -> return x

332 [] -> return n'

443 [] -> return n'

333 ns -> fail $ pshow ist (CantResolveAlts (map show ns))

444 ns -> fail $ pshow ist (CantResolveAlts (map show ns))

@@ -342,13 +453,13 @@ process fn (HNF t) = do (tm, ty) <- elabVal toplevel False t

342 ctxt <- getContext

453 ctxt <- getContext

343 ist <- getIState

454 ist <- getIState

344 let tm' = hnf ctxt [] tm

455 let tm' = hnf ctxt [] tm

345− iputStrLn (show (delab ist tm'))

456+ iResult (show (delab ist tm'))

346process fn TTShell = do ist <- getIState

457process fn TTShell = do ist <- getIState

347 let shst = initState (tt_ctxt ist)

458 let shst = initState (tt_ctxt ist)

348 runShell shst

459 runShell shst

349 return ()

460 return ()

350−process fn Execute = do (m, _) <- elabVal toplevel False

461+process fn Execute = do (m, _) <- elabVal toplevel False

351− (PApp fc

462+ (PApp fc

352 (PRef fc (UN "run__IO"))

463 (PRef fc (UN "run__IO"))

353 [pexp $ PRef fc (NS (UN "main") ["Main"])])

464 [pexp $ PRef fc (NS (UN "main") ["Main"])])

354-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

465-- (PRef (FC "main" 0) (NS (UN "main") ["main"]))

@@ -358,37 +469,37 @@ process fn Execute = do (m, _) <- elabVal toplevel False

358 compile t tmpn m

469 compile t tmpn m

359 liftIO $ system tmpn

470 liftIO $ system tmpn

360 return ()

471 return ()

361− where fc = FC "main" 0

472+ where fc = FC "main" 0

362−process fn (NewCompile f)

473+process fn (NewCompile f)

363 = do (m, _) <- elabVal toplevel False

474 = do (m, _) <- elabVal toplevel False

364 (PApp fc (PRef fc (UN "run__IO"))

475 (PApp fc (PRef fc (UN "run__IO"))

365 [pexp $ PRef fc (NS (UN "main") ["Main"])])

476 [pexp $ PRef fc (NS (UN "main") ["Main"])])

366 compileEpic f m

477 compileEpic f m

367− where fc = FC "main" 0

478+ where fc = FC "main" 0

368−process fn (Compile target f)

479+process fn (Compile target f)

369 = do (m, _) <- elabVal toplevel False

480 = do (m, _) <- elabVal toplevel False

370 (PApp fc (PRef fc (UN "run__IO"))

481 (PApp fc (PRef fc (UN "run__IO"))

371 [pexp $ PRef fc (NS (UN "main") ["Main"])])

482 [pexp $ PRef fc (NS (UN "main") ["Main"])])

372 compile target f m

483 compile target f m

373− where fc = FC "main" 0

484+ where fc = FC "main" 0

374−process fn (LogLvl i) = setLogLevel i

485+process fn (LogLvl i) = setLogLevel i

375-- Elaborate as if LHS of a pattern (debug command)

486-- Elaborate as if LHS of a pattern (debug command)

376−process fn (Pattelab t)

487+process fn (Pattelab t)

377 = do (tm, ty) <- elabVal toplevel True t

488 = do (tm, ty) <- elabVal toplevel True t

378− iputStrLn $ show tm ++ "\n\n : " ++ show ty

489+ iResult $ show tm ++ "\n\n : " ++ show ty

379−

490+

380−process fn (Missing n) = do i <- getIState

491+process fn (Missing n)

381− case lookupDef Nothing n (tt_ctxt i) of

492+ = do i <- getIState

382− [CaseOp _ _ _ _ _ args t _ _]

493+ case lookupCtxt n (idris_patdefs i) of

383− -> do tms <- genMissing n args t

494+ [] -> return ()

384− iputStrLn (showSep "\n" (map (showImp True) tms))

495+ [(_, tms)] ->

385− [] -> iputStrLn $ show n ++ " undefined"

496+ iResult (showSep "\n" (map (showImp True) tms))

386− _ -> iputStrLn $ "Ambiguous name"

497+ _ -> iFail $ "Ambiguous name"

387process fn (DynamicLink l) = do i <- getIState

498process fn (DynamicLink l) = do i <- getIState

388 let lib = trim l

499 let lib = trim l

389 handle <- lift $ tryLoadLib lib

500 handle <- lift $ tryLoadLib lib

390 case handle of

501 case handle of

391− Nothing -> iputStrLn $ "Could not load dynamic lib \"" ++ l ++ "\""

502+ Nothing -> iFail $ "Could not load dynamic lib \"" ++ l ++ "\""

392 Just x -> do let libs = idris_dynamic_libs i

503 Just x -> do let libs = idris_dynamic_libs i

393 putIState $ i { idris_dynamic_libs = x:libs }

504 putIState $ i { idris_dynamic_libs = x:libs }

394 where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace

505 where trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace

@@ -401,8 +512,8 @@ process fn Metavars

401 = do ist <- getIState

512 = do ist <- getIState

402 let mvs = idris_metavars ist \\ primDefs

513 let mvs = idris_metavars ist \\ primDefs

403 case mvs of

514 case mvs of

404− [] -> iputStrLn "No global metavariables to solve"

515+ [] -> iFail "No global metavariables to solve"

405− _ -> iputStrLn $ "Global metavariables:\n\t" ++ show mvs

516+ _ -> iResult $ "Global metavariables:\n\t" ++ show mvs

406process fn NOP = return ()

517process fn NOP = return ()

407

518

408process fn (SetOpt ErrContext) = setErrContext True

519process fn (SetOpt ErrContext) = setErrContext True

@@ -410,8 +521,8 @@ process fn (UnsetOpt ErrContext) = setErrContext False

410process fn (SetOpt ShowImpl) = setImpShow True

521process fn (SetOpt ShowImpl) = setImpShow True

411process fn (UnsetOpt ShowImpl) = setImpShow False

522process fn (UnsetOpt ShowImpl) = setImpShow False

412

523

413−process fn (SetOpt _) = iputStrLn "Not a valid option"

524+process fn (SetOpt _) = iFail "Not a valid option"

414−process fn (UnsetOpt _) = iputStrLn "Not a valid option"

525+process fn (UnsetOpt _) = iFail "Not a valid option"

415

526

416

527

417classInfo :: ClassInfo -> Idris ()

528classInfo :: ClassInfo -> Idris ()

@@ -420,6 +531,7 @@ classInfo ci = do iputStrLn "Methods:\n"

420 iputStrLn ""

531 iputStrLn ""

421 iputStrLn "Instances:\n"

532 iputStrLn "Instances:\n"

422 mapM_ dumpInstance (class_instances ci)

533 mapM_ dumpInstance (class_instances ci)

534+ iResult ""

423

535

424dumpMethod :: (Name, (FnOpts, PTerm)) -> Idris ()

536dumpMethod :: (Name, (FnOpts, PTerm)) -> Idris ()

425dumpMethod (n, (_, t)) = iputStrLn $ show n ++ " : " ++ show t

537dumpMethod (n, (_, t)) = iputStrLn $ show n ++ " : " ++ show t

@@ -428,7 +540,7 @@ dumpInstance :: Name -> Idris ()

428dumpInstance n = do i <- getIState

540dumpInstance n = do i <- getIState

429 ctxt <- getContext

541 ctxt <- getContext

430 imp <- impShow

542 imp <- impShow

431− case lookupTy Nothing n ctxt of

543+ case lookupTy n ctxt of

432 ts -> mapM_ (\t -> iputStrLn $ showImp imp (delab i t)) ts

544 ts -> mapM_ (\t -> iputStrLn $ showImp imp (delab i t)) ts

433

545

434showTotal t@(Partial (Other ns)) i

546showTotal t@(Partial (Other ns)) i

@@ -459,6 +571,7 @@ parseTarget _ = error "unknown target" -- FIXME: partial function

459parseArgs :: [String] -> [Opt]

571parseArgs :: [String] -> [Opt]

460parseArgs [] = []

572parseArgs [] = []

461parseArgs ("--quiet":ns) = Quiet : (parseArgs ns)

573parseArgs ("--quiet":ns) = Quiet : (parseArgs ns)

574+parseArgs ("--ideslave":ns) = Ideslave : (parseArgs ns)

462parseArgs ("--log":lvl:ns) = OLogging (read lvl) : (parseArgs ns)

575parseArgs ("--log":lvl:ns) = OLogging (read lvl) : (parseArgs ns)

463parseArgs ("--noprelude":ns) = NoPrelude : (parseArgs ns)

576parseArgs ("--noprelude":ns) = NoPrelude : (parseArgs ns)

464parseArgs ("--check":ns) = NoREPL : (parseArgs ns)

577parseArgs ("--check":ns) = NoREPL : (parseArgs ns)

@@ -512,6 +625,7 @@ idrisMain :: [Opt] -> Idris ()

512idrisMain opts =

625idrisMain opts =

513 do let inputs = opt getFile opts

626 do let inputs = opt getFile opts

514 let quiet = Quiet `elem` opts

627 let quiet = Quiet `elem` opts

628+ let idesl = Ideslave `elem` opts

515 let runrepl = not (NoREPL `elem` opts)

629 let runrepl = not (NoREPL `elem` opts)

516 let output = opt getOutput opts

630 let output = opt getOutput opts

517 let newoutput = opt getNewOutput opts

631 let newoutput = opt getNewOutput opts

@@ -531,6 +645,7 @@ idrisMain opts =

531 mapM_ addLangExt (opt getLanguageExt opts)

645 mapM_ addLangExt (opt getLanguageExt opts)

532 setREPL runrepl

646 setREPL runrepl

533 setQuiet quiet

647 setQuiet quiet

648+ setIdeSlave idesl

534 setVerbose runrepl

649 setVerbose runrepl

535 setCmdLine opts

650 setCmdLine opts

536 setOutputTy outty

651 setOutputTy outty

@@ -549,12 +664,13 @@ idrisMain opts =

549 [] -> setIBCSubDir ""

664 [] -> setIBCSubDir ""

550 (d:_) -> setIBCSubDir d

665 (d:_) -> setIBCSubDir d

551 setImportDirs importdirs

666 setImportDirs importdirs

667+

552 addPkgDir "base"

668 addPkgDir "base"

553 mapM_ addPkgDir pkgdirs

669 mapM_ addPkgDir pkgdirs

554 elabPrims

670 elabPrims

555 when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"

671 when (not (NoPrelude `elem` opts)) $ do x <- loadModule "Prelude"

556 return ()

672 return ()

557− when (runrepl && not quiet) $ iputStrLn banner

673+ when (runrepl && not quiet && not idesl) $ iputStrLn banner

558 ist <- getIState

674 ist <- getIState

559 mods <- mapM loadModule inputs

675 mods <- mapM loadModule inputs

560 ok <- noErrors

676 ok <- noErrors

@@ -564,7 +680,8 @@ idrisMain opts =

564 when ok $ case newoutput of

680 when ok $ case newoutput of

565 [] -> return ()

681 [] -> return ()

566 (o:_) -> process "" (NewCompile o)

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

568 ok <- noErrors

685 ok <- noErrors

569 when (not ok) $ liftIO (exitWith (ExitFailure 1))

686 when (not ok) $ liftIO (exitWith (ExitFailure 1))

570 where

687 where

@@ -633,7 +750,7 @@ getLanguageExt (Extension e) = Just e

633getLanguageExt _ = Nothing

750getLanguageExt _ = Nothing

634

751

635opt :: (Opt -> Maybe a) -> [Opt] -> [a]

752opt :: (Opt -> Maybe a) -> [Opt] -> [a]

636−opt = mapMaybe

753+opt = mapMaybe

637

754

638ver = showVersion version

755ver = showVersion version

639

756

src/Idris/REPLParser.hs+2−1

@@ -45,6 +45,7 @@ pCmd = try (do cmd ["q", "quit"]; eof; return Quit)

45 <|> try (do cmd ["showproof"]; n <- pName; eof; return (ShowProof n))

46 <|> try (do cmd ["log"]; i <- natural; eof; return (LogLvl (fromIntegral i)))

47 <|> try (do cmd ["l", "load"]; f <- getInput; return (Load f))

48+ <|> try (do cmd ["cd"]; f <- getInput; return (ChangeDirectory f))

48 <|> try (do cmd ["spec"]; t <- pFullExpr defaultSyntax; return (Spec t))

49 <|> try (do cmd ["spec"]; t <- pFullExpr defaultSyntax; return (Spec t))

49 <|> try (do cmd ["hnf"]; t <- pFullExpr defaultSyntax; return (HNF t))

50 <|> try (do cmd ["hnf"]; t <- pFullExpr defaultSyntax; return (HNF t))

50 <|> try (do cmd ["doc"]; n <- pfName; eof; return (DocStr n))

51 <|> try (do cmd ["doc"]; n <- pfName; eof; return (DocStr n))

@@ -65,7 +66,7 @@ pCmd = try (do cmd ["q", "quit"]; eof; return Quit)

65 <|> do t <- pFullExpr defaultSyntax; return (Eval t)

66 <|> do t <- pFullExpr defaultSyntax; return (Eval t)

66 <|> do eof; return NOP

67 <|> do eof; return NOP

67

68

68− where toPath n = foldl1 (</>) $ splitOn "." n

69+ where toPath n = foldl1' (</>) $ splitOn "." n

69

70

70pOption :: IParser Opt

71pOption :: IParser Opt

71pOption = do discard (symbol "errorcontext"); return ErrContext

72pOption = do discard (symbol "errorcontext"); return ErrContext

src/Idris/UnusedArgs.hs+2−2

@@ -15,7 +15,7 @@ findUnusedArgs ns = mapM_ traceUnused ns

15traceUnused :: Name -> Idris ()

16traceUnused n

17 = do i <- getIState

18− case lookupCtxt Nothing n (idris_callgraph i) of

18+ case lookupCtxt n (idris_callgraph i) of

19 [CGInfo args calls scg usedns _] ->

20 do let argpos = zip args [0..]

21 let fargs = concatMap (getFargpos calls) argpos

@@ -39,7 +39,7 @@ used path g j

39 | otherwise

40 = do logLvl 5 $ (show ((g, j) : path))

41 i <- getIState

42− case lookupCtxt Nothing g (idris_callgraph i) of

42+ case lookupCtxt g (idris_callgraph i) of

43 [CGInfo args calls scg usedns unused] ->

44 if (j >= length args)

45 then -- overapplied, assume used

src/Main.hs+4

@@ -29,6 +29,7 @@ import Idris.Imports

29import Idris.Error

30

31import Util.System ( getLibFlags, getIdrisLibDir, getIncFlags )

32+import Util.DynamicLinker

32

33

33import Pkg.Package

34import Pkg.Package

34

35

@@ -90,7 +91,10 @@ usagemsg = "Idris version " ++ ver ++ "\n" ++

90 "\t--log [level] Type debugging log level\n" ++

91 "\t--log [level] Type debugging log level\n" ++

91 "\t-S Do no further compilation of code generator output\n" ++

92 "\t-S Do no further compilation of code generator output\n" ++

92 "\t-c Compile to object files rather than an executable\n" ++

93 "\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" ++

93 "\t--libdir Show library install directory and exit\n" ++

95 "\t--libdir Show library install directory and exit\n" ++

94 "\t--link Show C library directories and exit (for C linking)\n" ++

96 "\t--link Show C library directories and exit (for C linking)\n" ++

95 "\t--include Show C include directories and exit (for C linking)\n" ++

97 "\t--include Show C include directories and exit (for C linking)\n" ++

96 "\t--target [target] Type the target: C, Java, bytecode, javascript, node\n"

98 "\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

69

70buildMods :: [Opt] -> [Name] -> IO ()

71buildMods opts ns = do let f = map (toPath . show) ns

72+-- putStrLn $ "MODULE: " ++ show f

72 idris (map Filename f ++ opts)

73 idris (map Filename f ++ opts)

73 return ()

74 return ()

74− where toPath n = foldl1 (</>) $ splitOn "." n

75+ where toPath n = foldl1' (</>) $ splitOn "." n

75

76

76testLib :: Bool -> String -> String -> IO Bool

77testLib :: Bool -> String -> String -> IO Bool

77testLib warn p f

78testLib warn p f

@@ -93,7 +94,7 @@ rmIBC :: Name -> IO ()

93rmIBC m = rmFile $ toIBCFile m

94rmIBC m = rmFile $ toIBCFile m

94

95

95toIBCFile (UN n) = n ++ ".ibc"

96toIBCFile (UN n) = n ++ ".ibc"

96−toIBCFile (NS n ns) = foldl1 (</>) (reverse (toIBCFile n : ns))

97+toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns))

97

98

98installIBC :: String -> Name -> IO ()

99installIBC :: String -> Name -> IO ()

99installIBC p m = do let f = toIBCFile m

100installIBC p m = do let f = toIBCFile m

@@ -105,7 +106,7 @@ installIBC p m = do let f = toIBCFile m

105 copyFile f (destdir </> takeFileName f)

106 copyFile f (destdir </> takeFileName f)

106 return ()

107 return ()

107 where getDest (UN n) = ""

108 where getDest (UN n) = ""

108− getDest (NS n ns) = foldl1 (</>) (reverse (getDest n : ns))

109+ getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : ns))

109

110

110installObj :: String -> String -> IO ()

111installObj :: String -> String -> IO ()

111installObj p o = do d <- getDataDir

112installObj p o = do d <- getDataDir

src/Util/DynamicLinker.hs+31−5

@@ -4,8 +4,15 @@

4module Util.DynamicLinker where

5

6import Foreign.LibFFI

7−import Foreign.Ptr (nullPtr, FunPtr, nullFunPtr)

7+import Foreign.Ptr (nullPtr, FunPtr, nullFunPtr,castPtrToFunPtr)

8+import System.Directory

9+#ifndef WINDOWS

8import System.Posix.DynamicLinker

10import System.Posix.DynamicLinker

11+#else

12+import System.Win32.DLL

13+import System.Win32.Types

14+type DL = HMODULE

15+#endif

9

16

10hostDynamicLibExt :: String

17hostDynamicLibExt :: String

11#ifdef LINUX

18#ifdef LINUX

@@ -16,22 +23,41 @@ hostDynamicLibExt = "dylib"

16hostDynamicLibExt = "dll"

23hostDynamicLibExt = "dll"

17#endif

24#endif

18

25

26+data ForeignFun = forall a. Fun { fun_name :: String

27+ , fun_handle :: FunPtr a

28+ }

29+

19data DynamicLib = Lib { lib_name :: String

30data DynamicLib = Lib { lib_name :: String

20 , lib_handle :: DL

31 , lib_handle :: DL

21 }

32 }

22

33

34+#ifndef WINDOWS

23tryLoadLib :: String -> IO (Maybe DynamicLib)

35tryLoadLib :: 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]

25 if undl handle == nullPtr

39 if undl handle == nullPtr

26 then return Nothing

40 then return Nothing

27 else return . Just $ Lib lib handle

41 else return . Just $ Lib lib handle

28

42

29−data ForeignFun = forall a. Fun { fun_name :: String

30− , fun_handle :: FunPtr a

31− }

32

43

33tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)

44tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)

34tryLoadFn fn (Lib _ h) = do cFn <- dlsym h fn

45tryLoadFn fn (Lib _ h) = do cFn <- dlsym h fn

35 if cFn == nullFunPtr

46 if cFn == nullFunPtr

36 then return Nothing

47 then return Nothing

37 else return . Just $ Fun fn cFn

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

1{-# LANGUAGE CPP #-}

2module Util.System(tempfile,withTempdir,environment,getCC,

3 getLibFlags,getIdrisLibDir,getIncFlags,rmFile,

4− getMvn,getExecutablePom) where

4+ getMvn,getExecutablePom,catchIO) where

5

6-- System helper functions.

7import Control.Monad (when)

test/README+5

@@ -22,5 +22,10 @@ Tests:

22020: implicit conversions

23021: effects

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

25

30

26regxxx: various regression tests

31regxxx: various regression tests

test/reg011/reg011.idr+1−2

@@ -4,7 +4,6 @@ vfoldl : (P : Nat -> Type) ->

4-- vfoldl P cons nil []

5-- = nil

6vfoldl P cons nil (x :: xs)

7− = vfoldl (\n => P (S n)) (\ n => cons (S n)) (cons O nil x) xs

7+ = vfoldl (\k => P (S k)) (\ n => cons (S n)) (cons O nil x) xs

8−%logging 0

9-- vfoldl P cons nil (x :: xs)

8-- vfoldl P cons nil (x :: xs)

10-- = vfoldl (\n => P (S n)) (\ n => cons _) (cons _ nil x) xs

9-- = 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 @@

1#!/usr/bin/perl

2

3+use Cwd;

4+

3my $exitstatus = 0;

5my $exitstatus = 0;

4

6

5sub runtest {

7sub runtest {

@@ -79,6 +81,10 @@ while ($opt=shift(@opts)) {

79 else { push(@idrOpts, $opt); }

81 else { push(@idrOpts, $opt); }

80}

82}

81

83

84+my $idris = $ENV{IDRIS};

85+my $path = $ENV{PATH};

86+$ENV{PATH}=cwd() . "/" . $idris . ":" . $path;

87+

82foreach $test (@tests) {

88foreach $test (@tests) {

83

89

84 if ($diff == 0 && $show == 0) {

90 if ($diff == 0 && $show == 0) {

test/test008/test008.idr−1

@@ -26,4 +26,3 @@ main = do (a, b) <- ioVals

26 case lookup x testlist of

27 Just v => putStrLn (show v)

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

69 envUpdate (pop k) val (x :: xs) = x :: envUpdate k val xs

70 envUpdate stop _ Nil impossible

71

72+ total

73+ envUpdateVal : (p:HasType gam i a) -> (val:b) ->

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+

72 envTail : Env (a :: gam) -> Env gam

79 envTail : Env (a :: gam) -> Env gam

73 envTail (x :: xs) = xs

80 envTail (x :: xs) = xs

74

81

@@ -121,7 +128,7 @@ using (i: Fin n, gam : Vect Ty n, gam' : Vect Ty n, gam'' : Vect Ty n)

121 (\env', scope' => k (envTail env') scope')

128 (\env', scope' => k (envTail env') scope')

122 interp env (Update method x) k

129 interp env (Update method x) k

123 = do x' <- getUpdater (method (envLookup x env))

130 = do x' <- getUpdater (method (envLookup x env))

124− k (envUpdate x x' env) (return ())

131+ k (envUpdateVal x x' env) (return ())

125 interp env (Use method x) k

132 interp env (Use method x) k

126 = do x' <- getReader (method (envLookup x env))

133 = do x' <- getReader (method (envLookup x env))

127 k env (return x')

134 k env (return x')

test/test016/test016.idr+4−7

@@ -7,14 +7,11 @@ codata Stream a = Nil | (::) a (Stream a)

7countFrom : Int -> Stream Int

8countFrom x = x :: countFrom (x + 1)

9

10−take : Int -> Stream a -> List a

10+take : Nat -> Stream a -> List a

11−take 0 _ = []

11+take O _ = []

12−take n (x :: xs) = x :: take (n - 1) xs

12+take (S n) (x :: xs) = x :: take n xs

13take n [] = []

14

15−-- foo : main.countFrom 4 = 4 :: main.countFrom 5

15+main : IO ()

16−-- foo = refl

17−

18−partial main : IO ()

19main = do print (take 10 (Main.countFrom 10))

16main = do print (take 10 (Main.countFrom 10))

20

17

test/test021/expected+2−2

@@ -2,5 +2,5 @@

2, WORLD!!!

3, ]

43

5−23

5+15

6−Answer: 107

6+Answer: 99

test/test021/test021a.idr+5−5

@@ -6,18 +6,18 @@ import Effect.Random

6import Effect.StdIO

7

8data Expr = Var String

9− | Val Int

9+ | Val Integer

10 | Add Expr Expr

11− | Random Int

11+ | Random Integer

12

13Env : Type

14−Env = List (String, Int)

14+Env = List (String, Integer)

15

16-- Evaluator : Type -> Type

17-- Evaluator t

18-- = Eff m [EXCEPTION String, RND, STATE Env] t

19

20−eval : Expr -> Eff IO [EXCEPTION String, STDIO, RND, STATE Env] Int

20+eval : Expr -> Eff IO [EXCEPTION String, STDIO, RND, STATE Env] Integer

21eval (Var x) = do vs <- get

22 case lookup x vs of

23 Nothing => raise ("No such variable " ++ x)

@@ -31,7 +31,7 @@ eval (Random upper) = do val <- rndInt 0 upper

31testExpr : Expr

32testExpr = Add (Add (Var "foo") (Val 42)) (Random 100)

33

34−runEval : List (String, Int) -> Expr -> IO Int

34+runEval : List (String, Integer) -> Expr -> IO Integer

35runEval args expr = run [(), (), 123456, args] (eval expr)

36

37main : IO ()

test/test022/test022.idr+1−1

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

1module Main

2

3−%dynamic "libm"

3+%dynamic "dummy", "libm", "msvcrt"

4

5x : Float

6x = 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 @@

11\input{library.ltx}

12

13\newcommand{\Idris}{\textsc{Idris}}

14+\newcommand{\version}{0.9.8}

14

15

15\title{Programming in \Idris{}: a tutorial}

16\title{Programming in \Idris{}: a tutorial}

16\author{Edwin Brady \\ \url{eb@cs.st-andrews.ac.uk}}

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

97\noindent

98We can treat \remph{stop} as a proof that the most recently defined variable is well-typed,

99and \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

101refer to the most recently defined variable, \texttt{pop stop} to refer to the next, and so on,

102via the \texttt{Var} constructor:

103

@@ -339,12 +339,12 @@ type to another if possible. Here, it converts a string to

339an integer, giving 0 if the input is invalid. An example run of this program

340at the \Idris{} interactive environment is shown in Figure \ref{factrun}.

341

342−\begin{SaveVerbatim}{factrun}

342+\begin{SaveVerbatim}[commandchars=^\{\}]{factrun}

343

344$ idris interp.idr

345 ____ __ _

346 / _/___/ /____(_)____

347− / // __ / ___/ / ___/ Version 0.9.7

347+ / // __ / ___/ / ___/ Version ^version{}

348 _/ // /_/ / / / (__ ) http://www.idris-lang.org/

349 /___/\__,_/_/ /_/____/ Type :? for help

350

@@ -397,7 +397,7 @@ unitTestFac = oh

397\useverb{unitTestFac}

398

399\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},

401say, we will get an error message like the following:

402

403\begin{SaveVerbatim}{unitTestErr}

tutorial/intro.tex+1−1

@@ -62,7 +62,7 @@ verifying systems software.

62\subsection{Example Code}

63

64This 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,

66so that you can try them out easily,

67under \texttt{tutorial/examples}. However, it is strongly recommended that you

68type them in yourself, rather than simply loading and reading them.

tutorial/starting.tex+6−6

@@ -74,12 +74,12 @@ interactive environment.

74Entering \texttt{idris} at the shell prompt starts up the interactive

75environment. You should see something like the following:

76

77−\begin{SaveVerbatim}{prompt1}

77+\begin{SaveVerbatim}[commandchars=^\{\}]{prompt1}

78

79$ idris

80 ____ __ _

81 / _/___/ /____(_)____

82− / // __ / ___/ / ___/ Version 0.9.7

82+ / // __ / ___/ / ___/ Version ^version{}

83 _/ // /_/ / / / (__ ) http://www.idris-lang.org/

84 /___/\__,_/_/ /_/____/ Type :? for help

85

@@ -98,8 +98,8 @@ as shown in Figure \ref{cmds}. Figure \ref{run1} shows an example run in which

98\texttt{hello.idr} is loaded, the type of \texttt{main} is checked and then

99the program is compiled to the executable \texttt{hello}.

100

101−\begin{SaveVerbatim}{cmds}

101+\begin{SaveVerbatim}[commandchars=\\\{\}]{cmds}

102−Idris version 0.9.7

102+Idris version \version{}

103-------------------

104

105 Command Arguments Purpose

@@ -129,12 +129,12 @@ Idris version 0.9.7

129\codefigs{cmds}{Interactive environment commands}

130

131

132−\begin{SaveVerbatim}{run1}

132+\begin{SaveVerbatim}[commandchars=^\{\}]{run1}

133

134$ idris hello.idr

135 ____ __ _

136 / _/___/ /____(_)____

137− / // __ / ___/ / ___/ Version 0.9.7

137+ / // __ / ___/ / ___/ Version ^version{}

138 _/ // /_/ / / / (__ ) http://www.idris-lang.org/

139 /___/\__,_/_/ /_/____/ Type :? for help

140

tutorial/theorems.tex+1−1

@@ -412,7 +412,7 @@ function \texttt{f} must:

412\item Cover all possible inputs

413\item Be \emph{well-founded} --- i.e. by the time a sequence of

414(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.

416\item Not use any data types which are not \emph{strictly positive}

417\item Not call any non-total functions

418\end{itemize}

tutorial/typesfuns.tex+5−5

@@ -257,11 +257,11 @@ even (S k) = odd k where

257 odd O = False

258 odd (S k) = even k

259

260−test : Num a => List a

260+test : List Nat

261−test = [c 1, c 2, d 3]

261+test = [c (S 1), c O, d (S O)]

262− where c x = 42 + x

262+ where c x = 42 + x

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

263+ d y = c (y + 1 + z y)

264− where z w = y + w

264+ where z w = y + w

265

266\end{SaveVerbatim}

267\useverb{whereinfer}