{-# LANGUAGE DeriveTraversable #-}

-- | A 'LexTree' is a map designed to reconstruct the lexical structure (tree of scopes) of a source file, given an unordered list of scopes.
-- Values are inserted with a pair source locations as its key.
-- For a given key, we can then ask what the smallest enclosing scope is.
--
-- For example, in the snippet below the smallest scope containing @x@ is @b@.
-- @
--      x
-- |      a      |
--    |  b  |
--                   |   c   |
-- @
--
-- Scopes are not allowed to overlap.
--
-- The purpose of this data structure is to find out what surrounding definition a certain use site belongs to.
module Calligraphy.Util.LexTree
  ( LexTree (..),
    TreeError (..),
    Calligraphy.Util.LexTree.lookup,
    lookupOuter,
    insert,
    emptyLexTree,
    foldLexTree,
    toForest,
    insertWith,
    height,
    toList,
    bin,
    shift,
  )
where

import Control.Applicative
import Data.Tree (Forest)
import qualified Data.Tree as Tree

data LexTree p a
  = Tip
  | Bin
      {-# UNPACK #-} !Int
      -- ^ Height
      !(LexTree p a)
      -- ^ Scopes at the same level, left of this one
      !p
      -- ^ Left-hand bound of this scope (inclusive)
      a
      !(LexTree p a)
      -- ^ Children
      !p
      -- ^ Right-hand bound of this scope (exclusive)
      !(LexTree p a)
      -- ^ Scopes at the same level, right of this entry
  deriving (Int -> LexTree p a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p a. (Show p, Show a) => Int -> LexTree p a -> ShowS
forall p a. (Show p, Show a) => [LexTree p a] -> ShowS
forall p a. (Show p, Show a) => LexTree p a -> String
showList :: [LexTree p a] -> ShowS
$cshowList :: forall p a. (Show p, Show a) => [LexTree p a] -> ShowS
show :: LexTree p a -> String
$cshow :: forall p a. (Show p, Show a) => LexTree p a -> String
showsPrec :: Int -> LexTree p a -> ShowS
$cshowsPrec :: forall p a. (Show p, Show a) => Int -> LexTree p a -> ShowS
Show, forall a b. a -> LexTree p b -> LexTree p a
forall a b. (a -> b) -> LexTree p a -> LexTree p b
forall p a b. a -> LexTree p b -> LexTree p a
forall p a b. (a -> b) -> LexTree p a -> LexTree p b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> LexTree p b -> LexTree p a
$c<$ :: forall p a b. a -> LexTree p b -> LexTree p a
fmap :: forall a b. (a -> b) -> LexTree p a -> LexTree p b
$cfmap :: forall p a b. (a -> b) -> LexTree p a -> LexTree p b
Functor, forall a. LexTree p a -> Bool
forall p a. Eq a => a -> LexTree p a -> Bool
forall p a. Num a => LexTree p a -> a
forall p a. Ord a => LexTree p a -> a
forall m a. Monoid m => (a -> m) -> LexTree p a -> m
forall p m. Monoid m => LexTree p m -> m
forall p a. LexTree p a -> Bool
forall p a. LexTree p a -> Int
forall p a. LexTree p a -> [a]
forall a b. (a -> b -> b) -> b -> LexTree p a -> b
forall p a. (a -> a -> a) -> LexTree p a -> a
forall p m a. Monoid m => (a -> m) -> LexTree p a -> m
forall p b a. (b -> a -> b) -> b -> LexTree p a -> b
forall p a b. (a -> b -> b) -> b -> LexTree p a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => LexTree p a -> a
$cproduct :: forall p a. Num a => LexTree p a -> a
sum :: forall a. Num a => LexTree p a -> a
$csum :: forall p a. Num a => LexTree p a -> a
minimum :: forall a. Ord a => LexTree p a -> a
$cminimum :: forall p a. Ord a => LexTree p a -> a
maximum :: forall a. Ord a => LexTree p a -> a
$cmaximum :: forall p a. Ord a => LexTree p a -> a
elem :: forall a. Eq a => a -> LexTree p a -> Bool
$celem :: forall p a. Eq a => a -> LexTree p a -> Bool
length :: forall a. LexTree p a -> Int
$clength :: forall p a. LexTree p a -> Int
null :: forall a. LexTree p a -> Bool
$cnull :: forall p a. LexTree p a -> Bool
toList :: forall a. LexTree p a -> [a]
$ctoList :: forall p a. LexTree p a -> [a]
foldl1 :: forall a. (a -> a -> a) -> LexTree p a -> a
$cfoldl1 :: forall p a. (a -> a -> a) -> LexTree p a -> a
foldr1 :: forall a. (a -> a -> a) -> LexTree p a -> a
$cfoldr1 :: forall p a. (a -> a -> a) -> LexTree p a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> LexTree p a -> b
$cfoldl' :: forall p b a. (b -> a -> b) -> b -> LexTree p a -> b
foldl :: forall b a. (b -> a -> b) -> b -> LexTree p a -> b
$cfoldl :: forall p b a. (b -> a -> b) -> b -> LexTree p a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> LexTree p a -> b
$cfoldr' :: forall p a b. (a -> b -> b) -> b -> LexTree p a -> b
foldr :: forall a b. (a -> b -> b) -> b -> LexTree p a -> b
$cfoldr :: forall p a b. (a -> b -> b) -> b -> LexTree p a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> LexTree p a -> m
$cfoldMap' :: forall p m a. Monoid m => (a -> m) -> LexTree p a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> LexTree p a -> m
$cfoldMap :: forall p m a. Monoid m => (a -> m) -> LexTree p a -> m
fold :: forall m. Monoid m => LexTree p m -> m
$cfold :: forall p m. Monoid m => LexTree p m -> m
Foldable, forall p. Functor (LexTree p)
forall p. Foldable (LexTree p)
forall p (m :: * -> *) a.
Monad m =>
LexTree p (m a) -> m (LexTree p a)
forall p (f :: * -> *) a.
Applicative f =>
LexTree p (f a) -> f (LexTree p a)
forall p (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LexTree p a -> m (LexTree p b)
forall p (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LexTree p a -> f (LexTree p b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LexTree p a -> f (LexTree p b)
sequence :: forall (m :: * -> *) a.
Monad m =>
LexTree p (m a) -> m (LexTree p a)
$csequence :: forall p (m :: * -> *) a.
Monad m =>
LexTree p (m a) -> m (LexTree p a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LexTree p a -> m (LexTree p b)
$cmapM :: forall p (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LexTree p a -> m (LexTree p b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
LexTree p (f a) -> f (LexTree p a)
$csequenceA :: forall p (f :: * -> *) a.
Applicative f =>
LexTree p (f a) -> f (LexTree p a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LexTree p a -> f (LexTree p b)
$ctraverse :: forall p (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LexTree p a -> f (LexTree p b)
Traversable)

instance (Eq p, Eq a) => Eq (LexTree p a) where
  LexTree p a
ta == :: LexTree p a -> LexTree p a -> Bool
== LexTree p a
tb = forall p a. LexTree p a -> [(p, a, p)]
toList LexTree p a
ta forall a. Eq a => a -> a -> Bool
== forall p a. LexTree p a -> [(p, a, p)]
toList LexTree p a
tb

lookup :: Ord p => p -> LexTree p a -> Maybe a
lookup :: forall p a. Ord p => p -> LexTree p a -> Maybe a
lookup p
p = forall r p a.
r -> (r -> p -> a -> r -> p -> r -> r) -> LexTree p a -> r
foldLexTree forall a. Maybe a
Nothing forall {a}. Maybe a -> p -> a -> Maybe a -> p -> Maybe a -> Maybe a
f
  where
    f :: Maybe a -> p -> a -> Maybe a -> p -> Maybe a -> Maybe a
f Maybe a
ls p
l a
a Maybe a
m p
r Maybe a
rs
      | p
p forall a. Ord a => a -> a -> Bool
>= p
l Bool -> Bool -> Bool
&& p
p forall a. Ord a => a -> a -> Bool
< p
r = Maybe a
m forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Maybe a
Just a
a
      | p
p forall a. Ord a => a -> a -> Bool
< p
l = Maybe a
ls
      | p
p forall a. Ord a => a -> a -> Bool
>= p
r = Maybe a
rs
      | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"impossible"

lookupOuter :: Ord p => p -> LexTree p a -> Maybe a
lookupOuter :: forall p a. Ord p => p -> LexTree p a -> Maybe a
lookupOuter p
p = forall r p a.
r -> (r -> p -> a -> r -> p -> r -> r) -> LexTree p a -> r
foldLexTree forall a. Maybe a
Nothing forall {a} {p}. Maybe a -> p -> a -> p -> p -> Maybe a -> Maybe a
f
  where
    f :: Maybe a -> p -> a -> p -> p -> Maybe a -> Maybe a
f Maybe a
ls p
l a
a p
_ p
r Maybe a
rs
      | p
p forall a. Ord a => a -> a -> Bool
>= p
l Bool -> Bool -> Bool
&& p
p forall a. Ord a => a -> a -> Bool
< p
r = forall a. a -> Maybe a
Just a
a
      | p
p forall a. Ord a => a -> a -> Bool
< p
l = Maybe a
ls
      | p
p forall a. Ord a => a -> a -> Bool
>= p
r = Maybe a
rs
      | Bool
otherwise = forall a. HasCallStack => String -> a
error String
"impossible"

toList :: LexTree p a -> [(p, a, p)]
toList :: forall p a. LexTree p a -> [(p, a, p)]
toList LexTree p a
t = forall r p a.
r -> (r -> p -> a -> r -> p -> r -> r) -> LexTree p a -> r
foldLexTree forall a. a -> a
id forall {a} {b} {c} {c} {b} {a}.
([(a, b, c)] -> c)
-> a -> b -> (b -> [(a, b, c)]) -> c -> (a -> b) -> a -> c
f LexTree p a
t []
  where
    f :: ([(a, b, c)] -> c)
-> a -> b -> (b -> [(a, b, c)]) -> c -> (a -> b) -> a -> c
f [(a, b, c)] -> c
ls a
l b
a b -> [(a, b, c)]
m c
r a -> b
rs = [(a, b, c)] -> c
ls forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a
l, b
a, c
r) forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> [(a, b, c)]
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
rs

foldLexTree :: r -> (r -> p -> a -> r -> p -> r -> r) -> LexTree p a -> r
foldLexTree :: forall r p a.
r -> (r -> p -> a -> r -> p -> r -> r) -> LexTree p a -> r
foldLexTree r
fTip r -> p -> a -> r -> p -> r -> r
fBin = LexTree p a -> r
go
  where
    go :: LexTree p a -> r
go LexTree p a
Tip = r
fTip
    go (Bin Int
_ LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rs) = r -> p -> a -> r -> p -> r -> r
fBin (LexTree p a -> r
go LexTree p a
ls) p
l a
a (LexTree p a -> r
go LexTree p a
ms) p
r (LexTree p a -> r
go LexTree p a
rs)

emptyLexTree :: LexTree p a
emptyLexTree :: forall p a. LexTree p a
emptyLexTree = forall p a. LexTree p a
Tip

toForest :: LexTree p a -> Forest (p, a, p)
toForest :: forall p a. LexTree p a -> Forest (p, a, p)
toForest LexTree p a
lt = forall r p a.
r -> (r -> p -> a -> r -> p -> r -> r) -> LexTree p a -> r
foldLexTree forall a. a -> a
id forall {a} {b} {c} {c} {a} {a}.
([Tree (a, b, c)] -> c)
-> a
-> b
-> ([a] -> [Tree (a, b, c)])
-> c
-> (a -> [Tree (a, b, c)])
-> a
-> c
f LexTree p a
lt []
  where
    f :: ([Tree (a, b, c)] -> c)
-> a
-> b
-> ([a] -> [Tree (a, b, c)])
-> c
-> (a -> [Tree (a, b, c)])
-> a
-> c
f [Tree (a, b, c)] -> c
ls a
l b
a [a] -> [Tree (a, b, c)]
m c
r a -> [Tree (a, b, c)]
rs = [Tree (a, b, c)] -> c
ls forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [Tree a] -> Tree a
Tree.Node (a
l, b
a, c
r) ([a] -> [Tree (a, b, c)]
m []) forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Tree (a, b, c)]
rs

{-# INLINE height #-}
height :: LexTree p a -> Int
height :: forall p a. LexTree p a -> Int
height LexTree p a
Tip = Int
0
height (Bin Int
h LexTree p a
_ p
_ a
_ LexTree p a
_ p
_ LexTree p a
_) = Int
h

shift :: Num p => p -> LexTree p a -> LexTree p a
shift :: forall p a. Num p => p -> LexTree p a -> LexTree p a
shift p
p = forall {a}. LexTree p a -> LexTree p a
go
  where
    go :: LexTree p a -> LexTree p a
go LexTree p a
Tip = forall p a. LexTree p a
Tip
    go (Bin Int
h LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rs) = forall p a.
Int
-> LexTree p a
-> p
-> a
-> LexTree p a
-> p
-> LexTree p a
-> LexTree p a
Bin Int
h (LexTree p a -> LexTree p a
go LexTree p a
ls) (p
l forall a. Num a => a -> a -> a
+ p
p) a
a (LexTree p a -> LexTree p a
go LexTree p a
ms) (p
r forall a. Num a => a -> a -> a
+ p
p) (LexTree p a -> LexTree p a
go LexTree p a
rs)

data TreeError p a
  = -- | Nonsensical bounds, i.e. a left-hand bound larger than the right-hand obund
    InvalidBounds p a p
  | -- | Two identical scopes
    OverlappingBounds a a p p
  | -- | An attempt to split halfway through a scope, usually the result of two partially overlapping scopes
    MidSplit
  | -- | Attempting to insert a scope that would not form a tree structure
    LexicalError p a p (LexTree p a)
  deriving (forall a b. a -> TreeError p b -> TreeError p a
forall a b. (a -> b) -> TreeError p a -> TreeError p b
forall p a b. a -> TreeError p b -> TreeError p a
forall p a b. (a -> b) -> TreeError p a -> TreeError p b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TreeError p b -> TreeError p a
$c<$ :: forall p a b. a -> TreeError p b -> TreeError p a
fmap :: forall a b. (a -> b) -> TreeError p a -> TreeError p b
$cfmap :: forall p a b. (a -> b) -> TreeError p a -> TreeError p b
Functor, forall a. TreeError p a -> Bool
forall p a. Eq a => a -> TreeError p a -> Bool
forall p a. Num a => TreeError p a -> a
forall p a. Ord a => TreeError p a -> a
forall m a. Monoid m => (a -> m) -> TreeError p a -> m
forall p m. Monoid m => TreeError p m -> m
forall p a. TreeError p a -> Bool
forall p a. TreeError p a -> Int
forall p a. TreeError p a -> [a]
forall a b. (a -> b -> b) -> b -> TreeError p a -> b
forall p a. (a -> a -> a) -> TreeError p a -> a
forall p m a. Monoid m => (a -> m) -> TreeError p a -> m
forall p b a. (b -> a -> b) -> b -> TreeError p a -> b
forall p a b. (a -> b -> b) -> b -> TreeError p a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => TreeError p a -> a
$cproduct :: forall p a. Num a => TreeError p a -> a
sum :: forall a. Num a => TreeError p a -> a
$csum :: forall p a. Num a => TreeError p a -> a
minimum :: forall a. Ord a => TreeError p a -> a
$cminimum :: forall p a. Ord a => TreeError p a -> a
maximum :: forall a. Ord a => TreeError p a -> a
$cmaximum :: forall p a. Ord a => TreeError p a -> a
elem :: forall a. Eq a => a -> TreeError p a -> Bool
$celem :: forall p a. Eq a => a -> TreeError p a -> Bool
length :: forall a. TreeError p a -> Int
$clength :: forall p a. TreeError p a -> Int
null :: forall a. TreeError p a -> Bool
$cnull :: forall p a. TreeError p a -> Bool
toList :: forall a. TreeError p a -> [a]
$ctoList :: forall p a. TreeError p a -> [a]
foldl1 :: forall a. (a -> a -> a) -> TreeError p a -> a
$cfoldl1 :: forall p a. (a -> a -> a) -> TreeError p a -> a
foldr1 :: forall a. (a -> a -> a) -> TreeError p a -> a
$cfoldr1 :: forall p a. (a -> a -> a) -> TreeError p a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> TreeError p a -> b
$cfoldl' :: forall p b a. (b -> a -> b) -> b -> TreeError p a -> b
foldl :: forall b a. (b -> a -> b) -> b -> TreeError p a -> b
$cfoldl :: forall p b a. (b -> a -> b) -> b -> TreeError p a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> TreeError p a -> b
$cfoldr' :: forall p a b. (a -> b -> b) -> b -> TreeError p a -> b
foldr :: forall a b. (a -> b -> b) -> b -> TreeError p a -> b
$cfoldr :: forall p a b. (a -> b -> b) -> b -> TreeError p a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> TreeError p a -> m
$cfoldMap' :: forall p m a. Monoid m => (a -> m) -> TreeError p a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> TreeError p a -> m
$cfoldMap :: forall p m a. Monoid m => (a -> m) -> TreeError p a -> m
fold :: forall m. Monoid m => TreeError p m -> m
$cfold :: forall p m. Monoid m => TreeError p m -> m
Foldable, forall p. Functor (TreeError p)
forall p. Foldable (TreeError p)
forall p (m :: * -> *) a.
Monad m =>
TreeError p (m a) -> m (TreeError p a)
forall p (f :: * -> *) a.
Applicative f =>
TreeError p (f a) -> f (TreeError p a)
forall p (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TreeError p a -> m (TreeError p b)
forall p (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TreeError p a -> f (TreeError p b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TreeError p a -> f (TreeError p b)
sequence :: forall (m :: * -> *) a.
Monad m =>
TreeError p (m a) -> m (TreeError p a)
$csequence :: forall p (m :: * -> *) a.
Monad m =>
TreeError p (m a) -> m (TreeError p a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TreeError p a -> m (TreeError p b)
$cmapM :: forall p (m :: * -> *) a b.
Monad m =>
(a -> m b) -> TreeError p a -> m (TreeError p b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
TreeError p (f a) -> f (TreeError p a)
$csequenceA :: forall p (f :: * -> *) a.
Applicative f =>
TreeError p (f a) -> f (TreeError p a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TreeError p a -> f (TreeError p b)
$ctraverse :: forall p (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> TreeError p a -> f (TreeError p b)
Traversable, TreeError p a -> TreeError p a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall p a. (Eq p, Eq a) => TreeError p a -> TreeError p a -> Bool
/= :: TreeError p a -> TreeError p a -> Bool
$c/= :: forall p a. (Eq p, Eq a) => TreeError p a -> TreeError p a -> Bool
== :: TreeError p a -> TreeError p a -> Bool
$c== :: forall p a. (Eq p, Eq a) => TreeError p a -> TreeError p a -> Bool
Eq, Int -> TreeError p a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p a. (Show p, Show a) => Int -> TreeError p a -> ShowS
forall p a. (Show p, Show a) => [TreeError p a] -> ShowS
forall p a. (Show p, Show a) => TreeError p a -> String
showList :: [TreeError p a] -> ShowS
$cshowList :: forall p a. (Show p, Show a) => [TreeError p a] -> ShowS
show :: TreeError p a -> String
$cshow :: forall p a. (Show p, Show a) => TreeError p a -> String
showsPrec :: Int -> TreeError p a -> ShowS
$cshowsPrec :: forall p a. (Show p, Show a) => Int -> TreeError p a -> ShowS
Show)

{-# INLINE bin' #-}
bin' :: LexTree p a -> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' :: forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rs = forall p a.
Int
-> LexTree p a
-> p
-> a
-> LexTree p a
-> p
-> LexTree p a
-> LexTree p a
Bin (forall a. Ord a => a -> a -> a
max (forall p a. LexTree p a -> Int
height LexTree p a
ls) (forall p a. LexTree p a -> Int
height LexTree p a
rs) forall a. Num a => a -> a -> a
+ Int
1) LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rs

-- | Only works if the height difference of the two trees is at most 2
{-# INLINE bin #-}
bin :: LexTree p a -> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin :: forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin (Bin Int
lh LexTree p a
lls p
ll a
la LexTree p a
lms p
lr LexTree p a
lrs) p
l a
a LexTree p a
ms p
r LexTree p a
rs
  | Int
lh forall a. Ord a => a -> a -> Bool
> forall p a. LexTree p a -> Int
height LexTree p a
rs forall a. Num a => a -> a -> a
+ Int
1 =
      case LexTree p a
lrs of
        Bin Int
lrh LexTree p a
lrls p
lrl a
lra LexTree p a
lrms p
lrr LexTree p a
lrrs | Int
lrh forall a. Ord a => a -> a -> Bool
> forall p a. LexTree p a -> Int
height LexTree p a
lls -> forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' (forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' LexTree p a
lls p
ll a
la LexTree p a
lms p
lr LexTree p a
lrls) p
lrl a
lra LexTree p a
lrms p
lrr (forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' LexTree p a
lrrs p
l a
a LexTree p a
ms p
r LexTree p a
rs)
        LexTree p a
_ -> forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' LexTree p a
lls p
ll a
la LexTree p a
lms p
lr (forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' LexTree p a
lrs p
l a
a LexTree p a
ms p
r LexTree p a
rs)
bin LexTree p a
ls p
l a
a LexTree p a
ms p
r (Bin Int
rh LexTree p a
rls p
rl a
ra LexTree p a
rms p
rr LexTree p a
rrs)
  | Int
rh forall a. Ord a => a -> a -> Bool
> forall p a. LexTree p a -> Int
height LexTree p a
ls forall a. Num a => a -> a -> a
+ Int
1 =
      case LexTree p a
rls of
        Bin Int
rlh LexTree p a
rlls p
rll a
rla LexTree p a
rlms p
rlr LexTree p a
rlrs | Int
rlh forall a. Ord a => a -> a -> Bool
> forall p a. LexTree p a -> Int
height LexTree p a
rrs -> forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' (forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rlls) p
rll a
rla LexTree p a
rlms p
rlr (forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' LexTree p a
rlrs p
rl a
ra LexTree p a
rms p
rr LexTree p a
rrs)
        LexTree p a
_ -> forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' (forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rls) p
rl a
ra LexTree p a
rms p
rr LexTree p a
rrs
bin LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rs = forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin' LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rs

split :: Ord p => p -> LexTree p a -> Either (TreeError p a) (LexTree p a, LexTree p a)
split :: forall p a.
Ord p =>
p
-> LexTree p a -> Either (TreeError p a) (LexTree p a, LexTree p a)
split p
p = forall {a} {p} {a}.
LexTree p a -> Either (TreeError p a) (LexTree p a, LexTree p a)
go
  where
    go :: LexTree p a -> Either (TreeError p a) (LexTree p a, LexTree p a)
go LexTree p a
Tip = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall p a. LexTree p a
Tip, forall p a. LexTree p a
Tip)
    go (Bin Int
_ LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rs)
      | p
p forall a. Ord a => a -> a -> Bool
<= p
l = do
          (LexTree p a
ll, LexTree p a
lr) <- LexTree p a -> Either (TreeError p a) (LexTree p a, LexTree p a)
go LexTree p a
ls
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (LexTree p a
ll, forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin LexTree p a
lr p
l a
a LexTree p a
ms p
r LexTree p a
rs)
      | p
p forall a. Ord a => a -> a -> Bool
>= p
r = do
          (LexTree p a
rl, LexTree p a
rr) <- LexTree p a -> Either (TreeError p a) (LexTree p a, LexTree p a)
go LexTree p a
rs
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rl, LexTree p a
rr)
      | Bool
otherwise = forall a b. a -> Either a b
Left forall p a. TreeError p a
MidSplit

{-# INLINE insertWith #-}
insertWith :: Ord p => (a -> a -> Maybe a) -> p -> a -> p -> LexTree p a -> Either (TreeError p a) (LexTree p a)
insertWith :: forall p a.
Ord p =>
(a -> a -> Maybe a)
-> p
-> a
-> p
-> LexTree p a
-> Either (TreeError p a) (LexTree p a)
insertWith a -> a -> Maybe a
f p
il a
ia p
ir LexTree p a
t
  | p
il forall a. Ord a => a -> a -> Bool
>= p
ir = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall p a. p -> a -> p -> TreeError p a
InvalidBounds p
il a
ia p
ir
  | Bool
otherwise = LexTree p a -> Either (TreeError p a) (LexTree p a)
go LexTree p a
t
  where
    go :: LexTree p a -> Either (TreeError p a) (LexTree p a)
go LexTree p a
Tip = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin forall p a. LexTree p a
Tip p
il a
ia forall p a. LexTree p a
Tip p
ir forall p a. LexTree p a
Tip
    go (Bin Int
h LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rs)
      | p
ir forall a. Ord a => a -> a -> Bool
<= p
l = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LexTree p a -> Either (TreeError p a) (LexTree p a)
go LexTree p a
ls) forall a b. (a -> b) -> a -> b
$ \LexTree p a
ls' -> forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin LexTree p a
ls' p
l a
a LexTree p a
ms p
r LexTree p a
rs
      | p
il forall a. Ord a => a -> a -> Bool
>= p
r = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LexTree p a -> Either (TreeError p a) (LexTree p a)
go LexTree p a
rs) forall a b. (a -> b) -> a -> b
$ \LexTree p a
rs' -> forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin LexTree p a
ls p
l a
a LexTree p a
ms p
r LexTree p a
rs'
      | p
il forall a. Eq a => a -> a -> Bool
== p
l Bool -> Bool -> Bool
&& p
ir forall a. Eq a => a -> a -> Bool
== p
r = case a -> a -> Maybe a
f a
ia a
a of
          Just a
a' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p a.
Int
-> LexTree p a
-> p
-> a
-> LexTree p a
-> p
-> LexTree p a
-> LexTree p a
Bin Int
h LexTree p a
ls p
l a
a' LexTree p a
ms p
r LexTree p a
rs
          Maybe a
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall p a. a -> a -> p -> p -> TreeError p a
OverlappingBounds a
ia a
a p
il p
ir
      | p
il forall a. Ord a => a -> a -> Bool
>= p
l Bool -> Bool -> Bool
&& p
ir forall a. Ord a => a -> a -> Bool
<= p
r = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LexTree p a -> Either (TreeError p a) (LexTree p a)
go LexTree p a
ms) forall a b. (a -> b) -> a -> b
$ \LexTree p a
ms' -> forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin LexTree p a
ls p
l a
a LexTree p a
ms' p
r LexTree p a
rs
      | p
il forall a. Ord a => a -> a -> Bool
<= p
l Bool -> Bool -> Bool
&& p
ir forall a. Ord a => a -> a -> Bool
>= p
r = do
          (LexTree p a
ll, LexTree p a
lr) <- forall p a.
Ord p =>
p
-> LexTree p a -> Either (TreeError p a) (LexTree p a, LexTree p a)
split p
il LexTree p a
ls
          (LexTree p a
rl, LexTree p a
rr) <- forall p a.
Ord p =>
p
-> LexTree p a -> Either (TreeError p a) (LexTree p a, LexTree p a)
split p
ir LexTree p a
rs
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin LexTree p a
ll p
il a
ia (forall p a.
LexTree p a
-> p -> a -> LexTree p a -> p -> LexTree p a -> LexTree p a
bin LexTree p a
lr p
l a
a LexTree p a
ms p
r LexTree p a
rl) p
ir LexTree p a
rr
      | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall p a. p -> a -> p -> LexTree p a -> TreeError p a
LexicalError p
il a
ia p
ir LexTree p a
t

insert :: Ord p => p -> a -> p -> LexTree p a -> Either (TreeError p a) (LexTree p a)
insert :: forall p a.
Ord p =>
p -> a -> p -> LexTree p a -> Either (TreeError p a) (LexTree p a)
insert = forall p a.
Ord p =>
(a -> a -> Maybe a)
-> p
-> a
-> p
-> LexTree p a
-> Either (TreeError p a) (LexTree p a)
insertWith (\a
_ a
_ -> forall a. Maybe a
Nothing)