{-# LANGUAGE
  DeriveTraversable,
  EmptyDataDeriving,
  FlexibleInstances,
  StandaloneDeriving,
  StrictData,
  UndecidableInstances #-}

module Little.Earley.Internal.Tree where

import Control.Monad (guard)
import Control.Applicative (Alternative(..), liftA2)
import Data.Function (on)
import Data.List (groupBy, sortBy)
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)

import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set

import Little.Earley.Internal.Core

-- | Generalized parse tree.
--
-- A basic parse tree ('Tree') consists of leaves labeled terminal symbols @t@ ('Leaf')
-- and nodes labeled with grammar rules associated to nonterminal symbols (@('Brch')@).
--
-- Other variants of parse trees ('TreeSet', 'TruncatedTreeSet') can be represented
-- using extension nodes ('Ext').
--
-- Trees may be infinite due to an input string matching infinitely many parse trees.
-- Note that even though @StrictData@ is enabled, we get laziness via the list type @[]@
-- and tuple type @(,)@.
data TreeT f n t c
  = Leaf Int t c  -- ^ The @Int@ field is the position of the token in the input.
  | Brch (RuleId n) Int Int [TreeT f n t c]
    -- ^ The @Int@ fields are the endpoints of this subtree in the input.
  | Ext (f (TreeT f n t c))

deriving instance (Eq n, Eq t, Eq c, Eq (f (TreeT f n t c))) => Eq (TreeT f n t c)
deriving instance (Show n, Show t, Show c, Show (f (TreeT f n t c))) => Show (TreeT f n t c)

-- | Basic parse tree.
type Tree = TreeT NoExt

-- | A set of 'Tree', using a compact encoding.
type TreeSet = TreeT Choice

-- | Result of 'truncateTree' applied to a 'Tree'.
type TruncatedTree = TreeT (Sum Ellipsis NoExt)

-- | Result of 'truncateTree' applied to a 'TreeSet'.
type TruncatedTreeSet = TreeT (Sum Ellipsis Choice)

-- * Functors for extending @TreeT@

-- | No extensions.
data NoExt a
  deriving (NoExt a -> NoExt a -> Bool
(NoExt a -> NoExt a -> Bool)
-> (NoExt a -> NoExt a -> Bool) -> Eq (NoExt a)
forall a. NoExt a -> NoExt a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoExt a -> NoExt a -> Bool
$c/= :: forall a. NoExt a -> NoExt a -> Bool
== :: NoExt a -> NoExt a -> Bool
$c== :: forall a. NoExt a -> NoExt a -> Bool
Eq, Int -> NoExt a -> ShowS
[NoExt a] -> ShowS
NoExt a -> String
(Int -> NoExt a -> ShowS)
-> (NoExt a -> String) -> ([NoExt a] -> ShowS) -> Show (NoExt a)
forall a. Int -> NoExt a -> ShowS
forall a. [NoExt a] -> ShowS
forall a. NoExt a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoExt a] -> ShowS
$cshowList :: forall a. [NoExt a] -> ShowS
show :: NoExt a -> String
$cshow :: forall a. NoExt a -> String
showsPrec :: Int -> NoExt a -> ShowS
$cshowsPrec :: forall a. Int -> NoExt a -> ShowS
Show, (a -> b) -> NoExt a -> NoExt b
(forall a b. (a -> b) -> NoExt a -> NoExt b)
-> (forall a b. a -> NoExt b -> NoExt a) -> Functor NoExt
forall a b. a -> NoExt b -> NoExt a
forall a b. (a -> b) -> NoExt a -> NoExt b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> NoExt b -> NoExt a
$c<$ :: forall a b. a -> NoExt b -> NoExt a
fmap :: (a -> b) -> NoExt a -> NoExt b
$cfmap :: forall a b. (a -> b) -> NoExt a -> NoExt b
Functor)

-- | Choice constructor to represent 'TreeSet'.
data Choice a = a :|: a
  deriving (Choice a -> Choice a -> Bool
(Choice a -> Choice a -> Bool)
-> (Choice a -> Choice a -> Bool) -> Eq (Choice a)
forall a. Eq a => Choice a -> Choice a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Choice a -> Choice a -> Bool
$c/= :: forall a. Eq a => Choice a -> Choice a -> Bool
== :: Choice a -> Choice a -> Bool
$c== :: forall a. Eq a => Choice a -> Choice a -> Bool
Eq, Int -> Choice a -> ShowS
[Choice a] -> ShowS
Choice a -> String
(Int -> Choice a -> ShowS)
-> (Choice a -> String) -> ([Choice a] -> ShowS) -> Show (Choice a)
forall a. Show a => Int -> Choice a -> ShowS
forall a. Show a => [Choice a] -> ShowS
forall a. Show a => Choice a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Choice a] -> ShowS
$cshowList :: forall a. Show a => [Choice a] -> ShowS
show :: Choice a -> String
$cshow :: forall a. Show a => Choice a -> String
showsPrec :: Int -> Choice a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Choice a -> ShowS
Show, a -> Choice b -> Choice a
(a -> b) -> Choice a -> Choice b
(forall a b. (a -> b) -> Choice a -> Choice b)
-> (forall a b. a -> Choice b -> Choice a) -> Functor Choice
forall a b. a -> Choice b -> Choice a
forall a b. (a -> b) -> Choice a -> Choice b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Choice b -> Choice a
$c<$ :: forall a b. a -> Choice b -> Choice a
fmap :: (a -> b) -> Choice a -> Choice b
$cfmap :: forall a b. (a -> b) -> Choice a -> Choice b
Functor)

-- | Overloaded version of @(':|:')@.
class HasChoice f where
  (.:|:) :: a -> a -> f a

