{-# 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
data TreeT f n t c
= Leaf Int t c
| Brch (RuleId n) Int Int [TreeT f n t c]
| 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)
type Tree = TreeT NoExt
type TreeSet = TreeT Choice
type TruncatedTree = TreeT (Sum Ellipsis NoExt)
type TruncatedTreeSet = TreeT (Sum Ellipsis Choice)
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)
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)
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)
(|:) :: 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')
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)
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)
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 :|:, |:
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)
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)
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))
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
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
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')
data Range = Range
{ Range -> Int
rangeLen :: Int
, Range -> Int
rangePos :: Int
} 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)
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
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)
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)
type LocAmbiguity n t c = (Range, Ambiguity n t c)
(><) :: [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
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')
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