module Text.Grampa.Internal (BinTree(..), FailureInfo(..), ResultList(..), ResultsOfLength(..), fromResultList) where

import Data.Foldable (toList)
import Data.Functor.Classes (Show1(..))
import Data.List.NonEmpty (NonEmpty)
import Data.List (nub)
import Data.Monoid (Monoid(mappend, mempty))
import Data.Semigroup (Semigroup((<>)))

import Data.Monoid.Factorial (FactorialMonoid, length)

import Text.Grampa.Class (ParseFailure(..), ParseResults)

import Prelude hiding (length, showList)

data FailureInfo = FailureInfo Int [String] deriving (FailureInfo -> FailureInfo -> Bool
(FailureInfo -> FailureInfo -> Bool)
-> (FailureInfo -> FailureInfo -> Bool) -> Eq FailureInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailureInfo -> FailureInfo -> Bool
$c/= :: FailureInfo -> FailureInfo -> Bool
== :: FailureInfo -> FailureInfo -> Bool
$c== :: FailureInfo -> FailureInfo -> Bool
Eq, Int -> FailureInfo -> ShowS
[FailureInfo] -> ShowS
FailureInfo -> String
(Int -> FailureInfo -> ShowS)
-> (FailureInfo -> String)
-> ([FailureInfo] -> ShowS)
-> Show FailureInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureInfo] -> ShowS
$cshowList :: [FailureInfo] -> ShowS
show :: FailureInfo -> String
$cshow :: FailureInfo -> String
showsPrec :: Int -> FailureInfo -> ShowS
$cshowsPrec :: Int -> FailureInfo -> ShowS
Show)

data ResultsOfLength g s r = ResultsOfLength !Int ![(s, g (ResultList g s))] !(NonEmpty r)

data ResultList g s r = ResultList ![ResultsOfLength g s r] !FailureInfo

data BinTree a = Fork !(BinTree a) !(BinTree a)
               | Leaf !a
               | EmptyTree
               deriving (Int -> BinTree a -> ShowS
[BinTree a] -> ShowS
BinTree a -> String
(Int -> BinTree a -> ShowS)
-> (BinTree a -> String)
-> ([BinTree a] -> ShowS)
-> Show (BinTree a)
forall a. Show a => Int -> BinTree a -> ShowS
forall a. Show a => [BinTree a] -> ShowS
forall a. Show a => BinTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BinTree a] -> ShowS
$cshowList :: forall a. Show a => [BinTree a] -> ShowS
show :: BinTree a -> String
$cshow :: forall a. Show a => BinTree a -> String
showsPrec :: Int -> BinTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BinTree a -> ShowS
Show)

fromResultList :: FactorialMonoid s => s -> ResultList g s r -> ParseResults [(s, r)]
fromResultList :: s -> ResultList g s r -> ParseResults [(s, r)]
fromResultList s :: s
s (ResultList [] (FailureInfo pos :: Int
pos msgs :: [String]
msgs)) =
   ParseFailure -> ParseResults [(s, r)]
