Merge pull request #17 from metatexx/mtx-cleanup

Cleaning up, adjusting some demos and documentation

ChangeLog.md

@@ -0,0 +1,12 @@
+* 0.13.x : (WIP) Major refaktoring and cleanups may break older code
+* 0.12.1.0 : Dropped Data.Hashtable (deprecated). Now it uses the package hashtables
+* 0.12.0.0 : space in index data in indexQuery.hs and IndexText.hs triggered errors in the AWS backend.  The space has been changed by \'-\'. So rename the "index *" files in the TCache folder in order to be recognized.  
+* 0.11.0.0 : added setIndexParsist to define persistence for indexes by type. started the addition of readDBRefs, readResources and so on for simultaneous read, writes and deletes of objects of the same type.
+* 0.10.2.0 : Added setDefaultPersist and modified the signature of setPersist in Data.TCache.DefaultPersistence. Fixed issues with ghc 7.6.3
+* 0.10.0.0 : version add memoization and a persistent and transactional collection/queue.
+* 0.10.0.8 : subversion add cachedByKeySTM
+* 0.10.0.9 : fixed an error in clearSyncCacheProc and SynWrite Asynchronous that checked the cache continuously
+* 0.9.0.4 : Solves a bug in the management of weak pointers that evaporated registers from the cache
+* 0.9.0.3 : Solves a lost registers bug.
+* 0.9.0.1 : Solves a bug when object keys generate invalid filenames, and includes changes in defaultPersistence to further separate serialization from input-output.
+* 0.9.0.0 : Adds full-text indexing and search, which is incorporated into the experimental query language. It also changes the default Persistence mechanism. Now `ByteString`s are used for serialization and deserialization. A `Serializable` class and a `Persist` structure decouples serialization from `ByteString` and read/write to files. Both can be redefined separately, so the default persistence could be changed with `setPersist` to write to blobs in a databases, for example. Default persistence now no longer has to be in files.

Data/Persistent/Collection.hs

