Created
May 21, 2009 01:14
-
-
Save rampion/115203 to your computer and use it in GitHub Desktop.
Haskell library for traversing and editing recursive data structures
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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, ()) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment