Commits

Grzegorz Chrupała  committed 6c1bcb3

Added monad-atom-experimental.

  • Participants
  • Parent commits dccfdc7

Comments (0)

Files changed (1)

File monad-atom-experimental/Control/Monad/ST/Atom.hs

+{-# LANGUAGE  GeneralizedNewtypeDeriving 
+  , NoMonomorphismRestriction 
+  , MultiParamTypeClasses
+  , TypeFamilies
+  , FlexibleInstances
+  , FlexibleContexts
+  , DeriveGeneric 
+  , BangPatterns #-}
+
+module Control.Monad.ST.Atom
+       ( Atom
+       , AtomTable
+       , initialize
+       , toAtom
+       , runAtom
+       )
+
+where
+import Control.Applicative
+import Control.Monad.Reader
+import Control.Monad.ST.Lazy (runST, ST, strictToLazyST)
+
+import Control.Monad.Identity
+import qualified Data.HashTable.ST.Basic as H
+import Data.Hashable (Hashable)
+
+import Data.STRef.Lazy
+import GHC.Generics (Generic)
+
+type HashTable s k v = H.HashTable s k v
+
+data AtomTable s a = T { lastID :: !(STRef s Int)
+                       , to :: !(HashTable s a Int) 
+                       }
+
+newtype Atom s a r = Atom { unAtom :: ReaderT (AtomTable s a) (ST s) r }
+                   deriving (Functor, Applicative, Monad)
+
+
+initialize :: ST s (AtomTable s a)
+initialize = do
+   i <- newSTRef (0::Int)
+   h <- strictToLazyST $ H.newSized 1000
+   return $! T i h
+
+toAtom :: (Eq a, Hashable a) => a -> Atom s a Int
+toAtom x = Atom $ do
+  t@(T ir h) <- ask
+  i <- lift $ readSTRef ir
+  r <- lift $ strictToLazyST $ H.lookup h x
+  case r of
+    Just j -> return $! j
+    Nothing -> do
+      let i' = i + 1
+      lift $ strictToLazyST $ H.insert h x i'    
+      lift $ writeSTRef ir i'
+      return $! i'
+
+runAtom :: Atom s a b -> ST s (AtomTable s a) -> ST s b      
+runAtom (Atom x) e = runReaderT x =<< e
+