columbia 0.1.0.2 → 0.1.1

raw patch · 14 files changed

+307/−174 lines, 14 filesdep +pointedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: pointed

API changes (from Hackage documentation)

Files

• columbia.cabal +16/−4
• src/Data/Columbia.hs +5/−4
• src/Data/Columbia/CompoundData.hs +77/−38
• src/Data/Columbia/CycleDetection.hs +8/−7
• src/Data/Columbia/DynamicWithCtx.hs +10/−0
• src/Data/Columbia/Gc.hs +0/−10
• src/Data/Columbia/Integral.hs +0/−1
• src/Data/Columbia/Mapper.hs +17/−22
• src/Data/Columbia/Orphans.hs +10/−0
• src/Data/Columbia/RWInstances.hs +2/−0
• src/Data/Columbia/SeekableStream.hs +8/−2
• src/Data/Columbia/SeekableWriter.hs +44/−3
• src/Data/Columbia/Utils.hs +81/−41
• src/Data/Columbia/WithAddress.hs +29/−42

@@ -2,26 +2,38 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                columbia
-version:             0.1.0.2
+version:             0.1.1
 synopsis:            Enhanced serialization for media that support seeking.
 description:         Libraries such as binary and cereal support sequential reading and writing but do not rely on any further operations. Many media support seeking in files as well. This library implements a file format that supports random access to data entities by seeking.
 	.
+	This library by default enforces a strong concept of immutability; this has a number of benefits including sharing of substructure. Files in its format have a nominal mutable state that changes over discrete time steps, permitting strong reasoning. This work was inspired by Haskell's focus on immutability, and by the programming langauge Clojure's very disciplined management of mutable state.
+	.
+	In addition to a bare bones locking strategy, an optional transactional locking strategy over tree data structures is implemented. This gets this close to an object-oriented DBMS; there is a strong affinity between persisted objects and tree data structures. The transaction strategy prevents multiple processes from reading and writing on data that is mutually descendant in a tree structure. I argue that this is the appropriate generalization of transactions on traditional relational database records.
+	.
+	The database's store has been implemented over memory maps for speed, and is portable between Windows and Linux platforms.
+	.
 	This library also uses the syb-with-class library to streamline implementation of serializers for various data entities, so that you don't have to write much boilerplate ;).
+	.
+	Release notes for version 0.1.1:
+	.
+	* Changed the invariant surrounding how files are seeked for reading/writing procedures. This permits an additional optimization. See Utils module for details.
+	.
+	* Generalized the interface to Utils locking strategies to arbitrary monads incorporating exceptions and I/O.
 license:             BSD3
 license-file:        LICENSE
 author:              James Candy
 maintainer:          jacinablackbox@yahoo.com
 -- copyright:           
-category:            Data
+category:            Serialization
 build-type:          Simple
 extra-source-files:  ChangeLog.md
 cabal-version:       >=1.10
 
 library
   exposed-modules:     Data.Columbia, Data.Columbia.CompoundData, Data.Columbia.SeekableStream, Data.Columbia.SeekableWriter, Data.Columbia.Utils, Data.Columbia.Gc, Data.Columbia.Integral, Data.Columbia.CycleDetection, Data.Columbia.FRecord, Data.Columbia.WithAddress, Data.Columbia.Orphans, Data.Columbia.DualLock
-  other-modules:       Data.Columbia.Headers, Data.Columbia.Coercion, Data.Columbia.RWInstances, Data.Columbia.Mapper, Data.Columbia.MyEndianness
+  other-modules:       Data.Columbia.Headers, Data.Columbia.Coercion, Data.Columbia.RWInstances, Data.Columbia.Mapper, Data.Columbia.MyEndianness, Data.Columbia.DynamicWithCtx
   -- other-extensions:    
-  build-depends:       base >=4.6 && <=5, filelock ==0.1.0.1, contravariant ==1.4, bytestring >=0.10 && <0.11, monad-loops ==0.4.3, mtl ==2.2.1, directory >=1.2.2.0 && <=1.3.0.0, syb-with-class ==0.6.1.7, array >=0.5.1 && <0.5.2, invariant ==0.4.2, containers ==0.5.8.1, pointless-haskell ==0.0.9, mmorph ==1.0.9, parallel ==3.2.1.1, transformers >=0.4.2.0 && <=0.5.0.0, mmap ==0.5.9, data-endian ==0.1
+  build-depends:       base >=4.6 && <=5, filelock ==0.1.0.1, contravariant ==1.4, bytestring >=0.10 && <0.11, monad-loops ==0.4.3, mtl ==2.2.1, directory >=1.2.2.0 && <=1.3.0.0, syb-with-class ==0.6.1.7, array >=0.5.1 && <0.5.2, invariant ==0.4.2, containers ==0.5.8.1, pointless-haskell ==0.0.9, mmorph ==1.0.9, parallel ==3.2.1.1, transformers >=0.4.2.0 && <=0.5.0.0, mmap ==0.5.9, data-endian ==0.1, pointed ==5
   if os(mingw32)
     cpp-options: -DWIN32
   hs-source-dirs:      src

@@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy, Rank2Types, TypeFamilies, FlexibleContexts #-}
 
