packages feed

binarydefer (empty) → 1.1

raw patch · 5 files changed

+277/−0 lines, 5 filesdep +basesetup-changed

Dependencies added: base

Files

+ Data/Binary/Defer.hs view
@@ -0,0 +1,165 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Binary.Defer+-- Copyright   : Neil Mitchell+-- License     : BSD3+-- +-- Maintainer  : Neil Mitchell <http://www.cs.york.ac.uk/~ndm/>+-- Stability   : unstable+-- Portability : portable to Hugs and GHC. Requires Control.Exception.catch+--+-- Binary serialisation of deferred values+--+-----------------------------------------------------------------------------++module Data.Binary.Defer(+    BinaryDefer(..), put,+    BinaryDeferStatic(..),+    defer,+    Defer(..),+    unit, (<<), (<<~), (<<!)+    ) where++import Prelude hiding (catch)+import Control.Exception (catch)++import System.IO+import Foreign(unsafePerformIO)+import Control.Monad+import Data.Binary.Defer.Internal+++class BinaryDefer a where+    -- take a data value+    -- return a function to save that data value+    -- and one to load it+    bothDefer :: (Handle -> a -> IO [(Int, IO ())], Handle -> IO a)+    bothDefer = (putDefer, get)+    +    putDefer :: Handle -> a -> IO [(Int, IO ())]+    putDefer = fst bothDefer+    +    get :: Handle -> IO a+    get = snd bothDefer++put :: BinaryDefer a => Handle -> a -> IO ()+put hndl x = putDefer hndl x >>= mapM_ f . reverse+    where+        f (pos,action) = do+            i <- hGetPos hndl+            hSetPos hndl pos+            hPutInt hndl i+            hSetPos hndl i+            action+++class BinaryDefer a => BinaryDeferStatic a where+    -- | Must be a constant, must not examine first argument+    getSize :: a -> Int+++-- have you used any combinators of <<, <<~ or <<!+data PendingNone = PendingNone+data PendingSome = PendingSome++data Pending a b = Pending {psave :: Handle -> Int -> IO [(Int, IO ())], pload :: Handle -> IO a}+type Both a = (Handle -> a -> IO [(Int, IO ())], Handle -> IO a)++++deferOne :: (a -> Pending a PendingSome) -> Both a+deferOne x = (save, load)+    where+        save hndl value = psave (x value) hndl (-1)++        load hndl = pload (x undefined)  hndl+            ++defer :: [a -> Pending a PendingSome] -> Both a+defer [x] = deferOne x+defer xs = (save, load)+    where+        -- value `seq` is important to that a _|_ in value is+        -- thrown before entering a Catch statement+        -- may still not be safe if multiple levels of combinators+        save hndl value = value `seq` f (zip [0::Int ..] xs)+            where+                f [] = error "unmatched item to save, or trying to save _|_"+                f ((i,x):xs) = catch (psave (x value) hndl i) (const $ f xs)++        load hndl = do+            i <- hGetInt hndl+            pload ((xs !! i) undefined) hndl++++instance BinaryDefer Int where+    putDefer hndl x = hPutInt hndl x >> return []+    get hndl = hGetInt hndl+++instance BinaryDefer a => BinaryDefer [a] where+    putDefer hndl xs = hPutInt hndl (length xs) >> concatMapM (putDefer hndl) xs+        where concatMapM f = liftM concat . mapM f+    +    get hndl = do i <- hGetInt hndl; replicateM i (get hndl)++instance BinaryDefer Char where+    putDefer hndl x = hPutChar hndl x >> return []+    get hndl = hGetChar hndl++instance BinaryDefer Bool where+    putDefer hndl x = putDefer hndl (if x then '1' else '0')+    get hndl = get hndl >>= return . (== '1')+++instance BinaryDeferStatic Int where getSize _ = 4+instance BinaryDeferStatic Char where getSize _ = 1+instance BinaryDeferStatic Bool where getSize _ = 1+++unit :: a -> Pending a PendingNone+unit f = Pending (\hndl i -> when (i /= -1) (hPutInt hndl i) >> return [])+                 (const $ return f)+++(<<!) :: Pending a p -> a -> Pending a PendingSome+(<<!) (Pending save load) val = Pending (val `seq` save) load+++(<<) :: BinaryDefer a => Pending (a -> b) p -> a -> Pending b PendingSome+(Pending save load) << x = Pending+        (\hndl i -> x `seq` do lazy <- save hndl i; l <- s hndl x; return (l ++ lazy))+        (\hndl -> do f <- load hndl; x2 <- l hndl; return (f x2))+    where (s,l) = bothDefer++(<<~) :: BinaryDefer a => Pending (a -> b) p -> a -> Pending b PendingSome+(Pending save load) <<~ x = Pending+    (\hndl i -> x `seq` do+        lazy <- save hndl i+        pos <- hGetPos hndl+        hPutInt hndl 0+        return ((pos,put hndl x):lazy))+    (\hndl -> do+        f <- load hndl+        pos <- hGetInt hndl+        return $ f $ lazyRead hndl pos)+    where+        lazyRead hndl pos = unsafePerformIO $ do+            p <- hGetPos hndl+            hSetPos hndl pos+            res <- get hndl+            hSetPos hndl p+            return res+++newtype Defer x = Defer {fromDefer :: x}++instance BinaryDefer a => BinaryDefer (Defer a) where+    bothDefer = defer [\ ~(Defer a) -> unit Defer <<~ a]++instance Show a => Show (Defer a) where+    show (Defer a) = "(Defer " ++ show a ++ ")"++instance BinaryDefer a => BinaryDeferStatic (Defer a) where+    getSize _ = 4
+ Data/Binary/Defer/Internal.hs view
@@ -0,0 +1,51 @@++module Data.Binary.Defer.Internal(+    hGetInt, hPutInt,+    hGetPos, hSetPos+    ) where++import System.IO+import Control.Monad+import Data.Bits+import Data.Char+++hGetPos :: Handle -> IO Int+hGetPos = liftM fromInteger . hTell++hSetPos :: Handle -> Int -> IO ()+hSetPos hndl = hSeek hndl AbsoluteSeek . toInteger+++-- FROM the Binary module, thanks to the Hac 07 people!++hPutInt :: Handle -> Int -> IO ()+hPutInt hndl w32 = do+    let w4 = (w32 `shiftR` 24) .&. 0xff+        w3 = (w32 `shiftR` 16) .&. 0xff+        w2 = (w32 `shiftR`  8) .&. 0xff+        w1 =  w32              .&. 0xff+    putWord8 hndl w1+    putWord8 hndl w2+    putWord8 hndl w3+    putWord8 hndl w4++putWord8 :: Handle -> Int -> IO ()+putWord8 hndl = hPutChar hndl . chr+++hGetInt :: Handle -> IO Int+hGetInt hndl = do+    w1 <- getWord8 hndl+    w2 <- getWord8 hndl+    w3 <- getWord8 hndl+    w4 <- getWord8 hndl+    return $! (w4 `shiftL` 24) .|.+              (w3 `shiftL` 16) .|.+              (w2 `shiftL`  8) .|.+              (w1)+++getWord8 :: Handle -> IO Int+getWord8 hndl = hGetChar hndl >>= return . ord+
+ Data/Binary/Defer/List.hs view
@@ -0,0 +1,47 @@++module Data.Binary.Defer.List(ListDefer, newListDefer, readListDefer) where++import System.IO+import Control.Monad+import Foreign (unsafePerformIO)++import Data.Binary.Defer+import Data.Binary.Defer.Internal+++data ListDefer a = ListWrite [a]+                 | ListRead {hndl :: Handle, pos :: Int, count :: Int, size :: Int, undef :: a}+++instance (BinaryDeferStatic  a, Show a) => Show (ListDefer a) where+    show (ListWrite a) = "(ListDefer " ++ show a ++ ")"+    show x = "(ListDefer " ++ show (readListDefer x 0 (count x)) ++ ")"+++instance BinaryDeferStatic a => BinaryDefer (ListDefer a) where+    putDefer hndl (ListWrite xs) = hPutInt hndl (length xs) >> concatMapM (putDefer hndl) xs+        where concatMapM f = liftM concat . mapM f+++    get hndl = do+        len <- hGetInt hndl+        pos <- hGetPos hndl+        let res = ListRead hndl pos len (getSize (undef res)) undefined+        hSetPos hndl (pos + (size res * len))+        return res+++newListDefer :: BinaryDeferStatic a => [a] -> ListDefer a+newListDefer = ListWrite+++-- | Start, Length+readListDefer :: BinaryDeferStatic a => ListDefer a -> Int -> Int -> [a]+readListDefer (ListRead hndl pos count size _) start len+    | start + len > count = error "readListDefer, ran off the end"+    | otherwise = unsafePerformIO $ do+        p <- hGetPos hndl+        hSetPos hndl (pos + (size * start))+        res <- replicateM len (get hndl)+        hSetPos hndl p+        return res
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ binarydefer.cabal view
@@ -0,0 +1,11 @@+name:            binarydefer+build-type:      Simple+version:         1.1+license:         BSD3+author:          Neil Mitchell+synopsis:        Binary serialization with deferred loading+build-depends:   base+exposed-modules: Data.Binary.Defer,+                 Data.Binary.Defer.List+                 Data.Binary.Defer.Internal+hs-source-dirs:  .