Commits

Grzegorz Chrupała committed dccfdc7

New implementation based on type functions.

Comments (0)

Files changed (3)

monad-atom/Control/Monad/Atom.hs

-{-# LANGUAGE  GeneralizedNewtypeDeriving 
-  , NoMonomorphismRestriction 
+{-# LANGUAGE  GeneralizedNewtypeDeriving
+  , NoMonomorphismRestriction
+  , MultiParamTypeClasses
+  , TypeFamilies
   , FlexibleInstances
+  , FlexibleContexts
+  , DeriveGeneric
   , BangPatterns #-}
+-- | The Atom monad provides functions which convert objects to unique
+-- atoms (represented as Ints). Example:
+--
+-- > example = evalAtom $ do
+-- >   xs <- mapM toAtom "abcabd"
+-- >   zs <- mapM fromAtom xs
+-- >   return $ zip zs xs
+--
+-- >>> example
+-- >>> [('a',0),('b',1),('c',2),('a',0),('b',1),('d',3)]
+
 module Control.Monad.Atom
-    ( MonadAtom (..)
-    , AtomTable
+    ( AtomTable
     , Atom
-    , AtomT
+    , toAtom
+    , fromAtom
+    , maybeToAtom
     , empty
     , evalAtom
-    , evalAtomT
     , runAtom
-    , runAtomT
-    , atoms
+    , mapping
     )
 where
 import Control.Monad.State
 import Control.Monad.Identity
 import qualified Data.Map as Map
 import qualified Data.IntMap as IntMap
-import qualified Data.Serialize as Serialize
-import Data.Serialize (Serialize)
-import qualified Data.ByteString as Strict
-import qualified Data.Vector.Unboxed as U
-import Data.Word
+import GHC.Generics (Generic)
 
-type Blob = U.Vector Word8
+-- | @AtomTable@ holds the state necessary for converting to and from
+-- @Int@s.
+data AtomTable a = T { lastID :: {-# UNPACK #-} !Int
+                     , to     :: !(Map.Map a Int)
+                     , from   :: !(IntMap.IntMap a) }
+                   deriving (Generic)
 
-data AtomTable = T { lastID :: {-# UNPACK #-} !Int 
-                   , to     :: !(Map.Map Blob Int)
-                   , from   :: !(IntMap.IntMap Blob) } 
-                   
 
-instance Serialize AtomTable where
-    put t = do Serialize.put (lastID t) 
-               Serialize.put (to t)
-               Serialize.put (from t)
-    get = do liftM3 T Serialize.get Serialize.get Serialize.get
+-- | @AtomT@ is a specialized state monad transformer for converting
+-- to and from @Int@s.
+newtype AtomT a m r = AtomT (StateT (AtomTable a) m r)
+   deriving (Functor, Monad, MonadTrans, MonadIO)
+-- | @Atom@ is a specialized state monad for converting to and from
+-- @Int@s.
+newtype Atom a r = Atom (AtomT a Identity r)
+   deriving (Functor, Monad)
 
-instance Serialize (U.Vector Word8) where
-  put v = Serialize.put . Strict.pack . U.toList $ v
-  get = do x <- Serialize.get
-           return . U.fromList . Strict.unpack $ x
+class (Monad m) => MonadAtom m where
+  type Key m
+  -- | @toAtom x@ converts @x@ to a unique @Int@ in the @Atom@ monad
+  toAtom :: Key m -> m Int
+  -- | @maybeToAtom x@ converts @x@ to a unique @Int@ in the @Atom@
+  -- monad only if @x@ already has a corresponding @Int@
+  maybeToAtom :: Key m -> m (Maybe Int)
+  -- | @fromAtom i@ converts the @Int@ @i@ to its corresponding object
+  -- in the Atom monad.
+  fromAtom :: Int -> m (Key m)
+instance (Ord a, Monad m) => MonadAtom (AtomT a m) where
+  type Key (AtomT a m) = a
+  toAtom = AtomT . toAtom'
+  {-# INLINE toAtom #-}
+  maybeToAtom = AtomT . maybeToAtom'
+  {-# INLINE maybeToAtom #-}
+  fromAtom = AtomT . fromAtom'
+  {-# INLINE fromAtom #-}
+instance (Ord a) => MonadAtom (Atom a) where
+  type Key (Atom a) = a
+  toAtom = Atom . toAtom
+  {-# INLINE toAtom #-}
+  maybeToAtom = Atom . maybeToAtom
+  {-# INLINE maybeToAtom #-}
+  fromAtom = Atom . fromAtom
+  {-# INLINE fromAtom #-}
 
-class Monad m => MonadAtom m where
-    -- | Monadically convert the argument into an atom (represented as an Int)
-    toAtom      :: Serialize a => a -> m Int
-    -- | Monadically convert the argument into an atom, but only if 
-    -- the corresponding atom has already been created
-    maybeToAtom :: Serialize a => a -> m (Maybe Int)
-    -- | Monadically convert an atom represented as an Int to its 
-    -- corresponding object
-    fromAtom    :: Serialize a => Int -> m a
+-- | @runAtomT c s@ runs computation c in the AtomT monad transformer
+-- with the initial @AtomTable@ s.
+runAtomT :: (Ord a, Monad m) => AtomT a m r -> AtomTable a -> m (r, AtomTable a)
+runAtomT (AtomT x) = runStateT x 
+{-# INLINE runAtomT #-}
 
+-- | @runAtom c s@ runs computation c in the Atom monad with the
+-- initial @AtomTable@ s.
+runAtom :: (Ord a) => Atom a r -> AtomTable a -> (r, AtomTable a)
+runAtom (Atom x) s = runIdentity (runAtomT x s)
+{-# INLINE runAtom #-}
 
-instance Monad m => MonadAtom (AtomT m) where
-    toAtom x = AtomT $ do
-      let b = enc x
-      t <- get
-      case Map.lookup b (to t) of
-        Just j -> return $! j
-        Nothing -> do 
-                 let i = lastID t
-                     i' = i + 1 
-                     !t' = t { lastID = i'
-                             , to = Map.insert b  i (to t) 
-                             , from = IntMap.insert i b (from t) }
-                 put t'
-                 return $! lastID t
+-- | @evalAtomT c@ runs computation c in the AtomT monad transformer
+-- with the empty initial @AtomTable@.
+evalAtomT :: (Ord a, Monad m) => AtomT a m r -> m r
+evalAtomT (AtomT x) = evalStateT x empty
+{-# INLINE evalAtomT #-}
 
-    maybeToAtom x = 
-        AtomT $ do
-          t <- get
-          return $! Map.lookup (enc x) . to $ t
-            
-    fromAtom i = AtomT $ do
-      t <- get
-      return $! dec $ (from t) IntMap.! i
+-- | @evalAtom c@ runs computation c in the Atom monad with the empty
+-- initial @AtomTable@.
+evalAtom :: (Ord a) => Atom a r -> r
+evalAtom (Atom x) = runIdentity (evalAtomT x)
+{-# INLINE evalAtom #-}
 
-empty :: AtomTable
+toAtom' :: (Monad m, Ord a) => a -> StateT (AtomTable a) m Int
+toAtom' x = do
+  let b = x
+  t <- get
+  case Map.lookup b (to t) of
+    Just j -> return $! j
+    Nothing -> do
+      let i = lastID t
+          i' = i + 1
+          !t' = t { lastID = i'
+                  , to = Map.insert b  i (to t)
+                  , from = IntMap.insert i b (from t) }
+      put $! t'
+      return $! lastID t
+{-# SPECIALIZE toAtom' :: (Ord a) => a -> StateT (AtomTable a) Identity Int #-}
+
+maybeToAtom' :: (Ord a, Monad m) =>
+                a -> StateT (AtomTable a) m (Maybe Int)
+maybeToAtom' x = do
+  t <- get
+  return $! Map.lookup x . to $ t
+{-# SPECIALIZE  maybeToAtom' :: (Ord a) =>
+                a -> StateT (AtomTable a) Identity (Maybe Int) #-}
+
+fromAtom' ::  Monad m => Int -> StateT (AtomTable a) m a
+fromAtom' i = do
+  t <- get
+  return $! from t IntMap.! i
+{-# SPECIALIZE fromAtom' :: Int -> StateT (AtomTable a) Identity a #-}
+
+-- | @empty@ is the initial empty @AtomTable@
+empty :: (Ord a) => AtomTable a
 empty = T 0 Map.empty IntMap.empty
 
-runAtomT :: AtomT t t1 -> AtomTable -> t (t1, AtomTable)
-runAtomT (AtomT x) s = runStateT x s
+-- | The mapping stored in the atom table
+mapping :: (Ord a) => AtomTable a -> Map.Map a Int
+mapping = to
+{-# INLINE mapping #-}
 
-runAtom :: Atom t -> AtomTable -> (t, AtomTable)
-runAtom (Atom x) s = runIdentity (runAtomT x s)
-
-
-evalAtom :: Atom t -> t
-evalAtom = fst . flip runAtom empty
-
-evalAtomT :: (Monad m) => AtomT m a -> m a
-evalAtomT = liftM fst . flip runAtomT empty
-
-newtype AtomT m r = AtomT (StateT AtomTable m r)
-    deriving (Functor,Monad,MonadTrans,MonadIO)
-
-newtype Atom r = Atom (AtomT Identity r)
-    deriving (Functor,Monad,MonadAtom)
-
--- | The list of atoms (as Ints) stored in the atom table
-atoms :: AtomTable -> [Int]
-atoms = IntMap.keys . from
-
--- FIXME: more efficient conversion from ByteString
-enc :: Serialize a => a -> Blob
-enc = U.fromList . Strict.unpack . Serialize.encode
-
-dec :: Serialize a => Blob -> a
-dec bs = case Serialize.decode . Strict.pack . U.toList $ bs of
-  Left err -> error (show err)
-  Right r -> r
-
-
-example :: [String]
-example = evalAtom $ do 
-  xs <- mapM toAtom . map show $ [1,2,3,1,2,3]
-  zs <- mapM fromAtom xs 
-  return zs

monad-atom/LICENSE

-Copyright (c)2011, Grzegorz Chrupała
+Copyright (c)2012, Grzegorz Chrupała
 
 All rights reserved.
 

monad-atom/monad-atom.cabal

 -- The package version. See the Haskell package versioning policy
 -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
 -- standards guiding when and how versions should be incremented.
-Version:             0.4.1
+Version:             0.4.0
 
 -- A short (one-line) description of the package.
-Synopsis:            Monadically convert objects to unique atoms and back.
+Synopsis:            Monadically convert object to unique integers and back.
 
 -- A longer description of the package.
-Description:         Monadically convert objects to unique atoms and back.
+-- Description:         
+
+-- URL for the project homepage or repository.
+Homepage:            https://bitbucket.org/gchrupala/lingo
 
 -- The license under which the package is released.
 License:             BSD3
 
 -- Extra files to be distributed with the package, such as examples or
 -- a README.
--- Extra-source-files:  
+Extra-source-files:  README
 
 -- Constraint on the version of Cabal needed to build this package.
 Cabal-version:       >=1.2
   Exposed-modules:     Control.Monad.Atom
   
   -- Packages needed in order to build this package.
-  Build-depends: base >= 3 && < 5, bytestring >= 0.9, cereal >= 0.3.5,
-                 containers >= 0.4, mtl >= 2.0 , vector >= 0.9
-
+  Build-depends:  base >=3 && <5
+                , mtl >=2.0
+                , containers >=0.4
+                , ghc-prim >= 0.2
   -- Modules not exported by this package.
   -- Other-modules:       
   
   -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
   -- Build-tools:         
-  
+  GHC-options: -O2  
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.