-module Data.Columbia (module Data.Columbia.CompoundData, module Data.Columbia.CycleDetection, module Data.Columbia.Utils, module Data.Columbia.Integral, module Data.Columbia.Gc, module Data.Columbia.FRecord, module Data.Columbia.WithAddress, module Data.Generics.SYB.WithClass.Basics, module Data.Generics.SYB.WithClass.Context, module Generics.Pointless.Functors,
+module Data.Columbia (module Data.Columbia.CompoundData, module Data.Columbia.CycleDetection, module Data.Columbia.Utils, module Data.Columbia.Integral, module Data.Columbia.Gc, module Data.Columbia.FRecord, module Data.Columbia.WithAddress, module Data.Generics.SYB.WithClass.Basics, module Data.Generics.SYB.WithClass.Context, module Generics.Pointless.Functors, module Control.Monad.IO.Class, module Control.Monad.Reader,
 -- ** Idioms
 rwProxy, readCompoundData, writeCompoundData, rwKeyProxy, readDataWithCycles, writeDataWithCycles) where
 
@@ -13,12 +13,13 @@ import Data.Columbia.Gc
 import Data.Columbia.FRecord
 import Data.Columbia.WithAddress
+import Data.Columbia.DynamicWithCtx
 import Data.Generics.SYB.WithClass.Basics
 import Data.Generics.SYB.WithClass.Context
 import Data.Word
 import Control.Monad.IO.Class
 import Control.Monad.Reader
-import Generics.Pointless.Functors
+import Generics.Pointless.Functors hiding (Functor,fmap)
 
 rwProxy :: Proxy(PairCtx RWCtx NoCtx)
 rwProxy = undefined
@@ -29,7 +30,7 @@ 
 -- | Convenient idiom; sells targets repeatedly until the entire data structure has been written.
 writeCompoundData :: forall m d. (Monad m, Data(PairCtx RWCtx NoCtx) d)
-	=> d -> ReaderT(SeekableWriter m Word8) m Word32
+	=> d -> ReaderT(SeekableWriter m Word8) m ()
 writeCompoundData = fixTW rwProxy(writeBackAddresses ##. writeOneLayer)
 
 rwKeyProxy :: Proxy(PairCtx RWCtx(PairCtx KeyCtx NoCtx))
@@ -39,5 +40,5 @@ readDataWithCycles = fixT rwKeyProxy(withAddresses #. cycleDetect #. readOneLayer)
 
 writeDataWithCycles :: forall m d. (StateM m, StateOf m ~ Map(DynamicWithCtx KeyComparable) Word32, Data(PairCtx RWCtx(PairCtx KeyCtx NoCtx)) d)
-	=> d -> ReaderT(SeekableWriter m Word8) m Word32
+	=> d -> ReaderT(SeekableWriter m Word8) m ()
 writeDataWithCycles = fixTW rwKeyProxy(writeBackAddresses ##. cycleDetectW ##. writeOneLayer)

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, ScopedTypeVariables, TypeOperators, Rank2Types, AllowAmbiguousTypes, ImpredicativeTypes, Trustworthy #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, ScopedTypeVariables, TypeOperators, Rank2Types, ImpredicativeTypes, Trustworthy #-}
 
 -- | Serialization of compound data types (with class!). Also read and write methods' type class contexts
 --   are implemented with heterogeneous list constraints, making them sufficiently abstract. For every
@@ -18,9 +18,11 @@ --   then follows from the finitude of the addresses.
 module Data.Columbia.CompoundData (module Data.Columbia.SeekableStream, module Data.Columbia.SeekableWriter, module Data.Columbia.RWInstances,
 -- ** Strategy/traversal combinators
-(#.), (##.), fixT, fixTW, typeCoerce,
+(#.), (##.), fixT, fixTW, typeCoerce, typeCoerceW,
 -- ** Compound data read/write strategies
-RW(..), RWCtx(..), PolyTraversal, readOneLayer, PolyTraversalW, writeOneLayer, seekToField) where
+RW(..), RWCtx(..), PolyTraversal, readOneLayer, PolyTraversalW, writeOneLayer,
+-- ** Seeking and updating
+seekByTrack, seekToField, updateField, updateByTrack) where
 
 import Data.Generics.SYB.WithClass.Basics
 import Data.Word
@@ -32,6 +34,7 @@ import Control.Monad.Writer
 import Control.Monad.Identity
 import Control.Monad.Trans
+import Control.Monad.Morph
 import Control.Monad
 import Data.Columbia.SeekableStream
 import Data.Columbia.SeekableWriter
@@ -39,16 +42,19 @@ import Data.Columbia.Headers
 import Data.Columbia.RWInstances
 import Data.Columbia.FRecord
+import Data.Columbia.DynamicWithCtx
 
 infixl 9 #.
 infixl 9 ##.
 
+{-# INLINE (#.) #-}
 (#.) :: (Data ctx t)
 	=> PolyTraversal ctx m t
 	-> (forall t2. (Data ctx t2) => PolyTraversal ctx m t2)
 	-> PolyTraversal ctx m t
 (traversal #. traversal2) proxy f = traversal proxy(traversal2 proxy f)
 
+{-# INLINE (##.) #-}
 (##.) :: (Data ctx t)
 	=> PolyTraversalW ctx m t
 	-> (forall t2. (Data ctx t2) => PolyTraversalW ctx m t2)
@@ -65,7 +71,7 @@ 	=> Proxy ctx
 	-> (forall t2. (Data ctx t2) => PolyTraversalW ctx m t2)
 	-> t
-	-> ReaderT(SeekableWriter m Word8) m Word32
+	-> ReaderT(SeekableWriter m Word8) m ()
 fixTW proxy traversal = traversal proxy(fixTW proxy traversal)
 
 -- | Try to cast from the first traversal; if that fails, use the second traversal.
@@ -79,23 +85,25 @@ 	id
 	(gcast(traversal proxy m))
 
-------------------------------------
+typeCoerceW :: (Typeable t, Data ctx t2)
+	=> PolyTraversalW ctx m t
+	-> (forall t3. (Data ctx t3) => PolyTraversalW ctx m t3)
+	-> PolyTraversalW ctx m t2
+typeCoerceW traversal traversal2 proxy f x = 
+	maybe
+	(traversal2 proxy f x)
+	(traversal proxy f)
+	(cast x)
 
-readAddresses :: forall ctx m a. (Monad m, HasField ctx RWCtx, Sat(ctx a))
-	=> Proxy ctx
-	-> WriterT[Word32] (ReaderT(SeekableStream m Word8) m) a
-readAddresses _ = case hasField(dict :: ctx a) of
-	RWCtx -> do
-		x <- lift readIntegral
-		tell[x]
-		return$error"readAddresses: unused"
+------------------------------------
 
+{-# INLINE recursor #-}
 recursor :: forall ctx m a. (Monad m, HasField ctx RWCtx, Data ctx a)
 	=> (forall a. (Data ctx a) => ReaderT(SeekableStream m Word8) m a)
-	-> Proxy ctx -> StateT[Word32] (ReaderT(SeekableStream m Word8) m) a
+	-> Proxy ctx -> StateT Word32(ReaderT(SeekableStream m Word8) m) a
 recursor rec proxy = do
-	~(x:xs) <- get
-	put xs
+	x <- get
+	put$!x+4
 	lift$do
 		seek x
 		rec
@@ -111,6 +119,7 @@ readOneLayer :: forall ctx m d. (Monad m, HasField ctx RWCtx, Data ctx d)
 	=> PolyTraversal ctx m d
 readOneLayer proxy0 m = do
+	seekByPointer
 	let specimen :: d = error"readOneLayer: specimen"
 	let ty = dataTypeOf proxy0 specimen
 	-- First examine the header on disk and compare to the header deriving from the data type.
@@ -127,63 +136,93 @@ 					return$!enhancedFromConstr proxy0 ty hdr l
 				else
 					return$!enhancedFromConstr proxy0 ty hdr 0
-			(_ :: d, ls) <- runWriterT(gmapM
-				proxy0
-				(\_ -> readAddresses proxy0)
-				specimen2)
+			addr <- getPosition
 			-- Construct a 'PolyTraversal' that reads the sub-components.
 			evalStateT
 				(gmapM
 				proxy0
 				(\_ -> recursor m proxy0)
 				specimen2)
-				ls
+				addr
 		else
 		-- Fall back on a primitive reader method if one is defined.
 		case hasField(dict :: ctx d) of
 			RWCtx -> readData
 
-recursorW :: forall ctx m a. (Monad m, HasField ctx RWCtx, Data(ctx) a)
-	=> (a -> ReaderT(SeekableWriter m Word8) m Word32)
-	-> Proxy ctx -> a -> StateT Word32(ReaderT(SeekableWriter m Word8) m) a
-recursorW rec proxy d = do
-	lift seekWriterAtEnd
-	x <- lift$rec d
+-- | This is a slightly more tail-recursive implementation of 'mapM_' for lists.
+--   That helps deal with serialization of lists, a common case.
+mapM_' :: (Monad m) => (t->m())->[t]->m()
+mapM_' f (x:xs@(_:_)) = do { f x;mapM_' f xs }
+mapM_' f [x] = f x
+mapM_' _ [] = return()
+
+{-# INLINE recursorW #-}
+recursorW :: forall ctx m. (Monad m, HasField ctx RWCtx)
+	=> (forall a. (Data ctx a) => a -> ReaderT(SeekableWriter m Word8) m ())
+	-> DynamicWithCtx(Data ctx)
+	-> StateT Word32(ReaderT(SeekableWriter m Word8) m) ()
+recursorW rec (DynamicWithCtx d) = do
 	n <- get
 	put$!n+4
 	lift$do
 		seekWriter n
-		writeIntegral x
-	return$error"recursorW: unused"
+		rec d -- Tail recursive
 
-type PolyTraversalW ctx m d = Proxy ctx
-	-> (forall a. (Data ctx a) => a -> ReaderT(SeekableWriter m Word8) m Word32)
-	-> d -> ReaderT(SeekableWriter m Word8) m Word32
+{-# INLINE collectSubterms #-}
+collectSubterms :: (Data ctx d) => Proxy ctx->d->[DynamicWithCtx(Data ctx)]
+collectSubterms proxy = snd.runWriter.gmapM proxy(\d->do { tell.return.dynamicWithCtx$d; return$error"unused result" })
 
 -- | Writes the top layer of a data structure, and sells each of the sub-targets in turn.
 writeOneLayer :: forall ctx m d. (Monad m, HasField ctx RWCtx, Data ctx d) => PolyTraversalW ctx m d
 writeOneLayer proxy0 f d = do
 	let ty = dataTypeOf proxy0 d
+	n <- getWriterPosition
+	seekWriterAtEnd
 	m <- getWriterPosition
+	seekWriter n
+	writeIntegral m
+	seekWriterAtEnd
 	if isAlgType ty || dataTypeName ty == "Data.Array.Array" then do
 			writeHeader proxy0 d
 			n <- getWriterPosition
 			sequence_(replicate(nConstructorParameters proxy0 d) (writeIntegral(0::Word32)))
-			evalStateT(gmapM proxy0
-				(recursorW f proxy0)
-				d)
+			let subterms = collectSubterms proxy0 d
+			evalStateT(mapM_'(recursorW f) subterms)
 				n
-			return m
 		else case hasField(dict :: ctx d) of
 			RWCtx -> do
 				writeHeader proxy0 d
 				writeData d
-				return m
 
+------------------------------------
+
 seekToField :: forall m. (Monad m) => Int -> ReaderT(SeekableStream m Word8) m ()
 seekToField ix = do
+	seekByPointer
 	hdr <- readHeader
 	(nf, _) <- nFieldsBytes hdr
 	when(ix<1||ix>nf)$fail$"seekToField: index out of range (1,"++showsPrec 11 nf")"
 	relSeek$fromIntegral$4*ix-4
-	seekByPointer
+
+{-# INLINE seekByTrack #-}
+seekByTrack track = mapM_ seekToField track
+
+updateField :: (Monad m, Data ctx d, HasField ctx RWCtx) => Int -> PolyTraversalW ctx(StateT Int m) d
+updateField n proxy f =
+	writeOneLayer proxy
+	$ \d->
+	do
+	m <- get
+	put$!succ m
+	if n==m then
+		hoist(lift.(`evalStateT`1))$f d
+		else
+		fixTW proxy writeOneLayer d
+
+_updateByTrack :: (Monad m, Data ctx d, HasField ctx RWCtx) => [Int] -> PolyTraversalW ctx(StateT Int m) d
+_updateByTrack (i:is) proxy f = (updateField i ##. _updateByTrack is) proxy f
+_updateByTrack [] _ f = f
+
+{-# INLINE updateByTrack #-}
+updateByTrack :: (Monad m, Data ctx d, HasField ctx RWCtx) => [Int]-> PolyTraversalW ctx m d
+updateByTrack = hoistPolyTraversalW(`evalStateT`1) lift._updateByTrack

@@ -13,6 +13,8 @@ import Data.Columbia.CompoundData
 import Data.Columbia.FRecord
 import Data.Columbia.Orphans
+import Data.Columbia.Integral
+import Data.Columbia.DynamicWithCtx
 import Generics.Pointless.Functors
 import Generics.Pointless.Combinators
 import Control.Monad.Reader
@@ -52,11 +54,6 @@ 
 instance (KeyComparable t) => Sat(KeyCtx t) where dict = KeyCtx
 
-data DynamicWithCtx ctx = forall t. (ctx t, Typeable t) => DynamicWithCtx !t
-
-dynamicWithCtx :: (ctx t, Typeable t) => t -> DynamicWithCtx ctx
-dynamicWithCtx = DynamicWithCtx
-
 instance Eq(DynamicWithCtx Eq) where
 	DynamicWithCtx x == DynamicWithCtx x2 = maybe False(==x2) (cast x)
 instance KeyComparable(DynamicWithCtx KeyComparable) where
@@ -76,7 +73,8 @@ cycleDetect :: forall ctx m t. (MonadFix m, StateM m, StateOf m ~ Map Word32 Dynamic, HasField ctx RWCtx, Data ctx t)
 	=> PolyTraversal ctx m t
 cycleDetect proxy m =
-	getPosition>>= \n->
+	readIntegral>>= \n->
+	relSeek(-4)>>
 	lift get'>>=
 	maybe
 		(mfix(\x -> do
@@ -97,10 +95,13 @@ 			lift get'>>= \mp->
 			maybe
 				(do
+				n <- getWriterPosition
+				seekWriterAtEnd
 				addr <- getWriterPosition
+				seekWriter n
 				when(isKeyed d)$lift$put'$insert d addr mp
 				f x)
-				return
+				writeIntegral
 				$lookup d mp
 
 runCycleDetectionR :: (Monad m)

@@ -0,0 +1,10 @@+{-# LANGUAGE ExistentialQuantification, ConstraintKinds, Safe #-}
+
+module Data.Columbia.DynamicWithCtx where
+
+import Data.Typeable
+
+data DynamicWithCtx ctx = forall t. (ctx t, Typeable t) => DynamicWithCtx !t
+
+dynamicWithCtx :: (ctx t, Typeable t) => t -> DynamicWithCtx ctx
+dynamicWithCtx = DynamicWithCtx

@@ -130,14 +130,6 @@ 		return$!n/=x2)
 		m
 
-concludeFileWrite ref table@(Table path _) = do
-	(_,sz) <- readIORef ref
-	unmapAll table
-	bracket
-		(openBinaryFile path ReadWriteMode)
-		hClose
-		(`hSetFileSize` toInteger sz)
-
 -- Run-length compression of the bit field defined in the mark.tmp file.
 compress :: SeekableWriter IO Word8 -> IO((FilePath,SeekableWriter IO Word8),Word32)	
 compress tmpwriter = do
@@ -225,8 +217,6 @@ 			_fixUpPointers half end addr2
 		else
 			liftM(\m -> m+addr2-st) readIntegral
-
-local' f x = ask>>=lift.runReaderT x.f
 
 -- Read the address at 'n' and use the information in compressed.tmp to find
 -- the corresponding fixed up address. Return the old address to be traversed

@@ -34,7 +34,6 @@ 	putToken$!fromIntegral$shiftR x 8
 	putToken$!fromIntegral x
 
-
 readIntegral16 :: (Monad m, Bits i, Integral i) => ReaderT(SeekableStream m Word8) m i
 readIntegral16 = liftM2(\x1 x2 -> shiftL(fromIntegral x1) 8 .|.
 	fromIntegral x2)

@@ -19,7 +19,6 @@ import Control.Exception
 import System.IO.MMap
 import System.IO
-import System.Mem
 import Prelude hiding (lookup, catch, mapM)
 
 foreign import ccall "HsMmap.h system_io_mmap_file_open"
@@ -30,11 +29,6 @@ foreign import ccall "HsMmap.h &system_io_mmap_file_close"
     c_system_io_mmap_file_close :: FunPtr(Ptr () -> IO ())
 
-foreign import ccall "dynamic"
-    toFun :: FunPtr(Ptr () -> IO ())
-	-> Ptr ()
-	-> IO ()
-
 foreign import ccall unsafe "HsMmap.h system_io_mmap_mmap"
     c_system_io_mmap_mmap :: Ptr ()
                           -> CInt
@@ -58,7 +52,7 @@ 
 type Pointer = Word32
 
-data Table = Table !FilePath !(MVar (Map Pointer (Ptr ())), ForeignPtr ())
+data Table = Table !FilePath !(MVar (Map Pointer (Ptr ())), ForeignPtr (){-file handle-})
 
 newTable path = do
 	mv <- newMVar empty
@@ -82,22 +76,21 @@ mapBlock :: Table -> Pointer -> IO (Ptr a)
 mapBlock table@(Table path(mp,handle)) ptr = modifyMVar mp $ \mp -> case lookup aligned mp of
 	Just p -> return (mp, castPtr (plusPtr p (fromIntegral r)))
-	Nothing -> withForeignPtr handle$ \handle' -> do
+	Nothing -> withForeignPtr handle$ \handle'->do
 		-- putStrLn$"mmap at "++show ptr
-		sz <- fileSize path mp
+		-- mp' <- _unmapAll False handle mp
+		mp' <-return mp
+		sz <- fileSize path mp'
 		when(aligned>=sz)$
 			bracket
 				(openBinaryFile path ReadWriteMode)
 				hClose
-				(`hSetFileSize` (toInteger aligned+toInteger amount))
-		(mp',p) <- liftM (\p -> (insert aligned p mp, plusPtr p (fromIntegral r))) $
-			c_system_io_mmap_mmap handle' 3{-ReadWriteEx-} (fromIntegral aligned) amount
+				(`hSetFileSize` (toInteger aligned+65536))
+		(mp'',p) <- liftM (\p -> (insert aligned p mp', plusPtr p (fromIntegral r))) $
+			c_system_io_mmap_mmap handle' 3{-ReadWriteEx-} (fromIntegral aligned) 65536
 		-- putStrLn$"mmap complete"
-		return$!(mp',p)
+		return$!(mp'',p)
 	where
-	-- Groups of four bytes that straddle a word
-	-- will have to trigger the mapping of two contiguous pages.
-	amount = if r >= 65533 then 2*65536 else 65536
 	(d, r) = ptr `divMod` 65536
 	aligned = 65536 * d
 
@@ -115,14 +108,15 @@ 
 	return (p, fromInteger fileSz)-}
 
-unmapAll (Table _ (mvar,handle)) =
-	modifyMVar_ mvar$ \mp-> do { withForeignPtr handle$ \handle'-> do
+_unmapAll isFinal handle mp = withForeignPtr handle$ \handle'->do
 		errref <- newIORef False
 #ifdef WIN32
 		mapM(\ptr->do
 			n<-c_win32_flush_view_of_file ptr 65536
 			when(n==0)$writeIORef errref True) mp
-		flush_file_buffers handle' -- To be *strictly correct*, must cause writeback manually.
+		-- When unmap operation is not final it is possible to skip this operation
+		-- that does not dispose of individual pages.
+		when isFinal$flush_file_buffers handle' -- To be *strictly correct*, must cause writeback manually.
 #else
 		mapM(\ptr->do
 			n<-c_msync ptr 65536 2
@@ -130,6 +124,7 @@ #endif
 		mapM(\ptr -> munmapFilePtr ptr 65536) mp
 		bool <- readIORef errref
-		when bool$fail"unmapAll: FlushViewOfFile or msync failed";
-		performGC;
-		return empty }
+		when bool$fail"unmapAll: FlushViewOfFile or msync failed"
+		return empty
+
+unmapAll (Table _ (mvar,handle)) = modifyMVar_ mvar$_unmapAll True handle

@@ -7,6 +7,7 @@ import Data.Generics.SYB.WithClass.Basics
 import Data.Columbia.RWInstances
 import Data.Array.Unboxed
+import Data.Tree
 
 idConstr = Constr(AlgConstr 1) "IdF" [] Prefix idDataType
 idDataType = DataType "Generics.Pointless.Functors" (AlgRep[idConstr])
@@ -87,4 +88,13 @@ 	gunfold = error"no gunfold"
 	toConstr = error"no toConstr"
 	dataTypeOf _ _ = mkNorepType"Data.Array.Unboxed.UArray"
+	dataCast1 _ = gcast1
+
+treeConstr = Constr(AlgConstr 1) "Node" [] Prefix treeDataType
+treeDataType = DataType "Data.Tree.Tree" (AlgRep[treeConstr])
+instance (Data ctx t,Data ctx[Tree t],Sat(ctx(Tree t))) => Data ctx(Tree t) where
+	gfoldl _ o k (Node x ls) = k Node `o` x `o` ls
+	gunfold _ f k _ = f(f(k Node))
+	toConstr _ _ = treeConstr
+	dataTypeOf _ _ = treeDataType
 	dataCast1 _ = gcast1

@@ -11,6 +11,7 @@ import Data.Set (Set)
 import qualified Data.Array.Unboxed as UA
 import Data.Char
+import Data.Tree
 import Data.Typeable hiding (Proxy)
 import Data.Columbia.Integral
 import Data.Columbia.Coercion
@@ -74,6 +75,7 @@ instance (Typeable t) => RW[t]
 instance (Typeable t, Typeable u) => RW(Map t u)
 instance (Typeable t) => RW(Set t)
+instance (Typeable t) => RW(Tree t)
 instance RW(UA.UArray Int32 Word8) where
 	readData = do
 		len :: Int32 <- readIntegral

@@ -55,8 +55,8 @@ 			return mzero
 		else
 			mapBlock table n>>=peek>>= \x->(writeIORef ref$!(succ n,sz))>>(return$!return x))
-	{-
-	TODO: not complete yet: (readIORef ref>>= \(n,sz)->if n+3>=sz then
+	{-- TODO: not complete yet:
+	(readIORef ref>>= \(n,sz)->if n+3>=sz then
 			return mzero
 		else
 			mapBlock table n>>=peek>>= \x->(writeIORef ref$!(n+4,sz))>>(return$!return$!swapEndian' x))-}
@@ -122,11 +122,17 @@ 	(modify(\(n, ls, ls2) -> using(n+fromIntegral(length ls2), reverse ls2++ls, []) (evalTuple3 rseq rseq rseq)))
 	(return True)
 
+{-# INLINE _consumeToken #-}
 _consumeToken = __consumeToken
+{-# INLINE _consumeIntegralToken #-}
 _consumeIntegralToken = __consumeIntegralToken
+{-# INLINE _seek #-}
 _seek = __seek
+{-# INLINE _getPosition #-}
 _getPosition = __getPosition
+{-# INLINE _seekAtEnd #-}
 _seekAtEnd = __seekAtEnd
+{-# INLINE _isLockLive #-}
 _isLockLive = __isLockLive
 
 {-# INLINE getPosition #-}

@@ -10,13 +10,16 @@ import Data.Char
 import Data.Bits
 import Data.IORef
+import Data.Generics.SYB.WithClass.Basics
 import System.IO
 import System.FileLock
 import Control.Monad.Reader
 import Control.Monad.State
+import Control.Monad.Morph
 import Control.Monad
 import Control.Arrow
 import Control.Parallel.Strategies
+import Control.Exception
 import Data.Columbia.SeekableStream
 import Data.Columbia.MyEndianness
 import Data.Columbia.Mapper
@@ -30,14 +33,14 @@ hoistWriter :: (forall t. m t -> m2 t) -> SeekableWriter m c -> SeekableWriter m2 c
 hoistWriter f sw = SeekableWriter(\x -> f(_putToken sw x)) (\x->f(_putIntegralToken sw x)) (hoistStream f(stream sw))
 
+{-# INLINE putWord8 #-}
 putWord8 :: Handle -> Word8 -> IO()
 putWord8 h x = with x(\p -> hPutBuf h p 1)
 
 makeIoWriter :: IORef(Pointer,Pointer) -> Table -> FileLock -> SeekableWriter IO Word8
 makeIoWriter ref table lock = SeekableWriter
 	(\x->readIORef ref>>= \(n,sz)->mapBlock table n>>=(`poke` x)>>(writeIORef ref$!(succ n,max(succ n) sz)))
-	{-
-	TODO: not complete yet
+	{- TODO: not complete yet
 	(\x->readIORef ref>>= \(n,sz)->mapBlock table n>>=(`poke` swapEndian' x)>>(writeIORef ref$!(n+4,max(n+4) sz)))-}
 	(\_->fail"makeIoWriter: unimplemented")
 	(makeIoStream ref table lock)
@@ -59,26 +62,64 @@ 	(\_->fail"makeGenericWriter: unimplemented")
 	makeGenericStream
 
+{-# INLINE putToken #-}
 putToken :: (Monad m) => c -> ReaderT(SeekableWriter m c) m ()
 putToken c = ask>>=lift.(`_putToken` c)
 
+{-# INLINE putIntegralToken #-}
 putIntegralToken :: (Monad m) => Word32 -> ReaderT(SeekableWriter m c) m ()
 putIntegralToken n = ask>>=lift.(`_putIntegralToken` n)
 
+{-# INLINE consumeTokenW #-}
 consumeTokenW :: (Monad m) => ReaderT(SeekableWriter m c) m (Maybe c)
 consumeTokenW = ask>>=lift._consumeToken.stream
 
+{-# INLINE consumeIntegralTokenW #-}
 consumeIntegralTokenW :: (Monad m) => ReaderT(SeekableWriter m c) m (Maybe Word32)
 consumeIntegralTokenW = ask>>=lift._consumeIntegralToken.stream
 
+{-# INLINE getWriterPosition #-}
 getWriterPosition :: (Monad m) => ReaderT(SeekableWriter m c) m Word32
 getWriterPosition = ask>>=lift._getPosition.stream
 
+{-# INLINE seekWriter #-}
 seekWriter :: (Monad m) => Word32 -> ReaderT(SeekableWriter m c) m ()
 seekWriter n = ask>>=lift.(`_seek` n).stream
 
+{-# INLINE seekWriterAtEnd #-}
 seekWriterAtEnd :: (Monad m) => ReaderT(SeekableWriter m c) m ()
 seekWriterAtEnd = ask>>=lift._seekAtEnd.stream
 
+{-# INLINE relSeekWriter #-}
 relSeekWriter :: (Monad m) => Word32 -> ReaderT(SeekableWriter m c) m ()
-relSeekWriter n = ask>>=lift.runReaderT(relSeek n).stream+relSeekWriter n = ask>>=lift.runReaderT(relSeek n).stream
+
+{-# INLINE local' #-}
+local' f x = ask>>=lift.runReaderT x.f
+
+{-# INLINE hoistReaderM #-}
+hoistReaderM :: (Monad m, Monad n)
+	=> (forall t. m t->n t)
+	-> (forall t. n t->m t)
+	-> ReaderT(SeekableWriter m c) m u
+	-> ReaderT(SeekableWriter n c) n u
+hoistReaderM f f2 = hoist f.local'(hoistWriter f2)
+
+type PolyTraversalW ctx m d = Proxy ctx
+	-> (forall a. (Data ctx a) => a -> ReaderT(SeekableWriter m Word8) m ())
+	-> d -> ReaderT(SeekableWriter m Word8) m ()
+
+hoistPolyTraversalW :: (Monad m, Monad n)
+	=> (forall t. m t->n t)
+	-> (forall t. n t->m t)
+	-> PolyTraversalW ctx m u
+	-> PolyTraversalW ctx n u
+hoistPolyTraversalW f f2 traversal proxy g = hoistReaderM f f2.traversal proxy(\x->hoistReaderM f2 f.g$x)
+
+concludeFileWrite ref table@(Table path _) = do
+	(_,sz) <- readIORef ref
+	unmapAll table
+	bracket
+		(openBinaryFile path ReadWriteMode)
+		hClose
+		(`hSetFileSize` toInteger sz)

@@ -1,14 +1,16 @@-{-# LANGUAGE FlexibleContexts, Safe #-}
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, Safe #-}
 
--- | Some utility functions. All functions maintain the invariant that the stream is seeked
+-- | Some utility functions. The reader strategies maintain the invariant that the stream is seeked
 --   to the beginning of a data entity, so that it is safe to use 'readData'/'writeData'/'seekTo'
---   etc.
+--   etc. The writer strategies maintain the invariant that the writer is seeked at the word
+--   that should receive the address of the data entity that is written. This allows the writer
+--   to write eagerly the address and so be tail recursive in some cases.
 --
---   Think of a columbia file as just a giant transactional log that is continually being
+--   Think of a columbia file as just a transactional log that is continually being
 --   written to; transactions are able to reference other transactions by address, thus
 --   constructing data structures; a single address, called the root node address, at the
 --   beginning of the file determines the file's nominal mutable state. To keep the file from getting
---   too large, it is garbage collected periodically; bear in mind that calls to the
+--   too large, it is garbage collected periodically; calls to the
 --   collector have to be programmed to happen manually at a time convenient for your
 --   application.
 --
@@ -26,67 +28,105 @@ import System.FileLock
 import Control.Monad.Reader
 import Control.Monad.Trans
-import Control.Exception
+import Control.Monad.Error
+import Control.Monad.IO.Class
 import Data.Columbia.Headers
 import Data.Columbia.Integral
 import Data.Columbia.CompoundData
 import Data.Columbia.DualLock
 import Data.Columbia.Mapper
 
+bracket m f f2 = do
+	x <-m
+	x2 <-catchError(f2 x) (\e->do { f x; throwError e })
+	f x
+	return x2
+
+withFileLock' path mode = bracket
+	(liftIO$lockFile path mode)
+	(liftIO.unlockFile)
+
+-----------------------------------
+
 {-# INLINE seekToStart #-}
 seekToStart :: (Monad m) => ReaderT(SeekableStream m Word8) m ()
-seekToStart = do
-	seek 0
-	addr <- readIntegral
-	seek addr
+seekToStart = seek 0
 
 -- | Opens a file for reading, under appropriate locks; seeks to the beginning of the data;
---   runs the procedure.
-readFileWrapper :: FilePath -> ReaderT(SeekableStream IO Word8) IO t -> IO t
-readFileWrapper path proc = 
-	dualLockShared path>>= \l@(DualLockShared _ _ l2) ->
+--   runs the procedure. For common use, set m := IO.
+readFileWrapper :: (MonadError e m, MonadIO m)
+	=> FilePath
+	-> ReaderT(SeekableStream m Word8) m t
+	-> m t
+readFileWrapper path proc = liftIO(newIORef undefined)>>= \cursor->
 	bracket
-	(newTable path)
-	unmapAll
+	(liftIO$dualLockShared path)
+	(liftIO.unlockShared)
+	$ \l@(DualLockShared _ _ l2) ->
+	bracket
+	(liftIO$newTable path)
+	(liftIO.concludeFileWrite cursor)
 	$ \table ->
-	fileSizeShim table>>= \sz->
-	newIORef(0,sz)>>= \cursor->
-	let stream = makeIoStream cursor table l2 in
-	finally
-		(do
-		-- Unlock the writer lock once having retrieved the root block address.
-		withFileLock(path++".lock.writer") Exclusive$ \_->runReaderT seekToStart stream
-		runReaderT proc stream)
-		(unlockShared l)
+	do
+	liftIO$do
+		sz <-fileSizeShim table
+		writeIORef cursor$!(0,sz)
+	let stream = hoistStream liftIO$makeIoStream cursor table l2
+	-- Unlock the writer lock once having retrieved the root block address.
+	withFileLock'(path++".lock.writer") Exclusive$ \_->runReaderT seekToStart stream
+	runReaderT proc stream
 
 -- | Opens a file for /writing/, under appropriate locks; seeks to the beginning of the data;
 --   runs the procedure; accepts from the procedure an address to write as the new
 --   root node address.
-writeFileWrapper :: FilePath -> ReaderT(SeekableWriter IO Word8) IO Word32 -> IO()
-writeFileWrapper path proc = newIORef undefined>>= \cursor->
-	bracket
-	(newTable path)
-	unmapAll
-	$ \table->
+writeFileWrapper :: (MonadError e m, MonadIO m)
+	=> FilePath
+	-> ReaderT(SeekableWriter m Word8) m t
+	-> m t
+writeFileWrapper path proc = liftIO(newIORef undefined)>>= \cursor->
 	bracket
-	(dualLockShared path)
-	unlockShared
-	$ \_ ->
-	withFileLock(path++".lock.writer") Exclusive
+	(liftIO$dualLockShared path)
+	(liftIO.unlockShared)
+	$ \_->
+	withFileLock'(path++".lock.writer") Exclusive
 	$ \l ->
+	bracket
+	(liftIO$newTable path)
+	(liftIO.concludeFileWrite cursor)
+	$ \table ->
+	let writer = hoistWriter liftIO$makeIoWriter cursor table l in
 	runReaderT
 	(do
-		sz <- lift$fileSizeShim table
-		lift$writeIORef cursor$!(0,sz)
+		liftIO$do
+			sz <-fileSizeShim table
+			writeIORef cursor$!(0,sz)
 		sw <- ask
 		seekWriterAtEnd
 		len <- getWriterPosition
-		when(len == 0)$writeIntegral(0 :: Word32)
-		addr <- proc
-		seekWriter 0
+		addr::Word32 <- if len==0 then do
+			writeIntegral(0 :: Word32)
+			return$!0
+			else do
+		-- For robustness in case of power failures etc. I will special case the root block pointer
+		-- so it writes into a slop field. Once writing is complete, the slop field is copied into
+		-- the actual root block pointer field. That way an interruption to the writing procedure
+		-- does no harm to the file and leaves it in its previous nominal state.
+			seekWriter 0
+			local' stream readIntegral
+		seekWriterAtEnd
+		len2 <- getWriterPosition
+		-- Create slop field.
 		writeIntegral addr
+		seekWriter len2
+		x <- proc
+		-- Copy address into root block address field.
+		seekWriter len2
+		n::Word32 <- local' stream readIntegral
+		seekWriter 0
+		writeIntegral n
+		return x
 	)
-	(makeIoWriter cursor table l)
+	writer
 
 nFields hdr@(_, _, nFields) = if isHeaderArraytype hdr then do
 		readIntegral

@@ -1,66 +1,58 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable, DeriveFunctor, ScopedTypeVariables, Trustworthy #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable, ScopedTypeVariables, Trustworthy #-}
 
-module Data.Columbia.WithAddress where
+module Data.Columbia.WithAddress (WithAddress, addressOf, dataOf, withAddresses, writeBackAddresses) where
 
 import Data.Word
 import Data.Function
 import Data.Generics.SYB.WithClass.Basics
+import Data.Copointed
+import Data.Pointed
 import Generics.Pointless.Functors hiding (Functor)
 import Control.Monad
 import Control.Monad.Reader
 import Data.Columbia.CompoundData
 import Data.Columbia.CycleDetection
 import Data.Columbia.FRecord
+import Data.Columbia.Integral
 
 -- | Data type for a piece of data that may or may not have an explicit address associated with it.
 --   This is nice because I can play with these in pure code to manipulate data, while still
 --   remembering all of the explicit term structure.
 data WithAddress t = WithAddress Word32 t
-	| Address Word32 -- The address only.
-	| Data t
-	deriving (Read, Show, Typeable, Functor)
+	deriving (Eq, Ord, Show, Typeable)
 
+instance Copointed WithAddress where
+	{-# INLINE copoint #-}
+	copoint(WithAddress _ x) = x
+
+instance Pointed WithAddress where
+	{-# INLINE point #-}
+	point = WithAddress 0 -- Null address indicates that no address is known.
+
+{-# INLINE addressOf #-}
 addressOf :: WithAddress t -> Word32
 addressOf(WithAddress n _) = n
-addressOf(Address n) = n
-addressOf(Data _) = maxBound -- This has to be non-zero because reasons.
 
+{-# INLINE dataOf #-}
 dataOf :: WithAddress t -> t
-dataOf (WithAddress _ x) = x
-dataOf (Address _) = error"dataOf: Address"
-dataOf (Data x) = x
-
--- | A null address object.
-nullAddress = Address$!0
+dataOf = copoint
 
 instance (Sat(ctx Word32), Sat(ctx(WithAddress t)), Data ctx t) => Data ctx(WithAddress t) where
 	gfoldl _ o k (WithAddress n x) = k WithAddress `o` n `o` x
-	gfoldl _ o k (Address n) = k Address `o` n
-	gfoldl _ o k (Data x) = k Data `o` x
-	gunfold _ f k constr = case constrIndex constr of
-		1 -> f(f(k WithAddress))
-		2 -> f(k Address)
-		3 -> f(k Data)
-		_ -> error"gunfold for WithAddress: invalid constructor"
+	gunfold _ f k _ = f(f(k WithAddress))
 	dataTypeOf proxy _ =
 		let ty = DataType "Data.Columbia.WithAddresses.WithAddress" (AlgRep[
-			Constr(AlgConstr 1) "WithAddress" [] Prefix ty,
-			Constr(AlgConstr 2) "Address" [] Prefix ty,
-			Constr(AlgConstr 3) "Data" [] Prefix ty]) in
+			Constr(AlgConstr 1) "WithAddress" [] Prefix ty]) in
 			ty
-	toConstr proxy x@(WithAddress _ _) = case dataTypeOf proxy x of
-		DataType _(AlgRep[c,_,_]) -> c
-	toConstr proxy x@(Address _) = case dataTypeOf proxy x of
-		DataType _(AlgRep[_,c,_]) -> c
-	toConstr proxy x@(Data _) = case dataTypeOf proxy x of
-		DataType _(AlgRep[_,_,c]) -> c
+	toConstr proxy x = case dataTypeOf proxy x of
+		DataType _(AlgRep ls) -> head ls
 	dataCast1 _ f = gcast1 f
 
 instance (Typeable t) => RW(WithAddress t)
 
 -- Addresses (file offsets) can serve as keys for purposes of cycle detection.
 instance KeyComparable(WithAddress t) where
-	isKeyed (Data _) = False
+	isKeyed (WithAddress 0 _) = False
 	isKeyed _ = True
 	keyCompare = compare `on` addressOf
 
@@ -69,24 +61,19 @@ --   relinquished, due to GC'ing (unless you do something heroic with your own locking pattern).
 withAddresses :: forall ctx m d. (Data ctx d, Monad m) => PolyTraversal ctx m d
 withAddresses proxy m = case dataCast1 proxy(do
-	n <- getPosition
-	if n == 0 then
-			return$!Address$!0
-		else
-			liftM(WithAddress n) m) of
+	addr <- readIntegral
+	relSeek(-4)
+	liftM(WithAddress addr) m) of
 	Just m2 -> m2
 	Nothing -> m
 
-newtype Fl m t = Fl { unFl :: t -> ReaderT(SeekableWriter m Word8) m Word32 }
+newtype Fl m t = Fl { unFl :: t -> ReaderT(SeekableWriter m Word8) m () }
 
 -- | A strategy to intelligently reconstruct shared structure on disk. It intercepts any subterm with
 --   type 'WithAddress' and that associates an address to the data, and writes that address
---   in lieu of writing all of the data. The term structure of 'WithAddress' constructor itself
---   never ends up in the file.
+--   in lieu of writing all of the data, thereby achieving structural sharing. The term structure of
+--   'WithAddress' constructor itself is never written to the file.
 writeBackAddresses ::  forall ctx m d. (Data ctx d, Monad m) => PolyTraversalW ctx m d
-writeBackAddresses proxy f d = case dataCast1 proxy(Fl$ \d2 -> case d2 of
-		WithAddress n _ -> return n
-		Address n -> return n
-		Data x -> f x) of
+writeBackAddresses proxy f d = case dataCast1 proxy(Fl$ \d2 -> if addressOf d2==0 then f$dataOf d2 else writeIntegral$addressOf d2) of
 	Just fl -> unFl fl d
 	Nothing -> f d