tbox 0.0.0 → 0.1.0
raw patch · 9 files changed
+721/−170 lines, 9 filesdep +IfElsedep +arraydep +containersdep ~stm-io-hooks
Dependencies added: IfElse, array, containers, monad-loops, random, safe-failure
Dependency ranges changed: stm-io-hooks
Files
- Control/Concurrent/TBox.hs +4/−3
- Control/Concurrent/TBox/Class.hs +0/−50
- Control/Concurrent/TBox/Internal/Class.hs +85/−0
- Control/Concurrent/TBox/Internal/Operations.hs +71/−0
- Control/Concurrent/TBox/Operations.hs +0/−66
- Control/Concurrent/TBox/TSkipList.hs +312/−0
- Control/Concurrent/TFile.hs +90/−38
- Control/Concurrent/TFile/TSkipList.hs +113/−0
- tbox.cabal +46/−13
Control/Concurrent/TBox.hs view
@@ -17,11 +17,12 @@ -- * Operations on a TBox read, write,- delete,+ clear, isEmpty,+ isEmptyNotDirty, ) where-import Control.Concurrent.TBox.Class-import Control.Concurrent.TBox.Operations+import Control.Concurrent.TBox.Internal.Class+import Control.Concurrent.TBox.Internal.Operations import Prelude hiding (read,readIO)
− Control/Concurrent/TBox/Class.hs
@@ -1,50 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Control.Concurrent.TBox.Class--- Copyright : Peter Robinson 2009--- License : LGPL------ Maintainer : Peter Robinson <thaldyron@gmail.com>--- Stability : experimental--- Portability : non-portable (requires STM)------ The type class 'TBox'.--- ----------------------------------------------------------------------------------module Control.Concurrent.TBox.Class-where-import Control.Concurrent.AdvSTM-import Prelude hiding(readIO)------------------------------------------------------------------------------------- | An instance of 'TBox' is a (Adv)STM variable that might contain a value of --- some type 'a'. In contrast to a plain 'TVar', a --- 'TBox' has IO hooks that are executed transparently on updates and reads.--- The functions of the type class shouldn't be exposed directly but should be used via--- the interface defined in the module 'TBox.Operations'.--- --- See the module 'TFile' for a concrete instantiation.-class TBox t a where- writeSTM :: t a -> a -> AdvSTM ()- writeIO :: t a -> a -> IO () -- readSTM :: t a -> AdvSTM (Maybe a)- -- | Note: Might be executed multiple times for the- -- same 'TBox' in a single transaction. See 'unsafeRetryWith'.- readIO :: t a -> IO (Maybe a)-- deleteSTM :: t a -> AdvSTM ()- deleteIO :: t a -> IO ()-- -- | If 'isDirty' yields 'True', the 'readIO' hook will be run on the next- -- read.- isDirty :: t a -> AdvSTM Bool- setDirty :: t a -> Bool -> AdvSTM ()---- modifySTM :: t a -> (a -> a) -> AdvSTM ()--- modifySTM t f = readSTM t >>= writeSTM t . f--- modifyIO :: t a -> (a -> a) -> AdvSTM ()--- modifyIO t f = readIO t >>= --
+ Control/Concurrent/TBox/Internal/Class.hs view
@@ -0,0 +1,85 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.TBox.Internal.Class+-- Copyright : Peter Robinson 2009+-- License : LGPL+--+-- Maintainer : Peter Robinson <thaldyron@gmail.com>+-- Stability : experimental+-- Portability : non-portable (requires STM)+--+-- The type class 'TBox'.+-- +--+-----------------------------------------------------------------------------+module Control.Concurrent.TBox.Internal.Class+where+import Control.Concurrent.AdvSTM+import Prelude hiding(readIO)++--------------------------------------------------------------------------------+-- | An instance of 'TBox' is a (Adv)STM variable that might contain a value of +-- some type 'a'. In contrast to a plain 'TVar (Maybe a)', a +-- 'TBox' has IO hooks that are executed transparently on writes and reads,+-- which makes it particularly suitable for implementing a persistent and thread-safe storage.+-- The type variable 'k' can be used to provide additional storage information, e.g.,+-- a filepath. +--+-- /Important:/ Note that the read/write functions of this type class, i.e.,+-- 'readIO', 'readSTM', 'writeIO', 'writeSTM', 'clearIO', 'clearSTM' should +-- /only/ be used to derive new +-- instances and do not serve to modify the state of a 'TBox'.+-- The interface defined in module 'TBox.Operations' provides +-- operations on 'TBox's that guarantee consistency.+-- +-- See the module 'Control.Concurrent.TFile' for a sample instance.+class TBox t k a where+ -- | Takes a key and an initial value+ new :: k -> a -> AdvSTM (t k a)+ -- | Takes a key and an initial value. Has a default implementation.+ newIO :: k -> a -> IO (t k a)+ newIO k a = atomically (new k a)++ -- | Takes a key and returns an empty 't'+ newEmpty :: k -> AdvSTM (t k a)+ -- | Takes a key and returns an empty 't'. Has a default implementation.+ newEmptyIO :: k -> IO (t k a)+ newEmptyIO = atomically . newEmpty++-- -- | Return the key+-- getKey :: t k a -> AdvSTM k++ -- | Used in 'TBox.write'.+ writeSTM :: t k a -> a -> AdvSTM ()+ -- | Used in 'TBox.write' during the commit phase. + -- Is guaranteed to be executed exactly once /iff/ the transaction commits.+ writeIO :: t k a -> a -> IO () ++ -- | Used in 'TBox.read'+ readSTM :: t k a -> AdvSTM (Maybe a)+ -- | Used in 'TBox.read' when retrying the transaction, which happens when the + -- 'TBox' has been marked \"dirty\".+ -- Note: Might be executed multiple times for the+ -- same 'TBox' in a single transaction. See 'unsafeRetryWith'.+ readIO :: t k a -> IO (Maybe a)++ -- | Used in 'TBox.clear'+ clearSTM :: t k a -> AdvSTM ()+ -- | Used in 'TBox.clear' during the commit phase.+ -- Is guaranteed to be executed exactly once /iff/ the transaction commits.+ clearIO :: t k a -> IO ()++ -- | If 'isDirty' yields 'True', the 'readIO' hook will be + -- run on the next read.+ isDirty :: t k a -> AdvSTM Bool+ -- | Change the \"dirty\" status of the 'TBox'.+ setDirty :: t k a -> Bool -> AdvSTM ()++{-+-- TODO: what about modify?+ modifySTM :: t k a -> (a -> a) -> AdvSTM ()+ modifyIO :: t k a -> (a -> a) -> IO (Maybe a)+ modifySTM t f = readSTM t >>= writeSTM t . f+ modifyIO t f = readIO t >>= writeIO t+-}+
+ Control/Concurrent/TBox/Internal/Operations.hs view
@@ -0,0 +1,71 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.TBox.Internal.Operations+-- Copyright : Peter Robinson 2009+-- License : LGPL+--+-- Maintainer : Peter Robinson <thaldyron@gmail.com>+-- Stability : experimental+-- Portability : non-portable (requires STM)+--+-- Operations on instances of 'TBox'.+--+-----------------------------------------------------------------------------+module Control.Concurrent.TBox.Internal.Operations+where+import Control.Concurrent.TBox.Internal.Class+import Control.Monad+import Control.Concurrent.AdvSTM+import Data.Maybe+import Control.Monad.Loops++import Prelude hiding(lookup,catch,null,read,readIO,writeFile)+++--------------------------------------------------------------------------------++-- | Deletes the content.+clear :: (TBox t k a) => t k a -> AdvSTM ()+clear tbox = do+ clearSTM tbox + setDirty tbox False+ onCommit $ clearIO tbox++-- | Writes the new content.+write :: (TBox t k a) => t k a -> a -> AdvSTM ()+write tbox a = do+ writeSTM tbox a + setDirty tbox False+ onCommit $ writeIO tbox a++-- | If the TBox is dirty, this retries the transaction and+-- rereads the content using 'readIO' in a separate thread.+-- Otherwise it simply returns the result of 'readSTM'.+--+-- Note: Depending on the instance implementation, careless +-- use of 'setDirty' and 'read' in the same transaction might lead+-- to nonterminating retry loops.+read :: TBox t k a => t k a -> AdvSTM (Maybe a)+read tbox = do+ dirty <- isDirty tbox+ if dirty + then unsafeRetryWith $ do + !mvalIO <- readIO tbox +-- print "retrying"+ atomically $ do+ stillDirty <- isDirty tbox+ when stillDirty $ do+ setDirty tbox False+ case mvalIO of+ Nothing -> clearSTM tbox + Just v -> writeSTM tbox v + else + readSTM tbox++-- | Returns 'True' iff the 'TBox' is empty.+isEmpty :: TBox t k a => t k a -> AdvSTM Bool+isEmpty = liftM isJust . readSTM ++-- | Returns 'True' iff the 'TBox' is empty and not dirty.+isEmptyNotDirty :: TBox t k a => t k a -> AdvSTM Bool+isEmptyNotDirty t = andM [isEmpty t,isDirty t]
− Control/Concurrent/TBox/Operations.hs
@@ -1,66 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Control.Concurrent.TBox.Operations--- Copyright : Peter Robinson 2009--- License : LGPL------ Maintainer : Peter Robinson <thaldyron@gmail.com>--- Stability : experimental--- Portability : non-portable (requires STM)------ Operations on instances of 'TBox'.----------------------------------------------------------------------------------module Control.Concurrent.TBox.Operations-where-import Control.Concurrent.TBox.Class-import Control.Monad-import Control.Concurrent.AdvSTM-import Data.Maybe--import Prelude hiding(lookup,catch,null,read,readIO,writeFile)--------------------------------------------------------------------------------------- | Deletes the content.-delete :: (TBox t a) => t a -> AdvSTM ()-delete tbox = do- deleteSTM tbox - setDirty tbox False- onCommit $ deleteIO tbox---- | Writes the new content.-write :: (TBox t a) => t a -> a -> AdvSTM ()-write tbox a = do- writeSTM tbox a - setDirty tbox False- onCommit $ writeIO tbox a---- | If the TBox is dirty, this retries the transaction and--- rereads the content using 'readIO' in a separate thread.--- Otherwise it simply returns the result of 'readSTM'.------ Note: Depending on the implementation, careless --- use of 'setDirty' and 'read' in the same transaction might lead--- to nonterminating retry loops.-read :: TBox t a => t a -> AdvSTM (Maybe a)-read tbox = do- dirty <- isDirty tbox- if dirty - then unsafeRetryWith $ do - mvalIO <- readIO tbox - atomically $ do- stillDirty <- isDirty tbox- when stillDirty $ do- setDirty tbox False- case mvalIO of- Nothing -> deleteSTM tbox - Just v -> writeSTM tbox v - else - readSTM tbox---- | Returns 'True' iff the 'TBox' is empty.-isEmpty :: TBox t a => t a -> AdvSTM Bool-isEmpty = liftM isJust . readSTM -
+ Control/Concurrent/TBox/TSkipList.hs view
@@ -0,0 +1,312 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.TBox.TSkipList+-- Copyright : Peter Robinson 2010+-- License : LGPL+-- +-- Maintainer : Peter Robinson <robinson@ecs.tuwien.ac.at>+-- Stability : experimental+-- Portability : non-portable (requires STM)+--+-- Provides an implementation of a skip list in the 'AdvSTM' monad.+-- A skip list is a probabilistic data structure with map-like operations.+-- In contrast to a balanced tree, a skip list does not need any rebalancing,+-- which makes it suitable for concurrent programming.+-- See: /William Pugh. Skip Lists: A Probabilistic Alternative to Balanced Trees./+--+-- The elements of the skip list are stored in a 'TBox'.+-- When an element of the skip list is modified, the operation is relegated+-- to the corresponding 'TBox'.+--+-- For a concrete instance see module 'Control.Concurrent.TFile.TSkipList'+-----------------------------------------------------------------------------+ +module Control.Concurrent.TBox.TSkipList(-- * Data type + TSkipList,newIO,+ -- * Operations+ insert,lookup,update,delete,geq,leq,min,filter,+ -- * Low-level Operations+ insertNode,lookupNode,readAndValidate,newNode,+ contentTBox,key,+ -- * Utilities + chooseLevel,+ toString,+ ) ++where+import Control.Concurrent.TBox(TBox)+import qualified Control.Concurrent.TBox as TBox++import Control.Exception+import Control.Concurrent.AdvSTM.TVar+import Control.Concurrent.AdvSTM.TArray+import Control.Concurrent.AdvSTM+import Control.Applicative+import Control.Monad+import Control.Monad.IfElse(unlessM)++import System.Random+import Data.Maybe+--import Data.List(unlines)+import Data.Map(Map)+import qualified Data.Map as M+import Data.Array.MArray+import Prelude hiding(lookup,filter,catch,min)++type ForwardPtrs t k a = TArray Int (Node t k a)+++data TSkipList t k a = TSkipList + { maxLevel :: Int+ , probability :: Float+ , curLevel :: TVar Int+ , listHead :: ForwardPtrs t k a+ }++data Node t k a+ = Nil + | Node { key :: k + , contentTBox :: t k a + , forwardPtrs :: ForwardPtrs t k a+ }++newNode :: TBox t k a => k -> t k a -> Int -> AdvSTM (Node t k a)+newNode k t maxLvl = Node k t `liftM` newForwardPtrs maxLvl++isNil :: Node t k a -> Bool+isNil Nil = True+isNil _ = False++-- | An empty skiplist.+newIO :: TBox t k a + => Float -- ^ Probability for choosing a new level+ -> Int -- ^ Maximum number of levels+ -> IO (TSkipList t k a)+newIO p maxLvl = + atomically $ new p maxLvl+++-- | An empty skiplist.+new :: TBox t k a + => Float -- ^ Probability for choosing a new level+ -> Int -- ^ Maximum number of levels+ -> AdvSTM (TSkipList t k a)+new p maxLvl = + TSkipList maxLvl p `liftM` {- newTVar stdG + `ap` -} newTVar 1 + `ap` newForwardPtrs maxLvl+++newForwardPtrs :: Int -> AdvSTM (ForwardPtrs t k a)+newForwardPtrs maxLvl = newListArray (1,maxLvl) $ replicate maxLvl Nil+++-- | Returns a randomly chosen level. Is used for inserting new elements.+-- Note that this function uses 'unsafeIOToAdvSTM' to access the random+-- number generator.+chooseLevel :: TSkipList t k a -> AdvSTM Int+chooseLevel tskip = do+ stdG <- unsafeIOToAdvSTM newStdGen+ let rs :: StdGen -> [(Float)]+ rs g = x : rs g' where (x,g') = randomR (0,1) g+ let samples = take (maxLevel tskip - 1) (rs stdG) + return $ 1 + length (takeWhile ((probability tskip) <) $ samples) +++-- | Returns all elements that are smaller than the key. +leq :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM (Map k a)+leq k tskip = + leqAcc (listHead tskip) 1 M.empty+ where+ leqAcc fwdPtrs lvl curAcc = do+ let moveDown acc _ level = + leqAcc fwdPtrs (level-1) acc + let moveRight acc succNode level = do + newAcc <- addElem acc succNode+ leqAcc (forwardPtrs succNode) level newAcc + let onFound acc succNode _ = + addElem acc succNode+ traverse k fwdPtrs lvl (moveDown curAcc) (moveRight curAcc) (onFound curAcc) (moveDown curAcc) curAcc++ addElem acc succNode = + maybe acc (\a -> M.insert (key succNode) a acc) <$> readAndValidate tskip succNode+++-- | Returns all elements that are greater than the key.+-- TODO: currently in O(n), can be made more efficient (like 'leq')+geq :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM (Map k a)+geq k = filter (\k' _ -> (k'>=k))++-- | Returns the element with the least key, if it exists. /O(1)/.+min :: (Ord k, TBox t k a) => TSkipList t k a -> AdvSTM (Maybe a)+min tskip = do+ node <- readArray (listHead tskip) 1 + if isNil node + then return Nothing+ else readAndValidate tskip node ++-- | Reads the 'TBox' of the node. If the 'TBox' is empty, the node+-- is removed from the skip list.+-- This is necessary when 'TBox's are shared between different data+-- structures. +readAndValidate :: (Ord k, TBox t k a) + => TSkipList t k a -> Node t k a -> AdvSTM (Maybe a)+readAndValidate tskip succNode = do+ ma <- TBox.read (contentTBox succNode)+ case ma of+ Just a -> return $ Just a+ Nothing -> do+ delete (key succNode) tskip+ return Nothing+ +{- + maxAcc (listHead tskip) 1 M.empty+ where+ maxAcc fwdPtrs level acc = do+ succNode <- readArray fwdPtrs level + if isNil succNode + then return Nothing+ else do+ if isNil succsuccNode + then return (key succNode)+ else maxAcc (forwardPtrs succNode) level newAcc+ newAcc <- addElem acc succNode+ filterAcc (forwardPtrs succNode) level newAcc+-}+++lookupNode :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM (Maybe (Node t k a))+lookupNode k tskip = + lookupAcc (listHead tskip) =<< readTVar (curLevel tskip)+ where+ lookupAcc fwdPtrs lvl = do+ let moveDown _ level = lookupAcc fwdPtrs (level-1)+ let moveRight succNode = lookupAcc (forwardPtrs succNode) + let onFound succNode _ = return (Just succNode)+ traverse k fwdPtrs lvl moveDown moveRight onFound moveDown Nothing+++lookup :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM (Maybe a)+lookup k tskip = + maybe (return Nothing)+ (readAndValidate tskip) =<< lookupNode k tskip+++-- | Updates an element. Throws 'AssertionFailed' if the element is not in the+-- list.+update :: ({- Show k,-}Ord k, TBox t k a) => k -> a -> TSkipList t k a -> AdvSTM ()+update k a tskip = + maybe (throw $ AssertionFailed "TSkipList.update: element not found!") + (flip TBox.write a . contentTBox) =<< lookupNode k tskip +++delete :: ({- Show k,-}Ord k, TBox t k a) => k -> TSkipList t k a -> AdvSTM ()+delete k tskip = + deleteAcc (listHead tskip) =<< readTVar (curLevel tskip)+ where+ deleteAcc fwdPtrs lvl = do+ let moveDown _ level = deleteAcc fwdPtrs (level-1)+ let moveRight succNode = deleteAcc (forwardPtrs succNode) + let onFound succNode level = do+ let tbox = contentTBox succNode+ unlessM (TBox.isEmptyNotDirty tbox) $+ TBox.clear (contentTBox succNode)+ succsuccNode <- readArray (forwardPtrs succNode) level + writeArray fwdPtrs level succsuccNode+ moveDown succNode level+ traverse k fwdPtrs lvl moveDown moveRight onFound moveDown ()+++insert :: ({- Show k,-}Ord k, TBox t k a) => k -> a -> TSkipList t k a -> AdvSTM ()+insert k a tskip = do+ -- Make new TBox:+ tbox <- TBox.new k a + newPtrs <- newForwardPtrs (maxLevel tskip)+ let node = Node k tbox newPtrs+ insertNode k node tskip+++insertNode :: ({- Show k,-}Ord k, TBox t k a) => k -> Node t k a -> TSkipList t k a -> AdvSTM ()+insertNode k node tskip = do+ newLevel <- chooseLevel tskip+ -- Adapt current maximum level:+ curLvl <- readTVar (curLevel tskip)+ when (curLvl < newLevel) $ + writeTVar (curLevel tskip) newLevel+ insertAcc (listHead tskip) newLevel+ where+ insertAcc fwdPtrs lvl = do+ let moveDown succNode level = do + writeArray (forwardPtrs node) level succNode+ writeArray fwdPtrs level node+ insertAcc fwdPtrs (level-1)+ let moveRight succNode = + insertAcc (forwardPtrs succNode) + let onFound _ level = do+ writeArray fwdPtrs level node+ insertAcc fwdPtrs (level-1)+ traverse k fwdPtrs lvl moveDown moveRight onFound moveDown ()+++traverse :: ({- Show k,-}Ord k, TBox t k a) + => k -> ForwardPtrs t k a -> Int + -> (Node t k a -> Int -> AdvSTM b)+ -> (Node t k a -> Int -> AdvSTM b)+ -> (Node t k a -> Int -> AdvSTM b)+ -> (Node t k a -> Int -> AdvSTM b)+ -> b+ -> AdvSTM b+traverse k fwdPtrs level onLT onGT onFound onNil def+ | level < 1 = return def+ | otherwise = do+ succNode <- readArray fwdPtrs level + if isNil succNode + then onNil succNode level+ else case k `compare` key succNode of+ GT -> onGT succNode level+ LT -> onLT succNode level+ EQ -> onFound succNode level+++-- | Returns all elements that satisfy the predicate. O(n).+filter :: ({- Show k,-}Ord k, TBox t k a) + => (k -> a -> Bool) -> TSkipList t k a -> AdvSTM (Map k a)+filter p tskip = + filterAcc (listHead tskip) 1 M.empty+ where+ filterAcc fwdPtrs level acc = do+ succNode <- readArray fwdPtrs level + if isNil succNode + then return acc+ else do+ newAcc <- addElem acc succNode+ filterAcc (forwardPtrs succNode) level newAcc++ addElem acc succNode = + maybe acc (\a -> if p (key succNode) a + then M.insert (key succNode) a acc+ else acc) + <$> readAndValidate tskip succNode+++-- | Debug helper. Returns the skip list as a string.+-- All elements smaller than the given key are written to the string.+toString :: (Ord k, Show k, TBox t k a) => k -> TSkipList t k a -> AdvSTM String+toString k tskip = do+ curLvl <- readTVar (curLevel tskip)+ ls <- forM (reverse [1..curLvl]) $ printAcc (listHead tskip) []+ return $ unlines ls+ where+ printAcc fwdPtrs acc curLvl = do+ let moveDown succNode level = + if (isNil succNode) + then return acc+ else printAcc (forwardPtrs succNode) acc level+ let moveRight succNode level = do+ let n = (' ':show (key succNode))+ printAcc (forwardPtrs succNode) (acc++n) level+ let onFound succNode level = do+ let n = (' ':show (key succNode))+ printAcc (forwardPtrs succNode) (acc++n) level+ traverse k fwdPtrs curLvl moveDown moveRight onFound moveDown ""+
Control/Concurrent/TFile.hs view
@@ -9,28 +9,37 @@ -- Portability : non-portable (requires STM) -- -- --- A transactional variable that writes its content to a file on each update.+-- A transactional variable that writes its content to a file when updated.+-- Due to the atomicity guarantees of the 'AdvSTM' monad, an update to a+-- 'TFile' is only committed when the file operation succeeds. -- -- This module should be imported qualified. -- ------------------------------------------------------------------------------module Control.Concurrent.TFile( -- * Data type+module Control.Concurrent.TFile( + -- * Data type TFile,- -- * Construction- newEmptyIO,- newIO,+-- -- * Construction+-- newIO,+-- new, new,+ newIO,+ newFromFileIO,+ newEmpty,+ newEmptyIO,+ newEmptyFromFileIO, -- * Operations read, write,- delete,- isEmpty+ clear,+ isEmpty,+ -- * Utilities+ basedir, ) where-import Control.Concurrent.TBox.Class-import Control.Concurrent.TBox.Operations+import Control.Concurrent.TBox import Data.Binary import Data.Typeable@@ -38,24 +47,30 @@ import Control.Concurrent.AdvSTM import Control.Concurrent.AdvSTM.TVar import Control.Monad+import Control.Monad.IfElse(unlessM) import Control.Exception +import System.FilePath((</>),takeFileName) import System.Directory import System.IO.Error hiding(catch) import System.IO.Cautious(writeFileL) import Prelude hiding(lookup,catch,null,read,readIO,writeFile)+import qualified Prelude as P+import qualified Safe.Failure as Safe -------------------------------------------------------------------------------- -- | A transactional variable that writes its content to a file on each update.+-- The file is created in directory \".\/_TFile\/\". ----- * The updated memory content of the TFile is not visible to other threads--- until the file has been written successfully. +-- * The 'onCommit' hook of the 'AdvSTM' monad guarantee that the updated memory content +-- of the TFile is only visible to other threads /iff/ the file has been written +-- successfully. -- -- * If the 'TFile' is \"dirty\", the content is (re)read from the file on the next -- 'read'. ---data TFile a = TF +data TFile k a = TF { filepath :: FilePath , tfileTVar :: TVar (Maybe a) , dirtyTVar :: TVar Bool@@ -63,42 +78,80 @@ } deriving(Typeable) --- | Constructs an initially empty 'TFile' that is marked dirty. --- That means, on the next 'read', the contents of the provided file (if it--- exists) will be loaded into the 'TFile'.-newEmptyIO :: Binary a => FilePath -> IO (TFile a)-newEmptyIO fp = - TF fp `liftM` newTVarIO Nothing - `ap` (newTVarIO =<< doesFileExist fp)- `ap` newTMVarIO () -newIO :: Binary a => FilePath -> a -> IO (TFile a)-newIO fp = atomically . new fp+-- | Currently set to \".\/_TFile\"+-- TODO: provide interface for updating base directory within a transaction(?)+basedir :: FilePath+basedir = "_TFile" -new :: Binary a => FilePath -> a -> AdvSTM (TFile a)-new fp a = do- tbox <- TF fp `liftM` newTVar (Just a) - `ap` newTVar False - `ap` newTMVar ()- write tbox a- return tbox -instance Binary a => TBox TFile a where- writeSTM tbox = writeTVar (tfileTVar tbox) . Just +-- | Tries to construct a 'TFile' from a given filepath. +-- Reads the content of the file into memory.+newFromFileIO :: (Read k,TBox TFile k a) => FilePath -> IO (TFile k a,k)+newFromFileIO fp = do+ (t,k) <- newEmptyFromFileIO fp + _ <- atomically $ read t+ return (t,k) - writeIO (TF fp _ _ lock) = withTMVar lock . const . writeFileL fp . encode +-- | Tries to construct a 'TFile' from a given filepath. +-- Note that the content of the file is read into memory only on demand, i.e.,+-- when executing 'TBox.read'.+-- Throws 'AssertionFailed' if the filename could not be parsed.+newEmptyFromFileIO :: (Read k,TBox TFile k a) => FilePath -> IO (TFile k a,k)+newEmptyFromFileIO fp = do+ k <- Safe.read (takeFileName fp) `catch` (\(_::Safe.SafeException) ->+ throw $ AssertionFailed ("Could not parse filename: " ++ fp))+ t <- newEmptyIO k+ return (t,k)+ +{- maybe (throw $ AssertionFailed ("Could not parse filename: " ++ fp))+ (\k -> do+ t <- newEmptyIO k+ return (t,k))+ $ Safe.read (takeFileName fp)+-} +instance (Binary a,Show k) => TBox TFile k a where+ newEmpty k = + let fp = basedir </> show k+ in TF fp `liftM` newTVar Nothing + `ap` newTVar True+ `ap` newTMVar ()++ newEmptyIO k = do+ unlessM (doesDirectoryExist basedir) $ + createDirectory basedir+ let fp = basedir </> show k+ TF fp `liftM` newTVarIO Nothing + `ap` (newTVarIO =<< doesFileExist fp)+ `ap` newTMVarIO ()++ new k a = do+ let fp = basedir </> show k+ tbox <- TF fp `liftM` newTVar (Just a) + `ap` newTVar False + `ap` newTMVar ()+ write tbox a+ return tbox++ writeSTM tfile = writeTVar (tfileTVar tfile) . Just ++ writeIO (TF fp _ _ lock) a = do + unlessM (doesDirectoryExist basedir) $ + createDirectory basedir+ withTMVar lock $ const $ writeFileL fp $ encode a+ readSTM = readTVar . tfileTVar - readIO (TF fp _ _ lock) = (do- a <- withTMVar lock $ const $ decodeFile fp- return $ Just a)+ readIO tmap = do+ a <- withTMVar (fileLock tmap) $ const $ decodeFile (filepath tmap)+ return (Just a) `catch` \(e::IOException) -> if isDoesNotExistError e then return Nothing else throw e - deleteSTM tbox = writeTVar (tfileTVar tbox) Nothing+ clearSTM tbox = writeTVar (tfileTVar tbox) Nothing - deleteIO (TF fp _ _ lock) = withTMVar lock $ const $ removeFile fp+ clearIO (TF fp _ _ lock) = withTMVar lock $ const $ removeFile fp `catch` \(e::IOException) -> unless (isDoesNotExistError e) $ throw e isDirty = readTVar . dirtyTVar @@ -112,5 +165,4 @@ return res ---------------------------------------------------------------------------------
+ Control/Concurrent/TFile/TSkipList.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+-- |+-- Module : Control.Concurrent.TFile.TSkipList+-- Copyright : Peter Robinson 2010+-- License : LGPL+-- +-- Maintainer : Peter Robinson <robinson@ecs.tuwien.ac.at>+-- Stability : experimental+-- Portability : non-portable (requires STM)+--+-- Instantiates the STM skiplist implementation of+-- Control.Concurrent.TBox.TSkipList with the 'TFile' backend.+--+-- This module should be imported qualified.+--+-- Example:+--+-- > t <- newIO 0.5 5 :: IO (TSkipList Int String) +-- > atomically $ sequence_ [ insert i (show i) t | i <- [1..10] ]+-- >+-- > putStr =<< atomically (toString 100 t)+-- > 9+-- > 9+-- > 3 7 9+-- > 1 3 7 9+-- > 1 2 3 4 5 6 7 8 9 10+-- >+-- > atomically $ delete 7 t+-- > putStr =<< atomically (toString 100 t)+-- > 9+-- > 9+-- > 3 9+-- > 1 3 9+-- > 1 2 3 4 5 6 8 9 10+-- > +-- > atomically $ sequence [ lookup i t | i <- [5..10] ]+-- > [Just "5",Just "6",Nothing,Just "8",Just "9",Just "10"]+-- >+-- > atomically $ update 8 "X" t+-- > atomically $ sequence [ lookup i t | i <- [5..10] ]+-- > [Just "5",Just "6",Nothing,Just "X",Just "9",Just "10"]+-----------------------------------------------------------------------------++module Control.Concurrent.TFile.TSkipList(-- * Data type + TSkipList,newEmptyIO,newIO,+ -- * Operations+ insert,lookup,update,leq,geq,min,filter,delete,+ -- * Utilities + chooseLevel, toString+ ) +where+import Prelude hiding(lookup,filter,catch,min)+import qualified Prelude as P+import Control.Concurrent.TBox.TSkipList hiding (TSkipList,newIO) -- (insert,lookup,update,leq,geq,filter,delete,newEmptyIO,chooseLevel)+import qualified Control.Concurrent.TBox.TSkipList as TBox.TSkipList+import Control.Concurrent.TBox(TBox)+import qualified Control.Concurrent.TBox as TBox+import Control.Concurrent.AdvSTM+import Control.Exception+import System.Directory+import System.IO.Error hiding (catch)+import Data.Binary+import Control.Monad+import Control.Applicative+--import Data.List(lem)++import Control.Concurrent.TFile(TFile)+import qualified Control.Concurrent.TFile as TFile+++type TSkipList k a = TBox.TSkipList.TSkipList TFile k a+++-- | Returns a new (reconstructed!) 'TSkipList'. Automatically inserts all 'TFile' entries found+-- in \"basedir</>\". +-- Note that the 'TFile's are initially empty, i.e., the file content will only be+-- read into memory on demand.+newEmptyIO :: (Binary a,Show k,Ord k,Read k,TBox TFile k a) => Float -> Int -> IO (TSkipList k a)+newEmptyIO p maxLvl = do+ fs <- getFilesInDirectory TFile.basedir `catch` \(e::IOException) ->+ if isDoesNotExistError e then return []+ else throw e+ tskip <- TBox.TSkipList.newIO p maxLvl + forM_ fs (\(f::String) -> do + (t,k) <- TFile.newEmptyFromFileIO f + atomically $ do node <- newNode k t maxLvl+ TBox.TSkipList.insertNode k node tskip)+ return tskip+ ++-- | Returns a new (reconstructed!) 'TSkipList'. Automatically inserts all 'TFile' entries found+-- in \"basedir</>\". +-- In contrast to 'newEmptyIO', the 'TFile's initially contain the file content.+-- Use this if you want to have all data in memory from the start.+newIO :: (Binary a,Show k,Ord k,Read k,TBox TFile k a) => Float -> Int -> IO (TSkipList k a)+newIO p maxLvl = do+ fs <- getFilesInDirectory TFile.basedir `catch` \(e::IOException) ->+ if isDoesNotExistError e then return []+ else throw e+ tskip <- TBox.TSkipList.newIO p maxLvl + forM_ fs (\(f::String) -> do + (t,k) <- TFile.newEmptyFromFileIO f -- TODO: why *empty*?+ atomically $ do + _ <- TBox.read t + node <- newNode k t maxLvl+ TBox.TSkipList.insertNode k node tskip)+ return tskip+++getFilesInDirectory :: FilePath -> IO [FilePath]+getFilesInDirectory fp = + P.filter (flip notElem [".",".."]) <$> getDirectoryContents fp+
tbox.cabal view
@@ -1,18 +1,36 @@ Name: tbox-Synopsis: Transactional variables with IO hooks+Synopsis: Transactional variables and data structures with IO hooks Description:- (to be expanded...)+ This package provides STM data structures with IO hooks. + The basic building blocks are instances of class 'TBox'. Such an+ instance is an STM variable that might contain a value of + some type 'a'. In contrast to a plain 'TVar (Maybe a)', a + 'TBox' has IO hooks that are executed transparently on writes and reads.+ The IO hooks of the 'AdvSTM' monad extend the atomicity of STM transactions+ to the on-commit IO actions, which makes it particularly suitable for + implementing a persistent and thread-safe storage. .- This package provides transactional variables with IO hooks. - See module 'Control.Concurrent.TFile' for a concrete instance. + See module Control.Concurrent.TFile for a (simple) instance of a 'TBox'+ that serializes its content to a file via 'Data.Binary'. .- Feedback appreciated!+ New in this release is the implementation of a skip list in module+ Control.Concurrent.TBox.TSkipList. A skip list is a probabilistic data+ structure that provides expected run time of /O(log n)/ for + dictionary operations (insert, lookup, filter, delete, update) similar to + a balanced tree. + The main advantage of a skip list is that it does not need rebalancing,+ which could cause lots of contention among transactions.+ The 'TFile' skip list instance tries to reconstruct its content from the+ 'TFile'-directory. See module Control.Concurrent.TFile.TSkipList for a+ usage example.+ .+ Feedback is highly appreciated! -Author: Peter Robinson 2009+Author: Peter Robinson 2009, 2010 Maintainer: Peter Robinson <thaldyron@gmail.com> License: LGPL License-file: LICENSE-Version: 0.0.0+Version: 0.1.0 Category: Data, Concurrency Stability: experimental Homepage: http://darcs.monoid.at/tbox@@ -23,28 +41,43 @@ ghc-options: -Wall -fno-ignore-asserts -fwarn-incomplete-patterns exposed-modules: Control.Concurrent.TBox- Control.Concurrent.TBox.Class- Control.Concurrent.TBox.Operations+ Control.Concurrent.TBox.Internal.Class+ Control.Concurrent.TBox.Internal.Operations+-- Control.Concurrent.TBox.TList+-- Control.Concurrent.TBox.THashtable+ Control.Concurrent.TBox.TSkipList Control.Concurrent.TFile+-- Control.Concurrent.TFile.TList+-- Control.Concurrent.TFile.THashtable+ Control.Concurrent.TFile.TSkipList -- other-modules: test.hs build-depends: base >= 4 && < 5, - stm-io-hooks >= 0.5.0 && < 0.6, + stm-io-hooks >= 0.6.0 && < 0.7, mtl >= 1.1.0.2 && < 1.2, binary >= 0.5 && < 0.6, filepath >= 1.1 && < 1.2, directory >= 1.0.0.3 && < 1.1,- cautious-file >= 0.1.5 && < 0.2--- containers >= 0.2.0.1 && < 0.3+ cautious-file >= 0.1.5 && < 0.2,+ array >= 0.2 && < 0.4,+ containers >= 0.2.0.1 && < 0.4,+ random >= 1.0.0.1 && < 1.1,+ monad-loops >= 0.3.0.2 && < 0.4.0.0,+ IfElse >= 0.85 && < 1,+ safe-failure >= 0.4.0 && < 0.5 extensions: MultiParamTypeClasses, -- RankNTypes, -- FunctionalDependencies, --- FlexibleContexts,+ FlexibleContexts, FlexibleInstances, -- UndecidableInstances, DeriveDataTypeable,+ ExistentialQuantification,+ TypeSynonymInstances,+ BangPatterns, ScopedTypeVariables -- TypeSynonymInstances+