{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, DefaultSignatures, OverloadedStrings, RankNTypes,
             ScopedTypeVariables, TypeApplications, TypeFamilies, DeriveDataTypeable #-}
module Text.Grampa.Class (MultiParsing(..), GrammarParsing(..), AmbiguousParsing(..), MonoidParsing(..), Lexical(..),
                          ParseResults, ParseFailure(..), Ambiguous(..), Position, positionOffset, completeParser) where

import Control.Applicative (Alternative(empty), liftA2, (<|>))
import Data.Char (isAlphaNum, isLetter, isSpace)
import Data.Functor.Classes (Show1(..))
import Data.Functor.Compose (Compose(..))
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Data (Data)
import Data.Typeable (Typeable)
import Data.Monoid (Monoid(mempty, mappend))
import Data.Monoid.Cancellative (LeftReductiveMonoid)
import qualified Data.Monoid.Null as Null
import Data.Monoid.Null (MonoidNull)
import qualified Data.Monoid.Factorial as Factorial
import Data.Monoid.Factorial (FactorialMonoid)
import Data.Monoid.Textual (TextualMonoid)
import Data.Semigroup (Semigroup((<>)))
import Text.Parser.Combinators (Parsing((<?>)), skipMany)
import Text.Parser.Char (CharParsing(char))
import GHC.Exts (Constraint)

import qualified Rank2

type ParseResults = Either ParseFailure

-- | A 'ParseFailure' contains the offset of the parse failure and the list of things expected at that offset.
data ParseFailure = ParseFailure Int [String] deriving (ParseFailure -> ParseFailure -> Bool
(ParseFailure -> ParseFailure -> Bool)
-> (ParseFailure -> ParseFailure -> Bool) -> Eq ParseFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseFailure -> ParseFailure -> Bool
$c/= :: ParseFailure -> ParseFailure -> Bool
== :: ParseFailure -> ParseFailure -> Bool
$c== :: ParseFailure -> ParseFailure -> Bool
Eq, Int -> ParseFailure -> ShowS
[ParseFailure] -> ShowS
ParseFailure -> String
(Int -> ParseFailure -> ShowS)
-> (ParseFailure -> String)
-> ([ParseFailure] -> ShowS)
-> Show ParseFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseFailure] -> ShowS
$cshowList :: [ParseFailure] -> ShowS
show :: ParseFailure -> String
$cshow :: ParseFailure -> String
showsPrec :: Int -> ParseFailure -> ShowS
$cshowsPrec :: Int -> ParseFailure -> ShowS
Show)

-- | Opaque data type that represents an input position.
newtype Position s = Position{
  -- | The length of the input from the position to end.
  Position s -> Int
remainderLength :: Int}

-- | Map the position into its offset from the beginning of the full input.
positionOffset :: FactorialMonoid s => s -> Position s -> Int
positionOffset :: s -> Position s -> Int
positionOffset wholeInput :: s
wholeInput = (Int
wholeLength Int -> Int -> Int
forall a. Num a => a -> a -> a
-) (Int -> Int) -> (Position s -> Int) -> Position s -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position s -> Int
forall s. Position s -> Int
remainderLength
   where wholeLength :: Int
