{-# LANGUAGE TypeFamilies #-}

module Text.Grampa.Combinators (moptional, concatMany, concatSome,
                                flag, count, upto,
                                delimiter, operator, keyword) where

import Control.Applicative(Applicative(..), Alternative(..))
import Data.List.NonEmpty (fromList)
import Data.Monoid (Monoid)
import Data.Monoid.Factorial (FactorialMonoid)
import Data.Semigroup (Semigroup(sconcat))
import Data.Semigroup.Cancellative (LeftReductive)

import Text.Grampa.Class (InputParsing(ParserInput, string), LexicalParsing(lexicalToken, keyword))
import Text.Parser.Combinators (Parsing((<?>)), count)

-- | Attempts to parse a monoidal value, if the argument parser fails returns 'mempty'.
moptional :: (Alternative p, Monoid a) => p a -> p a
moptional :: p a -> p a
moptional p :: p a
p = p a
p p a -> p a -> p a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> p a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

-- | Zero or more argument occurrences like 'many', with concatenated monoidal results.
concatMany :: (Alternative p, Monoid a) => p a -> p a
concatMany :: p a -> p a
concatMany p :: p a
p = [a] -> a
forall a. Monoid a => [a] -> a
mconcat ([a] -> a) -> p [a] -> p a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a -> p [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many p a
p

-- | One or more argument occurrences like 'some', with concatenated monoidal results.
concatSome :: (Alternative p, Semigroup a) => p a -> p a
concatSome :: p a -> p a
concatSome p :: p a
p = NonEmpty a -> a
forall a. Semigroup a => NonEmpty a -> a
sconcat (NonEmpty a -> a) -> ([a] -> NonEmpty a) -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> NonEmpty a
forall a. [a] -> NonEmpty a
fromList ([a] -> a) -> p [a] -> p a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a -> p [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some p a
p

-- | Returns 'True' if the argument parser succeeds and 'False' otherwise.
flag :: Alternative p => p a -> p Bool
flag :: p a -> p Bool
flag p :: p a
p = Bool
True Bool -> p a -> p Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ p a
p p Bool -> p Bool -> p Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> p Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Parses between 0 and N occurrences of the argument parser in sequence and returns the list of results.
upto :: Alternative p => Int -> p a -> p [a]
upto :: Int -> p a -> p [a]
upto n :: Int
n p :: p a
p
   | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = (:) (a -> [a] -> [a]) -> p a -> p ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p a
p p ([a] -> [a]) -> p [a] -> p [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> p a -> p [a]
forall (p :: * -> *) a. Alternative p => Int -> p a -> p [a]
upto (Int -> Int
forall a. Enum a => a -> a
pred Int
n) p a
p 
             p [a] -> p [a] -> p [a]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> p [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
   | Bool
otherwise = [a] -> p [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Parses the given delimiter, such as a comma or a brace
delimiter :: (Show s, FactorialMonoid s, LeftReductive s, s ~ ParserInput m, LexicalParsing m) => s -> m s
delimiter :: s -> m s
delimiter s :: s
s = m s -> m s
forall (m :: * -> *) a. LexicalParsing m => m a -> m a
lexicalToken (ParserInput m -> m (ParserInput m)
forall (m :: * -> *).
InputParsing m =>
ParserInput m -> m (ParserInput m)
string s
ParserInput m
s) m s -> String -> m s
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> ("delimiter " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> s -> String
forall a. Show a => a -> String
show s
s)

-- | Parses the given operator symbol
operator :: (Show s, FactorialMonoid s, LeftReductive s, s ~ ParserInput m, LexicalParsing m) => s -> m s
operator :: s -> m s
operator s :: s
s = m s -> m s
forall (m :: * -> *) a. LexicalParsing m => m a -> m a
lexicalToken (ParserInput m -> m (ParserInput m)
forall (m :: * -> *).
InputParsing m =>
ParserInput m -> m (ParserInput m)
string s
ParserInput m
s) m s -> String -> m s
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> ("operator " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> s -> String
forall a. Show a => a -> String
show s
s)