IDynamic (empty) → 0.1
raw patch · 5 files changed
+426/−0 lines, 5 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory
Files
- Data/IDynamic.hs +199/−0
- Data/IResource.hs +175/−0
- IDynamic.cabal +19/−0
- LICENSE +27/−0
- Setup.lhs +6/−0
+ Data/IDynamic.hs view
@@ -0,0 +1,199 @@+{-# OPTIONS -fglasgow-exts -XUndecidableInstances -XBangPatterns #-}+module Data.IDynamic where+ +import Data.Typeable +import Unsafe.Coerce +import System.IO.Unsafe +import Control.Concurrent.MVar +import Data.Map as M +import Data.IResource +import Data.HashTable(hashString) +import Data.Word+import Numeric (showHex, readHex)++ +{- |+Data.IDynamic is a indexable and serializable version @Data.Dynamic@ .+IDinamic provices methods for safe casting, serializaton, deserialization,+registration output and input++the data definition of IDymanic is as such:+ @data IDynamic= forall a. (Typeable a, IResource a) => IDynamic a deriving Typeable@++The registration trough @registerType@ is necessary before deserialization:+ @'registerType' :: IO Type@++example:+++@module Main where+import Data.IResource +import Data.IDynamic +import Data.Typeable++instance IResource Int where + keyResource x= \"I\" + serialize = show + deserialize = read + defPath _= \"data/ \"++instance IResource String where + keyResource x= take 5 x + serialize = show + deserialize = read + defPath _= \"data/\"+ +main= do + putStrLn \"see the code to know the meaning of he results\" + registerType :: IO Int -- register both datatypes (Int, and String) + registerType :: IO String+ let x= 1 :: Int++ let list= [IDynamic x, IDynamic \"hello, how are you\"]++ let assoc= zip (map keyResource list) list+ print $ lookup (keyResource (5 ::Int)) assoc++ mapM writeResource list+ mds <- readResource $ IDynamic \"hello\"+ case mds of+ Nothing -> error \"must have been Just!\"+ Just ds -> do+ putStrLn $ serialize ds+ let str= fromIDyn ds :: String+ putStrLn str++ let y= fromIDyn ds :: Int -- casting error+ print y@+++++++-}+ +data IDynamic= forall a. (Typeable a, IResource a) => IDynamic a deriving Typeable + + +list :: MVar (Map Word (IDynamic -> IO (Maybe IDynamic), String -> IDynamic) ) +list = unsafePerformIO $ newMVar $ empty ++hash x= unsafeCoerce . hashString . show $ typeOf x :: Word +instance IResource IDynamic where + keyResource (IDynamic x)= keyResource x + serialize (IDynamic x)= "Dyn " ++ showHex (hash x) ( " " ++ serialize x) + deserialize str2=+ let+ str= drop 4 str2+ [(t :: Word, str1)]= readHex str++ in+ case M.lookup t (unsafePerformIO $ readMVar list) of + Nothing -> error $ "not registered type " ++ str1 ++ " please registerType it" + Just (_, f)-> f $ tail str1 +++ + defPath (IDynamic x)= defPath x + + writeResource (IDynamic x)= writeResource x + + readResource d@(IDynamic x) + | typeOfx== typeOf Key= do+ mx <- readResource x --`debug` ("retrieving key "++ show (typeOf x)) + case mx of + Nothing -> return $ Nothing + Just x -> return $ Just $ toIDyn x + | otherwise= + case M.lookup type1 (unsafePerformIO $ readMVar list) of + Nothing -> error $ "not registered type " ++ show (typeOf x) ++ " please registerType it" + Just (f ,_)-> f d + where+ typeOfx= typeOf x + type1= unsafeCoerce $ hashString $ show typeOfx :: Word + + +instance Show IDynamic where + show (IDynamic x)= "(IDynamic \""++show (typeOf x) ++"\" "++ serialize x++")" + + +-- | DynamicInterface groups a set of default method calls to handle dynamic objects. It is not necessary to derive instances from it ++class DynamicInterface x where+ toIDyn :: x -> IDynamic -- ^ encapsulates data in a dynamic object + registerType :: IO x -- ^ registers the deserialize, readp and readResource methods for this data type + fromIDyn :: IDynamic -> x -- ^ extract the data from the dynamic object. trows a user error when the cast fails + unsafeFromIDyn :: IDynamic -> x -- ^ unsafe version. + safeFromIDyn :: IDynamic -> Maybe x -- ^ safe extraction with Maybe + +instance (IResource x,Typeable x) => DynamicInterface x where++ + toIDyn x= IDynamic x + + registerType = do + + let x= unsafeCoerce 1 :: x ++ let deserializex str= toIDyn (deserialize str :: x)+ + let readResourcex (IDynamic s)= do + mr <- readResource (unsafeCoerce s :: x) :: IO (Maybe x) + case mr of + Nothing -> return Nothing + Just s' -> return $ Just $ IDynamic s' + l <- takeMVar list++ let key= hash x ++ case M.lookup key l of + Just _ -> do + putMVar list l + return x + _ -> do + putMVar list $ insert key (readResourcex, deserializex) l + return x ++ + + fromIDyn d@(IDynamic a)= if type2 == type1 then v + else error ("fromIDyn: casting "++ show type1 ++" to type "++show type2 ++" for data "++ serialize a) + where + v= unsafeCoerce a :: x + type1= typeOf a + type2= typeOf v + + unsafeFromIDyn (IDynamic a)= unsafeCoerce a ++ safeFromIDyn (IDynamic a)= let v= unsafeCoerce a :: x in if typeOf a == typeOf v then Just v else Nothing+ +{- | Key datatype can be used to read any object trough the Dynamic interface.+ + @ data Key = Key 'TypeRep' String deriving Typeable @++ Example+ + @ mst <- 'getDResource' $ 'Key' type 'keyofDesiredObject'+ case mst of+ Nothing -> error $ \"not found \"++ key+ Just (idyn) -> fromIDyn idyn :: DesiredDatatype}@ +-} + +data Key = Key TypeRep String deriving Typeable + + +instance IResource Key where + keyResource (Key _ k)=k + serialize _= error "Key is not serializable" + deserialize _= error "Key is not serializable" + writeResource _= error "Please don't create Key objects" + readResource key@(Key t _)= + case M.lookup type1 (unsafePerformIO $ readMVar list) of + Nothing -> error $ "not registered type "++show t++" please registerType it" + Just (f,_) -> do+ d <- f . toIDyn $ key + return $ dynMaybe d + where + dynMaybe (Just dyn)= return $ fromIDyn dyn + type1= hash t
+ Data/IResource.hs view
@@ -0,0 +1,175 @@+module Data.IResource where + +import System.Directory +import Control.Exception as Exception +import System.IO.Error +import Data.List(elemIndices) +import System.IO +import Control.Monad(when,replicateM)++ +--import Debug.Trace++--debug a b= trace b a + +{- | A general interface for indexable, serializable and input-output objects. + 'readResource' and 'writeResource' are implemented by default as read-write to files with its key as filename + 'serialize' and 'deserialize' are specified just to allow these defaults. If you define your own persistence, then+ @serialize@ and @deserialize@ are not needed. The package 'Workflow' need them anyway. + +minimal definition: keyResource, serialize, deserialize++While serialize and deserialize are agnostic about the way of converison to strings, either binary or textual, treadp and+tshowp use the monad defined in the RefSerialize package. Both ways of serialization are alternative. one is defined+by default in terms of the other. the RefSerialize monad has been introduced to permit IResource objects to be+serialized as part of larger structures that embody them. This is necessary for the Workdlow package.+ +The keyResource string must be a unique since this is used to index it in the hash table. +when accessing a resource, the user must provide a partial object for wich the key can be obtained. +for example:+ +@data Person= Person{name, surname:: String, account :: Int ....) + +keyResource Person n s ...= n++s@ + +the data being accesed must have the fields used by keyResource filled. For example++ @ readResource Person {name="John", surname= "Adams"}@ + +leaving the rest of the fields undefined + +-} ++-- | IResource has defaults definitions for all the methods except keyResource+-- Either one or other serializer must be defiened for default witeResource, readResource and delResource +class IResource a where ++ keyResource :: a -> String -- ^ must be defined++ serialize :: a -> String -- ^ must be defined by the user++ + deserialize :: String -> a -- ^ must be defined by the user+ + defPath :: a-> String -- ^ additional extension for default file paths or key prefixes + defPath _ = "" + + -- get object content from the file + -- (NOTE: reads and writes can't collide, so they-- Not really needed since no write is done while read + -- must be strict, not lazy ) + readResource :: a-> IO (Maybe a) + readResource x=handleJust (\e -> fromException e) handleIt $ do + s <- readFileStrict filename :: IO String + return $ Just $ deserialize s -- `debug` ("read "++ filename) + where + filename= defPath x++ keyResource x + --handleIt :: IResource a => IOError -> IO (Maybe a) + handleIt e + |isAlreadyInUseError e = readResource x -- maybe is being written. try again. + + | isDoesNotExistError e = return Nothing + | isPermissionError e = error $ "readResource: no permissions for opening file: "++filename + | otherwise= error $ "readResource: " ++ show e + + writeResource:: a-> IO() + writeResource x=handleJust (\e -> fromException e) (handleIt x) $ writeFile filename (serialize x) -- `debug` ("write "++filename) + where + filename= defPath x ++ keyResource x + --handleIt :: a -> IOError -> IO () + handleIt x e + | isDoesNotExistError e=do + createDirectoryIfMissing True $ take (1+(last $ elemIndices '/' filename)) filename --maybe the path does not exist + writeResource x +-- | isAlreadyInUseError e= writeResource x -- maybe is being read. try again + -- Not really needed since no write is done while read ++ | otherwise =do+ hPutStrLn stderr $ "writeResource: " ++ show e ++ " in file: " ++ filename ++ " retrying" + writeResource x+ {-+ | isAlreadyExistsError e =+ do+ hPutStrLn stderr $ "writeResource: already exist file: " ++ filename ++ " retrying"+ writeResource x++++ | isAlreadyInUseError e =+ do+ hPutStrLn stderr $ "writeResource: already in use: " ++ filename ++ " retrying"+ writeResource x+ | isFullError e =+ do+ hPutStrLn stderr $ "writeResource: file full: " ++ filename ++ " retrying"+ writeResource x+ | isEOFError e =+ do+ hPutStrLn stderr $ "writeResource: EOF in file: " ++ filename ++ " retrying"+ writeResource x+ | isIllegalOperation e=+ do+ hPutStrLn stderr $ "writeResource: illegal Operation in file: " ++ filename ++ " retrying"+ writeResource x+ | isPermissionError e =+ do+ hPutStrLn stderr $ "writeResource:permission error in file: " ++ filename ++ " retrying"+ writeResource x+ | isUserError e =+ do+ hPutStrLn stderr $ "writeResource:user error in file: " ++ filename ++ " retrying"+ writeResource x+++ | otherwise =do+ hPutStrLn stderr $ "writeResource: error " ++ show e ++ " in file: " ++ filename + writeResource x +-} + + delResource:: a-> IO() + delResource x= handleJust (\e -> fromException e) (handleIt filename) $ removeFile filename --`debug` ("delete "++filename)+ + where+ filename= defPath x ++ keyResource x + handleIt :: String -> IOError -> IO () + handleIt file e + | isDoesNotExistError e= return ()+ | isAlreadyInUseError e= delResource x+ | isPermissionError e= delResource x+ + | otherwise = error ("delResource: " ++ show e ++ "for the file: "++ filename) + + + +type AccessTime = Integer +type ModifTime = Integer + + +infinite=10000000000 + +-- | Resources returned by 'withSTMResources'' +data Resources a b+ = Retry -- ^ forces a retry+ | Resources + { toAdd :: [a] -- ^ resources to be inserted back in the cache+ , toDelete :: [a] -- ^ resources to be deleted from the cache and from permanent storage + , toReturn :: b -- ^ result to be returned + }+ ++-- | @resources= Resources [] [] ()@+resources :: Resources a () +resources= Resources [] [] () + + + +-- Strict file read, needed for the default file persistence +readFileStrict f = openFile f ReadMode >>= \ h -> readIt h `finally` hClose h+ where+ readIt h= do + s <- hFileSize h + let n= fromIntegral s + str <- replicateM n (hGetChar h) + return str + + +
+ IDynamic.cabal view
@@ -0,0 +1,19 @@+name: IDynamic+version: 0.1+cabal-version: -any++synopsis: Indexable, serializable form of Data.Dynamic+description: A variant of Data.Dynamic that can be indexed, stored, transmitted trough communications etc.++category: Data+license: BSD3+license-file: LICENSE+author: Alberto Gómez Corona+maintainer: agocorona@gmail.com+Tested-With: GHC == 6.10.3+Build-Type: Simple+build-Depends: base == 4.1.0.0 , directory, containers+++exposed-modules: Data.IResource, Data.IDynamic+ghc-options:
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Alberto Gómez Corona 2008++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.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain +