{-# LANGUAGE ConstrainedClassMethods, FlexibleContexts, FlexibleInstances, GADTs, RankNTypes, TypeOperators #-}

module Text.Grampa.Internal (BinTree(..), FailureInfo(..), ResultList(..), ResultsOfLength(..), FallibleResults(..),
                             AmbiguousAlternative(..), AmbiguityDecidable(..), AmbiguityWitness(..),
                             TraceableParsing(..),
                             fromResultList, noFailure) where

import Control.Applicative (Applicative(..), Alternative(..))
import Data.Foldable (toList)
import Data.Functor.Classes (Show1(..))
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.List (nub)
import Data.Monoid (Monoid(mappend, mempty))
import Data.Semigroup (Semigroup((<>)))
import Data.Type.Equality ((:~:)(Refl))
import Witherable (Filterable(mapMaybe))

import Data.Monoid.Factorial (FactorialMonoid, length)

import Text.Grampa.Class (Ambiguous(..), Expected(..), ParseFailure(..), ParseResults, InputParsing(..))

import Prelude hiding (length, showList)

data FailureInfo s = FailureInfo Int [Expected s] deriving (FailureInfo s -> FailureInfo s -> Bool
(FailureInfo s -> FailureInfo s -> Bool)
-> (FailureInfo s -> FailureInfo s -> Bool) -> Eq (FailureInfo s)
forall s. Eq s => FailureInfo s -> FailureInfo s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FailureInfo s -> FailureInfo s -> Bool
$c/= :: forall s. Eq s => FailureInfo s -> FailureInfo s -> Bool
== :: FailureInfo s -> FailureInfo s -> Bool
$c== :: forall s. Eq s => FailureInfo s -> FailureInfo s -> Bool
Eq, Int -> FailureInfo s -> ShowS
[FailureInfo s] -> ShowS
FailureInfo s -> String
(Int -> FailureInfo s -> ShowS)
-> (FailureInfo s -> String)
-> ([FailureInfo s] -> ShowS)
-> Show (FailureInfo s)
forall s. Show s => Int -> FailureInfo s -> ShowS
forall s. Show s => [FailureInfo s] -> ShowS
forall s. Show s => FailureInfo s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureInfo s] -> ShowS
$cshowList :: forall s. Show s => [FailureInfo s] -> ShowS
show :: FailureInfo s -> String
$cshow :: forall s. Show s => FailureInfo s -> String
showsPrec :: Int -> FailureInfo s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> FailureInfo s -> 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 s)

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)

data AmbiguityWitness a where
   AmbiguityWitness :: (a :~: Ambiguous b) -> AmbiguityWitness a

class AmbiguityDecidable a where
   ambiguityWitness :: Maybe (AmbiguityWitness a)

