fix reset on index

Data/Persistent/IDynamic.hs

@@ -36,15 +36,15 @@ import Data.Map as M(empty)
 import Data.RefSerialize
 import Data.HashTable as HT
 
---import Debug.Trace
---(!>)= flip trace
+import Debug.Trace
+(!>)= flip trace
 
 
 data IDynamic  =  IDyn  (IORef IDynType) deriving Typeable
 
 data IDynType= forall a w r.(Typeable a, Serialize a)
-               => DRight  !a
-               |  DLeft  !(ByteString ,(Context, ByteString))
+               => DRight !a
+             |  DLeft  !(ByteString ,(Context, ByteString))
 
 
                deriving Typeable
@@ -116,18 +116,23 @@ instance Show  IDynamic where
 
 toIDyn x= IDyn . unsafePerformIO . newIORef $ DRight x
 
-
+-- | check if a (possibly polimorphic) value within a IDynamic value has the given serialization"
+serializedEqual (IDyn r) str= unsafePerformIO $ do
+  t <- readIORef r
+  case t of
+   DRight x -> return $ runW (showp x) == str   !> ("R "++ (show $ unpack $ runW (showp x)))
+   DLeft (str', _) -> return $ str== str'       !> ("L "++ (show $ unpack str' ))
+
 fromIDyn :: (Typeable a , Serialize a)=> IDynamic -> a
-fromIDyn x=r where
-  r = case safeFromIDyn x of
-          Left s -> error s
+fromIDyn x= case safeFromIDyn x of
+          Left  s -> error s
           Right v -> v
 
 
 safeFromIDyn :: (Typeable a, Serialize a) => IDynamic -> Either String a       
 safeFromIDyn (d@(IDyn r))= final where
  final= unsafePerformIO $ do
-  t<-  readIORef r
+  t <- readIORef r
   case t of
    DRight x ->  return $ case cast x of
         Nothing -> Left $ "fromIDyn: unable to extract from "
@@ -141,9 +146,9 @@ safeFromIDyn (d@(IDyn r))= final where
    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)
+          let v= runRC  c rreadp str    -- !> unpack str
+          writeIORef r $! DRight v      -- !> ("***reified "++ unpack str)
+          return $! Right v             -- !>  ("*** end reified " ++ unpack str)
 
 
 

Data/TCache/IndexQuery.hs

@@ -73,7 +73,15 @@ fields in a registers are to be indexed, they must have different types.
 {-# LANGUAGE  DeriveDataTypeable, MultiParamTypeClasses
 , FunctionalDependencies, FlexibleInstances, UndecidableInstances
 , TypeSynonymInstances, IncoherentInstances #-}
-module Data.TCache.IndexQuery(index, RelationOps(..), indexOf, recordsWith, (.&&.), (.||.), Select(..)) where
+module Data.TCache.IndexQuery(
+index
+, RelationOps((.==.),(.<.),(.<=.),(.>=.),(.>.))
+, indexOf
+, recordsWith
+, (.&&.)
+, (.||.)
+, Select(..))
+where
 
 import Data.TCache
 import Data.TCache.Defs
@@ -189,8 +197,11 @@ index sel= do
    let [one, two]= typeRepArgs $! typeOf sel
        rindex= getDBRef $! keyIndex one two
    addTrigger $ selectorIndex sel rindex
-   withResources [] $ const  [ (Index M.empty  `asTypeOf` indexsel sel )]
+   let proto= Index M.empty  `asTypeOf` indexsel sel
+   withResources [proto]  $ init proto
    where
+   init proto [Nothing]  =  [proto]
+   init _ [Just _] = []
    indexsel :: (reg-> a)  -> Index reg a
    indexsel= undefined
 -- | implement the relational-like operators, operating on record fields

Data/TCache/IndexText.hs

@@ -145,8 +145,11 @@ indexText sel convert= do
   addTrigger (indext sel  (words1 . convert))
   let [t1,t2]=  typeRepArgs $! typeOf sel
       t=  show t1 ++ show t2
-  withResources [] $ const [IndexText t 0 M.empty M.empty M.empty]
-
+  let proto = IndexText t 0 M.empty M.empty M.empty
+  withResources [proto] $ init proto
+  where
+  init proto [Nothing]  = [proto]
+  init _ [Just _] = []
 -- | trigger the indexation of list fields with elements convertible to Text
 indexList
   :: (IResource a, Typeable a, Typeable b)
@@ -157,7 +160,12 @@ indexList sel convert= do
   addTrigger (indext sel  convert)
   let [t1,t2]=  typeRepArgs $! typeOf sel
       t=  show t1 ++ show t2
-  withResources [] $ const [IndexText t 0 M.empty M.empty M.empty]
+  let proto= IndexText t 0 M.empty M.empty M.empty
+  withResources [proto] $ init proto
+
+  where
+  init proto [Nothing] = [proto]
+  init _ [Just _]= []