-- | A class for tree types and representations of selections on tree types, as well as functions for converting between text and tree selections. module Language.GroteTrap.Trees ( -- * Paths and navigation Path, root, Nav, up, into, down, left, right, sibling, -- * Tree types Tree(..), followM, follow, depth, selectDepth, flatten, -- * Tree selections Selectable(..), TreeSelection, select, allSelections, selectionToRange, rangeToSelection, posToPath, isValidRange, -- * Suggesting and fixing suggest, repair ) where import Language.GroteTrap.Range import Data.List (sortBy, findIndex) import Data.Maybe (isJust) import Control.Monad.Error () ------------------------------------ -- Paths and navigation ------------------------------------ -- | A path in a tree. Each integer denotes the selection of a child; these indices are 0-relative. type Path = [Int] -- | @root@ is the empty path. root :: Path root = [] -- | Navigation transforms one path to another. type Nav = Path -> Path -- | Move up to parent node. Moving up from root has no effect. up :: Nav up [] = [] up path = init path -- | Move down into the nth child node. into :: Int -> Nav into i = (++[i]) -- | Move down into first child node. down :: Nav down = into 0 -- | Move left one sibling. left :: Nav left = sibling (-1) -- | Move right one sibling. right :: Nav right = sibling 1 -- | Move @n@ siblings (@n@ can be negative). sibling :: Int -> Nav sibling 0 p = p -- because sibling 0 [] == [] sibling d p = if newindex < 0 then p else into newindex parent where index = last p newindex = index + d parent = up p ------------------------------------ -- Parents and children ------------------------------------ -- | Tree types. class Tree p where -- | Yields this tree's subtrees. children :: p -> [p] -- | Breadth-first, pre-order traversal. flatten :: Tree t => t -> [t] flatten t = t : concatMap flatten (children t) -- | Follows a path in a tree, returning the result in a monad. followM :: (Monad m, Tree t) => t -> Path -> m t followM parent [] = return parent followM parent (t:ts) = do c <- childM parent t followM c ts -- | Moves down into a child. childM :: (Monad m, Tree p) => p -> Int -> m p childM t i = if i >= 0 && i < length cs then return (cs !! i) else fail ("child " ++ show i ++ " does not exist") where cs = children t -- | Follows a path in a tree. follow :: Tree t => t -> Path -> t follow t = fromError . followM t fromError :: Either String a -> a fromError = either error id {- indexIn :: (Eq p, Parent p) => p -> p -> Maybe Int indexIn child = elemIndex child . children -} -- | Yields the depth of the tree. depth :: Tree t => t -> Int depth t | null depths = 1 | otherwise = 1 + maximum (map depth $ children t) where depths = map depth $ children t -- | Yields all ancestors at the specified depth. selectDepth :: Tree t => Int -> t -> [t] selectDepth 0 t = [t] selectDepth d t = concatMap (selectDepth (d - 1)) (children t) ------------------------------------ -- Tree selections ------------------------------------ -- | Selection in a tree. The path indicates the left side of the selection; the int tells how many siblings to the right are included in the selection. type TreeSelection = (Path, Int) -- | Selectable trees. class Tree t => Selectable t where -- | Tells whether complete subranges of children may be selected in this tree. If not, valid TreeSelections in this tree always have a second element @0@. allowSubranges :: t -> Bool -- | Enumerates all possible selections of a tree. allSelections :: Selectable a => a -> [TreeSelection] allSelections p = ([], 0) : subranges ++ recurse where subranges | allowSubranges p = [ ([from], to - from) | from <- [0 .. length cs - 2] , to <- [from + 1 .. length cs - 1] , from > 0 || to < length cs - 1 ] | otherwise = [] cs = children p recurse = concat $ zipWith label cs [0 ..] label c i = map (rt i) (allSelections c) rt i (path, offset) = (i : path, offset) -- | Selects part of a tree. select :: (Monad m, Tree t) => t -> TreeSelection -> m [t] select t (path, offset) = (sequence . map (followM t) . take (offset + 1) . iterate right) path -- | Computes the range of a valid selection. selectionToRange :: (Tree a, KnowsPosition a) => a -> TreeSelection -> Range selectionToRange parent (path, offset) = (from, to) where from = begin $ follow parent path to = end $ follow parent (sibling offset path) -- | Converts a specified range to a corresponding selection and returns it in a monad. rangeToSelection :: (Tree a, KnowsPosition a, Monad m) => a -> Range -> m TreeSelection rangeToSelection p ran@(b, e) -- If the range matches that of the root, we're done. | range p == ran = return ([], 0) | otherwise = -- Find the children whose ranges contain b and e. case ( findIndex (\c -> b `inRange` range c) cs , findIndex (\c -> e `inRange` range c) cs) of (Just l, Just r) -> if l == r -- b and e are contained by the same child! -- Recurse into child. then rangeToSelection (cs !! l) ran -- ... and prepend child index, of course. >>= (\(path, offset) -> return (l : path, offset)) else if begin (cs !! l) == b && end (cs !! r) == e -- b is the beginning of l, and e is the end -- of r: a selection of a range of children. -- Note that r - l > 0; else it would've been -- caught by the previous test. -- This also means that there are many ways -- to select a single node: either select it -- directly, or select all its children. then return ([l], r - l) -- All other cases are bad. else fail "text selection does not have corresponding tree selection" -- Either position is not contained -- within any child. Can't be valid. _ -> fail "text selection does not have corresponding tree selection" where cs = children p -- | Returns the path to the deepest descendant whose range contains the specified position. posToPath :: (Tree a, KnowsPosition a) => a -> Pos -> Path posToPath p pos = case break (\c -> pos `inRange` range c) (children p) of (_, []) -> [] (no, c:_) -> length no : posToPath c pos -- | Tells whether the text selection corresponds to a tree selection. isValidRange :: (KnowsPosition a, Selectable a) => a -> Range -> Bool isValidRange p = isJust . rangeToSelection p ------------------------------------ -- Suggesting and fixing ------------------------------------ -- | Yields all possible selections, ordered by distance to the specified range, closest first. suggest :: (Selectable a, KnowsPosition a) => a -> Range -> [TreeSelection] suggest p r = sortBy distance $ allSelections p where distance s1 s2 = (selectionToRange p s1 `distRange` r) `compare` (selectionToRange p s2 `distRange` r) -- | Takes @suggest@'s first suggestion and yields its range. repair :: (KnowsPosition a, Selectable a) => a -> Range -> Range repair p = selectionToRange p . head . suggest p