├── test.db ├── .gitignore ├── error_test ├── test.sqlite ├── error_test.ipkg └── ErrorTest.idr ├── type_provider-demo ├── test.sqlite ├── demo.ipkg └── Test.idr ├── sqlite_test.ipkg ├── type-provider ├── sqlite_provider.ipkg ├── Database.idr ├── Parser.idr ├── ErrorHandlers.idr ├── SQLiteTypes.idr ├── Provider.idr ├── Schema.idr ├── ParserHack.idr └── Queries.idr ├── sqlite.ipkg ├── src ├── MakefileC ├── DB │ └── SQLite │ │ ├── SQLiteTest.idr │ │ ├── SQLiteCodes.idr │ │ └── Effect.idr ├── sqlite3api.h └── sqlite3api.c ├── LICENSE └── README.md /test.db: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/david-christiansen/IdrisSqlite/HEAD/test.db -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.ibc 3 | *.o 4 | sqlite_test 5 | src/sqlite3api.so 6 | src/sqlite3api.o 7 | test 8 | -------------------------------------------------------------------------------- /error_test/test.sqlite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/david-christiansen/IdrisSqlite/HEAD/error_test/test.sqlite -------------------------------------------------------------------------------- /type_provider-demo/test.sqlite: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/david-christiansen/IdrisSqlite/HEAD/type_provider-demo/test.sqlite -------------------------------------------------------------------------------- /type_provider-demo/demo.ipkg: -------------------------------------------------------------------------------- 1 | package demo 2 | 3 | modules = Test 4 | 5 | executable = test 6 | 7 | main = Test 8 | 9 | pkgs = sqlite_provider, effects, sqlite 10 | 11 | -------------------------------------------------------------------------------- /error_test/error_test.ipkg: -------------------------------------------------------------------------------- 1 | package error_test 2 | 3 | modules = ErrorTest 4 | 5 | executable = test 6 | 7 | main = ErrorTest 8 | 9 | pkgs = sqlite_provider, effects, sqlite 10 | 11 | -------------------------------------------------------------------------------- /sqlite_test.ipkg: -------------------------------------------------------------------------------- 1 | package sqlite_test 2 | 3 | pkgs = effects, sqlite 4 | sourcedir = src 5 | modules = DB.SQLite.SQLiteTest 6 | 7 | executable = sqlite_test 8 | 9 | main = DB.SQLite.SQLiteTest 10 | -------------------------------------------------------------------------------- /type-provider/sqlite_provider.ipkg: -------------------------------------------------------------------------------- 1 | package sqlite_provider 2 | 3 | modules = ErrorHandlers, Schema, Database, Provider, SQLiteTypes, ParserHack, Queries 4 | 5 | pkgs = effects, sqlite, lightyear 6 | 7 | -------------------------------------------------------------------------------- /sqlite.ipkg: -------------------------------------------------------------------------------- 1 | package sqlite 2 | 3 | pkgs = effects 4 | sourcedir = src 5 | modules = DB.SQLite.Effect, DB.SQLite.SQLiteCodes 6 | 7 | makefile = MakefileC 8 | objs = sqlite3api.so, sqlite3api.o, sqlite3api.h 9 | 10 | -------------------------------------------------------------------------------- /src/MakefileC: -------------------------------------------------------------------------------- 1 | all : sqlite3api.o sqlite3api.so 2 | 3 | sqlite3api.o : sqlite3api.c sqlite3api.h 4 | gcc -c sqlite3api.c 5 | 6 | sqlite3api.so : sqlite3api.c sqlite3api.h 7 | gcc -fPIC -o sqlite3api.so -shared sqlite3api.c 8 | 9 | -------------------------------------------------------------------------------- /type-provider/Database.idr: -------------------------------------------------------------------------------- 1 | module Database 2 | 3 | import Schema 4 | 5 | import Decidable.Equality 6 | 7 | public export data DB : String -> Type where 8 | MkDB : (dbFile : String) -> 9 | (dbTables : List (String, Schema)) -> DB dbFile 10 | 11 | %name DB db 12 | 13 | public export data HasTable : List (String, Schema) -> String -> Schema -> Type where 14 | Here : HasTable ((name, s)::ts) name s 15 | There : HasTable ts name s -> 16 | HasTable ((name',s')::ts) name s 17 | 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Simon Fowler 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /type-provider/Parser.idr: -------------------------------------------------------------------------------- 1 | module Parser 2 | 3 | import Lightyear.Core 4 | import Lightyear.Strings 5 | import Lightyear.Combinators 6 | import Queries 7 | 8 | sqltype : Parser SQLiteType 9 | sqltype = the (Parser _) $ 10 | (do token "int" <|> token "integer" 11 | pure INTEGER) 12 | <|> (do token "text" <|> token "string" 13 | pure TEXT) 14 | <|> (do token "real" <|> token "float" 15 | pure REAL) 16 | 17 | name : Parser String 18 | name = do n <- many (satisfy (\c => c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')) 19 | return (pack n) 20 | 21 | nullable : Parser Bool 22 | nullable = (do token "not" 23 | token "null" 24 | return False) 25 | <|> return True 26 | 27 | 28 | sqlCol : Parser Attribute 29 | sqlCol = do n <- name 30 | space 31 | ty <- sqltype 32 | null <- nullable 33 | pure (n:::(if null then NULLABLE ty else ty)) 34 | 35 | comma : Parser () 36 | comma = char ',' 37 | 38 | 39 | cols : Parser Schema 40 | cols = do cols <- sepBy sqlCol (space $> comma $> space) 41 | pure (toSchema cols) 42 | where toSchema : List Attribute -> Schema 43 | toSchema [] = [] 44 | toSchema (x::xs) = x :: toSchema xs 45 | 46 | 47 | 48 | table : Parser (String, Schema) 49 | table = do token "create" 50 | token "table" 51 | n <- name 52 | space 53 | token "(" 54 | cs <- cols 55 | space 56 | token ")" 57 | pure (n,cs) 58 | 59 | -------------------------------------------------------------------------------- /type_provider-demo/Test.idr: -------------------------------------------------------------------------------- 1 | module Test 2 | 3 | import Effects 4 | import DB.SQLite.Effect 5 | 6 | import Provider 7 | import Database 8 | import Queries 9 | import Schema 10 | import SQLiteTypes 11 | 12 | %language TypeProviders 13 | 14 | -- Use the SQLite dependencies in generated code 15 | %link C "sqlite3api.o" 16 | %include C "sqlite3api.h" 17 | %lib C "sqlite3" 18 | 19 | %auto_implicits off 20 | %provide (db : DB "test.sqlite") 21 | with run {m = IO} (getSchemas "test.sqlite") 22 | 23 | 24 | speakers : Query db ["name":::TEXT, "bio":::NULLABLE TEXT] 25 | speakers = SELECT ["name":::TEXT, "bio":::NULLABLE TEXT] 26 | FROM "speaker" 27 | WHERE 1 28 | 29 | talks : Query db ["title":::TEXT, "abstract":::TEXT] 30 | talks = SELECT ["title":::TEXT, "abstract":::TEXT] 31 | FROM "talk" 32 | WHERE 1 33 | 34 | program : Query db ["name":::TEXT, "title":::TEXT, "abstract":::TEXT] 35 | program = SELECT ["name":::TEXT, "title":::TEXT, "abstract":::TEXT] 36 | FROM "speaker" * "talk" 37 | WHERE Col "id" == Col "speaker" 38 | 39 | 40 | printRes : {s : Schema} -> Query db s -> IO () 41 | printRes q = do res <- runInit {m = IO} [()] (query q) 42 | case res of 43 | Left err => putStrLn (show err) 44 | Right table => putStrLn (showTable _ table) 45 | 46 | namespace Main 47 | main : IO () 48 | main = do putStrLn "The speakers are:" 49 | printRes speakers 50 | putStrLn "The talks are:" 51 | printRes talks 52 | putStrLn "Conference program" 53 | printRes program 54 | putStrLn "ok" 55 | 56 | 57 | -------------------------------------------------------------------------------- /error_test/ErrorTest.idr: -------------------------------------------------------------------------------- 1 | module Test 2 | 3 | import Effects 4 | import DB.SQLite.Effect 5 | 6 | import Provider 7 | import Database 8 | import Queries 9 | import ErrorHandlers 10 | import Schema 11 | import SQLiteTypes 12 | 13 | 14 | %language TypeProviders 15 | %language ErrorReflection 16 | 17 | -- Use the SQLite dependencies in generated code 18 | %link C "sqlite3api.o" 19 | %include C "sqlite3api.h" 20 | %lib C "sqlite3" 21 | 22 | %auto_implicits off 23 | 24 | %provide (db : DB "test.sqlite") with run {m=IO} (getSchemas "test.sqlite") 25 | 26 | %error_handlers Col ok hasColErr 27 | %error_handlers Select ok notSubSchemaErr 28 | 29 | speakers : Query db ["name":::TEXT, "bio":::TEXT] 30 | speakers = SELECT ["name":::TEXT, "bio":::TEXT] FROM "speaker" WHERE 1 31 | 32 | talks : Query db ["title":::TEXT, "abstract":::TEXT] 33 | talks = SELECT ["title":::TEXT, "abstract":::TEXT] FROM "talk" WHERE 1 34 | 35 | 36 | program : Query db ["name":::TEXT, "title":::TEXT, "abstract":::TEXT] 37 | program = SELECT ["name":::TEXT, "title":::TEXT, "abstract":::TEXT] 38 | FROM "speaker" * "talk" 39 | WHERE Col "id" == Col "speaker_id" 40 | 41 | printRes : {s : Schema} -> Query db s -> IO () 42 | printRes q = do res <- runInit [()] (query q) 43 | case res of 44 | Left err => putStrLn (show err) 45 | Right table => putStrLn (showTable _ table) 46 | namespace Main 47 | main : IO () 48 | main = do putStrLn "The speakers are:" 49 | printRes speakers 50 | putStrLn "The talks are:" 51 | printRes talks 52 | putStrLn "Conference program" 53 | printRes program 54 | putStrLn "ok" 55 | -------------------------------------------------------------------------------- /type-provider/ErrorHandlers.idr: -------------------------------------------------------------------------------- 1 | module ErrorHandlers 2 | 3 | import Queries 4 | import Schema 5 | import SQLiteTypes 6 | import Language.Reflection 7 | import Language.Reflection.Errors 8 | 9 | %language ErrorReflection 10 | 11 | %access public export 12 | 13 | ||| Convert a reflected schema to a nice formatted error view 14 | getAttrs : TT -> List ErrorReportPart 15 | getAttrs `(~a ::: ~b) = [SubReport 16 | [ TermPart a 17 | , TextPart ":::" 18 | , TermPart b] ] 19 | getAttrs `(Schema.(::) ~hd ~tl) = getAttrs hd ++ getAttrs tl 20 | getAttrs `(Schema.append ~a ~b) = getAttrs a ++ getAttrs b 21 | getAttrs x = [] 22 | 23 | 24 | ||| Rewrite column missing errors 25 | hasColErr : Err -> Maybe (List ErrorReportPart) 26 | hasColErr (CantSolveGoal `(HasCol ~s ~want) _) = 27 | [| getWant want ++ 28 | pure ([TextPart "in the schema"] ++ getAttrs s) |] 29 | where getWant : TT -> Maybe (List ErrorReportPart) 30 | getWant `(~c ::: ~typ : Attribute)= 31 | pure [ TextPart "The column" 32 | , TermPart c 33 | , TextPart "was not found with type" 34 | , TermPart typ 35 | ] 36 | getWant _ = Nothing 37 | hasColErr _ = Nothing 38 | 39 | 40 | ||| Rewrite subschema errors 41 | notSubSchemaErr : Err -> Maybe (List ErrorReportPart) 42 | notSubSchemaErr (CantSolveGoal `(SubSchema ~s1 ~s2) ctxt) = 43 | Just $ [TextPart "Bad schema:"] ++ 44 | getAttrs s1 ++ 45 | [SubReport $ 46 | [TextPart "Expected subschema of"] ++ 47 | getAttrs s2] 48 | notSubSchemaErr (CantSolveGoal (App (App (App (App equals _) _) l) _) xs) = getSchemas l 49 | where getSchemas (App (App _ s1) s2) = 50 | Just $ [TextPart "Bad schema:"] ++ 51 | getAttrs s1 ++ 52 | [SubReport $ 53 | [TextPart "Expected subschema of"] ++ 54 | getAttrs s2] 55 | getSchemas _ = Nothing 56 | notSubSchemaErr _ = Nothing 57 | -------------------------------------------------------------------------------- /src/DB/SQLite/SQLiteTest.idr: -------------------------------------------------------------------------------- 1 | module DB.SQLite.SQLiteTest 2 | 3 | import Effects 4 | import DB.SQLite.Effect 5 | import DB.SQLite.SQLiteCodes 6 | 7 | 8 | testInsert : String -> Int -> Eff (Either QueryError ()) [SQLITE ()] 9 | testInsert name age = 10 | do open_db <- openDB "test.db" 11 | case open_db of 12 | Left err => return $ Left err 13 | Right () => 14 | do let sql = "INSERT INTO `test` (`name`, `age`) VALUES (?, ?);" 15 | prep_res <- prepareStatement sql 16 | case prep_res of 17 | Left err => do cleanupPSFail ; return $ Left err 18 | Right () => 19 | do bindText 1 name 20 | bindInt 2 age 21 | bind_res <- finishBind 22 | case bind_res of 23 | Just err => do cleanupBindFail ; return $ Left err 24 | Nothing => 25 | case !executeStatement of 26 | Unstarted => do finalise 27 | closeDB 28 | pure (Right ()) 29 | StepFail => do finalise 30 | closeDB 31 | pure (Right ()) 32 | StepComplete => do finalise 33 | closeDB 34 | pure (Right ()) 35 | NoMoreRows => do finalise 36 | closeDB 37 | pure (Right ()) 38 | 39 | 40 | 41 | 42 | testSelect : Eff (Either QueryError ResultSet) [SQLITE ()] 43 | testSelect = 44 | executeSelect "test.db" "SELECT `name`, `sql` FROM `sqlite_master`;" [] $ 45 | do name <- getColumnText 0 46 | sql <- getColumnText 1 47 | return [DBText name, DBText sql] 48 | 49 | 50 | namespace Main 51 | main : IO () 52 | main = do select_res <- run $ testInsert "foo" 29 53 | case select_res of 54 | Left err => putStrLn $ "Error: " ++ (show err) 55 | Right () => putStrLn $ "Done" 56 | select_res <- run $ testSelect 57 | case select_res of 58 | Left err => putStrLn $ "Error reading: " ++ show err 59 | Right res => putStrLn (show res) 60 | 61 | 62 | -- -} 63 | -- -} 64 | -- -} 65 | -------------------------------------------------------------------------------- /type-provider/SQLiteTypes.idr: -------------------------------------------------------------------------------- 1 | module SQLiteTypes 2 | 3 | import Decidable.Equality 4 | 5 | %default total 6 | 7 | 8 | public export data SQLiteType = TEXT | INTEGER | REAL 9 | | NULLABLE SQLiteType 10 | 11 | public export interpSql : SQLiteType -> Type 12 | interpSql TEXT = String 13 | interpSql INTEGER = Integer 14 | interpSql REAL = Double 15 | interpSql (NULLABLE x) = Maybe (interpSql x) 16 | 17 | equalSql : (t : SQLiteType) -> (x, y : interpSql t) -> Bool 18 | equalSql TEXT x y = x == y 19 | equalSql INTEGER x y = x == y 20 | equalSql REAL x y = x == y 21 | equalSql (NULLABLE ty) (Just x) (Just y) = equalSql ty x y 22 | equalSql (NULLABLE ty) Nothing Nothing = True 23 | equalSql (NULLABLE ty) _ _ = False 24 | 25 | export showSql : (t : SQLiteType) -> (x : interpSql t) -> String 26 | showSql TEXT x = show x 27 | showSql INTEGER x = show x 28 | showSql REAL x = show x 29 | showSql (NULLABLE ty) (Just x) = showSql ty x 30 | showSql (NULLABLE ty) Nothing = "null" 31 | 32 | 33 | integerNotText : INTEGER = TEXT -> Void 34 | integerNotText Refl impossible 35 | 36 | realNotText : REAL = TEXT -> Void 37 | realNotText Refl impossible 38 | 39 | nullableNotText : NULLABLE t = TEXT -> Void 40 | nullableNotText Refl impossible 41 | 42 | realNotInteger : REAL = INTEGER -> Void 43 | realNotInteger Refl impossible 44 | 45 | nullableNotInteger : NULLABLE t = INTEGER -> Void 46 | nullableNotInteger Refl impossible 47 | 48 | nullableNotReal : NULLABLE t = REAL -> Void 49 | nullableNotReal Refl impossible 50 | 51 | export implementation DecEq SQLiteType where 52 | decEq TEXT TEXT = Yes Refl 53 | decEq INTEGER TEXT = No integerNotText 54 | decEq REAL TEXT = No realNotText 55 | decEq (NULLABLE x) TEXT = No nullableNotText 56 | decEq TEXT INTEGER = No $ integerNotText . sym 57 | decEq INTEGER INTEGER = Yes Refl 58 | decEq REAL INTEGER = No realNotInteger 59 | decEq (NULLABLE x) INTEGER = No nullableNotInteger 60 | decEq TEXT REAL = No $ realNotText . sym 61 | decEq INTEGER REAL = No $ realNotInteger . sym 62 | decEq REAL REAL = Yes Refl 63 | decEq (NULLABLE x) REAL = No nullableNotReal 64 | decEq TEXT (NULLABLE x) = No $ nullableNotText . sym 65 | decEq INTEGER (NULLABLE x) = No $ nullableNotInteger . sym 66 | decEq REAL (NULLABLE x) = No $ nullableNotReal . sym 67 | decEq (NULLABLE y) (NULLABLE x) with (decEq y x) 68 | decEq (NULLABLE x) (NULLABLE x) | (Yes Refl) = Yes Refl 69 | decEq (NULLABLE y) (NULLABLE x) | (No prf) = No $ prf . inside 70 | where inside : NULLABLE a = NULLABLE b -> a = b 71 | inside Refl = Refl 72 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | SQLite bindings for Idris 2 | ======== 3 | 4 | These SQLite bindings are forked from IdrisWeb. 5 | 6 | To install: 7 | 8 | Make sure your idris command was built with libffi support (if not rebuild it so - you will need to create a custom.mk file - copy custom.mk-alldeps and edit it) 9 | 10 | idris --install sqlite.ipkg 11 | 12 | to test installation: 13 | 14 | idris --build sqlite_test.ipkg 15 | ./sqlite_test 16 | 17 | expected output is: 18 | 19 | Done 20 | [[DBText "test", DBText "CREATE TABLE test (name INT, age INT)"]] 21 | 22 | To install the type provider: 23 | 24 | cd type-provider 25 | 26 | idris --install sqlite_provider.ipkg 27 | 28 | to run the type-provider demo: 29 | 30 | cd ../type_provider-demo 31 | 32 | idris --build demo.ipkg 33 | 34 | ./test 35 | 36 | The expected output is: 37 | 38 | 39 | The speakers are: 40 | name|bio| 41 | "David Christiansen"|"PhD student at ITU"| 42 | "Another Speaker"|null| 43 | "Lots of Speaking"|null| 44 | 45 | The talks are: 46 | title|abstract| 47 | "Type Providers and Error Reflection in Idris"|"Let's talk to the outside world!"| 48 | "Monadic Missile Launching"|"Side effects FTW!"| 49 | "An Actuarial DSL"|"Dependently typed life insurance"| 50 | 51 | Conference program 52 | name|title|abstract| 53 | "David Christiansen"|"Type Providers and Error Reflection in Idris"|"Let's talk to the outside world!"| 54 | "Another Speaker"|"Monadic Missile Launching"|"Side effects FTW!"| 55 | "Lots of Speaking"|"An Actuarial DSL"|"Dependently typed life insurance"| 56 | 57 | ok 58 | 59 | 60 | To run the error test demo: 61 | 62 | cd ../error_test 63 | idris --build error_test.ipkg 64 | 65 | The expected output is: 66 | 67 | Type checking ./ErrorTest.idr 68 | ErrorTest.idr:30:12-32:1: 69 | When checking right hand side of speakers with expected type 70 | Query db ["name" ::: TEXT, "bio" ::: TEXT] 71 | 72 | When checking argument ok to constructor Queries.Query.Select: 73 | Bad schema: 74 | "name" ::: TEXT 75 | "bio" ::: TEXT 76 | Expected subschema of 77 | "id" ::: INTEGER 78 | "name" ::: TEXT 79 | "bio" ::: NULLABLE TEXT 80 | ErrorTest.idr:39:33: 81 | When checking right hand side of program with expected type 82 | Query db 83 | ["name" ::: TEXT, "title" ::: TEXT, "abstract" ::: TEXT] 84 | 85 | When checking argument ok to constructor Queries.Expr.Col: 86 | The column "speaker_id" was not found with type INTEGER in the 87 | schema 88 | "id" ::: INTEGER 89 | "name" ::: TEXT 90 | "bio" ::: NULLABLE TEXT 91 | "title" ::: TEXT 92 | "abstract" ::: TEXT 93 | "speaker" ::: INTEGER 94 | -------------------------------------------------------------------------------- /src/DB/SQLite/SQLiteCodes.idr: -------------------------------------------------------------------------------- 1 | module DB.SQLite.SQLiteCodes 2 | -- Status codes for SQLite 3 | 4 | %access public 5 | %default total 6 | 7 | SQLiteCode : Type 8 | SQLiteCode = Int 9 | 10 | sqlite_OK : Int 11 | sqlite_OK = 0 -- Successful result 12 | -- beginning-of-error-codes 13 | 14 | sqlite_ERROR : Int 15 | sqlite_ERROR = 1 -- SQL error or missing database 16 | 17 | sqlite_INTERNAL : Int 18 | sqlite_INTERNAL = 2 -- Internal logic error in SQLite 19 | 20 | sqlite_PERM : Int 21 | sqlite_PERM = 3 -- Access permission denied 22 | 23 | sqlite_ABORT : Int 24 | sqlite_ABORT = 4 -- Callback routine requested an abort 25 | 26 | sqlite_BUSY : Int 27 | sqlite_BUSY = 5 -- The database file is locked 28 | 29 | sqlite_LOCKED : Int 30 | sqlite_LOCKED = 6 -- A table in the database is locked 31 | 32 | sqlite_NOMEM : Int 33 | sqlite_NOMEM = 7 -- A malloc() failed 34 | 35 | sqlite_READONLY : Int 36 | sqlite_READONLY = 8 -- Attempt to write a readonly database 37 | 38 | sqlite_INTERRUPT : Int 39 | sqlite_INTERRUPT = 9 -- Operation terminated by sqlite3_interrupt() 40 | 41 | sqlite_IOERR : Int 42 | sqlite_IOERR = 10 -- Some kind of disk I/O error occurred 43 | 44 | sqlite_CORRUPT : Int 45 | sqlite_CORRUPT = 11 -- The database disk image is malformed 46 | 47 | sqlite_NOTFOUND : Int 48 | sqlite_NOTFOUND = 12 -- Unknown opcode in sqlite3_file_control() 49 | 50 | sqlite_FULL : Int 51 | sqlite_FULL = 13 -- Insertion failed because database is full 52 | 53 | sqlite_CANTOPEN : Int 54 | sqlite_CANTOPEN = 14 -- Unable to open the database file 55 | 56 | sqlite_PROTOCOL : Int 57 | sqlite_PROTOCOL = 15 -- Database lock protocol error 58 | 59 | sqlite_EMPTY : Int 60 | sqlite_EMPTY = 16 -- Database is empty 61 | 62 | sqlite_SCHEMA : Int 63 | sqlite_SCHEMA = 17 -- The database schema changed 64 | 65 | sqlite_TOOBIG : Int 66 | sqlite_TOOBIG = 18 -- String or BLOB exceeds size limit 67 | 68 | sqlite_CONSTRAINT : Int 69 | sqlite_CONSTRAINT = 19 -- Abort due to constraint violation 70 | 71 | sqlite_MISMATCH : Int 72 | sqlite_MISMATCH = 20 -- Data type mismatch 73 | 74 | sqlite_MISUSE : Int 75 | sqlite_MISUSE = 21 -- Library used incorrectly 76 | 77 | sqlite_NOLFS : Int 78 | sqlite_NOLFS = 22 -- Uses OS features not supported on host 79 | 80 | sqlite_AUTH : Int 81 | sqlite_AUTH = 23 -- Authorization denied 82 | 83 | sqlite_FORMAT : Int 84 | sqlite_FORMAT = 24 -- Auxiliary database format error 85 | 86 | sqlite_RANGE : Int 87 | sqlite_RANGE = 25 -- 2nd parameter to sqlite3_bind out of range 88 | 89 | sqlite_NOTADB : Int 90 | sqlite_NOTADB = 26 -- File opened that is not a database file 91 | 92 | sqlite_NOTICE : Int 93 | sqlite_NOTICE = 27 -- Notifications from sqlite3_log() 94 | 95 | sqlite_WARNING : Int 96 | sqlite_WARNING = 28 -- Warnings from sqlite3_log() 97 | 98 | sqlite_ROW : Int 99 | sqlite_ROW = 100 -- sqlite3_step() has another row ready 100 | 101 | sqlite_DONE : Int 102 | sqlite_DONE = 101 -- sqlite3_step() has finished executing 103 | -- end-of-error-codes 104 | 105 | data StepResult = Unstarted 106 | | StepFail 107 | | StepComplete 108 | | NoMoreRows 109 | 110 | 111 | -- FIXME: For some reason, pattern matching doesn't work 112 | -- when using the 113 | stepResult : Int -> StepResult 114 | stepResult 100 = StepComplete -- step complete, but more data available 115 | stepResult 101 = NoMoreRows -- statement has been fully executed 116 | stepResult _ = StepFail -- an error occurred 117 | 118 | hasMoreRows : StepResult -> Bool 119 | hasMoreRows NoMoreRows = False 120 | hasMoreRows StepComplete = True 121 | hasMoreRows StepFail = True 122 | hasMoreRows Unstarted = True 123 | -------------------------------------------------------------------------------- /src/sqlite3api.h: -------------------------------------------------------------------------------- 1 | /* 2 | * sqlite3api.h 3 | * 4 | * 5 | * Created by Melissa Farinaz MOZIFIAN on 22/06/2012. 6 | * Copyright 2012. All rights reserved. 7 | * 8 | */ 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | 16 | typedef struct { 17 | sqlite3 *db_ptr; // database pointer 18 | sqlite3_stmt *ppStmt; // statement pointer 19 | char buffer[1000]; // bufer to store errors returned by certain functions 20 | const char *Ptr_tail; 21 | sqlite3_value *value; 22 | int row_count; // row number store by exec function 23 | int col_count; 24 | 25 | } DBinfo; 26 | 27 | // struct used for backup functions 28 | typedef struct { 29 | sqlite3 *source_ptr; 30 | sqlite3_backup *backup; 31 | }DBbackup ; 32 | 33 | // Table struct used by get_table function 34 | // stores row and column 35 | // returned by get_table 36 | typedef struct { 37 | int num_row; 38 | int num_col; 39 | char** table_data; 40 | int data_size; 41 | int* data_type; 42 | DBinfo* database; 43 | }Table; 44 | 45 | 46 | void* sqlite3_open_idr(const char *filename); 47 | 48 | int exec_db(void*p); 49 | 50 | int sqlite3_close_idr(void* db); 51 | 52 | int sqlite3_exec_idr(void*, const char *sql); 53 | 54 | char* sqlite3_get_error(void* db); 55 | 56 | int idr_errcode(void* db); 57 | 58 | const unsigned char* sqlite3_get_val_text(void* p,int nCol); 59 | 60 | void* sqlite3_get_table_idr(void* db, const char *sql); 61 | 62 | void sqlite3_free_table_idr(void* db); 63 | 64 | int sqlite3_get_num_col(void* p); 65 | 66 | int sqlite3_get_num_row(void* p); 67 | 68 | int sqlite3_get_num_row_v2(void* p); 69 | 70 | int sqlite3_get_num_col_v2(void* p); 71 | 72 | int sqlite3_get_data_type(void* p, int nRow, int nCol); 73 | 74 | int sqlite3_get_val_int(void* p,int nCo); 75 | 76 | float sqlite3_get_float(void* p, int nCol); 77 | 78 | void* sqlite3_prepare_idr( 79 | void *db, /* Database handle */ 80 | const char *zSql /* SQL statement, UTF-8 encoded */ 81 | ); 82 | 83 | int sqlite3_step_idr(void* stmt); 84 | 85 | void* sqlite3_bind_double_idr(void* p,int index, double val); 86 | 87 | void* sqlite3_bind_int_idr(void* p,int index , int val); 88 | 89 | void* sqlite3_bind_null_idr(void* p,int index); 90 | 91 | void* sqlite3_bind_text_idr(void* p,const char* text, int index,int length); 92 | 93 | int sqlite3_column_count_idr(void* stmt, const char* tbl_name); 94 | 95 | int sqlite3_data_count_idr(void* stmt); 96 | 97 | int sqlite3_reset_idr(void* stmt); 98 | 99 | int sqlite3_finalize_idr(void* stmt); 100 | 101 | int sqlite3_complete_idr(const char *sql); 102 | 103 | const char *sqlite3_column_decltype_idr(void* stmt,int n); 104 | 105 | const char *sqlite3_column_name_idr(void* stmt, int N); 106 | 107 | int sqlite3_column_bytes_idr(void* stmt, int n); 108 | 109 | int sqlite3_column_bytes_idr(void* stmt, int n); 110 | 111 | const void *sqlite3_column_blob_idr(void* stmt, int iCol); 112 | 113 | const unsigned char *sqlite3_column_text_idr(void* stmt, int iCol); 114 | 115 | int sqlite3_column_int_idr(void* stmt, int iCol); 116 | 117 | int sqlite3_column_null_idr(void* db, int iCol); 118 | 119 | double sqlite3_column_double_idr(void* db, int iCol); 120 | 121 | void* sqlite3_backup_init_idr(void* pDestm, 122 | const char *zDestName, 123 | void* pSource, 124 | const char *zSourceName 125 | ); 126 | 127 | int sqlite3_backup_finish_idr(void *backup); 128 | 129 | int sqlite3_backup_step_idr(void *backup, int nPage); 130 | 131 | int sqlite3_backup_remaining_idr(void *backup); 132 | 133 | int sqlite3_backup_pagecount_idr(void *backup); 134 | 135 | int strLength(const char * str); 136 | -------------------------------------------------------------------------------- /type-provider/Provider.idr: -------------------------------------------------------------------------------- 1 | module Provider 2 | 3 | import DB.SQLite.Effect 4 | import DB.SQLite.SQLiteCodes 5 | import Effects 6 | 7 | import Database 8 | import ParserHack 9 | import Queries 10 | import Schema 11 | import SQLiteTypes 12 | 13 | %access export 14 | 15 | %language TypeProviders 16 | 17 | mkDB : ResultSet -> Either String (List (String, Schema)) 18 | mkDB [] = Right [] 19 | mkDB ([DBText v]::rest) = 20 | case getSchema (toLower v) of 21 | Nothing => Left ( "Couldn't parse schema '" ++ v ++ "'\n") 22 | Just (t, tbl) => 23 | with Applicative 24 | Right List.(::) <*> Right (t, tbl) <*> mkDB rest 25 | mkDB _ = Left "Couldn't understand SQLite output - wrong type" 26 | 27 | getSchemas : (filename : String) -> Eff (Provider (DB filename)) [SQLITE ()] 28 | getSchemas file = 29 | do let ddlQuery = "SELECT `sql` FROM `sqlite_master` " ++ 30 | "WHERE NOT (sqlite_master.name LIKE \"sqlite%\");" 31 | resSet <- executeSelect file ddlQuery [] $ 32 | do sql <- getColumnText 0 33 | pure [DBText sql] 34 | case resSet of 35 | Left err => pure (Error $ "Error reading '" ++ file ++ "': " ++ (show err)) 36 | Right res => case mkDB res of 37 | Left err => pure (Error err) 38 | Right db => pure (Provide (MkDB file db)) 39 | 40 | getRow : (s : Schema) -> SimpleEff.Eff (Row s) [SQLITE (SQLiteExecuting ValidRow)] 41 | getRow s = go 0 s 42 | where go : Int -> (s : Schema) -> Eff (Row s) [SQLITE (SQLiteExecuting ValidRow)] 43 | go i [] = pure [] 44 | go i ((_ ::: ty) :: s) = [| getCol ty :: go (i+1) s |] 45 | where getCol : (t : SQLiteType) -> Eff (interpSql t) [SQLITE (SQLiteExecuting ValidRow)] 46 | getCol TEXT = getColumnText i 47 | getCol INTEGER = do int <- getColumnInt i 48 | pure (cast int) 49 | getCol REAL = getColumnFloat i 50 | getCol (NULLABLE x) = do nullp <- isColumnNull i 51 | case nullp of 52 | True => pure Nothing 53 | False => do val <- getCol x 54 | pure (Just val) 55 | 56 | collectRows : (s : Schema) -> Eff (Table s) [SQLITE (SQLiteExecuting ValidRow)] [SQLITE (SQLiteExecuting InvalidRow)] 57 | collectRows s = do row <- getRow s 58 | case !nextRow of 59 | Unstarted => pure $ row :: !(collectRows s) 60 | StepFail => pure $ row :: !(collectRows s) 61 | StepComplete => pure $ row :: !(collectRows s) 62 | NoMoreRows => pure [row] 63 | 64 | query : {file : String} -> {db : DB file} -> Query db s -> Eff (Either QueryError (Table s)) [SQLITE ()] 65 | query {file=fn} q = 66 | case !(openDB fn) of 67 | Left err => pure $ Left err 68 | Right () => -- FIXME should really use binding 69 | case !(prepareStatement (compileQuery q)) of 70 | Left err => do cleanupPSFail 71 | pure $ Left err 72 | Right () => 73 | case !finishBind of 74 | Just err => do cleanupBindFail ; return $ Left err 75 | Nothing => 76 | case !executeStatement of 77 | Unstarted => do rs <- collectRows _ 78 | finalise 79 | closeDB 80 | pure (Right rs) 81 | StepFail => do rs <- collectRows _ 82 | finalise 83 | closeDB 84 | pure (Right rs) 85 | StepComplete => do rs <- collectRows _ 86 | finalise 87 | closeDB 88 | pure (Right rs) 89 | NoMoreRows => do finalise 90 | closeDB 91 | pure (Right []) 92 | 93 | 94 | 95 | -------------------------------------------------------------------------------- /type-provider/Schema.idr: -------------------------------------------------------------------------------- 1 | module Schema 2 | 3 | import SQLiteTypes 4 | 5 | import Decidable.Equality 6 | import Language.Reflection 7 | 8 | %access public export 9 | %default total 10 | 11 | %auto_implicits on 12 | 13 | infix 5 ::: 14 | data Attribute = (:::) String SQLiteType 15 | %name Attribute attr,attr' 16 | 17 | getName : Attribute -> String 18 | getName (c:::_) = c 19 | 20 | getTy : Attribute -> SQLiteType 21 | getTy (_:::t) = t 22 | 23 | attrEta : (attr : Attribute) -> (getName attr ::: getTy attr) = attr 24 | attrEta (x ::: y) = Refl 25 | 26 | attrInj : (c ::: t = c' ::: t') -> (c=c', t=t') 27 | attrInj Refl = (Refl, Refl) 28 | 29 | -- the first case forces it to get stuck if the constants are not in canonical form 30 | foo : (x : String) -> (y : String) -> Dec (x = y) 31 | foo "" "" = Yes Refl 32 | foo x y with (decEq x y) 33 | foo x y | Yes _ = Yes (really_believe_me (Refl {x})) 34 | foo x y | No urgh = No urgh 35 | 36 | 37 | implementation DecEq Attribute where 38 | decEq (x ::: y) (z ::: w) with (foo x z, decEq y w) 39 | decEq (x ::: y) (x ::: y) | (Yes Refl, Yes Refl) = Yes Refl 40 | decEq (x ::: y) (x ::: w) | (Yes Refl, No prf) = No $ prf . snd . attrInj 41 | decEq (x ::: y) (z ::: w) | (No prf, _) = No $ prf . fst . attrInj 42 | 43 | data Schema = Nil | (::) Attribute Schema 44 | %name Schema s,s' 45 | 46 | append : (s1, s2 : Schema) -> Schema 47 | append [] s2 = s2 48 | append (attr :: s) s2 = attr :: (append s s2) 49 | 50 | names : Schema -> List String 51 | names [] = [] 52 | names ((n ::: _) :: s) = n :: names s 53 | 54 | 55 | data HasCol : Schema -> Attribute -> Type where 56 | Here : HasCol (attr::s) attr 57 | There : HasCol s attr -> HasCol (attr'::s) attr 58 | 59 | HasColNotEmpty : HasCol [] a -> Void 60 | HasColNotEmpty Here impossible 61 | HasColNotEmpty (There _) impossible 62 | 63 | implementation Uninhabited (HasCol [] a) where 64 | uninhabited x = HasColNotEmpty x 65 | 66 | decHasColLemma : (HasCol s attr -> Void) -> 67 | (attr' = attr -> Void) -> 68 | HasCol (attr' :: s) attr -> Void 69 | decHasColLemma h1 h2 Here = h2 Refl 70 | decHasColLemma h1 h2 (There x) = h1 x 71 | 72 | decHasCol : (s : Schema) -> (attr : Attribute) -> Dec (HasCol s attr) 73 | decHasCol [] attr = No HasColNotEmpty 74 | decHasCol (attr' :: s) attr with (decEq attr' attr) 75 | decHasCol (attr' :: s) attr' | (Yes Refl) = Yes Here 76 | decHasCol (attr' :: s) attr | (No f) with (decHasCol s attr) 77 | decHasCol (attr' :: s) attr | (No f) | (Yes x) = Yes (There x) 78 | decHasCol (attr' :: s) attr | (No f) | (No g) = No $ \h => decHasColLemma g f h 79 | 80 | 81 | data SubSchema : Schema -> Schema -> Type where 82 | Empty : SubSchema [] s 83 | Head : (tailSub : SubSchema small large) -> 84 | (alsoThere : HasCol large attr) -> 85 | SubSchema (attr :: small) large 86 | 87 | HasColNamed : Schema -> String -> Type 88 | HasColNamed s col = (t : SQLiteType ** HasCol s (col ::: t)) 89 | 90 | decHasColNamed_lemma : ((HasColNamed s col) -> Void) -> ((col' = col) -> Void) -> 91 | (t ** HasCol ((col' ::: ty) :: s) (col ::: t)) -> Void 92 | decHasColNamed_lemma notThere notHere (ty ** Here) = notHere Refl 93 | decHasColNamed_lemma notThere notHere (ty ** (There more)) = notThere (ty ** more) 94 | 95 | 96 | decHasColNamed : (s : Schema) -> (col : String) -> Dec (HasColNamed s col) 97 | decHasColNamed [] col = No $ \h => HasColNotEmpty (snd h) 98 | decHasColNamed ((col' ::: ty) :: s) col with (decEq col' col) 99 | decHasColNamed ((col ::: ty) :: s) col | (Yes Refl) = Yes (ty ** Here) 100 | decHasColNamed ((col' ::: ty) :: s) col | (No f) with (decHasColNamed s col) 101 | decHasColNamed ((col' ::: ty) :: s) col | (No f) | (Yes x) = 102 | Yes (fst x ** There (snd x)) 103 | decHasColNamed ((col' ::: ty) :: s) col | (No f) | (No g) = No (decHasColNamed_lemma g f) 104 | 105 | colNames : Schema -> List String 106 | colNames [] = [] 107 | colNames ((col ::: _) :: s) = col :: colNames s 108 | 109 | data Disjointness : Type where 110 | Disjoint : Disjointness 111 | Overlap : (attr : Attribute) -> Disjointness 112 | 113 | isDisjoint : (s1, s2 : Schema) -> Disjointness 114 | isDisjoint [] s2 = Disjoint 115 | isDisjoint (attr :: s) s2 with (decHasColNamed s2 (getName attr)) 116 | isDisjoint (attr :: s) s2 | (Yes x) = Overlap attr 117 | isDisjoint (attr :: s) s2 | (No f) = isDisjoint s s2 118 | 119 | 120 | -------------------------------------------------------------------------------- /type-provider/ParserHack.idr: -------------------------------------------------------------------------------- 1 | module ParserHack 2 | import Schema 3 | import SQLiteTypes 4 | 5 | %access export 6 | 7 | people : String 8 | people = "CREATE TABLE \"people\" (\"id\" INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL UNIQUE , \"name\" VARCHAR NOT NULL , \"age\" INTEGER)" 9 | 10 | --quote : Char 11 | --quote = '\"' 12 | 13 | --createTable : Parser Char List () 14 | --createTable = str (unpack "CREATE") ~ many1 space ~ str (unpack "TABLE") ^^^ () 15 | 16 | -- schema : Parser String 17 | -- schema = do createTable 18 | -- many1 space 19 | -- is quote 20 | -- res <- many1 (isNot quote) 21 | -- is quote 22 | -- many1 space 23 | -- return (pack res) 24 | -- -- sequence_ [ is quote, many1 space, is '('] 25 | -- -- return (pack res) 26 | 27 | dropPrefixBy : (a -> a -> Bool) -> List a -> List a -> Maybe (List a) 28 | dropPrefixBy p [] ys = Just ys 29 | dropPrefixBy p (x::xs) [] = Nothing 30 | dropPrefixBy p (x::xs) (y::ys) = if p x y then dropPrefixBy p xs ys else Nothing 31 | 32 | getWhile : (a -> Bool) -> List a -> (List a, List a) 33 | getWhile p [] = ([], []) 34 | getWhile p (x::xs) with (p x) 35 | | True = let (ok, rest) = getWhile p xs 36 | in (x :: ok, rest) 37 | | False = ([], x::xs) 38 | 39 | 40 | 41 | isPrefix : (Eq a) => List a -> List a -> Bool 42 | isPrefix [] _ = True 43 | isPrefix (x::xs) [] = False 44 | isPrefix (x::xs) (y::ys) = x == y && isPrefix xs ys 45 | 46 | subList : (Eq a) => List a -> List a -> Bool 47 | subList [] _ = False 48 | subList (x::xs) [] = False 49 | subList (x::xs) (y::ys) = (x == y && isPrefix xs ys) || subList (x::xs) ys 50 | 51 | isNullable : String -> Bool 52 | isNullable = not . subList ["NOT", "NULL"] . split (==' ') 53 | 54 | getType : String -> Maybe String 55 | getType opts = List.find (isType . toUpper) (split (==' ') opts) 56 | where isType : String -> Bool 57 | isType x = List.elem x ["INTEGER", "VARCHAR", "TEXT", "INT" ] 58 | 59 | 60 | colNameTypeNullable : String -> Maybe (String, String, Bool) 61 | colNameTypeNullable col = case dropPrefixBy (==) [] (unpack (trim col)) of 62 | Nothing => Nothing 63 | Just rest => let (name, rest') = (getWhile (/= ' ') rest) 64 | in case dropPrefixBy (==) [' '] rest' of 65 | Just rest'' => case getType (pack rest'') of 66 | Just tp => Just (pack name, tp, isNullable (toUpper (pack rest''))) 67 | Nothing => Nothing 68 | Nothing => Nothing 69 | 70 | nameCols : String -> Maybe (String, List String) 71 | nameCols schema = case dropPrefixBy (\x,y => toLower x == toLower y) (unpack "create table ") (unpack schema) of 72 | Nothing => Nothing 73 | Just rest => let (name, rest') = (getWhile (/= ' ') rest) 74 | in case dropPrefixBy (==) [' ', '('] rest' of 75 | Just rest'' => case dropPrefixBy (==) [')'] (reverse rest'') of 76 | Just rest''' => 77 | Just (pack name, split (==',') (pack (reverse rest'''))) 78 | Nothing => Nothing 79 | Nothing => Nothing 80 | 81 | parse : String -> Maybe (String, List (String, String, Bool)) 82 | parse schema = case nameCols schema of 83 | Just (n, cols) => case sequence {f=Maybe} (map colNameTypeNullable (filter isColumn cols)) of 84 | Just cols' => Just (n, cols') 85 | Nothing => Nothing 86 | Nothing => Nothing 87 | where isColumn : String -> Bool 88 | isColumn col = not $ isPrefixOf "foreign" (toLower (trim col)) 89 | toSchema : List (String, String, Bool) -> Maybe Schema 90 | toSchema [] = Just [] 91 | toSchema ((colName, colT, nullable)::cols) = do tp <- getType (toUpper colT) nullable 92 | rest <- toSchema cols 93 | return ((colName:::tp) :: rest) 94 | where getType : String -> Bool -> Maybe SQLiteType 95 | getType t True = map NULLABLE (getType t False) 96 | getType "VARCHAR" False = Just TEXT 97 | getType "TEXT" False = Just TEXT 98 | getType "INTEGER" False = Just INTEGER 99 | getType "INT" False = Just INTEGER 100 | getType "REAL" False = Just REAL 101 | getType _ False = Nothing 102 | 103 | getSchema : String -> Maybe (String, Schema) 104 | getSchema str = do nameCols <- parse str 105 | tableSchema <- toSchema (snd nameCols) 106 | Just (fst nameCols, tableSchema) 107 | -------------------------------------------------------------------------------- /type-provider/Queries.idr: -------------------------------------------------------------------------------- 1 | module Queries 2 | 3 | import SQLiteTypes 4 | import Schema 5 | import Database 6 | 7 | import Decidable.Equality 8 | import Language.Reflection 9 | import Language.Reflection.Errors 10 | import Language.Reflection.Utils 11 | 12 | %access public export 13 | %default total 14 | %language ErrorReflection 15 | 16 | namespace Row0 17 | data Row : Schema -> Type where 18 | Nil : Row [] 19 | (::) : (x : interpSql t) -> (xs : Row s) -> Row ((c:::t) :: s) 20 | %name Row r1,r2,r3 21 | 22 | getSchema : Row s -> Schema 23 | getSchema {s} _ = s 24 | 25 | getCol : HasCol s attr -> Row s -> interpSql (getTy attr) 26 | getCol Here (x :: xs) = x 27 | getCol (There at) (y :: xs) = getCol at xs 28 | 29 | projectRow : (SubSchema s1 s2) -> Row s2 -> Row s1 30 | projectRow Empty r1 = [] 31 | projectRow {s1=(attr::small)} (Head tailSub alsoThere) r ?= {projectRow_lemma} 32 | let head = getCol alsoThere r in 33 | let tail = projectRow tailSub r in 34 | the (Row ((getName attr ::: getTy attr)::small)) (head::tail) 35 | 36 | showRow : (s : Schema) -> Row s -> String 37 | showRow [] [] = "\n" 38 | showRow ((_ ::: t) :: s) (x :: xs) = showSql t x ++ "|" ++ showRow s xs 39 | 40 | namespace Table 41 | data Table : Schema -> Type where 42 | Nil : Table s 43 | (::) : (r : Row s) -> (rs : Table s) -> Table s 44 | 45 | 46 | showTable' : (s : Schema) -> Table s -> String 47 | showTable' s [] = "" 48 | showTable' s (r :: rs) = showRow s r ++ showTable' s rs 49 | 50 | showHeader : Schema -> String 51 | showHeader [] = "\n" 52 | showHeader ((col ::: _) :: s) = col ++ "|" ++ showHeader s 53 | 54 | showTable : (s : Schema) -> Table s -> String 55 | showTable s t = showHeader s ++ showTable' s t 56 | 57 | 58 | namespace Expr 59 | 60 | data Expr : Schema -> SQLiteType -> Type where 61 | Col : (c : String) -> {t : SQLiteType} -> 62 | {auto ok : HasCol s (c:::t)} -> 63 | Expr s t 64 | (==) : Expr s t -> Expr s t -> Expr s INTEGER 65 | (>) : Expr s INTEGER -> Expr s INTEGER -> Expr s INTEGER 66 | (<) : Expr s INTEGER -> Expr s INTEGER -> Expr s INTEGER 67 | (>=) : Expr s INTEGER -> Expr s INTEGER -> Expr s INTEGER 68 | (<=) : Expr s INTEGER -> Expr s INTEGER -> Expr s INTEGER 69 | Length : Expr s TEXT -> Expr s INTEGER 70 | Not : Expr s INTEGER -> Expr s INTEGER 71 | CstI : Integer -> Expr s INTEGER 72 | 73 | compileOp : String -> String -> String -> String 74 | compileOp op x y = "(" ++ x ++ ") " ++ op ++ " (" ++ y ++ ")" 75 | 76 | compileExpr : Expr s t -> String 77 | compileExpr (Col c) = "`" ++ c ++ "`" 78 | compileExpr (x == y) = compileOp "==" (compileExpr x) (compileExpr y) 79 | compileExpr (x > y) = compileOp ">" (compileExpr x) (compileExpr y) 80 | compileExpr (x < y) = compileOp "<" (compileExpr x) (compileExpr y) 81 | compileExpr (x >= y) = compileOp ">=" (compileExpr x) (compileExpr y) 82 | compileExpr (x <= y) = compileOp "<=" (compileExpr x) (compileExpr y) 83 | compileExpr (Length x) = "LENGTH(" ++ compileExpr x ++ ")" 84 | compileExpr (Not x) = "NOT(" ++ compileExpr x ++ ")" 85 | compileExpr (CstI i) = show i 86 | 87 | fromInteger : Integer -> Expr s INTEGER 88 | fromInteger = CstI 89 | 90 | 91 | namespace Query 92 | %reflection 93 | reflectListPrf : List a -> Tactic 94 | reflectListPrf [] = Refine (UN "Here") `Seq` Solve 95 | reflectListPrf (x :: xs) 96 | = Try (Refine (UN "Here") `Seq` Solve) 97 | (Refine (UN "There") `Seq` (Solve `Seq` reflectListPrf xs)) 98 | -- TMP HACK! FIXME! 99 | -- The evaluator needs a 'function case' to know its a reflection function 100 | -- until we propagate that information! Without this, the _ case won't get 101 | -- matched. 102 | --reflectListPrf (x ++ y) = Refine "Here" `Seq` Solve 103 | reflectListPrf _ = Refine (UN "Here") `Seq` Solve 104 | 105 | %reflection 106 | solveHasTable : Type -> Tactic 107 | solveHasTable (HasTable ts n s) = reflectListPrf ts `Seq` Solve 108 | solveHasTable (HasTable (x ++ y) n s) = Solve 109 | 110 | data Tables : DB file -> Schema -> Type where 111 | T : (name : String) -> 112 | {default tactics { byReflection solveHasTable; } 113 | ok : HasTable db name s} -> 114 | Tables (MkDB file db) s 115 | (*) : (t1 : String) -> 116 | {auto 117 | ok : HasTable db t1 s1} -> 118 | Tables (MkDB file db) s2 -> 119 | {auto disj : isDisjoint s1 s2 = Disjoint} -> 120 | Tables (MkDB file db) (append s1 s2) 121 | 122 | implicit 123 | toTables : (tbl : String) -> 124 | {auto 125 | ok : HasTable db tbl s} -> 126 | Tables (MkDB name db) s 127 | toTables tbl {ok = ok} = T tbl {ok = ok} 128 | 129 | compileTables : {db : DB f} -> Tables db s -> String 130 | compileTables (T n) = n 131 | compileTables (x * y) = x ++ ", " ++ compileTables y 132 | 133 | data Cmd : DB f -> Type where 134 | Insert : (into : String) -> (s : Schema) -> 135 | {default tactics { byReflection solveHasTable; } 136 | ok : HasTable db into s} -> 137 | (values : Table s) -> 138 | Cmd (MkDB f db) 139 | Delete : (from : String) -> (s : Schema) -> 140 | {default tactics { byReflection solveHasTable; } 141 | ok : HasTable db from s} -> 142 | (when : Expr s INTEGER) -> 143 | Cmd (MkDB f db) 144 | 145 | syntax INSERT INTO [table] AS [schema] VALUES [values] = Insert table schema values 146 | syntax DELETE FROM [table] AS [schema] WHEN [when] = Delete table schema when 147 | 148 | 149 | data Query : DB f -> Schema -> Type where 150 | Select : {db : DB f} -> Tables db s -> Expr s INTEGER -> (s' : Schema) -> 151 | {auto ok : SubSchema s' s} -> 152 | Query db s' 153 | 154 | syntax SELECT [schema] FROM [tables] WHERE [expr] = Select tables expr schema 155 | 156 | compileQuery : {db : DB f} -> Query db proj -> String 157 | compileQuery (Select ts expr proj) = "SELECT " ++ 158 | cols ++ 159 | " FROM " ++ 160 | compileTables ts ++ 161 | " WHERE " ++ 162 | compileExpr expr ++ 163 | ";" 164 | where cols : String 165 | cols = Foldable.concat . List.intersperse ", " . colNames $ proj 166 | 167 | ---------- Proofs ---------- 168 | 169 | Queries.Row0.projectRow_lemma = proof 170 | intros 171 | rewrite (attrEta attr) 172 | exact value 173 | 174 | 175 | -------------------------------------------------------------------------------- /src/sqlite3api.c: -------------------------------------------------------------------------------- 1 | /* 2 | * sqlite3api.c 3 | * 4 | * 5 | * Created by Melissa Farinaz MOZIFIAN on 22/06/2012. 6 | * Copyright 2012. All rights reserved. 7 | * 8 | */ 9 | 10 | 11 | #include "sqlite3api.h" 12 | 13 | 14 | // buffer used for storing queries 15 | // Used in high-level functions. 16 | static char sql_query_buffer[2000]; 17 | // array used to store the string 18 | //value obtain by get_val_text 19 | unsigned char* array; 20 | /* 21 | open an SQLite database file as 22 | specified by the filename argument. 23 | Returns pointer to DB struct on success 24 | Null on failure. 25 | */ 26 | void* sqlite3_open_idr(const char *filename){ 27 | 28 | sqlite3 *db; 29 | int res =sqlite3_open(filename,&db); 30 | 31 | if(res != SQLITE_OK){ 32 | printf("Error occured while opening the databse."); 33 | return NULL; 34 | } 35 | DBinfo *dbi = malloc(sizeof(DBinfo)); 36 | dbi->db_ptr = db; 37 | return dbi; 38 | 39 | } 40 | /* 41 | Frees the resource and returns 0 on success 42 | */ 43 | int sqlite3_close_idr(void* db){ 44 | 45 | DBinfo* dbi =(DBinfo*) db; 46 | int res =sqlite3_close(dbi->db_ptr); 47 | if (res == SQLITE_OK){ 48 | free(dbi); 49 | return 0; 50 | } 51 | else { 52 | return res; 53 | } 54 | } 55 | /* 56 | SQLite wrapper around sqlite3_prepare_v2(), 57 | sqlite3_step(), and sqlite3_finalize(). 58 | This version of exec cannot be used with prepare. 59 | For executing queries, must use the exec_db function. 60 | */ 61 | int sqlite3_exec_idr(void* db, const char *sql) 62 | { 63 | DBinfo* dbi =(DBinfo*) db; 64 | char* err; 65 | int rc; 66 | rc = sqlite3_exec(dbi->db_ptr,sql,NULL, NULL, &err); 67 | if (rc != SQLITE_OK && err != NULL) { 68 | strncpy(dbi->buffer, err, sizeof(dbi->buffer)); 69 | sqlite3_free(err); 70 | } 71 | return rc; 72 | } 73 | /* 74 | Gets the error store in the buffer 75 | in the struct. Some certain functions 76 | have the feature to store errors in a buffer. 77 | */ 78 | char* sqlite3_get_error(void* db) { 79 | DBinfo* dbi =(DBinfo*) db; 80 | return dbi->buffer; 81 | } 82 | 83 | int idr_errcode(void* db) { 84 | sqlite3* sql_db = (sqlite3*) db; 85 | return sqlite3_errcode(sql_db); 86 | } 87 | 88 | /* 89 | Compiles the query into a byte-code program 90 | Returns a pointer to the sqlite3_stmt pointer 91 | and stores it in the struct. 92 | */ 93 | void* sqlite3_prepare_idr(void *db,const char *zSql){ 94 | sqlite3_stmt* stmt; 95 | const char *tail; 96 | 97 | DBinfo* dbi =(DBinfo*) db; 98 | 99 | int rec = sqlite3_prepare_v2(dbi->db_ptr,zSql,-1,&stmt,&tail); 100 | dbi ->ppStmt =stmt; 101 | dbi ->Ptr_tail = tail; 102 | 103 | if(rec != SQLITE_OK){ 104 | return NULL; 105 | } 106 | return dbi; 107 | } 108 | /* 109 | Another wrapper interface that is preserved 110 | for backwards compatibility. 111 | Use of this interface is not recommended. 112 | This was mainly used for testing within the 113 | library. 114 | */ 115 | void* sqlite3_get_table_idr(void* db, 116 | const char *sql){ 117 | 118 | DBinfo* dbi =(DBinfo*) db; 119 | char* err; 120 | 121 | Table* tbl = malloc(sizeof(Table)); 122 | tbl->database = dbi; 123 | int res = sqlite3_get_table(dbi->db_ptr,sql,&tbl->table_data,&tbl->num_row,&tbl->num_col,&err); 124 | int array_size = sizeof(&tbl->table_data); 125 | 126 | if( res != SQLITE_OK && err != NULL){ 127 | strncpy(dbi->buffer, err, sizeof(dbi->buffer)); 128 | sqlite3_free(err); 129 | return NULL; 130 | } 131 | tbl -> data_size = array_size; 132 | return tbl; 133 | } 134 | 135 | /* 136 | This function executes queries. 137 | This can be used after preparing a query 138 | In case of error or library misuse 139 | it returns 1. 140 | It also calls step in order to obtain 141 | the row and column number and stores them 142 | in the struct. The row number is needed 143 | later on in get_data_type function. 144 | */ 145 | int exec_db(void*p){ 146 | 147 | DBinfo* dbi =(DBinfo*) p; 148 | int rc, col, row_counter; 149 | 150 | const char* col_name; 151 | 152 | rc = sqlite3_step(dbi->ppStmt); 153 | 154 | if( rc == SQLITE_DONE){ 155 | return rc; 156 | } 157 | if(rc == SQLITE_ERROR && rc == SQLITE_MISUSE){ 158 | return 1; 159 | } 160 | row_counter =0; 161 | 162 | while (rc == SQLITE_ROW) { 163 | 164 | rc = sqlite3_step(dbi->ppStmt); 165 | row_counter++; 166 | } 167 | 168 | col = sqlite3_column_count(dbi->ppStmt); 169 | dbi->row_count = row_counter; 170 | dbi->col_count = col; 171 | return rc; 172 | } 173 | /* 174 | Returns row number from DB Struct 175 | 176 | */ 177 | int sqlite3_get_num_row_v2(void* p){ 178 | 179 | DBinfo* dbi =(DBinfo*) p; 180 | int row_number =dbi->row_count; 181 | return row_number; 182 | } 183 | 184 | /* 185 | Returns column number from DB Struct 186 | */ 187 | int sqlite3_get_num_col_v2(void* p){ 188 | 189 | DBinfo* dbi =(DBinfo*) p; 190 | int col_number =dbi-> col_count; 191 | return col_number; 192 | } 193 | 194 | /* 195 | Another way of obtaining row number 196 | Thought this function gets the value 197 | from Table struct. The value is stored 198 | in the struct after calling get_table. 199 | Using this version is not recommended 200 | unless used with get_table 201 | */ 202 | int sqlite3_get_num_row(void* p){ 203 | 204 | Table* tbl =(Table*) p; 205 | int row_number =tbl->num_row; 206 | return row_number; 207 | } 208 | 209 | /* 210 | Another way of obtaining column number 211 | Thought this function gets the value 212 | from Table struct. The value is stored 213 | in the struct after calling get_table. 214 | Using this version is not recommended 215 | unless used with get_table 216 | */ 217 | int sqlite3_get_num_col(void* p){ 218 | 219 | Table* tbl =(Table*) p; 220 | int col_number =tbl-> num_col; 221 | return col_number; 222 | } 223 | 224 | /* 225 | This routine returns the type of value 226 | and must be called after prepare and exec. 227 | Since exec steps through database to obtain 228 | row number, this function calls reset to 229 | set the pointer to its initial state 230 | and then calls sqlite3_column_type 231 | to get the type 232 | */ 233 | int sqlite3_get_data_type(void* p, int nRow, int nCol){ 234 | 235 | DBinfo* dbi =(DBinfo*) p; 236 | int rc, type, row_counter; 237 | const char* char_int; 238 | 239 | rc = sqlite3_reset(dbi->ppStmt); 240 | rc = sqlite3_step(dbi->ppStmt); 241 | row_counter =0; 242 | 243 | while (rc == SQLITE_ROW && row_counter < nRow) { 244 | 245 | rc = sqlite3_step(dbi->ppStmt); 246 | row_counter++; 247 | } 248 | type =sqlite3_column_type(dbi->ppStmt, nCol); 249 | return type; 250 | 251 | } 252 | /* 253 | Obtains the integer value in a given column 254 | */ 255 | 256 | int sqlite3_get_val_int(void* p, int nCol){ 257 | 258 | DBinfo* dbi =(DBinfo*) p; 259 | int val, col; 260 | val =sqlite3_column_int(dbi->ppStmt, nCol); 261 | return val; 262 | } 263 | 264 | /* 265 | Obtains the text value 266 | Need to allocate memory to store the string 267 | Use GC_malloc since Boehm garbage collector 268 | frees the resources . 269 | */ 270 | const unsigned char* sqlite3_get_val_text(void* p,int nCol){ 271 | 272 | 273 | DBinfo* dbi =(DBinfo*) p; 274 | int rc,i, val, counter; 275 | const unsigned char* text_val; 276 | array =(unsigned char *) malloc(1000*sizeof(char)); 277 | text_val =sqlite3_column_text(dbi->ppStmt, nCol); 278 | memcpy(array, text_val, strlen(text_val)); 279 | return array; 280 | 281 | } 282 | float sqlite3_get_float(void* p, int nCol){ 283 | 284 | DBinfo* dbi =(DBinfo*) p; 285 | double double_val; 286 | 287 | double_val =sqlite3_column_double(dbi->ppStmt, nCol); 288 | float float_val =(float)double_val; 289 | return float_val; 290 | 291 | } 292 | /* 293 | frees the pointer returned by get_table. 294 | */ 295 | 296 | void sqlite3_free_table_idr(void* db){ 297 | Table* tbl =(Table*) db; 298 | sqlite3_free_table(tbl->table_data); 299 | free(tbl); 300 | } 301 | int sqlite3_step_idr(void* db){ 302 | 303 | DBinfo* dbi =(DBinfo*) db; 304 | int rc =sqlite3_step(dbi->ppStmt); 305 | return rc; 306 | } 307 | /* 308 | Binds integer. This returns a pointer 309 | because of the implementation of BindMulti 310 | which binds multiple values 311 | */ 312 | void* sqlite3_bind_int_idr(void* p,int index, int val){ 313 | 314 | DBinfo* dbi =(DBinfo*) p; 315 | int rc; 316 | 317 | rc =sqlite3_bind_int(dbi->ppStmt,index,val); 318 | if(rc != SQLITE_OK){ 319 | return NULL; 320 | } 321 | 322 | return dbi; 323 | } 324 | 325 | void* sqlite3_bind_double_idr(void* p,int index, double val){ 326 | 327 | DBinfo* dbi =(DBinfo*) p; 328 | int rc; 329 | double res =(double)val; 330 | 331 | rc =sqlite3_bind_double(dbi->ppStmt,index,res); 332 | 333 | if(rc != SQLITE_OK){ 334 | return NULL; 335 | } 336 | return dbi; 337 | } 338 | 339 | void* sqlite3_bind_null_idr(void* p,int index){ 340 | 341 | DBinfo* dbi =(DBinfo*) p; 342 | int rc; 343 | rc =sqlite3_bind_null(dbi->ppStmt,index); 344 | if(rc != SQLITE_OK){ 345 | return NULL; 346 | } 347 | 348 | return dbi; 349 | } 350 | 351 | void* sqlite3_bind_text_idr(void* p,const char* text, int index,int length){ 352 | 353 | DBinfo* dbi =(DBinfo*) p; 354 | int rc; 355 | rc =sqlite3_bind_text(dbi->ppStmt,index,text,length,SQLITE_STATIC); 356 | if(rc != SQLITE_OK){ 357 | return NULL; 358 | } 359 | 360 | return dbi; 361 | } 362 | /* 363 | Used for testing column count function. 364 | This function prepares query and by passing 365 | select all, gets the count for column number 366 | Could be used for testing. Not recommended to 367 | be used with prepare and exec 368 | */ 369 | 370 | int sqlite3_column_count_idr(void* db, const char* tbl_name){ 371 | DBinfo* dbi =(DBinfo*) db; 372 | sqlite3_stmt* stmt; 373 | const char *tail; 374 | int rc; 375 | 376 | strcpy(sql_query_buffer, "select * from "); 377 | strcat(sql_query_buffer, tbl_name); 378 | 379 | rc = sqlite3_prepare_v2(dbi->db_ptr, sql_query_buffer, -1, &stmt, &tail); 380 | if(rc != SQLITE_OK){ 381 | fprintf(stderr, "SQL Prepare error"); 382 | return rc; 383 | } 384 | printf("Prepare successful %d\n", rc); 385 | 386 | rc =sqlite3_column_count(stmt); 387 | if(rc == 0){ 388 | fprintf(stderr, "SQL column count error\n"); 389 | return rc; 390 | } 391 | sqlite3_finalize(stmt); 392 | 393 | // rc = actual column count 394 | return rc; 395 | } 396 | 397 | int sqlite3_data_count_idr(void* db){ 398 | 399 | DBinfo* dbi =(DBinfo*) db; 400 | int rc = sqlite3_data_count(dbi->ppStmt); 401 | 402 | return rc; 403 | } 404 | /* 405 | Must be called after prepare to clean up 406 | the resources. 407 | */ 408 | int sqlite3_finalize_idr(void* db){ 409 | 410 | DBinfo* dbi=(DBinfo*) db; 411 | int rc =sqlite3_finalize(dbi->ppStmt); 412 | return rc; 413 | } 414 | 415 | int sqlite3_complete_idr(const char *sql){ 416 | 417 | int rc = sqlite3_complete(sql); 418 | return rc; 419 | } 420 | 421 | /* 422 | Resets a prepared statement pointer 423 | to its initial state 424 | */ 425 | int sqlite3_reset_idr(void* db){ 426 | 427 | DBinfo* dbi=(DBinfo*) db; 428 | int rc = sqlite3_reset(dbi-> ppStmt); 429 | return rc; 430 | 431 | } 432 | /* 433 | The following routines may be used to 434 | obtain column related information. 435 | */ 436 | const char *sqlite3_column_name_idr(void* db, int N){ 437 | 438 | DBinfo* dbi=(DBinfo*) db; 439 | const char *name = sqlite3_column_name(dbi->ppStmt, N); 440 | 441 | return name; 442 | } 443 | 444 | const char *sqlite3_column_decltype_idr(void* db,int n){ 445 | DBinfo* dbi=(DBinfo*) db; 446 | const char *dectype = sqlite3_column_decltype(dbi->ppStmt, n); 447 | 448 | return dectype; 449 | 450 | } 451 | int sqlite3_column_bytes_idr(void* db, int n){ 452 | 453 | DBinfo* dbi=(DBinfo*) db; 454 | int res = sqlite3_column_bytes(dbi->ppStmt, n); 455 | return res; 456 | 457 | 458 | } 459 | const void *sqlite3_column_blob_idr(void* db, int iCol){ 460 | DBinfo* dbi=(DBinfo*) db; 461 | const void* data =sqlite3_column_blob(dbi-> ppStmt, iCol); 462 | return data; 463 | } 464 | 465 | const unsigned char *sqlite3_column_text_idr(void* db, int iCol){ 466 | DBinfo* dbi=(DBinfo*) db; 467 | const unsigned char* col_text =sqlite3_column_text(dbi->ppStmt, iCol); 468 | return col_text; 469 | 470 | } 471 | 472 | int sqlite3_column_int_idr(void* db, int iCol){ 473 | DBinfo* dbi=(DBinfo*) db; 474 | int res =sqlite3_column_int(dbi-> ppStmt, iCol); 475 | return res; 476 | 477 | } 478 | 479 | 480 | /* True iff the column contains the NULL value */ 481 | int sqlite3_column_null_idr(void* db, int iCol) { 482 | DBinfo* dbi = (DBinfo *) db; 483 | return sqlite3_column_type(dbi->ppStmt, iCol) == SQLITE_NULL; 484 | } 485 | 486 | double sqlite3_column_double_idr(void* db, int iCol) { 487 | DBinfo* dbi = (DBinfo *) db; 488 | return sqlite3_column_double(dbi->ppStmt, iCol); 489 | } 490 | 491 | /* 492 | Some back up functions 493 | */ 494 | 495 | void* sqlite3_backup_init_idr(void* pDest, 496 | const char *zDestName, 497 | void* pSource, 498 | const char *zSourceName 499 | ){ 500 | 501 | DBinfo* dbi=(DBinfo*) pDest; 502 | DBbackup* dbi2=(DBbackup*) pSource; 503 | 504 | void* res = sqlite3_backup_init(dbi->db_ptr,zDestName, 505 | dbi2->source_ptr,zSourceName); 506 | 507 | if(res == NULL){ 508 | printf("Error number in initializing backup : %d\n", sqlite3_errcode(dbi->db_ptr)); 509 | } 510 | 511 | dbi2->backup = res; 512 | return dbi2; 513 | 514 | 515 | } 516 | 517 | int sqlite3_backup_step_idr(void *backup, int nPage){ 518 | 519 | DBbackup* dbi=(DBbackup*) backup; 520 | int res = sqlite3_backup_step(dbi->backup, nPage); 521 | return res; 522 | 523 | 524 | } 525 | int sqlite3_backup_finish_idr(void *backup){ 526 | 527 | DBbackup* dbi=(DBbackup*) backup; 528 | int res = sqlite3_backup_finish(dbi->backup); 529 | return res; 530 | 531 | 532 | } 533 | 534 | int sqlite3_backup_remaining_idr(void *backup){ 535 | 536 | DBbackup* dbi=(DBbackup*) backup; 537 | int res = sqlite3_backup_remaining(dbi->backup); 538 | 539 | return res; 540 | } 541 | 542 | int sqlite3_backup_pagecount_idr(void *backup){ 543 | 544 | DBbackup* dbi=(DBbackup*) backup; 545 | int res =sqlite3_backup_pagecount(dbi-> backup); 546 | return res; 547 | 548 | } 549 | /* 550 | Get the length of string 551 | Need this in Idris since length will not 552 | work on Strings. 553 | */ 554 | int strLength(const char * str){ 555 | 556 | int length = strlen(str); 557 | return length; 558 | 559 | 560 | } 561 | 562 | 563 | -------------------------------------------------------------------------------- /src/DB/SQLite/Effect.idr: -------------------------------------------------------------------------------- 1 | module DB.SQLite.Effect 2 | import Effects 3 | import DB.SQLite.SQLiteCodes 4 | 5 | %default total 6 | 7 | %link C "sqlite3api.o" 8 | %include C "sqlite3api.h" 9 | %lib C "sqlite3" 10 | 11 | %dynamic "libsqlite3" 12 | %dynamic "sqlite3api.so" 13 | %access public export 14 | 15 | data ConnectionPtr = ConnPtr Ptr 16 | data StmtPtr = PSPtr Ptr 17 | 18 | data DBVal = DBInt Int 19 | | DBText String 20 | | DBFloat Double 21 | | DBNull 22 | 23 | implementation Show DBVal where 24 | show (DBInt i) = "DBInt " ++ show i 25 | show (DBText t) = "DBText " ++ show t 26 | show (DBFloat f) = "DBFloat " ++ show f 27 | show DBNull = "DBNull" 28 | 29 | -- Type synonym for a table 30 | ResultSet : Type 31 | ResultSet = List (List DBVal) 32 | 33 | DBName : Type 34 | DBName = String 35 | 36 | QueryString : Type 37 | QueryString = String 38 | 39 | Column : Type 40 | Column = Int 41 | 42 | ArgPos : Type 43 | ArgPos = Int 44 | data BindError = BE ArgPos SQLiteCode 45 | 46 | {- Connection-stage resources -} 47 | data SQLiteConnected : Type where 48 | SQLConnection : ConnectionPtr -> SQLiteConnected 49 | 50 | {- PreparedStatement resources -} 51 | data BindStep = Binding | Bound 52 | 53 | data SQLitePSSuccess : BindStep -> Type where 54 | -- We record potential bind failures within the resource, 55 | -- and branch on the finishBind step. This prevents us from 56 | -- having to branch on every bind, which would be impractical. 57 | SQLitePS : ConnectionPtr -> StmtPtr -> SQLitePSSuccess a 58 | SQLiteBindFail : ConnectionPtr -> StmtPtr -> BindError -> SQLitePSSuccess a 59 | 60 | 61 | data SQLitePSFail : Type where 62 | PSFail : ConnectionPtr -> SQLitePSFail 63 | 64 | data SQLiteFinishBindFail : Type where 65 | SQLiteFBFail : ConnectionPtr -> StmtPtr -> SQLiteFinishBindFail 66 | 67 | {- Executing Resources -} 68 | -- Tag used to indicate whether another row may be fetched 69 | data ExecutionResult = ValidRow 70 | | InvalidRow 71 | 72 | data SQLiteExecuting : ExecutionResult -> Type where 73 | SQLiteE : ConnectionPtr -> StmtPtr -> SQLiteExecuting a 74 | 75 | data QueryError = ConnectionError SQLiteCode 76 | | BindingError BindError 77 | | StatementError SQLiteCode 78 | | ExecError String 79 | | InternalError 80 | 81 | implementation Show QueryError where 82 | show (ConnectionError code) = "Error connecting to database, code: " ++ (show code) 83 | show (BindingError (BE ap code)) = "Error binding variable, pos: " ++ (show ap) ++ ", code: " ++ (show code) 84 | show (StatementError code) = "Error creating prepared statement, code: " ++ (show code) 85 | show (ExecError err) = err 86 | show (InternalError) = "Internal Error." 87 | 88 | data Sqlite : Effect where 89 | -- Opens a connection to the database 90 | OpenDB : DBName -> sig Sqlite (Either QueryError ()) () (\result => (either (const ()) (const SQLiteConnected) result)) 91 | -- Closes the database handle 92 | CloseDB : sig Sqlite () SQLiteConnected () 93 | -- Prepares a statement, given a basic query string 94 | PrepareStatement : QueryString -> sig Sqlite (Either QueryError ()) 95 | (SQLiteConnected) 96 | (\result => either (const SQLitePSFail) 97 | (const $ SQLitePSSuccess Binding) result) 98 | -- Binds arguments to the given argument position 99 | BindInt : ArgPos -> Int -> sig Sqlite () (SQLitePSSuccess Binding) 100 | BindFloat : ArgPos -> Double -> sig Sqlite () (SQLitePSSuccess Binding) 101 | BindText : ArgPos -> String -> Int -> sig Sqlite () (SQLitePSSuccess Binding) 102 | BindNull : ArgPos -> sig Sqlite () (SQLitePSSuccess Binding) 103 | 104 | -- Checks to see whether all the binds were successful, if not then fails with the bind error 105 | FinishBind : sig Sqlite (Maybe QueryError) (SQLitePSSuccess Binding) (\result => maybe (SQLitePSSuccess Bound) (const SQLiteFinishBindFail) result) 106 | 107 | -- Executes the statement, and fetches the first row 108 | ExecuteStatement : sig Sqlite (StepResult) (SQLitePSSuccess Bound) 109 | (\result => if hasMoreRows result 110 | then SQLiteExecuting ValidRow 111 | else SQLiteExecuting InvalidRow) 112 | 113 | RowStep : sig Sqlite (StepResult) (SQLiteExecuting ValidRow) 114 | (\result => if hasMoreRows result 115 | then SQLiteExecuting ValidRow 116 | else SQLiteExecuting InvalidRow) 117 | 118 | -- We need two separate effects, but this is entirely non-user-facing due to 119 | -- if_valid in the wrapper function 120 | Reset : sig Sqlite (StepResult) (SQLiteExecuting state) 121 | (\result => if hasMoreRows result 122 | then SQLiteExecuting ValidRow 123 | else SQLiteExecuting InvalidRow) 124 | 125 | -- Column access functions 126 | GetColumnName : Column -> sig Sqlite String (SQLiteExecuting ValidRow) 127 | GetColumnDataSize : Column -> sig Sqlite Int (SQLiteExecuting ValidRow) 128 | GetColumnText : Column -> sig Sqlite String (SQLiteExecuting ValidRow) 129 | GetColumnInt : Column -> sig Sqlite Int (SQLiteExecuting ValidRow) 130 | GetColumnFloat : Column -> sig Sqlite Double (SQLiteExecuting ValidRow) 131 | IsColumnNull : Column -> sig Sqlite Bool (SQLiteExecuting ValidRow) 132 | 133 | -- Finalisation Functions 134 | Finalise : sig Sqlite () (SQLiteExecuting s) SQLiteConnected 135 | 136 | 137 | -- Cleanup functions to handle error states 138 | CleanupPSFail : sig Sqlite () SQLitePSFail () 139 | CleanupBindFail : sig Sqlite () SQLiteFinishBindFail () 140 | 141 | 142 | private 143 | foreignGetError : ConnectionPtr -> IO Int 144 | foreignGetError (ConnPtr ptr) = foreign FFI_C "idr_errcode" (Ptr -> IO Int) ptr 145 | 146 | private 147 | foreignNextRow : ConnectionPtr -> IO StepResult 148 | foreignNextRow (ConnPtr ptr) = 149 | map stepResult (foreign FFI_C "sqlite3_step_idr" (Ptr -> IO Int) ptr) 150 | 151 | private 152 | foreignFinalise : ConnectionPtr -> IO () 153 | foreignFinalise (ConnPtr c) = do foreign FFI_C "sqlite3_finalize_idr" (Ptr -> IO Int) c 154 | return () 155 | 156 | private 157 | foreignClose : ConnectionPtr -> IO () 158 | foreignClose (ConnPtr c) = do foreign FFI_C "sqlite3_close_idr" (Ptr -> IO Int) c 159 | return () 160 | 161 | -- That's the painful bit done, since exception branching will allow us to not have to do 162 | -- the ugliness of pass-through handlers 163 | implementation Handler Sqlite IO where 164 | handle () (OpenDB file) k = do 165 | ff <- foreign FFI_C "sqlite3_open_idr" (String -> IO Ptr) file 166 | is_null <- nullPtr ff 167 | if (not is_null) then k (Right ()) (SQLConnection (ConnPtr ff)) 168 | else k (Left (ConnectionError sqlite_ERROR)) () 169 | 170 | handle (SQLConnection (ConnPtr conn)) CloseDB k = do 171 | foreign FFI_C "sqlite3_close_idr" (Ptr -> IO Int) conn 172 | k () () 173 | 174 | handle (SQLConnection (ConnPtr conn)) (PrepareStatement str) k = do 175 | res <- foreign FFI_C "sqlite3_prepare_idr" (Ptr -> String -> IO Ptr) conn str 176 | is_null <- nullPtr res 177 | if (not is_null) then k (Right ()) (SQLitePS (ConnPtr conn) (PSPtr res)) 178 | else do err <- foreignGetError (ConnPtr conn) 179 | k (Left (StatementError err)) (PSFail (ConnPtr conn)) 180 | 181 | handle (SQLitePS (ConnPtr conn) (PSPtr res)) (BindInt pos i) k = do 182 | res <- foreign FFI_C "sqlite3_bind_int_idr" (Ptr -> Int -> Int -> IO Ptr) conn pos i 183 | is_null <- nullPtr res 184 | if (not is_null) then k () (SQLitePS (ConnPtr conn) (PSPtr res)) 185 | else do err <- foreignGetError (ConnPtr conn) 186 | -- putStrLn $ "BindInt error: " ++ (show err) 187 | k () (SQLiteBindFail (ConnPtr conn) (PSPtr res) (BE pos err)) 188 | 189 | handle (SQLitePS (ConnPtr conn) (PSPtr res)) (BindFloat pos f) k = do 190 | res <- foreign FFI_C "sqlite3_bind_double_idr" (Ptr -> Int -> Double -> IO Ptr) conn pos f 191 | is_null <- nullPtr res 192 | if (not is_null) then k () (SQLitePS (ConnPtr conn) (PSPtr res)) 193 | else do err <- foreignGetError (ConnPtr conn) 194 | k () (SQLiteBindFail (ConnPtr conn) (PSPtr res) (BE pos err)) 195 | 196 | handle (SQLitePS (ConnPtr conn) (PSPtr res)) (BindText pos str str_len) k = do 197 | res <- foreign FFI_C "sqlite3_bind_text_idr" 198 | (Ptr -> String -> Int -> Int -> IO Ptr) 199 | conn str pos str_len 200 | is_null <- nullPtr res 201 | if (not is_null) then k () (SQLitePS (ConnPtr conn) (PSPtr res)) 202 | else do err <- foreignGetError (ConnPtr conn) 203 | -- putStrLn $ "BindStr error: " ++ (show err) 204 | k () (SQLiteBindFail (ConnPtr conn) (PSPtr res) (BE pos err)) 205 | 206 | handle (SQLitePS (ConnPtr conn) (PSPtr res)) (BindNull pos) k = do 207 | res <- foreign FFI_C "sqlite3_bind_null_idr" (Ptr -> Int -> IO Ptr) conn pos 208 | is_null <- nullPtr res 209 | if (not is_null) then k () (SQLitePS (ConnPtr conn) (PSPtr res)) 210 | else do err <- foreignGetError (ConnPtr conn) 211 | k () (SQLiteBindFail (ConnPtr conn) (PSPtr res) (BE pos err)) 212 | 213 | -- Ok, I lied, we have to do *some* pass-throughs. But they're not terrible. 214 | handle (SQLiteBindFail conn ps be) (BindInt _ _) k = k () (SQLiteBindFail conn ps be) 215 | handle (SQLiteBindFail conn ps be) (BindText _ _ _) k = k () (SQLiteBindFail conn ps be) 216 | handle (SQLiteBindFail conn ps be) (BindFloat _ _) k = k () (SQLiteBindFail conn ps be) 217 | handle (SQLiteBindFail conn ps be) (BindNull _) k = k () (SQLiteBindFail conn ps be) 218 | 219 | 220 | -- Finishing binding, reporting any bind errors if they occurred 221 | handle (SQLitePS c p) (FinishBind) k = 222 | k Nothing (SQLitePS c p) 223 | 224 | handle (SQLiteBindFail c ps be) (FinishBind) k = 225 | k (Just (BindingError be)) (SQLiteFBFail c ps) 226 | 227 | handle (SQLitePS (ConnPtr c) (PSPtr p)) (ExecuteStatement) k = do 228 | step <- foreignNextRow (ConnPtr c) 229 | case step of 230 | Unstarted => k Unstarted (SQLiteE (ConnPtr c) (PSPtr p)) 231 | StepComplete => k StepComplete (SQLiteE (ConnPtr c) (PSPtr p)) 232 | StepFail => k StepFail (SQLiteE (ConnPtr c) (PSPtr p)) 233 | NoMoreRows => k NoMoreRows (SQLiteE (ConnPtr c) (PSPtr p)) 234 | 235 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (RowStep) k = do 236 | step <- foreignNextRow (ConnPtr c) 237 | case step of 238 | Unstarted => k Unstarted (SQLiteE (ConnPtr c) (PSPtr p)) 239 | StepComplete => k StepComplete (SQLiteE (ConnPtr c) (PSPtr p)) 240 | StepFail => k StepFail (SQLiteE (ConnPtr c) (PSPtr p)) 241 | NoMoreRows => k NoMoreRows (SQLiteE (ConnPtr c) (PSPtr p)) 242 | 243 | -- Getting values from the current row 244 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (GetColumnName i) k = do 245 | res <- foreign FFI_C "sqlite3_column_name_idr" (Ptr -> Int -> IO String) c i 246 | k res (SQLiteE (ConnPtr c) (PSPtr p)) 247 | 248 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (GetColumnDataSize i) k = do 249 | res <- foreign FFI_C "sqlite3_column_bytes_idr" (Ptr -> Int -> IO Int) c i 250 | k res (SQLiteE (ConnPtr c) (PSPtr p)) 251 | 252 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (GetColumnInt i) k = do 253 | res <- foreign FFI_C "sqlite3_column_int_idr" (Ptr -> Int -> IO Int) c i 254 | k res (SQLiteE (ConnPtr c) (PSPtr p)) 255 | 256 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (GetColumnFloat i) k = do 257 | res <- foreign FFI_C "sqlite3_column_double_idr" (Ptr -> Int -> IO Double) c i 258 | k res (SQLiteE (ConnPtr c) (PSPtr p)) 259 | 260 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (GetColumnText i) k = do 261 | res <- foreign FFI_C "sqlite3_column_text_idr" (Ptr -> Int -> IO String) c i 262 | k res (SQLiteE (ConnPtr c) (PSPtr p)) 263 | 264 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (IsColumnNull i) k = do 265 | res <- foreign FFI_C "sqlite3_column_null_idr" (Ptr -> Int -> IO Int) c i 266 | k (res /= 0) (SQLiteE (ConnPtr c) (PSPtr p)) 267 | 268 | -- Resetting our position 269 | handle (SQLiteE (ConnPtr c) (PSPtr p)) (Reset) k = do 270 | foreign FFI_C "sqlite3_reset_idr" (Ptr -> IO Int) c 271 | step <- foreignNextRow (ConnPtr c) 272 | case step of 273 | Unstarted => k Unstarted (SQLiteE (ConnPtr c) (PSPtr p)) 274 | StepComplete => k StepComplete (SQLiteE (ConnPtr c) (PSPtr p)) 275 | StepFail => k StepFail (SQLiteE (ConnPtr c) (PSPtr p)) 276 | NoMoreRows => k NoMoreRows (SQLiteE (ConnPtr c) (PSPtr p)) 277 | 278 | {- handle (SQLiteE (ConnPtr c) (PSPtr p)) (ResetFromEnd) k = do 279 | foreign FFI_C (FFun "sqlite3_reset_idr" [FPtr] FInt) c 280 | step <- foreignNextRow (ConnPtr c) 281 | case step of 282 | StepComplete => k StepComplete (SQLiteE (ConnPtr c) (PSPtr p)) 283 | StepFail => k StepFail (SQLiteE (ConnPtr c) (PSPtr p)) 284 | NoMoreRows => k NoMoreRows (SQLiteE (ConnPtr c) (PSPtr p)) 285 | -} 286 | -- Finalising the SQL Statement 287 | handle (SQLiteE c p) (Finalise) k = do 288 | foreignFinalise c 289 | k () (SQLConnection c) 290 | 291 | handle (PSFail c) CleanupPSFail k = do 292 | foreignClose c 293 | k () () 294 | 295 | handle (SQLiteFBFail c p) CleanupBindFail k = do 296 | foreignFinalise c 297 | foreignClose c 298 | k () () 299 | --hack 300 | handle _ _ k = believe_me () 301 | 302 | 303 | 304 | SQLITE : Type -> EFFECT 305 | SQLITE t = MkEff t Sqlite 306 | {- User-facing functions -} 307 | openDB : DBName -> Eff (Either QueryError ()) [SQLITE ()] 308 | (\result => [SQLITE (either (const ()) (const SQLiteConnected) result)]) 309 | openDB name = call $ OpenDB name 310 | 311 | closeDB : Eff () [SQLITE (SQLiteConnected)] [SQLITE ()] 312 | closeDB = call CloseDB 313 | 314 | prepareStatement : QueryString -> Eff (Either QueryError ()) 315 | [SQLITE SQLiteConnected] 316 | (\result => [SQLITE ( either (const SQLitePSFail) 317 | (const $ SQLitePSSuccess Binding) result)]) 318 | prepareStatement stmt = call $ PrepareStatement stmt 319 | 320 | bindInt : ArgPos -> Int -> Eff () [SQLITE (SQLitePSSuccess Binding)] 321 | bindInt pos i = call $ BindInt pos i 322 | 323 | bindFloat : ArgPos -> Double -> Eff () [SQLITE (SQLitePSSuccess Binding)] 324 | bindFloat pos f = call $ BindFloat pos f 325 | 326 | bindText : ArgPos -> String -> Eff () [SQLITE (SQLitePSSuccess Binding)] 327 | bindText pos str = call $ BindText pos str str_len 328 | where natToInt : Nat -> Int 329 | natToInt Z = 0 330 | natToInt (S k) = 1 + (natToInt k) 331 | 332 | str_len : Int 333 | str_len = natToInt (length str) 334 | 335 | bindNull : ArgPos -> Eff () [SQLITE (SQLitePSSuccess Binding)] 336 | bindNull pos = call $ BindNull pos 337 | 338 | finishBind : Eff (Maybe QueryError) [SQLITE (SQLitePSSuccess Binding)] 339 | (\result => [SQLITE (maybe (SQLitePSSuccess Bound) (const SQLiteFinishBindFail) result)]) 340 | finishBind = call FinishBind 341 | 342 | nextRow : Eff StepResult [SQLITE (SQLiteExecuting ValidRow)] 343 | (\result => [SQLITE (if hasMoreRows result 344 | then SQLiteExecuting ValidRow 345 | else SQLiteExecuting InvalidRow)]) 346 | nextRow = call RowStep 347 | 348 | reset : Eff StepResult [SQLITE (SQLiteExecuting state)] 349 | (\result => [SQLITE (if hasMoreRows result 350 | then SQLiteExecuting ValidRow 351 | else SQLiteExecuting InvalidRow)]) 352 | reset = call Reset 353 | 354 | 355 | getColumnName : Column -> Eff String [SQLITE (SQLiteExecuting ValidRow)] 356 | getColumnName col = call $ GetColumnName col 357 | 358 | getColumnText : Column -> Eff String [SQLITE (SQLiteExecuting ValidRow)] 359 | getColumnText col = call $ GetColumnText col 360 | 361 | getColumnInt : Column -> Eff Int [SQLITE (SQLiteExecuting ValidRow)] 362 | getColumnInt col = call $ GetColumnInt col 363 | 364 | getColumnFloat : Column -> Eff Double [SQLITE (SQLiteExecuting ValidRow)] 365 | getColumnFloat col = call $ GetColumnFloat col 366 | 367 | isColumnNull : Column -> Eff Bool [SQLITE (SQLiteExecuting ValidRow)] 368 | isColumnNull col = call $ IsColumnNull col 369 | 370 | getColumnDataSize : Column -> Eff Int [SQLITE (SQLiteExecuting ValidRow)] 371 | getColumnDataSize col = call $ GetColumnDataSize col 372 | 373 | finalise : Eff () [SQLITE (SQLiteExecuting s)] [SQLITE SQLiteConnected] 374 | finalise = call Finalise 375 | 376 | cleanupPSFail : Eff () [SQLITE (SQLitePSFail)] [SQLITE ()] 377 | cleanupPSFail = call CleanupPSFail 378 | 379 | cleanupBindFail : Eff () [SQLITE (SQLiteFinishBindFail)] [SQLITE ()] 380 | cleanupBindFail = call CleanupBindFail 381 | 382 | -- Just makes it a tad nicer to write 383 | executeStatement : Eff StepResult [SQLITE (SQLitePSSuccess Bound)] 384 | (\result => [SQLITE (if hasMoreRows result 385 | then SQLiteExecuting ValidRow 386 | else SQLiteExecuting InvalidRow)]) 387 | executeStatement = call ExecuteStatement 388 | 389 | 390 | getQueryError : Either QueryError b -> QueryError 391 | getQueryError (Left qe) = qe 392 | getQueryError _ = InternalError 393 | 394 | total 395 | multiBind' : List (Int, DBVal) -> Eff () [SQLITE (SQLitePSSuccess Binding)] 396 | multiBind' [] = Effects.pure () 397 | multiBind' ((pos, (DBInt i)) :: xs) = do bindInt pos i 398 | multiBind' xs 399 | multiBind' ((pos, (DBFloat f)) :: xs) = do bindFloat pos f 400 | multiBind' xs 401 | multiBind' ((pos, (DBText t)) :: xs) = do bindText pos t 402 | multiBind' xs 403 | multiBind' ((pos, DBNull) :: xs) = do bindNull pos 404 | multiBind' xs 405 | -- Binds multiple values within a query 406 | 407 | multiBind : List (Int, DBVal) -> Eff (Maybe QueryError) 408 | [SQLITE (SQLitePSSuccess Binding)] 409 | (\result => [SQLITE (maybe (SQLitePSSuccess Bound) (const SQLiteFinishBindFail) result)]) 410 | 411 | multiBind vals = do 412 | multiBind' vals 413 | finishBind 414 | 415 | 416 | 417 | getRowCount' : StepResult -> Eff (Either QueryError Int) [SQLITE (SQLiteExecuting s)] [SQLITE ()] 418 | 419 | getRowCount' NoMoreRows = do finalise 420 | closeDB 421 | return $ Left (ExecError "Unable to get row count") 422 | getRowCount' StepFail = do finalise 423 | closeDB 424 | return $ Left (ExecError "Error whilst getting row count") 425 | getRowCount' {s=ValidRow} StepComplete = do last_insert_id <- getColumnInt 0 426 | finalise 427 | closeDB 428 | return $ Right last_insert_id 429 | getRowCount' {s=InvalidRow} StepComplete = do finalise 430 | closeDB 431 | return $ Left (ExecError "Invalid row") 432 | getRowCount' Unstarted = do finalise 433 | closeDB 434 | return $ Left (ExecError "Not started") 435 | 436 | getBindError : Maybe QueryError -> QueryError 437 | getBindError (Just (BindingError be)) = (BindingError be) 438 | getBindError _ = InternalError 439 | 440 | 441 | getRowCount : Eff (Either QueryError Int) [SQLITE SQLiteConnected] [SQLITE ()] 442 | getRowCount = do 443 | let insert_id_sql = "SELECT last_insert_rowid()" 444 | sql_prep_res <- prepareStatement insert_id_sql 445 | case sql_prep_res of 446 | Left err => do cleanupPSFail 447 | return (Left err) 448 | Right () => 449 | do bind_res_2 <- finishBind 450 | case bind_res_2 of 451 | Just err => do let be = getBindError bind_res_2 452 | cleanupBindFail 453 | return $ Left be 454 | Nothing => 455 | do exec_res <- executeStatement 456 | case exec_res of 457 | NoMoreRows => getRowCount' NoMoreRows 458 | StepComplete => getRowCount' StepComplete 459 | StepFail => getRowCount' StepFail 460 | Unstarted => getRowCount' Unstarted 461 | 462 | executeInsert : String -> 463 | String -> 464 | List (Int, DBVal) -> 465 | Eff (Either QueryError Int) [SQLITE ()] 466 | executeInsert db_name query bind_vals = 467 | do db_res <- openDB db_name 468 | case db_res of 469 | Left err => return (Left err) 470 | Right () => 471 | do ps_res <- prepareStatement query 472 | case ps_res of 473 | Left err => do cleanupPSFail 474 | return (Left err) 475 | Right () => 476 | do bind_res <- multiBind bind_vals 477 | case bind_res of 478 | Just err => do cleanupBindFail 479 | return (Left err) 480 | Nothing => executeIt 481 | -- split out to make typechecking faster 482 | where executeIt : Eff (Either QueryError Int) [SQLITE (SQLitePSSuccess Bound)] [SQLITE ()] 483 | 484 | executeIt = 485 | do er_1 <- executeStatement 486 | case er_1 of 487 | StepFail => do finalise {s=ValidRow} 488 | closeDB 489 | return $ Left (ExecError "Error inserting") 490 | Unstarted => do finalise {s=ValidRow} 491 | closeDB 492 | return $ Left (ExecError "Internal error: 'unstarted' after execution") 493 | NoMoreRows => do finalise {s=InvalidRow} 494 | getRowCount 495 | StepComplete => do finalise {s=ValidRow} 496 | getRowCount 497 | 498 | 499 | -- Helper functions for selection from a DB 500 | partial 501 | collectResults : (Eff (List DBVal) [SQLITE (SQLiteExecuting ValidRow)]) -> 502 | Eff ResultSet [SQLITE (SQLiteExecuting ValidRow)] [SQLITE (SQLiteExecuting InvalidRow)] 503 | collectResults fn = 504 | do results <- fn 505 | case !nextRow of 506 | Unstarted => return $ results :: !(collectResults fn) 507 | StepFail => return $ results :: !(collectResults fn) 508 | StepComplete => return $ results :: !(collectResults fn) 509 | NoMoreRows => return [results] 510 | 511 | 512 | -- Convenience function to abstract around some of the boilerplate code. 513 | -- Takes in the DB name, query, a list of (position, variable value) tuples, 514 | -- a function to process the returned data, 515 | partial 516 | executeSelect : (db_name : String) -> (q : String) -> List (Int, DBVal) -> 517 | (Eff (List DBVal) [SQLITE (SQLiteExecuting ValidRow)]) -> 518 | Eff (Either QueryError ResultSet) [SQLITE ()] 519 | executeSelect db_name q bind_vals fn = 520 | do Right () <- openDB db_name | Left err => return (Left err) 521 | Right () <- prepareStatement q | Left err => do cleanupPSFail 522 | return $ Left err 523 | Nothing <- multiBind bind_vals | Just err => do cleanupBindFail 524 | return $ Left err 525 | case !executeStatement of 526 | Unstarted => do res <- collectResults fn 527 | finalise 528 | closeDB 529 | return $ Right res 530 | StepFail => do res <- collectResults fn 531 | finalise 532 | closeDB 533 | return $ Right res 534 | StepComplete => do res <- collectResults fn 535 | finalise 536 | closeDB 537 | return $ Right res 538 | NoMoreRows => do finalise 539 | closeDB 540 | return $ Right [] 541 | 542 | --------------------------------------------------------------------------------