acid-state 0.13.0 → 0.13.1

raw patch · 4 files changed

+32/−18 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• acid-state.cabal +1/−1
• src/Data/Acid/Log.hs +9/−6
• src/Data/Acid/Memory/Pure.hs +3/−3
• src/Data/Acid/TemplateHaskell.hs +19/−8

@@ -1,5 +1,5 @@ Name:                acid-state-Version:             0.13.0+Version:             0.13.1 Synopsis:            Add ACID guarantees to any serializable Haskell data structure. Description:         Use regular Haskell data structures as your database and get stronger ACID guarantees than most RDBMS offer. Homepage:            http://acid-state.seize.it/

@@ -43,6 +43,7 @@  import Paths_acid_state                          ( version ) import Data.Version                              ( showVersion )+import Control.Exception                         ( handle, IOException )  type EntryId = Int @@ -87,7 +88,8 @@   currentState <- newEmptyMVar   queue <- newTVarIO ([], [])   nextEntryRef <- newTVarIO 0-  tid2 <- forkIO $ fileWriter currentState queue+  tid1 <- myThreadId+  tid2 <- forkIO $ fileWriter currentState queue tid1   let fLog = FileLog { logIdentifier  = identifier                      , logCurrent     = currentState                      , logNextEntryId = nextEntryRef@@ -105,16 +107,17 @@              putMVar currentState handle   return fLog -fileWriter :: MVar FHandle -> TVar ([Lazy.ByteString], [IO ()]) -> IO ()-fileWriter currentState queue = forever $ do+fileWriter :: MVar FHandle -> TVar ([Lazy.ByteString], [IO ()]) -> ThreadId -> IO ()+fileWriter currentState queue parentTid = forever $ do   (entries, actions) <- atomically $ do     (entries, actions) <- readTVar queue     when (null entries && null actions) retry     writeTVar queue ([], [])     return (reverse entries, reverse actions)-  withMVar currentState $ \fd -> do-    let arch = Archive.packEntries entries-    writeToDisk fd (repack arch)+  handle (\e -> throwTo parentTid (e :: IOException)) $+    withMVar currentState $ \fd -> do+      let arch = Archive.packEntries entries+      writeToDisk fd (repack arch)   sequence_ actions   yield 

@@ -7,7 +7,7 @@ -- Maintainer  :  lemmih@gmail.com -- Portability :  non-portable (uses GHC extensions) ----- AcidState container without a transaction log. Mostly used for testing. +-- AcidState container without a transaction log. Mostly used for testing. --  module Data.Acid.Memory.Pure@@ -80,10 +80,10 @@  -- | Create an AcidState given an initial value. openAcidState :: IsAcidic st-              => st                          -- ^ Initial state value. +              => st                          -- ^ Initial state value.               -> AcidState st openAcidState initialState-    = AcidState { localMethods = mkMethodMap (eventsToMethods acidEvents) +    = AcidState { localMethods = mkMethodMap (eventsToMethods acidEvents)                 , localState   = initialState }  -- | Execute the 'Update' monad in a pure environment.

@@ -11,6 +11,7 @@ import Data.Acid.Common  import Data.List ((\\), nub)+import Data.Maybe (mapMaybe) import Data.SafeCopy import Data.Typeable import Data.Char@@ -91,7 +92,7 @@          cxts' <- mkCxtFromTyVars preds tyvars cxtFromEvents          instanceD (return cxts') ty                    [ valD (varP 'acidEvents) (normalB (listE handlers)) [] ]-    where stateType = foldl appT (conT stateName) [ varT var | PlainTV var <- tyvars ]+    where stateType = foldl appT (conT stateName) (map varT (allTyVarBndrNames tyvars))  -- | This function analyses an event function and extracts any -- additional class contexts which need to be added to the IsAcidic@@ -226,7 +227,7 @@ --    get = MyUpdateEvent <$> get <*> get makeSafeCopyInstance eventName eventType     = do let preds = [ ''SafeCopy ]-             ty = AppT (ConT ''SafeCopy) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ])+             ty = AppT (ConT ''SafeCopy) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars)))               getBase = appE (varE 'return) (conE eventStructName)              getArgs = foldl (\a b -> infixE (Just a) (varE '(<*>)) (Just (varE 'safeGet))) getBase args@@ -248,7 +249,7 @@           structName (x:xs) = toUpper x : xs  mkCxtFromTyVars preds tyvars extraContext-    = cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] +++    = cxt $ [ classP classPred [varT tyvar] | tyvar <- plainTyVarBndrNames tyvars, classPred <- preds ] ++             map return extraContext  {-@@ -259,9 +260,9 @@ -} makeMethodInstance eventName eventType     = do let preds = [ ''SafeCopy, ''Typeable ]-             ty = AppT (ConT ''Method) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ])-             structType = foldl appT (conT eventStructName) [ varT tyvar | PlainTV tyvar <- tyvars ]-         instanceD (cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ map return context)+             ty = AppT (ConT ''Method) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars)))+             structType = foldl appT (conT eventStructName) (map varT (allTyVarBndrNames tyvars))+         instanceD (cxt $ [ classP classPred [varT tyvar] | tyvar <- plainTyVarBndrNames tyvars, classPred <- preds ] ++ map return context)                    (return ty) #if __GLASGOW_HASKELL__ >= 707                    [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType))@@ -281,8 +282,8 @@ makeEventInstance eventName eventType     = do let preds = [ ''SafeCopy, ''Typeable ]              eventClass = if isUpdate then ''UpdateEvent else ''QueryEvent-             ty = AppT (ConT eventClass) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ])-         instanceD (cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ map return context)+             ty = AppT (ConT eventClass) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars)))+         instanceD (cxt $ [ classP classPred [varT tyvar] | tyvar <- plainTyVarBndrNames tyvars, classPred <- preds ] ++ map return context)                    (return ty)                    []     where (tyvars, context, _args, _stateType, _resultType, isUpdate) = analyseType eventName eventType@@ -327,3 +328,13 @@ tyVarBndrName :: TyVarBndr -> Name tyVarBndrName (PlainTV n)    = n tyVarBndrName (KindedTV n _) = n++plainTyVarBndrName :: TyVarBndr -> Maybe Name+plainTyVarBndrName (PlainTV name) = Just name+plainTyVarBndrName _ = Nothing++plainTyVarBndrNames :: [TyVarBndr] -> [Name]+plainTyVarBndrNames tyvars = mapMaybe plainTyVarBndrName tyvars++allTyVarBndrNames :: [TyVarBndr] -> [Name]+allTyVarBndrNames tyvars = map tyVarBndrName tyvars