haskelldb-flat (empty) → 0.10
raw patch · 4 files changed
+434/−0 lines, 4 filesdep +basedep +haskell98dep +haskelldbbuild-type:Customsetup-changed
Dependencies added: base, haskell98, haskelldb, mtl
Files
- Database/HaskellDB/FlatDB.hs +397/−0
- Setup.hs +4/−0
- haskelldb-flat.cabal +23/−0
- tools/flatdb-create.hs +10/−0
+ Database/HaskellDB/FlatDB.hs view
@@ -0,0 +1,397 @@+-----------------------------------------------------------+-- |+-- Module : Database.HaskellDB.FlatDB+-- Copyright : Bjorn Bringert 2006+-- License : BSD-style+-- +-- Maintainer : haskelldb-users@lists.sourceforge.net+-- Stability : experimental+-- Portability : non-portable+--+-- This is a very experimental HaskellDB back-end which is written in pure Haskell+-- and doesn't use SQL. It stores the database in a file. Using this with+-- concurrent writes leads to data loss. This back-end does not support transactions.+-----------------------------------------------------------+module Database.HaskellDB.FlatDB (DriverInterface(..), driver, + withFlatDB, newDB) where++import Database.HaskellDB.Database+import Database.HaskellDB.HDBRec+import Database.HaskellDB.FieldType+import Database.HaskellDB.PrimQuery+import Database.HaskellDB.Query hiding (isNull, union, intersect)+import Database.HaskellDB.DriverAPI++import Control.Monad+import Control.Monad.Trans+import Data.Bits+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid (mconcat)+import Data.List+import Data.Maybe+import Prelude hiding (toInteger)+import System.Time+import System.Directory+import System.IO++import Debug.Trace++type FlatDB = Map TableName FlatTable+type RelSchema = [(Attribute,FieldDesc)]+type FlatTable = FlatRel++data FlatRel = FlatRel { relSchema :: RelSchema,+ relRows :: [FlatRow] }+ deriving (Show,Read)++type FlatRow = [(String,Value)]++data Value = VString String+ | VInteger Integer+ | VDouble Double+ | VBool Bool+ | VDate CalendarTime+ | VNull+ deriving (Show,Read,Eq,Ord) -- FIXME: ord and eq are too liberal here?+++-- | This driver requires the following options: +-- "filepath"+driver :: DriverInterface+driver = defaultdriver {connect = flatDBConnectOpts}+++flatDBConnectOpts :: MonadIO m => [(String,String)] -> (Database -> m a) -> m a+flatDBConnectOpts opts f = do [a] <- getOptions ["filepath"] opts+ withFlatDB a f++withFlatDB :: MonadIO m => FilePath -> (Database -> m a) -> m a+withFlatDB f m = + do e <- liftIO $ doesFileExist f+ when (not e) $ liftIO $ newDB f+ db <- liftIO $ readDB f+ dbr <- liftIO $ newIORef db+ x <- m (flatDatabase dbr)+ db' <- liftIO $ readIORef dbr+ (tmpFile,tmpH) <- liftIO $ openTempFile "." (f++".tmp")+ liftIO $ hWriteDB tmpH db'+ liftIO $ hClose tmpH+ liftIO $ renameFile tmpFile f+ return x++emptyDB :: FlatDB+emptyDB = Map.empty++modifyDB :: IORef FlatDB -> (FlatDB -> FlatDB) -> IO ()+modifyDB db f = modifyIORef db f++queryDB :: IORef FlatDB -> (FlatDB -> a) -> IO a+queryDB db f = liftM f $ readIORef db++flatDatabase :: IORef FlatDB -> Database+flatDatabase db = + Database { dbQuery = \x y -> readIORef db >>= \d -> flatQueryHDB x y d,+ dbInsert = \x y -> modifyDB db $ flatInsert x y,+ dbInsertQuery = \x y -> modifyDB db $ flatInsertQuery x y,+ dbDelete = \x y -> modifyDB db $ flatDelete x y,+ dbUpdate = \x y z -> modifyDB db $ flatUpdate x y z,+ dbTables = queryDB db $ flatTables,+ dbDescribe = \x -> queryDB db $ flatDescribe x,+ dbTransaction = notImplemented "dbTransaction",+ dbCreateDB = \x -> return (),+ dbCreateTable = \x y -> modifyDB db $ flatCreateTable x y,+ dbDropDB = notImplemented "dbDropDB",+ dbDropTable = \x -> modifyDB db $ flatDropTable x+ }+++readDB :: FilePath -> IO FlatDB+readDB f = do c <- readFile f+ case reads c of+ [] -> err $ "parse error"+ [(x,[])] -> return x+ [(_,_)] -> err $ "junk at end"+ _ -> fail $ "ambiguous parse"+ where err e = fail $ "FlatDB error when reading " ++ show f + ++ ": " ++ e++writeDB :: FilePath -> FlatDB -> IO ()+writeDB f db = do h <- openFile f WriteMode+ hWriteDB h db+ hClose h++hWriteDB :: Handle -> FlatDB -> IO ()+hWriteDB h db = hPutStr h $ show db++newDB :: FilePath -> IO ()+newDB f = writeDB f emptyDB++-- Relations++-- FIXME: make distinct+relInsert :: FlatRow -> FlatRel -> FlatRel+relInsert r t = t { relRows = r : relRows t }++-- FIXME: make distinct+-- FIXME: assert relSchema t1 == relSchema t2+relUnion :: FlatRel -> FlatRel -> FlatRel+relUnion t1 t2 = t1 { relRows = relRows t1 `union` relRows t2 } ++relFilter :: (FlatRow -> Bool) -> FlatRel -> FlatRel+relFilter p t = t { relRows = filter p (relRows t) } ++-- FIXME: make distinct+relMap :: (FlatRow -> FlatRow) -> FlatRel -> FlatRel+relMap f t = t { relRows = map f (relRows t) }++++modifyTable :: TableName -> (FlatRel -> FlatRel) -> FlatDB -> FlatDB+modifyTable n f = Map.adjust f n -- FIXME: does nothing if the table doesn't exist++flatTrace :: String -> a -> a+--flatTrace = trace -- ENABLE FOR TRACING+flatTrace _ x = x++flatQueryHDB :: GetRec er vr => PrimQuery -> Rel er -> FlatDB -> IO [Record vr]+flatQueryHDB q rel db = + flatTrace (show q) $+ mapM (getRec flatGetInstances rel scheme) rs+ where scheme = attributes q+ rs = relRows $ flatQuery q db+++flatGetInstances :: GetInstances FlatRow+flatGetInstances = + GetInstances {+ getString = flatGetFieldM toString+ , getInt = flatGetFieldM toInt+ , getInteger = flatGetFieldM toInteger+ , getDouble = flatGetFieldM toDouble+ , getBool = flatGetFieldM toBool+ , getCalendarTime = flatGetFieldM toDate+ }+ where flatGetFieldM f r l = return $ flatGetField f r l+++++flatQuery :: PrimQuery -> FlatDB -> FlatRel+flatQuery pq db = e pq+ where + e q = case q of+ BaseTable n _ -> case Map.lookup n db of+ Just t -> t+ Nothing -> error $ "Table not found: " ++ n+ Project bs x ->+ FlatRel { relSchema = [(n, inferType s e) | (n,e) <- (gbs++abs)], -- FIXME: what about nullability?+ relRows = rps3 }+ where FlatRel { relSchema = s, relRows = rs } = e x+ (abs,gbs) = partition (isAggregate . snd) bs+ rps1 = map (\r -> (evalBinds r gbs, r)) rs+ rps2 = groupBy (\ (x1,_) (x2,_) -> x1 == x2) rps1 -- FIXME: BUG: what if groups are not contiguous?+ rps3 | null gbs && null rs = [[(n,evalAggr [] e) | (n,e) <- abs]] -- return one result if there are no non-aggregates and the relation is empty+ | otherwise = map (\g -> fst (head g) ++ [(n,evalAggr (map snd g) e) | (n,e) <- abs]) rps2+ Restrict p x -> relFilter (\r -> toBool (evalExpr r p)) t+ where t = e x+ Binary op x1 x2 ->+ case op of+ Times -> FlatRel { relSchema = s1 ++ s2, -- FIXME: assert s1, s2 disjoint+ relRows = [r1 ++ r2 | r1 <- rs1, r2 <- rs2] }+ Union -> FlatRel { relSchema = s1, -- FIXME: assert t1 == t2+ relRows = rs1 `union` rs2 }+ Intersect -> FlatRel { relSchema = s1, -- FIXME: assert t1 == t2+ relRows = rs1 `intersect` rs2 }+ Divide -> notImplemented $ show op -- FIXME: hairy, do it later+ Difference -> FlatRel { relSchema = s1, -- FIXME: assert t1 == t2+ relRows = rs1 \\ rs2 }+ where + FlatRel { relSchema = s1, relRows = rs1 } = e x1+ FlatRel { relSchema = s2, relRows = rs2 } = e x2+ Special op q ->+ case op of + Order os -> t { relRows = sortBy sortExprs (relRows t) }+ where sortExprs r1 r2 = mconcat [cmpExpr o e r1 r2 | OrderExpr o e <- os]+ cmpExpr OpAsc e r1 r2 = evalExpr r1 e `compare` evalExpr r2 e+ cmpExpr OpDesc e r1 r2 = evalExpr r2 e `compare` evalExpr r1 e+ Top n -> t { relRows = take n (relRows t) }+ where t = e q+ Empty -> FlatRel { relSchema = [], + relRows = [] }++flatInsert :: TableName -> Assoc -> FlatDB -> FlatDB+flatInsert n xs = flatTrace ("Insert: " ++ show xs) $ + modifyTable n (relInsert r)+ where r = evalBinds [] xs++flatInsertQuery :: TableName -> PrimQuery -> FlatDB -> FlatDB+flatInsertQuery n q db = modifyTable n (relUnion rs) db+ where rs = flatQuery q db++flatDelete :: TableName -> [PrimExpr] -> FlatDB -> FlatDB+flatDelete n cs = flatTrace ("Delete: " ++ n ++ ", " ++ show cs) $ + modifyTable n (relFilter (not . p))+ where p r = all (\c -> toBool (evalExpr r c)) cs++flatUpdate :: TableName -> [PrimExpr] -> Assoc -> FlatDB -> FlatDB+flatUpdate n cs u = flatTrace ("Update: " ++ n ++ ", " ++ show cs ++ ", " ++ show u) $ + modifyTable n (relMap f)+ where p r = all (\c -> toBool (evalExpr r c)) cs+ f r | p r = [maybe e ((,) n . evalExpr r) $ lookup n u | e@(n,_) <- r]+ | otherwise = r++flatTables :: FlatDB -> [TableName]+flatTables = Map.keys++flatDescribe :: TableName -> FlatDB -> [(Attribute,FieldDesc)]+flatDescribe n = relSchema . fromJust . Map.lookup n++flatCreateTable :: TableName -> [(Attribute,FieldDesc)] -> FlatDB -> FlatDB+flatCreateTable n s = Map.insert n t -- FIXME: overwrites existing table+ where t = FlatRel { relSchema = s, relRows = [] }++flatDropTable :: TableName -> FlatDB -> FlatDB+flatDropTable n = Map.delete n++evalBinds :: FlatRow -> [(Attribute,PrimExpr)] -> FlatRow+evalBinds env bs = [(n,evalExpr env e) | (n,e) <- bs]++evalExpr :: FlatRow -> PrimExpr -> Value+evalExpr env (AttrExpr a) = fromJust $ lookup a env+evalExpr env (BinExpr op x1 x2) = + case op of+ OpEq -> VBool (v1 == v2)+ OpLt -> VBool (v1 < v2)+ OpLtEq -> VBool (v1 <= v2)+ OpGt -> VBool (v1 > v2)+ OpGtEq -> VBool (v1 >= v2)+ OpNotEq -> VBool (v1 /= v2)+ OpAnd -> VBool (toBool v1 && toBool v2)+ OpOr -> VBool (toBool v1 || toBool v2)+ OpLike -> VBool (toString v1 `matches` toString v2)+ OpIn -> let v2s = case x2 of + ListExpr x2s -> map (evalExpr env) x2s+ in VBool (v1 `elem` v2s)+ OpOther o -> notImplemented $ show op+ OpCat -> VString (toString v1 ++ toString v2)+ OpPlus -> numOp (+) v1 v2+ OpMinus -> numOp (-) v1 v2+ OpMul -> numOp (*) v1 v2+ OpDiv -> case (v1,v2) of+ (VInteger i1, VInteger i2) -> VInteger (i1 `div` i2)+ (VDouble d1, VDouble d2) -> VDouble (d1 / d2)+ OpMod -> numOp (mod) v1 v2+ OpBitNot -> notImplemented $ show op -- FIXME: shouldn't this be an UnOp?+ OpBitAnd -> bitOp (.&.) v1 v2+ OpBitOr -> bitOp (.|.) v1 v2+ OpBitXor -> bitOp (xor) v1 v2+ OpAsg -> notImplemented $ show op -- FIXME: wtf is this?+ where v1 = evalExpr env x1+ v2 = evalExpr env x2+ numOp o (VInteger i1) (VInteger i2) = VInteger (o i1 i2)+ numOp _ _ _ = error "numOp"+ bitOp o (VInteger i1) (VInteger i2) = VInteger (o i1 i2)+ bitOp _ _ _ = error "bitOp"+ matches = notImplemented "matches"++evalExpr env (UnExpr op x) =+ case op of+ OpNot -> VBool (not (toBool v))+ OpIsNull -> VBool (isNull v)+ OpIsNotNull -> VBool (not (isNull v))+ OpLength -> VInteger (genericLength (toString v))+ UnOpOther o -> notImplemented $ show op+ where v = evalExpr env x+evalExpr env (AggrExpr op x) = undefined -- this need something different,+ -- it affects the result set+evalExpr env (ConstExpr c) = + case c of+ NullLit -> VNull+ DefaultLit -> notImplemented $ show c -- FIXME: need to know default for column+ BoolLit b -> VBool b+ StringLit s -> VString s+ IntegerLit i -> VInteger i+ DoubleLit d -> VDouble d+ DateLit d -> VDate d+ OtherLit l -> notImplemented $ show c+evalExpr env (CaseExpr cs el) =+ case [x | (c,x) <- cs, toBool (evalExpr env c)] of+ x:_ -> evalExpr env x+ _ -> evalExpr env el++evalAggr :: [FlatRow] -> PrimExpr -> Value+evalAggr rs (AggrExpr op e) = + case op of+ AggrCount -> VInteger (genericLength vs) -- FIXME: should this count unique values?+ AggrSum -> numAggr sum sum+ AggrAvg -> dblAggr average+ AggrMin -> numAggr minimum minimum+ AggrMax -> numAggr maximum minimum+ AggrStdDev -> dblAggr stddev+ AggrStdDevP -> dblAggr stddevp+ AggrVar -> dblAggr variance+ AggrVarP -> dblAggr variancep+ AggrOther o -> notImplemented $ show op+ where vs = map (\r -> evalExpr r e) rs+ numAggr :: ([Integer] -> Integer) -> ([Double] -> Double) -> Value+ numAggr f g | null vs || isInteger (head vs) = VInteger $ f $ map toInteger vs+ | otherwise = VDouble $ g $ map toDouble vs+ dblAggr :: ([Double] -> Double) -> Value+ dblAggr f = numAggr (round . f . map fromIntegral) f+ average xs = sum xs / len xs+ stddev = sqrt . variance+ stddevp = sqrt . variancep+ variance xs = sum [(x - average xs) ^ 2 | x <- xs] / (len xs - 1)+ variancep xs = sum [(x - average xs) ^ 2 | x <- xs] / len xs+ len = fromIntegral . length+++-- Type checking++inferType :: [(Attribute,FieldDesc)] -> PrimExpr -> FieldDesc+inferType env e = undefined++-- Getting values from results++flatGetField :: (Value -> a) -> FlatRow -> String -> Maybe a+flatGetField f r n = + case lookup n r of+ Nothing -> error $ "No field " ++ n ++ " in " ++ show r+ Just VNull -> Nothing+ Just v -> Just $ f v++isNull :: Value -> Bool+isNull VNull = True+isNull _ = False++isInteger :: Value -> Bool+isInteger (VInteger _) = True+isInteger _ = False++toString :: Value -> String+toString (VString s) = s+toString v = error $ show v ++ " is not a string"++toInt :: Value -> Int+toInt (VInteger i) = fromIntegral i+toInt v = error $ show v ++ " is not an integer"++toInteger :: Value -> Integer+toInteger (VInteger i) = i+toInteger v = error $ show v ++ " is not an integer"++toDouble :: Value -> Double+toDouble (VDouble d) = d+toDouble v = error $ show v ++ " is not a double"++toBool :: Value -> Bool+toBool (VBool b) = b+toBool v = error $ show v ++ " is not a boolean"++toDate :: Value -> CalendarTime+toDate (VDate d) = d+toDate v = error $ show v ++ " is not a date"++notImplemented s = error $ "NOT IMPLEMENTED: " ++ s
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++import Distribution.Simple+main = defaultMain
+ haskelldb-flat.cabal view
@@ -0,0 +1,23 @@+Name: haskelldb-flat+Version: 0.10+Copyright: Bjorn Bringert+Maintainer: bjorn@bringert.net+Author: Bjorn Bringert+License: BSD3+build-depends: + haskell98, + base, + mtl, + haskelldb==0.10+Extensions: +Synopsis: An experimental HaskellDB back-end in pure Haskell (no SQL)+Description:+ This is a very experimental HaskellDB back-end which is written in pure Haskell+ and doesn't use SQL. It stores the database in a file. Using this with+ concurrent writes leads to data loss. This back-end does not support transactions.+Exposed-Modules: Database.HaskellDB.FlatDB+ghc-options: -O2++Executable: flatdb-create+Main-Is: tools/flatdb-create.hs+ghc-options: -O2 -Wall
+ tools/flatdb-create.hs view
@@ -0,0 +1,10 @@+import Database.HaskellDB.FlatDB++import System.Environment+import System.IO++main :: IO ()+main = do args <- getArgs+ case args of+ [f] -> newDB f+ _ -> hPutStrLn stderr "Usage: flatdb-create <file>"