columbia (empty) → 0.1.0.0

raw patch · 20 files changed

+1873/−0 lines, 20 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, bytestring, containers, contravariant, directory, filelock, invariant, mmap, mmorph, monad-loops, mtl, parallel, pointless-haskell, syb-with-class, transformers

Files

• ChangeLog.md +5/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• columbia.cabal +28/−0
• src/Data/Columbia.hs +43/−0
• src/Data/Columbia/Coercion.hs +19/−0
• src/Data/Columbia/CompoundData.hs +189/−0
• src/Data/Columbia/CycleDetection.hs +182/−0
• src/Data/Columbia/DualLock.hs +58/−0
• src/Data/Columbia/FRecord.hs +13/−0
• src/Data/Columbia/Gc.hs +383/−0
• src/Data/Columbia/Headers.hs +124/−0
• src/Data/Columbia/Integral.hs +45/−0
• src/Data/Columbia/Mapper.hs +132/−0
• src/Data/Columbia/Orphans.hs +90/−0
• src/Data/Columbia/RWInstances.hs +136/−0
• src/Data/Columbia/SeekableStream.hs +142/−0
• src/Data/Columbia/SeekableWriter.hs +66/−0
• src/Data/Columbia/Utils.hs +94/−0
• src/Data/Columbia/WithAddress.hs +92/−0

@@ -0,0 +1,5 @@+# Revision history for columbia
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

@@ -0,0 +1,30 @@+Copyright (c) 2017, James Candy
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * 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.
+
+    * Neither the name of James Candy nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT
+OWNER 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.

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

@@ -0,0 +1,28 @@+-- Initial columbia.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                columbia
+version:             0.1.0.0
+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 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 ;).
+license:             BSD3
+license-file:        LICENSE
+author:              James Candy
+maintainer:          jacinablackbox@yahoo.com
+-- copyright:           
+category:            Data
+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
+  -- other-extensions:    
+  build-depends:       base >=4.6 && <4.9, 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, 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, QuickCheck ==2.10, transformers ==0.4.2.0, mmap ==0.5.9
+  if os(mingw32)
+    cpp-options: -DWIN32
+  hs-source-dirs:      src
+  default-language:    Haskell98

