qudb 0.0.0 → 0.0.1
raw patch · 11 files changed
+366/−214 lines, 11 filesdep +mtldep −deepseq
Dependencies added: mtl
Dependencies removed: deepseq
Files
- Database/QUDB.hs +6/−2
- Database/QUDB/EntityTypes.hs +0/−4
- Database/QUDB/Parser.y +34/−15
- Database/QUDB/Structure.hs +153/−146
- Database/QUDB/Utils.hs +76/−0
- README.mkd +7/−2
- dist/build/qudb/qudb-tmp/Database/QUDB/Parser.hs +38/−29
- qudb.cabal +4/−2
- qudb/qudb.hs +11/−6
- test/Test.lhs +16/−8
- test/Utils.hs +21/−0
Database/QUDB.hs view
@@ -5,5 +5,9 @@ import Database.QUDB.EntityTypes (Value(IntValue, StringValue)) import Database.QUDB.Parser (parse) -query :: S.DB -> String -> Maybe (S.DB, [[Value]])-query db str = S.query db $ parse str+query :: S.DB -> String -> Either String (S.DB, [[Value]])+query db str = case parse str of+ Left msg -> Left msg+ Right q -> case S.query db q of+ Left error -> Left $ show error+ Right results -> Right results
Database/QUDB/EntityTypes.hs view
@@ -3,8 +3,6 @@ Value(IntValue, StringValue), ) where -import Control.DeepSeq- -- |Types of values which can be stored in columns. data Type = Int | String deriving (Read, Show, Eq) @@ -12,5 +10,3 @@ data Value = IntValue Int | StringValue String deriving (Show, Read, Ord, Eq)--instance NFData (Value)
Database/QUDB/Parser.y view
@@ -1,6 +1,7 @@ { module Database.QUDB.Parser (parse) where import Database.QUDB.Scanner+import qualified Control.Monad.Error as E import qualified Database.QUDB.EntityTypes as T import qualified Database.QUDB.Query as Q }@@ -8,6 +9,7 @@ %name parseTokens %tokentype { Token } %error { parseError }+%monad { ParserMonad } %token str { Str $$ }@@ -43,12 +45,12 @@ Query : QueryWithoutSemicolon ';' { $1 } -QueryWithoutSemicolon : SelectQuery { $1 }- | InsertQuery { $1 }- | DeleteQuery { $1 }- | UpdateQuery { $1 }+QueryWithoutSemicolon : SelectQuery { return $1 }+ | InsertQuery { return $1 }+ | DeleteQuery { return $1 }+ | UpdateQuery { return $1 } | CreateTableQuery { $1 }- | DropTableQuery { $1 }+ | DropTableQuery { return $1 } SelectQuery : select '*' from Table Clauses { Q.SelectAll $4 : $5 } | select Columns from Table Clauses { Q.Select $4 $2 : $5 }@@ -59,7 +61,7 @@ UpdateQuery : update Table set UpdatedValues OptWhereClause { Q.Update $2 $4 : $5 } -CreateTableQuery : create table Table '(' ColumnsDefs ')' { [Q.CreateTable $3 $5] }+CreateTableQuery : create table Table '(' ColumnsDefs ')' { $5 >>= \x -> return [Q.CreateTable $3 x] } DropTableQuery : drop table Table { [Q.DropTable $3] } @@ -87,15 +89,18 @@ ColumnName : symb { $1 } -ColumnsDefs : ColumnDef OtherColumnsDefs { $1 : $2 }+ColumnsDefs : ColumnDef OtherColumnsDefs { do x <- $1; y <- $2;+ return (x:y) } -OtherColumnsDefs : ',' ColumnDef OtherColumnsDefs { $2 : $3 }- | {- empty -} { [] } +OtherColumnsDefs : ',' ColumnDef OtherColumnsDefs { do x <- $2; y <- $3;+ return (x:y) }+ | {- empty -} { return [] }+ ColumnDef : symb symb { case $2 of- "int" -> ($1, T.Int)- "string" -> ($1, T.String)- otherwise -> error $ "No such type: " ++ $2 }+ "int" -> return ($1, T.Int)+ "string" -> return ($1, T.String)+ otherwise -> E.throwError $ NoSuchType $2 } Clauses : Clause Clauses { $1 : $2 } | {- empty -} { [] }@@ -137,8 +142,22 @@ | ColumnName '>' Value { Q.Condition $1 (> $3) } {-parseError :: [Token] -> a-parseError (t:_) = error ("Parse error at " ++ show t)+type ParserMonad = Either ParsingError+data ParsingError = ParsingFailedAtToken Token+ | NoSuchType String -parse = parseTokens . scan+instance E.Error ParsingError++instance Show ParsingError where+ show (ParsingFailedAtToken t) = "Parsing failed at " ++ show t+ show (NoSuchType t) = "No such type: " ++ t++parseError :: [Token] -> ParserMonad a+parseError (t:_) = E.throwError $ ParsingFailedAtToken t++parse :: String -> Either String [Q.Query]+parse input = case parseTokens $ scan input of+ Left err -> Left $ show err+ Right (Left err) -> Left $ show err+ Right (Right queries) -> Right queries }
Database/QUDB/Structure.hs view
@@ -2,18 +2,16 @@ import Database.QUDB.EntityTypes import Database.QUDB.Query-import Data.List (elemIndex, sortBy)-import qualified Data.ByteString.Char8 as C (ByteString, pack, unpack, writeFile,- readFile)+import Database.QUDB.Utils (sortByM)+import Data.List (elemIndex)+import Data.Foldable (foldlM, foldrM)+import qualified Data.ByteString.Char8 as C (ByteString, pack, unpack)+import qualified Control.Monad.Error as E (Error, throwError) import Codec.Compression.Snappy (compress, decompress)-import Control.DeepSeq -- |A database has some metadata and tables. data DB = DB Meta [Table] deriving (Show, Read, Eq) -instance NFData (DB) where- rnf (DB _ tables) = map rnf tables `deepseq` ()- -- |Database's metadata consists of the format's version identifier. data Meta = Meta Version deriving (Show, Read, Eq) @@ -23,141 +21,168 @@ -- |A table has a name, a list of columns' types and rows. data Table = Table String [Column] [Row] deriving (Read, Show, Eq) -instance NFData (Table) where- rnf (Table _ cols rows) = map rnf cols `deepseq` map rnf rows `deepseq` ()- -- |A table's column which has a name and a type. data Column = Column String Type deriving (Read, Show, Eq) -instance NFData (Column) where- rnf (Column n t) = n `seq` t `seq` ()- -- |Row consists of a list of values. data Row = Row [Value] deriving (Read, Show, Eq) -instance NFData (Row) where- rnf (Row values) = map rnf values `deepseq` ()+-- |A monad in which queries are executed.+type DBMonad = Either Error +data Error = NoSuchColumn String+ | NoSuchTable String+ | TableMustHaveColumns+ | NoTableNameGiven+ | TableExists String+ | TypeMismatch+ deriving Show++instance E.Error Error+ -- |query is function responsible for executing Query tokens.-query :: DB -> [Query] -> Maybe (DB, [[Value]])-query db (CreateTable name rows : _) = Just $!! (createTable db name rows, [])-query db (DropTable name : _) = fmap (const (db, [])) $ dropTable db name+query :: DB -> [Query] -> DBMonad (DB, [[Value]]) +query db@(DB meta tables) (CreateTable name rows : _) =+ createTable name rows >>= \x -> return (x, [])+ where createTable _ [] = E.throwError TableMustHaveColumns+ createTable "" _ = E.throwError NoTableNameGiven+ createTable _ _ =+ case findTable db name of+ Right _ -> E.throwError $ TableExists name+ Left _ -> return (DB meta newTables)+ newTables = addedTable : tables+ addedTable = Table name (map (uncurry Column) rows) []++query db (DropTable name : _) = dropTable name >> return (db, [])+ where+ DB meta tables = db+ dropTable "" = E.throwError NoTableNameGiven+ dropTable name = findTable db name >> return (DB meta (drop tables))+ drop = filter (\(Table thisName _ _) -> name /= thisName)+ query db@(DB _ tables) (SelectAll tableName : stmts) = query db (Select tableName colNames : stmts) where (Table _ cols _) = head $ filter (\(Table n _ _) -> n == tableName) tables colNames = map (\(Column n _) -> n) cols query db@(DB _ tables) (Select tableName selectedColumns : stmts) =- Just (db, selRows)- where selRows = map (\(Row values) -> values) newQRows- newQRows = map colSelect rows- colSelect (Row values) = Row $ map (values !!) colIds- maybeColIds = map (`elemIndex` colNames) selectedColumns- colNames = map (\(Column cName _)-> cName) columns- colIds = map (\(Just int)->int) maybeColIds- (Table _ columns rows) = fst $ foldl constrain (table, emptyTable) stmts- emptyTable = Table "" [] []+ do (Table _ columns rows, _) <- constrain table stmts+ values <- mapM (colSelect columns) rows+ return (db, values)+ where colSelect cols (Row values) = do ids <- columnIDs cols+ return $ map (values !!) ids+ columnIDs cols = mapM (colIDByName cols) selectedColumns+ colIDByName :: [Column] -> String -> DBMonad Int+ colIDByName cols name = case name `elemIndex` colNames cols of+ Nothing -> E.throwError $ NoSuchColumn name+ Just id -> return id+ colNames = map $ \(Column name _) -> name table = head $ filter (\(Table n _ _) -> n == tableName) tables -query db (Insert name values : stmts) =- insertRow db name values >>= \db' -> Just $!! (db', [])+query db (Insert name values : _) = do db' <- insertRow db name values+ return (db', []) -query db@(DB _ tables) (Delete tableName : stmts) = Just (modifiedDB, [])- where Just modifiedDB = modifyTable db tableName deleteRows- deleteRows _ = Table tableName cols rej+query db@(DB _ tables) (Delete tableName : stmts) =+ do (Table _ cols _, Table _ _ rej) <- constrain table stmts+ db' <- modifyTable db tableName (deleteRows cols rej)+ return (db', [])+ where deleteRows cols rej _ = return $ Table tableName cols rej table = head $ filter (\(Table n _ _) -> n == tableName) tables- emptyTable = Table "" [] []- (Table _ cols _, (Table _ _ rej)) = foldl constrain (table, emptyTable) stmts+ -- |Update query set new values in selected columns of the qRows list. -- |After update concatenation of qRows and notQRows is placed as new -- |table rows set.-query db@(DB _ tables) (Update name newValues : stmts) = Just (modifiedDB, [])- where- (Table _ columns rows) = fst $ foldl constrain (table, emptyTable) stmts- emptyTable = Table "" [] []- table = head $ filter (\(Table n _ _) -> n == name) tables- (Table _ cols acc, (Table _ _ rej)) = foldl constrain (table, emptyTable) stmts- Just modifiedDB = modifyTable db name (modValues columns newValues acc rej)- modValues ::- [Column] -> [(String, Value)] -> [Row] -> [Row] -> Table -> Table- modValues columns newValues acc rej table = newTable table- newTable (Table name cols _) = Table name cols newRows- newRows = updatedRows ++ rej- updatedRows = map rowUpdate acc- indexValues = map extract newValues- columnNames = map (\(Column name _)->name) columns- extract (string, value) = case (elemIndex string columnNames) of- Nothing -> error $ "No such column: " ++ string- Just int -> (int, value)- rowUpdate (Row values) = Row $ correct values indexValues- correct :: [Value] -> [(Int, Value)] -> [Value]- correct values [] = values- correct values ((index, value):indexValues) = correct- (checkAndCorrectRow values index value (columns !! index))- indexValues- checkAndCorrectRow :: [Value] -> Int -> Value -> Column -> [Value]- checkAndCorrectRow values index- (StringValue str) (Column _ String) =- correctRow values index (StringValue str)+query db@(DB _ tables) (Update name newValues : stmts) =+ do (Table _ cols acc, Table _ _ rej) <- constrain table stmts+ db' <- modifyTable db name $ newTable cols acc rej+ return (db', [])+ where table = head $ filter (\(Table n _ _) -> n == name) tables+ newTable cols acc rej _ = do newRows <- fmap (++rej) (updatedRows acc cols)+ return $ Table name cols newRows+ updatedRows acc cols = mapM (rowUpdate cols) acc+ indexedValues cols = mapM (colNamesToIndices cols) newValues+ columnNames = map (\(Column name _) -> name)+ colNamesToIndices :: [Column] -> (String, Value) -> DBMonad (Int, Value)+ colNamesToIndices cols (name, value) =+ case elemIndex name (columnNames cols) of+ Nothing -> E.throwError $ NoSuchColumn name+ Just index -> return (index, value)+ rowUpdate cols (Row values) = do ivs <- indexedValues cols+ updated <- correct cols values ivs+ return $ Row updated+ correct :: [Column] -> [Value] -> [(Int, Value)] -> DBMonad [Value]+ correct cols values [] = return values+ correct cols values ((index, val):rest) =+ do updated <- checkAndCorrectRow values index val (cols !! index)+ correct cols updated rest+ checkAndCorrectRow :: [Value] -> Int -> Value -> Column -> DBMonad [Value]+ checkAndCorrectRow values index (StringValue str) (Column _ String) =+ return $ correctRow values index (StringValue str) checkAndCorrectRow values index (IntValue int) (Column _ Int) =- correctRow values index (IntValue int)- checkAndCorrectRow _ _ _ _ = error "Incorrect types!"+ return $ correctRow values index (IntValue int)+ checkAndCorrectRow _ _ _ _ = E.throwError TypeMismatch correctRow values index value = ((take index values) ++ [value] ++ (snd $ splitAt (index + 1) values)) -constrain :: (Table, Table) -> Query -> (Table, Table)-constrain ((Table name cols qRows), (Table _ _ notQRows)) (Where conds) =- ((Table name cols acc), (Table name cols rej))- where- (acc, rej) =- foldr rowWalker ([], notQRows) qRows where- rowWalker (row@(Row values)) (qRows, notQRows) =- if whereWalker conds values- then (row:qRows, notQRows)- else (qRows, row:notQRows)- whereWalker :: WhereConditions -> [Value] -> Bool- whereWalker (OrConditions conditions) values =- or (map (`whereWalker` values) conditions)- whereWalker (AndConditions conditions) values =- and (map (`whereWalker` values) conditions)- whereWalker (Condition colName comparer) values =- comparer $ getCell colName values- getCell colName values = values !! getColId colName- getColId colName =- case elemIndex colName (map (\(Column name _)->name) cols) of- Nothing -> error $ "No such column: " ++ colName- Just int -> int+constrain :: Table -> [Query] -> DBMonad (Table, Table)+constrain table stmts = foldlM constrainStep (table, emptyTable) stmts+ where emptyTable = Table "" [] [] +constrainStep :: (Table, Table) -> Query -> DBMonad (Table, Table)++constrainStep ((Table name cols qRows), (Table _ _ notQRows)) (Where conds) =+ do (acc, rej) <- foldrM rowWalker ([], notQRows) qRows+ return (Table name cols acc, Table name cols rej)+ where rowWalker :: Row -> ([Row], [Row]) -> DBMonad ([Row], [Row])+ rowWalker (row@(Row values)) (accepted, rejected) =+ do matches <- whereWalker conds values+ return $ if matches+ then (row:accepted, rejected)+ else (accepted, row:rejected)+ whereWalker :: WhereConditions -> [Value] -> DBMonad Bool+ whereWalker (OrConditions conditions) values =+ fmap or (mapM (`whereWalker` values) conditions)+ whereWalker (AndConditions conditions) values =+ fmap and (mapM (`whereWalker` values) conditions)+ whereWalker (Condition colName comparer) values =+ do cell <- getCell colName values+ return $ comparer cell+ getCell name values = fmap (values !!) $ getColId name+ getColId name = case name `elemIndex` (columnNames cols) of+ Nothing -> E.throwError $ NoSuchColumn name+ Just int -> return int+ columnNames = map (\(Column name _)->name)+ -- |OrderBy query sorts a qRows list, comparing values from -- |provided columns with selected order. The list of columns used to sort -- |a qRows list is reversed. Each column and its order is used in comparing--- |function used in stable sorting algorithm provided by 'sortBy'.-constrain (Table name cols qRows, rej) (OrderBy orderBy) =- (Table name cols sortedQRows, rej)- where sortedQRows = colSort qRows $ reverse orderBy- colSort qrows [] = qrows- colSort rows ((cName, ord):orderBy) =- colSort (sortBy (cmp cName ord) rows) orderBy+-- |function used in stable sorting algorithm provided by 'sortByM'.+constrainStep (Table name cols qRows, rej) (OrderBy orderBy) =+ do sortedRows <- colSort qRows $ reverse orderBy+ return (Table name cols sortedRows, rej)+ where colSort rows [] = return rows+ colSort rows ((colName, ord):orderBy) =+ do sorted <- sortByM (cmp colName ord) rows+ colSort sorted orderBy cmp colName Ascending (Row valuesTwo) (Row valuesOne) =- orderingValue (valuesTwo !! colIndex colName)- (valuesOne !! colIndex colName)- cmp colName Descending (Row valuesTwo) (Row valuesOne) =- orderingValue (valuesOne !! colIndex colName)- (valuesTwo !! colIndex colName)+ do index <- colIndex colName+ return $ orderingValue (valuesTwo !! index) (valuesOne !! index)+ cmp colName Descending x y = cmp colName Ascending y x orderingValue :: Value -> Value -> Ordering orderingValue valOne valTwo | valOne == valTwo = EQ | valOne > valTwo = GT | valOne < valTwo = LT- colIndex name = case elemIndex name columnNames of- Nothing -> error $ "No such column: " ++ name- Just int -> int+ colIndex :: String -> DBMonad Int+ colIndex name = case name `elemIndex` columnNames of+ Nothing -> E.throwError $ NoSuchColumn name+ Just int -> return int columnNames = map (\(Column name _)->name) cols -constrain ((Table name cols acc), (Table _ _ rej)) (Limit num) =- ((Table name cols acc'), (Table name cols (rej' ++ rej)))+constrainStep ((Table name cols acc), (Table _ _ rej)) (Limit num) =+ return ((Table name cols acc'), (Table name cols (rej' ++ rej))) where (acc', rej') = splitAt num acc -- |The current DB format's version identifier.@@ -172,40 +197,19 @@ load :: C.ByteString -> DB load = read . C.unpack . decompress --- |Adds a table to a given database.-createTable :: DB- -> String -- The name of the added table- -> [(String, Type)] -- Names and types of values stored in the table- -> DB-createTable _ _ [] = error "Tables without columns are illegal."-createTable _ "" _ = error "Table's name is mandatory."-createTable db@(DB meta tables) name cols =- case findTable db name of- Just _ -> error $ "Table: '" ++ name ++ "' already exists."- Nothing -> DB meta newTables- where newTables = addedTable : tables- addedTable = Table name (map (uncurry Column) cols) []---- |Drops a table from a given database.-dropTable :: DB- -> String -- The name of the dropped table- -> Maybe DB-dropTable _ "" = error "Table's name is mandatory."-dropTable db@(DB meta tables) name =- findTable db name >> Just (DB meta (drop tables))- where drop = filter (\(Table thisName _ _) -> name /= thisName)- -- |Used to apply a given function to the table with a given name. modifyTable :: DB- -> String -- The name of a table to modify- -> (Table -> Table) -- The modifying function- -> Maybe DB+ -> String -- The name of a table to modify+ -> (Table -> DBMonad Table) -- The modifying function+ -> DBMonad DB modifyTable db@(DB meta tables) name fun =- findTable db name >> Just (DB meta (modTable tables))- where modTable [] = []+ findTable db name >> modTable tables >>= \tables' -> return (DB meta tables')+ where modTable :: [Table] -> DBMonad [Table]+ modTable [] = return [] modTable (t@(Table thisName _ _):ts)- | thisName == name = fun t : ts- | otherwise = t : modTable ts+ | thisName == name = do t' <- fun t+ return $ t' : ts+ | otherwise = fmap (t:) $ modTable ts -- |Dumps the database to a bytestring, which can be later loaded using the -- load function.@@ -213,25 +217,28 @@ dump = compress . C.pack . show ---- |Inserts a new row to a given table. It should check all types and constraints.-insertRow :: DB -> String -> [Value] -> Maybe DB+insertRow :: DB -> String -> [Value] -> DBMonad DB insertRow db name values = modifyTable db name addRow- where addRow :: Table -> Table- addRow (Table _ columns rows) = Table name columns (rows ++ [newRow])- where newRow = Row $ buildNewRow (types columns) values+ where addRow :: Table -> DBMonad Table+ addRow (Table _ columns rows) = do new <- newRow+ return $ Table name columns (rows ++ [new])+ where newRow = fmap (Row) $ buildNewRow (types columns) values types = map (\(Column _ t) -> t)- buildNewRow [] [] = []+ buildNewRow [] [] = return [] buildNewRow (String:restTs) (val@(StringValue _):restVs) =- val:buildNewRow restTs restVs+ do rest <- buildNewRow restTs restVs+ return $ val:rest buildNewRow (Int:restTs) (val@(IntValue _):restVs) =- val:buildNewRow restTs restVs- buildNewRow _ _ = error "Incorrect types!"+ do rest <- buildNewRow restTs restVs+ return $ val:rest+ buildNewRow _ _ = E.throwError TypeMismatch --- |Returns a table with a given name. Returns Nothing if there's no table with+-- |Returns a table with a given name. Throws an error if there's no table with -- such name.-findTable :: DB -> String -> Maybe Table+findTable :: DB -> String -> DBMonad Table findTable (DB _ tables) name = findByName tables- where findByName :: [Table] -> Maybe Table- findByName [] = Nothing+ where findByName :: [Table] -> DBMonad Table+ findByName [] = E.throwError $ NoSuchTable name findByName (table@(Table thisName _ _):ts)- | thisName == name = Just table+ | thisName == name = return table | otherwise = findByName ts
+ Database/QUDB/Utils.hs view
@@ -0,0 +1,76 @@+module Database.QUDB.Utils where++{-+The following function is based on GHC's Data.List.sortBy distributed under a+following BSD-style license.++ Copyright 2002, The University Court of the University of Glasgow.+ All rights reserved.++ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions are met:++ - Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++ - Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++ - Neither name of the University nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+ DAMAGE.+-}++sortByM :: (Monad m) => (a -> a -> m Ordering) -> [a] -> m [a]+sortByM cmp input = sequences input >>= mergeAll+ where+ sequences (a:b:xs) =+ do rel <- a `cmp` b+ case rel of+ GT -> descending b [a] xs+ _ -> ascending b (a:) xs+ sequences xs = return [xs]++ descending a as bs@(b:bs') =+ do rel <- a `cmp` b+ case rel of+ GT -> descending b (a:as) bs'+ _ -> sequences bs >>= return . ((a:as):)+ descending a as bs = sequences bs >>= return . ((a:as):)++ ascending a as bs@(b:bs') =+ do rel <- a `cmp` b+ case rel of+ GT -> sequences bs >>= return . (as [a]:)+ _ -> ascending b (\ys -> as (a:ys)) bs'+ ascending a as bs = sequences bs >>= return . (as [a]:)++ mergeAll [x] = return x+ mergeAll xs = mergePairs xs >>= mergeAll++ mergePairs (a:b:xs) = do first <- merge a b+ rest <- mergePairs xs+ return $ first : rest+ mergePairs xs = return xs++ merge as@(a:as') bs@(b:bs') =+ do rel <- a `cmp` b+ case rel of+ GT -> merge as bs' >>= return . (b:)+ _ -> merge as' bs >>= return . (a:)+ merge [] bs = return bs+ merge as [] = return as
README.mkd view
@@ -1,6 +1,11 @@ qudb ==== -qudb is a Quite Useless DB. You really shouldn't use it.+qudb is a Quite Useless DB. You really shouldn't use it yet. Learn a bit more on+[Hackage](http://hackage.haskell.org/package/qudb).+You can also take a look at the occasionally refreshed+[documentation of qudb's internals](http://jstepien.github.com/qudb/). -Run test using `test/Test.lhs`.+Run tests using `test/Test.lhs`.++As this is my first project in Haskell I'd be really grateful for any comments.
dist/build/qudb/qudb-tmp/Database/QUDB/Parser.hs view
@@ -2,6 +2,7 @@ {-# OPTIONS -fglasgow-exts -cpp #-} module Database.QUDB.Parser (parse) where import Database.QUDB.Scanner+import qualified Control.Monad.Error as E import qualified Database.QUDB.EntityTypes as T import qualified Database.QUDB.Query as Q import qualified Data.Array as Happy_Data_Array@@ -318,28 +319,28 @@ happyReduction_2 happy_x_1 = case happyOut6 happy_x_1 of { happy_var_1 -> happyIn5- (happy_var_1+ (return happy_var_1 )} happyReduce_3 = happySpecReduce_1 1# happyReduction_3 happyReduction_3 happy_x_1 = case happyOut7 happy_x_1 of { happy_var_1 -> happyIn5- (happy_var_1+ (return happy_var_1 )} happyReduce_4 = happySpecReduce_1 1# happyReduction_4 happyReduction_4 happy_x_1 = case happyOut8 happy_x_1 of { happy_var_1 -> happyIn5- (happy_var_1+ (return happy_var_1 )} happyReduce_5 = happySpecReduce_1 1# happyReduction_5 happyReduction_5 happy_x_1 = case happyOut9 happy_x_1 of { happy_var_1 -> happyIn5- (happy_var_1+ (return happy_var_1 )} happyReduce_6 = happySpecReduce_1 1# happyReduction_6@@ -353,7 +354,7 @@ happyReduction_7 happy_x_1 = case happyOut11 happy_x_1 of { happy_var_1 -> happyIn5- (happy_var_1+ (return happy_var_1 )} happyReduce_8 = happyReduce 5# 2# happyReduction_8@@ -435,7 +436,7 @@ = case happyOut18 happy_x_3 of { happy_var_3 -> case happyOut22 happy_x_5 of { happy_var_5 -> happyIn10- ([Q.CreateTable happy_var_3 happy_var_5]+ (happy_var_5 >>= \x -> return [Q.CreateTable happy_var_3 x] ) `HappyStk` happyRest}} happyReduce_14 = happySpecReduce_3 7# happyReduction_14@@ -563,7 +564,8 @@ = case happyOut24 happy_x_1 of { happy_var_1 -> case happyOut23 happy_x_2 of { happy_var_2 -> happyIn22- (happy_var_1 : happy_var_2+ (do x <- happy_var_1; y <- happy_var_2;+ return (x:y) )}} happyReduce_30 = happySpecReduce_3 19# happyReduction_30@@ -573,12 +575,13 @@ = case happyOut24 happy_x_2 of { happy_var_2 -> case happyOut23 happy_x_3 of { happy_var_3 -> happyIn23- (happy_var_2 : happy_var_3+ (do x <- happy_var_2; y <- happy_var_3;+ return (x:y) )}} happyReduce_31 = happySpecReduce_0 19# happyReduction_31 happyReduction_31 = happyIn23- ([]+ (return [] ) happyReduce_32 = happySpecReduce_2 20# happyReduction_32@@ -588,9 +591,9 @@ case happyOutTok happy_x_2 of { (Symb happy_var_2) -> happyIn24 (case happy_var_2 of- "int" -> (happy_var_1, T.Int)- "string" -> (happy_var_1, T.String)- otherwise -> error $ "No such type: " ++ happy_var_2+ "int" -> return (happy_var_1, T.Int)+ "string" -> return (happy_var_1, T.String)+ otherwise -> E.throwError $ NoSuchType happy_var_2 )}} happyReduce_33 = happySpecReduce_2 21# happyReduction_33@@ -842,34 +845,40 @@ happyError_ tk tks = happyError' (tk:tks) -newtype HappyIdentity a = HappyIdentity a-happyIdentity = HappyIdentity-happyRunIdentity (HappyIdentity a) = a--instance Monad HappyIdentity where- return = HappyIdentity- (HappyIdentity p) >>= q = q p--happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b+happyThen :: () => ParserMonad a -> (a -> ParserMonad b) -> ParserMonad b happyThen = (>>=)-happyReturn :: () => a -> HappyIdentity a+happyReturn :: () => a -> ParserMonad a happyReturn = (return) happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> HappyIdentity a+happyReturn1 :: () => a -> b -> ParserMonad a happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> HappyIdentity a-happyError' = HappyIdentity . parseError+happyError' :: () => [(Token)] -> ParserMonad a+happyError' = parseError -parseTokens tks = happyRunIdentity happySomeParser where+parseTokens tks = happySomeParser where happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) happySeq = happyDontSeq -parseError :: [Token] -> a-parseError (t:_) = error ("Parse error at " ++ show t)+type ParserMonad = Either ParsingError+data ParsingError = ParsingFailedAtToken Token+ | NoSuchType String -parse = parseTokens . scan+instance E.Error ParsingError++instance Show ParsingError where+ show (ParsingFailedAtToken t) = "Parsing failed at " ++ show t+ show (NoSuchType t) = "No such type: " ++ t++parseError :: [Token] -> ParserMonad a+parseError (t:_) = E.throwError $ ParsingFailedAtToken t++parse :: String -> Either String [Q.Query]+parse input = case parseTokens $ scan input of+ Left err -> Left $ show err+ Right (Left err) -> Left $ show err+ Right (Right queries) -> Right queries {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}
qudb.cabal view
@@ -1,5 +1,5 @@ Name: qudb-Version: 0.0.0+Version: 0.0.1 Synopsis: Quite Useless DB Description: QUDB is a simple relational database meant to be a Haskell equivalent of@@ -17,16 +17,18 @@ README.mkd test/*.sql test/Test.lhs+ test/Utils.hs Cabal-version: >= 1.8 Executable qudb Main-is: qudb/qudb.hs- Build-depends: base >= 3 && < 5, array, bytestring, snappy, deepseq, directory+ Build-depends: base >= 3 && < 5, array, bytestring, snappy, directory, mtl Other-modules: Database.QUDB, Database.QUDB.Scanner, Database.QUDB.Parser, Database.QUDB.Structure, Database.QUDB.Query,+ Database.QUDB.Utils, Database.QUDB.EntityTypes Build-tools: happy, alex >= 3
qudb/qudb.hs view
@@ -2,12 +2,12 @@ import System.Environment import System.Directory import System.IO-import System.IO.Error import Data.Maybe (isJust) import Control.Monad (when) import qualified Control.Exception as E import qualified Data.ByteString.Char8 as C (hGetContents, writeFile) +main :: IO () main = do args <- getArgs if length args > 1@@ -22,10 +22,12 @@ when (isJust filename && db /= db') $ let (Just name) = filename in C.writeFile name $ QUDB.dump db' +usage :: IO () usage = do name <- getProgName putStrLn $ "Usage: " ++ name ++ " [filename]" +prepareDB :: Maybe FilePath -> IO QUDB.DB prepareDB Nothing = return QUDB.new prepareDB (Just file) = do gotFile <- doesFileExist file@@ -37,6 +39,7 @@ return $ QUDB.load dump else return QUDB.new +repl :: QUDB.DB -> IO QUDB.DB repl db = do putStr "> " hFlush stdout@@ -48,13 +51,14 @@ db' <- if null line then return db else (case QUDB.query db line of- Just (db', res) -> printResults res >> return db'- Nothing -> return db+ Right (db', res) -> printResults res >> return db'+ Left msg -> putStrLn msg >> return db ) `E.catch` handler db repl db' where handler :: QUDB.DB -> E.SomeException -> IO QUDB.DB handler db e = print e >> return db +noninteractive :: QUDB.DB -> IO QUDB.DB noninteractive db = do eof <- isEOF if eof@@ -64,11 +68,12 @@ db' <- if null line then return db else case QUDB.query db line of- Just (db', res) -> printResults res >> return db'- Nothing -> return db+ Right (db', res) -> printResults res >> return db'+ Left msg -> putStrLn msg >> return db noninteractive db' -printResults xs = mapM_ putStrLn . map columnify $ xs+printResults :: [[QUDB.Value]] -> IO ()+printResults = mapM_ (putStrLn . columnify) where columnify [] = "" columnify [x] = showValue x columnify (x:xs) = showValue x ++ "|" ++ columnify xs
test/Test.lhs view
@@ -14,19 +14,20 @@ main = do dir <- getCurrentDirectory inPlace <- doesFileExist $ dir ++ "/Test.lhs" if inPlace- then runTests >>= printResults+ then runSQLTests >>= printResults >> runQCTests else do setCurrentDirectory $ dir ++ "/test" main -testFiles :: IO [FilePath]-testFiles = fmap (filter (".sql" `isSuffixOf`)) allFiles- where allFiles = getCurrentDirectory >>= getDirectoryContents+filesEndingWith :: String -> IO [FilePath]+filesEndingWith suffix = fmap (filter (suffix `isSuffixOf`)) allFiles -runTests = do files <- testFiles- results <- mapM runTest files- putStrLn ""- return $ zip files results+allFiles = getCurrentDirectory >>= getDirectoryContents +runSQLTests = do files <- filesEndingWith ".sql"+ results <- mapM runTest files+ putStrLn ""+ return $ zip files results+ runTest fn = run `E.catch` handle where run = do code <- readFile fn expectation <- sqlite3 code@@ -68,5 +69,12 @@ printDetails (test, (Failure err)) = putStrLn $ "\n" ++ indent (test : lines err) ++ "\n" indent lines = " " ++ intercalate "\n " lines++runQCTests = do files <- filesEndingWith ".hs"+ setCurrentDirectory ".."+ mapM_ run files+ setCurrentDirectory "test"+ where run file = do output <- readProcess "runhaskell" ["test/" ++ file] ""+ putStr output \end{code}
+ test/Utils.hs view
@@ -0,0 +1,21 @@+module Main where++import Database.QUDB.Utils+import Test.QuickCheck+import Data.List (sort)++main = test_sortByM++test_sortByM = do c integers+ c reversed+ c nothing+ where c :: (Testable t) => t -> IO ()+ c = quickCheck+ integers xs = sortByM cmp xs == Just (sort xs)+ where types = xs :: [Int]+ reversed xs = sortByM (flip $ cmp) xs == Just (reverse $ sort xs)+ where types = xs :: [Int]+ nothing xs = (not . null . drop 2) xs ==>+ sortByM (const $ const Nothing) xs == Nothing+ where types = xs :: [Int]+ cmp x y = Just $ compare x y