@@ -1,13 +1,6 @@
-{-# OPTIONS  -XDeriveDataTypeable
-             -XTypeSynonymInstances
-             -XMultiParamTypeClasses
-             -XExistentialQuantification
-             -XOverloadedStrings
-             -XFlexibleInstances
-             -XUndecidableInstances
-             -XFunctionalDependencies
-
-           #-}
+{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances,
+  MultiParamTypeClasses, ExistentialQuantification,
+  OverloadedStrings, FlexibleInstances, UndecidableInstances #-}
 
 {- |
 A persistent, transactional collection with Queue interface as well as
@@ -30,7 +23,7 @@ data.persistent collection
  implementar un btree sobre el
 -}
 module Data.Persistent.Collection (
-RefQueue(..), getQRef,
+RefQueue, getQRef,
 pop,popSTM,pick, flush, flushSTM,
 pickAll, pickAllSTM, push,pushSTM,
 pickElem, pickElemSTM,  readAll, readAllSTM,
@@ -43,14 +36,11 @@ import Control.Monad
 import Data.TCache.DefaultPersistence
 
 import Data.TCache
-import System.IO.Unsafe
-import Data.RefSerialize
-import Data.ByteString.Lazy.Char8
 import Data.RefSerialize
 
-import Debug.Trace
-
-a !> b= trace b a
+--import Debug.Trace
+--(!>) :: a -> String -> a
+--a !> b= trace b a
 
 
 
@@ -61,7 +51,7 @@ instance Indexable (Queue a) where
 
 
 
-data Queue a= Queue {name :: String, imp :: [a], out ::  [a]}  deriving (Typeable)
+data Queue a= Queue String [a] [a]  deriving (Typeable)
 
 
 
@@ -76,11 +66,11 @@ instance Serialize a => Serialize (Queue a) where
 
 
 
-
+queuePrefix :: String
 queuePrefix= "Queue#"
-lenQPrefix= Prelude.length queuePrefix
-
 
+lenQPrefix :: Int
+lenQPrefix= Prelude.length queuePrefix
 
 instance   Serialize a => Serializable (Queue a ) where
   serialize = runW . showp
@@ -123,7 +113,7 @@ flush = atomically . flushSTM
 
 -- | Version in the STM monad
 flushSTM ::  (Typeable a, Serialize a)  => RefQueue a -> STM ()
-flushSTM tv= delDBRef tv
+flushSTM = delDBRef
 
 -- | Read  the first element in the queue and delete it (pop)
 pop
@@ -153,7 +143,7 @@ popSTM tv=do
     where
 
     doit (Queue n [x] [])= do
-                 writeDBRef tv $  (Queue n  [] [])
+                 writeDBRef tv (Queue n  [] [])
                  return   x
     doit (Queue _ [] []) =  retry
     doit (Queue  n imp [])  =  doit  (Queue  n [] $ Prelude.reverse imp)
@@ -172,7 +162,7 @@ pick tv = atomically $ do
     doit (Queue _ [x] [])= return   x
     doit (Queue _ [] []) =  retry
     doit (Queue  n imp [])  =  doit  (Queue  n [] $ Prelude.reverse imp)
-    doit (Queue n imp  list ) = return  $ Prelude.head list
+    doit (Queue _ _  list ) = return  $ Prelude.head list
 
 -- | Push an element in the queue
 push  ::   (Typeable a, Serialize a)  => RefQueue a -> a -> IO ()
@@ -181,7 +171,7 @@ push tv v = atomically $ pushSTM tv v
 -- | Version in the STM monad
 pushSTM ::  (Typeable a, Serialize a)  => RefQueue a -> a -> STM ()
 pushSTM  tv   v=
-      readQRef tv  >>= \ ((Queue n  imp out))  -> writeDBRef tv  $ Queue n  (v : imp) out
+      readQRef tv  >>= \ (Queue n  imp out)  -> writeDBRef tv  $ Queue n  (v : imp) out
 
 -- | Return the list of all elements in the queue. The queue remains unchanged
 pickAll ::  (Typeable a, Serialize a)  => RefQueue a -> IO [a]
@@ -190,23 +180,23 @@ pickAll= atomically  . pickAllSTM
 -- | Version in the STM monad
 pickAllSTM :: (Typeable a, Serialize a)  => RefQueue a -> STM [a]
 pickAllSTM tv= do
-     (Queue name imp out) <- readQRef tv
+     (Queue _ imp out) <- readQRef tv
      return $ out ++ Prelude.reverse imp
 
 -- | Return the first element in the queue that has the given key
 pickElem ::(Indexable a,Typeable a, Serialize a) => RefQueue a -> String -> IO(Maybe a)
-pickElem tv key= atomically $ pickElemSTM tv key
+pickElem tv k= atomically $ pickElemSTM tv k
 
 -- | Version in the STM monad
 pickElemSTM :: (Indexable a,Typeable a, Serialize a)
                      => RefQueue a -> String -> STM(Maybe a)
-pickElemSTM tv key1=  do
-     Queue name imp out <- readQRef tv
-     let xs= out ++ Prelude.reverse imp
-     when (not $ Prelude.null imp) $ writeDBRef tv $ Queue name [] xs
-     case  Prelude.filter (\x-> key x == key1) xs of
-          []    -> return $ Nothing
-          (x:_) -> return $ Just  x
+pickElemSTM tv key1 = do
+  Queue name imp out <- readQRef tv
+  let xs = out ++ Prelude.reverse imp
+  unless (Prelude.null imp) $ writeDBRef tv $ Queue name [] xs
+  case Prelude.filter (\x -> key x == key1) xs of
+    [] -> return Nothing
+    (x:_) -> return $ Just x
 
 -- | Update the first element of the queue with a new element with the same key
 updateElem :: (Indexable a,Typeable a, Serialize a)
@@ -239,12 +229,12 @@ readAllSTM tv= do
 deleteElem :: (Indexable a,Typeable a, Serialize a) => RefQueue a-> a -> IO ()
 deleteElem tv x= atomically $ deleteElemSTM tv x
 
--- | Verison in the STM monad
+-- | Version in the STM monad
 deleteElemSTM :: (Typeable a, Serialize a,Indexable a) => RefQueue a-> a -> STM ()
 deleteElemSTM tv x= do
      Queue name imp out <- readQRef tv
      let xs= out ++ Prelude.reverse imp
-     writeDBRef tv $ Queue name [] $ Prelude.filter (\x-> key x /= k) xs
+     writeDBRef tv $ Queue name [] $ Prelude.filter (\x2-> key x2 /= k) xs
      where
      k=key x
 

Data/Persistent/IDynamic.hs

@@ -1,46 +1,30 @@
-    {-# OPTIONS -XExistentialQuantification
-            -XUndecidableInstances
-            -XScopedTypeVariables
-            -XDeriveDataTypeable
-            -XTypeSynonymInstances
-            -XIncoherentInstances
-            -XOverloadedStrings
-            -XMultiParamTypeClasses
-            -XFunctionalDependencies
-            -XFlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification, UndecidableInstances,
+      ScopedTypeVariables, DeriveDataTypeable, TypeSynonymInstances,
+      IncoherentInstances, OverloadedStrings, MultiParamTypeClasses,
+      FlexibleInstances #-}
+
 {- |
 IDynamic is a indexable and serializable version of Dynamic. (See @Data.Dynamic@). It is used as containers of objects
 in the cache so any new datatype can be incrementally stored without recompilation.
 IDimamic provices methods for safe casting,  besides serializaton, deserialirezation and retrieval by key.
 -}
 module Data.Persistent.IDynamic where
 import Data.Typeable
-import Unsafe.Coerce
 import System.IO.Unsafe
-import Data.TCache
-import Data.TCache.Defs
-import Data.RefSerialize
-import Data.Char (showLitChar)
 
 import Data.ByteString.Lazy.Char8 as B
 
-import Data.Word
-import Numeric (showHex, readHex)
-import Control.Exception(handle, SomeException, ErrorCall)
-import Control.Monad(replicateM)
-import Data.Word
-import Control.Concurrent.MVar
+import Control.Exception(handle, SomeException)
 import Data.IORef
-import Data.Map as M(empty)
 import Data.RefSerialize
 
 --import Debug.Trace
 --(!>)= flip trace
 
 
-data IDynamic  =  IDyn  (IORef IDynType) deriving Typeable
+newtype IDynamic  =  IDyn  (IORef IDynType) deriving Typeable
 
-data IDynType= forall a w r.(Typeable a, Serialize a)
+data IDynType= forall a.(Typeable a, Serialize a)
                => DRight !a
              |  DLeft  !(ByteString ,(Context, ByteString))
 
@@ -49,6 +33,7 @@ data IDynType= forall a w r.(Typeable a, Serialize a)
 
 newtype Save= Save ByteString deriving Typeable
 
+tosave :: IDynamic -> IDynamic
 tosave d@(IDyn r)= unsafePerformIO $ do
    mr<- readIORef r
    case mr of
@@ -61,12 +46,18 @@ instance Serialize Save  where
   readp = error "readp not impremented for Save"
 
 
+errorfied :: String -> String -> a
 errorfied str str2= error $ str ++ ": IDynamic object not reified: "++ str2
 
 
 
+dynPrefix :: String
 dynPrefix= "Dyn"
+
+dynPrefixSp :: ByteString
 dynPrefixSp= append  (pack dynPrefix) " "
+
+notreified :: ByteString
 notreified = pack $ dynPrefix ++" 0"
 
 
@@ -77,7 +68,7 @@ instance Serialize IDynamic where
     case unsafePerformIO $ readIORef t of
      DRight x -> do
 --          insertString $ pack dynPrefix
-          c <- getWContext
+          _ <- getWContext
           showpx  <-  rshowps x
 --          showpText . fromIntegral $ B.length showpx
           showp $ unpack showpx
@@ -112,9 +103,11 @@ instance Show  IDynamic where
 
 
 
+toIDyn :: (Typeable a, Serialize a) => a -> IDynamic
 toIDyn x= IDyn . unsafePerformIO . newIORef $ DRight x
 
 -- | check if a (possibly polimorphic) value within a IDynamic value has the given serialization"
+serializedEqual :: IDynamic -> ByteString -> Bool
 serializedEqual (IDyn r) str= unsafePerformIO $ do
   t <- readIORef r
   case t of
@@ -128,29 +121,30 @@ fromIDyn x= case safeFromIDyn x of
 
 
 safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Either String a
-safeFromIDyn (d@(IDyn r))= final where
- final= unsafePerformIO $ do
-  t <- readIORef r
-  case t of
-   DRight x ->  return $ case cast x of
-        Nothing -> Left $ "fromIDyn: unable to extract from "
-                     ++ show d ++ " something of type: "
-                     ++ (show . typeOf $ fromRight final)
-        Just x  -> Right x
-        where
-        fromRight (Right x)= x
-
-
-   DLeft (str, c) ->
-    handle (\(e :: SomeException) ->  return $ Left (show e)) $  -- !> ("safeFromIDyn : "++ show e)) $
-        do
-          let v= runRC  c rreadp str    -- !> unpack str
-          writeIORef r $! DRight v      -- !> ("***reified "++ unpack str)
-          return $! Right v             -- !>  ("*** end reified " ++ unpack str)
+safeFromIDyn d@(IDyn r) = final
+  where
+    final =
+      unsafePerformIO $ do
+        t <- readIORef r
+        case t of
+          DRight x ->
+            return $
+            case cast x of
+              Nothing ->
+                Left $
+                "fromIDyn: unable to extract from " ++
+                show d ++ " something of type: " ++ (show . typeOf $ fromRight final)
+              Just x' -> Right x'
+            where fromRight (Right x') = x'
+                  fromRight (Left _') = error "this will never happen?"
+          DLeft (str, c) ->
+            handle (\(e :: SomeException) -> return $ Left (show e)) $ -- !> ("safeFromIDyn : "++ show e)) $
+             do
+              let v = runRC c rreadp str -- !> unpack str
+              writeIORef r $! DRight v -- !> ("***reified "++ unpack str)
+              return (Right v)             -- !>  ("*** end reified " ++ unpack str)
 
 
 
 reifyM :: (Typeable a,Serialize a) => IDynamic -> a -> IO a
-reifyM dyn v = do
-   let v'= fromIDyn dyn
-   return $ v' `seq` v'
+reifyM dyn _ = return $ fromIDyn dyn