xhb-atom-cache (empty) → 0.1.0.0
raw patch · 4 files changed
+216/−0 lines, 4 filesdep +basedep +hashabledep +mtlsetup-changed
Dependencies added: base, hashable, mtl, transformers, unordered-containers, xhb
Files
- LICENSE +26/−0
- Setup.hs +2/−0
- src/Graphics/XHB/AtomCache.hs +148/−0
- xhb-atom-cache.cabal +40/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015, Jochen Keil+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Graphics/XHB/AtomCache.hs view
@@ -0,0 +1,148 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module Graphics.XHB.AtomCache+ ( AtomId(..)+ , AtomLike(..)+ , AtomCacheT(..)+ , AtomCacheCtx(..)+ , AtomName+ , atomName+ , runAtomCacheT+ , seedAtoms+ , tryLookupAtom+ ) where++import Control.Applicative (Applicative, (<$>))+import Control.Monad.Except (MonadError(..), ExceptT(..), runExceptT)+import Control.Monad.Reader (MonadReader(..))+import Control.Monad.State (MonadState(..), StateT(..), evalStateT, get, gets, modify)+import Control.Monad.Writer (MonadWriter(..))+import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.IO.Class (MonadIO(..))+import Data.Word (Word32)+import Data.Hashable (Hashable(..))+import Data.HashMap.Lazy (HashMap)+import Data.Typeable (Typeable, cast)+import Graphics.XHB (Connection, SomeError, ATOM, InternAtom(..))+import qualified Data.HashMap.Lazy as M+import qualified Graphics.XHB as X++-- TODO: pull in to Graphics.XHB repo+instance Hashable ATOM where+ hashWithSalt s a = (s +) . fromIntegral $ (X.fromXid . X.toXid $ a :: Word32)++class (Eq l, Hashable l, Typeable l) => AtomLike l where+ toAtom :: l -> AtomId+ toAtom = AtomId++ fromAtom :: AtomId -> Maybe l+ fromAtom (AtomId a) = cast a++ toAtomName :: l -> AtomName++atomName :: AtomId -> AtomName+atomName (AtomId a) = toAtomName a++data AtomId = forall l. AtomLike l => AtomId l+ deriving Typeable++instance Eq AtomId where+ AtomId a == AtomId b = maybe False (b ==) (cast a)++instance Hashable AtomId where+ hashWithSalt s (AtomId a) = hashWithSalt s a++type AtomName = String++type AtomState = (HashMap AtomId ATOM, HashMap ATOM AtomId)++newtype AtomCacheT m a = AtomCacheT { unAtomT :: StateT AtomState m a }+ deriving (Applicative, Functor, Monad, MonadIO, Typeable)++instance MonadTrans AtomCacheT where+ lift = AtomCacheT . lift++eitherToExcept :: Monad m => Either e a -> ExceptT e m a+eitherToExcept = ExceptT . return++runAtomCacheT :: Monad m => AtomCacheT m a -> m a+runAtomCacheT = flip evalStateT (M.empty, M.empty) . unAtomT++-- | Preseed the atom cache with `ATOM`s+-- Example:+-- @ > let atoms = ["_NET_CLIENT_LIST", "_NET_NUMBER_OF_DESKTOPS"] @+-- @ > fromJust <$> X.connect >>= \c -> runAtomCacheT . seedAtoms c atoms $ mapM_ (\n -> unsafeLookupAtom n >>= liftIO . print) @+seedAtoms :: (AtomLike l, Applicative m, MonadIO m)+ => Connection -> [l] -> AtomCacheT m a -> AtomCacheT m (Either SomeError a)+seedAtoms _ [] m = Right <$> m+seedAtoms c as (AtomCacheT m) = AtomCacheT . runExceptT $ do+ atoms <- mapM eitherToExcept =<< mapM (internAtom c) (map toAtomName as)+ modify $ \(f, s) -> (f `M.union` fs atoms, s `M.union` ss atoms)+ lift m+ where+ atomids = map toAtom as+ fs = M.fromList . zip atomids+ ss = M.fromList . flip zip atomids++internAtom :: MonadIO m => Connection -> AtomName -> m (Either SomeError ATOM)+internAtom c name = liftIO $ X.internAtom c request >>= X.getReply+ where request = MkInternAtom True (fromIntegral $ length name) (X.stringToCList name)++-- | Lookup AtomName in cache first, if that fails, try to fetch from the+-- X server and put it into the cache+tryLookupAtom :: (AtomLike l, AtomCacheCtx m, MonadIO m)+ => Connection -> l -> m (Either SomeError ATOM)+tryLookupAtom c a = lookupATOM a >>= \case+ Just atom -> return $ Right atom+ Nothing -> runExceptT $ do+ atom <- eitherToExcept =<< internAtom c (toAtomName a)+ insertATOM a atom+ return atom++class Monad m => AtomCacheCtx m where+ insertATOM :: AtomLike l => l -> ATOM -> m ()+ lookupATOM :: AtomLike l => l -> m (Maybe ATOM)+ unsafeLookupATOM :: AtomLike l => l -> m ATOM+ lookupAtomId :: ATOM -> m (Maybe AtomId)+ unsafeLookupAtomId :: ATOM -> m AtomId++instance Monad m => AtomCacheCtx (AtomCacheT m) where+ insertATOM n a = AtomCacheT . modify $ \(na, an) -> (M.insert (toAtom n) a na, M.insert a (toAtom n) an)+ lookupATOM n = AtomCacheT . gets $ M.lookup (toAtom n) . fst+ unsafeLookupATOM n = AtomCacheT . gets $ (M.! (toAtom n)) . fst+ lookupAtomId a = AtomCacheT . gets $ M.lookup a . snd+ unsafeLookupAtomId a = AtomCacheT . gets $ (M.! a) . snd++instance MonadError e m => MonadError e (AtomCacheT m) where+ throwError = lift . throwError+ catchError (AtomCacheT m) f = AtomCacheT $ catchError m (unAtomT . f)++instance (AtomCacheCtx m, MonadTrans t, Monad (t m)) => AtomCacheCtx (t m) where+ insertATOM n = lift . insertATOM n+ lookupATOM = lift . lookupATOM+ unsafeLookupATOM = lift . unsafeLookupATOM+ lookupAtomId = lift . lookupAtomId+ unsafeLookupAtomId = lift . unsafeLookupAtomId++instance MonadReader r m => MonadReader r (AtomCacheT m) where+ ask = lift ask+ local f = AtomCacheT . local f . unAtomT++instance MonadState s m => MonadState s (AtomCacheT m) where+ get = lift get+ put = lift . put++instance MonadWriter w m => MonadWriter w (AtomCacheT m) where+ tell = lift . tell+ listen = AtomCacheT . listen . unAtomT+ pass = AtomCacheT . pass . unAtomT
+ xhb-atom-cache.cabal view
@@ -0,0 +1,40 @@+name: xhb-atom-cache+version: 0.1.0.0+synopsis: Atom cache for XHB+description: Atom cache for XHB+license: BSD2+license-file: LICENSE+author: Jochen Keil+maintainer: Jochen Keil <jochen.keil+xhb-atom-cache@gmail.com>+homepage: http://github.com/jotrk/xhb-atom-cache/+bug-reports: http://github.com/jotrk/xhb-atom-cache/issues++category: Graphics+build-type: Simple++cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/jotrk/xhb-atom-cache.git++library+ build-depends: base >= 4.7 && < 4.8,+ mtl >= 2.2 && < 3.0,+ transformers >= 0.4 && < 0.5,+ xhb >= 0.5 && < 0.6,+ hashable >= 1.2 && < 1.3,+ unordered-containers >= 0.2.5 && < 0.3++ exposed-modules: Graphics.XHB.AtomCache++ other-extensions: DeriveDataTypeable,+ FlexibleContexts,+ FlexibleInstances,+ GeneralizedNewtypeDeriving,+ OverlappingInstances,+ UndecidableInstances++ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: src