forall a b. a -> Either a b
Left (Int -> [String] -> ParseFailure
ParseFailure (s -> Int
forall m. Factorial m => m -> Int
length s
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ([String] -> [String]
forall a. Eq a => [a] -> [a]
nub [String]
msgs))
fromResultList _ (ResultList rl :: [ResultsOfLength g s r]
rl _failure :: FailureInfo
_failure) = [(s, r)] -> ParseResults [(s, r)]
forall a b. b -> Either a b
Right ((ResultsOfLength g s r -> [(s, r)])
-> [ResultsOfLength g s r] -> [(s, r)]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ResultsOfLength g s r -> [(s, r)]
forall a (g :: (* -> *) -> *) b.
Monoid a =>
ResultsOfLength g a b -> [(a, b)]
f [ResultsOfLength g s r]
rl)
   where f :: ResultsOfLength g a b -> [(a, b)]
f (ResultsOfLength _ ((s :: a
s, _):_) r :: NonEmpty b
r) = (,) a
s (b -> (a, b)) -> [b] -> [(a, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty b -> [b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty b
r
         f (ResultsOfLength _ [] r :: NonEmpty b
r) = (,) a
forall a. Monoid a => a
mempty (b -> (a, b)) -> [b] -> [(a, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty b -> [b]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty b
r
{-# INLINABLE fromResultList #-}

instance Semigroup FailureInfo where
   FailureInfo pos1 :: Int
pos1 exp1 :: [String]
exp1 <> :: FailureInfo -> FailureInfo -> FailureInfo
<> FailureInfo pos2 :: Int
pos2 exp2 :: [String]
exp2 = Int -> [String] -> FailureInfo
FailureInfo Int
pos' [String]
exp'
      where (pos' :: Int
pos', exp' :: [String]
exp') | Int
pos1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
pos2 = (Int
pos1, [String]
exp1)
                         | Int
pos1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pos2 = (Int
pos2, [String]
exp2)
                         | Bool
otherwise = (Int
pos1, [String] -> [String] -> [String]
forall a. Ord a => [a] -> [a] -> [a]
merge [String]
exp1 [String]
exp2)
            merge :: [a] -> [a] -> [a]
merge [] exps :: [a]
exps = [a]
exps
            merge exps :: [a]
exps [] = [a]
exps
            merge xs :: [a]
xs@(x :: a
x:xs' :: [a]
xs') ys :: [a]
ys@(y :: a
y:ys' :: [a]
ys')
               | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
merge [a]
xs' [a]
ys
               | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
y = a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
merge [a]
xs [a]
ys'
               | Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
merge [a]
xs' [a]
ys'

instance Monoid FailureInfo where
   mempty :: FailureInfo
mempty = Int -> [String] -> FailureInfo
FailureInfo Int
forall a. Bounded a => a
maxBound []
   mappend :: FailureInfo -> FailureInfo -> FailureInfo
mappend = FailureInfo -> FailureInfo -> FailureInfo
forall a. Semigroup a => a -> a -> a
(<>)

instance Show r => Show (ResultList g s r) where
   show :: ResultList g s r -> String
show (ResultList l :: [ResultsOfLength g s r]
l f :: FailureInfo
f) = "ResultList (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [ResultsOfLength g s r] -> ShowS
forall a. Show a => a -> ShowS
shows [ResultsOfLength g s r]
l (") (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ FailureInfo -> ShowS
forall a. Show a => a -> ShowS
shows FailureInfo
f ")")

instance Show1 (ResultList g s) where
   liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> ResultList g s a -> ShowS
liftShowsPrec _sp :: Int -> a -> ShowS
_sp showList :: [a] -> ShowS
showList _prec :: Int
_prec (ResultList rol :: [ResultsOfLength g s a]
rol f :: FailureInfo
f) rest :: String
rest = 
      "ResultList " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> ShowS
forall a. Show a => a -> ShowS
shows (ResultsOfLength g s a -> String
forall (g :: (* -> *) -> *) s. ResultsOfLength g s a -> String
simplify (ResultsOfLength g s a -> String)
-> [ResultsOfLength g s a] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ResultsOfLength g s a] -> [ResultsOfLength g s a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [ResultsOfLength g s a]
rol) (FailureInfo -> ShowS
forall a. Show a => a -> ShowS
shows FailureInfo
f String
rest)
      where simplify :: ResultsOfLength g s a -> String
simplify (ResultsOfLength l :: Int
l _ r :: NonEmpty a
r) = "ResultsOfLength " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
l String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " _ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [a] -> ShowS
showList (NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty a
r) ""

instance Show r => Show (ResultsOfLength g s r) where
   show :: ResultsOfLength g s r -> String
show (ResultsOfLength l :: Int
l _ r :: NonEmpty r
r) = "(ResultsOfLength @" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonEmpty r -> ShowS
forall a. Show a => a -> ShowS
shows NonEmpty r
r ")"

instance Functor (ResultsOfLength g s) where
   fmap :: (a -> b) -> ResultsOfLength g s a -> ResultsOfLength g s b
fmap f :: a -> b
f (ResultsOfLength l :: Int
l t :: [(s, g (ResultList g s))]
t r :: NonEmpty a
r) = Int
-> [(s, g (ResultList g s))] -> NonEmpty b -> ResultsOfLength g s b
forall (g :: (* -> *) -> *) s r.
Int
-> [(s, g (ResultList g s))] -> NonEmpty r -> ResultsOfLength g s r
ResultsOfLength Int
l [(s, g (ResultList g s))]
t (a -> b
f (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty a
r)
   {-# INLINE fmap #-}

instance Functor (ResultList g s) where
   fmap :: (a -> b) -> ResultList g s a -> ResultList g s b
fmap f :: a -> b
f (ResultList l :: [ResultsOfLength g s a]
l failure :: FailureInfo
failure) = [ResultsOfLength g s b] -> FailureInfo -> ResultList g s b
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo -> ResultList g s r
ResultList ((a -> b
f (a -> b) -> ResultsOfLength g s a -> ResultsOfLength g s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ResultsOfLength g s a -> ResultsOfLength g s b)
-> [ResultsOfLength g s a] -> [ResultsOfLength g s b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ResultsOfLength g s a]
l) FailureInfo
failure
   {-# INLINE fmap #-}

instance Semigroup (ResultList g s r) where
   ResultList rl1 :: [ResultsOfLength g s r]
rl1 f1 :: FailureInfo
f1 <> :: ResultList g s r -> ResultList g s r -> ResultList g s r
<> ResultList rl2 :: [ResultsOfLength g s r]
rl2 f2 :: FailureInfo
f2 = [ResultsOfLength g s r] -> FailureInfo -> ResultList g s r
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo -> ResultList g s r
ResultList ([ResultsOfLength g s r]
-> [ResultsOfLength g s r] -> [ResultsOfLength g s r]
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r]
-> [ResultsOfLength g s r] -> [ResultsOfLength g s r]
join [ResultsOfLength g s r]
rl1 [ResultsOfLength g s r]
rl2) (FailureInfo
f1 FailureInfo -> FailureInfo -> FailureInfo
forall a. Semigroup a => a -> a -> a
<> FailureInfo
f2)
      where join :: [ResultsOfLength g s r]
-> [ResultsOfLength g s r] -> [ResultsOfLength g s r]
join [] rl :: [ResultsOfLength g s r]
rl = [ResultsOfLength g s r]
rl
            join rl :: [ResultsOfLength g s r]
rl [] = [ResultsOfLength g s r]
rl
            join rl1' :: [ResultsOfLength g s r]
rl1'@(rol1 :: ResultsOfLength g s r
rol1@(ResultsOfLength l1 :: Int
l1 s1 :: [(s, g (ResultList g s))]
s1 r1 :: NonEmpty r
r1) : rest1 :: [ResultsOfLength g s r]
rest1) rl2' :: [ResultsOfLength g s r]
rl2'@(rol2 :: ResultsOfLength g s r
rol2@(ResultsOfLength l2 :: Int
l2 _ r2 :: NonEmpty r
r2) : rest2 :: [ResultsOfLength g s r]
rest2)
               | Int
l1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l2 = ResultsOfLength g s r
rol1 ResultsOfLength g s r
-> [ResultsOfLength g s r] -> [ResultsOfLength g s r]
forall a. a -> [a] -> [a]
: [ResultsOfLength g s r]
-> [ResultsOfLength g s r] -> [ResultsOfLength g s r]
join [ResultsOfLength g s r]
rest1 [ResultsOfLength g s r]
rl2'
               | Int
l1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
l2 = ResultsOfLength g s r
rol2 ResultsOfLength g s r
-> [ResultsOfLength g s r] -> [ResultsOfLength g s r]
forall a. a -> [a] -> [a]
: [ResultsOfLength g s r]
-> [ResultsOfLength g s r] -> [ResultsOfLength g s r]
join [ResultsOfLength g s r]
rl1' [ResultsOfLength g s r]
rest2
               | Bool
otherwise = Int
-> [(s, g (ResultList g s))] -> NonEmpty r -> ResultsOfLength g s r
forall (g :: (* -> *) -> *) s r.
Int
-> [(s, g (ResultList g s))] -> NonEmpty r -> ResultsOfLength g s r
ResultsOfLength Int
l1 [(s, g (ResultList g s))]
s1 (NonEmpty r
r1 NonEmpty r -> NonEmpty r -> NonEmpty r
forall a. Semigroup a => a -> a -> a
<> NonEmpty r
r2) ResultsOfLength g s r
-> [ResultsOfLength g s r] -> [ResultsOfLength g s r]
forall a. a -> [a] -> [a]
: [ResultsOfLength g s r]
-> [ResultsOfLength g s r] -> [ResultsOfLength g s r]
join [ResultsOfLength g s r]
rest1 [ResultsOfLength g s r]
rest2

instance Monoid (ResultList g s r) where
   mempty :: ResultList g s r
mempty = [ResultsOfLength g s r] -> FailureInfo -> ResultList g s r
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo -> ResultList g s r
ResultList [ResultsOfLength g s r]
forall a. Monoid a => a
mempty FailureInfo
forall a. Monoid a => a
mempty
   mappend :: ResultList g s r -> ResultList g s r -> ResultList g s r
mappend = ResultList g s r -> ResultList g s r -> ResultList g s r
forall a. Semigroup a => a -> a -> a
(<>)

instance Functor BinTree where
   fmap :: (a -> b) -> BinTree a -> BinTree b
fmap f :: a -> b
f (Fork left :: BinTree a
left right :: BinTree a
right) = BinTree b -> BinTree b -> BinTree b
forall a. BinTree a -> BinTree a -> BinTree a
Fork ((a -> b) -> BinTree a -> BinTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f BinTree a
left) ((a -> b) -> BinTree a -> BinTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f BinTree a
right)
   fmap f :: a -> b
f (Leaf a :: a
a) = b -> BinTree b
forall a. a -> BinTree a
Leaf (a -> b
f a
a)
   fmap _ EmptyTree = BinTree b
forall a. BinTree a
EmptyTree

instance Foldable BinTree where
   foldMap :: (a -> m) -> BinTree a -> m
foldMap f :: a -> m
f (Fork left :: BinTree a
left right :: BinTree a
right) = (a -> m) -> BinTree a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f BinTree a
left m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` (a -> m) -> BinTree a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f BinTree a
right
   foldMap f :: a -> m
f (Leaf a :: a
a) = a -> m
f a
a
   foldMap _ EmptyTree = m
forall a. Monoid a => a
mempty

instance Semigroup (BinTree a) where
   EmptyTree <> :: BinTree a -> BinTree a -> BinTree a
<> t :: BinTree a
t = BinTree a
t
   t :: BinTree a
t <> EmptyTree = BinTree a
t
   l :: BinTree a
l <> r :: BinTree a
r = BinTree a -> BinTree a -> BinTree a
forall a. BinTree a -> BinTree a -> BinTree a
Fork BinTree a
l BinTree a
r

instance Monoid (BinTree a) where
   mempty :: BinTree a
mempty = BinTree a
forall a. BinTree a
EmptyTree
   mappend :: BinTree a -> BinTree a -> BinTree a
mappend = BinTree a -> BinTree a -> BinTree a
forall a. Semigroup a => a -> a -> a
(<>)