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 (<>)