freezing haskell STrefs

Question

I would like to implement a Doubly Connected Edge List data structure for use in Haskell. This data structure is used to manage the topology of an arrangement of lines in a plane, and contains structures for faces, edges, and vertices.

It seems to me like a good interface to this data structure would be as a type Arrangement, with functions like

overlay :: Arrangement -> Arrangement -> Arrangement

but the usual implementation relies heavily on references (for example each face has references to the adjacent edges).

It seems to me that the ideal way for this to work would be similar to the way mutable and immutable arrays do: the internals of the Arrangement data structure are implemented as functional data structures, but the operations that mutate arrangements "unfreeze" them to create new mutable instances within a monad (ideally using COW magic to make things efficient).

So my questions are:

(1) is there a way to freeze and unfreeze a small heap like there is for arrays? (2) if not, is there a better approach?

Answer 1

Not that the safe versions of freeze and thaw make complete copies of the array, so aren't necessarily that efficient. Of course, making a complete copy of an array of refs is arguably an optimization over making a complete copy of a structure through walking it and recursively pulling things ou of MVars, etc.

Another approach to take would be something similar to that of Repa -- represent operations over your structure algebraically, and write a run function that optimizes, fuses, and then executes all in one pass. Arguably this is a more functional design. (You can use unsafe operations under the covers even, to make reification happen on-demand rather than explicitly).

Answer 2

This might be what you are looking for. Loops should work fine. A simple example involving a loop appears first.

data List a t = Nil | Cons a t deriving (Show, Functor, Foldable, Traversable)
runTerm $ do
  x <- newVar Nil
  writeVar x (Cons 'a' (Var x)))
  return $ Var x

And now, the code.

{-# LANGUAGE
    Rank2Types
  , StandaloneDeriving
  , UndecidableInstances #-}
module Freeze
       ( Term (..)
       , Fix (..)
       , runTerm
       , freeze
       , thaw
       , Var
       , newVar
       , writeVar
       , readVar
       , modifyVar
       , modifyVar'
       ) where

import Control.Applicative
import Control.Monad.Fix
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.ST

import Data.STRef
import Data.Traversable (Traversable, traverse)

data Term s f
  = Var {-# UNPACK #-} !(Var s f)
  | Val !(f (Term s f))

newtype Fix f = Fix { getFix :: f (Fix f) }
deriving instance Show (f (Fix f)) => Show (Fix f)

runTerm :: Traversable f => (forall s . ST s (Term s f)) -> Fix f
runTerm m = runST $ m >>= freeze

freeze :: Traversable f => Term s f -> ST s (Fix f)
freeze t = do
  xs <- newSTRef Nil
  f <- runReaderT (loop t) xs
  readSTRef xs >>= mapM_' modifyToOnly
  return f
  where
    loop (Val f) = Fix <$> traverse loop f
    loop (Var (STRef ref)) = do
      a <- lift $ readSTRef ref
      case a of
        Both _ f' ->
          return f'
        Only f -> mfix $ \ f' -> do
          lift $ writeSTRef ref $! Both f f'
          ask >>= lift . flip modifySTRef' (ref :|)
          Fix <$> traverse loop f

thaw :: Traversable f => Fix f -> ST s (Term s f)
thaw = return . loop
  where
    loop = Val . fmap loop . getFix

newtype Var s f = STRef (STRef s (Many s f))

newVar :: f (Term s f) -> ST s (Var s f)
newVar = fmap STRef . newSTRef . Only

readVar :: Var s f -> ST s (f (Term s f))
readVar (STRef ref) = fst' <$> readSTRef ref

writeVar :: Var s f -> f (Term s f) -> ST s ()
writeVar (STRef ref) a = writeSTRef ref $! Only a

modifyVar :: Var s f -> (f (Term s f) -> f (Term s f)) -> ST s ()
modifyVar (STRef ref) f = modifySTRef' ref (Only . f . fst')

modifyVar' :: Var s f -> (f (Term s f) -> f (Term s f)) -> ST s ()
modifyVar' (STRef ref) f = modifySTRef' ref (\ a -> Only $! f (fst' a))

data Many s f
  = Only (f (Term s f))
  | Both (f (Term s f)) (Fix f)

fst' :: Many s f -> f (Term s f)
fst' (Only a) = a
fst' (Both a _) = a

modifyToOnly :: STRef s (Many s f) -> ST s ()
modifyToOnly ref = do
  a <- readSTRef ref
  case a of
    Only _ -> return ()
    Both f _ -> writeSTRef ref $! Only f

data List s a = Nil | {-# UNPACK #-} !(STRef s a) :| !(List s a)

mapM_' :: Monad m => (STRef s a -> m b) -> List s a -> m ()
mapM_' _ Nil = return ()
mapM_' k (x :| xs) = k x >> mapM_' k xs