instance HasChoice Choice where
  .:|: :: a -> a -> Choice a
(.:|:) = a -> a -> Choice a
forall a. a -> a -> Choice a
(:|:)

instance HasChoice (Sum f Choice) where
  a
x .:|: :: a -> a -> Sum f Choice a
.:|: a
y = Choice a -> Sum f Choice a
forall (f :: * -> *) (g :: * -> *) a. g a -> Sum f g a
InR (a
x a -> a -> Choice a
forall a. a -> a -> Choice a
:|: a
y)

-- | Construct the disjunction of two trees featuring the 'Choice' functor.
(|:) :: HasChoice f => TreeT f n t c -> TreeT f n t c -> TreeT f n t c
TreeT f n t c
u |: :: TreeT f n t c -> TreeT f n t c -> TreeT f n t c
|: TreeT f n t c
u' = f (TreeT f n t c) -> TreeT f n t c
forall (f :: * -> *) n t c. f (TreeT f n t c) -> TreeT f n t c
Ext (TreeT f n t c
u TreeT f n t c -> TreeT f n t c -> f (TreeT f n t c)
forall (f :: * -> *) a. HasChoice f => a -> a -> f a
.:|: TreeT f n t c
u')

-- | Ellided by 'truncateTree'.
data Ellipsis a = Ellipsis
  deriving (Ellipsis a -> Ellipsis a -> Bool
(Ellipsis a -> Ellipsis a -> Bool)
-> (Ellipsis a -> Ellipsis a -> Bool) -> Eq (Ellipsis a)
forall a. Ellipsis a -> Ellipsis a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ellipsis a -> Ellipsis a -> Bool
$c/= :: forall a. Ellipsis a -> Ellipsis a -> Bool
== :: Ellipsis a -> Ellipsis a -> Bool
$c== :: forall a. Ellipsis a -> Ellipsis a -> Bool
Eq, Int -> Ellipsis a -> ShowS
[Ellipsis a] -> ShowS
Ellipsis a -> String
(Int -> Ellipsis a -> ShowS)
-> (Ellipsis a -> String)
-> ([Ellipsis a] -> ShowS)
-> Show (Ellipsis a)
forall a. Int -> Ellipsis a -> ShowS
forall a. [Ellipsis a] -> ShowS
forall a. Ellipsis a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ellipsis a] -> ShowS
$cshowList :: forall a. [Ellipsis a] -> ShowS
show :: Ellipsis a -> String
$cshow :: forall a. Ellipsis a -> String
showsPrec :: Int -> Ellipsis a -> ShowS
$cshowsPrec :: forall a. Int -> Ellipsis a -> ShowS
Show, (a -> b) -> Ellipsis a -> Ellipsis b
(forall a b. (a -> b) -> Ellipsis a -> Ellipsis b)
-> (forall a b. a -> Ellipsis b -> Ellipsis a) -> Functor Ellipsis
forall a b. a -> Ellipsis b -> Ellipsis a
forall a b. (a -> b) -> Ellipsis a -> Ellipsis b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Ellipsis b -> Ellipsis a
$c<$ :: forall a b. a -> Ellipsis b -> Ellipsis a
fmap :: (a -> b) -> Ellipsis a -> Ellipsis b
$cfmap :: forall a b. (a -> b) -> Ellipsis a -> Ellipsis b
Functor)

-- | Empty tree.
ellipsis :: TreeT (Sum Ellipsis f) n t c
ellipsis :: TreeT (Sum Ellipsis f) n t c
ellipsis = Sum Ellipsis f (TreeT (Sum Ellipsis f) n t c)
-> TreeT (Sum Ellipsis f) n t c
forall (f :: * -> *) n t c. f (TreeT f n t c) -> TreeT f n t c
Ext (Ellipsis (TreeT (Sum Ellipsis f) n t c)
-> Sum Ellipsis f (TreeT (Sum Ellipsis f) n t c)
forall (f :: * -> *) (g :: * -> *) a. f a -> Sum f g a
InL Ellipsis (TreeT (Sum Ellipsis f) n t c)
forall a. Ellipsis a
Ellipsis)

