content: -----------------------------------------------------------
  -- |
  -- 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.FieldType
  import Database.HaskellDB.PrimQuery
  import Database.HaskellDB.Query	hiding (isNull, union, intersect)
  import Database.HaskellDB.DriverAPI
  import Database.HaskellDB (Record)
  
  import Control.Exception (bracket)
  import Control.Monad
  import Control.Monad.Error ()
  import Control.Monad.Trans
  import Data.Bits
  import Data.Function (on)
  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
  
  -- FIXME: this is full of race conditions
  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 $ fileReadDB 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
  	     }
  
  fileReadDB :: FilePath -> IO FlatDB
  fileReadDB f = openFile f ReadMode >>= hReadDB
  
  hReadDB :: Handle -> IO FlatDB
  hReadDB h = 
      do c <- hGetContents h
         case readDB c of
             Left err ->
                 fail $ "FlatDB error when reading " ++ show h
                          ++ ": " ++ err
             Right db -> return db
  
  fileWriteDB :: FilePath -> FlatDB -> IO ()
  fileWriteDB f db = bracket (openFile f WriteMode) hClose (flip hWriteDB db) 
  
  hWriteDB :: Handle -> FlatDB -> IO ()
  hWriteDB h db = hPutStr h $ showDB db
  
  newDB :: FilePath -> IO ()
  newDB f = fileWriteDB f emptyDB
  
  showDB :: FlatDB -> String
  showDB = show . Map.toList 
  
  readDB :: Monad m => String -> m FlatDB
  readDB c = case reads c of
                  []       -> fail "parse error"
                  [(x,[])] -> return $ Map.fromList x
                  [(_,_)]  -> fail "junk at end"
                  _        -> fail "ambiguous parse"
  
  -- 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
             Group gs x -> FlatRel { relSchema = s, relRows = rs' }
                 where FlatRel { relSchema = s, relRows = rs } = e x
                       -- FIXME: BUG: what if groups are not contiguous?
                       rs' = map (fst . head) $ groupBy ((==) `on` snd) [(r,evalBinds r gs) | r <- rs]
             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