module Language.GroteTrap.Trees (
Path, root,
Nav, up, into, down, left, right, sibling,
Tree(..), followM, follow, depth, selectDepth, flatten,
Selectable(..), TreeSelection,
select, allSelections, selectionToRange, rangeToSelection, posToPath, isValidRange,
suggest, repair
) where
import Language.GroteTrap.Range
import Data.List (sortBy, findIndex)
import Data.Maybe (isJust)
import Control.Monad.Error ()
type Path = [Int]
root :: Path
root = []
type Nav = Path -> Path
up :: Nav
up [] = []
up path = init path
into :: Int -> Nav
into i = (++[i])
down :: Nav
down = into 0
left :: Nav
left = sibling (1)
right :: Nav
right = sibling 1
sibling :: Int -> Nav
sibling 0 p = p
sibling d p = if newindex < 0 then p else into newindex parent
where index = last p
newindex = index + d
parent = up p
class Tree p where
children :: p -> [p]
flatten :: Tree t => t -> [t]
flatten t = t : concatMap flatten (children t)
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
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
follow :: Tree t => t -> Path -> t
follow t = fromError . followM t
fromError :: Either String a -> a
fromError = either error id
depth :: Tree t => t -> Int
depth t
| null depths = 1
| otherwise = 1 + maximum (map depth $ children t)
where depths = map depth $ children t
selectDepth :: Tree t => Int -> t -> [t]
selectDepth 0 t = [t]
selectDepth d t = concatMap (selectDepth (d 1)) (children t)
type TreeSelection = (Path, Int)
class Tree t => Selectable t where
allowSubranges :: t -> Bool
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)
select :: (Monad m, Tree t) => t -> TreeSelection -> m [t]
select t (path, offset) = (sequence . map (followM t) . take offset . iterate right) path
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)
rangeToSelection :: (Tree a, KnowsPosition a, Monad m) => a -> Range -> m TreeSelection
rangeToSelection p ran@(b, e)
| range p == ran = return ([], 0)
| otherwise =
case ( findIndex (\c -> b `inRange` range c) cs
, findIndex (\c -> e `inRange` range c) cs) of
(Just l, Just r) ->
if l == r
then rangeToSelection (cs !! l) ran
>>= (\(path, offset) -> return (l : path, offset))
else if begin (cs !! l) == b && end (cs !! r) == e
then return ([l], r l)
else fail "text selection does not have corresponding tree selection"
_ -> fail "text selection does not have corresponding tree selection"
where cs = children p
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
isValidRange :: (KnowsPosition a, Selectable a) => a -> Range -> Bool
isValidRange p = isJust . rangeToSelection p
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)
repair :: (KnowsPosition a, Selectable a) => a -> Range -> Range
repair p = selectionToRange p . head . suggest p