-- | Like 'Data.Functor.Sum.Sum' from "Data.Functor.Sum" but with more basic instances
data Sum f g a = InL (f a) | InR (g a)
  deriving (Sum f g a -> Sum f g a -> Bool
(Sum f g a -> Sum f g a -> Bool)
-> (Sum f g a -> Sum f g a -> Bool) -> Eq (Sum f g a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) (g :: * -> *) a.
(Eq (f a), Eq (g a)) =>
Sum f g a -> Sum f g a -> Bool
/= :: Sum f g a -> Sum f g a -> Bool
$c/= :: forall (f :: * -> *) (g :: * -> *) a.
(Eq (f a), Eq (g a)) =>
Sum f g a -> Sum f g a -> Bool
== :: Sum f g a -> Sum f g a -> Bool
$c== :: forall (f :: * -> *) (g :: * -> *) a.
(Eq (f a), Eq (g a)) =>
Sum f g a -> Sum f g a -> Bool
Eq, Int -> Sum f g a -> ShowS
[Sum f g a] -> ShowS
Sum f g a -> String
(Int -> Sum f g a -> ShowS)
-> (Sum f g a -> String)
-> ([Sum f g a] -> ShowS)
-> Show (Sum f g a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
Int -> Sum f g a -> ShowS
forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
[Sum f g a] -> ShowS
forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
Sum f g a -> String
showList :: [Sum f g a] -> ShowS
$cshowList :: forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
[Sum f g a] -> ShowS
show :: Sum f g a -> String
$cshow :: forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
Sum f g a -> String
showsPrec :: Int -> Sum f g a -> ShowS
$cshowsPrec :: forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
Int -> Sum f g a -> ShowS
Show, a -> Sum f g b -> Sum f g a
(a -> b) -> Sum f g a -> Sum f g b
(forall a b. (a -> b) -> Sum f g a -> Sum f g b)
-> (forall a b. a -> Sum f g b -> Sum f g a) -> Functor (Sum f g)
forall a b. a -> Sum f g b -> Sum f g a
forall a b. (a -> b) -> Sum f g a -> Sum f g b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
a -> Sum f g b -> Sum f g a
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> Sum f g a -> Sum f g b
<$ :: a -> Sum f g b -> Sum f g a
$c<$ :: forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
a -> Sum f g b -> Sum f g a
fmap :: (a -> b) -> Sum f g a -> Sum f g b
$cfmap :: forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> Sum f g a -> Sum f g b
Functor)

infixr 1 :|:, |:

-- | Parse a chain of tokens @[c]@ into a parse tree.
-- Simplified variant of 'Little.Earley.parse'.
parseTreeSet :: (Ord n, Ord t) => Grammar n t c -> n -> [c] -> Maybe (TreeSet n t c)
parseTreeSet :: Grammar n t c -> n -> [c] -> Maybe (TreeSet n t c)
parseTreeSet Grammar n t c
g n
n = (Seq1 (Set (Item n t)), Maybe (TreeSet n t c))
-> Maybe (TreeSet n t c)
forall a b. (a, b) -> b
snd ((Seq1 (Set (Item n t)), Maybe (TreeSet n t c))
 -> Maybe (TreeSet n t c))
-> ([c] -> (Seq1 (Set (Item n t)), Maybe (TreeSet n t c)))
-> [c]
-> Maybe (TreeSet n t c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Grammar n t c
-> n -> [c] -> (Seq1 (Set (Item n t)), Maybe (TreeSet n t c))
forall n t c.
(Ord n, Ord t) =>
Grammar n t c
-> n -> [c] -> (Seq1 (Set (Item n t)), Maybe (TreeSet n t c))
parseTreeSet_ Grammar n t c
g n
n

parseTreeSet_ ::
  (Ord n, Ord t) =>
  Grammar n t c -> n -> [c] -> (Seq1 (Set (Item n t)), Maybe (TreeSet n t c))
parseTreeSet_ :: Grammar n t c
-> n -> [c] -> (Seq1 (Set (Item n t)), Maybe (TreeSet n t c))
parseTreeSet_ Grammar n t c
g n
n [c]
cs =
  let hs :: Seq1 (Set (Item n t))
hs = Grammar n t c -> n -> [c] -> Seq1 (Set (Item n t))
forall n t c.
(Ord n, Ord t) =>
Grammar n t c -> n -> [c] -> Seq1 (Set (Item n t))
preparse Grammar n t c
g n
n [c]
cs in
  (Seq1 (Set (Item n t))
hs, Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> n
-> Int
-> Int
-> Maybe (TreeSet n t c)
forall n t c.
(Ord n, Ord t) =>
Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> n
-> Int
-> Int
-> Maybe (TreeSet n t c)
growTree Grammar n t c
g ([c] -> Seq c
forall a. [a] -> Seq a
Seq.fromList [c]
cs) Seq1 (Set (Item n t))
hs n
n Int
0 (Seq1 (Set (Item n t)) -> Int
forall a. Seq1 a -> Int
endOfSeq1 Seq1 (Set (Item n t))
hs))

endOfSeq1 :: Seq1 a -> Int
endOfSeq1 :: Seq1 a -> Int
endOfSeq1 (Seq a
xs ::> a
_) = Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
xs

lookupSeq1 :: Int -> Seq1 a -> a
lookupSeq1 :: Int -> Seq1 a -> a
lookupSeq1 Int
i (Seq a
xs ::> a
x)
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
xs = a
x
  | Bool
otherwise = Seq a -> Int -> a
forall a. Seq a -> Int -> a
Seq.index Seq a
xs Int
i

growTree ::
  (Ord n, Ord t) =>
  Grammar n t c -> Seq c -> Seq1 (Set (Item n t)) -> n -> Int -> Int -> Maybe (TreeSet n t c)
growTree :: Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> n
-> Int
-> Int
-> Maybe (TreeSet n t c)
growTree Grammar n t c
g Seq c
cs Seq1 (Set (Item n t))
hs n
n Int
i0 Int
i1 =
  [TreeSet n t c] -> Maybe (TreeSet n t c)
forall n t c. [TreeSet n t c] -> Maybe (TreeSet n t c)
unionTrees (do
    Item RuleId n
ri [Atom n t]
_ Int
i' <- Seq1 (Set (Item n t)) -> n -> Int -> [Item n t]
forall n t.
(Ord n, Ord t) =>
Seq1 (Set (Item n t)) -> n -> Int -> [Item n t]
matchItems Seq1 (Set (Item n t))
hs n
n Int
i1
    Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
i' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i0)
    Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> RuleId n
-> Int
-> Int
-> [TreeSet n t c]
forall n t c.
(Ord n, Ord t) =>
Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> RuleId n
-> Int
-> Int
-> [TreeSet n t c]
growBranches Grammar n t c
g Seq c
cs Seq1 (Set (Item n t))
hs RuleId n
ri Int
i0 Int
i1)

matchItems :: (Ord n, Ord t) => Seq1 (Set (Item n t)) -> n -> Int -> [Item n t]
matchItems :: Seq1 (Set (Item n t)) -> n -> Int -> [Item n t]
matchItems Seq1 (Set (Item n t))
hs n
n Int
i1 =
  [Item n t
h | h :: Item n t
h@(Item (RuleId n
n' Int
_) [] Int
_) <- Set (Item n t) -> [Item n t]
forall a. Set a -> [a]
Set.toList (Int -> Seq1 (Set (Item n t)) -> Set (Item n t)
forall a. Int -> Seq1 a -> a
lookupSeq1 Int
i1 Seq1 (Set (Item n t))
hs), n
n' n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
n]

unionTrees :: [TreeSet n t c] -> Maybe (TreeSet n t c)
unionTrees :: [TreeSet n t c] -> Maybe (TreeSet n t c)
unionTrees (TreeSet n t c
t : [TreeSet n t c]
ts) = case [TreeSet n t c] -> Maybe (TreeSet n t c)
forall n t c. [TreeSet n t c] -> Maybe (TreeSet n t c)
unionTrees [TreeSet n t c]
ts of
  Maybe (TreeSet n t c)
Nothing -> TreeSet n t c -> Maybe (TreeSet n t c)
forall a. a -> Maybe a
Just TreeSet n t c
t
  Just TreeSet n t c
t' -> TreeSet n t c -> Maybe (TreeSet n t c)
forall a. a -> Maybe a
Just (TreeSet n t c
t TreeSet n t c -> TreeSet n t c -> TreeSet n t c
forall (f :: * -> *) n t c.
HasChoice f =>
TreeT f n t c -> TreeT f n t c -> TreeT f n t c
|: TreeSet n t c
t')
unionTrees [] = Maybe (TreeSet n t c)
forall a. Maybe a
Nothing

growBranches ::
  (Ord n, Ord t) =>
  Grammar n t c -> Seq c -> Seq1 (Set (Item n t)) -> RuleId n -> Int -> Int -> [TreeSet n t c]
growBranches :: Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> RuleId n
-> Int
-> Int
-> [TreeSet n t c]
growBranches Grammar n t c
g Seq c
cs Seq1 (Set (Item n t))
hs ri :: RuleId n
ri@(RuleId n
n Int
j) Int
i0 Int
i1 =
  RuleId n -> Int -> Int -> [TreeSet n t c] -> TreeSet n t c
forall (f :: * -> *) n t c.
RuleId n -> Int -> Int -> [TreeT f n t c] -> TreeT f n t c
Brch RuleId n
ri Int
i0 Int
i1 ([TreeSet n t c] -> TreeSet n t c)
-> [[TreeSet n t c]] -> [TreeSet n t c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> Int
-> Int
-> [Atom n t]
-> [TreeSet n t c]
-> [[TreeSet n t c]]
forall n t c.
(Ord n, Ord t) =>
Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> Int
-> Int
-> [Atom n t]
-> [TreeSet n t c]
-> [[TreeSet n t c]]
growBranchesFrom Grammar n t c
g Seq c
cs Seq1 (Set (Item n t))
hs Int
i0 Int
i1 ([Atom n t] -> [Atom n t]
forall a. [a] -> [a]
reverse (Grammar n t c -> n -> [[Atom n t]]
forall n t c. Grammar n t c -> n -> [Rule n t]
rules Grammar n t c
g n
n [[Atom n t]] -> Int -> [Atom n t]
forall a. [a] -> Int -> a
!! Int
j)) []

sortAndGroupBy :: Ord b => (a -> b) -> [a] -> [[a]]
sortAndGroupBy :: (a -> b) -> [a] -> [[a]]
sortAndGroupBy a -> b
f = (a -> a -> Bool) -> [a] -> [[a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) (b -> b -> Bool) -> (a -> b) -> a -> a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
f) ([a] -> [[a]]) -> ([a] -> [a]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> Ordering) -> [a] -> [a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((a -> b) -> a -> a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing a -> b
f)

growBranchesFrom ::
  (Ord n, Ord t) =>
  Grammar n t c -> Seq c -> Seq1 (Set (Item n t)) ->
  Int -> Int -> [Atom n t] -> [TreeSet n t c] -> [[TreeSet n t c]]
growBranchesFrom :: Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> Int
-> Int
-> [Atom n t]
-> [TreeSet n t c]
-> [[TreeSet n t c]]
growBranchesFrom Grammar n t c
_g Seq c
_cs Seq1 (Set (Item n t))
_hs Int
i0 Int
i1 [Atom n t]
_ [TreeSet n t c]
_acc | Int
i1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i0 = []
growBranchesFrom Grammar n t c
_g Seq c
_cs Seq1 (Set (Item n t))
_hs Int
i0 Int
i1 [] [TreeSet n t c]
acc
  | Int
i0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i1 = [[TreeSet n t c]
acc]
  | Bool
otherwise = []
growBranchesFrom Grammar n t c
g Seq c
cs Seq1 (Set (Item n t))
hs Int
i0 Int
i1 (T t
t : [Atom n t]
xs) [TreeSet n t c]
acc =
  Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> Int
-> Int
-> [Atom n t]
-> [TreeSet n t c]
-> [[TreeSet n t c]]
forall n t c.
(Ord n, Ord t) =>
Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> Int
-> Int
-> [Atom n t]
-> [TreeSet n t c]
-> [[TreeSet n t c]]
growBranchesFrom Grammar n t c
g Seq c
cs Seq1 (Set (Item n t))
hs Int
i0 (Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Atom n t]
xs (Int -> t -> c -> TreeSet n t c
forall (f :: * -> *) n t c. Int -> t -> c -> TreeT f n t c
Leaf (Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) t
t (Seq c -> Int -> c
forall a. Seq a -> Int -> a
Seq.index Seq c
cs (Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) TreeSet n t c -> [TreeSet n t c] -> [TreeSet n t c]
forall a. a -> [a] -> [a]
: [TreeSet n t c]
acc)
growBranchesFrom Grammar n t c
g Seq c
cs Seq1 (Set (Item n t))
hs Int
i0 Int
i1 (N n
n : [Atom n t]
xs) [TreeSet n t c]
acc = do
  let begin :: Item n t -> Int
begin (Item RuleId n
_ [Atom n t]
_ Int
i') = Int
i'
  grp :: [Item n t]
grp@(Item RuleId n
_ [Atom n t]
_ Int
i' : [Item n t]
_) <- (Item n t -> Int) -> [Item n t] -> [[Item n t]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
sortAndGroupBy Item n t -> Int
forall n t. Item n t -> Int
begin (Seq1 (Set (Item n t)) -> n -> Int -> [Item n t]
forall n t.
(Ord n, Ord t) =>
Seq1 (Set (Item n t)) -> n -> Int -> [Item n t]
matchItems Seq1 (Set (Item n t))
hs n
n Int
i1)
  -- This @u@ might be an infinite loop caused by right recursion,
  -- but it would end up being discarded in the recursive call to @growBranchesFrom@,
  -- so this is fine.
  let brch :: [TreeSet n t c]
brch = [Item n t]
grp [Item n t] -> (Item n t -> [TreeSet n t c]) -> [TreeSet n t c]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Item RuleId n
ri [Atom n t]
_ Int
_i') -> Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> RuleId n
-> Int
-> Int
-> [TreeSet n t c]
forall n t c.
(Ord n, Ord t) =>
Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> RuleId n
-> Int
-> Int
-> [TreeSet n t c]
growBranches Grammar n t c
g Seq c
cs Seq1 (Set (Item n t))
hs RuleId n
ri Int
i' Int
i1
      u :: TreeSet n t c
u = TreeSet n t c -> Maybe (TreeSet n t c) -> TreeSet n t c
forall a. a -> Maybe a -> a
fromMaybe (String -> TreeSet n t c
forall a. HasCallStack => String -> a
error String
"Should not happen") ([TreeSet n t c] -> Maybe (TreeSet n t c)
forall n t c. [TreeSet n t c] -> Maybe (TreeSet n t c)
unionTrees [TreeSet n t c]
brch)
  Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> Int
-> Int
-> [Atom n t]
-> [TreeSet n t c]
-> [[TreeSet n t c]]
forall n t c.
(Ord n, Ord t) =>
Grammar n t c
-> Seq c
-> Seq1 (Set (Item n t))
-> Int
-> Int
-> [Atom n t]
-> [TreeSet n t c]
-> [[TreeSet n t c]]
growBranchesFrom Grammar n t c
g Seq c
cs Seq1 (Set (Item n t))
hs Int
i0 Int
i' [Atom n t]
xs (TreeSet n t c
u TreeSet n t c -> [TreeSet n t c] -> [TreeSet n t c]
forall a. a -> [a] -> [a]
: [TreeSet n t c]
acc)

-- | Truncate a tree to finite depth.
--
-- @
-- 'truncateTree' :: Int -> 'TreeSet' n t c -> 'TruncatedTreeSet' n t c
-- 'truncateTree' :: Int -> 'Tree' n t c -> 'TruncatedTree' n t c
-- @
truncateTree :: Functor f => Int -> TreeT f n t c -> TreeT (Sum Ellipsis f) n t c
truncateTree :: Int -> TreeT f n t c -> TreeT (Sum Ellipsis f) n t c
truncateTree Int
0 TreeT f n t c
_ = TreeT (Sum Ellipsis f) n t c
forall (f :: * -> *) n t c. TreeT (Sum Ellipsis f) n t c
ellipsis
truncateTree Int
_ (Leaf Int
i t
t c
c) = Int -> t -> c -> TreeT (Sum Ellipsis f) n t c
forall (f :: * -> *) n t c. Int -> t -> c -> TreeT f n t c
Leaf Int
i t
t c
c
truncateTree Int
i (Brch RuleId n
n Int
i0 Int
i1 [TreeT f n t c]
us) = RuleId n
-> Int
-> Int
-> [TreeT (Sum Ellipsis f) n t c]
-> TreeT (Sum Ellipsis f) n t c
forall (f :: * -> *) n t c.
RuleId n -> Int -> Int -> [TreeT f n t c] -> TreeT f n t c
Brch RuleId n
n Int
i0 Int
i1 ((TreeT f n t c -> TreeT (Sum Ellipsis f) n t c)
-> [TreeT f n t c] -> [TreeT (Sum Ellipsis f) n t c]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> TreeT f n t c -> TreeT (Sum Ellipsis f) n t c
forall (f :: * -> *) n t c.
Functor f =>
Int -> TreeT f n t c -> TreeT (Sum Ellipsis f) n t c
truncateTree (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) [TreeT f n t c]
us)
truncateTree Int
i (Ext f (TreeT f n t c)
ext) = Sum Ellipsis f (TreeT (Sum Ellipsis f) n t c)
-> TreeT (Sum Ellipsis f) n t c
forall (f :: * -> *) n t c. f (TreeT f n t c) -> TreeT f n t c
Ext (f (TreeT (Sum Ellipsis f) n t c)
-> Sum Ellipsis f (TreeT (Sum Ellipsis f) n t c)
forall (f :: * -> *) (g :: * -> *) a. g a -> Sum f g a
InR (Int -> TreeT f n t c -> TreeT (Sum Ellipsis f) n t c
forall (f :: * -> *) n t c.
Functor f =>
Int -> TreeT f n t c -> TreeT (Sum Ellipsis f) n t c
truncateTree (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (TreeT f n t c -> TreeT (Sum Ellipsis f) n t c)
-> f (TreeT f n t c) -> f (TreeT (Sum Ellipsis f) n t c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (TreeT f n t c)
ext))

-- | Return 'Just' if the given 'TreeSet' represents a single 'Tree',
-- 'Nothing' otherwise (ambiguous parse tree).
fromSingleton :: TreeSet n t c -> Maybe (Tree n t c)
fromSingleton :: TreeSet n t c -> Maybe (Tree n t c)
fromSingleton (Leaf Int
i t
t c
c) = Tree n t c -> Maybe (Tree n t c)
forall a. a -> Maybe a
Just (Int -> t -> c -> Tree n t c
forall (f :: * -> *) n t c. Int -> t -> c -> TreeT f n t c
Leaf Int
i t
t c
c)
fromSingleton (Brch RuleId n
n Int
i0 Int
i1 [TreeSet n t c]
us) = RuleId n -> Int -> Int -> [Tree n t c] -> Tree n t c
forall (f :: * -> *) n t c.
RuleId n -> Int -> Int -> [TreeT f n t c] -> TreeT f n t c
Brch RuleId n
n Int
i0 Int
i1 ([Tree n t c] -> Tree n t c)
-> Maybe [Tree n t c] -> Maybe (Tree n t c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeSet n t c -> Maybe (Tree n t c))
-> [TreeSet n t c] -> Maybe [Tree n t c]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TreeSet n t c -> Maybe (Tree n t c)
forall n t c. TreeSet n t c -> Maybe (Tree n t c)
fromSingleton [TreeSet n t c]
us
fromSingleton (Ext (TreeSet n t c
_ :|: TreeSet n t c
_)) = Maybe (Tree n t c)
forall a. Maybe a
Nothing

-- @arbTree@: Get an arbitrary @Tree@ from a @TreeSet@.
-- This is not completely straightforward in the presence of infinitary
-- ambiguity. To ensure termination, we perform a kind of BFS; this is done
-- implicitly via the use of the @Lazy@ monad (aka. the delay monad).

data Lazy a = Now a | Later ~(Lazy a)
  deriving a -> Lazy b -> Lazy a
(a -> b) -> Lazy a -> Lazy b
(forall a b. (a -> b) -> Lazy a -> Lazy b)
-> (forall a b. a -> Lazy b -> Lazy a) -> Functor Lazy
forall a b. a -> Lazy b -> Lazy a
forall a b. (a -> b) -> Lazy a -> Lazy b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Lazy b -> Lazy a
$c<$ :: forall a b. a -> Lazy b -> Lazy a
fmap :: (a -> b) -> Lazy a -> Lazy b
$cfmap :: forall a b. (a -> b) -> Lazy a -> Lazy b
Functor

instance Applicative Lazy where
  pure :: a -> Lazy a
pure = a -> Lazy a
forall a. a -> Lazy a
Now
  liftA2 :: (a -> b -> c) -> Lazy a -> Lazy b -> Lazy c
liftA2 a -> b -> c
f (Now a
x) Lazy b
y = (b -> c) -> Lazy b -> Lazy c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> b -> c
f a
x) Lazy b
y
  liftA2 a -> b -> c
f Lazy a
x (Now b
y) = (a -> c) -> Lazy a -> Lazy c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x0 -> a -> b -> c
f a
x0 b
y) Lazy a
x
  liftA2 a -> b -> c
f (Later Lazy a
x) (Later Lazy b
y) = Lazy c -> Lazy c
forall a. Lazy a -> Lazy a
Later ((a -> b -> c) -> Lazy a -> Lazy b -> Lazy c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> b -> c
f Lazy a
x Lazy b
y)

instance Alternative Lazy where
  empty :: Lazy a
empty = Lazy a -> Lazy a
forall a. Lazy a -> Lazy a
Later Lazy a
forall (f :: * -> *) a. Alternative f => f a
empty
  Later Lazy a
x <|> :: Lazy a -> Lazy a -> Lazy a
<|> Later Lazy a
y = Lazy a -> Lazy a
forall a. Lazy a -> Lazy a
Later (Lazy a
x Lazy a -> Lazy a -> Lazy a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Lazy a
y)
  Now a
x <|> Lazy a
_ = a -> Lazy a
forall a. a -> Lazy a
Now a
x
  Lazy a
_ <|> Now a
y = a -> Lazy a
forall a. a -> Lazy a
Now a
y

forceLazy :: Lazy a -> a
forceLazy :: Lazy a -> a
forceLazy (Now a
x) = a
x
forceLazy (Later Lazy a
x) = Lazy a -> a
forall a. Lazy a -> a
forceLazy Lazy a
x

-- | Get an arbitrary @Tree@ from a @TreeSet@, even if it is ambiguous.
arbTree :: TreeSet n t c -> Tree n t c
arbTree :: TreeSet n t c -> Tree n t c
arbTree = Lazy (Tree n t c) -> Tree n t c
forall a. Lazy a -> a
forceLazy (Lazy (Tree n t c) -> Tree n t c)
-> (TreeSet n t c -> Lazy (Tree n t c))
-> TreeSet n t c
-> Tree n t c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeSet n t c -> Lazy (Tree n t c)
forall n t c. TreeSet n t c -> Lazy (Tree n t c)
arbTree_

arbTree_ :: TreeSet n t c -> Lazy (Tree n t c)
arbTree_ :: TreeSet n t c -> Lazy (Tree n t c)
arbTree_ (Leaf Int
i t
t c
c) = Tree n t c -> Lazy (Tree n t c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> t -> c -> Tree n t c
forall (f :: * -> *) n t c. Int -> t -> c -> TreeT f n t c
Leaf Int
i t
t c
c)
arbTree_ (Brch RuleId n
n Int
i0 Int
i1 [TreeSet n t c]
us) = RuleId n -> Int -> Int -> [Tree n t c] -> Tree n t c
forall (f :: * -> *) n t c.
RuleId n -> Int -> Int -> [TreeT f n t c] -> TreeT f n t c
Brch RuleId n
n Int
i0 Int
i1 ([Tree n t c] -> Tree n t c)
-> Lazy [Tree n t c] -> Lazy (Tree n t c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeSet n t c -> Lazy (Tree n t c))
-> [TreeSet n t c] -> Lazy [Tree n t c]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TreeSet n t c -> Lazy (Tree n t c)
forall n t c. TreeSet n t c -> Lazy (Tree n t c)
arbTree_ [TreeSet n t c]
us
arbTree_ (Ext (TreeSet n t c
u :|: TreeSet n t c
u')) = Lazy (Tree n t c) -> Lazy (Tree n t c)
forall a. Lazy a -> Lazy a
Later (TreeSet n t c -> Lazy (Tree n t c)
forall n t c. TreeSet n t c -> Lazy (Tree n t c)
arbTree_ TreeSet n t c
u Lazy (Tree n t c) -> Lazy (Tree n t c) -> Lazy (Tree n t c)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TreeSet n t c -> Lazy (Tree n t c)
forall n t c. TreeSet n t c -> Lazy (Tree n t c)
arbTree_ TreeSet n t c
u')

-- @ambiguities@: enumerate (some) ambiguous parses.
-- When an input is ambiguous, the ambiguity can often be minimized
-- to a relatively small fragment of the input.
-- However since a @TreeSet@ is potentially infinite, I'm not sure
-- how to find a "smallest" ambiguous subtree (containing a @Choice@ node).
-- Instead, we enumerate them all, so we can then stop the unbounded search at
-- an arbitrary point.

-- | An interval in some input sequence.
data Range = Range
  { Range -> Int
rangeLen :: Int  -- ^ Length.
  , Range -> Int
rangePos :: Int  -- ^ Starting position.
  } deriving (Range -> Range -> Bool
(Range -> Range -> Bool) -> (Range -> Range -> Bool) -> Eq Range
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Range -> Range -> Bool
$c/= :: Range -> Range -> Bool
== :: Range -> Range -> Bool
$c== :: Range -> Range -> Bool
Eq, Eq Range
Eq Range
-> (Range -> Range -> Ordering)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Bool)
-> (Range -> Range -> Range)
-> (Range -> Range -> Range)
-> Ord Range
Range -> Range -> Bool
Range -> Range -> Ordering
Range -> Range -> Range
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Range -> Range -> Range
$cmin :: Range -> Range -> Range
max :: Range -> Range -> Range
$cmax :: Range -> Range -> Range
>= :: Range -> Range -> Bool
$c>= :: Range -> Range -> Bool
> :: Range -> Range -> Bool
$c> :: Range -> Range -> Bool
<= :: Range -> Range -> Bool
$c<= :: Range -> Range -> Bool
< :: Range -> Range -> Bool
$c< :: Range -> Range -> Bool
compare :: Range -> Range -> Ordering
$ccompare :: Range -> Range -> Ordering
$cp1Ord :: Eq Range
Ord, Int -> Range -> ShowS
[Range] -> ShowS
Range -> String
(Int -> Range -> ShowS)
-> (Range -> String) -> ([Range] -> ShowS) -> Show Range
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Range] -> ShowS
$cshowList :: [Range] -> ShowS
show :: Range -> String
$cshow :: Range -> String
showsPrec :: Int -> Range -> ShowS
$cshowsPrec :: Int -> Range -> ShowS
Show)

-- | Construt a range from its end points.
mkRange :: Int -> Int -> Range
mkRange :: Int -> Int -> Range
mkRange Int
i0 Int
i1 = Int -> Int -> Range
Range (Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i0) Int
i0

treeRange :: Tree n t c -> Range
treeRange :: Tree n t c -> Range
treeRange Tree n t c
t = Int -> Int -> Range
mkRange (Tree n t c -> Int
forall n t c. Tree n t c -> Int
leftEnd Tree n t c
t) (Tree n t c -> Int
forall n t c. Tree n t c -> Int
rightEnd Tree n t c
t)

leftEnd, rightEnd :: Tree n t c -> Int
leftEnd :: Tree n t c -> Int
leftEnd (Leaf Int
i t
_ c
_) = Int
i
leftEnd (Brch RuleId n
_ Int
i0 Int
_i1 [Tree n t c]
_) = Int
i0

rightEnd :: Tree n t c -> Int
rightEnd (Leaf Int
i t
_ c
_) = Int
i
rightEnd (Brch RuleId n
_ Int
_i0 Int
i1 [Tree n t c]
_) = Int
i1

-- | Evidence of ambiguity: two parse trees for the same input.
data Ambiguity n t c = Ambiguity (Tree n t c) (Tree n t c)
  deriving (Int -> Ambiguity n t c -> ShowS
[Ambiguity n t c] -> ShowS
Ambiguity n t c -> String
(Int -> Ambiguity n t c -> ShowS)
-> (Ambiguity n t c -> String)
-> ([Ambiguity n t c] -> ShowS)
-> Show (Ambiguity n t c)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall n t c.
(Show n, Show t, Show c) =>
Int -> Ambiguity n t c -> ShowS
forall n t c.
(Show n, Show t, Show c) =>
[Ambiguity n t c] -> ShowS
forall n t c. (Show n, Show t, Show c) => Ambiguity n t c -> String
showList :: [Ambiguity n t c] -> ShowS
$cshowList :: forall n t c.
(Show n, Show t, Show c) =>
[Ambiguity n t c] -> ShowS
show :: Ambiguity n t c -> String
$cshow :: forall n t c. (Show n, Show t, Show c) => Ambiguity n t c -> String
showsPrec :: Int -> Ambiguity n t c -> ShowS
$cshowsPrec :: forall n t c.
(Show n, Show t, Show c) =>
Int -> Ambiguity n t c -> ShowS
Show)

-- | This instance treats @Ambiguity@ as an unordered pair.
instance (Eq n, Eq t, Eq c) => Eq (Ambiguity n t c) where
  Ambiguity Tree n t c
x1 Tree n t c
x2 == :: Ambiguity n t c -> Ambiguity n t c -> Bool
== Ambiguity Tree n t c
y1 Tree n t c
y2 =
    (Tree n t c
x1, Tree n t c
x2) (Tree n t c, Tree n t c) -> (Tree n t c, Tree n t c) -> Bool
forall a. Eq a => a -> a -> Bool
== (Tree n t c
y1, Tree n t c
y2) Bool -> Bool -> Bool
|| (Tree n t c
x1, Tree n t c
x2) (Tree n t c, Tree n t c) -> (Tree n t c, Tree n t c) -> Bool
forall a. Eq a => a -> a -> Bool
== (Tree n t c
y2, Tree n t c
y1)

-- | Ambiguity at a given location.
type LocAmbiguity n t c = (Range, Ambiguity n t c)

-- | Interleave two lists together.
-- This combines enumerations somewhat fairly.
(><) :: [a] -> [a] -> [a]
(a
x : [a]
xs) >< :: [a] -> [a] -> [a]
>< [a]
ys = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: ([a]
ys [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
>< [a]
xs)
[] >< [a]
ys = [a]
ys

-- | Enumerate (some) ambiguous parses.
--
-- If there are multiple ambiguities at the same location, we just pick
-- an arbitrary example.
ambiguities :: TreeSet n t c -> [LocAmbiguity n t c]
ambiguities :: TreeSet n t c -> [LocAmbiguity n t c]
ambiguities (Leaf Int
_ t
_ c
_) = []
ambiguities (Brch RuleId n
_ Int
_ Int
_ [TreeSet n t c]
us) = [TreeSet n t c] -> [LocAmbiguity n t c]
forall n t c. [TreeSet n t c] -> [LocAmbiguity n t c]
go [TreeSet n t c]
us where
  go :: [TreeSet n t c] -> [LocAmbiguity n t c]
go [] = []
  go (TreeSet n t c
u : [TreeSet n t c]
us1) = TreeSet n t c -> [LocAmbiguity n t c]
forall n t c. TreeSet n t c -> [LocAmbiguity n t c]
ambiguities TreeSet n t c
u [LocAmbiguity n t c]
-> [LocAmbiguity n t c] -> [LocAmbiguity n t c]
forall a. [a] -> [a] -> [a]
>< [TreeSet n t c] -> [LocAmbiguity n t c]
go [TreeSet n t c]
us1
ambiguities (Ext (TreeSet n t c
u :|: TreeSet n t c
u')) =
  let au :: Tree n t c
au = TreeSet n t c -> Tree n t c
forall n t c. TreeSet n t c -> Tree n t c
arbTree TreeSet n t c
u
      ambig :: LocAmbiguity n t c
ambig = (Tree n t c -> Range
forall n t c. Tree n t c -> Range
treeRange Tree n t c
au, Tree n t c -> Tree n t c -> Ambiguity n t c
forall n t c. Tree n t c -> Tree n t c -> Ambiguity n t c
Ambiguity Tree n t c
au (TreeSet n t c -> Tree n t c
forall n t c. TreeSet n t c -> Tree n t c
arbTree TreeSet n t c
u')) in
  LocAmbiguity n t c
ambig LocAmbiguity n t c -> [LocAmbiguity n t c] -> [LocAmbiguity n t c]
forall a. a -> [a] -> [a]
: (TreeSet n t c -> [LocAmbiguity n t c]
forall n t c. TreeSet n t c -> [LocAmbiguity n t c]
ambiguities' TreeSet n t c
u [LocAmbiguity n t c]
-> [LocAmbiguity n t c] -> [LocAmbiguity n t c]
forall a. [a] -> [a] -> [a]
>< TreeSet n t c -> [LocAmbiguity n t c]
forall n t c. TreeSet n t c -> [LocAmbiguity n t c]
ambiguities' TreeSet n t c
u')

-- Skip ambiguities at the same location.
ambiguities' :: TreeSet n t c -> [LocAmbiguity n t c]
ambiguities' :: TreeSet n t c -> [LocAmbiguity n t c]
ambiguities' (Ext (TreeSet n t c
u :|: TreeSet n t c
u')) = TreeSet n t c -> [LocAmbiguity n t c]
forall n t c. TreeSet n t c -> [LocAmbiguity n t c]
ambiguities' TreeSet n t c
u [LocAmbiguity n t c]
-> [LocAmbiguity n t c] -> [LocAmbiguity n t c]
forall a. [a] -> [a] -> [a]
>< TreeSet n t c -> [LocAmbiguity n t c]
forall n t c. TreeSet n t c -> [LocAmbiguity n t c]
ambiguities' TreeSet n t c
u'
ambiguities' TreeSet n t c
u = TreeSet n t c -> [LocAmbiguity n t c]
forall n t c. TreeSet n t c -> [LocAmbiguity n t c]
ambiguities TreeSet n t c
u