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

module Text.Grampa.Internal (BinTree(..), ResultList(..), ResultsOfLength(..), FallibleResults(..),
                             AmbiguousAlternative(..), AmbiguityDecidable(..), AmbiguityWitness(..),
                             ParserFlags (ParserFlags, nullable, dependsOn),
                             Dependencies (DynamicDependencies, StaticDependencies),
                             TraceableParsing(..),
                             emptyFailure, erroneous, expected, expectedInput, replaceExpected, noFailure) where

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

import Text.Grampa.Class (Ambiguous(..), FailureDescription(..), ParseFailure(..), InputParsing(..), Pos)

import Prelude hiding (length, showList)

data ResultsOfLength g s r = ResultsOfLength !Int ![(s, g (ResultList g s))] {-# UNPACK #-} !(NonEmpty r)

data ResultList g s r = ResultList ![ResultsOfLength g s r] (ParseFailure Pos 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
$cshowsPrec :: forall a. Show a => Int -> BinTree a -> ShowS
showsPrec :: Int -> BinTree a -> ShowS
$cshow :: forall a. Show a => BinTree a -> String
show :: BinTree a -> String
$cshowList :: forall a. Show a => [BinTree a] -> ShowS
showList :: [BinTree a] -> ShowS
Show)

data ParserFlags g = ParserFlags {
   forall (g :: (* -> *) -> *). ParserFlags g -> Bool
nullable :: Bool,
   forall (g :: (* -> *) -> *). ParserFlags g -> Dependencies g
dependsOn :: Dependencies g}

data Dependencies g = DynamicDependencies
                    | StaticDependencies (g (Const Bool))

deriving instance Show (g (Const Bool)) => Show (Dependencies g)

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)

noFailure :: ParseFailure Pos s
noFailure :: forall s. ParseFailure Pos s
noFailure = Pos -> ParseFailure Pos s
forall s. Pos -> ParseFailure Pos s
emptyFailure (Int -> Pos
forall a. a -> Down a
Down Int
forall a. Bounded a => a
maxBound)

emptyFailure :: Pos -> ParseFailure Pos s
emptyFailure :: forall s. Pos -> ParseFailure Pos s
emptyFailure Pos
pos = Pos -> FailureDescription s -> [String] -> ParseFailure Pos s
forall pos s.
pos -> FailureDescription s -> [String] -> ParseFailure pos s
ParseFailure Pos
pos ([String] -> [s] -> FailureDescription s
forall s. [String] -> [s] -> FailureDescription s
FailureDescription [] []) []

expected :: Pos -> String -> ParseFailure Pos s
expected :: forall s. Pos -> String -> ParseFailure Pos s
expected Pos
pos String
msg = Pos -> FailureDescription s -> [String] -> ParseFailure Pos s
forall pos s.
pos -> FailureDescription s -> [String] -> ParseFailure pos s
ParseFailure Pos
pos ([String] -> [s] -> FailureDescription s
forall s. [String] -> [s] -> FailureDescription s
FailureDescription [String
msg] []) []

expectedInput :: Pos -> s -> ParseFailure Pos s
expectedInput :: forall s. Pos -> s -> ParseFailure Pos s
expectedInput Pos
pos s
s = Pos -> FailureDescription s -> [String] -> ParseFailure Pos s
forall pos s.
pos -> FailureDescription s -> [String] -> ParseFailure pos s
ParseFailure Pos
pos ([String] -> [s] -> FailureDescription s
forall s. [String] -> [s] -> FailureDescription s
FailureDescription [] [s
s]) []

erroneous :: Pos -> String -> ParseFailure Pos s
erroneous :: forall s. Pos -> String -> ParseFailure Pos s
erroneous Pos
pos String
msg = Pos -> FailureDescription s -> [String] -> ParseFailure Pos s
forall pos s.
pos -> FailureDescription s -> [String] -> ParseFailure pos s
ParseFailure Pos
pos ([String] -> [s] -> FailureDescription s
forall s. [String] -> [s] -> FailureDescription s
FailureDescription [] []) [String
msg]

