git.iko.soy/Idris-dev
on master help sign in
Merge branch 'master' of git://github.com/edwinb/Idris-dev into unified-int-primitives
b1a9e75Benjamin Saunders
.gitignore+4
compare with master
unifiedsplit
@@ -3,6 +3,9 @@ cabal-dev/
3*.ibc
3*.ibc
4*.o
4*.o
5*.a
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+
CHANGELOG+2
@@ -9,10 +9,12 @@ User visible changes:
9* Tab completion in REPL
9* Tab completion in REPL
10* Dynamic loading of C libraries in the interpreter
10* Dynamic loading of C libraries in the interpreter
11* Testing IO actions at the REPL with :x command
11* Testing IO actions at the REPL with :x command
12+* Improve rendering of :t
12* Fixed some INTERNAL ERROR messages
13* Fixed some INTERNAL ERROR messages
13
14
14Internal changes:
15Internal changes:
15
16
17+* Fix non-linear pattern checking
16* Improved name disambiguation
18* Improved name disambiguation
17* More flexible unification and elaboration of lambdas
19* More flexible unification and elaboration of lambdas
18* Various unification and totality checking bug fixes
20* Various unification and totality checking bug fixes
Makefile+2−2
@@ -17,8 +17,8 @@ test:
17 make -C test
17 make -C test
18
18
19relib:
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 $(CABAL) install $(CABALFLAGS)
22 $(CABAL) install $(CABALFLAGS)
23
23
24linecount:
24linecount:
Setup.hs+6−3
@@ -28,8 +28,11 @@ mvn verbosity = P.runProgramInvocation verbosity . P.simpleProgramInvocation "mv
28(<//>) = (Px.</>)
28(<//>) = (Px.</>)
29idrisCmd local = Px.joinPath $ splitDirectories $
29idrisCmd local = Px.joinPath $ splitDirectories $
30 ".." <//> buildDir local <//> "idris" <//> "idris"
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
@@ -103,9 +106,9 @@ checkStdLib local withoutEffects verbosity
103 ]
106 ]
104 unless withoutEffects $
107 unless withoutEffects $
105 make verbosity
108 make verbosity
106− [ "-C", "effects", "check"
109+ [ "-C", "effects", "check"
107− , "IDRIS=" ++ icmd
110+ , "IDRIS=" ++ icmd
108− ]
111+ ]
109 make verbosity
112 make verbosity
110 [ "-C", "rts", "check"
113 [ "-C", "rts", "check"
111 , "IDRIS=" ++ icmd
114 , "IDRIS=" ++ icmd
config.mk+26
@@ -7,3 +7,29 @@ CABAL :=cabal
7## Disable building of Effects
7## Disable building of Effects
8#CABALFLAGS :=-f NoEffects
8#CABALFLAGS :=-f NoEffects
9
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
35+
contribs/lib/SQLite3/Makefile+1−1
@@ -3,7 +3,7 @@
3
3
4.PHONY: all
4.PHONY: all
5
5
6−sqltest : testunit.idr sqlite3.idr sqlite3api.o
6+sqltest : testunit.idr Sqlite3.idr sqlite3api.o
7 idris testunit.idr -o sqltest
7 idris testunit.idr -o sqltest
8
8
9sqlite3api.o : sqlite3api.c
9sqlite3api.o : sqlite3api.c
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
22 | DBText String
23 | DBFloat Float
23 | DBFloat Float
24 | DBNull
24 | DBNull
25−
25+
26-- Database pointer
26-- Database pointer
27data DBPointer = MkDBPointer Ptr
27data DBPointer = MkDBPointer Ptr
28-- Table pointer
28-- Table pointer
@@ -30,16 +30,29 @@ data TBPointer = MkTBPointer Ptr
30-- Statement pointer
30-- Statement pointer
31data StmtPtr = MkStmtPtr Ptr
31data StmtPtr = MkStmtPtr Ptr
32
32
33−Table : Set
33+Table : Type
34Table = List (List DBVal)
34Table = List (List DBVal)
35
35
36-- ForMap used in to_list_v1
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
39
40-- Neater error handling done using DB
40-- Neater error handling done using DB
41data DB a = MkDB (IO (Either String a))
41data DB a = MkDB (IO (Either String a))
42
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
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 ITNative] 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 ITNative, FAny Bits8, FInt ITNative] 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 ITNative, FInt ITNative, FInt ITNative] 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 ITNative] (FInt ITNative)) ptr (cast offset)
69+ bs <- do_peek ptr (S offset) n
70+ Prelude.Monad.return (Prelude.Vect.(::) (prim__intToB8 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 ITNative, FAny Bits8] 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/Makefile+1−1
@@ -4,7 +4,7 @@ check: .PHONY
4
4
5recheck: clean check
5recheck: clean check
6
6
7−install:
7+install:
8 $(IDRIS) --install effects.ipkg
8 $(IDRIS) --install effects.ipkg
9
9
10clean: .PHONY
10clean: .PHONY
effects/effects.ipkg+3−1
@@ -3,4 +3,6 @@ package effects
3opts = "-i ../lib"
3opts = "-i ../lib"
4modules = Effects,
4modules = Effects,
5 Effect.Exception, Effect.File, Effect.State,
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+6−2
@@ -1,5 +1,5 @@
1Name: idris
1Name: idris
2−Version: 0.9.7
2+Version: 0.9.8
3License: BSD3
3License: BSD3
4License-file: LICENSE
4License-file: LICENSE
5Author: Edwin Brady
5Author: Edwin Brady
@@ -58,6 +58,7 @@ Extra-source-files: lib/Makefile lib/*.idr lib/Prelude/*.idr
58 lib/Control/Monad/*.idr lib/Language/*.idr
58 lib/Control/Monad/*.idr lib/Language/*.idr
59 lib/System/Concurrency/*.idr
59 lib/System/Concurrency/*.idr
60 lib/Data/*.idr lib/Debug/*.idr
60 lib/Data/*.idr lib/Debug/*.idr
61+ lib/Data/Vect/*.idr
61 lib/Decidable/*.idr
62 lib/Decidable/*.idr
62 tutorial/examples/*.idr lib/base.ipkg
63 tutorial/examples/*.idr lib/base.ipkg
63 effects/Makefile effects/*.idr effects/Effect/*.idr
64 effects/Makefile effects/*.idr effects/Effect/*.idr
@@ -111,7 +112,7 @@ Executable idris
111 haskeline>=0.7, split, directory,
112 haskeline>=0.7, split, directory,
112 containers, process, transformers, filepath,
113 containers, process, transformers, filepath,
113 directory, binary, bytestring, text, pretty,
114 directory, binary, bytestring, text, pretty,
114− language-java>=0.2.2, libffi, unix
115+ language-java>=0.2.2, libffi
115
116
116 Extensions: MultiParamTypeClasses, FunctionalDependencies,
117 Extensions: MultiParamTypeClasses, FunctionalDependencies,
117 FlexibleInstances, TemplateHaskell
118 FlexibleInstances, TemplateHaskell
@@ -119,7 +120,10 @@ Executable idris
119 ghc-options: -rtsopts
120 ghc-options: -rtsopts
120 if os(linux)
121 if os(linux)
121 cpp-options: -DLINUX
122 cpp-options: -DLINUX
123+ build-depends: unix
122 if os(darwin)
124 if os(darwin)
123 cpp-options: -DMACOSX
125 cpp-options: -DMACOSX
126+ build-depends: unix
124 if os(windows)
127 if os(windows)
125 cpp-options: -DWINDOWS
128 cpp-options: -DWINDOWS
129+ 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);
191 return (o == null ? 1 : 0);
192 }
192 }
193
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 }
js/Runtime-common.js+2
@@ -10,8 +10,10 @@ __IDRRT__.Char = new __IDRRT__.Type('Char');
10__IDRRT__.String = new __IDRRT__.Type('String');
10__IDRRT__.String = new __IDRRT__.Type('String');
11__IDRRT__.Integer = new __IDRRT__.Type('Integer');
11__IDRRT__.Integer = new __IDRRT__.Type('Integer');
12__IDRRT__.Float = new __IDRRT__.Type('Float');
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 };
17
19
lib/Builtins.idr+3
@@ -44,6 +44,9 @@ really_believe_me x = prim__believe_me _ _ x
44
44
45namespace Builtins {
45namespace Builtins {
46
46
47+Not : Type -> Type
48+Not a = a -> _|_
49+
47id : a -> a
50id : a -> a
48id x = x
51id x = x
49
52
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/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 _ 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+19
@@ -0,0 +1,19 @@
1+module Decidable.Decidable
2+
3+%access public
4+
5+--------------------------------------------------------------------------------
6+-- Typeclass for decidable n-ary Relations
7+--------------------------------------------------------------------------------
8+
9+using (t : Type)
10+ class Rel (p : t) where
11+ total liftRel : (Type -> Type) -> Type
12+
13+ class (Rel p) => Decidable (p : t) where
14+ total decide : liftRel Dec
15+
16+using (P : Type, p : P)
17+ data Given : Dec P -> Type where
18+ always : Given (Yes p)
19+
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
75leftNotRight refl impossible
76
76
77instance (DecEq a, DecEq b) => DecEq (Either a b) where
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
79 | Yes p = Yes $ cong p
80 | No p = No $ \h : Left x' = Left y' => p $ leftInjective {b = b} h
80 | No p = No $ \h : Left x' = Left y' => p $ leftInjective {b = b} h
81 decEq (Right x') (Right y') with (decEq x' y')
81 decEq (Right x') (Right y') with (decEq x' y')
lib/Decidable/Order.idrnew file+77
@@ -0,0 +1,77 @@
1+module Decidable.Order
2+
3+import Decidable.Decidable
4+import Decidable.Equality
5+
6+--------------------------------------------------------------------------------
7+-- Utility Lemmas
8+--------------------------------------------------------------------------------
9+
10+--------------------------------------------------------------------------------
11+-- Preorders and Posets
12+--------------------------------------------------------------------------------
13+
14+class Preorder t (po : t -> t -> Type) where
15+ total transitive : (a : t) -> (b : t) -> (c : t) -> po a b -> po b c -> po a c
16+ total reflexive : (a : t) -> po a a
17+
18+class (Preorder t po) => Poset t (po : t -> t -> Type) where
19+ total antisymmetric : (a : t) -> (b : t) -> po a b -> po b a -> a = b
20+
21+--------------------------------------------------------------------------------
22+-- Natural numbers
23+--------------------------------------------------------------------------------
24+
25+data NatLTE : Nat -> Nat -> Type where
26+ nEqn : NatLTE n n
27+ nLTESm : NatLTE n m -> NatLTE n (S m)
28+
29+total NatLTEIsTransitive : (m : Nat) -> (n : Nat) -> (o : Nat) ->
30+ NatLTE m n -> NatLTE n o ->
31+ NatLTE m o
32+NatLTEIsTransitive m n n mLTEn (nEqn) = mLTEn
33+NatLTEIsTransitive m n (S o) mLTEn (nLTESm nLTEo)
34+ = nLTESm (NatLTEIsTransitive m n o mLTEn nLTEo)
35+
36+total NatLTEIsReflexive : (n : Nat) -> NatLTE n n
37+NatLTEIsReflexive _ = nEqn
38+
39+instance Preorder Nat NatLTE where
40+ transitive = NatLTEIsTransitive
41+ reflexive = NatLTEIsReflexive
42+
43+total NatLTEIsAntisymmetric : (m : Nat) -> (n : Nat) -> po m n -> po n m -> m = n
44+NatLTEIsAntisymmetric n n nEqn nEqn = refl
45+NatLTEIsAntisymmetric n m nEqn (nLTESm _) impossible
46+NatLTEIsAntisymmetric n m (nLTESm _) nEqn impossible
47+
48+instance Poset Nat NatLTE where
49+ antisymmetric = NatLTEIsAntisymmetric
50+
51+total zeroNeverGreater : {n : Nat} -> NatLTE (S n) O -> _|_
52+zeroNeverGreater {n} (nLTESm _) impossible
53+zeroNeverGreater {n} nEqn impossible
54+
55+total
56+nGTSm : {n : Nat} -> {m : Nat} -> (NatLTE n m -> _|_) -> NatLTE n (S m) -> _|_
57+nGTSm disprf (nLTESm nLTEm) = FalseElim (disprf nLTEm)
58+nGTSm {n} {m} disprf (nEqn) impossible
59+
60+total
61+decideNatLTE : (n : Nat) -> (m : Nat) -> Dec (NatLTE n m)
62+decideNatLTE O O = Yes nEqn
63+decideNatLTE (S x) O = No zeroNeverGreater
64+decideNatLTE x (S y) with (decEq x (S y))
65+ | Yes eq = rewrite eq in Yes nEqn
66+ | No _ with (decideNatLTE x y)
67+ | Yes nLTEm = Yes (nLTESm nLTEm)
68+ | No nGTm = No (nGTSm nGTm)
69+
70+instance Rel NatLTE where
71+ liftRel P = (n : Nat) -> (m : Nat) -> P (NatLTE n m)
72+
73+instance Decidable NatLTE where
74+ decide = decideNatLTE
75+
76+lte : (m : Nat) -> (n : Nat) -> Dec (NatLTE m n)
77+lte m n = decide {p = NatLTE} m n
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/Prelude.idr+11−2
@@ -178,6 +178,15 @@ atan x = prim__floatATan x
178atan2 : Float -> Float -> Float
178atan2 : Float -> Float -> Float
179atan2 y x = atan (y/x)
179atan2 y x = atan (y/x)
180
180
181+sinh : Float -> Float
182+sinh x = (exp x - exp (-x)) / 2
183+
184+cosh : Float -> Float
185+cosh x = (exp x + exp (-x)) / 2
186+
187+tanh : Float -> Float
188+tanh x = sinh x / cosh x
189+
181sqrt : Float -> Float
190sqrt : Float -> Float
182sqrt x = prim__floatSqrt x
191sqrt x = prim__floatSqrt x
183
192
@@ -189,12 +198,12 @@ ceiling x = prim__floatCeil x
189
198
190---- Ranges
199---- Ranges
191
200
192−%assert_total
201+partial abstract
193count : (Ord a, Num a) => a -> a -> a -> List a
202count : (Ord a, Num a) => a -> a -> a -> List a
194count a inc b = if a <= b then a :: count (a + inc) inc b
203count a inc b = if a <= b then a :: count (a + inc) inc b
195 else []
204 else []
196
205
197−partial
206+partial abstract
198countFrom : (Ord a, Num a) => a -> a -> List a
207countFrom : (Ord a, Num a) => a -> a -> List a
199countFrom a inc = a :: lazy (countFrom (a + inc) inc)
208countFrom a inc = a :: lazy (countFrom (a + inc) inc)
200
209
lib/Providers.idr+4−3
@@ -1,8 +1,9 @@
1module Providers
1module Providers
2
2
3public
3public
4−data Provider a = Provide (IO a) | Error (IO String)
4+data Provider a = Provide a | Error String
5
5
6partial public
6partial public
7−unProv : Provider a -> a
7+unProv : IO (Provider a) -> a
8−unProv (Provide x) = unsafePerformIO x
8+unProv p = case unsafePerformIO p of
9+ Provide x => x
lib/base.ipkg+4−2
@@ -13,15 +13,17 @@ modules = Builtins, Prelude, IO, System,
13
13
14 System.Concurrency.Raw, System.Concurrency.Process,
14 System.Concurrency.Raw, System.Concurrency.Process,
15
15
16− Decidable.Equality,
16+ Decidable.Equality, Decidable.Decidable, Decidable.Order,
17
17
18 Uninhabited,
18 Uninhabited,
19
19
20 Providers,
20 Providers,
21
21
22− Language.Reflection,
22+ Language.Reflection, Language.Reflection.Utils,
23
23
24 Data.Morphisms, Data.Bits, Data.Mod2, Data.Z, Data.Sign,
24 Data.Morphisms, Data.Bits, Data.Mod2, Data.Z, Data.Sign,
25+ Data.SortedMap, Data.SortedSet, Data.BoundedList,
26+ Data.Vect.Quantifiers,
25
27
26 Control.Monad.Identity, Control.Monad.State, Control.Category,
28 Control.Monad.Identity, Control.Monad.State, Control.Category,
27 Control.Arrow,
29 Control.Arrow,
rts/Makefile+4−4
@@ -2,15 +2,15 @@ include ../config.mk
2
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
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
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
6
7ifneq ($(GMP_INCLUDE_DIR),)
7ifneq ($(GMP_INCLUDE_DIR),)
8− CFLAGS += -isystem $(GMP_INCLUDE_DIR)
8+ CFLAGS += -isystem $(GMP_INCLUDE_DIR)
9endif
9endif
10
10
11LIBTARGET = libidris_rts.a
11LIBTARGET = libidris_rts.a
12
12
13−check : $(LIBTARGET)
13+check : $(LIBTARGET) $(DYLIBTARGET)
14
14
15$(LIBTARGET) : $(OBJS)
15$(LIBTARGET) : $(OBJS)
16 ar r $(LIBTARGET) $(OBJS)
16 ar r $(LIBTARGET) $(OBJS)
@@ -21,7 +21,7 @@ install : .PHONY
21 install $(LIBTARGET) $(HDRS) $(TARGET)
21 install $(LIBTARGET) $(HDRS) $(TARGET)
22
22
23clean : .PHONY
23clean : .PHONY
24− rm -f $(OBJS) $(LIBTARGET)
24+ rm -f $(OBJS) $(LIBTARGET) $(DYLIBTARGET)
25
25
26idris_rts.o: idris_rts.h
26idris_rts.o: idris_rts.h
27
27
rts/idris_rts.c+45
@@ -186,6 +186,34 @@ VAL MKPTRc(VM* vm, void* ptr) {
186 return cl;
186 return cl;
187}
187}
188
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,23 @@ void dumpVal(VAL v) {
243
271
244}
272}
245
273
274+void idris_memset(void* ptr, i_int offset, VAL c, i_int size) {
275+ memset(((uint8_t*)ptr) + offset, c->info.bits8, size);
276+}
277+
278+int idris_peek(void* ptr, i_int offset) {
279+ uint8_t res = *(((uint8_t*)ptr) + offset);
280+ return (int)res;
281+}
282+
283+void idris_poke(void* ptr, i_int offset, VAL data) {
284+ *(((uint8_t*)ptr) + offset) = data->info.bits8;
285+}
286+
287+void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size) {
288+ memmove(dest + dest_offset, src + src_offset, size);
289+}
290+
246VAL idris_castIntStr(VM* vm, VAL i) {
291VAL idris_castIntStr(VM* vm, VAL i) {
247 Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0);
292 Closure* cl = allocate(vm, sizeof(Closure) + sizeof(char)*16, 0);
248 SETTY(cl, STRING);
293 SETTY(cl, STRING);
rts/idris_rts.h+10
@@ -148,6 +148,10 @@ typedef intptr_t i_int;
148VAL MKFLOAT(VM* vm, double val);
148VAL MKFLOAT(VM* vm, double val);
149VAL MKSTR(VM* vm, char* str);
149VAL MKSTR(VM* vm, char* str);
150VAL 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);
151
155
152// following versions don't take a lock when allocating
156// following versions don't take a lock when allocating
153VAL MKFLOATc(VM* vm, double val);
157VAL MKFLOATc(VM* vm, double val);
@@ -203,6 +207,12 @@ VAL idris_castStrInt(VM* vm, VAL i);
203VAL idris_castFloatStr(VM* vm, VAL i);
207VAL idris_castFloatStr(VM* vm, VAL i);
204VAL idris_castStrFloat(VM* vm, VAL i);
208VAL idris_castStrFloat(VM* vm, VAL i);
205
209
210+// Raw memory manipulation
211+void idris_memset(void* ptr, i_int offset, VAL c, i_int size);
212+int idris_peek(void* ptr, i_int offset);
213+void idris_poke(void* ptr, i_int offset, VAL data);
214+void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size);
215+
206// String primitives
216// String primitives
207
217
208VAL 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
8
9void* fileOpen(char* f, char* mode);
9void* fileOpen(char* f, char* mode);
10void fileClose(void* h);
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);
src/Core/CaseTree.hs+4−4
@@ -14,11 +14,11 @@ import Debug.Trace
14data CaseDef = CaseDef [Name] SC [Term]
14data CaseDef = CaseDef [Name] SC [Term]
15 deriving Show
15 deriving Show
16
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
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)
22 deriving (Eq, Ord, Functor)
23{-!
23{-!
24deriving instance Binary SC
24deriving instance Binary SC
src/Core/CoreParser.hs+1−1
@@ -466,7 +466,7 @@ idrisMakeTokenParser languageDef
466
466
467 number base baseDigit
467 number base baseDigit
468 = do{ digits <- many1 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)
470 ; seq n (return n)
471 }
471 }
472
472
src/Core/Elaborate.hs+16−3
@@ -171,7 +171,7 @@ checkInjective (tm, l, r) = do ctxt <- get_context
171 if isInj ctxt tm then return ()
171 if isInj ctxt tm then return ()
172 else lift $ tfail (NotInjective tm l r)
172 else lift $ tfail (NotInjective tm l r)
173 where isInj ctxt (P _ n _)
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
175 isInj ctxt (App f a) = isInj ctxt f
176 isInj ctxt (Constant _) = True
176 isInj ctxt (Constant _) = True
177 isInj ctxt (TType _) = True
177 isInj ctxt (TType _) = True
@@ -210,7 +210,7 @@ unique_hole' reusable n
210uniqueNameCtxt :: Context -> Name -> [Name] -> Elab' aux Name
210uniqueNameCtxt :: Context -> Name -> [Name] -> Elab' aux Name
211uniqueNameCtxt ctxt n hs
211uniqueNameCtxt ctxt n hs
212 | n `elem` hs = uniqueNameCtxt ctxt (nextName 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
214 | otherwise = return n
215
215
216elog :: String -> Elab' aux ()
216elog :: String -> Elab' aux ()
@@ -356,7 +356,7 @@ prepare_apply fn imps =
356 mkClaims _ _ _ _
356 mkClaims _ _ _ _
357 | Var n <- fn
357 | Var n <- fn
358 = do ctxt <- get_context
358 = do ctxt <- get_context
359− case lookupTy Nothing n ctxt of
359+ case lookupTy n ctxt of
360 [] -> lift $ tfail $ NoSuchVariable n
360 [] -> lift $ tfail $ NoSuchVariable n
361 _ -> fail $ "Too many arguments for " ++ show fn
361 _ -> fail $ "Too many arguments for " ++ show fn
362 | otherwise = fail $ "Too many arguments for " ++ show fn
362 | otherwise = fail $ "Too many arguments for " ++ show fn
@@ -525,6 +525,19 @@ arg n tyhole = do ty <- unique_hole tyhole
525 claim ty RType
525 claim ty RType
526 forall n (Var ty)
526 forall n (Var ty)
527
527
528+-- try a tactic, if it adds any unification problem, return an error
529+no_errors :: Elab' aux () -> Elab' aux ()
530+no_errors tac
531+ = do ps <- get_probs
532+ tac
533+ ps' <- get_probs
534+ if (length ps' > length ps) then
535+ case reverse ps' of
536+ ((x,y,env,err) : _) ->
537+ let env' = map (\(x, b) -> (x, binderTy b)) env in
538+ lift $ tfail $ CantUnify False x y err env' 0
539+ else return ()
540+
528-- Try a tactic, if it fails, try another
541-- Try a tactic, if it fails, try another
529try :: Elab' aux a -> Elab' aux a -> Elab' aux a
542try :: Elab' aux a -> Elab' aux a -> Elab' aux a
530try t1 t2 = try' t1 t2 False
543try t1 t2 = try' t1 t2 False
src/Core/Evaluate.hs+34−34
@@ -9,7 +9,7 @@ module Core.Evaluate(normalise, normaliseTrace, normaliseC, normaliseAll,
9 addDatatype, addCasedef, simplifyCasedef, addOperator,
9 addDatatype, addCasedef, simplifyCasedef, addOperator,
10 lookupNames, lookupTy, lookupP, lookupDef, lookupVal,
10 lookupNames, lookupTy, lookupP, lookupDef, lookupVal,
11 lookupTotal, lookupTyEnv, isConName, isFnName,
11 lookupTotal, lookupTyEnv, isConName, isFnName,
12− Value(..)) where
12+ Value(..), Quote(..), evalState, initEval) where
13
13
14import Debug.Trace
14import Debug.Trace
15import Control.Monad.State
15import Control.Monad.State
@@ -149,7 +149,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
149 ev ntimes_in stk top env (P Ref n ty)
149 ev ntimes_in stk top env (P Ref n ty)
150 | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty)
150 | not top && hnf = liftM (VP Ref n) (ev ntimes stk top env ty)
151 | (True, ntimes) <- usable simpl n ntimes_in
151 | (True, ntimes) <- usable simpl n ntimes_in
152− = do let val = lookupDefAcc Nothing n atRepl ctxt
152+ = do let val = lookupDefAcc n atRepl ctxt
153 case val of
153 case val of
154 [(Function _ tm, Public)] ->
154 [(Function _ tm, Public)] ->
155 ev ntimes (n:stk) True env tm
155 ev ntimes (n:stk) True env tm
@@ -220,7 +220,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
220 _ -> return $ unload env f args
220 _ -> return $ unload env f args
221 | (True, ntimes) <- usable simpl n ntimes_in
221 | (True, ntimes) <- usable simpl n ntimes_in
222 = traceWhen traceon (show stk) $
222 = traceWhen traceon (show stk) $
223− do let val = lookupDefAcc Nothing n atRepl ctxt
223+ do let val = lookupDefAcc n atRepl ctxt
224 case val of
224 case val of
225 [(CaseOp inl inr _ _ _ ns tree _ _, acc)]
225 [(CaseOp inl inr _ _ _ ns tree _ _, acc)]
226 | acc == Public -> -- unoptimised version
226 | acc == Public -> -- unoptimised version
@@ -243,7 +243,7 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
243 apply ntimes stk top env f [] = return f
243 apply ntimes stk top env f [] = return f
244
244
245-- specApply stk env f@(VP Ref n ty) args
245-- specApply stk env f@(VP Ref n ty) args
246−-- = case lookupCtxt Nothing n statics of
246+-- = case lookupCtxt n statics of
247-- [as] -> if or as
247-- [as] -> if or as
248-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $
248-- then trace (show (n, map fst (filter (\ (_, s) -> s) (zip args as)))) $
249-- return $ unload env f args
249-- return $ unload env f args
@@ -397,7 +397,7 @@ eval_hnf ctxt statics genv tm = ev [] tm where
397 ev :: [HNF] -> TT Name -> Eval HNF
397 ev :: [HNF] -> TT Name -> Eval HNF
398 ev env (P _ n ty)
398 ev env (P _ n ty)
399 | Just (Let t v) <- lookup n genv = ev env v
399 | Just (Let t v) <- lookup n genv = ev env v
400− ev env (P Ref n ty) = case lookupDef Nothing n ctxt of
400+ ev env (P Ref n ty) = case lookupDef n ctxt of
401 [Function _ t] -> ev env t
401 [Function _ t] -> ev env t
402 [TyDecl nt ty] -> return $ HP nt n ty
402 [TyDecl nt ty] -> return $ HP nt n ty
403 [CaseOp inl _ _ _ _ [] tree _ _] ->
403 [CaseOp inl _ _ _ _ [] tree _ _] ->
@@ -430,7 +430,7 @@ eval_hnf ctxt statics genv tm = ev [] tm where
430 app <- apply env sc' as
430 app <- apply env sc' as
431 wknH (-1) app
431 wknH (-1) app
432 apply env (HP Ref n ty) args
432 apply env (HP Ref n ty) args
433− | [CaseOp _ _ _ _ _ ns tree _ _] <- lookupDef Nothing n ctxt
433+ | [CaseOp _ _ _ _ _ ns tree _ _] <- lookupDef n ctxt
434 = do c <- evCase env ns args tree
434 = do c <- evCase env ns args tree
435 case c of
435 case c of
436 (Nothing, _, env') -> return $ unload env' (HP Ref n ty) args
436 (Nothing, _, env') -> return $ unload env' (HP Ref n ty) args
@@ -565,7 +565,7 @@ convEq ctxt = ceq [] where
565 caseeq ps (UnmatchedCase _) (UnmatchedCase _) = return True
565 caseeq ps (UnmatchedCase _) (UnmatchedCase _) = return True
566 caseeq ps _ _ = return False
566 caseeq ps _ _ = return False
567
567
568− sameDefs ps x y = case (lookupDef Nothing x ctxt, lookupDef Nothing y ctxt) of
568+ sameDefs ps x y = case (lookupDef x ctxt, lookupDef y ctxt) of
569 ([Function _ xdef], [Function _ ydef])
569 ([Function _ xdef], [Function _ ydef])
570 -> ceq ((x,y):ps) xdef ydef
570 -> ceq ((x,y):ps) xdef ydef
571 ([CaseOp _ _ _ _ _ _ xdef _ _],
571 ([CaseOp _ _ _ _ _ _ xdef _ _],
@@ -669,7 +669,7 @@ data Context = MkContext {
669 uconstraints :: [UConstraint],
669 uconstraints :: [UConstraint],
670 next_tvar :: Int,
670 next_tvar :: Int,
671 definitions :: Ctxt (Def, Accessibility, Totality)
671 definitions :: Ctxt (Def, Accessibility, Totality)
672− }
672+ } deriving Show
673
673
674-- | The initial empty context
674-- | The initial empty context
675initContext = MkContext [] 0 emptyContext
675initContext = MkContext [] 0 emptyContext
@@ -730,7 +730,7 @@ addCasedef :: Name -> Bool -> Bool -> Bool -> Bool ->
730 Type -> Context -> Context
730 Type -> Context -> Context
731addCasedef n alwaysInline tcase covering asserted ps_in ps psrt ty uctxt
731addCasedef n alwaysInline tcase covering asserted ps_in ps psrt ty uctxt
732 = let ctxt = definitions uctxt
732 = let ctxt = definitions uctxt
733− access = case lookupDefAcc Nothing n False uctxt of
733+ access = case lookupDefAcc n False uctxt of
734 [(_, acc)] -> acc
734 [(_, acc)] -> acc
735 _ -> Public
735 _ -> Public
736 ctxt' = case (simpleCase tcase covering CompileTime (FC "" 0) ps,
736 ctxt' = case (simpleCase tcase covering CompileTime (FC "" 0) ps,
@@ -747,7 +747,7 @@ addCasedef n alwaysInline tcase covering asserted ps_in ps psrt ty uctxt
747simplifyCasedef :: Name -> Context -> Context
747simplifyCasedef :: Name -> Context -> Context
748simplifyCasedef n uctxt
748simplifyCasedef n uctxt
749 = let ctxt = definitions uctxt
749 = let ctxt = definitions uctxt
750− ctxt' = case lookupCtxt Nothing n ctxt of
750+ ctxt' = case lookupCtxt n ctxt of
751 [(CaseOp inl inr ty [] ps args sc args' sc', acc, tot)] ->
751 [(CaseOp inl inr ty [] ps args sc args' sc', acc, tot)] ->
752 ctxt -- nothing to simplify (or already done...)
752 ctxt -- nothing to simplify (or already done...)
753 [(CaseOp inl inr ty ps_in ps args sc args' sc', acc, tot)] ->
753 [(CaseOp inl inr ty ps_in ps args sc args' sc', acc, tot)] ->
@@ -780,40 +780,40 @@ addOperator n ty a op uctxt
780
780
781tfst (a, _, _) = a
781tfst (a, _, _) = a
782
782
783−lookupNames :: Maybe [String] -> Name -> Context -> [Name]
783+lookupNames :: Name -> Context -> [Name]
784−lookupNames root n ctxt
784+lookupNames n ctxt
785− = let ns = lookupCtxtName root n (definitions ctxt) in
785+ = let ns = lookupCtxtName n (definitions ctxt) in
786 map fst ns
786 map fst ns
787
787
788−lookupTy :: Maybe [String] -> Name -> Context -> [Type]
788+lookupTy :: Name -> Context -> [Type]
789−lookupTy root n ctxt
789+lookupTy n ctxt
790− = do def <- lookupCtxt root n (definitions ctxt)
790+ = do def <- lookupCtxt n (definitions ctxt)
791 case tfst def of
791 case tfst def of
792 (Function ty _) -> return ty
792 (Function ty _) -> return ty
793 (TyDecl _ ty) -> return ty
793 (TyDecl _ ty) -> return ty
794 (Operator ty _ _) -> return ty
794 (Operator ty _ _) -> return ty
795 (CaseOp _ _ ty _ _ _ _ _ _) -> return ty
795 (CaseOp _ _ ty _ _ _ _ _ _) -> return ty
796
796
797−isConName :: Maybe [String] -> Name -> Context -> Bool
797+isConName :: Name -> Context -> Bool
798−isConName root n ctxt
798+isConName n ctxt
799− = or $ do def <- lookupCtxt root n (definitions ctxt)
799+ = or $ do def <- lookupCtxt n (definitions ctxt)
800 case tfst def of
800 case tfst def of
801 (TyDecl (DCon _ _) _) -> return True
801 (TyDecl (DCon _ _) _) -> return True
802 (TyDecl (TCon _ _) _) -> return True
802 (TyDecl (TCon _ _) _) -> return True
803 _ -> return False
803 _ -> return False
804
804
805−isFnName :: Maybe [String] -> Name -> Context -> Bool
805+isFnName :: Name -> Context -> Bool
806−isFnName root n ctxt
806+isFnName n ctxt
807− = or $ do def <- lookupCtxt root n (definitions ctxt)
807+ = or $ do def <- lookupCtxt n (definitions ctxt)
808 case tfst def of
808 case tfst def of
809 (Function _ _) -> return True
809 (Function _ _) -> return True
810 (Operator _ _ _) -> return True
810 (Operator _ _ _) -> return True
811 (CaseOp _ _ _ _ _ _ _ _ _) -> return True
811 (CaseOp _ _ _ _ _ _ _ _ _) -> return True
812 _ -> return False
812 _ -> return False
813
813
814−lookupP :: Maybe [String] -> Name -> Context -> [Term]
814+lookupP :: Name -> Context -> [Term]
815−lookupP root n ctxt
815+lookupP n ctxt
816− = do def <- lookupCtxt root n (definitions ctxt)
816+ = do def <- lookupCtxt n (definitions ctxt)
817 p <- case def of
817 p <- case def of
818 (Function ty tm, a, _) -> return (P Ref n ty, a)
818 (Function ty tm, a, _) -> return (P Ref n ty, a)
819 (TyDecl nt ty, a, _) -> return (P nt n ty, a)
819 (TyDecl nt ty, a, _) -> return (P nt n ty, a)
@@ -823,22 +823,22 @@ lookupP root n ctxt
823 Hidden -> []
823 Hidden -> []
824 _ -> return (fst p)
824 _ -> return (fst p)
825
825
826−lookupDef :: Maybe [String] -> Name -> Context -> [Def]
826+lookupDef :: Name -> Context -> [Def]
827−lookupDef root n ctxt = map tfst $ lookupCtxt root n (definitions ctxt)
827+lookupDef n ctxt = map tfst $ lookupCtxt n (definitions ctxt)
828
828
829−lookupDefAcc :: Maybe [String] -> Name -> Bool -> Context ->
829+lookupDefAcc :: Name -> Bool -> Context ->
830 [(Def, Accessibility)]
830 [(Def, Accessibility)]
831−lookupDefAcc root n mkpublic ctxt
831+lookupDefAcc n mkpublic ctxt
832− = map mkp $ lookupCtxt root n (definitions ctxt)
832+ = map mkp $ lookupCtxt n (definitions ctxt)
833 where mkp (d, a, _) = if mkpublic then (d, Public) else (d, a)
833 where mkp (d, a, _) = if mkpublic then (d, Public) else (d, a)
834
834
835lookupTotal :: Name -> Context -> [Totality]
835lookupTotal :: Name -> Context -> [Totality]
836−lookupTotal n ctxt = map mkt $ lookupCtxt Nothing n (definitions ctxt)
836+lookupTotal n ctxt = map mkt $ lookupCtxt n (definitions ctxt)
837 where mkt (d, a, t) = t
837 where mkt (d, a, t) = t
838
838
839−lookupVal :: Maybe [String] -> Name -> Context -> [Value]
839+lookupVal :: Name -> Context -> [Value]
840−lookupVal root n ctxt
840+lookupVal n ctxt
841− = do def <- lookupCtxt root n (definitions ctxt)
841+ = do def <- lookupCtxt n (definitions ctxt)
842 case tfst def of
842 case tfst def of
843 (Function _ htm) -> return (veval ctxt [] htm)
843 (Function _ htm) -> return (veval ctxt [] htm)
844 (TyDecl nt ty) -> return (VP nt n (veval ctxt [] ty))
844 (TyDecl nt ty) -> return (VP nt n (veval ctxt [] ty))
src/Core/Execute.hs+438−76
@@ -1,3 +1,4 @@
1+{-# LANGUAGE PatternGuards, ExistentialQuantification #-}
1module Core.Execute (execute) where
2module Core.Execute (execute) where
2
3
3import Idris.AbsSyntax
4import Idris.AbsSyntax
@@ -5,104 +6,456 @@ import Idris.AbsSyntaxTree
5
6
6import Core.TT
7import Core.TT
7import Core.Evaluate
8import Core.Evaluate
9+import Core.CaseTree
8
10
9import Debug.Trace
11import Debug.Trace
10
12
11import Util.DynamicLinker
13import Util.DynamicLinker
14+import Util.System
12
15
13import Control.Applicative hiding (Const)
16import Control.Applicative hiding (Const)
14import Control.Monad.Trans
17import Control.Monad.Trans
18+import Control.Monad.Trans.State.Strict
19+import Control.Monad.Trans.Error
15import Control.Monad
20import Control.Monad
16import Data.Maybe
21import Data.Maybe
22+import qualified Data.Map as M
17
23
18import Foreign.LibFFI
24import Foreign.LibFFI
19import Foreign.C.String
25import Foreign.C.String
20import Foreign.Marshal.Alloc (free)
26import Foreign.Marshal.Alloc (free)
27+import Foreign.Ptr
28+
29+import System.IO
30+
31+
32+data Lazy = Delayed ExecEnv Context Term | Forced ExecVal deriving Show
33+
34+data ExecState = ExecState { exec_thunks :: M.Map Int Lazy -- ^ Thunks - the result of evaluating "lazy" or calling lazy funcs
35+ , exec_next_thunk :: Int -- ^ Ensure thunk key uniqueness
36+ , exec_implicits :: Ctxt [PArg] -- ^ Necessary info on laziness from idris monad
37+ , exec_dynamic_libs :: [DynamicLib] -- ^ Dynamic libs from idris monad
38+ }
39+
40+data ExecVal = EP NameType Name ExecVal
41+ | EV Int
42+ | EBind Name (Binder ExecVal) (ExecVal -> Exec ExecVal)
43+ | EApp ExecVal ExecVal
44+ | EType UExp
45+ | EErased
46+ | EConstant Const
47+ | forall a. EPtr (Ptr a)
48+ | EThunk Int
49+ | EHandle Handle
50+
51+instance Show ExecVal where
52+ show (EP _ n _) = show n
53+ show (EV i) = "!!V" ++ show i ++ "!!"
54+ show (EBind n b body) = "EBind " ++ show b ++ " <<fn>>"
55+ show (EApp e1 e2) = show e1 ++ " (" ++ show e2 ++ ")"
56+ show (EType _) = "Type"
57+ show EErased = "[__]"
58+ show (EConstant c) = show c
59+ show (EPtr p) = "<<ptr " ++ show p ++ ">>"
60+ show (EThunk i) = "<<thunk " ++ show i ++ ">>"
61+ show (EHandle h) = "<<handle " ++ show h ++ ">>"
62+
63+toTT :: ExecVal -> Exec Term
64+toTT (EP nt n ty) = (P nt n) <$> (toTT ty)
65+toTT (EV i) = return $ V i
66+toTT (EBind n b body) = do body' <- body $ EP Bound n EErased
67+ b' <- fixBinder b
68+ Bind n b' <$> toTT body'
69+ where fixBinder (Lam t) = Lam <$> toTT t
70+ fixBinder (Pi t) = Pi <$> toTT t
71+ fixBinder (Let t1 t2) = Let <$> toTT t1 <*> toTT t2
72+ fixBinder (NLet t1 t2) = NLet <$> toTT t1 <*> toTT t2
73+ fixBinder (Hole t) = Hole <$> toTT t
74+ fixBinder (GHole t) = GHole <$> toTT t
75+ fixBinder (Guess t1 t2) = Guess <$> toTT t1 <*> toTT t2
76+ fixBinder (PVar t) = PVar <$> toTT t
77+ fixBinder (PVTy t) = PVTy <$> toTT t
78+toTT (EApp e1 e2) = do e1' <- toTT e1
79+ e2' <- toTT e2
80+ return $ App e1' e2'
81+toTT (EType u) = return $ TType u
82+toTT EErased = return Erased
83+toTT (EConstant c) = return (Constant c)
84+toTT (EThunk i) = return (P (DCon 0 0) (MN i "THUNK") Erased) --(force i) >>= toTT
85+toTT (EHandle _) = return Erased
86+
87+unApplyV :: ExecVal -> (ExecVal, [ExecVal])
88+unApplyV tm = ua [] tm
89+ where ua args (EApp f a) = ua (a:args) f
90+ ua args t = (t, args)
91+
92+mkEApp :: ExecVal -> [ExecVal] -> ExecVal
93+mkEApp f [] = f
94+mkEApp f (a:args) = mkEApp (EApp f a) args
95+
96+initState :: Idris ExecState
97+initState = do ist <- getIState
98+ return $ ExecState M.empty 0 (idris_implicits ist) (idris_dynamic_libs ist)
99+
100+type Exec = ErrorT String (StateT ExecState IO)
101+
102+runExec :: Exec a -> ExecState -> IO (Either String a)
103+runExec ex st = fst <$> runStateT (runErrorT ex) st
104+
105+getExecState :: Exec ExecState
106+getExecState = lift get
107+
108+putExecState :: ExecState -> Exec ()
109+putExecState = lift . put
110+
111+execFail :: String -> Exec a
112+execFail = throwError
113+
114+execIO :: IO a -> Exec a
115+execIO = lift . lift
116+
117+delay :: ExecEnv -> Context -> Term -> Exec ExecVal
118+delay env ctxt tm =
119+ do st <- getExecState
120+ let i = exec_next_thunk st
121+ putExecState $ st { exec_thunks = M.insert i (Delayed env ctxt tm) (exec_thunks st)
122+ , exec_next_thunk = exec_next_thunk st + 1
123+ }
124+ return $ EThunk i
125+
126+force :: Int -> Exec ExecVal
127+force i = do st <- getExecState
128+ case M.lookup i (exec_thunks st) of
129+ Just (Delayed env ctxt tm) -> do tm' <- doExec env ctxt tm
130+ case tm' of
131+ EThunk i ->
132+ do res <- force i
133+ update res i
134+ return res
135+ _ -> do update tm' i
136+ return tm'
137+ Just (Forced tm) -> return tm
138+ Nothing -> execFail "Tried to exec non-existing thunk. This is a bug!"
139+ where update :: ExecVal -> Int -> Exec ()
140+ update tm i = do est <- getExecState
141+ putExecState $ est { exec_thunks = M.insert i (Forced tm) (exec_thunks est) }
142+
143+tryForce :: ExecVal -> Exec ExecVal
144+tryForce (EThunk i) = force i
145+tryForce tm = return tm
146+
147+debugThunks :: Exec ()
148+debugThunks = do st <- getExecState
149+ execIO $ putStrLn (take 4000 (show (exec_thunks st)))
150+
151+execute :: Term -> Idris Term
152+execute tm = do est <- initState
153+ ctxt <- getContext
154+ res <- lift $ flip runExec est $ do res <- doExec [] ctxt tm
155+ toTT res
156+ case res of
157+ Left err -> fail err
158+ Right tm' -> return tm'
159+
160+ioWrap :: ExecVal -> ExecVal
161+ioWrap tm = mkEApp (EP (DCon 0 2) (UN "prim__IO") EErased) [EErased, tm]
162+
163+ioUnit :: ExecVal
164+ioUnit = ioWrap (EP Ref unitCon EErased)
165+
166+type ExecEnv = [(Name, ExecVal)]
167+
168+doExec :: ExecEnv -> Context -> Term -> Exec ExecVal
169+doExec env ctxt p@(P Ref n ty) =
170+ do let val = lookupDef n ctxt
171+ case val of
172+ [Function _ tm] -> doExec env ctxt tm
173+ [TyDecl _ _] -> return (EP Ref n EErased) -- abstract def
174+ [Operator tp arity op] -> return (EP Ref n EErased) -- will be special-cased later
175+ [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun
176+ doExec env ctxt tm
177+ [CaseOp _ _ _ _ _ ns sc _ _] -> return (EP Ref n EErased)
178+ thing -> trace (take 200 $ "got to " ++ show thing ++ " lookup up " ++ show n) $ undefined
179+doExec env ctxt p@(P Bound n ty) =
180+ case lookup n env of
181+ Nothing -> execFail "not found"
182+ Just tm -> return tm
183+doExec env ctxt (P (DCon a b) n _) = return (EP (DCon a b) n EErased)
184+doExec env ctxt (P (TCon a b) n _) = return (EP (TCon a b) n EErased)
185+doExec env ctxt v@(V i) | i < length env = return (snd (env !! i))
186+ | otherwise = execFail "env too small"
187+doExec env ctxt (Bind n (Let t v) body) = do v' <- doExec env ctxt v
188+ doExec ((n, v'):env) ctxt body
189+doExec env ctxt (Bind n (NLet t v) body) = trace "NLet" $ undefined
190+doExec env ctxt tm@(Bind n b body) = return $
191+ EBind n (fmap (\_->EErased) b)
192+ (\arg -> doExec ((n, arg):env) ctxt body)
193+doExec env ctxt a@(App _ _) = execApp env ctxt (unApply a)
194+doExec env ctxt (Constant c) = return (EConstant c)
195+doExec env ctxt (Proj tm i) = let (x, xs) = unApply tm in
196+ doExec env ctxt ((x:xs) !! i)
197+doExec env ctxt Erased = return EErased
198+doExec env ctxt Impossible = fail "Tried to execute an impossible case"
199+doExec env ctxt (TType u) = return (EType u)
200+
201+execApp :: ExecEnv -> Context -> (Term, [Term]) -> Exec ExecVal
202+execApp env ctxt (f, args) = do newF <- doExec env ctxt f
203+ laziness <- (++ repeat False) <$> (getLaziness newF)
204+ newArgs <- mapM argExec (zip args laziness)
205+ execApp' env ctxt newF newArgs
206+ where getLaziness (EP _ (UN "lazy") _) = return [False, True]
207+ getLaziness (EP _ n _) = do est <- getExecState
208+ let argInfo = exec_implicits est
209+ case lookupCtxtName n argInfo of
210+ [] -> return (repeat False)
211+ [ps] -> return $ map lazyarg (snd ps)
212+ many -> execFail $ "Ambiguous " ++ show n ++ ", found " ++ (take 200 $ show many)
213+ getLaziness _ = return (repeat False) -- ok due to zip above
214+ argExec :: (Term, Bool) -> Exec ExecVal
215+ argExec (tm, False) = doExec env ctxt tm
216+ argExec (tm, True) = delay env ctxt tm
217+
218+
219+execApp' :: ExecEnv -> Context -> ExecVal -> [ExecVal] -> Exec ExecVal
220+execApp' env ctxt v [] = return v -- no args is just a constant! can result from function calls
221+execApp' env ctxt (EP _ (UN "unsafePerformIO") _) (ty:action:rest) | (prim__IO, [_, v]) <- unApplyV action =
222+ execApp' env ctxt v rest
223+
224+execApp' env ctxt (EP _ (UN "io_bind") _) args@(_:_:v:k:rest) | (prim__IO, [_, v']) <- unApplyV v =
225+ do v'' <- tryForce v'
226+ res <- execApp' env ctxt k [v''] >>= tryForce
227+ execApp' env ctxt res rest
228+execApp' env ctxt con@(EP _ (UN "io_return") _) args@(tp:v:rest) =
229+ do v' <- tryForce v
230+ execApp' env ctxt (mkEApp con [tp, v']) rest
231+
232+-- Special cases arising from not having access to the C RTS in the interpreter
233+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str arg):rest)
234+ | Just (FFun "putStr" _ _) <- foreignFromTT fn = do execIO (putStr arg)
235+ execApp' env ctxt ioUnit rest
236+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:EConstant (Str f):EConstant (Str mode):rest)
237+ | Just (FFun "fileOpen" _ _) <- foreignFromTT fn = do m <- case mode of
238+ "r" -> return ReadMode
239+ "w" -> return WriteMode
240+ "a" -> return AppendMode
241+ "rw" -> return ReadWriteMode
242+ "wr" -> return ReadWriteMode
243+ "r+" -> return ReadWriteMode
244+ _ -> execFail ("Invalid mode for " ++ f ++ ": " ++ mode)
245+ h <- execIO $ openFile f m
246+ execApp' env ctxt (ioWrap (EHandle h)) rest
247+
248+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)
249+ | Just (FFun "fileEOF" _ _) <- foreignFromTT fn = do eofp <- execIO $ hIsEOF h
250+ let res = ioWrap (EConstant (I $ if eofp then 1 else 0))
251+ execApp' env ctxt res rest
252+
253+execApp' env ctxt (EP _ (UN "mkForeign") _) (_:fn:(EHandle h):rest)
254+ | Just (FFun "fileClose" _ _) <- foreignFromTT fn = do execIO $ hClose h
255+ execApp' env ctxt ioUnit rest
256+
257+
258+execApp' env ctxt f@(EP _ (UN "mkForeign") _) args@(ty:fn:xs) | Just (FFun _ argTs retT) <- foreignFromTT fn
259+ , length xs >= length argTs =
260+ do res <- stepForeign (ty:fn:take (length argTs) xs)
261+ case res of
262+ Nothing -> fail "Could not call foreign function"
263+ Just r -> return (mkEApp r (drop (length argTs) xs))
264+ | otherwise = return (mkEApp f args)
265+
266+execApp' env ctxt f@(EP _ n _) args =
267+ do let val = lookupDef n ctxt
268+ case val of
269+ [Function _ tm] -> fail "should already have been eval'd"
270+ [TyDecl nt ty] -> return $ mkEApp f args
271+ [Operator tp arity op] ->
272+ if length args >= arity
273+ then do args' <- mapM tryForce $ take arity args
274+ case getOp n args' of
275+ Just res -> do r <- res
276+ execApp' env ctxt r (drop arity args)
277+ Nothing -> return (mkEApp f args)
278+ else return (mkEApp f args)
279+ [CaseOp _ _ _ _ _ [] (STerm tm) _ _] -> -- nullary fun
280+ do rhs <- doExec env ctxt tm
281+ execApp' env ctxt rhs args
282+ [CaseOp _ _ _ _ _ ns sc _ _] ->
283+ do res <- execCase env ctxt ns sc args
284+ return $ fromMaybe (mkEApp f args) res
285+ thing -> return $ mkEApp f args
286+ where getOp :: Name -> [ExecVal] -> Maybe (Exec ExecVal)
287+ getOp (UN "prim__addInt") [EConstant (I i1), EConstant (I i2)] =
288+ primRes I (i1 + i2)
289+ getOp (UN "prim__charToInt") [EConstant (Ch c)] =
290+ primRes I (fromEnum c)
291+ getOp (UN "prim__concat") [EConstant (Str s1), EConstant (Str s2)] =
292+ primRes Str (s1 ++ s2)
293+ getOp (UN "prim__eqChar") [EConstant (Ch c1), EConstant (Ch c2)] =
294+ primResBool (c1 == c2)
295+ getOp (UN "prim__eqInt") [EConstant (I i1), EConstant (I i2)] =
296+ primResBool (i1 == i2)
297+ getOp (UN "prim__eqString") [EConstant (Str s1), EConstant (Str s2)] =
298+ primResBool (s1 == s2)
299+ getOp (UN "prim__intToFloat") [EConstant (I i)] =
300+ primRes Fl (fromRational (toRational i))
301+ getOp (UN "prim__intToStr") [EConstant (I i)] =
302+ primRes Str (show i)
303+ getOp (UN "prim__ltInt") [EConstant (I i1), EConstant (I i2)] =
304+ primResBool (i1 < i2)
305+ getOp (UN "prim__mulBigInt") [EConstant (BI i1), EConstant (BI i2)] =
306+ primRes BI (i1 * i2)
307+ getOp (UN "prim__mulFloat") [EConstant (Fl i1), EConstant (Fl i2)] =
308+ primRes Fl (i1 * i2)
309+ getOp (UN "prim__mulInt") [EConstant (I i1), EConstant (I i2)] =
310+ primRes I (i1 * i2)
311+ getOp (UN "prim__readString") [EP _ (UN "prim__stdin") _] =
312+ Just $ do line <- execIO getLine
313+ return (EConstant (Str line))
314+ getOp (UN "prim__readString") [EHandle h] =
315+ Just $ do contents <- execIO $ hGetLine h
316+ return (EConstant (Str contents))
317+ getOp (UN "prim__strCons") [EConstant (Ch c), EConstant (Str s)] =
318+ primRes Str (c:s)
319+ getOp (UN "prim__strHead") [EConstant (Str (c:s))] =
320+ primRes Ch c
321+ getOp (UN "prim__strRev") [EConstant (Str s)] =
322+ primRes Str (reverse s)
323+ getOp (UN "prim__strTail") [EConstant (Str (c:s))] =
324+ primRes Str s
325+ getOp (UN "prim__subFloat") [EConstant (Fl i1), EConstant (Fl i2)] =
326+ primRes Fl (i1 - i2)
327+ getOp (UN "prim__subInt") [EConstant (I i1), EConstant (I i2)] =
328+ primRes I (i1 - i2)
329+ getOp n args = trace ("No prim " ++ show n ++ " for " ++ take 1000 (show args)) Nothing
330+
331+ primRes :: (a -> Const) -> a -> Maybe (Exec ExecVal)
332+ primRes constr = Just . return . EConstant . constr
333+
334+ primResBool :: Bool -> Maybe (Exec ExecVal)
335+ primResBool b = primRes I (if b then 1 else 0)
336+
337+execApp' env ctxt bnd@(EBind n b body) (arg:args) = do ret <- body arg
338+ let (f', as) = unApplyV ret
339+ execApp' env ctxt f' (as ++ args)
340+execApp' env ctxt (EThunk i) args = do f <- force i
341+ execApp' env ctxt f args
342+execApp' env ctxt app@(EApp _ _) args2 | (f, args1) <- unApplyV app = execApp' env ctxt f (args1 ++ args2)
343+execApp' env ctxt f args = return (mkEApp f args)
344+
345+
346+
347+
348+
349+-- | Overall wrapper for case tree execution. If there are enough arguments, it takes them,
350+-- evaluates them, then begins the checks for matching cases.
351+execCase :: ExecEnv -> Context -> [Name] -> SC -> [ExecVal] -> Exec (Maybe ExecVal)
352+execCase env ctxt ns sc args =
353+ let arity = length ns in
354+ if arity <= length args
355+ then do let amap = zip ns args
356+ caseRes <- execCase' env ctxt amap sc
357+ case caseRes of
358+ Just res -> Just <$> execApp' (map (\(n, tm) -> (n, tm)) amap ++ env) ctxt res (drop arity args)
359+ Nothing -> return Nothing
360+ else return Nothing
361+
362+-- | Take bindings and a case tree and examines them, executing the matching case if possible.
363+execCase' :: ExecEnv -> Context -> [(Name, ExecVal)] -> SC -> Exec (Maybe ExecVal)
364+execCase' env ctxt amap (UnmatchedCase _) = return Nothing
365+execCase' env ctxt amap (STerm tm) =
366+ Just <$> doExec (map (\(n, v) -> (n, v)) amap ++ env) ctxt tm
367+execCase' env ctxt amap (Case n alts) | Just tm <- lookup n amap =
368+ do tm' <- tryForce tm
369+ case chooseAlt tm' alts of
370+ Just (newCase, newBindings) ->
371+ let amap' = newBindings ++ (filter (\(x,_) -> not (elem x (map fst newBindings))) amap) in
372+ execCase' env ctxt amap' newCase
373+ Nothing -> return Nothing
374+
375+chooseAlt :: ExecVal -> [CaseAlt] -> Maybe (SC, [(Name, ExecVal)])
376+chooseAlt _ (DefaultCase sc : alts) = Just (sc, [])
377+chooseAlt (EConstant c) (ConstCase c' sc : alts) | c == c' = Just (sc, [])
378+chooseAlt tm (ConCase n i ns sc : alts) | ((EP _ cn _), args) <- unApplyV tm
379+ , cn == n = Just (sc, zip ns args)
380+ | otherwise = chooseAlt tm alts
381+chooseAlt tm (_:alts) = chooseAlt tm alts
382+chooseAlt _ [] = Nothing
21
383
22−-- | Attempt to perform a side effect. Return either Just the next step in
23−-- evaluation (after performing the side effect through IO), or Nothing if no
24−-- IO was performed.
25−--
26−-- This function is exceedingly generous about what it will accept in order to
27−-- enable convenient testing at the REPL.
28−step :: TT Name -> Idris (Maybe (TT Name))
29−step tm = step' (unApply tm)
30− where step' (P _ (UN "unsafePerformIO") _, [_, arg] ) = step arg -- Only step if arg can be stepped
31− step' (P _ (UN "mkForeign") _, args) = stepForeign args
32− step' (P _ (UN "prim__IO") _, [_, arg]) = return (Just arg)
33− step' (P _ (UN "prim__readString") _, [(P _ (UN "prim__stdin") _)]) =
34− do line <- lift $ getLine
35− return . Just . Constant . Str $ line
36− step' _ = return Nothing
37−
38−-- | Perform side effects until no more can be performed, then return the
39−-- resulting term (possibly the argument).
40−execute :: TT Name -> Idris (TT Name)
41−execute tm = case unApply tm of
42− (P _ (UN "unsafePerformIO") _, [_, arg] ) -> execute' arg
43− _ -> return tm
44− where execute' tm = do stepped <- step tm
45− case stepped of
46− Nothing -> return tm
47− Just tm' -> execute' tm'
48
384
49
385
50
386
51data FTy = FInt | FFloat | FChar | FString | FPtr | FUnit deriving (Show, Read)
387data FTy = FInt | FFloat | FChar | FString | FPtr | FUnit deriving (Show, Read)
52
388
389+idrisType :: FTy -> ExecVal
390+idrisType FUnit = EP Ref unitTy EErased
391+idrisType ft = EConstant (idr ft)
392+ where idr FInt = IType
393+ idr FFloat = FlType
394+ idr FChar = ChType
395+ idr FString = StrType
396+ idr FPtr = PtrType
397+
53data Foreign = FFun String [FTy] FTy deriving Show
398data Foreign = FFun String [FTy] FTy deriving Show
54
399
400+
55−call :: Foreign -> [TT Name] -> Idris (Maybe (TT Name))
401+call :: Foreign -> [ExecVal] -> Exec (Maybe ExecVal)
56−call (FFun name argTypes retType) args = do fn <- findForeign name
402+call (FFun name argTypes retType) args =
403+ do fn <- findForeign name
57− case fn of
404+ case fn of
58− Nothing -> return Nothing
405+ Nothing -> return Nothing
59− Just f -> return . Just =<< call' f args retType
406+ Just f -> do res <- call' f args retType
407+ return . Just . ioWrap $ res
60− where call' :: ForeignFun -> [TT Name] -> FTy -> Idris (TT Name)
408+ where call' :: ForeignFun -> [ExecVal] -> FTy -> Exec ExecVal
61− call' (Fun _ h) args FInt = do res <- lift $ callFFI h retCInt (prepArgs args)
409+ call' (Fun _ h) args FInt = do res <- execIO $ callFFI h retCInt (prepArgs args)
62− return (Constant (I (fromIntegral res)))
410+ return (EConstant (I (fromIntegral res)))
63− call' (Fun _ h) args FFloat = do res <- lift $ callFFI h retCDouble (prepArgs args)
411+ call' (Fun _ h) args FFloat = do res <- execIO $ callFFI h retCDouble (prepArgs args)
64− return (Constant (Fl (realToFrac res)))
412+ return (EConstant (Fl (realToFrac res)))
65− call' (Fun _ h) args FChar = do res <- lift $ callFFI h retCChar (prepArgs args)
413+ call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)
66− return (Constant (Ch (castCCharToChar res)))
414+ return (EConstant (Ch (castCCharToChar res)))
67− call' (Fun _ h) args FString = do res <- lift $ callFFI h retCString (prepArgs args)
415+ call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)
68− hStr <- lift $ peekCString res
416+ hStr <- execIO $ peekCString res
69-- lift $ free res
417-- lift $ free res
70− return (Constant (Str hStr))
418+ return (EConstant (Str hStr))
71−-- awaiting Const constructor for pointers
419+
72−-- call' (Fun _ h) args FPtr = do res <- lift $ callFFI h retPtr (prepArgs args)
420+ call' (Fun _ h) args FPtr = do res <- execIO $ callFFI h (retPtr retVoid) (prepArgs args)
73−-- return (Constant (Ch (castCCharToChar res)))
421+ return (EPtr res)
74− call' (Fun _ h) args FUnit = do res <- lift $ callFFI h retVoid (prepArgs args)
422+ 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
423+ return (EP Ref unitCon EErased)
424+-- call' (Fun _ h) args other = fail ("Unsupported foreign return type " ++ show other)
425+
76
426
77 prepArgs = map prepArg
427 prepArgs = map prepArg
78− prepArg (Constant (I i)) = argCInt (fromIntegral i)
428+ prepArg (EConstant (I i)) = argCInt (fromIntegral i)
79− prepArg (Constant (Fl f)) = argCDouble (realToFrac f)
429+ prepArg (EConstant (Fl f)) = argCDouble (realToFrac f)
80− prepArg (Constant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars
430+ prepArg (EConstant (Ch c)) = argCChar (castCharToCChar c) -- FIXME - castCharToCChar only safe for first 256 chars
81− prepArg (Constant (Str s)) = argString s
431+ prepArg (EConstant (Str s)) = argString s
432+ prepArg (EPtr p) = argPtr p
433+ prepArg other = trace ("Could not use " ++ take 100 (show other) ++ " as FFI arg.") undefined
82
434
83
435
84
436
85−foreignFromTT :: TT Name -> Maybe Foreign
437+foreignFromTT :: ExecVal -> Maybe Foreign
86−foreignFromTT t = case (unApply t) of
438+foreignFromTT t = case (unApplyV t) of
87− (_, [(Constant (Str name)), args, ret]) ->
439+ (_, [(EConstant (Str name)), args, ret]) ->
88− do argTy <- unList args
440+ do argTy <- unEList args
89 argFTy <- sequence $ map getFTy argTy
441 argFTy <- sequence $ map getFTy argTy
90 retFTy <- getFTy ret
442 retFTy <- getFTy ret
91 return $ FFun name argFTy retFTy
443 return $ FFun name argFTy retFTy
92− _ -> Nothing
444+ _ -> trace "failed to construct ffun" Nothing
93−
445+
94−getFTy :: TT Name -> Maybe FTy
446+getFTy :: ExecVal -> Maybe FTy
95−getFTy (P _ (UN t) _) = case t of
447+getFTy (EP _ (UN t) _) =
448+ case t of
96− "FInt" -> Just FInt
449+ "FInt" -> Just FInt
97− "FFloat" -> Just FFloat
450+ "FFloat" -> Just FFloat
98− "FChar" -> Just FChar
451+ "FChar" -> Just FChar
99− "FString" -> Just FString
452+ "FString" -> Just FString
100− "FPtr" -> Just FPtr
453+ "FPtr" -> Just FPtr
101− "FUnit" -> Just FUnit
454+ "FUnit" -> Just FUnit
102− _ -> Nothing
455+ _ -> Nothing
103getFTy _ = Nothing
456getFTy _ = Nothing
104
457
105−unList :: TT Name -> Maybe [TT Name]
458+unList :: Term -> Maybe [Term]
106unList tm = case unApply tm of
459unList tm = case unApply tm of
107 (nil, [_]) -> Just []
460 (nil, [_]) -> Just []
108 (cons, ([_, x, xs])) ->
461 (cons, ([_, x, xs])) ->
@@ -110,11 +463,20 @@ unList tm = case unApply tm of
110 return $ x:rest
463 return $ x:rest
111 (f, args) -> Nothing
464 (f, args) -> Nothing
112
465
466+unEList :: ExecVal -> Maybe [ExecVal]
467+unEList tm = case unApplyV tm of
468+ (nil, [_]) -> Just []
469+ (cons, ([_, x, xs])) ->
470+ do rest <- unEList xs
471+ return $ x:rest
472+ (f, args) -> Nothing
473+
474+
113−toConst :: TT Name -> Maybe Const
475+toConst :: Term -> Maybe Const
114toConst (Constant c) = Just c
476toConst (Constant c) = Just c
115toConst _ = Nothing
477toConst _ = Nothing
116
478
117−stepForeign :: [TT Name] -> Idris (Maybe (TT Name))
479+stepForeign :: [ExecVal] -> Exec (Maybe ExecVal)
118stepForeign (ty:fn:args) = do let ffun = foreignFromTT fn
480stepForeign (ty:fn:args) = do let ffun = foreignFromTT fn
119 f' <- case (call <$> ffun) of
481 f' <- case (call <$> ffun) of
120 Just f -> f args
482 Just f -> f args
@@ -130,15 +492,15 @@ mapMaybeM f (x:xs) = do rest <- mapMaybeM f xs
130 Just x'' -> return (x'':rest)
492 Just x'' -> return (x'':rest)
131 Nothing -> return rest
493 Nothing -> return rest
132
494
133−findForeign :: String -> Idris (Maybe ForeignFun)
495+findForeign :: String -> Exec (Maybe ForeignFun)
134−findForeign fn = do i <- getIState
496+findForeign fn = do est <- getExecState
135− let libs = idris_dynamic_libs i
497+ let libs = exec_dynamic_libs est
136− fns <- mapMaybeM (lift . tryLoadFn fn) libs
498+ fns <- mapMaybeM getFn libs
137 case fns of
499 case fns of
138 [f] -> return (Just f)
500 [f] -> return (Just f)
139− [] -> do iputStrLn $ "Symbol \"" ++ fn ++ "\" not found"
501+ [] -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" not found"
140 return Nothing
502 return Nothing
141− fs -> do iputStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++
503+ fs -> do execIO . putStrLn $ "Symbol \"" ++ fn ++ "\" is ambiguous. Found " ++
142− show (length fs) ++ " occurrences."
504+ show (length fs) ++ " occurrences."
143 return Nothing
505 return Nothing
144−
506+ 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)
41 (state, show nf ++ " : " ++ show ty)
42 err -> (state, show err)
42 err -> (state, show err)
43processCommand (Print n) state =
43processCommand (Print n) state =
44− case lookupDef Nothing n (ctxt state) of
44+ case lookupDef n (ctxt state) of
45 [tm] -> (state, show tm)
45 [tm] -> (state, show tm)
46 _ -> (state, "No such name")
46 _ -> (state, "No such name")
47processCommand (Tac e) state
47processCommand (Tac e) state
src/Core/ProofState.hs+1−1
@@ -162,7 +162,7 @@ unify' ctxt env topx topy =
162-- -- " in " ++ show env ++
162-- -- " in " ++ show env ++
163-- "\n" ++ show u ++ "\n" ++ qshow fails ++ "\nCurrent problems:\n"
163-- "\n" ++ show u ++ "\n" ++ qshow fails ++ "\nCurrent problems:\n"
164-- ++ qshow (problems ps) ++ "\n" ++ show (holes ps) ++ "\n"
164-- ++ qshow (problems ps) ++ "\n" ++ show (holes ps) ++ "\n"
165−-- -- ++ show (pterm ps)
165+-- ++ show (pterm ps)
166-- ++ "\n----------") $
166-- ++ "\n----------") $
167 case fails of
167 case fails of
168-- [] -> return u
168-- [] -> return u
src/Core/TT.hs+9−6
@@ -244,8 +244,8 @@ addDef n v ctxt = case Map.lookup (nsroot n) ctxt of
244
244
245-}
245-}
246
246
247−lookupCtxtName :: Maybe [String] -> Name -> Ctxt a -> [(Name, a)]
247+lookupCtxtName :: Name -> Ctxt a -> [(Name, a)]
248−lookupCtxtName nspace n ctxt = case Map.lookup (nsroot n) ctxt of
248+lookupCtxtName n ctxt = case Map.lookup (nsroot n) ctxt of
249 Just xs -> filterNS (Map.toList xs)
249 Just xs -> filterNS (Map.toList xs)
250 Nothing -> []
250 Nothing -> []
251 where
251 where
@@ -258,12 +258,12 @@ lookupCtxtName nspace n ctxt = case Map.lookup (nsroot n) ctxt of
258 nsmatch (NS _ _) _ = False
258 nsmatch (NS _ _) _ = False
259 nsmatch looking found = True
259 nsmatch looking found = True
260
260
261−lookupCtxt :: Maybe [String] -> Name -> Ctxt a -> [a]
261+lookupCtxt :: Name -> Ctxt a -> [a]
262−lookupCtxt ns n ctxt = map snd (lookupCtxtName ns n ctxt)
262+lookupCtxt n ctxt = map snd (lookupCtxtName n ctxt)
263
263
264updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a
264updateDef :: Name -> (a -> a) -> Ctxt a -> Ctxt a
265updateDef n f ctxt
265updateDef n f ctxt
266− = let ds = lookupCtxtName Nothing n ctxt in
266+ = let ds = lookupCtxtName n ctxt in
267 foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds
267 foldr (\ (n, t) c -> addDef n (f t) c) ctxt ds
268
268
269toAlist :: Ctxt a -> [(Name, a)]
269toAlist :: Ctxt a -> [(Name, a)]
@@ -430,7 +430,10 @@ instance Show UConstraint where
430
430
431type UCs = (Int, [UConstraint])
431type UCs = (Int, [UConstraint])
432
432
433−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
434 deriving (Show, Ord)
437 deriving (Show, Ord)
435{-!
438{-!
436deriving instance Binary NameType
439deriving instance Binary NameType
src/Core/Typecheck.hs+1−1
@@ -60,7 +60,7 @@ check' :: Bool -> Context -> Env -> Raw -> StateT UCs TC (Term, Type)
60check' holes ctxt env top = chk env top where
60check' holes ctxt env top = chk env top where
61 chk env (Var n)
61 chk env (Var n)
62 | Just (i, ty) <- lookupTyEnv n env = return (P Bound n ty, ty)
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
64 | otherwise = do lift $ tfail $ NoSuchVariable n
65 chk env (RApp f a)
65 chk env (RApp f a)
66 = do (fv, fty) <- chk env f
66 = do (fv, fty) <- chk env f
src/IRTS/CodegenC.hs+1−1
@@ -48,7 +48,7 @@ codegenC defs out exec incs objs libs dbg
48 incFlags <- getIncFlags
48 incFlags <- getIncFlags
49 let gcc = comp ++ " " ++
49 let gcc = comp ++ " " ++
50 gccDbg dbg ++
50 gccDbg dbg ++
51− " -I. " ++ objs ++ " -x c " ++
51+ " -I. " ++ objs ++ " -x c " ++
52 (if (exec == Executable) then "" else " -c ") ++
52 (if (exec == Executable) then "" else " -c ") ++
53 " " ++ tmpn ++
53 " " ++ tmpn ++
54 " " ++ libFlags ++
54 " " ++ libFlags ++
src/IRTS/CodegenJava.hs+12−6
@@ -15,7 +15,7 @@ import qualified Control.Monad.Trans as T
15import Control.Monad.Trans.State
15import Control.Monad.Trans.State
16import Data.Char
16import Data.Char
17import Data.Maybe (fromJust)
17import Data.Maybe (fromJust)
18−import Data.List (isPrefixOf, isSuffixOf, intercalate)
18+import Data.List (isPrefixOf, isSuffixOf, intercalate, foldl')
19import qualified Data.Text as T
19import qualified Data.Text as T
20import qualified Data.Text.IO as TIO
20import qualified Data.Text.IO as TIO
21import Language.Java.Parser
21import Language.Java.Parser
@@ -255,7 +255,7 @@ mkMainMethod =
255 )
255 )
256
256
257mergeInnerClasses :: [Decl] -> [Decl]
257mergeInnerClasses :: [Decl] -> [Decl]
258−mergeInnerClasses = foldl mergeInner []
258+mergeInnerClasses = foldl' mergeInner []
259 where
259 where
260 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
260 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
261 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
261 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
@@ -418,6 +418,12 @@ mkIdentifier (UN name) =
418 cleanReserved "idris_K" = "_idris_K"
418 cleanReserved "idris_K" = "_idris_K"
419 cleanReserved "idris_flipK" = "_idris_flipK"
419 cleanReserved "idris_flipK" = "_idris_flipK"
420 cleanReserved "idris_assignStack" = "_idris_assignStack"
420 cleanReserved "idris_assignStack" = "_idris_assignStack"
421+ cleanReserved "free" = "_free"
422+ cleanReserved "malloc" = "_malloc"
423+ cleanReserved "idris_memset" = "_idris_memset"
424+ cleanReserved "idris_peek" = "_idris_peek"
425+ cleanReserved "idris_poke" = "_idris_poke"
426+ cleanReserved "idris_memmove" = "_idris_memmove"
421
427
422 cleanReserved x = x
428 cleanReserved x = x
423
429
@@ -1253,10 +1259,10 @@ mkExp (SConst BIType) = return $ mkClass bigIntegerType
1253mkExp (SConst FlType) = return $ mkClass doubleType
1259mkExp (SConst FlType) = return $ mkClass doubleType
1254mkExp (SConst ChType) = return $ mkClass charType
1260mkExp (SConst ChType) = return $ mkClass charType
1255mkExp (SConst StrType) = return $ mkClass stringType
1261mkExp (SConst StrType) = return $ mkClass stringType
1256−mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (Int (toInteger x))
1262+mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))
1257−mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (Int (toInteger x))
1263+mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))
1258mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1264mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1259−mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (Int (toInteger x))
1265+mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))
1260mkExp (SConst (B8Type))= return $ mkClass byteType
1266mkExp (SConst (B8Type))= return $ mkClass byteType
1261mkExp (SConst (B16Type)) = return $ mkClass shortType
1267mkExp (SConst (B16Type)) = return $ mkClass shortType
1262mkExp (SConst (B32Type)) = return $ mkClass integerType
1268mkExp (SConst (B32Type)) = return $ mkClass integerType
@@ -1513,4 +1519,4 @@ mkExp (SError err) =
1513 []
1519 []
1514 (Ident "throwSelf")
1520 (Ident "throwSelf")
1515 []
1521 []
1516−mkExp other = error (show other)
1522+mkExp other = error (show other)
src/IRTS/CodegenJavaScript.hs+2−1
@@ -139,6 +139,7 @@ translateConstant ChType = "__IDRRT__.Char"
139translateConstant StrType = "__IDRRT__.String"
139translateConstant StrType = "__IDRRT__.String"
140translateConstant BIType = "__IDRRT__.Integer"
140translateConstant BIType = "__IDRRT__.Integer"
141translateConstant FlType = "__IDRRT__.Float"
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 ++ "';})()"
@@ -450,7 +451,7 @@ translateCase var (SConstCase ty e)
450 | IType <- ty = matchHelper "Int"
451 | IType <- ty = matchHelper "Int"
451 | BIType <- ty = matchHelper "Integer"
452 | BIType <- ty = matchHelper "Integer"
452 | FlType <- ty = matchHelper "Float"
453 | FlType <- ty = matchHelper "Float"
453− | PtrType <- ty = matchHelper "Pointer"
454+ | PtrType <- ty = matchHelper "Ptr"
454 | Forgot <- ty = matchHelper "Forgot"
455 | Forgot <- ty = matchHelper "Forgot"
455 where
456 where
456 matchHelper tyName = translateTypeMatch var tyName e
457 matchHelper tyName = translateTypeMatch var tyName e
src/IRTS/Compiler.hs+3−3
@@ -98,7 +98,7 @@ irMain tm = do i <- ir tm
98allNames :: [Name] -> Name -> Idris [Name]
98allNames :: [Name] -> Name -> Idris [Name]
99allNames ns n | n `elem` ns = return []
99allNames ns n | n `elem` ns = return []
100allNames ns n = do i <- getIState
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'))
102 [ns'] -> do more <- mapM (allNames (n:ns)) (map fst (calls ns'))
103 return (nub (n : concat more))
103 return (nub (n : concat more))
104 _ -> return [n]
104 _ -> return [n]
@@ -205,12 +205,12 @@ instance ToIR (TT Name) where
205 Just tm -> return tm
205 Just tm -> return tm
206 _ -> do
206 _ -> do
207 let collapse
207 let collapse
208− = case lookupCtxt Nothing n
208+ = case lookupCtxt n
209 (idris_optimisation i) of
209 (idris_optimisation i) of
210 [oi] -> collapsible oi
210 [oi] -> collapsible oi
211 _ -> False
211 _ -> False
212 let unused
212 let unused
213− = case lookupCtxt Nothing n
213+ = case lookupCtxt n
214 (idris_callgraph i) of
214 (idris_callgraph i) of
215 [CGInfo _ _ _ _ unusedpos] ->
215 [CGInfo _ _ _ _ unusedpos] ->
216 unusedpos
216 unusedpos
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
80-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e
81 aa env (LApp tc (LV (Glob n)) args)
81 aa env (LApp tc (LV (Glob n)) args)
82 = do args' <- mapM (aa env) args
82 = do args' <- mapM (aa env) args
83− case lookupCtxt Nothing n defs of
83+ case lookupCtxt n defs of
84 [LConstructor _ i ar] -> return $ DApp tc n args'
84 [LConstructor _ i ar] -> return $ DApp tc n args'
85 [LFun _ _ as _] -> let arity = length as in
85 [LFun _ _ as _] -> let arity = length as in
86 fixApply tc n args' arity
86 fixApply tc n args' arity
87 [] -> return $ chainAPPLY (DV (Glob n)) args'
87 [] -> return $ chainAPPLY (DV (Glob n)) args'
88 aa env (LLazyApp n args)
88 aa env (LLazyApp n args)
89 = do args' <- mapM (aa env) 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'
91 [LConstructor _ i ar] -> return $ DApp False n args'
92 [LFun _ _ as _] -> let arity = length as in
92 [LFun _ _ as _] -> let arity = length as in
93 fixLazyApply n args' arity
93 fixLazyApply n args' arity
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))
46simplify tl (DV (Loc i)) = return (SV (Loc i))
47simplify tl (DV (Glob x))
47simplify tl (DV (Glob x))
48 = do ctxt <- ldefs
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 []
50 [DConstructor _ t 0] -> return $ SCon t x []
51 _ -> return $ SV (Glob x)
51 _ -> return $ SV (Glob x)
52simplify tl (DApp tc n args) = do args' <- mapM sVar args
52simplify tl (DApp tc n args) = do args' <- mapM sVar args
@@ -88,7 +88,7 @@ simplify tl (DError str) = return $ SError str
88
88
89sVar (DV (Glob x))
89sVar (DV (Glob x))
90 = do ctxt <- ldefs
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 [])
92 [DConstructor _ t 0] -> sVar (DC t x [])
93 _ -> return (Glob x, Nothing)
93 _ -> return (Glob x, Nothing)
94sVar (DV x) = return (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)) =
136 sc env (SV (Glob n)) =
137 case lookup n (reverse env) of -- most recent first
137 case lookup n (reverse env) of -- most recent first
138 Just i -> do lvar i; return (SV (Loc i))
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] ->
140 [DConstructor _ i ar] ->
141 if True -- ar == 0
141 if True -- ar == 0
142 then return (SCon i n [])
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
146 [] -> fail $ "Codegen error: No such variable " ++ show n
147 sc env (SApp tc f args)
147 sc env (SApp tc f args)
148 = do args' <- mapM (scVar env) 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] ->
150 [DConstructor n tag ar] ->
151 if True -- (ar == length args)
151 if True -- (ar == length args)
152 then return $ SCon tag n 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'
160 return $ SForeign l ty f args'
161 sc env (SCon tag f args)
161 sc env (SCon tag f args)
162 = do args' <- mapM (scVar env) 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] ->
164 [DConstructor n tag ar] ->
165 if True -- (ar == length args)
165 if True -- (ar == length args)
166 then return $ SCon tag n 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) =
197 scVar env (Glob n) =
198 case lookup n (reverse env) of -- most recent first
198 case lookup n (reverse env) of -- most recent first
199 Just i -> do lvar i; return (Loc i)
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] ->
201 [DConstructor _ i ar] ->
202 fail $ "Codegen error : can't pass constructor here"
202 fail $ "Codegen error : can't pass constructor here"
203 [_] -> return (Glob n)
203 [_] -> return (Glob n)
@@ -207,7 +207,7 @@ scopecheck ctxt envTop tm = sc envTop tm where
207
207
208 scalt env (SConCase _ i n args e)
208 scalt env (SConCase _ i n args e)
209 = do let env' = env ++ zip args [length env..]
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] ->
211 [DConstructor _ i ar] ->
212 if True -- (length args == ar)
212 if True -- (length args == ar)
213 then return i
213 then return i
src/Idris/AbsSyntax.hs+24−20
@@ -24,7 +24,7 @@ import Data.Either
24import Debug.Trace
24import Debug.Trace
25
25
26import Util.Pretty
26import Util.Pretty
27−
27+import Util.System
28
28
29getContext :: Idris Context
29getContext :: Idris Context
30getContext = do i <- getIState; return (tt_ctxt i)
30getContext = do i <- getIState; return (tt_ctxt i)
@@ -41,13 +41,15 @@ getLibs = do i <- getIState; return (idris_libs i)
41addLib :: String -> Idris ()
41addLib :: String -> Idris ()
42addLib f = do i <- getIState; putIState $ i { idris_libs = f : idris_libs i }
42addLib f = do i <- getIState; putIState $ i { idris_libs = f : idris_libs i }
43
43
44−addDyLib :: String -> Idris ()
44+addDyLib :: [String] -> Idris (Either DynamicLib String)
45−addDyLib lib = do i <- getIState
45+addDyLib libs = do i <- getIState
46− handle <- lift $ tryLoadLib lib
46+ handle <- lift $ mapM (\l -> catchIO (tryLoadLib l) (\_ -> return Nothing)) libs
47− case handle of
47+ case msum handle of
48− Nothing -> fail $ "Could not load dynamic lib \"" ++ lib ++ "\""
48+ Nothing -> return (Right $ "Could not load dynamic alternatives \"" ++
49+ concat (intersperse "," libs) ++ "\"")
49− Just x -> do let libs = idris_dynamic_libs i
50+ Just x -> do let ls = idris_dynamic_libs i
50− putIState $ i { idris_dynamic_libs = x:libs }
51+ putIState $ i { idris_dynamic_libs = x:ls }
52+ return (Left x)
51
53
52addHdr :: String -> Idris ()
54addHdr :: String -> Idris ()
53addHdr f = do i <- getIState; putIState $ i { idris_hdrs = f : idris_hdrs i }
55addHdr f = do i <- getIState; putIState $ i { idris_hdrs = f : idris_hdrs i }
@@ -88,7 +90,7 @@ getCoercionsTo i ty =
88 findCoercions fn cs
90 findCoercions fn cs
89 where findCoercions t [] = []
91 where findCoercions t [] = []
90 findCoercions t (n : ns) =
92 findCoercions t (n : ns) =
91− let ps = case lookupTy Nothing n (tt_ctxt i) of
93+ let ps = case lookupTy n (tt_ctxt i) of
92 [ty] -> case unApply (getRetTy ty) of
94 [ty] -> case unApply (getRetTy ty) of
93 (t', _) ->
95 (t', _) ->
94 if t == t' then [n] else []
96 if t == t' then [n] else []
@@ -119,7 +121,7 @@ addToCalledG n ns = return () -- TODO
119addInstance :: Bool -> Name -> Name -> Idris ()
121addInstance :: Bool -> Name -> Name -> Idris ()
120addInstance int n i
122addInstance int n i
121 = do ist <- getIState
123 = do ist <- getIState
122− case lookupCtxt Nothing n (idris_classes ist) of
124+ case lookupCtxt n (idris_classes ist) of
123 [CI a b c d ins] ->
125 [CI a b c d ins] ->
124 do let cs = addDef n (CI a b c d (addI i ins)) (idris_classes ist)
126 do let cs = addDef n (CI a b c d (addI i ins)) (idris_classes ist)
125 putIState $ ist { idris_classes = cs }
127 putIState $ ist { idris_classes = cs }
@@ -139,7 +141,7 @@ addInstance int n i
139addClass :: Name -> ClassInfo -> Idris ()
141addClass :: Name -> ClassInfo -> Idris ()
140addClass n i
142addClass n i
141 = do ist <- getIState
143 = do ist <- getIState
142− let i' = case lookupCtxt Nothing n (idris_classes ist) of
144+ let i' = case lookupCtxt n (idris_classes ist) of
143 [c] -> c { class_instances = class_instances i }
145 [c] -> c { class_instances = class_instances i }
144 _ -> i
146 _ -> i
145 putIState $ ist { idris_classes = addDef n i' (idris_classes ist) }
147 putIState $ ist { idris_classes = addDef n i' (idris_classes ist) }
@@ -193,7 +195,7 @@ getName = do i <- getIState;
193checkUndefined :: FC -> Name -> Idris ()
195checkUndefined :: FC -> Name -> Idris ()
194checkUndefined fc n
196checkUndefined fc n
195 = do i <- getContext
197 = do i <- getContext
196− case lookupTy Nothing n i of
198+ case lookupTy n i of
197 (_:_) -> fail $ show fc ++ ":" ++
199 (_:_) -> fail $ show fc ++ ":" ++
198 show n ++ " already defined"
200 show n ++ " already defined"
199 _ -> return ()
201 _ -> return ()
@@ -201,7 +203,7 @@ checkUndefined fc n
201isUndefined :: FC -> Name -> Idris Bool
203isUndefined :: FC -> Name -> Idris Bool
202isUndefined fc n
204isUndefined fc n
203 = do i <- getContext
205 = do i <- getContext
204− case lookupTy Nothing n i of
206+ case lookupTy n i of
205 (_:_) -> return False
207 (_:_) -> return False
206 _ -> return True
208 _ -> return True
207
209
@@ -641,7 +643,7 @@ getPriority :: IState -> PTerm -> Int
641getPriority i tm = 1 -- pri tm
643getPriority i tm = 1 -- pri tm
642 where
644 where
643 pri (PRef _ n) =
645 pri (PRef _ n) =
644− case lookupP Nothing n (tt_ctxt i) of
646+ case lookupP n (tt_ctxt i) of
645 ((P (DCon _ _) _ _):_) -> 1
647 ((P (DCon _ _) _ _):_) -> 1
646 ((P (TCon _ _) _ _):_) -> 1
648 ((P (TCon _ _) _ _):_) -> 1
647 ((P Ref _ _):_) -> 1
649 ((P Ref _ _):_) -> 1
@@ -882,9 +884,9 @@ addImpl' inpat env infns ist ptm = ai (zip env (repeat Nothing)) ptm
882
884
883aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm
885aiFn :: Bool -> Bool -> IState -> FC -> Name -> [PArg] -> Either Err PTerm
884aiFn inpat True ist fc f []
886aiFn inpat True ist fc f []
885− = case lookupDef Nothing f (tt_ctxt ist) of
887+ = case lookupDef f (tt_ctxt ist) of
886 [] -> Right $ PPatvar fc f
888 [] -> Right $ PPatvar fc f
887− alts -> let ialts = lookupCtxt Nothing f (idris_implicits ist) in
889+ alts -> let ialts = lookupCtxt f (idris_implicits ist) in
888 -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $
890 -- trace (show f ++ " " ++ show (fc, any (all imp) ialts, ialts, any constructor alts)) $
889 if (not (vname f) || tcname f
891 if (not (vname f) || tcname f
890 || any constructor alts || any allImp ialts)
892 || any constructor alts || any allImp ialts)
@@ -904,7 +906,7 @@ aiFn inpat expat ist fc f as
904 | f `elem` primNames = Right $ PApp fc (PRef fc f) as
906 | f `elem` primNames = Right $ PApp fc (PRef fc f) as
905aiFn inpat expat ist fc f as
907aiFn inpat expat ist fc f as
906 -- This is where namespaces get resolved by adding PAlternative
908 -- This is where namespaces get resolved by adding PAlternative
907− = case lookupCtxtName Nothing f (idris_implicits ist) of
909+ = case lookupCtxtName f (idris_implicits ist) of
908 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)
910 [(f',ns)] -> Right $ mkPApp fc (length ns) (PRef fc f') (insertImpl ns as)
909 [] -> if f `elem` idris_metavars ist
911 [] -> if f `elem` idris_metavars ist
910 then Right $ PApp fc (PRef fc f) as
912 then Right $ PApp fc (PRef fc f) as
@@ -949,7 +951,7 @@ stripLinear :: IState -> PTerm -> PTerm
949stripLinear i tm = evalState (sl tm) [] where
951stripLinear i tm = evalState (sl tm) [] where
950 sl :: PTerm -> State [Name] PTerm
952 sl :: PTerm -> State [Name] PTerm
951 sl (PRef fc f)
953 sl (PRef fc f)
952− | (_:_) <- lookupTy Nothing f (tt_ctxt i)
954+ | (_:_) <- lookupTy f (tt_ctxt i)
953 = return $ PRef fc f
955 = return $ PRef fc f
954 | otherwise = do ns <- get
956 | otherwise = do ns <- get
955 if (f `elem` ns)
957 if (f `elem` ns)
@@ -1074,14 +1076,16 @@ matchClause' names i x y = checkRpts $ match (fullApp x) (fullApp y) where
1074-- match (PRef _ n) (PRef _ n') | n == n' = return []
1076-- match (PRef _ n) (PRef _ n') | n == n' = return []
1075-- | otherwise = Nothing
1077-- | otherwise = Nothing
1076 match (PRef f n) (PApp _ x []) = match (PRef f n) x
1078 match (PRef f n) (PApp _ x []) = match (PRef f n) x
1079+ match (PPatvar f n) xr = match (PRef f n) xr
1080+ match xr (PPatvar f n) = match xr (PRef f n)
1077 match (PApp _ x []) (PRef f n) = match x (PRef f n)
1081 match (PApp _ x []) (PRef f n) = match x (PRef f n)
1078 match (PRef _ n) tm@(PRef _ n')
1082 match (PRef _ n) tm@(PRef _ n')
1079 | n == n' && not names &&
1083 | n == n' && not names &&
1080− (not (isConName Nothing n (tt_ctxt i)) || tm == Placeholder)
1084+ (not (isConName n (tt_ctxt i)) || tm == Placeholder)
1081 = return [(n, tm)]
1085 = return [(n, tm)]
1082 | n == n' = return []
1086 | n == n' = return []
1083 match (PRef _ n) tm
1087 match (PRef _ n) tm
1084− | not names && (not (isConName Nothing n (tt_ctxt i)) || tm == Placeholder)
1088+ | not names && (not (isConName n (tt_ctxt i)) || tm == Placeholder)
1085 = return [(n, tm)]
1089 = return [(n, tm)]
1086 match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l'
1090 match (PEq _ l r) (PEq _ l' r') = do ml <- match' l l'
1087 mr <- match' r r'
1091 mr <- match' r r'
src/Idris/AbsSyntaxTree.hs+39−5
@@ -887,10 +887,10 @@ prettyImp impl = prettySe 10
887 bracket p 1 $
887 bracket p 1 $
888 prettySe 1 f <+>
888 prettySe 1 f <+>
889 if impl then
889 if impl then
890− foldl fS empty as
890+ foldl' fS empty as
891 -- foldr (<+>) empty $ map prettyArgS as
891 -- foldr (<+>) empty $ map prettyArgS as
892 else
892 else
893− foldl fSe empty args
893+ foldl' fSe empty args
894 -- foldr (<+>) empty $ map prettyArgSe args
894 -- foldr (<+>) empty $ map prettyArgSe args
895 where
895 where
896 fS l r =
896 fS l r =
@@ -979,7 +979,7 @@ prettyImp impl = prettySe 10
979showImp :: Bool -> PTerm -> String
979showImp :: Bool -> PTerm -> String
980showImp impl tm = se 10 tm where
980showImp impl tm = se 10 tm where
981 se p (PQuote r) = "![" ++ show r ++ "]"
981 se p (PQuote r) = "![" ++ show r ++ "]"
982− se p (PPatvar fc n) = show n
982+ se p (PPatvar fc n) = if impl then show n ++ "[p]" else show n
983 se p (PInferRef fc n) = "!" ++ show n -- ++ "[" ++ show fc ++ "]"
983 se p (PInferRef fc n) = "!" ++ show n -- ++ "[" ++ show fc ++ "]"
984 se p (PRef fc n) = if impl then show n -- ++ "[" ++ show fc ++ "]"
984 se p (PRef fc n) = if impl then show n -- ++ "[" ++ show fc ++ "]"
985 else showbasic n
985 else showbasic n
@@ -1014,6 +1014,9 @@ showImp impl tm = se 10 tm where
1014 = bracket p 2 $ se 10 ty ++ " => " ++ se 10 sc
1014 = bracket p 2 $ se 10 ty ++ " => " ++ se 10 sc
1015 se p (PPi (TacImp _ _ s _) n ty sc)
1015 se p (PPi (TacImp _ _ s _) n ty sc)
1016 = bracket p 2 $ "{tacimp " ++ show n ++ " : " ++ se 10 ty ++ "} -> " ++ se 10 sc
1016 = bracket p 2 $ "{tacimp " ++ show n ++ " : " ++ se 10 ty ++ "} -> " ++ se 10 sc
1017+ se p e
1018+ | Just str <- slist p e = str
1019+ | Just num <- snat p e = show num
1017 se p (PApp _ (PRef _ f) [])
1020 se p (PApp _ (PRef _ f) [])
1018 | not impl = show f
1021 | not impl = show f
1019 se p (PApp _ (PRef _ op@(UN (f:_))) args)
1022 se p (PApp _ (PRef _ op@(UN (f:_))) args)
@@ -1052,6 +1055,37 @@ showImp impl tm = se 10 tm where
1052 se p (PCoerced t) = se p t
1055 se p (PCoerced t) = se p t
1053-- se p x = "Not implemented"
1056-- se p x = "Not implemented"
1054
1057
1058+ slist' p (PApp _ (PRef _ nil) _)
1059+ | nsroot nil == UN "Nil" = Just []
1060+ slist' p (PApp _ (PRef _ cons) args)
1061+ | nsroot cons == UN "::",
1062+ (PExp {getTm=tl}):(PExp {getTm=hd}):imps <- reverse args,
1063+ all isImp imps,
1064+ Just tl' <- slist' p tl
1065+ = Just (hd:tl')
1066+ where
1067+ isImp (PImp {}) = True
1068+ isImp _ = False
1069+ slist' _ _ = Nothing
1070+
1071+ slist p e | Just es <- slist' p e = Just $
1072+ case es of [] -> "[]"
1073+ [x] -> "[" ++ se p x ++ "]"
1074+ xs -> "[" ++ intercalate "," (map (se p) xs) ++ "]"
1075+ slist _ _ = Nothing
1076+
1077+ -- since Prelude is always imported, S & O are unqualified iff they're the
1078+ -- Nat ones.
1079+ snat p (PRef _ o)
1080+ | show o == (natns++"O") || show o == "O" = Just 0
1081+ snat p (PApp _ s [PExp {getTm=n}])
1082+ | show s == (natns++"S") || show s == "S",
1083+ Just n' <- snat p n
1084+ = Just $ 1 + n'
1085+ snat _ _ = Nothing
1086+
1087+ natns = "Prelude.Nat."
1088+
1055 sArg (PImp _ _ n tm _) = siArg (n, tm)
1089 sArg (PImp _ _ n tm _) = siArg (n, tm)
1056 sArg (PExp _ _ tm _) = seArg tm
1090 sArg (PExp _ _ tm _) = seArg tm
1057 sArg (PConstraint _ _ tm _) = scArg tm
1091 sArg (PConstraint _ _ tm _) = scArg tm
@@ -1128,7 +1162,7 @@ namesIn uvars ist tm = nub $ ni [] tm
1128 where
1162 where
1129 ni env (PRef _ n)
1163 ni env (PRef _ n)
1130 | not (n `elem` env)
1164 | not (n `elem` env)
1131− = case lookupTy Nothing n (tt_ctxt ist) of
1165+ = case lookupTy n (tt_ctxt ist) of
1132 [] -> [n]
1166 [] -> [n]
1133 _ -> if n `elem` (map fst uvars) then [n] else []
1167 _ -> if n `elem` (map fst uvars) then [n] else []
1134 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)
1168 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)
@@ -1152,7 +1186,7 @@ usedNamesIn vars ist tm = nub $ ni [] tm
1152 where
1186 where
1153 ni env (PRef _ n)
1187 ni env (PRef _ n)
1154 | n `elem` vars && not (n `elem` env)
1188 | n `elem` vars && not (n `elem` env)
1155− = case lookupTy Nothing n (tt_ctxt ist) of
1189+ = case lookupTy n (tt_ctxt ist) of
1156 [] -> [n]
1190 [] -> [n]
1157 _ -> []
1191 _ -> []
1158 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)
1192 ni env (PApp _ f as) = ni env f ++ concatMap (ni env) (map getTm as)
src/Idris/Coverage.hs+25−25
@@ -38,7 +38,7 @@ mkPatTm t = do i <- getIState
38 evalStateT (toTT timp) 0
38 evalStateT (toTT timp) 0
39 where
39 where
40 toTT (PRef _ n) = do i <- lift getIState
40 toTT (PRef _ n) = do i <- lift getIState
41− case lookupDef Nothing n (tt_ctxt i) of
41+ case lookupDef n (tt_ctxt i) of
42 [TyDecl nt _] -> return $ P nt n Erased
42 [TyDecl nt _] -> return $ P nt n Erased
43 _ -> return $ P Ref n Erased
43 _ -> return $ P Ref n Erased
44 toTT (PApp _ t args) = do t' <- toTT t
44 toTT (PApp _ t args) = do t' <- toTT t
@@ -107,9 +107,9 @@ expandAlts :: IState -> [CaseAlt] -> SC -> Idris [CaseAlt]
107expandAlts i all@(ConstCase c _ : alts) def
107expandAlts i all@(ConstCase c _ : alts) def
108 = return $ all ++ [DefaultCase def]
108 = return $ all ++ [DefaultCase def]
109expandAlts i all@(ConCase n _ _ _ : alts) def
109expandAlts i all@(ConCase n _ _ _ : alts) def
110− | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef Nothing n (tt_ctxt i)
110+ | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i)
111 = do let tyn = getTy n (tt_ctxt i)
111 = do let tyn = getTy n (tt_ctxt i)
112− case lookupCtxt Nothing tyn (idris_datatypes i) of
112+ case lookupCtxt tyn (idris_datatypes i) of
113 (TI ns _ _: _) -> do let ps = map mkPat ns
113 (TI ns _ _: _) -> do let ps = map mkPat ns
114 return $ addAlts ps (altsFor all) all
114 return $ addAlts ps (altsFor all) all
115 _ -> return all
115 _ -> return all
@@ -127,13 +127,13 @@ expandAlts i all@(ConCase n _ _ _ : alts) def
127 argList i = take i (map (\x -> (MN x "ign")) [0..])
127 argList i = take i (map (\x -> (MN x "ign")) [0..])
128
128
129 getTy n ctxt
129 getTy n ctxt
130− = case lookupTy Nothing n ctxt of
130+ = case lookupTy n ctxt of
131 (t : _) -> case unApply (getRetTy t) of
131 (t : _) -> case unApply (getRetTy t) of
132 (P _ tyn _, _) -> tyn
132 (P _ tyn _, _) -> tyn
133 x -> error $ "Can't happen getTy 1 " ++ show (n, x)
133 x -> error $ "Can't happen getTy 1 " ++ show (n, x)
134 _ -> error "Can't happen getTy 2"
134 _ -> error "Can't happen getTy 2"
135
135
136− mkPat x = case lookupCtxt Nothing x (idris_implicits i) of
136+ mkPat x = case lookupCtxt x (idris_implicits i) of
137 (pargs : _)
137 (pargs : _)
138 -> (x, length pargs)
138 -> (x, length pargs)
139 _ -> error "Can't happen - genAll"
139 _ -> error "Can't happen - genAll"
@@ -160,7 +160,7 @@ genClauses fc n xs given
160 logLvl 10 $ show argss ++ "\n" ++ show all_args
160 logLvl 10 $ show argss ++ "\n" ++ show all_args
161 logLvl 10 $ "Original: \n" ++
161 logLvl 10 $ "Original: \n" ++
162 showSep "\n" (map (\t -> showImp True (delab' i t True)) xs)
162 showSep "\n" (map (\t -> showImp True (delab' i t True)) xs)
163− let parg = case lookupCtxt Nothing n (idris_implicits i) of
163+ let parg = case lookupCtxt n (idris_implicits i) of
164 (p : _) -> p
164 (p : _) -> p
165 _ -> repeat (pexp Placeholder)
165 _ -> repeat (pexp Placeholder)
166 let tryclauses = mkClauses parg all_args
166 let tryclauses = mkClauses parg all_args
@@ -217,8 +217,8 @@ genAll i args = case filter (/=Placeholder) $ concatMap otherPats (nub args) of
217 [] -> [Placeholder]
217 [] -> [Placeholder]
218 xs -> nub xs
218 xs -> nub xs
219 where
219 where
220− conForm (PApp _ (PRef fc n) _) = isConName Nothing n (tt_ctxt i)
220+ conForm (PApp _ (PRef fc n) _) = isConName n (tt_ctxt i)
221− conForm (PRef fc n) = isConName Nothing n (tt_ctxt i)
221+ conForm (PRef fc n) = isConName n (tt_ctxt i)
222 conForm _ = False
222 conForm _ = False
223
223
224 otherPats :: PTerm -> [PTerm]
224 otherPats :: PTerm -> [PTerm]
@@ -227,22 +227,22 @@ genAll i args = case filter (/=Placeholder) $ concatMap otherPats (nub args) of
227 otherPats arg = return Placeholder
227 otherPats arg = return Placeholder
228
228
229 ops fc n xs o
229 ops fc n xs o
230− | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef Nothing n (tt_ctxt i)
230+ | (TyDecl c@(DCon _ arity) ty : _) <- lookupDef n (tt_ctxt i)
231 = do xs' <- mapM otherPats (map getTm xs)
231 = do xs' <- mapM otherPats (map getTm xs)
232 let p = PApp fc (PRef fc n) (zipWith upd xs' xs)
232 let p = PApp fc (PRef fc n) (zipWith upd xs' xs)
233 let tyn = getTy n (tt_ctxt i)
233 let tyn = getTy n (tt_ctxt i)
234− case lookupCtxt Nothing tyn (idris_datatypes i) of
234+ case lookupCtxt tyn (idris_datatypes i) of
235 (TI ns _ _ : _) -> p : map (mkPat fc) (ns \\ [n])
235 (TI ns _ _ : _) -> p : map (mkPat fc) (ns \\ [n])
236 _ -> [p]
236 _ -> [p]
237 ops fc n arg o = return Placeholder
237 ops fc n arg o = return Placeholder
238
238
239− getTy n ctxt = case lookupTy Nothing n ctxt of
239+ getTy n ctxt = case lookupTy n ctxt of
240 (t : _) -> case unApply (getRetTy t) of
240 (t : _) -> case unApply (getRetTy t) of
241 (P _ tyn _, _) -> tyn
241 (P _ tyn _, _) -> tyn
242 x -> error $ "Can't happen getTy 1 " ++ show (n, x)
242 x -> error $ "Can't happen getTy 1 " ++ show (n, x)
243 _ -> error "Can't happen getTy 2"
243 _ -> error "Can't happen getTy 2"
244
244
245− mkPat fc x = case lookupCtxt Nothing x (idris_implicits i) of
245+ mkPat fc x = case lookupCtxt x (idris_implicits i) of
246 (pargs : _)
246 (pargs : _)
247 -> PApp fc (PRef fc x) (map (upd Placeholder) pargs)
247 -> PApp fc (PRef fc x) (map (upd Placeholder) pargs)
248 _ -> error "Can't happen - genAll"
248 _ -> error "Can't happen - genAll"
@@ -306,7 +306,7 @@ calcProd i fc n pats = do patsprod <- mapM prodRec pats
306
306
307 cotype ty
307 cotype ty
308 | (P _ t _, _) <- unApply (getRetTy ty)
308 | (P _ t _, _) <- unApply (getRetTy ty)
309− = case lookupCtxt Nothing t (idris_datatypes i) of
309+ = case lookupCtxt t (idris_datatypes i) of
310 [TI _ True _] -> True
310 [TI _ True _] -> True
311 _ -> False
311 _ -> False
312 | otherwise = False
312 | otherwise = False
@@ -315,7 +315,7 @@ calcTotality :: [Name] -> FC -> Name -> [([Name], Term, Term)]
315 -> Idris Totality
315 -> Idris Totality
316calcTotality path fc n pats
316calcTotality path fc n pats
317 = do i <- getIState
317 = do i <- getIState
318− let opts = case lookupCtxt Nothing n (idris_flags i) of
318+ let opts = case lookupCtxt n (idris_flags i) of
319 [fs] -> fs
319 [fs] -> fs
320 _ -> []
320 _ -> []
321 case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of
321 case mapMaybe (checkLHS i) (map (\ (_, l, r) -> l) pats) of
@@ -339,12 +339,12 @@ checkTotality path fc n
339 updateContext (simplifyCasedef n)
339 updateContext (simplifyCasedef n)
340 ctxt <- getContext
340 ctxt <- getContext
341 i <- getIState
341 i <- getIState
342− let opts = case lookupCtxt Nothing n (idris_flags i) of
342+ let opts = case lookupCtxt n (idris_flags i) of
343 [fs] -> fs
343 [fs] -> fs
344 _ -> []
344 _ -> []
345 t' <- case t of
345 t' <- case t of
346 Unchecked ->
346 Unchecked ->
347− case lookupDef Nothing n ctxt of
347+ case lookupDef n ctxt of
348 [CaseOp _ _ _ _ pats _ _ _ _] ->
348 [CaseOp _ _ _ _ pats _ _ _ _] ->
349 do t' <- if AssertTotal `elem` opts
349 do t' <- if AssertTotal `elem` opts
350 then return $ Total []
350 then return $ Total []
@@ -378,7 +378,7 @@ checkTotality path fc n
378
378
379 warnPartial n t
379 warnPartial n t
380 = do i <- getIState
380 = do i <- getIState
381− case lookupDef Nothing n (tt_ctxt i) of
381+ case lookupDef n (tt_ctxt i) of
382 [x] -> do
382 [x] -> do
383 iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t
383 iputStrLn $ show fc ++ ":Warning - " ++ show n ++ " is " ++ show t
384-- ++ "\n" ++ show x
384-- ++ "\n" ++ show x
@@ -407,8 +407,8 @@ checkDeclTotality (fc, n)
407buildSCG :: (FC, Name) -> Idris ()
407buildSCG :: (FC, Name) -> Idris ()
408buildSCG (_, n) = do
408buildSCG (_, n) = do
409 ist <- getIState
409 ist <- getIState
410− case lookupCtxt Nothing n (idris_callgraph ist) of
410+ case lookupCtxt n (idris_callgraph ist) of
411− [cg] -> case lookupDef Nothing n (tt_ctxt ist) of
411+ [cg] -> case lookupDef n (tt_ctxt ist) of
412 [CaseOp _ _ _ _ _ args sc _ _] ->
412 [CaseOp _ _ _ _ _ args sc _ _] ->
413 do logLvl 3 $ "Building SCG for " ++ show n ++ " from\n"
413 do logLvl 3 $ "Building SCG for " ++ show n ++ " from\n"
414 ++ show sc
414 ++ show sc
@@ -442,7 +442,7 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $
442 -- how the arguments relate - either Smaller or Unknown
442 -- how the arguments relate - either Smaller or Unknown
443 argRels :: Name -> [(Name, SizeChange)]
443 argRels :: Name -> [(Name, SizeChange)]
444 argRels n = let ctxt = tt_ctxt ist
444 argRels n = let ctxt = tt_ctxt ist
445− [ty] = lookupTy Nothing n ctxt -- must exist!
445+ [ty] = lookupTy n ctxt -- must exist!
446 P _ nty _ = fst (unApply (getRetTy ty))
446 P _ nty _ = fst (unApply (getRetTy ty))
447 args = map snd (getArgTys ty) in
447 args = map snd (getArgTys ty) in
448 map (getRel nty) (map (fst . unApply . getRetTy) args)
448 map (getRel nty) (map (fst . unApply . getRetTy) args)
@@ -503,7 +503,7 @@ buildSCG' ist sc args = -- trace ("Building SCG for " ++ show sc) $
503checkSizeChange :: Name -> Idris Totality
503checkSizeChange :: Name -> Idris Totality
504checkSizeChange n = do
504checkSizeChange n = do
505 ist <- getIState
505 ist <- getIState
506− case lookupCtxt Nothing n (idris_callgraph ist) of
506+ case lookupCtxt n (idris_callgraph ist) of
507 [cg] -> do let ms = mkMultiPaths ist [] (scg cg)
507 [cg] -> do let ms = mkMultiPaths ist [] (scg cg)
508 logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++
508 logLvl 5 ("Multipath for " ++ show n ++ ":\n" ++
509 "from " ++ show (scg cg) ++ "\n" ++
509 "from " ++ show (scg cg) ++ "\n" ++
@@ -530,7 +530,7 @@ mkMultiPaths ist path cg
530 where extend (nextf, args)
530 where extend (nextf, args)
531 | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ]
531 | (nextf, args) `elem` path = [ reverse ((nextf, args) : path) ]
532 | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)
532 | [Unchecked] <- lookupTotal nextf (tt_ctxt ist)
533− = case lookupCtxt Nothing nextf (idris_callgraph ist) of
533+ = case lookupCtxt nextf (idris_callgraph ist) of
534 [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)
534 [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)
535 _ -> [ reverse ((nextf, args) : path) ]
535 _ -> [ reverse ((nextf, args) : path) ]
536 | otherwise = [ reverse ((nextf, args) : path) ]
536 | otherwise = [ reverse ((nextf, args) : path) ]
@@ -538,7 +538,7 @@ mkMultiPaths ist path cg
538-- do (nextf, args) <- cg
538-- do (nextf, args) <- cg
539-- if ((nextf, args) `elem` path)
539-- if ((nextf, args) `elem` path)
540-- then return (reverse ((nextf, args) : path))
540-- then return (reverse ((nextf, args) : path))
541−-- else case lookupCtxt Nothing nextf (idris_callgraph ist) of
541+-- else case lookupCtxt nextf (idris_callgraph ist) of
542-- [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)
542-- [ncg] -> mkMultiPaths ist ((nextf, args) : path) (scg ncg)
543-- _ -> return (reverse ((nextf, args) : path))
543-- _ -> return (reverse ((nextf, args) : path))
544
544
@@ -562,12 +562,12 @@ checkMP ist i mp = if i > 0
562-- = Partial BelieveMe
562-- = Partial BelieveMe
563 -- if we get to a constructor, it's fine as long as it's strictly positive
563 -- if we get to a constructor, it's fine as long as it's strictly positive
564 tryPath desc path ((f, _) :es) arg
564 tryPath desc path ((f, _) :es) arg
565− | [TyDecl (DCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)
565+ | [TyDecl (DCon _ _) _] <- lookupDef f (tt_ctxt ist)
566 = case lookupTotal f (tt_ctxt ist) of
566 = case lookupTotal f (tt_ctxt ist) of
567 [Total _] -> Unchecked -- okay so far
567 [Total _] -> Unchecked -- okay so far
568 [Partial _] -> Partial (Other [f])
568 [Partial _] -> Partial (Other [f])
569 x -> error (show x)
569 x -> error (show x)
570− | [TyDecl (TCon _ _) _] <- lookupDef Nothing f (tt_ctxt ist)
570+ | [TyDecl (TCon _ _) _] <- lookupDef f (tt_ctxt ist)
571 = Total []
571 = Total []
572 tryPath desc path (e@(f, args) : es) arg
572 tryPath desc path (e@(f, args) : es) arg
573 | e `elem` es && allNothing args = Partial (Mutual [f])
573 | 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 ()
17forceArgs :: Name -> Type -> Idris ()
18forceArgs n t = do i <- getIState
18forceArgs n t = do i <- getIState
19 let fargs = force i 0 t
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 [] []
21 [] -> return $ Optimise False [] []
22 (op:_) -> return op
22 (op:_) -> return op
23 let opts = addDef n (copt { forceable = fargs }) (idris_optimisation i)
23 let opts = addDef n (copt { forceable = fargs }) (idris_optimisation i)
@@ -38,7 +38,7 @@ forceArgs n t = do i <- getIState
38
38
39 collapsibleIn i t
39 collapsibleIn i t
40 | (P _ tn _, _) <- unApply 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
42 [oi] -> collapsible oi
43 _ -> False
43 _ -> False
44 | otherwise = False
44 | otherwise = False
@@ -68,7 +68,7 @@ collapseCons ty cons =
68 setCollapsible n
68 setCollapsible n
69 = do i <- getIState
69 = do i <- getIState
70 iLOG $ show n ++ " collapsible"
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 }
72 (oi:_) -> do let oi' = oi { collapsible = True }
73 let opts = addDef n oi' (idris_optimisation i)
73 let opts = addDef n oi' (idris_optimisation i)
74 putIState (i { idris_optimisation = opts })
74 putIState (i { idris_optimisation = opts })
@@ -79,15 +79,15 @@ collapseCons ty cons =
79
79
80 forceRec :: IState -> (Name, [Type]) -> Idris Bool
80 forceRec :: IState -> (Name, [Type]) -> Idris Bool
81 forceRec i (n, ts)
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
83 (oi:_) -> checkFR (forceable oi) 0 ts
84 _ -> return False
84 _ -> return False
85 checkFR fs i [] = return True
85 checkFR fs i [] = return True
86 checkFR fs i (_ : xs) | i `elem` fs = checkFR fs (i + 1) xs
86 checkFR fs i (_ : xs) | i `elem` fs = checkFR fs (i + 1) xs
87 checkFR fs i (t : xs)
87 checkFR fs i (t : xs)
88 -- must be recursive or type is not collapsible
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
91 then checkFR fs (i+1) xs
92 else return False
92 else return False
93
93
@@ -161,7 +161,7 @@ instance Optimisable Raw where
161 | (Var n, args) <- raw_unapply t -- MAGIC HERE
161 | (Var n, args) <- raw_unapply t -- MAGIC HERE
162 = do args' <- mapM applyOpts args
162 = do args' <- mapM applyOpts args
163 i <- getIState
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'
165 (oi:_) -> return $ applyDataOpt oi n args'
166 _ -> return (raw_apply (Var n) args')
166 _ -> return (raw_apply (Var n) args')
167 | otherwise = do f' <- applyOpts f
167 | otherwise = do f' <- applyOpts f
@@ -202,14 +202,14 @@ applyDataOpt oi n args
202instance Optimisable (TT Name) where
202instance Optimisable (TT Name) where
203 applyOpts c@(P (DCon t arity) n _)
203 applyOpts c@(P (DCon t arity) n _)
204 = do i <- getIState
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 []
206 (oi:_) -> return $ applyDataOptRT oi n t arity []
207 _ -> return c
207 _ -> return c
208 applyOpts t@(App f a)
208 applyOpts t@(App f a)
209 | (c@(P (DCon t arity) n _), args) <- unApply t -- MAGIC HERE
209 | (c@(P (DCon t arity) n _), args) <- unApply t -- MAGIC HERE
210 = do args' <- mapM applyOpts args
210 = do args' <- mapM applyOpts args
211 i <- getIState
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'
213 (oi:_) -> do return $ applyDataOptRT oi n t arity args'
214 _ -> return (mkApp c args')
214 _ -> return (mkApp c args')
215 | otherwise = do f' <- applyOpts f
215 | otherwise = do f' <- applyOpts f
@@ -224,7 +224,7 @@ instance Optimisable (TT Name) where
224
224
225 stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x
225 stripCollapsed (Bind n (PVar x) t) | (P _ ty _, _) <- unApply x
226 = do i <- getIState
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
228 [oi] -> if collapsible oi
229 then do t' <- stripCollapsed t
229 then do t' <- stripCollapsed t
230 return (Bind n (PVar x) (instantiate Erased t'))
230 return (Bind n (PVar x) (instantiate Erased t'))
src/Idris/Delaborate.hs+56−34
@@ -7,6 +7,7 @@ module Idris.Delaborate where
7
7
8import Idris.AbsSyntax
8import Idris.AbsSyntax
9import Core.TT
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
src/Idris/Docs.hs+6−6
@@ -65,9 +65,9 @@ instance Show Doc where
65getDocs :: Name -> Idris Doc
65getDocs :: Name -> Idris Doc
66getDocs n
66getDocs n
67 = do i <- getIState
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
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
71 [ti] -> docData n ti
72 _ -> do fd <- docFun n
72 _ -> do fd <- docFun n
73 return (FunDoc fd)
73 return (FunDoc fd)
@@ -81,7 +81,7 @@ docData n ti
81docClass :: Name -> ClassInfo -> Idris Doc
81docClass :: Name -> ClassInfo -> Idris Doc
82docClass n ci
82docClass n ci
83 = do i <- getIState
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
85 [str] -> str
86 _ -> ""
86 _ -> ""
87 mdocs <- mapM docFun (map fst (class_methods ci))
87 mdocs <- mapM docFun (map fst (class_methods ci))
@@ -90,13 +90,13 @@ docClass n ci
90docFun :: Name -> Idris FunDoc
90docFun :: Name -> Idris FunDoc
91docFun n
91docFun n
92 = do i <- getIState
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
94 [str] -> str
95 _ -> ""
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
97 (t : _) -> t
98 let argnames = map fst (getArgTys ty)
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
100 [args] -> zip argnames args
101 _ -> []
101 _ -> []
102 let infixes = idris_infixes i
102 let infixes = idris_infixes i
src/Idris/ElabDecls.hs+75−53
@@ -69,7 +69,7 @@ elabType info syn doc fc opts n ty' = {- let ty' = piBind (params info) ty_in
69 let nty' = normalise ctxt [] nty
69 let nty' = normalise ctxt [] nty
70 let (t, _) = unApply (getRetTy nty')
70 let (t, _) = unApply (getRetTy nty')
71 let corec = case t of
71 let corec = case t of
72− P _ rcty _ -> case lookupCtxt Nothing rcty (idris_datatypes i) of
72+ P _ rcty _ -> case lookupCtxt rcty (idris_datatypes i) of
73 [TI _ True _] -> True
73 [TI _ True _] -> True
74 _ -> False
74 _ -> False
75 _ -> False
75 _ -> False
@@ -93,14 +93,14 @@ elabPostulate info syn doc fc opts n ty
93 -- make sure it's collapsible, so it is never needed at run time
93 -- make sure it's collapsible, so it is never needed at run time
94 -- start by getting the elaborated type
94 -- start by getting the elaborated type
95 ctxt <- getContext
95 ctxt <- getContext
96− fty <- case lookupTy Nothing n ctxt of
96+ fty <- case lookupTy n ctxt of
97 [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen!
97 [] -> tclift $ tfail $ (At fc (NoTypeDecl n)) -- can't happen!
98 [ty] -> return ty
98 [ty] -> return ty
99 ist <- getIState
99 ist <- getIState
100 let (ap, _) = unApply (getRetTy (normalise ctxt [] fty))
100 let (ap, _) = unApply (getRetTy (normalise ctxt [] fty))
101 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)
101 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)
102 let postOK = case ap of
102 let postOK = case ap of
103− P _ tn _ -> case lookupCtxt Nothing tn
103+ P _ tn _ -> case lookupCtxt tn
104 (idris_optimisation ist) of
104 (idris_optimisation ist) of
105 [oi] -> collapsible oi
105 [oi] -> collapsible oi
106 _ -> False
106 _ -> False
@@ -147,7 +147,7 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)
147 ttag <- getName
147 ttag <- getName
148 i <- getIState
148 i <- getIState
149 let as = map (const Nothing) (getArgTys cty)
149 let as = map (const Nothing) (getArgTys cty)
150− let params = findParams (zip as (repeat True)) (map snd cons)
150+ let params = findParams (map snd cons)
151 logLvl 2 $ "Parameters : " ++ show params
151 logLvl 2 $ "Parameters : " ++ show params
152 putIState (i { idris_datatypes = addDef n (TI (map fst cons) codata params)
152 putIState (i { idris_datatypes = addDef n (TI (map fst cons) codata params)
153 (idris_datatypes i) })
153 (idris_datatypes i) })
@@ -161,32 +161,53 @@ elabData info syn doc fc codata (PDatadecl n t_in dcons)
161 where
161 where
162 -- parameters are names which are unchanged across the structure,
162 -- parameters are names which are unchanged across the structure,
163 -- which appear exactly once in the return type of a constructor
163 -- which appear exactly once in the return type of a constructor
164− findParams :: [(Maybe Name, Bool)] -> [Type] -> [Int]
164+
165− findParams ps [] = mapMaybe (\ ((x, y), n) ->
165+ -- First, find all applications of the constructor, then check over
166− if y then Just n else Nothing)
166+ -- them for repeated arguments
167− (zip ps [0..])
167+
168− findParams ps (t : ts) = findParams (updateParams ps t) ts
168+ findParams :: [Type] -> [Int]
169−
169+ findParams ts = let allapps = concatMap getDataApp ts in
170− updateParams ps (Bind n (Pi t) sc)
170+ paramPos allapps
171− = updateParams (updateParams ps (instantiate (P Bound n t) sc)) t
171+
172− updateParams ps tm@(App f a)
172+ paramPos [] = []
173+ paramPos (args : rest)
174+ = dropNothing $ keepSame (zip [0..] args) rest
175+
176+ dropNothing [] = []
177+ dropNothing ((x, Nothing) : ts) = dropNothing ts
178+ dropNothing ((x, _) : ts) = x : dropNothing ts
179+
180+ keepSame :: [(Int, Maybe Name)] -> [[Maybe Name]] ->
181+ [(Int, Maybe Name)]
182+ keepSame as [] = as
183+ keepSame as (args : rest) = keepSame (update as args) rest
184+ where
185+ update [] _ = []
186+ update _ [] = []
187+ update ((n, Just x) : as) (Just x' : args)
188+ | x == x' = (n, Just x) : update as args
189+ update ((n, _) : as) (_ : args) = (n, Nothing) : update as args
190+
191+ getDataApp :: Type -> [[Maybe Name]]
192+ getDataApp f@(App _ _)
173− | (P _ fn _, args) <- unApply tm
193+ | (P _ d _, args) <- unApply f
174− = if fn == n
194+ = if (d == n) then [mParam args args] else []
175− then updateParamsA ps args (tail args)
195+ getDataApp (Bind n (Pi t) sc)
176− else updateParams (updateParams ps f) a
196+ = getDataApp t ++ getDataApp (instantiate (P Bound n t) sc)
177− | otherwise = updateParams (updateParams ps f) a
197+ getDataApp _ = []
178− updateParams ps _ = ps
198+
179−
199+ -- keep the arguments which are single names, which don't appear
180− updateParamsA ((mn, _) : ns) (p@(P _ n' _) : args) all
200+ -- elsewhere
201+
202+ mParam args [] = []
203+ mParam args (P Bound n _ : rest)
204+ | count n args == 1
205+ = Just n : mParam args rest
206+ where count n [] = 0
207+ count n (t : ts)
181− | n' `elem` concatMap freeNames all
208+ | n `elem` freeNames t = 1 + count n ts
182− = (mn, False) : updateParamsA ns args (p : all)
209+ | otherwise = count n ts
183− updateParamsA ((Nothing, b) : ns) (p@(P _ n' _) : args) all
210+ 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
211
191-- | Elaborate a type provider
212-- | Elaborate a type provider
192elabProvider :: ElabInfo -> SyntaxInfo -> FC -> Name -> PTerm -> PTerm -> Idris ()
213elabProvider :: ElabInfo -> SyntaxInfo -> FC -> Name -> PTerm -> PTerm -> Idris ()
@@ -202,11 +223,11 @@ elabProvider info syn fc n ty tm
202 " as " ++ show using
223 " as " ++ show using
203 (e', et) <- elabVal toplevel False using
224 (e', et) <- elabVal toplevel False using
204 ctxt <- getContext
225 ctxt <- getContext
205− let e'' = normaliseAll ctxt [] e'
226+ let str = show e' in
206− logLvl 1 $ "Term is " ++ show e''
227+ logLvl 1 $ "Term is " ++ if length str > 200 then (take 200 str) ++ "..." else str
207 let et' = normaliseAll ctxt [] et
228 let et' = normaliseAll ctxt [] et
208 elabType info syn "" fc [] n ty
229 elabType info syn "" fc [] n ty
209− rhs <- execute e''
230+ rhs <- execute e'
210 logLvl 1 $ "Normalized " ++ show n ++ "'s RHS to " ++ show rhs
231 logLvl 1 $ "Normalized " ++ show n ++ "'s RHS to " ++ show rhs
211 providerError rhs
232 providerError rhs
212 elabClauses info fc [] n [PClause fc n (PRef fc $ n) [] (delab i rhs) []]
233 elabClauses info fc [] n [PClause fc n (PRef fc $ n) [] (delab i rhs) []]
@@ -219,10 +240,10 @@ elabRecord info syn doc fc tyn ty cdoc cn cty
219 = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)])
240 = do elabData info syn doc fc False (PDatadecl tyn ty [(cdoc, cn, cty, fc)])
220 cty' <- implicit syn cn cty
241 cty' <- implicit syn cn cty
221 i <- getIState
242 i <- getIState
222− cty <- case lookupTy Nothing cn (tt_ctxt i) of
243+ cty <- case lookupTy cn (tt_ctxt i) of
223 [t] -> return (delab i t)
244 [t] -> return (delab i t)
224 _ -> fail "Something went inexplicably wrong"
245 _ -> fail "Something went inexplicably wrong"
225− cimp <- case lookupCtxt Nothing cn (idris_implicits i) of
246+ cimp <- case lookupCtxt cn (idris_implicits i) of
226 [imps] -> return imps
247 [imps] -> return imps
227 let ptys = getProjs [] (renameBs cimp cty)
248 let ptys = getProjs [] (renameBs cimp cty)
228 let ptys_u = getProjs [] cty
249 let ptys_u = getProjs [] cty
@@ -363,7 +384,7 @@ elabClauses :: ElabInfo -> FC -> FnOpts -> Name -> [PClause] -> Idris ()
363elabClauses info fc opts n_in cs = let n = liftname info n_in in
384elabClauses info fc opts n_in cs = let n = liftname info n_in in
364 do ctxt <- getContext
385 do ctxt <- getContext
365 -- Check n actually exists, with no definition yet
386 -- Check n actually exists, with no definition yet
366− let tys = lookupTy Nothing n ctxt
387+ let tys = lookupTy n ctxt
367 checkUndefined n ctxt
388 checkUndefined n ctxt
368 unless (length tys > 1) $ do
389 unless (length tys > 1) $ do
369 fty <- case tys of
390 fty <- case tys of
@@ -380,7 +401,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in
380 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)
401 logLvl 5 $ "Checking collapsibility of " ++ show (ap, fty)
381 -- FIXME: Really ought to only do this for total functions!
402 -- FIXME: Really ought to only do this for total functions!
382 let doNothing = case ap of
403 let doNothing = case ap of
383− P _ tn _ -> case lookupCtxt Nothing tn
404+ P _ tn _ -> case lookupCtxt tn
384 (idris_optimisation ist) of
405 (idris_optimisation ist) of
385 [oi] -> collapsible oi
406 [oi] -> collapsible oi
386 _ -> False
407 _ -> False
@@ -388,7 +409,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in
388 solveDeferred n
409 solveDeferred n
389 ist <- getIState
410 ist <- getIState
390 when doNothing $
411 when doNothing $
391− case lookupCtxt Nothing n (idris_optimisation ist) of
412+ case lookupCtxt n (idris_optimisation ist) of
392 [oi] -> do let opts = addDef n (oi { collapsible = True })
413 [oi] -> do let opts = addDef n (oi { collapsible = True })
393 (idris_optimisation ist)
414 (idris_optimisation ist)
394 putIState (ist { idris_optimisation = opts })
415 putIState (ist { idris_optimisation = opts })
@@ -430,6 +451,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in
430 else return []
451 else return []
431 let pcover = null pmissing
452 let pcover = null pmissing
432 logLvl 2 $ "Optimising patterns"
453 logLvl 2 $ "Optimising patterns"
454+ logLvl 5 $ show optpdef
433 pdef' <- applyOpts optpdef
455 pdef' <- applyOpts optpdef
434 logLvl 2 $ "Optimised patterns"
456 logLvl 2 $ "Optimised patterns"
435 logLvl 5 $ show pdef'
457 logLvl 5 $ show pdef'
@@ -459,7 +481,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in
459 ctxt <- getContext
481 ctxt <- getContext
460 ist <- getIState
482 ist <- getIState
461 putIState (ist { idris_patdefs = addDef n pdef' (idris_patdefs ist) })
483 putIState (ist { idris_patdefs = addDef n pdef' (idris_patdefs ist) })
462− case lookupTy (namespace info) n ctxt of
484+ case lookupTy n ctxt of
463 [ty] -> do updateContext (addCasedef n (inlinable opts)
485 [ty] -> do updateContext (addCasedef n (inlinable opts)
464 tcase knowncovering
486 tcase knowncovering
465 (AssertTotal `elem` opts)
487 (AssertTotal `elem` opts)
@@ -470,7 +492,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in
470 totcheck (fc, n)
492 totcheck (fc, n)
471 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)
493 when (tot /= Unchecked) $ addIBC (IBCTotal n tot)
472 i <- getIState
494 i <- getIState
473− case lookupDef Nothing n (tt_ctxt i) of
495+ case lookupDef n (tt_ctxt i) of
474 (CaseOp _ _ _ _ _ scargs sc scargs' sc' : _) ->
496 (CaseOp _ _ _ _ _ scargs sc scargs' sc' : _) ->
475 do let calls = findCalls sc' scargs'
497 do let calls = findCalls sc' scargs'
476 let used = findUsedArgs sc' scargs'
498 let used = findUsedArgs sc' scargs'
@@ -486,7 +508,7 @@ elabClauses info fc opts n_in cs = let n = liftname info n_in in
486 [] -> return ()
508 [] -> return ()
487 return ()
509 return ()
488 where
510 where
489− checkUndefined n ctxt = case lookupDef Nothing n ctxt of
511+ checkUndefined n ctxt = case lookupDef n ctxt of
490 [] -> return ()
512 [] -> return ()
491 [TyDecl _ _] -> return ()
513 [TyDecl _ _] -> return ()
492 _ -> tclift $ tfail (At fc (AlreadyDefined n))
514 _ -> tclift $ tfail (At fc (AlreadyDefined n))
@@ -571,10 +593,10 @@ elabClause info tcgen (cnum, PClause fc fname lhs_in withs rhs_in whereblock)
571 -- pattern bindings
593 -- pattern bindings
572 i <- getIState
594 i <- getIState
573 -- get the parameters first, to pass through to any where block
595 -- get the parameters first, to pass through to any where block
574− let fn_ty = case lookupTy Nothing fname (tt_ctxt i) of
596+ let fn_ty = case lookupTy fname (tt_ctxt i) of
575 [t] -> t
597 [t] -> t
576 _ -> error "Can't happen (elabClause function type)"
598 _ -> error "Can't happen (elabClause function type)"
577− let fn_is = case lookupCtxt Nothing fname (idris_implicits i) of
599+ let fn_is = case lookupCtxt fname (idris_implicits i) of
578 [t] -> t
600 [t] -> t
579 _ -> []
601 _ -> []
580 let params = getParamsInType i [] fn_is fn_ty
602 let params = getParamsInType i [] fn_is fn_ty
@@ -678,7 +700,7 @@ elabClause info tcgen (cnum, PClause fc fname lhs_in withs rhs_in whereblock)
678 = getParamsInType i (n : env) is (instantiate (P Bound n t) sc)
700 = getParamsInType i (n : env) is (instantiate (P Bound n t) sc)
679 getParamsInType i env is tm@(App f a)
701 getParamsInType i env is tm@(App f a)
680 | (P _ tn _, args) <- unApply tm
702 | (P _ tn _, args) <- unApply tm
681− = case lookupCtxt Nothing tn (idris_datatypes i) of
703+ = case lookupCtxt tn (idris_datatypes i) of
682 [t] -> nub $ paramNames args env (param_pos t) ++
704 [t] -> nub $ paramNames args env (param_pos t) ++
683 getParamsInType i env is f ++
705 getParamsInType i env is f ++
684 getParamsInType i env is a
706 getParamsInType i env is a
@@ -711,7 +733,7 @@ elabClause info tcgen (_, PWith fc fname lhs_in withs wval_in withblock)
711 -- Build the LHS as an "Infer", and pull out its type and
733 -- Build the LHS as an "Infer", and pull out its type and
712 -- pattern bindings
734 -- pattern bindings
713 i <- getIState
735 i <- getIState
714− let lhs = addImpl i lhs_in
736+ let lhs = addImplPat i lhs_in
715 logLvl 5 ("LHS: " ++ showImp True lhs)
737 logLvl 5 ("LHS: " ++ showImp True lhs)
716 ((lhs', dlhs, []), _) <-
738 ((lhs', dlhs, []), _) <-
717 tclift $ elaborate ctxt (MN 0 "patLHS") infP []
739 tclift $ elaborate ctxt (MN 0 "patLHS") infP []
@@ -809,18 +831,18 @@ elabClause info tcgen (_, PWith fc fname lhs_in withs wval_in withblock)
809
831
810 mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)
832 mkAux wname toplhs ns ns' (PClause fc n tm_in (w:ws) rhs wheres)
811 = do i <- getIState
833 = do i <- getIState
812− let tm = addImpl i tm_in
834+ let tm = addImplPat i tm_in
813 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++
835 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++
814 showImp True toplhs)
836 showImp True toplhs)
815 case matchClause i toplhs tm of
837 case matchClause i toplhs tm of
816− Left _ -> fail $ show fc ++ "with clause does not match top level"
838+ Left f -> fail $ show fc ++ ":with clause does not match top level"
817 Right mvars ->
839 Right mvars ->
818 do logLvl 3 ("Match vars : " ++ show mvars)
840 do logLvl 3 ("Match vars : " ++ show mvars)
819 lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w
841 lhs <- updateLHS n wname mvars ns ns' (fullApp tm) w
820 return $ PClause fc wname lhs ws rhs wheres
842 return $ PClause fc wname lhs ws rhs wheres
821 mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs)
843 mkAux wname toplhs ns ns' (PWith fc n tm_in (w:ws) wval withs)
822 = do i <- getIState
844 = do i <- getIState
823− let tm = addImpl i tm_in
845+ let tm = addImplPat i tm_in
824 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++
846 logLvl 2 ("Matching " ++ showImp True tm ++ " against " ++
825 showImp True toplhs)
847 showImp True toplhs)
826 withs' <- mapM (mkAuxC wname toplhs ns ns') withs
848 withs' <- mapM (mkAuxC wname toplhs ns ns') withs
@@ -954,7 +976,7 @@ elabClass info syn doc fc constraints tn ps ds
954 let conn = case con of
976 let conn = case con of
955 PRef _ n -> n
977 PRef _ n -> n
956 PApp _ (PRef _ n) _ -> n
978 PApp _ (PRef _ n) _ -> n
957− let conn' = case lookupCtxtName Nothing conn (idris_classes i) of
979+ let conn' = case lookupCtxtName conn (idris_classes i) of
958 [(n, _)] -> n
980 [(n, _)] -> n
959 _ -> conn
981 _ -> conn
960 addInstance False conn' cfn
982 addInstance False conn' cfn
@@ -1015,7 +1037,7 @@ elabInstance :: ElabInfo -> SyntaxInfo ->
1015 [PDecl] -> Idris ()
1037 [PDecl] -> Idris ()
1016elabInstance info syn fc cs n ps t expn ds
1038elabInstance info syn fc cs n ps t expn ds
1017 = do i <- getIState
1039 = do i <- getIState
1018− (n, ci) <- case lookupCtxtName (namespace info) n (idris_classes i) of
1040+ (n, ci) <- case lookupCtxtName n (idris_classes i) of
1019 [c] -> return c
1041 [c] -> return c
1020 _ -> fail $ show fc ++ ":" ++ show n ++ " is not a type class"
1042 _ -> fail $ show fc ++ ":" ++ show n ++ " is not a type class"
1021 let constraint = PApp fc (PRef fc n) (map pexp ps)
1043 let constraint = PApp fc (PRef fc n) (map pexp ps)
@@ -1075,7 +1097,7 @@ elabInstance info syn fc cs n ps t expn ds
1075 checkNotOverlapping i t n
1097 checkNotOverlapping i t n
1076 | take 2 (show n) == "@@" = return ()
1098 | take 2 (show n) == "@@" = return ()
1077 | otherwise
1099 | otherwise
1078− = case lookupTy Nothing n (tt_ctxt i) of
1100+ = case lookupTy n (tt_ctxt i) of
1079 [t'] -> let tret = getRetType t
1101 [t'] -> let tret = getRetType t
1080 tret' = getRetType (delab i t') in
1102 tret' = getRetType (delab i t') in
1081 case matchClause i tret' tret of
1103 case matchClause i tret' tret of
@@ -1112,7 +1134,7 @@ elabInstance info syn fc cs n ps t expn ds
1112 | PRef _ n <- getTm p
1134 | PRef _ n <- getTm p
1113 = do ps' <- getWParams ps
1135 = do ps' <- getWParams ps
1114 ctxt <- getContext
1136 ctxt <- getContext
1115− case lookupP Nothing n ctxt of
1137+ case lookupP n ctxt of
1116 [] -> return (pimp n (PRef fc n) : ps')
1138 [] -> return (pimp n (PRef fc n) : ps')
1117 _ -> return ps'
1139 _ -> return ps'
1118 getWParams (_ : ps) = getWParams ps
1140 getWParams (_ : ps) = getWParams ps
@@ -1247,7 +1269,7 @@ elabDecl' what info d@(PClauses f o n ps)
1247 | what /= ETypes
1269 | what /= ETypes
1248 = do iLOG $ "Elaborating clause " ++ show n
1270 = do iLOG $ "Elaborating clause " ++ show n
1249 i <- getIState -- get the type options too
1271 i <- getIState -- get the type options too
1250− let o' = case lookupCtxt Nothing n (idris_flags i) of
1272+ let o' = case lookupCtxt n (idris_flags i) of
1251 [fs] -> fs
1273 [fs] -> fs
1252 [] -> []
1274 [] -> []
1253 elabClauses info f (o ++ o') n ps
1275 elabClauses info f (o ++ o') n ps
src/Idris/ElabTerm.hs+17−15
@@ -211,7 +211,7 @@ elab ist info pattern tcgen fn tm
211 elab' ina (PPatvar fc n) | pattern = patvar n
211 elab' ina (PPatvar fc n) | pattern = patvar n
212 elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n)
212 elab' (ina, guarded) (PRef fc n) | pattern && not (inparamBlock n)
213 = do ctxt <- get_context
213 = do ctxt <- get_context
214− let defined = case lookupTy Nothing n ctxt of
214+ let defined = case lookupTy n ctxt of
215 [] -> False
215 [] -> False
216 _ -> True
216 _ -> True
217 -- this is to stop us resolve type classes recursively
217 -- this is to stop us resolve type classes recursively
@@ -221,7 +221,7 @@ elab ist info pattern tcgen fn tm
221 then do apply (Var n) []; solve
221 then do apply (Var n) []; solve
222 else try (do apply (Var n) []; solve)
222 else try (do apply (Var n) []; solve)
223 (patvar n)
223 (patvar n)
224− where inparamBlock n = case lookupCtxtName Nothing n (inblock info) of
224+ where inparamBlock n = case lookupCtxtName n (inblock info) of
225 [] -> False
225 [] -> False
226 _ -> True
226 _ -> True
227 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])
227 elab' ina f@(PInferRef fc n) = elab' ina (PApp fc f [])
@@ -334,7 +334,7 @@ elab ist info pattern tcgen fn tm
334 elab' (ina, g) tm@(PApp fc (PRef _ f) args')
334 elab' (ina, g) tm@(PApp fc (PRef _ f) args')
335 = do let args = {- case lookupCtxt f (inblock info) of
335 = do let args = {- case lookupCtxt f (inblock info) of
336 Just ps -> (map (pexp . (PRef fc)) ps ++ args')
336 Just ps -> (map (pexp . (PRef fc)) ps ++ args')
337− _ ->-} args'
337+ _ -> -} args'
338-- newtm <- mkSpecialised ist fc f (map getTm args') tm
338-- newtm <- mkSpecialised ist fc f (map getTm args') tm
339 env <- get_env
339 env <- get_env
340 if (f `elem` map fst env && length args' == 1)
340 if (f `elem` map fst env && length args' == 1)
@@ -350,11 +350,11 @@ elab ist info pattern tcgen fn tm
350 let isinf = f == inferCon || tcname f
350 let isinf = f == inferCon || tcname f
351 -- if f is a type class, we need to know its arguments so that
351 -- if f is a type class, we need to know its arguments so that
352 -- we can unify with them
352 -- we can unify with them
353− case lookupCtxt Nothing f (idris_classes ist) of
353+ case lookupCtxt f (idris_classes ist) of
354 [] -> return ()
354 [] -> return ()
355 _ -> mapM_ setInjective (map getTm args')
355 _ -> mapM_ setInjective (map getTm args')
356 ctxt <- get_context
356 ctxt <- get_context
357− let guarded = isConName Nothing f ctxt
357+ let guarded = isConName f ctxt
358 ns <- apply (Var f) (map isph args)
358 ns <- apply (Var f) (map isph args)
359 ptm <- get_term
359 ptm <- get_term
360 g <- goal
360 g <- goal
@@ -547,7 +547,7 @@ pruneAlt xs = map prune xs
547pruneByType :: Term -> Context -> [PTerm] -> [PTerm]
547pruneByType :: Term -> Context -> [PTerm] -> [PTerm]
548pruneByType (P _ n _) c as
548pruneByType (P _ n _) c as
549-- if the goal type is polymorphic, keep e
549-- if the goal type is polymorphic, keep e
550− | [] <- lookupTy Nothing n c = as
550+ | [] <- lookupTy n c = as
551 | otherwise
551 | otherwise
552 = let asV = filter (headIs True n) as
552 = let asV = filter (headIs True n) as
553 as' = filter (headIs False n) as in
553 as' = filter (headIs False n) as in
@@ -563,7 +563,7 @@ pruneByType (P _ n _) c as
563 headIs _ _ _ = True -- keep if it's not an application
563 headIs _ _ _ = True -- keep if it's not an application
564
564
565 typeHead var f f'
565 typeHead var f f'
566− = case lookupTy Nothing f' c of
566+ = case lookupTy f' c of
567 [ty] -> let ty' = normalise c [] ty in
567 [ty] -> let ty' = normalise c [] ty in
568 case unApply (getRetTy ty') of
568 case unApply (getRetTy ty') of
569 (P _ ftyn _, _) -> ftyn == f
569 (P _ ftyn _, _) -> ftyn == f
@@ -596,7 +596,7 @@ trivial ist = try' (do elab ist toplevel False False (MN 0 "tac")
596findInstances :: IState -> Term -> [Name]
596findInstances :: IState -> Term -> [Name]
597findInstances ist t
597findInstances ist t
598 | (P _ n _, _) <- unApply t
598 | (P _ n _, _) <- unApply t
599− = case lookupCtxt Nothing n (idris_classes ist) of
599+ = case lookupCtxt n (idris_classes ist) of
600 [CI _ _ _ _ ins] -> ins
600 [CI _ _ _ _ ins] -> ins
601 _ -> []
601 _ -> []
602 | otherwise = []
602 | otherwise = []
@@ -658,7 +658,7 @@ resolveTC depth fn ist
658-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist
658-- if (all boundVar ttypes) then resolveTC (depth - 1) fn insts ist
659-- else do
659-- else do
660 -- if there's a hole in the goal, don't even try
660 -- if there's a hole in the goal, don't even try
661− let imps = case lookupCtxtName Nothing n (idris_implicits ist) of
661+ let imps = case lookupCtxtName n (idris_implicits ist) of
662 [] -> []
662 [] -> []
663 [args] -> map isImp (snd args) -- won't be overloaded!
663 [args] -> map isImp (snd args) -- won't be overloaded!
664 ps <- get_probs
664 ps <- get_probs
@@ -695,10 +695,12 @@ collectDeferred (App f a) = liftM2 App (collectDeferred f) (collectDeferred a)
695collectDeferred t = return t
695collectDeferred t = return t
696
696
697-- Running tactics directly
697-- Running tactics directly
698+-- if a tactic adds unification problems, return an error
698
699
699runTac :: Bool -> IState -> PTactic -> ElabD ()
700runTac :: Bool -> IState -> PTactic -> ElabD ()
700−runTac autoSolve ist tac = do env <- get_env
701+runTac autoSolve ist tac
702+ = do env <- get_env
701− runT (fmap (addImplBound ist (map fst env)) tac)
703+ no_errors $ runT (fmap (addImplBound ist (map fst env)) tac)
702 where
704 where
703 runT (Intro []) = do g <- goal
705 runT (Intro []) = do g <- goal
704 attack; intro (bname g)
706 attack; intro (bname g)
@@ -716,7 +718,7 @@ runTac autoSolve ist tac = do env <- get_env
716 runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm
718 runT (Exact tm) = do elab ist toplevel False False (MN 0 "tac") tm
717 when autoSolve solveAll
719 when autoSolve solveAll
718 runT (Refine fn [])
720 runT (Refine fn [])
719− = do (fn', imps) <- case lookupCtxtName Nothing fn (idris_implicits ist) of
721+ = do (fn', imps) <- case lookupCtxtName fn (idris_implicits ist) of
720 [] -> do a <- envArgs fn
722 [] -> do a <- envArgs fn
721 return (fn, a)
723 return (fn, a)
722 -- FIXME: resolve ambiguities
724 -- FIXME: resolve ambiguities
@@ -1200,7 +1202,7 @@ solveAll = try (do solve; solveAll) (return ())
1200mkSpecialised :: IState -> FC -> Name -> [PTerm] -> PTerm -> ElabD PTerm
1202mkSpecialised :: IState -> FC -> Name -> [PTerm] -> PTerm -> ElabD PTerm
1201mkSpecialised i fc n args def
1203mkSpecialised i fc n args def
1202 = do let tm' = def
1204 = do let tm' = def
1203− case lookupCtxt Nothing n (idris_statics i) of
1205+ case lookupCtxt n (idris_statics i) of
1204 [] -> return tm'
1206 [] -> return tm'
1205 [as] -> if (not (or as)) then return tm' else
1207 [as] -> if (not (or as)) then return tm' else
1206 mkSpecDecl i n (zip args as) tm'
1208 mkSpecDecl i n (zip args as) tm'
@@ -1227,8 +1229,8 @@ mkSpecDecl i n pargs tm'
1227 cg = idris_callgraph i
1229 cg = idris_callgraph i
1228
1230
1229 staticFnNames tm | (P _ f _, as) <- unApply tm
1231 staticFnNames tm | (P _ f _, as) <- unApply tm
1230− = if not (isFnName Nothing f ctxt) then []
1232+ = if not (isFnName f ctxt) then []
1231− else case lookupCtxt Nothing f cg of
1233+ else case lookupCtxt f cg of
1232 [ns] -> f : f : [] --(ns \\ [f])
1234 [ns] -> f : f : [] --(ns \\ [f])
1233 [] -> [f,f]
1235 [] -> [f,f]
1234 _ -> []
1236 _ -> []
src/Idris/IBC.hs+40−26
@@ -18,6 +18,8 @@ import Control.Monad.State hiding (get, put)
18import System.FilePath
18import System.FilePath
19import System.Directory
19import System.Directory
20
20
21+import Debug.Trace
22+
21import Paths_idris
23import Paths_idris
22
24
23ibcVersion :: Word8
25ibcVersion :: Word8
@@ -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
src/Idris/Parser.hs+19−11
@@ -30,6 +30,7 @@ import qualified Text.Parsec.Token as PTok
30import Data.List
30import Data.List
31import Data.List.Split(splitOn)
31import Data.List.Split(splitOn)
32import Control.Monad.State
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.
@@ -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
617
618pExtensions :: SyntaxInfo -> [Syntax] -> IParser PTerm
618pExtensions :: SyntaxInfo -> [Syntax] -> IParser PTerm
619pExtensions syn rules = choice (map (try . pExt syn) (filter valid rules))
619pExtensions syn rules = choice (map (try . pExt syn) (filter valid rules))
@@ -763,6 +763,7 @@ pSimpleExpr syn =
763 fc <- pfc
763 fc <- pfc
764 return (PInferRef fc x))
764 return (PInferRef fc x))
765 <|> try (pList syn)
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 '('
@@ -881,7 +882,7 @@ pApp syn = do f <- pSimpleExpr syn
881 return (dslify i $ PApp fc f args)
882 return (dslify i $ PApp fc f args)
882 where
883 where
883 dslify i (PApp fc (PRef _ f) [a])
884 dslify i (PApp fc (PRef _ f) [a])
884− | [d] <- lookupCtxt Nothing f (idris_dsls i)
885+ | [d] <- lookupCtxt f (idris_dsls i)
885 = desugar (syn { dsl_info = d }) i (getTm a)
886 = desugar (syn { dsl_info = d }) i (getTm a)
886 dslify i t = t
887 dslify i t = t
887
888
@@ -975,7 +976,9 @@ pLet syn = try (do reserved "let"; n <- pName;
975 return (PCase fc v [(pat, sc)]))
976 return (PCase fc v [(pat, sc)]))
976
977
977pPi syn =
978pPi syn =
979+ try (do lazy <- if implicitAllowed syn -- laziness is top level only
978− try (do lazy <- option False (do lchar '|'; return True)
980+ then option False (do lchar '|'; return True)
981+ else return False
979 st <- pStatic
982 st <- pStatic
980 lchar '('; xt <- tyDeclList syn; lchar ')'
983 lchar '('; xt <- tyDeclList syn; lchar ')'
981 doc <- option "" (pDocComment '^')
984 doc <- option "" (pDocComment '^')
@@ -1361,7 +1364,8 @@ pClause syn
1361 cargs <- many (pConstraintArg syn)
1364 cargs <- many (pConstraintArg syn)
1362 iargs <- many (pImplicitArg (syn { inPattern = True } ))
1365 iargs <- many (pImplicitArg (syn { inPattern = True } ))
1363 fc <- pfc
1366 fc <- pfc
1367+ args <- many (try (pImplicitArg (syn { inPattern = True } ))
1364− args <- many (pArgExpr syn)
1368+ <|> (fmap pexp (pArgExpr syn)))
1365 wargs <- many (pWExpr syn)
1369 wargs <- many (pWExpr syn)
1366 rhs <- pRHS syn n
1370 rhs <- pRHS syn n
1367 ist <- getState
1371 ist <- getState
@@ -1373,7 +1377,7 @@ pClause syn
1373 do pTerminator
1377 do pTerminator
1374 return ([], [])]
1378 return ([], [])]
1375 let capp = PApp fc (PRef fc n)
1379 let capp = PApp fc (PRef fc n)
1376− (iargs ++ cargs ++ map pexp args)
1380+ (iargs ++ cargs ++ args)
1377 ist <- getState
1381 ist <- getState
1378 setState (ist { lastParse = Just n })
1382 setState (ist { lastParse = Just n })
1379 return $ PClause fc n capp wargs rhs wheres)
1383 return $ PClause fc n capp wargs rhs wheres)
@@ -1399,10 +1403,11 @@ pClause syn
1399 cargs <- many (pConstraintArg syn)
1403 cargs <- many (pConstraintArg syn)
1400 iargs <- many (pImplicitArg (syn { inPattern = True } ))
1404 iargs <- many (pImplicitArg (syn { inPattern = True } ))
1401 fc <- pfc
1405 fc <- pfc
1406+ args <- many (try (pImplicitArg (syn { inPattern = True } ))
1402− args <- many (pArgExpr syn)
1407+ <|> (fmap pexp (pArgExpr syn)))
1403 wargs <- many (pWExpr syn)
1408 wargs <- many (pWExpr syn)
1404 let capp = PApp fc (PRef fc n)
1409 let capp = PApp fc (PRef fc n)
1405− (iargs ++ cargs ++ map pexp args)
1410+ (iargs ++ cargs ++ args)
1406 ist <- getState
1411 ist <- getState
1407 setState (ist { lastParse = Just n })
1412 setState (ist { lastParse = Just n })
1408 reserved "with"
1413 reserved "with"
@@ -1510,9 +1515,12 @@ pDirective syn = try (do lchar '%'; reserved "lib"; lib <- strlit;
1510 putIState (i { default_total = tot }))])
1515 putIState (i { default_total = tot }))])
1511 <|> try (do lchar '%'; reserved "logging"; i <- natural;
1516 <|> try (do lchar '%'; reserved "logging"; i <- natural;
1512 return [PDirective (setLogLevel (fromInteger i))])
1517 return [PDirective (setLogLevel (fromInteger i))])
1513− <|> try (do lchar '%'; reserved "dynamic"; lib <- strlit;
1518+ <|> try (do lchar '%'; reserved "dynamic"; libs <- sepBy1 strlit (lchar ',');
1514− return [PDirective (do addIBC (IBCDyLib lib)
1519+ return [PDirective (do added <- addDyLib libs
1515− addDyLib lib)])
1520+ case added of
1521+ Left lib -> addIBC (IBCDyLib (lib_name lib))
1522+ Right msg ->
1523+ fail $ msg)])
1516 <|> try (do lchar '%'; reserved "language"; ext <- reserved "TypeProviders";
1524 <|> try (do lchar '%'; reserved "language"; ext <- reserved "TypeProviders";
1517 return [PDirective (addLangExt TypeProviders)])
1525 return [PDirective (addLangExt TypeProviders)])
1518
1526
src/Idris/Primitives.hs+1
@@ -439,6 +439,7 @@ p_floatFloor = p_fPrim (fromInteger . floor)
439p_floatCeil = p_fPrim (fromInteger . ceiling)
439p_floatCeil = p_fPrim (fromInteger . ceiling)
440
440
441p_strLen [VConstant (Str xs)] = Just $ VConstant (I (length xs))
441p_strLen [VConstant (Str xs)] = Just $ VConstant (I (length xs))
442+p_strLen _ = Nothing
442p_strHead [VConstant (Str (x:xs))] = Just $ VConstant (Ch x)
443p_strHead [VConstant (Str (x:xs))] = Just $ VConstant (Ch x)
443p_strHead _ = Nothing
444p_strHead _ = Nothing
444p_strTail [VConstant (Str (x:xs))] = Just $ VConstant (Str xs)
445p_strTail [VConstant (Str (x:xs))] = Just $ VConstant (Str xs)
src/Idris/Prover.hs+1−1
@@ -26,7 +26,7 @@ prover :: Bool -> Name -> Idris ()
26prover lit x =
26prover lit x =
27 do ctxt <- getContext
27 do ctxt <- getContext
28 i <- getIState
28 i <- getIState
29− case lookupTy Nothing x ctxt of
29+ case lookupTy x ctxt of
30 [t] -> if elem x (idris_metavars i)
30 [t] -> if elem x (idris_metavars i)
31 then prove ctxt lit x t
31 then prove ctxt lit x t
32 else fail $ show x ++ " is not a metavariable"
32 else fail $ show x ++ " is not a metavariable"
src/Idris/Providers.hs+7−13
@@ -1,3 +1,4 @@
1+{-# LANGUAGE PatternGuards #-}
1module Idris.Providers where
2module Idris.Providers where
2
3
3import Core.TT
4import Core.TT
@@ -19,16 +20,9 @@ unProv fc tm = PApp fc (PRef fc $ NS (UN "unProv") ["Providers"]) [PExp 0 False
19
20
20-- | Handle an error, if the type provider returned an error. Otherwise do nothing.
21-- | Handle an error, if the type provider returned an error. Otherwise do nothing.
21providerError :: TT Name -> Idris ()
22providerError :: TT Name -> Idris ()
22−providerError tm = case unApply tm of
23+providerError tm | (P _ unProv_case _, _:_:tm':_) <- unApply tm
23− (P _ (NS (UN "unProv") ["Providers"]) _, [_, tm']) ->
24− case unApply tm' of
25− (P _ (NS (UN "Error") ["Providers"]) _, [_, err]) ->
24+ , (P _ (NS (UN "Error") ["Providers"]) _, [_, err]) <- unApply tm' =
26− do str <- execute err
27− case (unApply str) of
25+ case err of
28− (Constant (Str msg), []) ->
29− ierror . ProviderError $ msg
30− (P _ (UN "prim__IO") _, [_, (Constant (Str msg))]) ->
31− ierror . ProviderError $ msg
26+ Constant (Str msg) -> ierror . ProviderError $ msg
32− _ -> fail "Error in type provider."
27+ _ -> fail "Error in type provider"
33− _ -> return ()
34− _ -> return ()
28+ | otherwise = return ()
src/Idris/REPL.hs+36−26
@@ -129,7 +129,7 @@ resolveProof :: Name -> Idris Name
129resolveProof n'
129resolveProof n'
130 = do i <- getIState
130 = do i <- getIState
131 ctxt <- getContext
131 ctxt <- getContext
132− n <- case lookupNames Nothing n' ctxt of
132+ n <- case lookupNames n' ctxt of
133 [x] -> return x
133 [x] -> return x
134 [] -> return n'
134 [] -> return n'
135 ns -> fail $ pshow i (CantResolveAlts (map show ns))
135 ns -> fail $ pshow i (CantResolveAlts (map show ns))
@@ -196,21 +196,21 @@ process fn (ExecVal t)
196 = do ctxt <- getContext
196 = do ctxt <- getContext
197 ist <- getIState
197 ist <- getIState
198 (tm, ty) <- elabVal toplevel False t
198 (tm, ty) <- elabVal toplevel False t
199− let tm' = normaliseAll ctxt [] tm
199+-- let tm' = normaliseAll ctxt [] tm
200 let ty' = normaliseAll ctxt [] ty
200 let ty' = normaliseAll ctxt [] ty
201− res <- execute tm'
201+ res <- execute tm
202 imp <- impShow
202 imp <- impShow
203 iputStrLn (showImp imp (delab ist res) ++ " : " ++
203 iputStrLn (showImp imp (delab ist res) ++ " : " ++
204 showImp imp (delab ist ty'))
204 showImp imp (delab ist ty'))
205 return ()
205 return ()
206process fn (Check (PRef _ n))
206process fn (Check (PRef _ n))
207− = do ctxt <- getContext
207+ = do ctxt <- getContext
208− ist <- getIState
208+ ist <- getIState
209− imp <- impShow
209+ imp <- impShow
210− case lookupTy Nothing n ctxt of
210+ case lookupNames n ctxt of
211− ts@(_:_) -> mapM_ (\t -> iputStrLn $ show n ++ " : " ++
211+ ts@(_:_) -> mapM_ (\n -> iputStrLn $ show n ++ " : " ++
212− showImp imp (delab ist t)) ts
212+ showImp imp (delabTy ist n)) ts
213− [] -> iputStrLn $ "No such variable " ++ show n
213+ [] -> iputStrLn $ "No such variable " ++ show n
214process fn (Check t) = do (tm, ty) <- elabVal toplevel False t
214process fn (Check t) = do (tm, ty) <- elabVal toplevel False t
215 ctxt <- getContext
215 ctxt <- getContext
216 ist <- getIState
216 ist <- getIState
@@ -220,7 +220,7 @@ process fn (Check t) = do (tm, ty) <- elabVal toplevel False t
220 showImp imp (delab ist ty))
220 showImp imp (delab ist ty))
221
221
222process fn (DocStr n) = do i <- getIState
222process fn (DocStr n) = do i <- getIState
223− case lookupCtxtName Nothing n (idris_docstrings i) of
223+ case lookupCtxtName n (idris_docstrings i) of
224 [] -> iputStrLn $ "No documentation for " ++ show n
224 [] -> iputStrLn $ "No documentation for " ++ show n
225 ns -> mapM_ showDoc ns
225 ns -> mapM_ showDoc ns
226 where showDoc (n, d)
226 where showDoc (n, d)
@@ -237,8 +237,8 @@ process fn Universes = do i <- getIState
237 OK _ -> iputStrLn "Universes OK"
237 OK _ -> iputStrLn "Universes OK"
238process fn (Defn n) = do i <- getIState
238process fn (Defn n) = do i <- getIState
239 iputStrLn "Compiled patterns:\n"
239 iputStrLn "Compiled patterns:\n"
240− liftIO $ print (lookupDef Nothing n (tt_ctxt i))
240+ liftIO $ print (lookupDef n (tt_ctxt i))
241− case lookupCtxt Nothing n (idris_patdefs i) of
241+ case lookupCtxt n (idris_patdefs i) of
242 [] -> return ()
242 [] -> return ()
243 [d] -> do iputStrLn "Original definiton:\n"
243 [d] -> do iputStrLn "Original definiton:\n"
244 mapM_ (printCase i) d
244 mapM_ (printCase i) d
@@ -255,25 +255,25 @@ process fn (TotCheck n) = do i <- getIState
255 _ -> return ()
255 _ -> return ()
256process fn (DebugInfo n)
256process fn (DebugInfo n)
257 = do i <- getIState
257 = do i <- getIState
258− let oi = lookupCtxtName Nothing n (idris_optimisation i)
258+ let oi = lookupCtxtName n (idris_optimisation i)
259 when (not (null oi)) $ iputStrLn (show oi)
259 when (not (null oi)) $ iputStrLn (show oi)
260− let si = lookupCtxt Nothing n (idris_statics i)
260+ let si = lookupCtxt n (idris_statics i)
261 when (not (null si)) $ iputStrLn (show si)
261 when (not (null si)) $ iputStrLn (show si)
262− let di = lookupCtxt Nothing n (idris_datatypes i)
262+ let di = lookupCtxt n (idris_datatypes i)
263 when (not (null di)) $ iputStrLn (show di)
263 when (not (null di)) $ iputStrLn (show di)
264− let d = lookupDef Nothing n (tt_ctxt i)
264+ let d = lookupDef n (tt_ctxt i)
265 when (not (null d)) $ liftIO $
265 when (not (null d)) $ liftIO $
266 do print (head d)
266 do print (head d)
267− let cg = lookupCtxtName Nothing n (idris_callgraph i)
267+ let cg = lookupCtxtName n (idris_callgraph i)
268 findUnusedArgs (map fst cg)
268 findUnusedArgs (map fst cg)
269 i <- getIState
269 i <- getIState
270− let cg' = lookupCtxtName Nothing n (idris_callgraph i)
270+ let cg' = lookupCtxtName n (idris_callgraph i)
271 sc <- checkSizeChange n
271 sc <- checkSizeChange n
272 iputStrLn $ "Size change: " ++ show sc
272 iputStrLn $ "Size change: " ++ show sc
273 when (not (null cg')) $ do iputStrLn "Call graph:\n"
273 when (not (null cg')) $ do iputStrLn "Call graph:\n"
274 iputStrLn (show cg')
274 iputStrLn (show cg')
275process fn (Info n) = do i <- getIState
275process fn (Info n) = do i <- getIState
276− case lookupCtxt Nothing n (idris_classes i) of
276+ case lookupCtxt n (idris_classes i) of
277 [c] -> classInfo c
277 [c] -> classInfo c
278 _ -> iputStrLn "Not a class"
278 _ -> iputStrLn "Not a class"
279process fn (Search t) = iputStrLn "Not implemented"
279process fn (Search t) = iputStrLn "Not implemented"
@@ -299,8 +299,17 @@ process fn (RmProof n')
299 let ms = idris_metavars i
299 let ms = idris_metavars i
300 putIState $ i { idris_metavars = n : ms }
300 putIState $ i { idris_metavars = n : ms }
301
301
302−process fn (AddProof prf)
302+process fn' (AddProof prf)
303+ = do fn <- do
304+ ex <- liftIO $ doesFileExist fn'
305+ let fnExt = fn' <.> "idr"
306+ exExt <- liftIO $ doesFileExist fnExt
307+ if ex
308+ then return fn'
309+ else if exExt
310+ then return fnExt
311+ else fail $ "Neither \""++fn'++"\" nor \""++fnExt++"\" exist"
303− = do let fb = fn ++ "~"
312+ let fb = fn ++ "~"
304 liftIO $ copyFile fn fb -- make a backup in case something goes wrong!
313 liftIO $ copyFile fn fb -- make a backup in case something goes wrong!
305 prog <- liftIO $ readFile fb
314 prog <- liftIO $ readFile fb
306 i <- getIState
315 i <- getIState
@@ -330,7 +339,7 @@ process fn (ShowProof n')
330process fn (Prove n')
339process fn (Prove n')
331 = do ctxt <- getContext
340 = do ctxt <- getContext
332 ist <- getIState
341 ist <- getIState
333− n <- case lookupNames Nothing n' ctxt of
342+ n <- case lookupNames n' ctxt of
334 [x] -> return x
343 [x] -> return x
335 [] -> return n'
344 [] -> return n'
336 ns -> fail $ pshow ist (CantResolveAlts (map show ns))
345 ns -> fail $ pshow ist (CantResolveAlts (map show ns))
@@ -381,7 +390,7 @@ process fn (Pattelab t)
381 iputStrLn $ show tm ++ "\n\n : " ++ show ty
390 iputStrLn $ show tm ++ "\n\n : " ++ show ty
382
391
383process fn (Missing n) = do i <- getIState
392process fn (Missing n) = do i <- getIState
384− case lookupDef Nothing n (tt_ctxt i) of
393+ case lookupDef n (tt_ctxt i) of
385 [CaseOp _ _ _ _ _ args t _ _]
394 [CaseOp _ _ _ _ _ args t _ _]
386 -> do tms <- genMissing n args t
395 -> do tms <- genMissing n args t
387 iputStrLn (showSep "\n" (map (showImp True) tms))
396 iputStrLn (showSep "\n" (map (showImp True) tms))
@@ -431,7 +440,7 @@ dumpInstance :: Name -> Idris ()
431dumpInstance n = do i <- getIState
440dumpInstance n = do i <- getIState
432 ctxt <- getContext
441 ctxt <- getContext
433 imp <- impShow
442 imp <- impShow
434− case lookupTy Nothing n ctxt of
443+ case lookupTy n ctxt of
435 ts -> mapM_ (\t -> iputStrLn $ showImp imp (delab i t)) ts
444 ts -> mapM_ (\t -> iputStrLn $ showImp imp (delab i t)) ts
436
445
437showTotal t@(Partial (Other ns)) i
446showTotal t@(Partial (Other ns)) i
@@ -552,6 +561,7 @@ idrisMain opts =
552 [] -> setIBCSubDir ""
561 [] -> setIBCSubDir ""
553 (d:_) -> setIBCSubDir d
562 (d:_) -> setIBCSubDir d
554 setImportDirs importdirs
563 setImportDirs importdirs
564+
555 addPkgDir "base"
565 addPkgDir "base"
556 mapM_ addPkgDir pkgdirs
566 mapM_ addPkgDir pkgdirs
557 elabPrims
567 elabPrims
@@ -636,7 +646,7 @@ getLanguageExt (Extension e) = Just e
636getLanguageExt _ = Nothing
646getLanguageExt _ = Nothing
637
647
638opt :: (Opt -> Maybe a) -> [Opt] -> [a]
648opt :: (Opt -> Maybe a) -> [Opt] -> [a]
639−opt = mapMaybe
649+opt = mapMaybe
640
650
641ver = showVersion version
651ver = showVersion version
642
652
src/Idris/REPLParser.hs+1−1
@@ -66,7 +66,7 @@ pCmd = try (do cmd ["q", "quit"]; eof; return Quit)
66 <|> do t <- pFullExpr defaultSyntax; return (Eval t)
66 <|> do t <- pFullExpr defaultSyntax; return (Eval t)
67 <|> do eof; return NOP
67 <|> do eof; return NOP
68
68
69− where toPath n = foldl1 (</>) $ splitOn "." n
69+ where toPath n = foldl1' (</>) $ splitOn "." n
70
70
71pOption :: IParser Opt
71pOption :: IParser Opt
72pOption = 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 ()
15traceUnused :: Name -> Idris ()
16traceUnused n
16traceUnused n
17 = do i <- getIState
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 _] ->
19 [CGInfo args calls scg usedns _] ->
20 do let argpos = zip args [0..]
20 do let argpos = zip args [0..]
21 let fargs = concatMap (getFargpos calls) argpos
21 let fargs = concatMap (getFargpos calls) argpos
@@ -39,7 +39,7 @@ used path g j
39 | otherwise
39 | otherwise
40 = do logLvl 5 $ (show ((g, j) : path))
40 = do logLvl 5 $ (show ((g, j) : path))
41 i <- getIState
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] ->
43 [CGInfo args calls scg usedns unused] ->
44 if (j >= length args)
44 if (j >= length args)
45 then -- overapplied, assume used
45 then -- overapplied, assume used
src/Main.hs+3
@@ -29,6 +29,7 @@ import Idris.Imports
29import Idris.Error
29import Idris.Error
30
30
31import Util.System ( getLibFlags, getIdrisLibDir, getIncFlags )
31import Util.System ( getLibFlags, getIdrisLibDir, getIncFlags )
32+import Util.DynamicLinker
32
33
33import Pkg.Package
34import Pkg.Package
34
35
@@ -94,3 +95,5 @@ usagemsg = "Idris version " ++ ver ++ "\n" ++
94 "\t--link Show C library directories and exit (for C linking)\n" ++
95 "\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" ++
96 "\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"
97 "\t--target [target] Type the target: C, Java, bytecode, javascript, node\n"
98+
99+
src/Pkg/Package.hs+3−3
@@ -71,7 +71,7 @@ buildMods :: [Opt] -> [Name] -> IO ()
71buildMods opts ns = do let f = map (toPath . show) ns
71buildMods opts ns = do let f = map (toPath . show) ns
72 idris (map Filename f ++ opts)
72 idris (map Filename f ++ opts)
73 return ()
73 return ()
74− where toPath n = foldl1 (</>) $ splitOn "." n
74+ where toPath n = foldl1' (</>) $ splitOn "." n
75
75
76testLib :: Bool -> String -> String -> IO Bool
76testLib :: Bool -> String -> String -> IO Bool
77testLib warn p f
77testLib warn p f
@@ -93,7 +93,7 @@ rmIBC :: Name -> IO ()
93rmIBC m = rmFile $ toIBCFile m
93rmIBC m = rmFile $ toIBCFile m
94
94
95toIBCFile (UN n) = n ++ ".ibc"
95toIBCFile (UN n) = n ++ ".ibc"
96−toIBCFile (NS n ns) = foldl1 (</>) (reverse (toIBCFile n : ns))
96+toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : ns))
97
97
98installIBC :: String -> Name -> IO ()
98installIBC :: String -> Name -> IO ()
99installIBC p m = do let f = toIBCFile m
99installIBC p m = do let f = toIBCFile m
@@ -105,7 +105,7 @@ installIBC p m = do let f = toIBCFile m
105 copyFile f (destdir </> takeFileName f)
105 copyFile f (destdir </> takeFileName f)
106 return ()
106 return ()
107 where getDest (UN n) = ""
107 where getDest (UN n) = ""
108− getDest (NS n ns) = foldl1 (</>) (reverse (getDest n : ns))
108+ getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : ns))
109
109
110installObj :: String -> String -> IO ()
110installObj :: String -> String -> IO ()
111installObj p o = do d <- getDataDir
111installObj p o = do d <- getDataDir
src/Util/DynamicLinker.hs+25−4
@@ -4,8 +4,14 @@
4module Util.DynamicLinker where
4module Util.DynamicLinker where
5
5
6import Foreign.LibFFI
6import Foreign.LibFFI
7−import Foreign.Ptr (nullPtr, FunPtr, nullFunPtr)
7+import Foreign.Ptr (nullPtr, FunPtr, nullFunPtr,castPtrToFunPtr)
8+#ifndef WINDOWS
8import System.Posix.DynamicLinker
9import System.Posix.DynamicLinker
10+#else
11+import System.Win32.DLL
12+import System.Win32.Types
13+type DL = HMODULE
14+#endif
9
15
10hostDynamicLibExt :: String
16hostDynamicLibExt :: String
11#ifdef LINUX
17#ifdef LINUX
@@ -16,22 +22,37 @@ hostDynamicLibExt = "dylib"
16hostDynamicLibExt = "dll"
22hostDynamicLibExt = "dll"
17#endif
23#endif
18
24
25+data ForeignFun = forall a. Fun { fun_name :: String
26+ , fun_handle :: FunPtr a
27+ }
28+
19data DynamicLib = Lib { lib_name :: String
29data DynamicLib = Lib { lib_name :: String
20 , lib_handle :: DL
30 , lib_handle :: DL
21 }
31 }
22
32
33+#ifndef WINDOWS
23tryLoadLib :: String -> IO (Maybe DynamicLib)
34tryLoadLib :: String -> IO (Maybe DynamicLib)
24tryLoadLib lib = do handle <- dlopen (lib ++ "." ++ hostDynamicLibExt) [RTLD_NOW]
35tryLoadLib lib = do handle <- dlopen (lib ++ "." ++ hostDynamicLibExt) [RTLD_NOW]
25 if undl handle == nullPtr
36 if undl handle == nullPtr
26 then return Nothing
37 then return Nothing
27 else return . Just $ Lib lib handle
38 else return . Just $ Lib lib handle
28
39
29−data ForeignFun = forall a. Fun { fun_name :: String
30− , fun_handle :: FunPtr a
31− }
32
40
33tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
41tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
34tryLoadFn fn (Lib _ h) = do cFn <- dlsym h fn
42tryLoadFn fn (Lib _ h) = do cFn <- dlsym h fn
35 if cFn == nullFunPtr
43 if cFn == nullFunPtr
36 then return Nothing
44 then return Nothing
37 else return . Just $ Fun fn cFn
45 else return . Just $ Fun fn cFn
46+#else
47+tryLoadLib :: String -> IO (Maybe DynamicLib)
48+tryLoadLib lib = do handle <- loadLibrary (lib ++ "." ++ hostDynamicLibExt)
49+ if handle == nullPtr
50+ then return Nothing
51+ else return . Just $ Lib lib handle
52+
53+tryLoadFn :: String -> DynamicLib -> IO (Maybe ForeignFun)
54+tryLoadFn fn (Lib _ h) = do cFn <- getProcAddress h fn
55+ if cFn == nullPtr
56+ then return Nothing
57+ else return . Just $ Fun fn (castPtrToFunPtr cFn)
58+#endif
src/Util/System.hs+1−1
@@ -1,7 +1,7 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2module Util.System(tempfile,withTempdir,environment,getCC,
2module Util.System(tempfile,withTempdir,environment,getCC,
3 getLibFlags,getIdrisLibDir,getIncFlags,rmFile,
3 getLibFlags,getIdrisLibDir,getIncFlags,rmFile,
4− getMvn,getExecutablePom) where
4+ getMvn,getExecutablePom,catchIO) where
5
5
6-- System helper functions.
6-- System helper functions.
7import Control.Monad (when)
7import Control.Monad (when)
test/README+4
@@ -22,5 +22,9 @@ Tests:
22020: implicit conversions
22020: implicit conversions
23021: effects
23021: effects
24022: dynamic C library loading and interpreter IO
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
25
29
26regxxx: various regression tests
30regxxx: various regression tests
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/test022/test022.idr+1−1
@@ -1,6 +1,6 @@
1module Main
1module Main
2
2
3−%dynamic "libm"
3+%dynamic "dummy", "libm", "msvcrt"
4
4
5x : Float
5x : Float
6x = unsafePerformIO (mkForeign (FFun "sin" [FFloat] FFloat) 1.6)
6x = unsafePerformIO (mkForeign (FFun "sin" [FFloat] FFloat) 1.6)
test/test023/test023.idr+4−4
@@ -7,8 +7,8 @@ import Providers
7%language TypeProviders
7%language TypeProviders
8
8
9-- Provide the Unit type
9-- Provide the Unit type
10−goodProvider : Provider Type
10+goodProvider : IO (Provider Type)
11−goodProvider = Provide (return (the Type ()))
11+goodProvider = return (Provide (the Type ()))
12
12
13%provide (Unit : Type) with goodProvider
13%provide (Unit : Type) with goodProvider
14
14
@@ -16,8 +16,8 @@ foo : Unit
16foo = ()
16foo = ()
17
17
18-- Always fail
18-- Always fail
19−badProvider : Provider Type
19+badProvider : IO (Provider Type)
20−badProvider = Error (return "Always fails")
20+badProvider = return (Error "Always fails")
21
21
22%provide (t : Type) with badProvider
22%provide (t : Type) with badProvider
23
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__intToB8 [0, 1, 2, 3, 5]
13+
14+sub1 : Vect Bits8 n -> Vect Bits8 n
15+sub1 xs = map (prim__intToB8 . (\ x => x - 1) . prim__B32ToInt . prim__sextB8_32) 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__intToB8 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__B32ToInt . prim__sextB8_32) 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
tutorial/idris-tutorial.tex+1
@@ -11,6 +11,7 @@
11\input{library.ltx}
11\input{library.ltx}
12
12
13\newcommand{\Idris}{\textsc{Idris}}
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+2−2
@@ -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
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}.
340at the \Idris{} interactive environment is shown in Figure \ref{factrun}.
341
341
342−\begin{SaveVerbatim}{factrun}
342+\begin{SaveVerbatim}[commandchars=^\{\}]{factrun}
343
343
344$ idris interp.idr
344$ idris interp.idr
345 ____ __ _
345 ____ __ _
346 / _/___/ /____(_)____
346 / _/___/ /____(_)____
347− / // __ / ___/ / ___/ Version 0.9.7
347+ / // __ / ___/ / ___/ Version ^version{}
348 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
348 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
349 /___/\__,_/_/ /_/____/ Type :? for help
349 /___/\__,_/_/ /_/____/ Type :? for help
350
350
tutorial/intro.tex+1−1
@@ -62,7 +62,7 @@ verifying systems software.
62\subsection{Example Code}
62\subsection{Example Code}
63
63
64This tutorial includes some example code, which has been tested with \Idris{} version
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,
66so that you can try them out easily,
67under \texttt{tutorial/examples}. However, it is strongly recommended that you
67under \texttt{tutorial/examples}. However, it is strongly recommended that you
68type them in yourself, rather than simply loading and reading them.
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
74Entering \texttt{idris} at the shell prompt starts up the interactive
75environment. You should see something like the following:
75environment. You should see something like the following:
76
76
77−\begin{SaveVerbatim}{prompt1}
77+\begin{SaveVerbatim}[commandchars=^\{\}]{prompt1}
78
78
79$ idris
79$ idris
80 ____ __ _
80 ____ __ _
81 / _/___/ /____(_)____
81 / _/___/ /____(_)____
82− / // __ / ___/ / ___/ Version 0.9.7
82+ / // __ / ___/ / ___/ Version ^version{}
83 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
83 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
84 /___/\__,_/_/ /_/____/ Type :? for help
84 /___/\__,_/_/ /_/____/ Type :? for help
85
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
98\texttt{hello.idr} is loaded, the type of \texttt{main} is checked and then
99the program is compiled to the executable \texttt{hello}.
99the program is compiled to the executable \texttt{hello}.
100
100
101−\begin{SaveVerbatim}{cmds}
101+\begin{SaveVerbatim}[commandchars=\\\{\}]{cmds}
102−Idris version 0.9.7
102+Idris version \version{}
103-------------------
103-------------------
104
104
105 Command Arguments Purpose
105 Command Arguments Purpose
@@ -129,12 +129,12 @@ Idris version 0.9.7
129\codefigs{cmds}{Interactive environment commands}
129\codefigs{cmds}{Interactive environment commands}
130
130
131
131
132−\begin{SaveVerbatim}{run1}
132+\begin{SaveVerbatim}[commandchars=^\{\}]{run1}
133
133
134$ idris hello.idr
134$ idris hello.idr
135 ____ __ _
135 ____ __ _
136 / _/___/ /____(_)____
136 / _/___/ /____(_)____
137− / // __ / ___/ / ___/ Version 0.9.7
137+ / // __ / ___/ / ___/ Version ^version{}
138 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
138 _/ // /_/ / / / (__ ) http://www.idris-lang.org/
139 /___/\__,_/_/ /_/____/ Type :? for help
139 /___/\__,_/_/ /_/____/ Type :? for help
140
140