Skip to content

Commit

Permalink
Hide acid-state code from ghcjs
Browse files Browse the repository at this point in the history
  • Loading branch information
ddssff committed Apr 5, 2019

Verified

This commit was created on GitHub.com and signed with GitHub’s verified signature.
1 parent 035236a commit 59e0166
Showing 4 changed files with 15 additions and 12 deletions.
20 changes: 13 additions & 7 deletions Appraisal/AcidCache.hs
Original file line number Diff line number Diff line change
@@ -19,6 +19,7 @@ module Appraisal.AcidCache
CacheMap(..)
, CacheValue(..), _InProgress, _Cached, _Failed
, unCacheMap
#if !__GHCJS__
, initCacheMap
, openCache
, withCache
@@ -38,21 +39,24 @@ module Appraisal.AcidCache
, cacheDelete
-- * Instance
-- , runMonadCacheT
#endif
) where

import Control.Lens ((%=), at, makeLenses, makePrisms, view)
import Data.Generics (Data, Proxy, Typeable)
import Data.Map.Strict as Map (delete, difference, fromSet, insert, intersection, Map, union)
import Data.SafeCopy -- (deriveSafeCopy, extension, Migrate(..), SafeCopy)
import Data.Serialize (label, Serialize)
import GHC.Generics (Generic)
#if !__GHCJS__
import Control.Monad.Catch (bracket, {-MonadCatch,-} MonadMask)
import Control.Monad.Reader (MonadReader(ask))
import Control.Monad.State (liftIO)
import Data.Acid (AcidState, makeAcidic, openLocalStateFrom, Query, query, Update, update)
import Data.Acid.Local (createCheckpointAndClose)
import Data.Generics (Data, Proxy, Typeable)
import Data.Map.Strict as Map (delete, difference, fromSet, insert, intersection, Map, union)
import Data.SafeCopy -- (deriveSafeCopy, extension, Migrate(..), SafeCopy)
import Data.Serialize (label, Serialize)
import Data.Set as Set (Set)
import Extra.Except (liftIOError, MonadIO, MonadIOError)
import GHC.Generics (Generic)
#endif

data CacheValue err val
= InProgress
@@ -94,6 +98,7 @@ instance (Ord key, SafeCopy key, SafeCopy val) => Migrate (CacheMap key val err)
type MigrateFrom (CacheMap key val err) = Map key val
migrate mp = CacheMap (fmap Cached mp)

#if !__GHCJS__
-- | Install a key/value pair into the cache.
putValue :: Ord key => key -> CacheValue err val -> Update (CacheMap key val err) ()
putValue key img = unCacheMap %= Map.insert key img
@@ -123,11 +128,11 @@ deleteValue key = unCacheMap %= Map.delete key
deleteValues :: Ord key => Set key -> Update (CacheMap key val err) ()
deleteValues keys = unCacheMap %= (`Map.difference` (Map.fromSet (const ()) keys))

$(makeAcidic ''CacheMap ['putValue, 'putValues, 'lookValue, 'lookValues, 'lookMap, 'deleteValue, 'deleteValues])

initCacheMap :: Ord key => CacheMap key val err
initCacheMap = CacheMap mempty

$(makeAcidic ''CacheMap ['putValue, 'putValues, 'lookValue, 'lookValues, 'lookMap, 'deleteValue, 'deleteValues])

openCache :: (SafeCopy key, Typeable key, Ord key,
SafeCopy err, Typeable err,
SafeCopy val, Typeable val) => FilePath -> IO (AcidState (CacheMap key val err))
@@ -177,3 +182,4 @@ cacheDelete :: forall key val err m. (HasCache key val err m) => Proxy (val, err
cacheDelete _ keys = do
(st :: AcidState (CacheMap key val err)) <- askCacheAcid
liftIO $ update st (DeleteValues keys)
#endif
3 changes: 0 additions & 3 deletions Appraisal/FileError.hs
Original file line number Diff line number Diff line change
@@ -35,7 +35,6 @@ import Data.Data (Data)
import Data.SafeCopy (base, deriveSafeCopy)
import Data.Serialize (Serialize)
import Data.Text (pack, Text, unpack)
import Debug.Show (V(V))
import Extra.Except (HasIOException(fromIOException))
import Extra.Orphans ({-instance Serialize Text-})
import GHC.Generics (Generic)
@@ -66,8 +65,6 @@ data CommandInfo
| Description String CommandInfo -- ^ free form description of what happened
deriving (Data, Eq, Ord, Show, Generic, Serialize)

instance Show (V FileError) where show (V x) = show x

instance Loggable FileError where
logit priority loc (IOException e) = liftIO (logM (loc_module loc) priority (" - IO exception: " <> unpack e))
logit priority loc (ErrorCall e) = liftIO (logM (loc_module loc) priority (" - error call: " <> show e))
2 changes: 1 addition & 1 deletion Appraisal/LogException.hs
Original file line number Diff line number Diff line change
@@ -9,8 +9,8 @@ module Appraisal.LogException

import Control.Monad.Except (MonadError(catchError, throwError))
import Control.Monad.Trans (MonadIO(..))
import Debug.Show (V(V))
import Language.Haskell.TH (ExpQ, Exp, Loc(..), location, pprint, Q)
import Language.Haskell.TH.Instances ()
import qualified Language.Haskell.TH.Lift as TH (Lift(lift))
import System.Log.Logger (Priority, logM)

2 changes: 1 addition & 1 deletion image-cache.cabal
Original file line number Diff line number Diff line change
@@ -63,7 +63,6 @@ Library
Appraisal.Serialize
Appraisal.Utils.ErrorWithIO
Build-Depends:
acid-state,
base >= 4,
binary,
bytestring,
@@ -101,6 +100,7 @@ Library
utf8-string
if !impl(ghcjs)
Build-Depends:
acid-state,
filemanip-extra
else
Build-Depends: Cabal

0 comments on commit 59e0166

Please sign in to comment.