SSCCE: Storing large structured binary data with Haskell

{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving,
    FunctionalDependencies, FlexibleContexts, FlexibleInstances #-}
import System.IO
import System.IO.MMap
import System.FilePath
import Data.Char(chr)
import Control.Monad.Reader
import Foreign.Ptr
import Foreign.Storable
import Data.Int(Int64)
import System.IO.Unsafe

{-
 - struct Foo {
 -     int gunk;
 -     Bar *foosBar;
 - };
 - struct Bar {
 -     int gunk;
 -     int junk;
 - };
 -}

class DBStruct a where
    structRead :: Ptr a -> IO a

class DBStruct st => StructMem st vt name | st name -> vt where
    offset :: st -> vt -> name -> Int64

--this looks really stupid but it's neccesary. eg see advancePtr
strOffset :: StructMem st vt name => Ptr st -> name -> Ptr vt
strOffset = doOffset undefined undefined
    where doOffset :: StructMem st vt name => st -> vt -> Ptr st -> name -> Ptr vt
          doOffset sdummy vdummy s n = plusPtr s $ fromIntegral $ offset sdummy vdummy n

elemRead :: (Storable vt, StructMem st vt name) => Ptr st -> name -> IO vt
elemRead s n = peek $ strOffset s n

elemPtr :: (DBStruct vt, StructMem st (Ptr vt) name) => Ptr st -> name -> IO vt
elemPtr s n = elemRead s n >>= structRead

elemWrite :: (Storable vt, StructMem st vt name) => Ptr st -> name -> vt -> IO ()
elemWrite s n v = poke (strOffset s n) v

data Foo = Foo Int Bar
    deriving Show

data Bar = Bar Int Int
    deriving Show

data Gunk = Gunk
data Junk = Junk
data FoosBar = FoosBar

instance StructMem Foo Int Gunk where offset _ _ _ = 0
instance StructMem Foo (Ptr Bar) FoosBar where offset _ _ _ = 8

instance StructMem Bar Int Gunk where offset _ _ _ = 0
instance StructMem Bar Int Junk where offset _ _ _ = 8

instance DBStruct Foo where
    structRead p = do
        g <- elemRead p Gunk
        b <- elemPtr p FoosBar
        return $ Foo g b

instance DBStruct Bar where
    structRead p = do
        g <- elemRead p Gunk
        j <- elemRead p Junk
        return $ Bar g j

main = mmapWithFilePtr fname ReadWriteEx (Just (0, sz)) $ test . fst
    where fname = "." </> "test"
          sz = 1024

test p = do
    elemWrite theFoo Gunk 17
    elemWrite theFoo FoosBar theBar
    elemWrite theBar Gunk 22
    elemWrite theBar Junk 56
    structRead theFoo >>= print
    where theFoo = plusPtr p 0 :: Ptr Foo
          theBar = plusPtr p 64 :: Ptr Bar