{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- the CPP seems to confuse GHC; we have uniplate patterns {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-incomplete-patterns #-} {-# OPTIONS_HADDOCK show-extensions #-} -- | -- Module : Yi.Syntax.Tree -- License : GPL-2 -- Maintainer : yi-devel@googlegroups.com -- Stability : experimental -- Portability : portable -- Generic syntax tree handling functions module Yi.Syntax.Tree (IsTree(..), toksAfter, allToks, tokAtOrBefore, toksInRegion, sepBy, sepBy1, getLastOffset, getFirstOffset, getFirstElement, getLastElement, getLastPath, getAllSubTrees, tokenBasedAnnots, tokenBasedStrokes, subtreeRegion, fromLeafToLeafAfter, fromNodeToFinal) where -- Some of this might be replaced by a generic package -- such as multirec, uniplace, emgm, ... import Prelude hiding (concatMap, error) import Control.Applicative (Alternative ((<|>), many)) import Control.Arrow (first) import Data.Foldable (concatMap, toList) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE (reverse, toList, (<|)) import Data.Maybe (catMaybes, listToMaybe) import Data.Monoid (First (First, getFirst), Last (Last, getLast), (<>)) import Yi.Buffer.Basic (Point) import Yi.Debug (error, trace) import Yi.Lexer.Alex (posnLine, posnOfs, Tok (tokPosn), tokBegin, tokEnd) import Yi.Region (Region (regionEnd, regionStart), mkRegion) import Yi.String (showT) -- Fundamental types type Path = [Int] type Node t = (Path, t) class Foldable tree => IsTree tree where -- | Direct subtrees of a tree subtrees :: tree t -> [tree t] subtrees = ([tree t], [tree t] -> tree t) -> [tree t] forall a b. (a, b) -> a fst (([tree t], [tree t] -> tree t) -> [tree t]) -> (tree t -> ([tree t], [tree t] -> tree t)) -> tree t -> [tree t] forall b c a. (b -> c) -> (a -> b) -> a -> c . tree t -> ([tree t], [tree t] -> tree t) forall (tree :: * -> *) t. IsTree tree => tree t -> ([tree t], [tree t] -> tree t) uniplate uniplate :: tree t -> ([tree t], [tree t] -> tree t) emptyNode :: tree t toksAfter :: Foldable t1 => t -> t1 a -> [a] toksAfter :: t -> t1 a -> [a] toksAfter t _begin = t1 a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] allToks allToks :: Foldable t => t a -> [a] allToks :: t a -> [a] allToks = t a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList tokAtOrBefore :: Foldable t => Point -> t (Tok t1) -> Maybe (Tok t1) tokAtOrBefore :: Point -> t (Tok t1) -> Maybe (Tok t1) tokAtOrBefore Point p t (Tok t1) res = [Tok t1] -> Maybe (Tok t1) forall a. [a] -> Maybe a listToMaybe ([Tok t1] -> Maybe (Tok t1)) -> [Tok t1] -> Maybe (Tok t1) forall a b. (a -> b) -> a -> b $ [Tok t1] -> [Tok t1] forall a. [a] -> [a] reverse ([Tok t1] -> [Tok t1]) -> [Tok t1] -> [Tok t1] forall a b. (a -> b) -> a -> b $ Region -> t (Tok t1) -> [Tok t1] forall (t1 :: * -> *) t. Foldable t1 => Region -> t1 (Tok t) -> [Tok t] toksInRegion (Point -> Point -> Region mkRegion Point 0 (Point pPoint -> Point -> Point forall a. Num a => a -> a -> a +Point 1)) t (Tok t1) res toksInRegion :: Foldable t1 => Region -> t1 (Tok t) -> [Tok t] toksInRegion :: Region -> t1 (Tok t) -> [Tok t] toksInRegion Region reg = (Tok t -> Bool) -> [Tok t] -> [Tok t] forall a. (a -> Bool) -> [a] -> [a] takeWhile (\Tok t t -> Tok t -> Point forall t. Tok t -> Point tokBegin Tok t t Point -> Point -> Bool forall a. Ord a => a -> a -> Bool <= Region -> Point regionEnd Region reg) ([Tok t] -> [Tok t]) -> (t1 (Tok t) -> [Tok t]) -> t1 (Tok t) -> [Tok t] forall b c a. (b -> c) -> (a -> b) -> a -> c . (Tok t -> Bool) -> [Tok t] -> [Tok t] forall a. (a -> Bool) -> [a] -> [a] dropWhile (\Tok t t -> Tok t -> Point forall t. Tok t -> Point tokEnd Tok t t Point -> Point -> Bool forall a. Ord a => a -> a -> Bool < Region -> Point regionStart Region reg) ([Tok t] -> [Tok t]) -> (t1 (Tok t) -> [Tok t]) -> t1 (Tok t) -> [Tok t] forall b c a. (b -> c) -> (a -> b) -> a -> c . Point -> t1 (Tok t) -> [Tok t] forall (t1 :: * -> *) t a. Foldable t1 => t -> t1 a -> [a] toksAfter (Region -> Point regionStart Region reg) tokenBasedAnnots :: (Foldable t1) => (a1 -> Maybe a) -> t1 a1 -> t -> [a] tokenBasedAnnots :: (a1 -> Maybe a) -> t1 a1 -> t -> [a] tokenBasedAnnots a1 -> Maybe a tta t1 a1 t t begin = [Maybe a] -> [a] forall a. [Maybe a] -> [a] catMaybes (a1 -> Maybe a tta (a1 -> Maybe a) -> [a1] -> [Maybe a] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> t -> t1 a1 -> [a1] forall (t1 :: * -> *) t a. Foldable t1 => t -> t1 a -> [a] toksAfter t begin t1 a1 t) tokenBasedStrokes :: (Foldable t3) => (a -> b) -> t3 a -> t -> t2 -> t1 -> [b] tokenBasedStrokes :: (a -> b) -> t3 a -> t -> t2 -> t1 -> [b] tokenBasedStrokes a -> b tts t3 a t t _point t2 begin t1 _end = a -> b tts (a -> b) -> [a] -> [b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> t2 -> t3 a -> [a] forall (t1 :: * -> *) t a. Foldable t1 => t -> t1 a -> [a] toksAfter t2 begin t3 a t -- | Prune the nodes before the given point. -- The path is used to know which nodes we can force or not. pruneNodesBefore :: IsTree tree => Point -> Path -> tree (Tok a) -> tree (Tok a) pruneNodesBefore :: Point -> Path -> tree (Tok a) -> tree (Tok a) pruneNodesBefore Point _ [] tree (Tok a) t = tree (Tok a) t pruneNodesBefore Point p (Int x:Path xs) tree (Tok a) t = [tree (Tok a)] -> tree (Tok a) rebuild ([tree (Tok a)] -> tree (Tok a)) -> [tree (Tok a)] -> tree (Tok a) forall a b. (a -> b) -> a -> b $ [tree (Tok a)] left' [tree (Tok a)] -> [tree (Tok a)] -> [tree (Tok a)] forall a. Semigroup a => a -> a -> a <> (Point -> Path -> tree (Tok a) -> tree (Tok a) forall (tree :: * -> *) a. IsTree tree => Point -> Path -> tree (Tok a) -> tree (Tok a) pruneNodesBefore Point p Path xs tree (Tok a) c tree (Tok a) -> [tree (Tok a)] -> [tree (Tok a)] forall a. a -> [a] -> [a] : [tree (Tok a)] rs) where ([tree (Tok a)] children,[tree (Tok a)] -> tree (Tok a) rebuild) = tree (Tok a) -> ([tree (Tok a)], [tree (Tok a)] -> tree (Tok a)) forall (tree :: * -> *) t. IsTree tree => tree t -> ([tree t], [tree t] -> tree t) uniplate tree (Tok a) t ([tree (Tok a)] left,tree (Tok a) c:[tree (Tok a)] rs) = Int -> [tree (Tok a)] -> ([tree (Tok a)], [tree (Tok a)]) forall a. Int -> [a] -> ([a], [a]) splitAt Int x [tree (Tok a)] children left' :: [tree (Tok a)] left' = (tree (Tok a) -> tree (Tok a)) -> [tree (Tok a)] -> [tree (Tok a)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap tree (Tok a) -> tree (Tok a) forall (tree :: * -> *) t1. IsTree tree => tree (Tok t1) -> tree (Tok t1) replaceEmpty [tree (Tok a)] left replaceEmpty :: tree (Tok t1) -> tree (Tok t1) replaceEmpty tree (Tok t1) s = if tree (Tok t1) -> Point forall (t :: * -> *) t1. Foldable t => t (Tok t1) -> Point getLastOffset tree (Tok t1) s Point -> Point -> Bool forall a. Ord a => a -> a -> Bool < Point p then tree (Tok t1) forall (tree :: * -> *) t. IsTree tree => tree t emptyNode else tree (Tok t1) s -- | Given an approximate path to a leaf at the end of the region, -- return: (path to leaf at the end of the region,path from focused -- node to the leaf, small node encompassing the region) fromNodeToFinal :: IsTree tree => Region -> Node (tree (Tok a)) -> Node (tree (Tok a)) fromNodeToFinal :: Region -> Node (tree (Tok a)) -> Node (tree (Tok a)) fromNodeToFinal Region r (Path xs,tree (Tok a) root) = Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "r = " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Region -> Text forall a. Show a => a -> Text showT Region r) (Node (tree (Tok a)) -> Node (tree (Tok a))) -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a b. (a -> b) -> a -> b $ Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "focused ~ " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Region -> Text forall a. Show a => a -> Text showT (tree (Tok a) -> Region forall (t :: * -> *) t1. Foldable t => t (Tok t1) -> Region subtreeRegion tree (Tok a) focused) ) (Node (tree (Tok a)) -> Node (tree (Tok a))) -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a b. (a -> b) -> a -> b $ Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "pathFromFocusedToLeaf = " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Path -> Text forall a. Show a => a -> Text showT Path focusedToLeaf) (Node (tree (Tok a)) -> Node (tree (Tok a))) -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a b. (a -> b) -> a -> b $ Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "pruned ~ " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Region -> Text forall a. Show a => a -> Text showT (tree (Tok a) -> Region forall (t :: * -> *) t1. Foldable t => t (Tok t1) -> Region subtreeRegion tree (Tok a) focused)) (Path xs', tree (Tok a) pruned) where n :: Node (tree (Tok a)) n@(Path xs',tree (Tok a) _) = Point -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall (tree :: * -> *) a. IsTree tree => Point -> Node (tree (Tok a)) -> Node (tree (Tok a)) fromLeafToLeafAfter (Region -> Point regionEnd Region r) (Path xs,tree (Tok a) root) (Path _,(Path focusedToLeaf,tree (Tok a) focused)) = Point -> Node (tree (Tok a)) -> (Path, Node (tree (Tok a))) forall (tree :: * -> *) a. IsTree tree => Point -> Node (tree (Tok a)) -> (Path, Node (tree (Tok a))) fromLeafAfterToFinal Point p0 Node (tree (Tok a)) n p0 :: Point p0 = Region -> Point regionStart Region r pruned :: tree (Tok a) pruned = Point -> Path -> tree (Tok a) -> tree (Tok a) forall (tree :: * -> *) a. IsTree tree => Point -> Path -> tree (Tok a) -> tree (Tok a) pruneNodesBefore Point p0 Path focusedToLeaf tree (Tok a) focused -- | Return the first element that matches the predicate, or the last -- of the list if none matches. firstThat :: (a -> Bool) -> NonEmpty a -> a firstThat :: (a -> Bool) -> NonEmpty a -> a firstThat a -> Bool _ (a x :| []) = a x firstThat a -> Bool p (a x :| [a y]) = if a -> Bool p a x then a x else a y firstThat a -> Bool p (a x :| a y : [a] xs) = if a -> Bool p a x then a x else (a -> Bool) -> NonEmpty a -> a forall a. (a -> Bool) -> NonEmpty a -> a firstThat a -> Bool p (a y a -> [a] -> NonEmpty a forall a. a -> [a] -> NonEmpty a :| [a] xs) -- | Return the element before first element that violates the -- predicate, or the first of the list if that one violates the -- predicate. lastThat :: (a -> Bool) -> NonEmpty a -> a lastThat :: (a -> Bool) -> NonEmpty a -> a lastThat a -> Bool p (a x :| [a] xs) = if a -> Bool p a x then a -> [a] -> a work a x [a] xs else a x where work :: a -> [a] -> a work a x0 [] = a x0 work a x0 (a y:[a] ys) = if a -> Bool p a y then a -> [a] -> a work a y [a] ys else a x0 -- | Given a path to a node, return a path+node which node that -- encompasses the given node + a point before it. fromLeafAfterToFinal :: IsTree tree => Point -> Node (tree (Tok a)) -> (Path, Node (tree (Tok a))) fromLeafAfterToFinal :: Point -> Node (tree (Tok a)) -> (Path, Node (tree (Tok a))) fromLeafAfterToFinal Point p Node (tree (Tok a)) n = -- trace ("reg = " <> showT (fmap (subtreeRegion . snd) nsPth)) $ ((Path, Node (tree (Tok a))) -> Bool) -> NonEmpty (Path, Node (tree (Tok a))) -> (Path, Node (tree (Tok a))) forall a. (a -> Bool) -> NonEmpty a -> a firstThat (\(Path _,(Path _,tree (Tok a) s)) -> tree (Tok a) -> Point forall (t :: * -> *) t1. Foldable t => t (Tok t1) -> Point getFirstOffset tree (Tok a) s Point -> Point -> Bool forall a. Ord a => a -> a -> Bool <= Point p) NonEmpty (Path, Node (tree (Tok a))) ns where ns :: NonEmpty (Path, Node (tree (Tok a))) ns = NonEmpty (Path, Node (tree (Tok a))) -> NonEmpty (Path, Node (tree (Tok a))) forall a. NonEmpty a -> NonEmpty a NE.reverse (Node (tree (Tok a)) -> NonEmpty (Path, Node (tree (Tok a))) forall (tree :: * -> *) a. IsTree tree => Node (tree a) -> NonEmpty (Path, Node (tree a)) nodesOnPath Node (tree (Tok a)) n) -- | Search the tree in pre-order starting at a given node, until -- finding a leaf which is at or after the given point. An effort is -- also made to return a leaf as close as possible to @p@. -- -- TODO: rename to fromLeafToLeafAt fromLeafToLeafAfter :: IsTree tree => Point -> Node (tree (Tok a)) -> Node (tree (Tok a)) fromLeafToLeafAfter :: Point -> Node (tree (Tok a)) -> Node (tree (Tok a)) fromLeafToLeafAfter Point p (Path xs, tree (Tok a) root) = Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace Text "fromLeafToLeafAfter:" (Node (tree (Tok a)) -> Node (tree (Tok a))) -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a b. (a -> b) -> a -> b $ Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "xs = " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Path -> Text forall a. Show a => a -> Text showT Path xs) (Node (tree (Tok a)) -> Node (tree (Tok a))) -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a b. (a -> b) -> a -> b $ Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "xsValid = " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Path -> Text forall a. Show a => a -> Text showT Path xsValid) (Node (tree (Tok a)) -> Node (tree (Tok a))) -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a b. (a -> b) -> a -> b $ Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "p = " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Point -> Text forall a. Show a => a -> Text showT Point p) (Node (tree (Tok a)) -> Node (tree (Tok a))) -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a b. (a -> b) -> a -> b $ Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "leafBeforeP = " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Bool -> Text forall a. Show a => a -> Text showT Bool leafBeforeP) (Node (tree (Tok a)) -> Node (tree (Tok a))) -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a b. (a -> b) -> a -> b $ Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "leaf ~ " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Region -> Text forall a. Show a => a -> Text showT (tree (Tok a) -> Region forall (t :: * -> *) t1. Foldable t => t (Tok t1) -> Region subtreeRegion tree (Tok a) leaf)) (Node (tree (Tok a)) -> Node (tree (Tok a))) -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a b. (a -> b) -> a -> b $ Text -> Node (tree (Tok a)) -> Node (tree (Tok a)) forall a. Text -> a -> a trace (Text "xs' = " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Path -> Text forall a. Show a => a -> Text showT Path xs') Node (tree (Tok a)) result where xs' :: Path xs' = case [Node (tree (Tok a))] candidateLeaves of [] -> [] Node (tree (Tok a)) c:[Node (tree (Tok a))] cs -> Node (tree (Tok a)) -> Path forall a b. (a, b) -> a fst (Node (tree (Tok a)) -> Path) -> Node (tree (Tok a)) -> Path forall a b. (a -> b) -> a -> b $ (Node (tree (Tok a)) -> Bool) -> NonEmpty (Node (tree (Tok a))) -> Node (tree (Tok a)) forall a. (a -> Bool) -> NonEmpty a -> a firstOrLastThat (\(Path _,tree (Tok a) s) -> tree (Tok a) -> Point forall (t :: * -> *) t1. Foldable t => t (Tok t1) -> Point getFirstOffset tree (Tok a) s Point -> Point -> Bool forall a. Ord a => a -> a -> Bool >= Point p) (Node (tree (Tok a)) c Node (tree (Tok a)) -> [Node (tree (Tok a))] -> NonEmpty (Node (tree (Tok a))) forall a. a -> [a] -> NonEmpty a :| [Node (tree (Tok a))] cs) candidateLeaves :: [Node (tree (Tok a))] candidateLeaves = (Int -> [(Int, tree (Tok a))] -> [(Int, tree (Tok a))]) -> Node (tree (Tok a)) -> [Node (tree (Tok a))] forall (tree :: * -> *) a. IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Node (tree a) -> [Node (tree a)] allLeavesRelative Int -> [(Int, tree (Tok a))] -> [(Int, tree (Tok a))] forall a. Int -> [a] -> [a] relChild Node (tree (Tok a)) n ((a -> Bool) -> NonEmpty a -> a firstOrLastThat,Int -> [a] -> [a] relChild) = if Bool leafBeforeP then ((a -> Bool) -> NonEmpty a -> a forall a. (a -> Bool) -> NonEmpty a -> a firstThat,Int -> [a] -> [a] forall a. Int -> [a] -> [a] afterChild) else ((a -> Bool) -> NonEmpty a -> a forall a. (a -> Bool) -> NonEmpty a -> a lastThat,Int -> [a] -> [a] forall a. Int -> [a] -> [a] beforeChild) (Path xsValid,tree (Tok a) leaf) = Node (tree (Tok a)) -> Node (tree (Tok a)) forall (tree :: * -> *) a. IsTree tree => Node (tree a) -> Node (tree a) wkDown (Path xs,tree (Tok a) root) leafBeforeP :: Bool leafBeforeP = tree (Tok a) -> Point forall (t :: * -> *) t1. Foldable t => t (Tok t1) -> Point getFirstOffset tree (Tok a) leaf Point -> Point -> Bool forall a. Ord a => a -> a -> Bool <= Point p n :: Node (tree (Tok a)) n = (Path xsValid,tree (Tok a) root) result :: Node (tree (Tok a)) result = (Path xs',tree (Tok a) root) allLeavesRelative :: IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Node (tree a) -> [Node (tree a)] allLeavesRelative :: (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Node (tree a) -> [Node (tree a)] allLeavesRelative Int -> [(Int, tree a)] -> [(Int, tree a)] select = (Node (tree a) -> Bool) -> [Node (tree a)] -> [Node (tree a)] forall a. (a -> Bool) -> [a] -> [a] filter (Bool -> Bool not (Bool -> Bool) -> (Node (tree a) -> Bool) -> Node (tree a) -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . tree a -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool nullSubtree (tree a -> Bool) -> (Node (tree a) -> tree a) -> Node (tree a) -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Node (tree a) -> tree a forall a b. (a, b) -> b snd) ([Node (tree a)] -> [Node (tree a)]) -> (Node (tree a) -> [Node (tree a)]) -> Node (tree a) -> [Node (tree a)] forall b c a. (b -> c) -> (a -> b) -> a -> c . (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> [(Node (tree a), Int)] -> [Node (tree a)] forall (tree :: * -> *) a. IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> [(Node (tree a), Int)] -> [Node (tree a)] allLeavesRelative' Int -> [(Int, tree a)] -> [(Int, tree a)] select ([(Node (tree a), Int)] -> [Node (tree a)]) -> (Node (tree a) -> [(Node (tree a), Int)]) -> Node (tree a) -> [Node (tree a)] forall b c a. (b -> c) -> (a -> b) -> a -> c . NonEmpty (Node (tree a), Int) -> [(Node (tree a), Int)] forall a. NonEmpty a -> [a] NE.toList (NonEmpty (Node (tree a), Int) -> [(Node (tree a), Int)]) -> (Node (tree a) -> NonEmpty (Node (tree a), Int)) -> Node (tree a) -> [(Node (tree a), Int)] forall b c a. (b -> c) -> (a -> b) -> a -> c . NonEmpty (Node (tree a), Int) -> NonEmpty (Node (tree a), Int) forall a. NonEmpty a -> NonEmpty a NE.reverse (NonEmpty (Node (tree a), Int) -> NonEmpty (Node (tree a), Int)) -> (Node (tree a) -> NonEmpty (Node (tree a), Int)) -> Node (tree a) -> NonEmpty (Node (tree a), Int) forall b c a. (b -> c) -> (a -> b) -> a -> c . Node (tree a) -> NonEmpty (Node (tree a), Int) forall (tree :: * -> *) a. IsTree tree => Node (tree a) -> NonEmpty (Node (tree a), Int) nodesAndChildIndex -- we remove empty subtrees because their region is [0,0]. -- | Takes a list of (node, index of already inspected child), and -- return all leaves in this node after the said child). allLeavesRelative' :: IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> [(Node (tree a), Int)] -> [Node (tree a)] allLeavesRelative' :: (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> [(Node (tree a), Int)] -> [Node (tree a)] allLeavesRelative' Int -> [(Int, tree a)] -> [(Int, tree a)] select [(Node (tree a), Int)] l = [(Path xs Path -> Path -> Path forall a. Semigroup a => a -> a -> a <> Path xs', tree a t') | ((Path xs,tree a t),Int c) <- [(Node (tree a), Int)] l , (Path xs',tree a t') <- (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Int -> tree a -> [Node (tree a)] forall (tree :: * -> *) a. IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Int -> tree a -> [Node (tree a)] allLeavesRelativeChild Int -> [(Int, tree a)] -> [(Int, tree a)] select Int c tree a t] -- | Given a root, return all the nodes encountered along it, their -- paths, and the index of the child which comes next. nodesAndChildIndex :: IsTree tree => Node (tree a) -> NonEmpty (Node (tree a), Int) nodesAndChildIndex :: Node (tree a) -> NonEmpty (Node (tree a), Int) nodesAndChildIndex ([],tree a t) = (Node (tree a), Int) -> NonEmpty (Node (tree a), Int) forall (m :: * -> *) a. Monad m => a -> m a return (([],tree a t),Int -> Int forall a. Num a => a -> a negate Int 1) nodesAndChildIndex (Int x:Path xs, tree a t) = case Int -> [tree a] -> Maybe (tree a) forall a. Int -> [a] -> Maybe a index Int x (tree a -> [tree a] forall (tree :: * -> *) t. IsTree tree => tree t -> [tree t] subtrees tree a t) of Just tree a c' -> (([],tree a t), Int x) (Node (tree a), Int) -> NonEmpty (Node (tree a), Int) -> NonEmpty (Node (tree a), Int) forall a. a -> NonEmpty a -> NonEmpty a NE.<| ((Node (tree a), Int) -> (Node (tree a), Int)) -> NonEmpty (Node (tree a), Int) -> NonEmpty (Node (tree a), Int) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((Node (tree a) -> Node (tree a)) -> (Node (tree a), Int) -> (Node (tree a), Int) forall (a :: * -> * -> *) b c d. Arrow a => a b c -> a (b, d) (c, d) first ((Node (tree a) -> Node (tree a)) -> (Node (tree a), Int) -> (Node (tree a), Int)) -> (Node (tree a) -> Node (tree a)) -> (Node (tree a), Int) -> (Node (tree a), Int) forall a b. (a -> b) -> a -> b $ (Path -> Path) -> Node (tree a) -> Node (tree a) forall (a :: * -> * -> *) b c d. Arrow a => a b c -> a (b, d) (c, d) first (Int xInt -> Path -> Path forall a. a -> [a] -> [a] :)) (Node (tree a) -> NonEmpty (Node (tree a), Int) forall (tree :: * -> *) a. IsTree tree => Node (tree a) -> NonEmpty (Node (tree a), Int) nodesAndChildIndex (Path xs,tree a c')) Maybe (tree a) Nothing -> (Node (tree a), Int) -> NonEmpty (Node (tree a), Int) forall (m :: * -> *) a. Monad m => a -> m a return (([],tree a t),Int -> Int forall a. Num a => a -> a negate Int 1) nodesOnPath :: IsTree tree => Node (tree a) -> NonEmpty (Path, Node (tree a)) nodesOnPath :: Node (tree a) -> NonEmpty (Path, Node (tree a)) nodesOnPath ([],tree a t) = (Path, Node (tree a)) -> NonEmpty (Path, Node (tree a)) forall (m :: * -> *) a. Monad m => a -> m a return ([],([],tree a t)) nodesOnPath (Int x:Path xs,tree a t) = ([],(Int xInt -> Path -> Path forall a. a -> [a] -> [a] :Path xs,tree a t)) (Path, Node (tree a)) -> NonEmpty (Path, Node (tree a)) -> NonEmpty (Path, Node (tree a)) forall a. a -> NonEmpty a -> NonEmpty a NE.<| case Int -> [tree a] -> Maybe (tree a) forall a. Int -> [a] -> Maybe a index Int x (tree a -> [tree a] forall (tree :: * -> *) t. IsTree tree => tree t -> [tree t] subtrees tree a t) of Maybe (tree a) Nothing -> Text -> NonEmpty (Path, Node (tree a)) forall a. Text -> a error Text "nodesOnPath: non-existent path" Just tree a c -> ((Path, Node (tree a)) -> (Path, Node (tree a))) -> NonEmpty (Path, Node (tree a)) -> NonEmpty (Path, Node (tree a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((Path -> Path) -> (Path, Node (tree a)) -> (Path, Node (tree a)) forall (a :: * -> * -> *) b c d. Arrow a => a b c -> a (b, d) (c, d) first (Int xInt -> Path -> Path forall a. a -> [a] -> [a] :)) (Node (tree a) -> NonEmpty (Path, Node (tree a)) forall (tree :: * -> *) a. IsTree tree => Node (tree a) -> NonEmpty (Path, Node (tree a)) nodesOnPath (Path xs,tree a c)) beforeChild :: Int -> [a] -> [a] beforeChild :: Int -> [a] -> [a] beforeChild (-1) = [a] -> [a] forall a. [a] -> [a] reverse -- (-1) indicates that all children should be taken. beforeChild Int c = [a] -> [a] forall a. [a] -> [a] reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a] forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> [a] -> [a] forall a. Int -> [a] -> [a] take (Int cInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) afterChild :: Int -> [a] -> [a] afterChild :: Int -> [a] -> [a] afterChild Int c = Int -> [a] -> [a] forall a. Int -> [a] -> [a] drop (Int cInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) -- | Return all leaves after or before child depending on the relation -- which is given. allLeavesRelativeChild :: IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Int -> tree a -> [Node (tree a)] allLeavesRelativeChild :: (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Int -> tree a -> [Node (tree a)] allLeavesRelativeChild Int -> [(Int, tree a)] -> [(Int, tree a)] select Int c tree a t | [tree a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [tree a] ts = Node (tree a) -> [Node (tree a)] forall (m :: * -> *) a. Monad m => a -> m a return ([], tree a t) | Bool otherwise = [(Int xInt -> Path -> Path forall a. a -> [a] -> [a] :Path xs,tree a t') | (Int x,tree a ct) <- Int -> [(Int, tree a)] -> [(Int, tree a)] select Int c (Path -> [tree a] -> [(Int, tree a)] forall a b. [a] -> [b] -> [(a, b)] zip [Int 0..] [tree a] ts), (Path xs, tree a t') <- (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> tree a -> [Node (tree a)] forall (tree :: * -> *) a. IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> tree a -> [Node (tree a)] allLeavesIn Int -> [(Int, tree a)] -> [(Int, tree a)] select tree a ct] where ts :: [tree a] ts = tree a -> [tree a] forall (tree :: * -> *) t. IsTree tree => tree t -> [tree t] subtrees tree a t -- | Return all leaves (with paths) inside a given root. allLeavesIn :: (IsTree tree) => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> tree a -> [Node (tree a)] allLeavesIn :: (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> tree a -> [Node (tree a)] allLeavesIn Int -> [(Int, tree a)] -> [(Int, tree a)] select = (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Int -> tree a -> [Node (tree a)] forall (tree :: * -> *) a. IsTree tree => (Int -> [(Int, tree a)] -> [(Int, tree a)]) -> Int -> tree a -> [Node (tree a)] allLeavesRelativeChild Int -> [(Int, tree a)] -> [(Int, tree a)] select (-Int 1) -- | Return all subtrees in a tree; each element of the return list -- contains paths to nodes. (Root is at the start of each path) getAllPaths :: IsTree tree => tree t -> [[tree t]] getAllPaths :: tree t -> [[tree t]] getAllPaths tree t t = ([tree t] -> [tree t]) -> [[tree t]] -> [[tree t]] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ([tree t] -> [tree t] -> [tree t] forall a. Semigroup a => a -> a -> a <>[tree t t]) ([] [tree t] -> [[tree t]] -> [[tree t]] forall a. a -> [a] -> [a] : (tree t -> [[tree t]]) -> [tree t] -> [[tree t]] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap tree t -> [[tree t]] forall (tree :: * -> *) t. IsTree tree => tree t -> [[tree t]] getAllPaths (tree t -> [tree t] forall (tree :: * -> *) t. IsTree tree => tree t -> [tree t] subtrees tree t t)) goDown :: IsTree tree => Int -> tree t -> Maybe (tree t) goDown :: Int -> tree t -> Maybe (tree t) goDown Int i = Int -> [tree t] -> Maybe (tree t) forall a. Int -> [a] -> Maybe a index Int i ([tree t] -> Maybe (tree t)) -> (tree t -> [tree t]) -> tree t -> Maybe (tree t) forall b c a. (b -> c) -> (a -> b) -> a -> c . tree t -> [tree t] forall (tree :: * -> *) t. IsTree tree => tree t -> [tree t] subtrees index :: Int -> [a] -> Maybe a index :: Int -> [a] -> Maybe a index Int _ [] = Maybe a forall a. Maybe a Nothing index Int 0 (a h:[a] _) = a -> Maybe a forall a. a -> Maybe a Just a h index Int n (a _:[a] t) = Int -> [a] -> Maybe a forall a. Int -> [a] -> Maybe a index (Int nInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) [a] t walkDown :: IsTree tree => Node (tree t) -> Maybe (tree t) walkDown :: Node (tree t) -> Maybe (tree t) walkDown ([],tree t t) = tree t -> Maybe (tree t) forall (m :: * -> *) a. Monad m => a -> m a return tree t t walkDown (Int x:Path xs,tree t t) = Int -> tree t -> Maybe (tree t) forall (tree :: * -> *) t. IsTree tree => Int -> tree t -> Maybe (tree t) goDown Int x tree t t Maybe (tree t) -> (tree t -> Maybe (tree t)) -> Maybe (tree t) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (Node (tree t) -> Maybe (tree t)) -> Path -> tree t -> Maybe (tree t) forall a b c. ((a, b) -> c) -> a -> b -> c curry Node (tree t) -> Maybe (tree t) forall (tree :: * -> *) t. IsTree tree => Node (tree t) -> Maybe (tree t) walkDown Path xs wkDown :: IsTree tree => Node (tree a) -> Node (tree a) wkDown :: Node (tree a) -> Node (tree a) wkDown ([],tree a t) = ([],tree a t) wkDown (Int x:Path xs,tree a t) = case Int -> tree a -> Maybe (tree a) forall (tree :: * -> *) t. IsTree tree => Int -> tree t -> Maybe (tree t) goDown Int x tree a t of Maybe (tree a) Nothing -> ([],tree a t) Just tree a t' -> (Path -> Path) -> Node (tree a) -> Node (tree a) forall (a :: * -> * -> *) b c d. Arrow a => a b c -> a (b, d) (c, d) first (Int xInt -> Path -> Path forall a. a -> [a] -> [a] :) (Node (tree a) -> Node (tree a)) -> Node (tree a) -> Node (tree a) forall a b. (a -> b) -> a -> b $ Node (tree a) -> Node (tree a) forall (tree :: * -> *) a. IsTree tree => Node (tree a) -> Node (tree a) wkDown (Path xs,tree a t') -- | Search the given list, and return the last tree before the given -- point; with path to the root. (Root is at the start of the path) getLastPath :: IsTree tree => [tree (Tok t)] -> Point -> Maybe [tree (Tok t)] getLastPath :: [tree (Tok t)] -> Point -> Maybe [tree (Tok t)] getLastPath [tree (Tok t)] roots Point offset = case (([tree (Tok t)], Posn) -> Bool) -> [([tree (Tok t)], Posn)] -> [([tree (Tok t)], Posn)] forall a. (a -> Bool) -> [a] -> [a] takeWhile ((Point -> Point -> Bool forall a. Ord a => a -> a -> Bool < Point offset) (Point -> Bool) -> (([tree (Tok t)], Posn) -> Point) -> ([tree (Tok t)], Posn) -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Posn -> Point posnOfs (Posn -> Point) -> (([tree (Tok t)], Posn) -> Posn) -> ([tree (Tok t)], Posn) -> Point forall b c a. (b -> c) -> (a -> b) -> a -> c . ([tree (Tok t)], Posn) -> Posn forall a b. (a, b) -> b snd) [([tree (Tok t)], Posn)] allSubPathPosn of [] -> Maybe [tree (Tok t)] forall a. Maybe a Nothing [([tree (Tok t)], Posn)] xs -> [tree (Tok t)] -> Maybe [tree (Tok t)] forall a. a -> Maybe a Just ([tree (Tok t)] -> Maybe [tree (Tok t)]) -> [tree (Tok t)] -> Maybe [tree (Tok t)] forall a b. (a -> b) -> a -> b $ ([tree (Tok t)], Posn) -> [tree (Tok t)] forall a b. (a, b) -> a fst (([tree (Tok t)], Posn) -> [tree (Tok t)]) -> ([tree (Tok t)], Posn) -> [tree (Tok t)] forall a b. (a -> b) -> a -> b $ [([tree (Tok t)], Posn)] -> ([tree (Tok t)], Posn) forall a. [a] -> a last [([tree (Tok t)], Posn)] xs where allSubPathPosn :: [([tree (Tok t)], Posn)] allSubPathPosn = [ ([tree (Tok t)] p,Posn posn) | tree (Tok t) root <- [tree (Tok t)] roots , p :: [tree (Tok t)] p@(tree (Tok t) t':[tree (Tok t)] _) <- tree (Tok t) -> [[tree (Tok t)]] forall (tree :: * -> *) t. IsTree tree => tree t -> [[tree t]] getAllPaths tree (Tok t) root , Just Tok t tok <- [tree (Tok t) -> Maybe (Tok t) forall (t :: * -> *) a. Foldable t => t a -> Maybe a getFirstElement tree (Tok t) t'] , let posn :: Posn posn = Tok t -> Posn forall t. Tok t -> Posn tokPosn Tok t tok ] -- | Return all subtrees in a tree, in preorder. getAllSubTrees :: IsTree tree => tree t -> [tree t] getAllSubTrees :: tree t -> [tree t] getAllSubTrees tree t t = tree t t tree t -> [tree t] -> [tree t] forall a. a -> [a] -> [a] : (tree t -> [tree t]) -> [tree t] -> [tree t] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap tree t -> [tree t] forall (tree :: * -> *) t. IsTree tree => tree t -> [tree t] getAllSubTrees (tree t -> [tree t] forall (tree :: * -> *) t. IsTree tree => tree t -> [tree t] subtrees tree t t) -- | Return the 1st token of a subtree. getFirstElement :: Foldable t => t a -> Maybe a getFirstElement :: t a -> Maybe a getFirstElement t a tree = First a -> Maybe a forall a. First a -> Maybe a getFirst (First a -> Maybe a) -> First a -> Maybe a forall a b. (a -> b) -> a -> b $ (a -> First a) -> t a -> First a forall (t :: * -> *) m a. (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap (Maybe a -> First a forall a. Maybe a -> First a First (Maybe a -> First a) -> (a -> Maybe a) -> a -> First a forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Maybe a forall a. a -> Maybe a Just) t a tree nullSubtree :: Foldable t => t a -> Bool nullSubtree :: t a -> Bool nullSubtree = [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null ([a] -> Bool) -> (t a -> [a]) -> t a -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . t a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList getFirstTok, getLastTok :: Foldable t => t a -> Maybe a getFirstTok :: t a -> Maybe a getFirstTok = t a -> Maybe a forall (t :: * -> *) a. Foldable t => t a -> Maybe a getFirstElement getLastTok :: t a -> Maybe a getLastTok = t a -> Maybe a forall (t :: * -> *) a. Foldable t => t a -> Maybe a getLastElement -- | Return the last token of a subtree. getLastElement :: Foldable t => t a -> Maybe a getLastElement :: t a -> Maybe a getLastElement t a tree = Last a -> Maybe a forall a. Last a -> Maybe a getLast (Last a -> Maybe a) -> Last a -> Maybe a forall a b. (a -> b) -> a -> b $ (a -> Last a) -> t a -> Last a forall (t :: * -> *) m a. (Foldable t, Monoid m) => (a -> m) -> t a -> m foldMap (Maybe a -> Last a forall a. Maybe a -> Last a Last (Maybe a -> Last a) -> (a -> Maybe a) -> a -> Last a forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Maybe a forall a. a -> Maybe a Just) t a tree getFirstOffset, getLastOffset :: Foldable t => t (Tok t1) -> Point getFirstOffset :: t (Tok t1) -> Point getFirstOffset = Point -> (Tok t1 -> Point) -> Maybe (Tok t1) -> Point forall b a. b -> (a -> b) -> Maybe a -> b maybe Point 0 Tok t1 -> Point forall t. Tok t -> Point tokBegin (Maybe (Tok t1) -> Point) -> (t (Tok t1) -> Maybe (Tok t1)) -> t (Tok t1) -> Point forall b c a. (b -> c) -> (a -> b) -> a -> c . t (Tok t1) -> Maybe (Tok t1) forall (t :: * -> *) a. Foldable t => t a -> Maybe a getFirstTok getLastOffset :: t (Tok t1) -> Point getLastOffset = Point -> (Tok t1 -> Point) -> Maybe (Tok t1) -> Point forall b a. b -> (a -> b) -> Maybe a -> b maybe Point 0 Tok t1 -> Point forall t. Tok t -> Point tokEnd (Maybe (Tok t1) -> Point) -> (t (Tok t1) -> Maybe (Tok t1)) -> t (Tok t1) -> Point forall b c a. (b -> c) -> (a -> b) -> a -> c . t (Tok t1) -> Maybe (Tok t1) forall (t :: * -> *) a. Foldable t => t a -> Maybe a getLastTok subtreeRegion :: Foldable t => t (Tok t1) -> Region subtreeRegion :: t (Tok t1) -> Region subtreeRegion t (Tok t1) t = Point -> Point -> Region mkRegion (t (Tok t1) -> Point forall (t :: * -> *) t1. Foldable t => t (Tok t1) -> Point getFirstOffset t (Tok t1) t) (t (Tok t1) -> Point forall (t :: * -> *) t1. Foldable t => t (Tok t1) -> Point getLastOffset t (Tok t1) t) -- | Given a tree, return (first offset, number of lines). getSubtreeSpan :: (Foldable tree) => tree (Tok t) -> (Point, Int) getSubtreeSpan :: tree (Tok t) -> (Point, Int) getSubtreeSpan tree (Tok t) tree = (Posn -> Point posnOfs Posn firstOff, Int lastLine Int -> Int -> Int forall a. Num a => a -> a -> a - Int firstLine) where bounds :: [Posn] bounds@[Posn firstOff, Posn _last] = (Maybe (Tok t) -> Posn) -> [Maybe (Tok t)] -> [Posn] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Tok t -> Posn forall t. Tok t -> Posn tokPosn (Tok t -> Posn) -> (Maybe (Tok t) -> Tok t) -> Maybe (Tok t) -> Posn forall b c a. (b -> c) -> (a -> b) -> a -> c . Maybe (Tok t) -> Tok t forall p. Maybe p -> p assertJust) [tree (Tok t) -> Maybe (Tok t) forall (t :: * -> *) a. Foldable t => t a -> Maybe a getFirstElement tree (Tok t) tree, tree (Tok t) -> Maybe (Tok t) forall (t :: * -> *) a. Foldable t => t a -> Maybe a getLastElement tree (Tok t) tree] [Int firstLine, Int lastLine] = (Posn -> Int) -> [Posn] -> Path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Posn -> Int posnLine [Posn] bounds assertJust :: Maybe p -> p assertJust (Just p x) = p x assertJust Maybe p _ = Text -> p forall a. Text -> a error Text "assertJust: Just expected" ------------------------------------- -- Should be in Control.Applicative.? sepBy :: (Alternative f) => f a -> f v -> f [a] sepBy :: f a -> f v -> f [a] sepBy f a p f v s = f a -> f v -> f [a] forall (f :: * -> *) a v. Alternative f => f a -> f v -> f [a] sepBy1 f a p f v s f [a] -> f [a] -> f [a] forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> [a] -> f [a] forall (f :: * -> *) a. Applicative f => a -> f a pure [] sepBy1 :: (Alternative f) => f a -> f v -> f [a] sepBy1 :: f a -> f v -> f [a] sepBy1 f a p f v s = (:) (a -> [a] -> [a]) -> f a -> f ([a] -> [a]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f a p f ([a] -> [a]) -> f [a] -> f [a] forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> f a -> f [a] forall (f :: * -> *) a. Alternative f => f a -> f [a] many (f v s f v -> f a -> f a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> f a p)