diff --git a/Database/QUDB.hs b/Database/QUDB.hs --- a/Database/QUDB.hs +++ b/Database/QUDB.hs @@ -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 diff --git a/Database/QUDB/EntityTypes.hs b/Database/QUDB/EntityTypes.hs --- a/Database/QUDB/EntityTypes.hs +++ b/Database/QUDB/EntityTypes.hs @@ -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) diff --git a/Database/QUDB/Parser.y b/Database/QUDB/Parser.y --- a/Database/QUDB/Parser.y +++ b/Database/QUDB/Parser.y @@ -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 } diff --git a/Database/QUDB/Structure.hs b/Database/QUDB/Structure.hs --- a/Database/QUDB/Structure.hs +++ b/Database/QUDB/Structure.hs @@ -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 diff --git a/Database/QUDB/Utils.hs b/Database/QUDB/Utils.hs new file mode 100644 --- /dev/null +++ b/Database/QUDB/Utils.hs @@ -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 diff --git a/README.mkd b/README.mkd --- a/README.mkd +++ b/README.mkd @@ -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. diff --git a/dist/build/qudb/qudb-tmp/Database/QUDB/Parser.hs b/dist/build/qudb/qudb-tmp/Database/QUDB/Parser.hs --- a/dist/build/qudb/qudb-tmp/Database/QUDB/Parser.hs +++ b/dist/build/qudb/qudb-tmp/Database/QUDB/Parser.hs @@ -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 "" #-} diff --git a/qudb.cabal b/qudb.cabal --- a/qudb.cabal +++ b/qudb.cabal @@ -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 diff --git a/qudb/qudb.hs b/qudb/qudb.hs --- a/qudb/qudb.hs +++ b/qudb/qudb.hs @@ -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 diff --git a/test/Test.lhs b/test/Test.lhs --- a/test/Test.lhs +++ b/test/Test.lhs @@ -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} diff --git a/test/Utils.hs b/test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Utils.hs @@ -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