@@ -0,0 +1,43 @@+{-# 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,
+-- ** Idioms
+rwProxy, readCompoundData, writeCompoundData, rwKeyProxy, readDataWithCycles, writeDataWithCycles) where
+
+import Data.Map
+import Data.Dynamic (Dynamic)
+import Data.Columbia.CompoundData
+import Data.Columbia.CycleDetection
+import Data.Columbia.Utils
+import Data.Columbia.Integral
+import Data.Columbia.Gc
+import Data.Columbia.FRecord
+import Data.Columbia.WithAddress
+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
+
+rwProxy :: Proxy(PairCtx RWCtx NoCtx)
+rwProxy = undefined
+
+-- | Most common idiom of using 'readOneLayer'; reads an entire data structure.
+readCompoundData :: forall m d. (Monad m, Data(PairCtx RWCtx NoCtx) d) => ReaderT(SeekableStream m Word8) m d
+readCompoundData = fixT rwProxy(withAddresses rwProxy #. readOneLayer rwProxy)
+
+-- | 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
+writeCompoundData = fixTW rwProxy(writeBackAddresses rwProxy ##. writeOneLayer rwProxy)
+
+rwKeyProxy :: Proxy(PairCtx RWCtx(PairCtx KeyCtx NoCtx))
+rwKeyProxy = undefined
+
+readDataWithCycles :: forall m d. (MonadFix m, StateM m, StateOf m ~ Map Word32 Dynamic, Data(PairCtx RWCtx(PairCtx KeyCtx NoCtx)) d) => ReaderT(SeekableStream m Word8) m d
+readDataWithCycles = fixT rwKeyProxy(withAddresses rwKeyProxy #. cycleDetect rwKeyProxy #. readOneLayer rwKeyProxy)
+
+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
+writeDataWithCycles = fixTW rwKeyProxy(writeBackAddresses rwKeyProxy ##. cycleDetectW rwKeyProxy ##. writeOneLayer rwKeyProxy)

@@ -0,0 +1,19 @@+{-# LANGUAGE Trustworthy #-}
+
+module Data.Columbia.Coercion (floatToInt32, int32ToFloat) where
+
+import Foreign.Marshal.Utils
+import Foreign.Storable
+import Foreign.Ptr
+import System.IO.Unsafe
+import Data.Int
+
+{-# INLINE unsafeCoerceBits #-}
+unsafeCoerceBits :: (Storable t, Storable u) => t -> u
+unsafeCoerceBits n = unsafePerformIO$with n(peek.castPtr)
+
+floatToInt32 :: Float -> Int32
+floatToInt32 = unsafeCoerceBits
+
+int32ToFloat :: Int32 -> Float
+int32ToFloat = unsafeCoerceBits

@@ -0,0 +1,189 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs, ScopedTypeVariables, TypeOperators, Rank2Types, AllowAmbiguousTypes, 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
+--   context FooCtx that a program uses, one has a constraint /HasField ctx FooCtx/, that allows
+--   one to find the context evidence in the concrete context.
+--
+--   The recursive function that is generally needed to traverse an inductive data type instance is
+--   implemented in 'readOneLayer'. A bare-bones reader function is then /let r = readOneLayer proxy r in r/.
+--   A poly-traversal is a function that is inserted into this recursive call chain. For instance,
+--   'cycReadCompoundData' is a poly-traversal implementing cycle detection for circular data dependencies,
+--   but it leaves the programmer free to determine exactly how the layers are to be read.
+--   The types of poly-traversals are found in 'PolyTraversal' and 'PolyTraversalW'.
+--
+--   Technically, the type of poly-traversals encompasses all co-recursive definitions at that type.
+--   Well-founded recursion cannot be guaranteed owing to the cyclical nature of data structures.
+--   If one needs recursion to be well-founded, one can use 'cycReadCompoundData' -- the well-foundedness
+--   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,
+-- ** Compound data read/write strategies
+RW(..), RWCtx(..), PolyTraversal, readOneLayer, PolyTraversalW, writeOneLayer, seekToField) where
+
+import Data.Generics.SYB.WithClass.Basics
+import Data.Word
+import Data.Int
+import Data.Maybe
+import Data.Array
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Monad.Identity
+import Control.Monad.Trans
+import Control.Monad
+import Data.Columbia.SeekableStream
+import Data.Columbia.SeekableWriter
+import Data.Columbia.Integral
+import Data.Columbia.Headers
+import Data.Columbia.RWInstances
+import Data.Columbia.FRecord
+
+infixl 9 #.
+infixl 9 ##.
+
+(#.) :: (Data ctx t)
+	=> PolyTraversal ctx m t
+	-> (forall t2. (Data ctx t2) => PolyTraversal ctx m t2)
+	-> PolyTraversal ctx m t
+(traversal #. traversal2) f = traversal(traversal2 f)
+
+(##.) :: (Data ctx t)
+	=> PolyTraversalW ctx m t
+	-> (forall t2. (Data ctx t2) => PolyTraversalW ctx m t2)
+	-> PolyTraversalW ctx m t
+(traversal ##. traversal2) f = traversal(traversal2 f)
+
+fixT :: (Data ctx t)
+	=> Proxy ctx
+	-> (forall t2. (Data ctx t2) => PolyTraversal ctx m t2)
+	-> ReaderT(SeekableStream m Word8) m t
+fixT proxy traversal = traversal(fixT proxy traversal)
+
+fixTW :: (Data ctx t)
+	=> Proxy ctx
+	-> (forall t2. (Data ctx t2) => PolyTraversalW ctx m t2)
+	-> t
+	-> ReaderT(SeekableWriter m Word8) m Word32
+fixTW proxy traversal = traversal(fixTW proxy traversal)
+
+-- | Try to cast from the first traversal; if that fails, use the second traversal.
+typeCoerce :: (Typeable t, Data ctx t2)
+	=> Proxy ctx
+	-> PolyTraversal ctx m t
+	-> (forall t3. (Data ctx t3) => PolyTraversal ctx m t3)
+	-> PolyTraversal ctx m t2
+typeCoerce _ traversal traversal2 m = 
+	maybe
+	(traversal2 m)
+	id
+	(gcast(traversal m))
+
+------------------------------------
+
+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"
+
+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
+recursor rec proxy = do
+	~(x:xs) <- get
+	put xs
+	lift$do
+		seek x
+		rec
+
+-- | A 'PolyTraversal' is a reader method over a data type, parameterized over a method to read components.
+--   Think: the targets have /wide appeal/, making it /easy to find a buyer/.
+type PolyTraversal ctx m d = (forall a. (Data ctx a) => ReaderT(SeekableStream m Word8) m a)
+	-> ReaderT(SeekableStream m Word8) m d
+
+-- | Function returns something 'PolyTraversal'. We can use this to examine the top layer
+--   of a data structure, then seek to and read some of its components.
+readOneLayer :: forall ctx m d. (Monad m, HasField ctx RWCtx, Data ctx d)
+	=> Proxy ctx
+	-> PolyTraversal ctx m d
+readOneLayer proxy0 m = do
+	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.
+	-- If they don't match, reading cannot continue.
+	hdr@(_, ix, _) <- readHeader
+	let hdr2 = headerFromConstr proxy0 specimen(indexConstr ty ix)
+	when(hdr/=hdr2)$fail$"readCompoundData: header check failed "++
+		"(header from file is "++showsPrec 11 hdr
+		("; header from program is "++showsPrec 11 hdr2 ")")
+	if isHeaderAlgtype hdr || isHeaderArraytype hdr then do
+			-- Construct a term skeleton; transforming this skeleton will load the data.
+			specimen2 <- if isHeaderArraytype hdr then do
+					l <- readIntegral
+					return$!enhancedFromConstr proxy0 ty hdr l
+				else
+					return$!enhancedFromConstr proxy0 ty hdr 0
+			(_ :: d, ls) <- runWriterT(gmapM
+				proxy0
+				(\_ -> readAddresses proxy0)
+				specimen2)
+			-- Construct a 'PolyTraversal' that reads the sub-components.
+			evalStateT
+				(gmapM
+				proxy0
+				(\_ -> recursor m proxy0)
+				specimen2)
+				ls
+		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
+	n <- get
+	put$!n+4
+	lift$do
+		seekWriter n
+		writeIntegral x
+	return$error"recursorW: unused"
+
+type PolyTraversalW ctx m d = (forall a. (Data ctx a) => a -> ReaderT(SeekableWriter m Word8) m Word32)
+	-> d -> ReaderT(SeekableWriter m Word8) m Word32
+
+-- | 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) => Proxy ctx -> PolyTraversalW ctx m d
+writeOneLayer proxy0 f d = do
+	let ty = dataTypeOf proxy0 d
+	m <- getWriterPosition
+	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)
+				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
+	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

@@ -0,0 +1,182 @@+{-# LANGUAGE ConstraintKinds, ExistentialQuantification, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, DeriveDataTypeable, TypeFamilies, StandaloneDeriving, Trustworthy #-}
+
+-- | PolyTraversals that add cycle detection and fixed point construction to any R/W strategy.
+module Data.Columbia.CycleDetection where
+
+import Data.Map
+import Data.Set (Set)
+import Data.Int
+import Data.Word
+import Data.IORef
+import Data.Dynamic hiding (Proxy)
+import Data.Generics.SYB.WithClass.Basics
+import Data.Columbia.CompoundData
+import Data.Columbia.FRecord
+import Data.Columbia.Orphans
+import Generics.Pointless.Functors
+import Generics.Pointless.Combinators
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Fix
+import Prelude hiding (lookup)
+
+import Data.Array
+import qualified Data.Array.Unboxed as U
+
+class (Monad m) => StateM m where
+	type StateOf m :: *
+	mfy' :: (StateOf m -> (StateOf m, a)) -> m a
+
+instance (Monad m) => StateM(StateT s m) where
+	type StateOf(StateT s m) = s
+	mfy' f = get>>= \s -> let(s', x) = f s in (put$!s')>>return x
+instance StateM(ReaderT(IORef s) IO) where
+	type StateOf(ReaderT(IORef s) IO) = s
+	mfy' f = ask>>=lift.(`atomicModifyIORef'` f)
+
+get' :: (StateM m) => m(StateOf m)
+get' = mfy'(\s -> (s, s))
+put' s = mfy'(\_ -> (s, ()))
+
+-- | 'isKeyed' may always return false, but if it returns true ever, 'keyCompare'
+--   must be well-defined and a valid equivalence relation on values for which
+--   'isKeyed' returns true (i.e. where all values concerned have /isKeyed x=true/).
+--The default is to have 'isKeyed' return false on all values.
+class KeyComparable t where
+	isKeyed :: t->Bool
+	isKeyed _ = False
+	keyCompare :: t -> t->Ordering
+	keyCompare _ _ = error"KeyComparable.keyCompare: is not a keyed data type"
+
+data KeyCtx t = (KeyComparable t) => KeyCtx
+
+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
+	isKeyed(DynamicWithCtx x) = isKeyed x
+	keyCompare(DynamicWithCtx x) (DynamicWithCtx x2) = maybe(compare(typeOf x) (typeOf x2)) (`keyCompare` x2) (cast x)
+instance Ord(DynamicWithCtx KeyComparable) where
+	-- Here I'm going to assume that all data being compared have keys.
+	compare = keyCompare
+instance Eq(DynamicWithCtx KeyComparable) where
+	(==) d = (==EQ).keyCompare d
+
+type CycleDetectionR m = StateT(Map Word32 Dynamic) m
+type CycleDetectionW m = StateT(Map(DynamicWithCtx KeyComparable) Word32) m
+type CycleDetectionRIO = ReaderT(IORef(Map Word32 Dynamic)) IO
+type CycleDetectionWIO = ReaderT(IORef(Map(DynamicWithCtx KeyComparable) Word32)) IO
+
+cycleDetect :: forall ctx m t. (MonadFix m, StateM m, StateOf m ~ Map Word32 Dynamic, HasField ctx RWCtx, Data ctx t)
+	=> Proxy ctx -> PolyTraversal ctx m t
+cycleDetect proxy m =
+	getPosition>>= \n->
+	lift get'>>=
+	maybe
+		(mfix(\x -> do
+			lift$mfy'(\mp -> (insert n(toDyn x) mp, ()))
+			m))
+		(maybe
+			(fail$"cycleDetect: type mismatch")
+			return
+			.fromDynamic)
+		.lookup n
+
+cycleDetectW :: forall ctx m t. (StateM m, StateOf m ~ Map(DynamicWithCtx KeyComparable) Word32, HasField ctx RWCtx, HasField ctx KeyCtx, Data ctx t)
+	=> Proxy ctx
+	-> PolyTraversalW ctx m t
+cycleDetectW proxy f x =
+	case hasField(dict :: ctx t) :: KeyCtx t of
+		KeyCtx ->
+			let d = dynamicWithCtx x in
+			lift get'>>= \mp->
+			maybe
+				(do
+				addr <- getWriterPosition
+				when(isKeyed d)$lift$put'$insert d addr mp
+				f x)
+				return
+				$lookup d mp
+
+runCycleDetectionR :: (Monad m)
+	=> ReaderT(SeekableStream(CycleDetectionR m) Word8) (CycleDetectionR m) t
+	-> ReaderT(SeekableStream m Word8) m t
+runCycleDetectionR m = do
+	s <- ask
+	lift$evalStateT(runReaderT m(hoistStream lift s)) empty
+
+runCycleDetectionW :: (Monad m)
+	=> ReaderT(SeekableWriter(CycleDetectionW m) Word8) (CycleDetectionW m) t
+	-> ReaderT(SeekableWriter m Word8) m t
+runCycleDetectionW m = do
+	sw <- ask
+	lift$evalStateT(runReaderT m(hoistWriter lift sw)) empty
+
+-----------------------------------
+
+-- | A 'Pair' is a good data structures for associating a key and a value.
+data Pair k v = Pair k v deriving (Read, Show, Typeable, Eq, Ord)
+
+instance (Ord k) => KeyComparable(Pair k v) where
+	isKeyed _ = True
+	keyCompare(Pair k _) (Pair k2 _) = compare k k2
+
+pairCtor = Constr(AlgConstr 1) "Pair" [] Prefix pairDataType
+pairDataType = DataType "Data.Columbia.CycleDetection"(AlgRep[pairCtor])
+instance (Sat(ctx(Pair k v)), Data ctx k, Data ctx v) => Data ctx(Pair k v) where
+	gfoldl _ o f (Pair k v) = f Pair `o` k `o` v
+	gunfold _ k f _ = k(k(f Pair))
+	dataTypeOf _ _ = pairDataType
+	toConstr _ _ = pairCtor
+	dataCast2 _ f = gcast2 f
+
+instance (Typeable k, Typeable v) => RW(Pair k v)
+
+type instance Rep(Pair k) v = Pair k v
+
+instance ToRep(Pair k) where
+	rep = id
+	unrep _ _ = id
+	val _ = ann
+	fun _ = ann
+
+-- Some boilerplate instances
+instance KeyComparable(t1,t2)
+instance KeyComparable(t1,t2,t3)
+instance KeyComparable(t1,t2,t3,t4)
+instance KeyComparable(t1,t2,t3,t4,t5)
+instance KeyComparable(Either t t2)
+instance KeyComparable(Maybe t)
+instance KeyComparable[t]
+instance KeyComparable(Map t u)
+instance KeyComparable(Set t)
+instance KeyComparable(Array i e)
+instance KeyComparable(U.UArray i e)
+instance KeyComparable Int
+instance KeyComparable Word
+instance KeyComparable Int8
+instance KeyComparable Word8
+instance KeyComparable Int16
+instance KeyComparable Word16
+instance KeyComparable Int32
+instance KeyComparable Word32
+instance KeyComparable Int64
+instance KeyComparable Word64
+instance KeyComparable Float
+instance KeyComparable Char
+instance KeyComparable Ordering
+instance KeyComparable Bool
+instance KeyComparable ()
+instance KeyComparable ((:+:) f g x)
+instance KeyComparable ((:*:) f g x)
+instance KeyComparable ((:@:) f g x)
+instance KeyComparable (Fix f)
+instance KeyComparable (LazyFix f)
+instance KeyComparable (Const x x2)
+instance KeyComparable (Id x)

@@ -0,0 +1,58 @@+{-# LANGUAGE Safe #-}
+
+-- | A dual lock can be taken in either exclusive or shared mode, and also supports
+--   switching (atomically) from one mode to the other.
+module Data.Columbia.DualLock where
+
+import System.IO
+import System.FileLock
+import Control.Monad
+
+data DualLockShared = DualLockShared!FilePath !FileLock !FileLock
+data DualLock = DualLock!FilePath !FileLock !FileLock
+
+dualLockShared :: FilePath -> IO DualLockShared
+dualLockShared path = liftM2(DualLockShared path)
+	(lockFile(path++".lock") Shared)
+	(lockFile(path++".lock2") Shared)
+
+dualLock :: FilePath -> IO DualLock
+dualLock path = do
+	l1 <- lockFile(path++".lock") Exclusive
+	tryLockFile(path++".lock2") Exclusive>>=maybe
+		(do
+		unlockFile l1
+		dualLock path)
+		((return$!).DualLock path l1)
+
+unlockShared :: DualLockShared -> IO()
+unlockShared(DualLockShared _ l1 l2) = unlockFile l1>>unlockFile l2
+
+unlock :: DualLock -> IO()
+unlock(DualLock _ l1 l2) = unlockFile l1>>unlockFile l2
+
+-- | N.B. That two simultaneous attempts to switch locks will deadlock. Please protect a critical
+--   section that switches locks with some other lock, to ensure this doesn't happen. For instance,
+--   the garbage collector protects its use of 'switchLocks' on a dual lock, with an exclusive
+--   writer lock.
+switchLocks :: DualLockShared->IO DualLock
+switchLocks(DualLockShared path l1 l2) = do
+	unlockFile l1
+	l3 <- lockFile(path++".lock") Exclusive
+	unlockFile l2
+	tryLockFile(path++".lock2") Exclusive>>=maybe
+		(do
+		l2' <- lockFile(path++".lock2") Shared
+		unlockFile l3
+		l1' <- lockFile(path++".lock") Shared
+		switchLocks$!DualLockShared path l1' l2')
+		((return$!).DualLock path l3)
+
+-- | Switching from an exclusive to a shared lock may be done at any time.
+switchLocks2 :: DualLock->IO DualLockShared
+switchLocks2(DualLock path l1 l2) = do
+	unlockFile l2
+	l4 <- lockFile(path++".lock2") Shared
+	unlockFile l1
+	l3 <- lockFile(path++".lock") Shared
+	return$!DualLockShared path l3 l4

@@ -0,0 +1,13 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, OverlappingInstances, Trustworthy #-}
+
+module Data.Columbia.FRecord where
+
+import Data.Generics.SYB.WithClass.Context
+
+class HasField scheme f where
+	hasField :: scheme t -> f t
+
+instance HasField(PairCtx f f2) f where
+	hasField(PairCtx fn _) = fn
+instance (HasField scheme f2) => HasField(PairCtx f scheme) f2 where
+	hasField(PairCtx _ fn2) = hasField fn2

@@ -0,0 +1,383 @@+{-# LANGUAGE ScopedTypeVariables, Safe #-}
+
+-- | A brief note on the locking strategy:
+--
+--   A Columbia data file is covered by three locks: a dual lock (comprising two locks) and a writer lock;
+--   the lock hierarchy goes in that order. The dual lock is taken in a shared mode during
+--   all reading. The only circumstance in which the dual lock is taken
+--   in exclusive mode is to execute the write phase of a garbage collection.
+--
+--   The writer lock protects the action of writing to the end of the file and also
+--   to the root node offset; readers take the writer lock only during reading the root node
+--   offset; the writer lock is always taken in exclusive mode.
+--
+--   The high level view is: you can always run the collector in parallel with any other
+--   operation you are doing; you can read freely while using the collector; writes to the
+--   file will be held up until the collector finishes.
+module Data.Columbia.Gc (markAndSweepGc) where
+
+import Control.Monad.Reader
+import Control.Monad
+import Control.Monad.Loops
+import Control.Exception
+import System.IO
+import System.IO.Error	
+import System.Directory
+import System.FileLock
+import Data.Char
+import Data.Word
+import Data.Bits
+import Data.IORef
+import Data.Columbia.RWInstances
+import Data.Columbia.Integral
+import Data.Columbia.Headers
+import Data.Columbia.DualLock
+import Data.Columbia.SeekableStream
+import Data.Columbia.SeekableWriter
+import Data.Columbia.Mapper
+
+{-guardedGetChar handle =
+	catchError(getWord8 handle)
+		(\ex -> if isEOFError ex then
+				return 0
+			else throwError ex)-}
+
+setBitAt :: (Monad m) => SeekableWriter m Word8 -> Word32 -> m()
+setBitAt writer n = runReaderT(do
+	let (dv, md) = divMod n 8
+	seekWriter dv
+	m <- liftM(maybe 0 id)$consumeTokenW
+	seekWriter dv
+	let m' = setBit m(fromIntegral md)
+	putToken m')
+	writer
+getBitAt :: (Monad m) => SeekableWriter m Word8 -> Word32 -> m(Maybe Bool)
+getBitAt writer n = runReaderT(do
+	let (dv, md) = divMod n 8
+	seekWriter dv
+	liftM(liftM(`testBit` fromIntegral md)) consumeTokenW)
+	writer
+getBitAt' :: (Monad m) => SeekableWriter m Word8 -> Word32 -> m Bool
+getBitAt' writer n = liftM(maybe False id)$getBitAt writer n
+
+_mark :: (Monad m) => SeekableWriter m Word8 -> Word32 -> ReaderT(SeekableStream m Word8) m ()
+_mark tmpwriter addr = do
+	bool <- lift$getBitAt' tmpwriter addr
+	unless bool$do
+		seek addr
+		hdr <- readHeader
+		-- Have to determine how many bytes to mark and how many fields to recurse on.
+		-- In the case of primitive types it is zero fields.
+		(nFields, nBytes) <- nFieldsBytes hdr
+		-- Mark fields
+		lift$mapM_(setBitAt tmpwriter) [fromIntegral addr..fromIntegral addr+fromIntegral nBytes-1]
+		-- Read addresses and recurse on them.
+		addrs <- sequence(replicate nFields readIntegral)
+		mapM_(_mark tmpwriter) addrs
+
+mark :: FilePath -> SeekableStream IO Word8 -> IO(FilePath,SeekableWriter IO Word8,IORef(Word32,Word32),Table)
+mark path stream = do
+	dir <- getTemporaryDirectory
+	(tmppath, tmphandle) <- openBinaryTempFile dir "mark"
+	hClose tmphandle
+	ref <- newIORef$!(0,0)
+	table <- newTable tmppath
+	let tmpwriter = makeIoWriter ref table undefined
+	-- Mark root node.
+	mapM_(setBitAt tmpwriter) [0..3]
+	runReaderT(do
+		-- Read root node.
+		addr <- readIntegral
+		-- ...and proceed to recurse on the structure of the data.
+		_mark tmpwriter addr)
+		stream
+	return$!(tmppath,tmpwriter,ref,table)
+
+{-# INLINE forLoop #-}
+forLoop :: (MonadIO m) => IORef Word32 -> (Word32 -> m Bool) -> m Word32
+forLoop ref f = do
+	whileM_(liftIO(readIORef ref)>>=f)$liftIO$modifyIORef' ref succ
+	liftIO$readIORef ref
+
+untilEOF :: (Monad m)
+	=> ReaderT(SeekableWriter m Word8) m t
+	-> ReaderT(SeekableWriter m Word8) m Bool
+untilEOF m = do
+	-- Save writer position; determine file size.
+	x <- getWriterPosition
+	seekWriterAtEnd
+	n <- getWriterPosition
+	seekWriter x
+	whileM_
+		(do
+		x2 <- getWriterPosition
+		return$!n/=x2)
+		m
+	x2 <- getWriterPosition
+	return$!n==x2
+
+untilEOF' :: (Monad m)
+	=> ReaderT(SeekableStream m Word8) m t
+	-> ReaderT(SeekableStream m Word8) m ()
+untilEOF' m = do
+	x <- getPosition
+	seekAtEnd
+	n <- getPosition
+	seek x
+	whileM_
+		(do
+		x2 <- getPosition
+		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
+	dir <- getTemporaryDirectory
+	(tmppath2, tmphandle2) <- openBinaryTempFile dir "compressed"
+	hClose tmphandle2
+	counter <- newIORef 0
+	newSize <- newIORef 0
+	ref <- newIORef$!(0,0)
+	table <- newTable tmppath2
+	let tmpwriter2 = makeIoWriter ref table undefined
+	m <- runReaderT(do
+		-- Save writer position; determine file size.
+		lift$_seekAtEnd$stream tmpwriter
+		newFileSize <- lift$_getPosition$stream tmpwriter
+		lift$_seek(stream tmpwriter) 0
+		whileM_
+			(lift$liftM(/=newFileSize) (_getPosition$stream tmpwriter))
+			(do
+				m <- lift$readIORef counter
+				sz <- lift$readIORef newSize
+				lift$forLoop counter(liftM(maybe False id).getBitAt tmpwriter)
+				n <- lift$readIORef counter
+				writeIntegral m
+				writeIntegral n
+				writeIntegral sz
+				lift$writeIORef newSize$!sz+n-m
+				lift$forLoop counter(liftM(maybe False not).getBitAt tmpwriter)
+			)
+		-- Stick on an extra piece that lets pointer fixups reconcile extra stuff.
+		m <- lift$readIORef counter
+		sz <- lift$readIORef newSize
+		writeIntegral m
+		writeIntegral(maxBound :: Word32)
+		writeIntegral sz
+		return m)
+		tmpwriter2
+
+	return$!((tmppath2,tmpwriter2),m)
+
+-- N.B. That this only works if 1) ranges are disjoint, or 2) to <= fromStart.
+copyRange :: (Monad m) => SeekableWriter m Word8 -> Word32 -> Word32 -> Word32 -> m()
+copyRange writer to fromStart fromEnd = runReaderT(
+	mapM_
+	(\ii -> do
+	seekWriter ii
+	ch <- liftM(maybe(error"end of file") id) consumeTokenW
+	seekWriter$!ii-fromStart+to
+	putToken ch)
+	[fromStart..fromEnd-1])
+	writer
+
+sweep :: SeekableWriter IO Word8 -> IORef(Word32,Word32) -> Table -> SeekableStream IO Word8 -> IO()
+sweep writer newref newtable@(Table newpath _) tmpstream2 = do
+	newSize <- newIORef 0
+	runReaderT(do
+		seekAtEnd
+		compressSz <- getPosition
+		seek 0
+		whileM_
+			(liftM(/=compressSz-12) getPosition)
+			(do
+			st <- readIntegral
+			end <- readIntegral
+			sz <- readIntegral
+			lift$copyRange writer sz st end
+			lift$writeIORef newSize$!sz+end-st)
+			)
+		tmpstream2
+	unmapAll newtable
+	-- Once the file is all sweeped have to find the end of the file
+	-- and truncate it. (The actual truncation is postponed until the end.)
+	n <- readIORef newSize
+	writeIORef newref$!(0,n)
+
+_fixUpPointers :: (Monad m) => Word32 -> Word32 -> Word32 -> ReaderT(SeekableStream m Word8) m Word32
+_fixUpPointers start end addr2 = do
+	let half = (end-start)`quot`2+start
+	seek$12*half
+	st <- readIntegral
+	en <- readIntegral
+	if addr2 < st then
+			_fixUpPointers start half addr2
+		else if addr2 >= en then
+			_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
+-- further.
+_fixUpPointers2 :: (Monad m) => SeekableStream m Word8 -> Word32 -> Word32 -> ReaderT(SeekableWriter m Word8) m Word32
+_fixUpPointers2 tmpstream2 len addr = do
+	seekWriter addr
+	addr2 <- local' stream$readIntegral
+	n <- lift$runReaderT(_fixUpPointers 0 len addr2) tmpstream2
+	seekWriter addr
+	writeIntegral n
+	return addr2
+
+_fixUpPointers3 tmpwriter tmpstream2 len addr = do
+	b <- lift$getBitAt' tmpwriter addr
+	unless(b||addr==0)$do --Account for possible zero addresses.
+		seekWriter addr
+		hdr <- local' stream readHeader
+		(nFields, nBytes) <- local' stream(nFieldsBytes hdr)
+		n <- getWriterPosition
+		-- Mark fields to prevent following addresses twice
+		lift$mapM_(setBitAt tmpwriter) [addr..addr+fromIntegral nBytes-1]
+		-- Adjust record's pointers
+		addrs <- mapM(_fixUpPointers2 tmpstream2 len) [n,n+4..n+4*fromIntegral nFields-4]
+		-- Recurse on the structure of the data.
+		mapM_(_fixUpPointers3 tmpwriter tmpstream2 len) addrs
+
+_fixUpPointers4 :: (MonadIO m) => SeekableStream m Word8 -> Word32 -> [IORef Word32] -> m()
+_fixUpPointers4 tmpstream2 len moreAddresses =
+	mapM_(\addrRef -> do
+		addr2 <- liftIO$readIORef addrRef
+		n <- runReaderT(_fixUpPointers 0 len addr2) tmpstream2
+		liftIO$writeIORef addrRef n
+		) moreAddresses
+
+void' m = liftM(const()) m
+_fixUpPointers5 :: (Monad m) => SeekableWriter m Word8 -> SeekableStream m Word8 -> Word32 -> Word32->ReaderT(SeekableWriter m Word8) m ()
+_fixUpPointers5 tmpwriter tmpstream2 len addr = do
+	seekWriterAtEnd
+	x <- getWriterPosition
+	seekWriter addr
+	-- Going to scan the differential segment and mop up its addresses.
+	void'$untilEOF(do
+		-- Scan over zeroes.
+		whileM_
+			(liftM(maybe False(==0)) consumeTokenW)
+			(return())
+		n <- getWriterPosition
+		unless(x==n)$do
+			relSeekWriter(-1)
+			n <- getWriterPosition
+			hdr <- local' stream readHeader
+			m <- getWriterPosition
+			(nFields, nBytes) <- local' stream$nFieldsBytes hdr
+			mapM_(_fixUpPointers2 tmpstream2 len) [m,m+4..m+4*fromIntegral nFields-4]
+			seekWriter$n+fromIntegral nBytes
+		)
+
+fixUpPointers writer tmpwriter tmpstream2 moreAddresses = do
+	len <- liftM(`quot`12)$runReaderT
+		(seekAtEnd>>getPosition)
+		tmpstream2
+	runReaderT
+		(do
+		seekWriter 0
+		addr <- local' stream$readIntegral
+		_fixUpPointers3 tmpwriter tmpstream2 len addr
+		)
+		writer
+	_fixUpPointers4 tmpstream2 len moreAddresses
+	return len
+
+-- | Garbage collection for files. It is a good idea when using garbage collection, never
+--   to be holding addresses into a file when releasing that file's lock, as at that point the
+--   garbage collector may move the data referenced. There is also a pattern, where only
+--   one thread runs the garbage collector; in that case, the collector thread may hold addresses
+--   and have these updated when the garbage collector moves data. These are currently the only
+--   safe patterns for using addresses with the collector:
+--
+--   * Multi-thread GC with use of addresses protected by locks.
+--
+--   * Single-thread GC with use of addresses unprotected by locks /solely in the GC thread/
+--     and protected use of addresses in other threads.
+--
+--  Also note that appropriate locks are applied automatically when you use the wrappers in
+--  Data.Columbia.Utils, but must be applied manually in the same manner when not using those
+--  patterns.
+markAndSweepGc :: FilePath -> [IORef Word32] -> IO()
+markAndSweepGc path moreAddresses = do
+	dir <- getAppUserDataDirectory "tmp"
+	createDirectoryIfMissing True dir
+	(newpath,newhandle) <- openBinaryTempFile dir "new"
+	hClose newhandle
+	l <- dualLockShared path
+	withFileLock(path++".lock.writer") Exclusive$ \_->catch
+		(
+		-- A copy is made for robustness.
+		copyFile path newpath)
+		(\(ex::SomeException)->throwIO ex)
+	(newhandle,(tmppath,tmpwriter,_,_),((tmppath2,tmpwriter2),newFileSize),len,writer,ref,table) <- catch
+		(do
+		putStrLn"Mark phase"
+		newhandle <- openBinaryFile newpath ReadWriteMode
+		hClose newhandle
+		table <- newTable newpath
+		sz <- fileSizeShim table
+		ref <- newIORef$!(0,sz)
+		let writer = makeIoWriter ref table undefined
+		tmp@(tmppath,tmpwriter,tmpref,tmptable) <- mark newpath(stream writer)
+		mapM_(\ref -> readIORef ref>>=(`runReaderT` stream writer)._mark tmpwriter) moreAddresses
+		putStrLn"Compress phase"
+		tmp2@((tmppath2,tmpwriter2),_) <- compress tmpwriter
+		unmapAll tmptable
+		bracket
+			(openFile tmppath ReadWriteMode)
+			hClose
+			(`hSetFileSize` 0)
+		writeIORef tmpref$!(0,0)
+		putStrLn"Fixup phase"
+		len <- fixUpPointers writer tmpwriter(stream tmpwriter2) moreAddresses
+		putStrLn"Sweep phase"
+		sweep writer ref table(stream tmpwriter2)
+		return$!(newhandle, tmp, tmp2, len, writer, ref, table))
+		(\(ex::SomeException)->unlockShared l>>throwIO ex)
+	l2 <- switchLocks l
+	withFileLock(path++".lock.writer") Exclusive$ \_->finally
+		(do
+		-- Reconcile the differential segment (the part that got written while the
+		-- lion's share of the GC [in terms of time] was going on).
+		putStrLn"Reconcile phase"
+		oldtable <- newTable path
+		oldsz <- fileSizeShim oldtable
+		oldref <- newIORef$!(0,oldsz)
+		let oldstream = makeIoStream oldref oldtable undefined
+		n <- runReaderT
+			(do
+			n <- lift$runReaderT(seekWriterAtEnd>>getWriterPosition) writer
+			seek newFileSize
+			untilEOF'
+				(lift$_consumeToken oldstream>>=maybe(return()) (_putToken writer))
+			return n)
+			oldstream
+		putStrLn$"newFileSize: "++show newFileSize++"; n: "++show n
+		runReaderT(_fixUpPointers5 tmpwriter(stream tmpwriter2) len n) writer
+		-- Don't forget the root block pointer in case it changed.
+		addr :: Word32 <- runReaderT(seek 0>>readIntegral) oldstream
+		runReaderT(do
+			seekWriter 0
+			writeIntegral addr
+			_fixUpPointers2(stream tmpwriter2) len 0) writer
+		concludeFileWrite ref table
+		-- Atomically swap the newly swept file in place of the old one.
+		renameFile newpath path)
+		(unlock l2)

@@ -0,0 +1,124 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, Trustworthy #-}
+
+{-
+Here I document the header layout. Every entity in a file has a header attached.
+The header has enough information to traverse the graph structure of data.
+It is laid out as follows:
+
+* The first bit determines whether the entity is an algebraic type. If it is
+zero, the next seven bits specify the index of the constructor represented,
+minus one. The next bit is a parity check bit. The seven bits following
+that specify how many parameters the constructor takes, and therefore the
+number of four-byte addresses in the body of the entity.
+
+* If the first bit is one, the second bit specifies whether the entity
+is a primitive type (0) or an array (1). In this case the remaining six bits
+in the first byte are reserved and must be zero, and the entity follows.
+
+* The body of a primitive type is always four bytes long.
+
+* The body of an array consists of a four-byte length entry, followed
+by that many four-byte addresses.-}
+module Data.Columbia.Headers where
+
+import Data.Bits
+import Data.Word
+import Data.Int
+import Data.Array
+import Data.Maybe
+import Data.Generics.SYB.WithClass.Basics
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Trans
+import Control.Monad.Identity
+import Control.Monad
+import Control.Parallel.Strategies
+import Data.Columbia.RWInstances
+import Data.Columbia.Integral
+import Data.Columbia.FRecord
+
+evalTriple = evalTuple3 rseq rseq rseq
+
+parity x1 fields = (popCount x1 + popCount fields) .&. 1
+
+readHeader :: (Monad m) => ReaderT(SeekableStream m Word8) m (Word8, ConIndex, Int)
+readHeader = do
+	x1 <- consumeToken
+	if testBit x1 7 then
+			let x = (case x1 of
+				160 -> 3
+				192 -> 2
+				128 -> 1
+				_ -> error$"readHeader: header code "++show x1++" is invalid") in
+			return$!using(x, 0, 0) evalTriple
+		else do
+		x2 <- consumeToken
+		let fields = fromIntegral x2 .&. 127
+		when(testBit x2 7 /= (parity x1 fields == 1))$
+			fail"readHeader: parity check error"
+		return$!using(0, fromIntegral x1, fields) evalTriple
+
+{-# INLINE enhancedFromConstr #-}
+enhancedFromConstr :: forall ctx a. (Data ctx a) => Proxy ctx -> DataType -> (Word8, ConIndex, Int) -> Int -> a
+enhancedFromConstr proxy0 ty hdr@(_, ix, _) l = maybe
+	(runIdentity$fromConstrM proxy0(return$error"enhancedFromConstr: constr is too strict")$indexConstr ty ix)
+	runIdentity
+	(dataCast1 proxy0(return$listArray(1,l)$repeat$error"enhancedFromConstr: uninitialized array"))
+
+nConstructorParameters :: forall ctx d. (Data ctx d) => Proxy ctx -> d -> Int
+nConstructorParameters proxy d =
+	execState(gmapM
+		proxy
+		(\_ -> do { modify succ; return$error"nConstructorParameters: unused" })
+		d)
+		0
+
+headerFromConstr :: forall ctx d. (Data ctx d) => Proxy ctx -> d -> Constr -> (Word8, ConIndex, Int)
+headerFromConstr proxy d constr = hdr where
+	ty = dataTypeOf proxy d
+	specimen :: d = fromConstr proxy constr
+	hdr = if dataTypeName ty == "Data.Array.Unboxed.UArray" then
+			(3, 0, 0)
+		else if dataTypeName ty == "Data.Array.Array" then
+			(2, 0, 0)
+		else if not(isAlgType ty) then
+			(1, 0, 0)
+		else
+			(0, constrIndex constr, nConstructorParameters proxy specimen) where
+
+writeHeader :: (Monad m, Data cxt d) => Proxy cxt -> d -> ReaderT(SeekableWriter m Word8) m ()
+writeHeader proxy d = do
+	let (n, conIndex, nFields) = headerFromConstr proxy d(toConstr proxy d)
+	case n of
+		3 -> putToken 160
+		2 -> putToken 192
+		1 -> putToken 128
+		0 -> do
+			when(conIndex>127)$fail"writeCompoundData: constructor index not in range 1-127"
+			putToken(fromIntegral conIndex)
+			when(nFields>127)$fail"writeCompoundData: number of fields not in range 0-127"
+			putToken(fromIntegral$nFields .|. shiftL(parity conIndex nFields) 7)
+
+nFieldsBytes hdr@(_, _, nFields) = if isHeaderPrimtype hdr then
+		return(0, 5)
+	else if isHeaderUArraytype hdr then do
+		len <- readIntegral
+		return(0, 5+len)
+	else if isHeaderArraytype hdr then do
+		len <- readIntegral
+		return(len, 5+4*len)
+	else
+		return(nFields, 2+4*nFields)
+
+isHeaderUArraytype :: (Word8, ConIndex, Int) -> Bool
+isHeaderUArraytype (n, _, _) = n == 3
+
+isHeaderArraytype :: (Word8, ConIndex, Int) -> Bool
+isHeaderArraytype (n, _, _) = n == 2
+
+isHeaderPrimtype :: (Word8, ConIndex, Int) -> Bool
+isHeaderPrimtype (n, _, _) = n == 1
+
+isHeaderAlgtype :: (Word8, ConIndex, Int) -> Bool
+isHeaderAlgtype (n, _, _) = n == 0
+

@@ -0,0 +1,45 @@+{-# LANGUAGE Trustworthy #-}
+
+module Data.Columbia.Integral where
+
+import Data.Generics.SYB.WithClass.Basics
+import Data.Bits
+import Data.Word
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Trans
+import Data.Columbia.SeekableStream
+import Data.Columbia.SeekableWriter
+
+readIntegral :: (Monad m, Bits i, Integral i) => ReaderT(SeekableStream m Word8) m i
+readIntegral = liftM4(\x1 x2 x3 x4 -> shiftL(fromIntegral x1) 24 .|.
+	shiftL(fromIntegral x2) 16 .|.
+	shiftL(fromIntegral x3) 8 .|.
+	fromIntegral x4)
+	consumeToken
+	consumeToken
+	consumeToken
+	consumeToken
+
+writeIntegral :: (Monad m, Bits i, Integral i) => i -> ReaderT(SeekableWriter m Word8) m ()
+writeIntegral x = do
+	putToken$!fromIntegral$shiftR x 24
+	putToken$!fromIntegral$shiftR x 16
+	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)
+	consumeToken
+	consumeToken
+
+writeIntegral16 :: (Monad m, Bits i, Integral i) => i -> ReaderT(SeekableWriter m Word8) m ()
+writeIntegral16 x = do
+	putToken$!fromIntegral$shiftR x 8
+	putToken$!fromIntegral x
+
+seekByPointer :: (Monad m) => ReaderT(SeekableStream m Word8) m ()
+seekByPointer = do
+	n <- readIntegral
+	seek n

@@ -0,0 +1,132 @@+{-# LANGUAGE Trustworthy, ForeignFunctionInterface, CPP #-}
+
+-- | Allows a block to be requested an unlimited number of times without using up the address space. N.B. Usage of memory cannot cross multiples of 64 kilobytes.
+module Data.Columbia.Mapper (Pointer, Table(..), newTable, fileSize, fileSizeShim, mapBlock, unmapAll) where
+
+import Data.Map
+import Data.Word
+import Data.Int
+import Data.Traversable (mapM)
+import Data.IORef
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
+import Foreign.C.String
+import Foreign.C.Types
+import Foreign.C.Error
+import Control.Concurrent.MVar
+import Control.Monad hiding (mapM)
+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"
+    c_system_io_mmap_file_open :: CString
+                               -> CInt
+                               -> IO (Ptr ())
+
+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
+                          -> CLLong
+                          -> CSize
+                          -> IO (Ptr a)
+
+#ifdef WIN32
+foreign import stdcall "FileAPI.h FlushViewOfFile"
+    c_win32_flush_view_of_file :: Ptr () -> CSize -> IO Word32
+
+foreign import stdcall "FileAPI.h FlushFileBuffers"
+    c_win32_flush_file_buffers :: Ptr () -> IO Word32
+flush_file_buffers ptr = do
+	n <- c_win32_flush_file_buffers ptr
+	when(n==0)$fail"FlushFileBuffers: failed"
+#else
+foreign import ccall "sys/mman.h msync"
+    c_msync :: Ptr () -> CSize -> CInt -> IO Word32
+#endif
+
+type Pointer = Word32
+
+data Table = Table !FilePath !(MVar (Map Pointer (Ptr ())), ForeignPtr ())
+
+newTable path = do
+	mv <- newMVar empty
+	handle <- withCString path$ \p->c_system_io_mmap_file_open p 3{-ReadWriteEx-}
+	handle' <- newForeignPtr c_system_io_mmap_file_close handle
+	return$!Table path$!(mv,handle')
+
+fileSize :: FilePath -> Map Pointer (Ptr ()) -> IO Word32
+fileSize path mp =
+	liftM2
+		(max.fromInteger)
+		(bracket
+		(openBinaryFile path ReadWriteMode)
+		hClose
+		hFileSize)
+		(return$!maybe 0((+65536).fst.fst) (maxViewWithKey mp))
+
+fileSizeShim :: Table -> IO Word32
+fileSizeShim (Table path(mv,_)) = modifyMVar mv(\mp->liftM((,) mp) (fileSize path mp))
+
+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
+		-- putStrLn$"mmap at "++show ptr
+		sz <- fileSize path mp
+		when(aligned>=sz)$
+			bracket
+				(openBinaryFile path ReadWriteMode)
+				hClose
+				(`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)
+	where
+	(d, r) = ptr `divMod` 65536
+	aligned = 65536 * d
+
+{-newBlock :: Table -> IO (Ptr a, Int)
+newBlock (Table path mp) = do
+	-- Get the file size.
+	hdl <- openBinaryFile path ReadWriteMode
+	fileSz <- finally (hFileSize hdl) (hClose hdl)
+
+	-- Add a new block at the end.
+	(p, _, _, _) <- mmapFilePtr path ReadWriteEx (Just (fromInteger fileSz, 65536))
+
+	-- Store it.
+	modifyMVar_ mp (return . insert (fromInteger fileSz) (castPtr p))
+
+	return (p, fromInteger fileSz)-}
+
+unmapAll (Table _ (mvar,handle)) =
+	modifyMVar_ mvar$ \mp-> do { 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.
+#else
+		mapM(\ptr->do
+			n<-c_msync ptr 65536 2
+			when(n/=0)$writeIORef errref True) mp
+#endif
+		mapM(\ptr -> munmapFilePtr ptr 65536) mp
+		bool <- readIORef errref
+		when bool$fail"unmapAll: FlushViewOfFile or msync failed";
+		performGC;
+		return empty }

@@ -0,0 +1,90 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, StandaloneDeriving, DeriveDataTypeable, Trustworthy #-}
+
+module Data.Columbia.Orphans (LazyFix(LazyFix)) where
+
+import Data.Typeable
+import Generics.Pointless.Functors
+import Data.Generics.SYB.WithClass.Basics
+import Data.Columbia.RWInstances
+import Data.Array.Unboxed
+
+idConstr = Constr(AlgConstr 1) "IdF" [] Prefix idDataType
+idDataType = DataType "Generics.Pointless.Functors" (AlgRep[idConstr])
+instance (Sat(ctx(Id x)), Data ctx x) => Data ctx(Id x) where
+	gfoldl _ o f (IdF x) = f IdF `o` x
+	gunfold _ k f _ = k(f IdF)
+	dataTypeOf _ _ = idDataType
+	toConstr _ _ = idConstr
+
+constConstr = Constr(AlgConstr 1) "ConsF" [] Prefix idDataType
+constDataType = DataType "Generics.Pointless.Functors" (AlgRep[constConstr])
+instance (Sat(ctx(Const t x)), Data ctx t, Typeable x) => Data ctx(Const t x) where
+	gfoldl _ o f (ConsF x) = f ConsF `o` x
+	gunfold _ k f _ = k(f ConsF)
+	dataTypeOf _ _ = constDataType
+	toConstr _ _ = constConstr
+
+sumConstr1 = Constr(AlgConstr 1) "InlF" [] Prefix sumDataType
+sumConstr2 = Constr(AlgConstr 2) "InrF" [] Prefix sumDataType
+sumDataType = DataType "Generics.Pointless.Functors" (AlgRep[sumConstr1,sumConstr2])
+instance (Sat(ctx((:+:) g h x)), Typeable1 g, Typeable1 h, Typeable x, Data ctx(g x), Data ctx(h x)) => Data ctx((:+:) g h x) where
+	gfoldl _ o f (InlF x) = f InlF `o` x
+	gfoldl _ o f (InrF x) = f InrF `o` x
+	gunfold _ k f constr = case constrIndex constr of
+		1 -> k(f InlF)
+		2 -> k(f InrF)
+		_ -> error"Data: unrecognized constructor index"
+
+prodConstr = Constr(AlgConstr 1) "ProdF" [] Prefix prodDataType
+prodDataType = DataType "Generics.Pointless.Functors" (AlgRep[prodConstr])
+instance (Sat(ctx((:*:) g h x)), Typeable1 g, Typeable1 h, Typeable x, Data ctx(g x), Data ctx(h x)) => Data ctx((:*:) g h x) where
+	gfoldl _ o f (ProdF x x2) = f ProdF `o` x `o` x2
+	gunfold _ k f _ = k(k(f ProdF))
+	dataTypeOf _ _ = prodDataType
+	toConstr _ _ = prodConstr
+
+instance (Sat(ctx((:@:) g h x)), Typeable1 g, Typeable1 h, Typeable x, Data ctx(g(h x))) => Data ctx((:@:) g h x) where
+	gfoldl _ o f (CompF x) = f CompF `o` x
+
+fixConstr = Constr(AlgConstr 1) "Inn" [] Prefix fixDataType
+fixDataType = DataType "Generics.Pointless.Functors" (AlgRep[fixConstr])
+instance (Sat(ctx(Fix f)), Typeable1 f, Data ctx(Rep f(Fix f))) => Data ctx(Fix f) where
+	gfoldl _ o f (Inn x) = f Inn `o` x
+	gunfold _ k f _ = k(f Inn)
+	dataTypeOf _ _ = fixDataType
+	toConstr _ _ = fixConstr
+
+instance (Typeable1 f) => RW(Fix f)
+
+deriving instance (Eq(Rep f(Fix f))) => Eq(Fix f)
+
+deriving instance (Ord(Rep f(Fix f))) => Ord(Fix f)
+
+data LazyFix f = LazyFix(Rep f(LazyFix f))
+
+deriving instance (Typeable1 f) => Typeable(LazyFix f)
+
+deriving instance (Eq(Rep f(LazyFix f))) => Eq(LazyFix f)
+
+deriving instance (Ord(Rep f(LazyFix f))) => Ord(LazyFix f)
+
+deriving instance (Show(Rep f(LazyFix f))) => Show(LazyFix f)
+
+deriving instance (Read(Rep f(LazyFix f))) => Read(LazyFix f)
+
+lazyFixConstr = Constr(AlgConstr 1) "LazyFix" [] Prefix lazyFixDataType
+lazyFixDataType = DataType "Generics.Pointless.Functors" (AlgRep[lazyFixConstr])
+instance (Sat(ctx(LazyFix f)), Typeable1 f, Data ctx(Rep f(LazyFix f))) => Data ctx(LazyFix f) where
+	gfoldl _ o f (LazyFix x) = f LazyFix `o` x
+	gunfold _ k f _ = k(f LazyFix)
+	dataTypeOf _ _ = lazyFixDataType
+	toConstr _ _ = lazyFixConstr
+
+instance (Typeable1 f) => RW(LazyFix f)
+
+instance (Ix i, IArray UArray e, Sat(ctx(UArray i e)), Typeable i, Data ctx e, Sat(ctx[e])) => Data ctx(UArray i e) where
+	gfoldl _ o f ua = f(listArray(bounds ua)) `o` elems ua
+	gunfold = error"no gunfold"
+	toConstr = error"no toConstr"
+	dataTypeOf _ _ = mkNorepType"Data.Array.Unboxed.UArray"
+	dataCast1 _ = gcast1

@@ -0,0 +1,136 @@+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, FlexibleInstances, FlexibleContexts, Trustworthy #-}
+
+module Data.Columbia.RWInstances (module Data.Generics.SYB.WithClass.Instances, module Data.Columbia.SeekableStream, module Data.Columbia.SeekableWriter, RW(..), RWCtx(..)) where
+
+import Data.Generics.SYB.WithClass.Basics
+import Data.Generics.SYB.WithClass.Instances
+import Data.Word
+import Data.Int
+import Data.Array
+import Data.Map (Map)
+import Data.Set (Set)
+import qualified Data.Array.Unboxed as UA
+import Data.Char
+import Data.Typeable hiding (Proxy)
+import Data.Columbia.Integral
+import Data.Columbia.Coercion
+import Data.Columbia.SeekableStream
+import Data.Columbia.SeekableWriter
+import Control.Monad
+import Control.Monad.Reader
+
+-- | The 'RW' class describes operations that can locate entities in a stream by seeking,
+--   and also read and write primitive types.
+class (Typeable t) => RW t where
+	readData :: (Monad m) => ReaderT(SeekableStream m Word8) m t
+	readData = fail$"RW.readData: unimplemented for " ++ show(typeOf(undefined :: t))
+	writeData :: (Monad m) => t -> ReaderT(SeekableWriter m Word8) m ()
+	writeData = fail$"RW.writeData: unimplemented for " ++ show(typeOf(undefined :: t))
+
+data RWCtx a = (RW a) => RWCtx
+
+instance (RW t) => Sat(RWCtx t) where dict = RWCtx
+
+instance RW Int where
+	readData = readIntegral
+	writeData = writeIntegral
+instance RW Word where
+	readData = readIntegral
+	writeData = writeIntegral
+instance RW Int32 where
+	readData = readIntegral
+	writeData = writeIntegral
+instance RW Word32 where
+	readData = readIntegral
+	writeData = writeIntegral
+instance RW Int16 where
+	readData = readIntegral
+	writeData = writeIntegral
+instance RW Word16 where
+	readData = readIntegral
+	writeData = writeIntegral
+instance RW Int8 where
+	readData = readIntegral
+	writeData = writeIntegral
+instance RW Word8 where
+	readData = readIntegral
+	writeData = writeIntegral
+instance RW Float where
+	readData = liftM int32ToFloat readIntegral
+	writeData = writeIntegral.floatToInt32
+instance RW Char where
+	readData = liftM chr readIntegral
+	writeData = writeIntegral.ord
+instance RW Bool
+instance RW Ordering
+instance RW()
+instance (Typeable t, Typeable u) => RW(t, u)
+instance (Typeable t, Typeable u, Typeable v) => RW(t, u, v)
+instance (Typeable t, Typeable u, Typeable v, Typeable w) => RW(t, u, v, w)
+instance (Typeable t, Typeable u, Typeable v, Typeable w, Typeable x) => RW(t, u, v, w, x)
+instance (Typeable t, Typeable u) => RW(Either t u)
+instance (Typeable t) => RW(Maybe t)
+instance (Typeable i, Typeable t) => RW(Array i t)
+instance (Typeable t) => RW[t]
+instance (Typeable t, Typeable u) => RW(Map t u)
+instance (Typeable t) => RW(Set t)
+instance RW(UA.UArray Int32 Word8) where
+	readData = do
+		len :: Int32 <- readIntegral
+		liftM(UA.listArray(0, len-1))$mapM(const consumeToken) [0..len-1]
+	writeData ua = do
+		let len = succ$uncurry subtract$UA.bounds ua
+		writeIntegral len
+		mapM_ putToken(UA.elems ua)
+instance RW(UA.UArray Int32 Int8) where
+	readData = do
+		len :: Int32 <- readIntegral
+		liftM(UA.listArray(0, len-1))$mapM(const$liftM fromIntegral consumeToken) [0..len-1]
+	writeData ua = do
+		let len = succ$uncurry subtract$UA.bounds ua
+		writeIntegral len
+		mapM_(putToken.fromIntegral) (UA.elems ua)
+instance RW(UA.UArray Int32 Word16) where
+	readData = do
+		len :: Int32 <- readIntegral
+		let endIdx = len`quot`2 - 1
+		liftM(UA.listArray(0, endIdx))$mapM(const readIntegral16) [0..endIdx]
+	writeData ua = do
+		let nElems = succ(uncurry subtract$UA.bounds ua)
+		when(nElems>=maxBound`quot`2)$fail"RW.writeData: UArray is too large to index"
+		let len = 2*nElems
+		writeIntegral len
+		mapM_ writeIntegral16(UA.elems ua)
+instance RW(UA.UArray Int32 Int16) where
+	readData = do
+		len :: Int32 <- readIntegral
+		let endIdx = len`quot`2 - 1
+		liftM(UA.listArray(0, endIdx))$mapM(const readIntegral16) [0..endIdx]
+	writeData ua = do
+		let nElems = succ(uncurry subtract$UA.bounds ua)
+		when(nElems>=maxBound`quot`2)$fail"RW.writeData: UArray is too large to index"
+		let len = 2*nElems
+		writeIntegral len
+		mapM_ writeIntegral16(UA.elems ua)
+instance RW(UA.UArray Int32 Word32) where
+	readData = do
+		len :: Int32 <- readIntegral
+		let endIdx = len`quot`4 - 1
+		liftM(UA.listArray(0, endIdx))$mapM(const readIntegral) [0..endIdx]
+	writeData ua = do
+		let nElems = succ(uncurry subtract$UA.bounds ua)
+		when(nElems>=maxBound`quot`4)$fail"RW.writeData: UArray is too large to index"
+		let len = 4*nElems
+		writeIntegral len
+		mapM_ writeIntegral(UA.elems ua)
+instance RW(UA.UArray Int32 Int32) where
+	readData = do
+		len :: Int32 <- readIntegral
+		let endIdx = len`quot`4 - 1
+		liftM(UA.listArray(0, endIdx))$mapM(const readIntegral) [0..endIdx]
+	writeData ua = do
+		let nElems = succ(uncurry subtract$UA.bounds ua)
+		when(nElems>=maxBound`quot`4)$fail"RW.writeData: UArray is too large to index"
+		let len = 4*nElems
+		writeIntegral len
+		mapM_ writeIntegral(UA.elems ua)

@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveFunctor, Rank2Types, NoMonomorphismRestriction, Trustworthy #-}
+
+module Data.Columbia.SeekableStream (newTable, SeekableStream, seekableStream, hoistStream, getWord8,
+-- ** Stream forming functions
+makeIoStream, makeIoStreamChar, unshimmedIOStream, makeByteStringStream, makeGenericStream,
+-- ** Stream management functions
+_getPosition, _seek, _consumeToken, _seekAtEnd, _isLockLive, getPosition, seek, consumeToken, seekAtEnd, isLockLive, relSeek, peekStream, streamToList) where
+
+import Foreign.Marshal.Utils
+import Foreign.Storable
+import Data.Word
+import Data.Maybe
+import Data.Char
+import Data.IORef
+import System.IO
+import System.IO.Error
+import System.FileLock
+import Control.Monad.State
+import Control.Monad.Reader
+import Control.Monad.Loops
+import Control.Monad
+import Control.Exception
+import Control.Parallel.Strategies
+import qualified Data.ByteString as B
+import System.IO.Unsafe
+import Unsafe.Coerce
+import Data.Columbia.Mapper
+
+data SeekableStream m c = SeekableStream
+	{ __consumeToken :: !(m(Maybe c)), __seek :: !(Word32 -> m()), __getPosition :: !(m Word32), __seekAtEnd :: !(m()), __isLockLive :: !(m Bool) } deriving Functor
+
+seekableStream :: m(Maybe c) -> (Word32 -> m()) -> m Word32 -> m() -> m Bool -> SeekableStream m c
+seekableStream = SeekableStream
+
+hoistStream :: (forall t. m t -> m2 t) -> SeekableStream m c -> SeekableStream m2 c
+hoistStream f s = SeekableStream(f(_consumeToken s)) (\n -> f(_seek s n)) (f(_getPosition s)) (f(_seekAtEnd s)) (f(_isLockLive s))
+
+getWord8 :: Handle -> IO Word8
+getWord8 h = with 0$ \p -> do
+	n <- hGetBuf h p 1
+	when(n==0)$void$hGetChar h -- Cause EOF exception
+	peek p
+
+data LockLike = LockLike !() !(IORef Bool)
+
+getLiveReference :: FileLock -> IORef Bool
+getLiveReference lock = let LockLike _ r = unsafeCoerce lock in r
+
+makeIoStream :: IORef(Pointer,Pointer) -> Table -> FileLock -> SeekableStream IO Word8
+makeIoStream ref table lock = SeekableStream
+	(readIORef ref>>= \(n,sz)->if n>=sz then
+			return mzero
+		else
+			mapBlock table n>>=peek>>= \x->(writeIORef ref$!(succ n,sz))>>(return$!return x))
+	(\n->modifyIORef' ref(\(_,sz)->(n,sz)))
+	(liftM fst$readIORef ref)
+	(modifyIORef' ref(\(_,sz)->(sz,sz)))
+	(atomicModifyIORef'(getLiveReference lock)$ \b -> (b, b))
+makeIoStreamChar :: IORef(Pointer,Pointer) -> Table -> FileLock -> SeekableStream IO Char
+makeIoStreamChar ref t = fmap(chr.fromIntegral).makeIoStream ref t
+
+unshimmedIOStream :: Handle -> FileLock -> SeekableStream IO Word8
+unshimmedIOStream handle lock = SeekableStream
+	(liftM(return$!) (getWord8 handle))
+	(hSeek handle AbsoluteSeek. toInteger)
+	(liftM fromInteger(hTell handle))
+	(hSeek handle SeekFromEnd 0)
+	(atomicModifyIORef'(getLiveReference lock)$ \b -> (b, b))
+
+makeByteStringStream :: B.ByteString -> SeekableStream(State Word32) Word8
+makeByteStringStream b = SeekableStream
+	(do
+	n <- get
+	let n' = fromIntegral n
+	if n' == B.length b then
+			return mzero
+		else do
+			put$!succ n
+			return$!return$!B.index b n')
+	put
+	get
+	(put$!fromIntegral$B.length b)
+	(return True)
+
+_fst3 (x, _, _) = x
+
+makeGenericStream :: SeekableStream(State(Word32, [t], [t])) t
+makeGenericStream = SeekableStream
+	(do
+	(m, ls, ls2) <- get
+	case ls2 of
+		x:xs -> do
+			put$!(succ m, x:ls, xs)
+			return$!return x
+		[] -> return mzero)
+	(\n -> do
+	(m, ls, ls2) <- get
+	let n' = fromIntegral n-fromIntegral m
+	if n' < 0 then
+		let (lsa, lsb) = splitAt(-n') ls in
+			put$!using(n, lsb, reverse lsa ++ ls2) (evalTuple3 rseq rseq rseq)
+		else let (ls2a, ls2b) = splitAt n' ls2 in
+			put$!using(n, reverse ls2a ++ ls, ls2b) (evalTuple3 rseq rseq rseq))
+	(liftM _fst3 get)
+	(modify(\(n, ls, ls2) -> using(n+fromIntegral(length ls2), reverse ls2++ls, []) (evalTuple3 rseq rseq rseq)))
+	(return True)
+
+_consumeToken = __consumeToken
+_seek = __seek
+_getPosition = __getPosition
+_seekAtEnd = __seekAtEnd
+_isLockLive = __isLockLive
+
+getPosition :: (Monad m) => ReaderT(SeekableStream m c) m Word32
+getPosition = ask>>=lift._getPosition
+
+seek :: (Monad m) => Word32 -> ReaderT(SeekableStream m c) m ()
+seek n = ask>>=lift.(`_seek` n)
+
+consumeToken :: (Monad m) => ReaderT(SeekableStream m c) m c
+consumeToken = do
+	s <- ask
+	liftM(maybe(error"consumeToken: end of stream") id)$lift$_consumeToken s
+
+seekAtEnd :: (Monad m) => ReaderT(SeekableStream m c) m ()
+seekAtEnd = ask>>=lift._seekAtEnd
+
+isLockLive :: (Monad m) => ReaderT(SeekableStream m c) m Bool
+isLockLive = ask>>=lift._isLockLive 
+
+relSeek n = do
+	m <- getPosition
+	seek$!m+n
+
+peekStream :: (Monad m) => ReaderT(SeekableStream m c) m c
+peekStream = do
+	x <- consumeToken
+	relSeek(-1)
+	return x
+
+streamToList :: (Monad m) => SeekableStream m c -> m[c]
+streamToList = unfoldM._consumeToken

@@ -0,0 +1,66 @@+{-# LANGUAGE Rank2Types, Trustworthy #-}
+
+module Data.Columbia.SeekableWriter where
+
+import Foreign.Marshal.Utils
+import Foreign.Storable
+import Data.Functor.Invariant
+import Data.List
+import Data.Word
+import Data.Char
+import Data.IORef
+import System.IO
+import System.FileLock
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad
+import Control.Arrow
+import Control.Parallel.Strategies
+import Data.Columbia.SeekableStream
+import Data.Columbia.Mapper
+
+data SeekableWriter m c = SeekableWriter
+	{ _putToken :: !(c -> m()), stream :: !(SeekableStream m c) }
+
+instance (Functor m) => Invariant(SeekableWriter m) where
+	invmap f g sw = SeekableWriter(_putToken sw.g) (fmap f(stream sw))
+
+hoistWriter :: (forall t. m t -> m2 t) -> SeekableWriter m c -> SeekableWriter m2 c
+hoistWriter f sw = SeekableWriter(\x -> f(_putToken sw x)) (hoistStream f(stream sw))
+
+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)))
+	(makeIoStream ref table lock)
+
+makeIoWriterChar :: IORef(Pointer,Pointer) -> Table -> FileLock -> SeekableWriter IO Char
+makeIoWriterChar ref t = invmap(chr.fromIntegral) (fromIntegral.ord).makeIoWriter ref t
+
+unshimmedIOWriter :: Handle -> FileLock -> SeekableWriter IO Word8
+unshimmedIOWriter handle lock = SeekableWriter(putWord8 handle) (unshimmedIOStream handle lock)
+
+makeGenericWriter :: SeekableWriter(State(Word32, [t], [t])) t
+makeGenericWriter = SeekableWriter
+	(\x -> modify(\(n, ls, ls2) -> using(succ n, x:ls, drop 1 ls2) (evalTuple3 rseq rseq rseq)))
+	makeGenericStream
+
+putToken :: (Monad m) => c -> ReaderT(SeekableWriter m c) m ()
+putToken c = ask>>=lift.(`_putToken` c)
+
+consumeTokenW :: (Monad m) => ReaderT(SeekableWriter m c) m (Maybe c)
+consumeTokenW = ask>>=lift._consumeToken.stream
+
+getWriterPosition :: (Monad m) => ReaderT(SeekableWriter m c) m Word32
+getWriterPosition = ask>>=lift._getPosition.stream
+
+seekWriter :: (Monad m) => Word32 -> ReaderT(SeekableWriter m c) m ()
+seekWriter n = ask>>=lift.(`_seek` n).stream
+
+seekWriterAtEnd :: (Monad m) => ReaderT(SeekableWriter m c) m ()
+seekWriterAtEnd = ask>>=lift._seekAtEnd.stream
+
+relSeekWriter :: (Monad m) => Word32 -> ReaderT(SeekableWriter m c) m ()
+relSeekWriter n = ask>>=lift.runReaderT(relSeek n).stream

@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleContexts, Safe #-}
+
+-- | Some utility functions. All functions 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.
+--
+--   Think of a columbia file as just a giant 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
+--   collector have to be programmed to happen manually at a time convenient for your
+--   application.
+--
+--   Please be aware that while you *can* write new addresses over old in the file,
+--   this is not compatible with the locking scheme, which is predicated on
+--   the assumption that all writing happens to the root block address and appending to
+--   the end of the file; in other words it is predicated on all data being immutable
+--   except the root block address. In order to do that, you will have to use your own
+--   locking scheme to make that work.
+module Data.Columbia.Utils where
+
+import Data.Word
+import Data.IORef
+import System.IO
+import System.FileLock
+import Control.Monad.Reader
+import Control.Monad.Trans
+import Control.Exception
+import Data.Columbia.Headers
+import Data.Columbia.Integral
+import Data.Columbia.CompoundData
+import Data.Columbia.DualLock
+import Data.Columbia.Mapper
+
+{-# INLINE seekToStart #-}
+seekToStart :: (Monad m) => ReaderT(SeekableStream m Word8) m ()
+seekToStart = do
+	seek 0
+	addr <- readIntegral
+	seek addr
+
+-- | 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) ->
+	bracket
+	(newTable path)
+	unmapAll
+	$ \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)
+
+-- | 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->
+	bracket
+	(dualLockShared path)
+	unlockShared
+	$ \_ ->
+	withFileLock(path++".lock.writer") Exclusive
+	$ \l ->
+	runReaderT
+	(do
+		sz <- lift$fileSizeShim table
+		lift$writeIORef cursor$!(0,sz)
+		sw <- ask
+		seekWriterAtEnd
+		len <- getWriterPosition
+		when(len == 0)$writeIntegral(0 :: Word32)
+		addr <- proc
+		seekWriter 0
+		writeIntegral addr
+	)
+	(makeIoWriter cursor table l)
+
+nFields hdr@(_, _, nFields) = if isHeaderArraytype hdr then do
+		readIntegral
+	else
+		return nFields

@@ -0,0 +1,92 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, DeriveDataTypeable, DeriveFunctor, ScopedTypeVariables, Trustworthy #-}
+
+module Data.Columbia.WithAddress where
+
+import Data.Word
+import Data.Function
+import Data.Generics.SYB.WithClass.Basics
+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
+
+-- | 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)
+
+addressOf :: WithAddress t -> Word32
+addressOf(WithAddress n _) = n
+addressOf(Address n) = n
+addressOf(Data _) = maxBound -- This has to be non-zero because reasons.
+
+dataOf :: WithAddress t -> t
+dataOf (WithAddress _ x) = x
+dataOf (Address _) = error"dataOf: Address"
+dataOf (Data x) = x
+
+-- | A null address object.
+nullAddress = Address$!0
+
+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"
+	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
+			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
+	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 _ = True
+	keyCompare = compare `on` addressOf
+
+-- | The strategy reads term structure from a file and associates file addresses with it.
+--   Bear in mind that the addresses become no good at the moment your reader lock is
+--   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) => Proxy ctx -> 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
+	Just m2 -> m2
+	Nothing -> m
+
+newtype Fl m t = Fl { unFl :: t -> ReaderT(SeekableWriter m Word8) m Word32 }
+
+-- | 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.
+writeBackAddresses ::  forall ctx m d. (Data ctx d, Monad m) => Proxy ctx -> 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
+	Just fl -> unFl fl d
+	Nothing -> f d