wholeLength = s -> Int
forall m. Factorial m => m -> Int
Factorial.length s
wholeInput
{-# INLINE positionOffset #-}

-- | An 'Ambiguous' parse result, produced by the 'ambiguous' combinator, contains a 'NonEmpty' list of
-- alternative results.
newtype Ambiguous a = Ambiguous (NonEmpty a) deriving (Typeable (Ambiguous a)
DataType
Constr
Typeable (Ambiguous a) =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Ambiguous a -> c (Ambiguous a))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Ambiguous a))
-> (Ambiguous a -> Constr)
-> (Ambiguous a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Ambiguous a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (Ambiguous a)))
-> ((forall b. Data b => b -> b) -> Ambiguous a -> Ambiguous a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Ambiguous a -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Ambiguous a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a))
-> Data (Ambiguous a)
Ambiguous a -> DataType
Ambiguous a -> Constr
(forall d. Data d => c (t d)) -> Maybe (c (Ambiguous a))
(forall b. Data b => b -> b) -> Ambiguous a -> Ambiguous a
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Ambiguous a -> c (Ambiguous a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Ambiguous a)
forall a. Data a => Typeable (Ambiguous a)
forall a. Data a => Ambiguous a -> DataType
forall a. Data a => Ambiguous a -> Constr
forall a.
Data a =>
(forall b. Data b => b -> b) -> Ambiguous a -> Ambiguous a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Ambiguous a -> u
forall a u.
Data a =>
(forall d. Data d => d -> u) -> Ambiguous a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r
forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Ambiguous a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Ambiguous a -> c (Ambiguous a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Ambiguous a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Ambiguous a))
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Ambiguous a -> u
forall u. (forall d. Data d => d -> u) -> Ambiguous a -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Ambiguous a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Ambiguous a -> c (Ambiguous a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Ambiguous a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Ambiguous a))
$cAmbiguous :: Constr
$tAmbiguous :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
gmapMp :: (forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
gmapM :: (forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Ambiguous a -> m (Ambiguous a)
gmapQi :: Int -> (forall d. Data d => d -> u) -> Ambiguous a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Ambiguous a -> u
gmapQ :: (forall d. Data d => d -> u) -> Ambiguous a -> [u]
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> Ambiguous a -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Ambiguous a -> r
gmapT :: (forall b. Data b => b -> b) -> Ambiguous a -> Ambiguous a
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Ambiguous a -> Ambiguous a
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Ambiguous a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Ambiguous a))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (Ambiguous a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Ambiguous a))
dataTypeOf :: Ambiguous a -> DataType
$cdataTypeOf :: forall a. Data a => Ambiguous a -> DataType
toConstr :: Ambiguous a -> Constr
$ctoConstr :: forall a. Data a => Ambiguous a -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Ambiguous a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Ambiguous a)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Ambiguous a -> c (Ambiguous a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Ambiguous a -> c (Ambiguous a)
$cp1Data :: forall a. Data a => Typeable (Ambiguous a)
Data, Ambiguous a -> Ambiguous a -> Bool
(Ambiguous a -> Ambiguous a -> Bool)
-> (Ambiguous a -> Ambiguous a -> Bool) -> Eq (Ambiguous a)
forall a. Eq a => Ambiguous a -> Ambiguous a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ambiguous a -> Ambiguous a -> Bool
$c/= :: forall a. Eq a => Ambiguous a -> Ambiguous a -> Bool
== :: Ambiguous a -> Ambiguous a -> Bool
$c== :: forall a. Eq a => Ambiguous a -> Ambiguous a -> Bool
Eq, Eq (Ambiguous a)
Eq (Ambiguous a) =>
(Ambiguous a -> Ambiguous a -> Ordering)
-> (Ambiguous a -> Ambiguous a -> Bool)
-> (Ambiguous a -> Ambiguous a -> Bool)
-> (Ambiguous a -> Ambiguous a -> Bool)
-> (Ambiguous a -> Ambiguous a -> Bool)
-> (Ambiguous a -> Ambiguous a -> Ambiguous a)
-> (Ambiguous a -> Ambiguous a -> Ambiguous a)
-> Ord (Ambiguous a)
Ambiguous a -> Ambiguous a -> Bool
Ambiguous a -> Ambiguous a -> Ordering
Ambiguous a -> Ambiguous a -> Ambiguous a
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
forall a. Ord a => Eq (Ambiguous a)
forall a. Ord a => Ambiguous a -> Ambiguous a -> Bool
forall a. Ord a => Ambiguous a -> Ambiguous a -> Ordering
forall a. Ord a => Ambiguous a -> Ambiguous a -> Ambiguous a
min :: Ambiguous a -> Ambiguous a -> Ambiguous a
$cmin :: forall a. Ord a => Ambiguous a -> Ambiguous a -> Ambiguous a
max :: Ambiguous a -> Ambiguous a -> Ambiguous a
$cmax :: forall a. Ord a => Ambiguous a -> Ambiguous a -> Ambiguous a
>= :: Ambiguous a -> Ambiguous a -> Bool
$c>= :: forall a. Ord a => Ambiguous a -> Ambiguous a -> Bool
> :: Ambiguous a -> Ambiguous a -> Bool
$c> :: forall a. Ord a => Ambiguous a -> Ambiguous a -> Bool
<= :: Ambiguous a -> Ambiguous a -> Bool
$c<= :: forall a. Ord a => Ambiguous a -> Ambiguous a -> Bool
< :: Ambiguous a -> Ambiguous a -> Bool
$c< :: forall a. Ord a => Ambiguous a -> Ambiguous a -> Bool
compare :: Ambiguous a -> Ambiguous a -> Ordering
$ccompare :: forall a. Ord a => Ambiguous a -> Ambiguous a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Ambiguous a)
Ord, Int -> Ambiguous a -> ShowS
[Ambiguous a] -> ShowS
Ambiguous a -> String
(Int -> Ambiguous a -> ShowS)
-> (Ambiguous a -> String)
-> ([Ambiguous a] -> ShowS)
-> Show (Ambiguous a)
forall a. Show a => Int -> Ambiguous a -> ShowS
forall a. Show a => [Ambiguous a] -> ShowS
forall a. Show a => Ambiguous a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ambiguous a] -> ShowS
$cshowList :: forall a. Show a => [Ambiguous a] -> ShowS
show :: Ambiguous a -> String
$cshow :: forall a. Show a => Ambiguous a -> String
showsPrec :: Int -> Ambiguous a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Ambiguous a -> ShowS
Show, Typeable)