instance {-# overlappable #-} AmbiguityDecidable a where
   ambiguityWitness :: Maybe (AmbiguityWitness a)
ambiguityWitness = Maybe (AmbiguityWitness a)
forall a. Maybe a
Nothing

instance AmbiguityDecidable (Ambiguous a) where
   ambiguityWitness :: Maybe (AmbiguityWitness (Ambiguous a))
ambiguityWitness = AmbiguityWitness (Ambiguous a)
-> Maybe (AmbiguityWitness (Ambiguous a))
forall a. a -> Maybe a
Just ((Ambiguous a :~: Ambiguous a) -> AmbiguityWitness (Ambiguous a)
forall a b. (a :~: Ambiguous b) -> AmbiguityWitness a
AmbiguityWitness Ambiguous a :~: Ambiguous a
forall k (a :: k). a :~: a
Refl)

fromResultList :: (Eq s, FactorialMonoid s) => s -> ResultList g s r -> ParseResults s [(s, r)]
fromResultList :: s -> ResultList g s r -> ParseResults s [(s, r)]
fromResultList s
s (ResultList [] (FailureInfo Int
pos [Expected s]
msgs)) =
   ParseFailure s -> ParseResults s [(s, r)]
forall a b. a -> Either a b
Left (Int -> [Expected s] -> ParseFailure s
forall s. Int -> [Expected s] -> ParseFailure s
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
+ Int
1) ([Expected s] -> [Expected s]
forall a. Eq a => [a] -> [a]
nub [Expected s]
msgs))
fromResultList s
_ (ResultList [ResultsOfLength g s r]
rl FailureInfo s
_failure) = [(s, r)] -> ParseResults s [(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 Int
_ ((a
s, g (ResultList g a)
_):[(a, g (ResultList g a))]
_) 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 Int
_ [] 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 #-}

noFailure :: FailureInfo s
noFailure :: FailureInfo s
noFailure = Int -> [Expected s] -> FailureInfo s
forall s. Int -> [Expected s] -> FailureInfo s
FailureInfo Int
forall a. Bounded a => a
maxBound []

instance Semigroup (FailureInfo s) where
   FailureInfo Int
pos1 [Expected s]
exp1 <> :: FailureInfo s -> FailureInfo s -> FailureInfo s
<> FailureInfo Int
pos2 [Expected s]
exp2 = Int -> [Expected s] -> FailureInfo s
forall s. Int -> [Expected s] -> FailureInfo s
FailureInfo Int
pos' [Expected s]
exp'
      where (Int
pos', [Expected s]
exp') | Int
pos1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
pos2 = (Int
pos1, [Expected s]
exp1)
                         | Int
pos1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
pos2 = (Int
pos2, [Expected s]
exp2)
                         | Bool
otherwise = (Int
pos1, [Expected s]
exp1 [Expected s] -> [Expected s] -> [Expected s]
forall a. Semigroup a => a -> a -> a
<> [Expected s]
exp2)

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

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

instance Show s => Show1 (ResultList g s) where
   liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> ResultList g s a -> ShowS
liftShowsPrec Int -> a -> ShowS
_sp [a] -> ShowS
showList Int
_prec (ResultList [ResultsOfLength g s a]
rol FailureInfo s
f) String
rest = 
      String
"ResultList " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> ShowS
forall a. Show a => a -> ShowS
shows (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 s -> ShowS
forall a. Show a => a -> ShowS
shows FailureInfo s
f String
rest)
      where simplify :: ResultsOfLength g s a -> String
simplify (ResultsOfLength Int
l [(s, g (ResultList g s))]
_ NonEmpty a
r) = String
"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
" _ " 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) String
""

instance Show r => Show (ResultsOfLength g s r) where
   show :: ResultsOfLength g s r -> String
show (ResultsOfLength Int
l [(s, g (ResultList g s))]
_ NonEmpty r
r) = String
"(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
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ NonEmpty r -> ShowS
forall a. Show a => a -> ShowS
shows NonEmpty r
r String
")"

instance Functor (ResultsOfLength g s) where
   fmap :: (a -> b) -> ResultsOfLength g s a -> ResultsOfLength g s b
fmap a -> b
f (ResultsOfLength Int
l [(s, g (ResultList g s))]
t 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 a -> b
f (ResultList [ResultsOfLength g s a]
l FailureInfo s
failure) = [ResultsOfLength g s b] -> FailureInfo s -> ResultList g s b
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo s -> 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 s
failure
   {-# INLINE fmap #-}

instance Applicative (ResultsOfLength g s) where
   pure :: a -> ResultsOfLength g s a
pure = Int
-> [(s, g (ResultList g s))] -> NonEmpty a -> ResultsOfLength g s a
forall (g :: (* -> *) -> *) s r.
Int
-> [(s, g (ResultList g s))] -> NonEmpty r -> ResultsOfLength g s r
ResultsOfLength Int
0 [(s, g (ResultList g s))]
forall a. Monoid a => a
mempty (NonEmpty a -> ResultsOfLength g s a)
-> (a -> NonEmpty a) -> a -> ResultsOfLength g s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
   ResultsOfLength Int
l1 [(s, g (ResultList g s))]
_ NonEmpty (a -> b)
fs <*> :: ResultsOfLength g s (a -> b)
-> ResultsOfLength g s a -> ResultsOfLength g s b
<*> ResultsOfLength Int
l2 [(s, g (ResultList g s))]
t2 NonEmpty a
xs = 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
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l2) [(s, g (ResultList g s))]
t2 (NonEmpty (a -> b)
fs NonEmpty (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NonEmpty a
xs)

instance Applicative (ResultList g s) where
   pure :: a -> ResultList g s a
pure a
a = [ResultsOfLength g s a] -> FailureInfo s -> ResultList g s a
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo s -> ResultList g s r
ResultList [a -> ResultsOfLength g s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a] FailureInfo s
forall a. Monoid a => a
mempty
   ResultList [ResultsOfLength g s (a -> b)]
rl1 FailureInfo s
f1 <*> :: ResultList g s (a -> b) -> ResultList g s a -> ResultList g s b
<*> ResultList [ResultsOfLength g s a]
rl2 FailureInfo s
f2 = [ResultsOfLength g s b] -> FailureInfo s -> ResultList g s b
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo s -> ResultList g s r
ResultList (ResultsOfLength g s (a -> b)
-> ResultsOfLength g s a -> ResultsOfLength g s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (ResultsOfLength g s (a -> b)
 -> ResultsOfLength g s a -> ResultsOfLength g s b)
-> [ResultsOfLength g s (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 -> b)]
rl1 [ResultsOfLength g s a -> ResultsOfLength g s b]
-> [ResultsOfLength g s a] -> [ResultsOfLength g s b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [ResultsOfLength g s a]
rl2) (FailureInfo s
f1 FailureInfo s -> FailureInfo s -> FailureInfo s
forall a. Semigroup a => a -> a -> a
<> FailureInfo s
f2)

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

instance Filterable (ResultList g s) where
   mapMaybe :: (a -> Maybe b) -> ResultList g s a -> ResultList g s b
mapMaybe a -> Maybe b
f (ResultList [ResultsOfLength g s a]
l FailureInfo s
failure) = [ResultsOfLength g s b] -> FailureInfo s -> ResultList g s b
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo s -> ResultList g s r
ResultList ((ResultsOfLength g s a -> Maybe (ResultsOfLength g s b))
-> [ResultsOfLength g s a] -> [ResultsOfLength g s b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe ResultsOfLength g s a -> Maybe (ResultsOfLength g s b)
maybeROL [ResultsOfLength g s a]
l) FailureInfo s
failure
      where maybeROL :: ResultsOfLength g s a -> Maybe (ResultsOfLength g s b)
maybeROL (ResultsOfLength Int
l [(s, g (ResultList g s))]
t NonEmpty a
rs) = 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 (NonEmpty b -> ResultsOfLength g s b)
-> Maybe (NonEmpty b) -> Maybe (ResultsOfLength g s b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [b] -> Maybe (NonEmpty b)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe a -> Maybe b
f ([a] -> [b]) -> [a] -> [b]
forall a b. (a -> b) -> a -> b
$ NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty a
rs)
   {-# INLINE mapMaybe #-}

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

instance AmbiguousAlternative (ResultList g s) where
   ambiguousOr :: ResultList g s (Ambiguous a)
-> ResultList g s (Ambiguous a) -> ResultList g s (Ambiguous a)
ambiguousOr (ResultList [ResultsOfLength g s (Ambiguous a)]
rl1 FailureInfo s
f1) (ResultList [ResultsOfLength g s (Ambiguous a)]
rl2 FailureInfo s
f2) = [ResultsOfLength g s (Ambiguous a)]
-> FailureInfo s -> ResultList g s (Ambiguous a)
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo s -> ResultList g s r
ResultList ([ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
forall (g :: (* -> *) -> *) s a.
[ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
merge [ResultsOfLength g s (Ambiguous a)]
rl1 [ResultsOfLength g s (Ambiguous a)]
rl2) (FailureInfo s
f1 FailureInfo s -> FailureInfo s -> FailureInfo s
forall a. Semigroup a => a -> a -> a
<> FailureInfo s
f2)
      where merge :: [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
merge [] [ResultsOfLength g s (Ambiguous a)]
rl = [ResultsOfLength g s (Ambiguous a)]
rl
            merge [ResultsOfLength g s (Ambiguous a)]
rl [] = [ResultsOfLength g s (Ambiguous a)]
rl
            merge rl1' :: [ResultsOfLength g s (Ambiguous a)]
rl1'@(rol1 :: ResultsOfLength g s (Ambiguous a)
rol1@(ResultsOfLength Int
l1 [(s, g (ResultList g s))]
s1 NonEmpty (Ambiguous a)
r1) : [ResultsOfLength g s (Ambiguous a)]
rest1) rl2' :: [ResultsOfLength g s (Ambiguous a)]
rl2'@(rol2 :: ResultsOfLength g s (Ambiguous a)
rol2@(ResultsOfLength Int
l2 [(s, g (ResultList g s))]
_ NonEmpty (Ambiguous a)
r2) : [ResultsOfLength g s (Ambiguous a)]
rest2)
               | Int
l1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
l2 = ResultsOfLength g s (Ambiguous a)
rol1 ResultsOfLength g s (Ambiguous a)
-> [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
forall a. a -> [a] -> [a]
: [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
merge [ResultsOfLength g s (Ambiguous a)]
rest1 [ResultsOfLength g s (Ambiguous a)]
rl2'
               | Int
l1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
l2 = ResultsOfLength g s (Ambiguous a)
rol2 ResultsOfLength g s (Ambiguous a)
-> [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
forall a. a -> [a] -> [a]
: [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
merge [ResultsOfLength g s (Ambiguous a)]
rl1' [ResultsOfLength g s (Ambiguous a)]
rest2
               | Bool
otherwise = Int
-> [(s, g (ResultList g s))]
-> NonEmpty (Ambiguous a)
-> ResultsOfLength g s (Ambiguous a)
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 ((Ambiguous a -> Ambiguous a -> Ambiguous a)
-> NonEmpty (Ambiguous a)
-> NonEmpty (Ambiguous a)
-> NonEmpty (Ambiguous a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Ambiguous a -> Ambiguous a -> Ambiguous a
forall a. Ambiguous a -> Ambiguous a -> Ambiguous a
collect NonEmpty (Ambiguous a)
r1 NonEmpty (Ambiguous a)
r2) ResultsOfLength g s (Ambiguous a)
-> [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
forall a. a -> [a] -> [a]
: [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
-> [ResultsOfLength g s (Ambiguous a)]
merge [ResultsOfLength g s (Ambiguous a)]
rest1 [ResultsOfLength g s (Ambiguous a)]
rest2
            collect :: Ambiguous a -> Ambiguous a -> Ambiguous a
collect (Ambiguous NonEmpty a
xs) (Ambiguous NonEmpty a
ys) = NonEmpty a -> Ambiguous a
forall a. NonEmpty a -> Ambiguous a
Ambiguous (NonEmpty a
xs NonEmpty a -> NonEmpty a -> NonEmpty a
forall a. Semigroup a => a -> a -> a
<> NonEmpty a
ys)

class Alternative f => AmbiguousAlternative f where
   ambiguousOr :: f (Ambiguous a) -> f (Ambiguous a) -> f (Ambiguous a)

instance Monoid (ResultList g s r) where
   mempty :: ResultList g s r
mempty = [ResultsOfLength g s r] -> FailureInfo s -> ResultList g s r
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo s -> ResultList g s r
ResultList [ResultsOfLength g s r]
forall a. Monoid a => a
mempty FailureInfo s
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 a -> b
f (Fork BinTree a
left 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 a -> b
f (Leaf a
a) = b -> BinTree b
forall a. a -> BinTree a
Leaf (a -> b
f a
a)
   fmap a -> b
_ BinTree a
EmptyTree = BinTree b
forall a. BinTree a
EmptyTree

instance Foldable BinTree where
   foldMap :: (a -> m) -> BinTree a -> m
foldMap a -> m
f (Fork BinTree a
left 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 a -> m
f (Leaf a
a) = a -> m
f a
a
   foldMap a -> m
_ BinTree a
EmptyTree = m
forall a. Monoid a => a
mempty

instance Traversable BinTree where
   traverse :: (a -> f b) -> BinTree a -> f (BinTree b)
traverse a -> f b
f (Fork BinTree a
left BinTree a
right) = BinTree b -> BinTree b -> BinTree b
forall a. BinTree a -> BinTree a -> BinTree a
Fork (BinTree b -> BinTree b -> BinTree b)
-> f (BinTree b) -> f (BinTree b -> BinTree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> BinTree a -> f (BinTree b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f BinTree a
left f (BinTree b -> BinTree b) -> f (BinTree b) -> f (BinTree b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f b) -> BinTree a -> f (BinTree b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f BinTree a
right
   traverse a -> f b
f (Leaf a
a) = b -> BinTree b
forall a. a -> BinTree a
Leaf (b -> BinTree b) -> f b -> f (BinTree b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
   traverse a -> f b
_ BinTree a
EmptyTree = BinTree b -> f (BinTree b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure BinTree b
forall a. BinTree a
EmptyTree

instance Filterable BinTree where
   mapMaybe :: (a -> Maybe b) -> BinTree a -> BinTree b
mapMaybe a -> Maybe b
f (Fork BinTree a
left BinTree a
right) = (a -> Maybe b) -> BinTree a -> BinTree b
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe a -> Maybe b
f BinTree a
left BinTree b -> BinTree b -> BinTree b
forall a. Semigroup a => a -> a -> a
<> (a -> Maybe b) -> BinTree a -> BinTree b
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe a -> Maybe b
f BinTree a
right
   mapMaybe a -> Maybe b
f (Leaf a
a) = BinTree b -> (b -> BinTree b) -> Maybe b -> BinTree b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BinTree b
forall a. BinTree a
EmptyTree b -> BinTree b
forall a. a -> BinTree a
Leaf (a -> Maybe b
f a
a)
   mapMaybe a -> Maybe b
_ BinTree a
EmptyTree = BinTree b
forall a. BinTree a
EmptyTree

instance Semigroup (BinTree a) where
   BinTree a
EmptyTree <> :: BinTree a -> BinTree a -> BinTree a
<> BinTree a
t = BinTree a
t
   BinTree a
t <> BinTree a
EmptyTree = BinTree a
t
   BinTree a
l <> 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
(<>)

class FallibleResults f where
   hasSuccess   :: f s a -> Bool
   failureOf    :: f s a -> FailureInfo s
   failWith     :: FailureInfo s -> f s a

instance FallibleResults (ResultList g) where
   hasSuccess :: ResultList g s a -> Bool
hasSuccess (ResultList [] FailureInfo s
_) = Bool
False
   hasSuccess ResultList g s a
_ = Bool
True
   failureOf :: ResultList g s a -> FailureInfo s
failureOf (ResultList [ResultsOfLength g s a]
_ FailureInfo s
failure) = FailureInfo s
failure
   failWith :: FailureInfo s -> ResultList g s a
failWith = [ResultsOfLength g s a] -> FailureInfo s -> ResultList g s a
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> FailureInfo s -> ResultList g s r
ResultList []

class InputParsing m => TraceableParsing m where
   traceInput :: (ParserInput m -> String) -> m a -> m a
   traceAs :: Show (ParserInput m) => String -> m a -> m a
   traceAs String
description = (ParserInput m -> String) -> m a -> m a
forall (m :: * -> *) a.
TraceableParsing m =>
(ParserInput m -> String) -> m a -> m a
traceInput (\ParserInput m
input-> String
description String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" @ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ParserInput m -> String
forall a. Show a => a -> String
show ParserInput m
input)