module Language.GroteTrap.Trees (
Path, root,
Nav, up, into, down, left, right, sibling,
Tree(..), depth, selectDepth, flatten, follow, child,
Selectable(..), TreeSelection,
select, allSelections, selectionToRange, rangeToSelection, posToPath, isValidRange,
suggestBy, suggest, repairBy, repair
) where
import Language.GroteTrap.Range
import Language.GroteTrap.Util
import Control.Monad (liftM)
import Data.List (sortBy, findIndex)
import Data.Maybe (isJust)
import Data.Ord (comparing)
type Path = [Int]
root :: Path
root = []
type Nav = Path -> Path
up :: Nav
up [] = []
up path = init path
into :: Int -> Nav
into i = (++ [i `max` 0])
down :: Nav
down = into 0
left :: Nav
left = sibling (1)
right :: Nav
right = sibling 1
sibling :: Int -> Nav
sibling 0 [] = []
sibling _ [] = error "the root has no siblings"
sibling d p = into (last p + d) (up p)
class Tree p where
children :: p -> [p]
flatten :: Tree t => t -> [t]
flatten t = t : concatMap flatten (children t)
follow :: (Monad m, Tree t) => t -> Path -> m t
follow parent [] = return parent
follow parent (t:ts) = do
c <- child parent t
follow c ts
child :: (Monad m, Tree t) => t -> Int -> m t
child t i
| i >= 0 && i < length cs = return (cs !! i)
| otherwise = fail ("child " ++ show i ++ " does not exist")
where cs = children t
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 = (root, 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 (follow t) . take (offset + 1) . iterate right) path
selectionToRange :: (Monad m, Tree a, Ranged a) => a -> TreeSelection -> m Range
selectionToRange parent (path, offset) = do
from <- follow parent path
to <- follow parent (sibling offset path)
return (begin from, end to)
rangeToSelection :: (Monad m, Selectable a, Ranged a) => a -> Range -> m TreeSelection
rangeToSelection p (b, e)
| range p == (b, e) =
return (root, 0)
| otherwise =
let cs = children p
ri pos = findIndex (inRange pos . range) cs
in case (ri b, ri e) of
(Just l, Just r) ->
if l == r
then liftM (\(path, offset) -> (l : path, offset)) $
rangeToSelection (cs !! l) (b, e)
else if allowSubranges p && 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"
posToPath :: (Monad m, Tree a, Ranged a) => a -> Pos -> m Path
posToPath p pos = case break (inRange pos . range) (children p) of
(_, []) -> if pos `inRange` range p
then return root
else fail ("tree does not contain position " ++ show pos)
(no, c:_) -> liftM (length no :) (posToPath c pos)
isValidRange :: (Ranged a, Selectable a) => a -> Range -> Bool
isValidRange p = isJust . rangeToSelection p
suggestBy :: (Selectable a, Ranged a) => (Range -> Range -> Int) -> a -> Range -> [TreeSelection]
suggestBy cost p r = sortBy (comparing distance) (allSelections p) where
distance = cost r . fromError . selectionToRange p
suggest :: (Selectable a, Ranged a) => a -> Range -> [TreeSelection]
suggest = suggestBy distRange
repairBy :: (Ranged a, Selectable a) => (Range -> Range -> Int) -> a -> Range -> Range
repairBy cost p = fromError . selectionToRange p . head . suggestBy cost p
repair :: (Ranged a, Selectable a) => a -> Range -> Range
repair = repairBy distRange