Haskell library for traversing and editing recursive data structures

CursorM.hs

module Traverse.CursorM where
import Prelude (($), Bool)
import Maybe
import Monad
import Traverse

-- encapsulate a cursor in a monad
newtype (Traversable t) => CursorM t a = CursorM { runCursor :: Cursor t -> Maybe (Cursor t, a) }
instance (Traversable t) => Monad (CursorM t) where
  return a = CursorM $ \c -> Just (c,a)
  m >>= f = CursorM $ \c -> do 
    (c', a) <- m `runCursor` c;
    f a `runCursor` c'

-- move in a direction
moveM :: (Traversable t) => Direction t -> CursorM t ()
moveM d = CursorM $ \c -> do
  c' <- c `move` d;
  return (c', ())

-- move as far as possible in a direction
skipM :: (Traversable t) => Direction t -> CursorM t ()
skipM d = CursorM $ \c -> Just (c `skip` d, ())

-- test if it's possible to move in a direction from the current position
canMoveM :: (Traversable t) => Direction t -> CursorM t Bool
canMoveM d = CursorM $ \c -> Just (c, c `canMove` d)

-- see what moves are available in the current position
validMovesM :: (Traversable t) => CursorM t [ Direction t ]
validMovesM = CursorM $ \c -> Just (c, validMoves c)

-- follow a sequence of directions
followM :: (Traversable t) => [ Direction t ] -> CursorM t ()
followM ds = CursorM $ \c -> do 
  c' <- follow c ds
  return (c', ())

-- move back to the start of the data structure
resetM :: (Traversable t) => CursorM t ()
resetM = CursorM $ \c -> Just (reset c, ())
  
-- see if we've reached the beginning of the data structure
isResetM :: (Traversable t) => CursorM t Bool
isResetM = CursorM $ \c -> Just (c, isReset c)

-- read the current value stored in the data structure
readM :: (Traversable t) => CursorM t (Data t)
readM = CursorM $ \c -> Just (c, read c)

-- change the current value stored in the data structure
writeM :: (Traversable t) => Data t -> CursorM t ()
writeM v = CursorM $ \c -> do
  c' <- c `write` v;
  return (c', ())

-- extract the substructure at this location
extractM :: (Traversable t) => CursorM t t
extractM = CursorM $ \c -> Just (c, extract c)

-- insert a new substructure at this location
insertM :: (Traversable t) => t -> CursorM t ()
insertM t = CursorM $ \c -> Just (c `insert` t, ())

List.hs

{-# LANGUAGE TypeFamilies #-}
module Traverse.List where
import Traverse

instance Traversable [a] where
  -- move forward or backward through a list
  data Direction [a] = Forward | Backward
  directions = [ Forward, Backward ]
  opposite Forward = Backward
  opposite Backward = Forward

  -- store a path through a list, with preceding elements stored in reverse
  data Cursor [a] = ListCursor [a] [a]
  cursor as = ListCursor [] as
  move (ListCursor _ [])      Forward   = Nothing
  move (ListCursor bs (x:fs)) Forward   = Just $ ListCursor (x:bs) fs
  move (ListCursor [] _)      Backward  = Nothing
  move (ListCursor (x:bs) fs) Backward  = Just $ ListCursor bs (x:fs)
  reset (ListCursor bs fs) = ListCursor [] $ foldl (flip (:)) fs bs
  isReset (ListCursor bs _) = null bs

  type Data [a] = a
  -- read or write the value at this position in the list
  read (ListCursor _ (x:fs)) = x
  write (ListCursor bs (_:fs)) x = Just $ ListCursor bs (x:fs)
  write (ListCursor bs []) x = Just $ ListCursor bs [x]
  -- extract or insert a new sublist at this point in the list
  extract (ListCursor _ fs) = fs
  insert (ListCursor bs _) fs = ListCursor bs fs

Makefile

BASE_SRC=Traverse.hs 
BASE_TGT=$(basename $(BASE_SRC))
BASE_OBJ=$(addsuffix .o,$(BASE_TGT))
BASE_INT=$(addsuffix .hi,$(BASE_TGT))

EXT_SRCS=$(wildcard Traverse/*.hs)
EXT_TGTS=$(basename $(EXT_SRCS))
EXT_OBJS=$(addsuffix .o,$(EXT_TGTS))
EXT_INTS=$(addsuffix .hi,$(EXT_TGTS))

SOURCES=$(BASE_SRC) $(EXT_SRCS)
TARGETS=$(BASE_TGT) $(EXT_TGTS)
OBJECTS=$(BASE_OBJ) $(EXT_OBJS)
INTERFACES=$(BASE_INT) $(EXT_INTS)

all: $(OBJECTS)

%.hi %.o: %.hs
	ghc -c $<

$(EXT_OBJS): $(BASE_OBJ)

Traverse/Forest.o: Traverse/List.o

clean:
	rm -f $(OBJECTS) $(INTERFACES)

Traverse.hs

{-# LANGUAGE TypeFamilies #-}
module Traverse where
import Maybe (isNothing)
import Monad (foldM)

-- a class for traversing recursive data structures
class Traversable t where
  -- directions the cursor can move through the structure
  data Direction t
  directions :: [ Direction t ]
  opposite  :: Direction t -> Direction t

  -- used to hold state about where we are in the data structure
  data Cursor t
  cursor :: t -> Cursor t
  -- move one increment in the given direction
  move :: Cursor t -> Direction t -> Maybe (Cursor t)
  -- return to our entry point in the data structure
  reset :: Cursor t -> Cursor t
  isReset :: Cursor t -> Bool

  -- what kind(s) of data can be read/written in the data strucutre
  type Data t
  -- find the value stored at the current position
  read :: Cursor t -> Data t
  -- attempt to replace the value at the current position
  write :: Cursor t -> Data t -> Maybe (Cursor t)
  -- find the substructure at this position
  extract :: Cursor t -> t
  -- replace the substructure at this position
  insert :: Cursor t -> t -> Cursor t

-- rules (or at least, suggestions):
--  * The list of directions is comprehensive:
--    d `elem` directions == True
--
--  * Every direction has a dual:
--    opposite . opposite == id
--
--  * Moves are reversible: 
--    Just c' = c `move` d implies
--    Just c = c' `move` (opposite d)
--
--  * reset works as described
--    isReset . reset == const True
--    
--  * creating a cursor doesn't change the structure
--    extract . cursor == id
--
--  * The original position is the reset location:
--    isReset . cursor == const True
--
--  * moves don't change the data structure
--    Just c' = c `move` d implies
--    extract . reset c' == extract . reset c

-- move another increment in the a given direction if the previous action succeeded
andMove :: (Traversable t) => Maybe (Cursor t) -> Direction t -> Maybe (Cursor t)
andMove maybeCursor direction = maybeCursor >>= \c -> c `move` direction

-- move as far as possible in the given direction
skip :: (Traversable t) => Cursor t -> Direction t -> Cursor t
skip cursor direction = case cursor `move` direction of
  Nothing -> cursor
  Just cursor' -> cursor' `skip` direction

-- move as far as possible in the given direction if the previous action succeeded
andSkip :: (Traversable t) => Maybe (Cursor t) -> Direction t -> Maybe (Cursor t)
andSkip maybeCursor direction = maybeCursor >>= \c -> Just $ c `skip` direction

-- test if the cursor can move in the given direction from the current position
canMove :: (Traversable t) => Cursor t -> Direction t -> Bool
canMove cursor = isNothing . move cursor

-- list the valid moves from the current cursor position
validMoves :: (Traversable t) => Cursor t -> [ Direction t ]
validMoves cursor = filter (canMove cursor) directions

-- follow a sequence of directions
follow :: (Traversable t) => Cursor t -> [ Direction t ] -> Maybe (Cursor t)
follow = foldM move