instance Show1 Ambiguous where
   liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Ambiguous a -> ShowS
liftShowsPrec sp :: Int -> a -> ShowS
sp sl :: [a] -> ShowS
sl d :: Int
d (Ambiguous (h :: a
h :| l :: [a]
l)) t :: String
t
      | Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 5 = "(Ambiguous $ " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> a -> ShowS
sp 0 a
h (" :| " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [a] -> ShowS
sl [a]
l (')' Char -> ShowS
forall a. a -> [a] -> [a]
: String
t))
      | Bool
otherwise = "Ambiguous (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> a -> ShowS
sp 0 a
h (" :| " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [a] -> ShowS
sl [a]
l (')' Char -> ShowS
forall a. a -> [a] -> [a]
: String
t))

instance Functor Ambiguous where
   fmap :: (a -> b) -> Ambiguous a -> Ambiguous b
fmap f :: a -> b
f (Ambiguous a :: NonEmpty a
a) = NonEmpty b -> Ambiguous b
forall a. NonEmpty a -> Ambiguous a
Ambiguous ((a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f NonEmpty a
a)

instance Applicative Ambiguous where
   pure :: a -> Ambiguous a
pure a :: a
a = NonEmpty a -> Ambiguous a
forall a. NonEmpty a -> Ambiguous a
Ambiguous (a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
   Ambiguous f :: NonEmpty (a -> b)
f <*> :: Ambiguous (a -> b) -> Ambiguous a -> Ambiguous b
<*> Ambiguous a :: NonEmpty a
a = NonEmpty b -> Ambiguous b
forall a. NonEmpty a -> Ambiguous a
Ambiguous (NonEmpty (a -> b)
f NonEmpty (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NonEmpty a
a)

instance Foldable Ambiguous where
   foldMap :: (a -> m) -> Ambiguous a -> m
foldMap f :: a -> m
f (Ambiguous a :: NonEmpty a
a) = (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f NonEmpty a
a

instance Traversable Ambiguous where
   traverse :: (a -> f b) -> Ambiguous a -> f (Ambiguous b)
traverse f :: a -> f b
f (Ambiguous a :: NonEmpty a
a) = NonEmpty b -> Ambiguous b
forall a. NonEmpty a -> Ambiguous a
Ambiguous (NonEmpty b -> Ambiguous b) -> f (NonEmpty b) -> f (Ambiguous b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> NonEmpty a -> f (NonEmpty b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f NonEmpty a
a

instance Semigroup a => Semigroup (Ambiguous a) where
   Ambiguous xs :: NonEmpty a
xs <> :: Ambiguous a -> Ambiguous a -> Ambiguous a
<> Ambiguous ys :: NonEmpty a
ys = NonEmpty a -> Ambiguous a
forall a. NonEmpty a -> Ambiguous a
Ambiguous ((a -> a -> a) -> NonEmpty a -> NonEmpty a -> NonEmpty a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) NonEmpty a
xs NonEmpty a
ys)

instance Monoid a => Monoid (Ambiguous a) where
   mempty :: Ambiguous a
mempty = NonEmpty a -> Ambiguous a
forall a. NonEmpty a -> Ambiguous a
Ambiguous (a
forall a. Monoid a => a
mempty a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [])
   Ambiguous xs :: NonEmpty a
xs mappend :: Ambiguous a -> Ambiguous a -> Ambiguous a
`mappend` Ambiguous ys :: NonEmpty a
ys = NonEmpty a -> Ambiguous a
forall a. NonEmpty a -> Ambiguous a
Ambiguous ((a -> a -> a) -> NonEmpty a -> NonEmpty a -> NonEmpty a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Monoid a => a -> a -> a
mappend NonEmpty a
xs NonEmpty a
ys)

completeParser :: MonoidNull s => Compose ParseResults (Compose [] ((,) s)) r -> Compose ParseResults [] r
completeParser :: Compose ParseResults (Compose [] ((,) s)) r
-> Compose ParseResults [] r
completeParser (Compose (Left failure :: ParseFailure
failure)) = Either ParseFailure [r] -> Compose ParseResults [] r
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (ParseFailure -> Either ParseFailure [r]
forall a b. a -> Either a b
Left ParseFailure
failure)
completeParser (Compose (Right (Compose results :: [(s, r)]
results))) =
   case ((s, r) -> Bool) -> [(s, r)] -> [(s, r)]
forall a. (a -> Bool) -> [a] -> [a]
filter (s -> Bool
forall m. MonoidNull m => m -> Bool
Null.null (s -> Bool) -> ((s, r) -> s) -> (s, r) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s, r) -> s
forall a b. (a, b) -> a
fst) [(s, r)]
results
   of [] -> Either ParseFailure [r] -> Compose ParseResults [] r
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (ParseFailure -> Either ParseFailure [r]
forall a b. a -> Either a b
Left (ParseFailure -> Either ParseFailure [r])
-> ParseFailure -> Either ParseFailure [r]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> ParseFailure
ParseFailure 0 ["complete parse"])
      completeResults :: [(s, r)]
completeResults -> Either ParseFailure [r] -> Compose ParseResults [] r
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ([r] -> Either ParseFailure [r]
forall a b. b -> Either a b
Right ([r] -> Either ParseFailure [r]) -> [r] -> Either ParseFailure [r]
forall a b. (a -> b) -> a -> b
$ (s, r) -> r
forall a b. (a, b) -> b
snd ((s, r) -> r) -> [(s, r)] -> [r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(s, r)]
completeResults)

-- | Choose one of the instances of this class to parse with.
class MultiParsing m where
   -- | Some parser types produce a single result, others a list of results.
   type ResultFunctor m :: * -> *
   type GrammarConstraint m (g :: (* -> *) -> *) :: Constraint
   type GrammarConstraint m g = Rank2.Functor g
   -- | Given a rank-2 record of parsers and input, produce a record of parses of the complete input.
   parseComplete :: (GrammarConstraint m g, FactorialMonoid s) => g (m g s) -> s -> g (ResultFunctor m)
   -- | Given a rank-2 record of parsers and input, produce a record of prefix parses paired with the remaining input
   -- suffix.
   parsePrefix :: (GrammarConstraint m g, FactorialMonoid s) =>
                  g (m g s) -> s -> g (Compose (ResultFunctor m) ((,) s))

-- | Parsers that belong to this class can memoize the parse results to avoid exponential performance complexity.
class MultiParsing m => GrammarParsing m where
   type GrammarFunctor m :: ((* -> *) -> *) -> * -> * -> *
   -- | Used to reference a grammar production, only necessary from outside the grammar itself
   nonTerminal :: GrammarConstraint m g => (g (GrammarFunctor m g s) -> GrammarFunctor m g s a) -> m g s a
   -- | Construct a grammar whose every production refers to itself.
   selfReferring :: (GrammarConstraint m g, Rank2.Distributive g) => g (m g s)
   -- | Convert a self-referring grammar function to a grammar.
   fixGrammar :: forall g s. (GrammarConstraint m g, Rank2.Distributive g) => (g (m g s) -> g (m g s)) -> g (m g s)
   -- | Mark a parser that relies on primitive recursion to prevent an infinite loop in 'fixGrammar'.
   recursive :: m g s a -> m g s a

   selfReferring = (forall a.
 (g (GrammarFunctor m g s) -> GrammarFunctor m g s a) -> m g s a)
-> (g (GrammarFunctor m g s) -> g (GrammarFunctor m g s))
-> g (m g s)
forall k (g :: (k -> *) -> *) (m :: * -> *) (p :: k -> *)
       (q :: k -> *).
(Distributive g, Functor m) =>
(forall (a :: k). m (p a) -> q a) -> m (g p) -> g q
Rank2.cotraverse forall a.
(g (GrammarFunctor m g s) -> GrammarFunctor m g s a) -> m g s a
forall (m :: ((* -> *) -> *) -> * -> * -> *) (g :: (* -> *) -> *) s
       a.
(GrammarParsing m, GrammarConstraint m g) =>
(g (GrammarFunctor m g s) -> GrammarFunctor m g s a) -> m g s a
nonTerminal g (GrammarFunctor m g s) -> g (GrammarFunctor m g s)
forall a. a -> a
id
   {-# INLINE selfReferring #-}
   fixGrammar = ((g (m g s) -> g (m g s)) -> g (m g s) -> g (m g s)
forall a b. (a -> b) -> a -> b
$ g (m g s)
forall (m :: ((* -> *) -> *) -> * -> * -> *) (g :: (* -> *) -> *)
       s.
(GrammarParsing m, GrammarConstraint m g, Distributive g) =>
g (m g s)
selfReferring)
   {-# INLINE fixGrammar #-}
   recursive = m g s a -> m g s a
forall a. a -> a
id

-- | Methods for parsing monoidal inputs
class MonoidParsing m where
   -- | A parser that fails on any input and succeeds at its end.
   endOfInput :: FactorialMonoid s => m s ()
   -- | Always sucessful parser that returns the remaining input without consuming it.
   getInput :: FactorialMonoid s => m s s
   -- | Retrieve the 'Position' the parser has reached in the input source.
   getSourcePos :: FactorialMonoid s => m s (Position s)

   -- | A parser that accepts any single input atom.
   anyToken :: FactorialMonoid s => m s s
   -- | A parser that accepts an input atom only if it satisfies the given predicate.
   satisfy :: FactorialMonoid s => (s -> Bool) -> m s s
   -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting and returning an input character only if it
   -- satisfies the given predicate.
   satisfyChar :: TextualMonoid s => (Char -> Bool) -> m s Char
   -- | Specialization of 'satisfy' on 'TextualMonoid' inputs, accepting an input character only if it satisfies the
   -- given predicate, and returning the input atom that represents the character. A faster version of @singleton <$>
   -- satisfyChar p@ and of @satisfy (fromMaybe False p . characterPrefix)@.
   satisfyCharInput :: TextualMonoid s => (Char -> Bool) -> m s s
   -- | A parser that succeeds exactly when satisfy doesn't, equivalent to
   -- 'Text.Parser.Combinators.notFollowedBy' @. satisfy@
   notSatisfy :: FactorialMonoid s => (s -> Bool) -> m s ()
   -- | A parser that succeeds exactly when satisfyChar doesn't, equivalent to
   -- 'Text.Parser.Combinators.notFollowedBy' @. satisfyChar@
   notSatisfyChar :: TextualMonoid s => (Char -> Bool) -> m s ()

   -- | A stateful scanner. The predicate modifies a state argument, and each transformed state is passed to successive
   -- invocations of the predicate on each token of the input until one returns 'Nothing' or the input ends.
   --
   -- This parser does not fail.  It will return an empty string if the predicate returns 'Nothing' on the first
   -- character.
   --
   -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers
   -- loop until a failure occurs.  Careless use will thus result in an infinite loop.
   scan :: FactorialMonoid t => s -> (s -> t -> Maybe s) -> m t t
   -- | Stateful scanner like `scanChars`, but specialized for 'TextualMonoid' inputs.
   scanChars :: TextualMonoid t => s -> (s -> Char -> Maybe s) -> m t t
   -- | A parser that consumes and returns the given prefix of the input.
   string :: (FactorialMonoid s, LeftReductiveMonoid s, Show s) => s -> m s s

   -- | A parser accepting the longest sequence of input atoms that match the given predicate; an optimized version of
   -- 'concatMany . satisfy'.
   --
   -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers
   -- loop until a failure occurs.  Careless use will thus result in an infinite loop.
   takeWhile :: FactorialMonoid s => (s -> Bool) -> m s s
   -- | A parser accepting the longest non-empty sequence of input atoms that match the given predicate; an optimized
   -- version of 'concatSome . satisfy'.
   takeWhile1 :: FactorialMonoid s => (s -> Bool) -> m s s
   -- | Specialization of 'takeWhile' on 'TextualMonoid' inputs, accepting the longest sequence of input characters that
   -- match the given predicate; an optimized version of 'fmap fromString  . many . satisfyChar'.
   --
   -- /Note/: Because this parser does not fail, do not use it with combinators such as 'many', because such parsers
   -- loop until a failure occurs.  Careless use will thus result in an infinite loop.
   takeCharsWhile :: TextualMonoid s => (Char -> Bool) -> m s s
   -- | Specialization of 'takeWhile1' on 'TextualMonoid' inputs, accepting the longest sequence of input characters
   -- that match the given predicate; an optimized version of 'fmap fromString  . some . satisfyChar'.
   takeCharsWhile1 :: TextualMonoid s => (Char -> Bool) -> m s s
   -- | Zero or more argument occurrences like 'many', with concatenated monoidal results.
   concatMany :: Monoid a => m s a -> m s a

   default concatMany :: (Monoid a, Alternative (m s)) => m s a -> m s a
   concatMany p :: m s a
p = m s a
go
      where go :: m s a
go = a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (a -> a -> a) -> m s a -> m s (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s a
p m s (a -> a) -> m s a -> m s a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m s a
go m s a -> m s a -> m s a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> m s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
   default getSourcePos :: (FactorialMonoid s, Functor (m s)) => m s (Position s)
   getSourcePos = Int -> Position s
forall s. Int -> Position s
Position (Int -> Position s) -> (s -> Int) -> s -> Position s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Int
forall m. Factorial m => m -> Int
Factorial.length (s -> Position s) -> m s s -> m s (Position s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s s
forall (m :: * -> * -> *) s.
(MonoidParsing m, FactorialMonoid s) =>
m s s
getInput
   {-# INLINE concatMany #-}
   {-# INLINE getSourcePos #-}

-- | Parsers that can produce alternative parses and collect them into an 'Ambiguous' node
class AmbiguousParsing m where
   -- | Collect all alternative parses of the same length into a 'NonEmpty' list of results.
   ambiguous :: m a -> m (Ambiguous a)

-- | If a grammar is 'Lexical', its parsers can instantiate the 'Text.Parser.Token.TokenParsing' class.
class Lexical (g :: (* -> *) -> *) where
   type LexicalConstraint (m :: ((* -> *) -> *) -> * -> * -> *) g s :: Constraint
   -- | Always succeeds, consuming all white space and comments
   lexicalWhiteSpace :: LexicalConstraint m g s => m g s ()
   -- | Consumes all whitespace and comments, failing if there are none
   someLexicalSpace :: LexicalConstraint m g s => m g s ()
   -- | Consumes a single comment, defaults to 'empty'
   lexicalComment :: LexicalConstraint m g s => m g s ()
   -- | Consumes a single semicolon and any trailing whitespace, returning the character |';'|. The method can be
   -- overridden for automatic semicolon insertion, but if it succeeds on semicolon or white space input it must
   -- consume it.
   lexicalSemicolon :: LexicalConstraint m g s => m g s Char
   -- | Applies the argument parser and consumes the trailing 'lexicalWhitespace'
   lexicalToken :: LexicalConstraint m g s => m g s a -> m g s a
   -- | Applies the argument parser, determines whether its result is a legal identifier, and consumes the trailing
   -- 'lexicalWhitespace'
   identifierToken :: LexicalConstraint m g s => m g s s -> m g s s
   -- | Determines whether the given character can start an identifier token, allows only a letter or underscore by
   -- default
   isIdentifierStartChar :: Char -> Bool
   -- | Determines whether the given character can be any part of an identifier token, also allows numbers
   isIdentifierFollowChar :: Char -> Bool
   -- | Parses a valid identifier and consumes the trailing 'lexicalWhitespace'
   identifier :: LexicalConstraint m g s => m g s s
   -- | Parses the argument word whole, not followed by any identifier character, and consumes the trailing
   -- 'lexicalWhitespace'
   keyword :: LexicalConstraint m g s => s -> m g s ()

   type instance LexicalConstraint m g s = (Applicative (m g ()), Monad (m g s),
                                            CharParsing (m g s), MonoidParsing (m g),
                                            Show s, TextualMonoid s)
   default lexicalComment :: Alternative (m g s) => m g s ()
   default lexicalWhiteSpace :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)
                             => m g s ()
   default someLexicalSpace :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)
                            => m g s ()
   default lexicalSemicolon :: (LexicalConstraint m g s, CharParsing (m g s), MonoidParsing (m g), TextualMonoid s)
                            => m g s Char
   default lexicalToken :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)
                        => m g s a -> m g s a
   default identifierToken :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)
                           => m g s s -> m g s s
   default identifier :: (LexicalConstraint m g s, Monad (m g s), Alternative (m g s),
                          Parsing (m g s), MonoidParsing (m g), TextualMonoid s) => m g s s
   default keyword :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), Show s, TextualMonoid s)
                   => s -> m g s ()
   lexicalWhiteSpace = (Char -> Bool) -> m g s s
forall (m :: * -> * -> *) s.
(MonoidParsing m, TextualMonoid s) =>
(Char -> Bool) -> m s s
takeCharsWhile Char -> Bool
isSpace m g s s -> m g s () -> m g s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m g s s -> m g s ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipMany (m g s ()
forall (g :: (* -> *) -> *) (m :: ((* -> *) -> *) -> * -> * -> *)
       s.
(Lexical g, LexicalConstraint m g s) =>
m g s ()
lexicalComment m g s () -> m g s s -> m g s s
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> m g s s
forall (m :: * -> * -> *) s.
(MonoidParsing m, TextualMonoid s) =>
(Char -> Bool) -> m s s
takeCharsWhile Char -> Bool
isSpace)
   someLexicalSpace = (Char -> Bool) -> m g s s
forall (m :: * -> * -> *) s.
(MonoidParsing m, TextualMonoid s) =>
(Char -> Bool) -> m s s
takeCharsWhile1 Char -> Bool
isSpace m g s s -> m g s () -> m g s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m g s s -> m g s ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipMany (m g s ()
forall (g :: (* -> *) -> *) (m :: ((* -> *) -> *) -> * -> * -> *)
       s.
(Lexical g, LexicalConstraint m g s) =>
m g s ()
lexicalComment m g s () -> m g s s -> m g s s
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> m g s s
forall (m :: * -> * -> *) s.
(MonoidParsing m, TextualMonoid s) =>
(Char -> Bool) -> m s s
takeCharsWhile Char -> Bool
isSpace)
                      m g s () -> m g s () -> m g s ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m g s ()
forall (g :: (* -> *) -> *) (m :: ((* -> *) -> *) -> * -> * -> *)
       s.
(Lexical g, LexicalConstraint m g s) =>
m g s ()
lexicalComment m g s () -> m g s () -> m g s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m g s () -> m g s ()
forall (m :: * -> *) a. Parsing m => m a -> m ()
skipMany ((Char -> Bool) -> m g s s
forall (m :: * -> * -> *) s.
(MonoidParsing m, TextualMonoid s) =>
(Char -> Bool) -> m s s
takeCharsWhile Char -> Bool
isSpace m g s s -> m g s () -> m g s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m g s ()
forall (g :: (* -> *) -> *) (m :: ((* -> *) -> *) -> * -> * -> *)
       s.
(Lexical g, LexicalConstraint m g s) =>
m g s ()
lexicalComment)
   lexicalComment = m g s ()
forall (f :: * -> *) a. Alternative f => f a
empty
   lexicalSemicolon = m g s Char -> m g s Char
forall (g :: (* -> *) -> *) (m :: ((* -> *) -> *) -> * -> * -> *) s
       a.
(Lexical g, LexicalConstraint m g s) =>
m g s a -> m g s a
lexicalToken (Char -> m g s Char
forall (m :: * -> *). CharParsing m => Char -> m Char
char ';')
   lexicalToken p :: m g s a
p = m g s a
p m g s a -> m g s () -> m g s a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* m g s ()
forall (g :: (* -> *) -> *) (m :: ((* -> *) -> *) -> * -> * -> *)
       s.
(Lexical g, LexicalConstraint m g s) =>
m g s ()
lexicalWhiteSpace
   isIdentifierStartChar c :: Char
c = Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'
   isIdentifierFollowChar c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'
   identifier = m g s s -> m g s s
forall (g :: (* -> *) -> *) (m :: ((* -> *) -> *) -> * -> * -> *)
       s.
(Lexical g, LexicalConstraint m g s) =>
m g s s -> m g s s
identifierToken ((s -> s -> s) -> m g s s -> m g s s -> m g s s
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 s -> s -> s
forall a. Monoid a => a -> a -> a
mappend ((Char -> Bool) -> m g s s
forall (m :: * -> * -> *) s.
(MonoidParsing m, TextualMonoid s) =>
(Char -> Bool) -> m s s
satisfyCharInput (Lexical g => Char -> Bool
forall (g :: (* -> *) -> *). Lexical g => Char -> Bool
isIdentifierStartChar @g))
                                                ((Char -> Bool) -> m g s s
forall (m :: * -> * -> *) s.
(MonoidParsing m, TextualMonoid s) =>
(Char -> Bool) -> m s s
takeCharsWhile (Lexical g => Char -> Bool
forall (g :: (* -> *) -> *). Lexical g => Char -> Bool
isIdentifierFollowChar @g))) m g s s -> String -> m g s s
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> "an identifier"
   identifierToken = m g s s -> m g s s
forall (g :: (* -> *) -> *) (m :: ((* -> *) -> *) -> * -> * -> *) s
       a.
(Lexical g, LexicalConstraint m g s) =>
m g s a -> m g s a
lexicalToken
   keyword s :: s
s = m g s () -> m g s ()
forall (g :: (* -> *) -> *) (m :: ((* -> *) -> *) -> * -> * -> *) s
       a.
(Lexical g, LexicalConstraint m g s) =>
m g s a -> m g s a
lexicalToken (s -> m g s s
forall (m :: * -> * -> *) s.
(MonoidParsing m, FactorialMonoid s, LeftReductiveMonoid s,
 Show s) =>
s -> m s s
string s
s m g s s -> m g s () -> m g s ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> m g s ()
forall (m :: * -> * -> *) s.
(MonoidParsing m, TextualMonoid s) =>
(Char -> Bool) -> m s ()
notSatisfyChar (Lexical g => Char -> Bool
forall (g :: (* -> *) -> *). Lexical g => Char -> Bool
isIdentifierFollowChar @g)) m g s () -> String -> m g s ()
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> ("keyword " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> s -> String
forall a. Show a => a -> String
show s
s)