replaceExpected :: Pos -> String -> ParseFailure Pos s -> ParseFailure Pos s
replaceExpected :: forall s. Pos -> String -> ParseFailure Pos s -> ParseFailure Pos s
replaceExpected Pos
pos String
msg (ParseFailure Pos
pos' FailureDescription s
msgs [String]
errs) = Pos -> FailureDescription s -> [String] -> ParseFailure Pos s
forall pos s.
pos -> FailureDescription s -> [String] -> ParseFailure pos s
ParseFailure Pos
pos' FailureDescription s
msgs' [String]
errs
   where msgs' :: FailureDescription s
msgs' | Pos
pos Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
pos' = [String] -> [s] -> FailureDescription s
forall s. [String] -> [s] -> FailureDescription s
FailureDescription [String
msg] []
               | Bool
otherwise = FailureDescription s
msgs

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

instance Show s => Show1 (ResultList g s) where
   liftShowsPrec :: forall a.
(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 ParseFailure Pos 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 a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [ResultsOfLength g s a]
rol) (ParseFailure Pos s -> ShowS
forall a. Show a => a -> ShowS
shows ParseFailure Pos 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 a. 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 :: forall a b.
(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 :: forall a b. (a -> b) -> ResultList g s a -> ResultList g s b
fmap a -> b
f (ResultList [ResultsOfLength g s a]
l ParseFailure Pos s
failure) = [ResultsOfLength g s b] -> ParseFailure Pos s -> ResultList g s b
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> ParseFailure Pos 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) ParseFailure Pos s
failure
   {-# INLINE fmap #-}

instance Ord s => Applicative (ResultsOfLength g s) where
   pure :: forall a. 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 a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
   ResultsOfLength Int
l1 [(s, g (ResultList g s))]
_ NonEmpty (a -> b)
fs <*> :: forall a b.
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 a b. NonEmpty (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NonEmpty a
xs)

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

instance Ord s => Alternative (ResultList g s) where
   empty :: forall a. ResultList g s a
empty = [ResultsOfLength g s a] -> ParseFailure Pos s -> ResultList g s a
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> ParseFailure Pos s -> ResultList g s r
ResultList [ResultsOfLength g s a]
forall a. Monoid a => a
mempty ParseFailure Pos s
forall a. Monoid a => a
mempty
   <|> :: forall a. 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 :: forall a b. (a -> Maybe b) -> ResultList g s a -> ResultList g s b
mapMaybe a -> Maybe b
f (ResultList [ResultsOfLength g s a]
rols ParseFailure Pos s
failure) = [ResultsOfLength g s b] -> ParseFailure Pos s -> ResultList g s b
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> ParseFailure Pos s -> ResultList g s r
ResultList ((ResultsOfLength g s a -> Maybe (ResultsOfLength g s b))
-> [ResultsOfLength g s a] -> [ResultsOfLength g s b]
forall a b. (a -> Maybe b) -> [a] -> [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]
rols) ParseFailure Pos 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 a b. (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 a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty a
rs)
   {-# INLINE mapMaybe #-}

instance Ord s => Semigroup (ResultList g s r) where
   ResultList [ResultsOfLength g s r]
rl1 ParseFailure Pos s
f1 <> :: ResultList g s r -> ResultList g s r -> ResultList g s r
<> ResultList [ResultsOfLength g s r]
rl2 ParseFailure Pos s
f2 = [ResultsOfLength g s r] -> ParseFailure Pos s -> ResultList g s r
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> ParseFailure Pos 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) (ParseFailure Pos s
f1 ParseFailure Pos s -> ParseFailure Pos s -> ParseFailure Pos s
forall a. Semigroup a => a -> a -> a
<> ParseFailure Pos 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 Ord s => AmbiguousAlternative (ResultList g s) where
   ambiguousOr :: forall a.
ResultList g s (Ambiguous a)
-> ResultList g s (Ambiguous a) -> ResultList g s (Ambiguous a)
ambiguousOr (ResultList [ResultsOfLength g s (Ambiguous a)]
rl1 ParseFailure Pos s
f1) (ResultList [ResultsOfLength g s (Ambiguous a)]
rl2 ParseFailure Pos s
f2) = [ResultsOfLength g s (Ambiguous a)]
-> ParseFailure Pos s -> ResultList g s (Ambiguous a)
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> ParseFailure Pos 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) (ParseFailure Pos s
f1 ParseFailure Pos s -> ParseFailure Pos s -> ParseFailure Pos s
forall a. Semigroup a => a -> a -> a
<> ParseFailure Pos 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 a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
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 Ord s => Monoid (ResultList g s r) where
   mempty :: ResultList g s r
mempty = [ResultsOfLength g s r] -> ParseFailure Pos s -> ResultList g s r
forall (g :: (* -> *) -> *) s r.
[ResultsOfLength g s r] -> ParseFailure Pos s -> ResultList g s r
ResultList [ResultsOfLength g s r]
forall a. Monoid a => a
mempty ParseFailure Pos 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 :: forall a b. (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 a b. (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 a b. (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 Applicative BinTree where
  pure :: forall a. a -> BinTree a
pure = a -> BinTree a
forall a. a -> BinTree a
Leaf
  BinTree (a -> b)
EmptyTree <*> :: forall a b. BinTree (a -> b) -> BinTree a -> BinTree b
<*> BinTree a
_ = BinTree b
forall a. BinTree a
EmptyTree
  Leaf a -> b
f <*> BinTree a
t = a -> b
f (a -> b) -> BinTree a -> BinTree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinTree a
t
  Fork BinTree (a -> b)
f1 BinTree (a -> b)
f2 <*> BinTree a
t = BinTree b -> BinTree b -> BinTree b
forall a. BinTree a -> BinTree a -> BinTree a
Fork (BinTree (a -> b)
f1 BinTree (a -> b) -> BinTree a -> BinTree b
forall a b. BinTree (a -> b) -> BinTree a -> BinTree b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinTree a
t) (BinTree (a -> b)
f2 BinTree (a -> b) -> BinTree a -> BinTree b
forall a b. BinTree (a -> b) -> BinTree a -> BinTree b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinTree a
t)

instance Foldable BinTree where
   foldMap :: forall m a. Monoid m => (a -> m) -> BinTree a -> m
foldMap a -> m
f (Fork BinTree a
left BinTree a
right) = (a -> m) -> BinTree a -> m
forall m a. Monoid m => (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 m a. Monoid m => (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 :: forall (f :: * -> *) a b.
Applicative f =>
(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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BinTree a -> f (BinTree b)
traverse a -> f b
f BinTree a
left f (BinTree b -> BinTree b) -> f (BinTree b) -> f (BinTree b)
forall a b. f (a -> b) -> f a -> f 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> BinTree a -> f (BinTree 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 a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BinTree b
forall a. BinTree a
EmptyTree

instance Filterable BinTree where
   mapMaybe :: forall a b. (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 a b. (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 a b. (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 -> ParseFailure Pos s
   failWith     :: ParseFailure Pos s -> f s a

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

-- | The class of parsers whose execution can be traced for debugging purposes
class InputParsing m => TraceableParsing m where
   -- | Modify the argument parser to log its input whenever invoked.
   traceInput :: (ParserInput m -> String) -> m a -> m a
   -- | Modify the argument parser to log the given description and its input whenever invoked.
   traceAs :: Show (ParserInput m) => String -> m a -> m a
   traceAs String
description = (ParserInput m -> String) -> m a -> m a
forall a. (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)