{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE RankNTypes #-}

-- | Commonly used generic combinators.

module Text.Cassette.Combinator where

import Control.Category ((.))
import Prelude hiding ((.))
import Text.Cassette.Lead
import Text.Cassette.Prim

-- | Applies each cassette in the supplied list in order, until one of them
-- succeeds.
choice :: [PP a] -> PP a
choice :: forall a. [PP a] -> PP a
choice [] = K7 Tr r (a -> r)
forall a. Monoid a => a
mempty
choice (PP a
p:[PP a]
ps) = K7 Tr r (a -> r)
PP a
p K7 Tr r (a -> r) -> K7 Tr r (a -> r) -> K7 Tr r (a -> r)
forall a. Semigroup a => a -> a -> a
<> [PP a] -> PP a
forall a. [PP a] -> PP a
choice [PP a]
ps

-- | @count n p@ matches @n@ occurrences of @p@.
count :: Int -> PP a -> PP [a]
count :: forall a. Int -> PP a -> PP [a]
count Int
0 PP a
_ = K7 Tr r ([a] -> r)
forall a r. K7 Tr r ([a] -> r)
nilL
count Int
n PP a
p = K7 Tr (a -> [a] -> r) ([a] -> r)
forall a r. K7 Tr (a -> [a] -> r) ([a] -> r)
consL K7 Tr (a -> [a] -> r) ([a] -> r)
-> K7 Tr r (a -> [a] -> r) -> K7 Tr r ([a] -> r)
forall (p :: * -> * -> *) b c a.
Category p =>
K7 p b c -> K7 p a b -> K7 p a c
--> K7 Tr ([a] -> r) (a -> [a] -> r)
PP a
p K7 Tr ([a] -> r) (a -> [a] -> r)
-> K7 Tr r ([a] -> r) -> K7 Tr r (a -> [a] -> r)
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> PP a -> PP [a]
forall a. Int -> PP a -> PP [a]
count (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) K7 Tr r (a -> r)
PP a
p

-- | Tries to apply the given cassette. It returns the value of the cassette on
-- success, the first argument otherwise.
option :: a -> PP a -> PP a
option :: forall a. a -> PP a -> PP a
option a
x PP a
p = K7 Tr r (a -> r)
PP a
p K7 Tr r (a -> r) -> K7 Tr r (a -> r) -> K7 Tr r (a -> r)
forall a. Semigroup a => a -> a -> a
<> a -> PP0 -> PP a
forall a. a -> PP0 -> PP a
set a
x K7 Tr r r
PP0
nothing

-- | Tries to apply the given cassette. It returns a value of the form @Just x@
-- on success, @Nothing@ otherwise.
optionMaybe :: PP a -> PP (Maybe a)
optionMaybe :: forall a. PP a -> PP (Maybe a)
optionMaybe PP a
p = K7 Tr (a -> r) (Maybe a -> r)
forall a r. K7 Tr (a -> r) (Maybe a -> r)
justL K7 Tr (a -> r) (Maybe a -> r)
-> K7 Tr r (a -> r) -> K7 Tr r (Maybe a -> r)
forall (p :: * -> * -> *) b c a.
Category p =>
K7 p b c -> K7 p a b -> K7 p a c
--> K7 Tr r (a -> r)
PP a
p K7 Tr r (Maybe a -> r)
-> K7 Tr r (Maybe a -> r) -> K7 Tr r (Maybe a -> r)
forall a. Semigroup a => a -> a -> a
<> K7 Tr r (Maybe a -> r)
forall a r. K7 Tr r (Maybe a -> r)
nothingL

-- | Tries to match the given cassette and discards the result, otherwise does
-- nothing in case of failure.
optional :: PP a -> PP0
optional :: forall a. PP a -> PP0
optional PP a
p = [a] -> PP [a] -> PP0
forall a. a -> PP a -> PP0
unset [] (Int -> PP a -> PP [a]
forall a. Int -> PP a -> PP [a]
count Int
1 K7 Tr r (a -> r)
PP a
p K7 Tr r ([a] -> r) -> K7 Tr r ([a] -> r) -> K7 Tr r ([a] -> r)
forall a. Semigroup a => a -> a -> a
<> Int -> PP a -> PP [a]
forall a. Int -> PP a -> PP [a]
count Int
0 K7 Tr r (a -> r)
PP a
p)

-- | Apply the given cassette zero or more times.
many :: PP a -> PP [a]
many :: forall a. PP a -> PP [a]
many PP a
p = PP a -> PP [a]
forall a. PP a -> PP [a]
some K7 Tr r (a -> r)
PP a
p K7 Tr r ([a] -> r) -> K7 Tr r ([a] -> r) -> K7 Tr r ([a] -> r)
forall a. Semigroup a => a -> a -> a
<> K7 Tr r ([a] -> r)
forall a r. K7 Tr r ([a] -> r)
nilL

-- | Apply the given cassette one or more times.
some :: PP a -> PP [a]
some :: forall a. PP a -> PP [a]
some PP a
p = K7 Tr (a -> [a] -> r) ([a] -> r)
forall a r. K7 Tr (a -> [a] -> r) ([a] -> r)
consL K7 Tr (a -> [a] -> r) ([a] -> r)
-> K7 Tr r (a -> [a] -> r) -> K7 Tr r ([a] -> r)
forall (p :: * -> * -> *) b c a.
Category p =>
K7 p b c -> K7 p a b -> K7 p a c
--> K7 Tr ([a] -> r) (a -> [a] -> r)
PP a
p K7 Tr ([a] -> r) (a -> [a] -> r)
-> K7 Tr r ([a] -> r) -> K7 Tr r (a -> [a] -> r)
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PP a -> PP [a]
forall a. PP a -> PP [a]
many K7 Tr r (a -> r)
PP a
p

-- | Apply the given cassette zero or more times, discarding the result.
skipMany :: PP a -> PP0
skipMany :: forall a. PP a -> PP0
skipMany PP a
p = [a] -> PP [a] -> PP0
forall a. a -> PP a -> PP0
unset [] (PP [a] -> PP0) -> PP [a] -> PP0
forall a b. (a -> b) -> a -> b
$ PP a -> PP [a]
forall a. PP a -> PP [a]
many K7 Tr r (a -> r)
PP a
p

-- | Apply the given cassette one or more times, discarding the result.
skipSome :: PP a -> PP0
skipSome :: forall a. PP a -> PP0
skipSome PP a
p = [a] -> PP [a] -> PP0
forall a. a -> PP a -> PP0
unset [] (PP [a] -> PP0) -> PP [a] -> PP0
forall a b. (a -> b) -> a -> b
$ PP a -> PP [a]
forall a. PP a -> PP [a]
some K7 Tr r (a -> r)
PP a
p

-- | Apply the first argument zero or more times, separated by the second
-- argument.
sepBy :: PP a -> PP0 -> PP [a]
sepBy :: forall a. PP a -> PP0 -> PP [a]
sepBy PP a
px PP0
psep = PP a -> PP0 -> PP [a]
forall a. PP a -> PP0 -> PP [a]
sepBy1 K7 Tr r (a -> r)
PP a
px K7 Tr r r
PP0
psep K7 Tr r ([a] -> r) -> K7 Tr r ([a] -> r) -> K7 Tr r ([a] -> r)
forall a. Semigroup a => a -> a -> a
<> K7 Tr r ([a] -> r)
forall a r. K7 Tr r ([a] -> r)
nilL

-- | Apply the first argument one or more times, separated by the second
-- argument.
sepBy1 :: PP a -> PP0 -> PP [a]
sepBy1 :: forall a. PP a -> PP0 -> PP [a]
sepBy1 PP a
px PP0
psep = K7 Tr (a -> [a] -> r) ([a] -> r)
forall a r. K7 Tr (a -> [a] -> r) ([a] -> r)
consL K7 Tr (a -> [a] -> r) ([a] -> r)
-> K7 Tr r (a -> [a] -> r) -> K7 Tr r ([a] -> r)
forall (p :: * -> * -> *) b c a.
Category p =>
K7 p b c -> K7 p a b -> K7 p a c
--> K7 Tr ([a] -> r) (a -> [a] -> r)
PP a
px K7 Tr ([a] -> r) (a -> [a] -> r)
-> K7 Tr r ([a] -> r) -> K7 Tr r (a -> [a] -> r)
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PP a -> PP [a]
forall a. PP a -> PP [a]
many (K7 Tr (a -> r) (a -> r)
PP0
psep K7 Tr (a -> r) (a -> r) -> K7 Tr r (a -> r) -> K7 Tr r (a -> r)
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. K7 Tr r (a -> r)
PP a
px)

-- | @chainl p op x@ matches zero or more occurrences of @p@, separated by @op@.
-- Returns a value obtained by a /left associative/ application of all functions
-- returned by @op@ to the values returned by @p@. If there are zero occurrences
-- of @p@, the value @x@ is returned.
chainl :: PP0 -> BinL a a a -> PP a -> a -> PP a
chainl :: forall a. PP0 -> BinL a a a -> PP a -> a -> PP a
chainl PP0
opP BinL a a a
opL PP a
xP a
dflt = PP0 -> BinL a a a -> PP a -> PP a
forall a. PP0 -> BinL a a a -> PP a -> PP a
chainl1 K7 Tr r r
PP0
opP K7 Tr (a -> a -> r) (a -> r)
BinL a a a
opL K7 Tr r (a -> r)
PP a
xP K7 Tr r (a -> r) -> K7 Tr r (a -> r) -> K7 Tr r (a -> r)
forall a. Semigroup a => a -> a -> a
<> a -> PP0 -> PP a
forall a. a -> PP0 -> PP a
set a
dflt K7 Tr r r
PP0
nothing

-- | Match a left-associative chain of infix operators.
chainl1 :: PP0 -> BinL a a a -> PP a -> PP a
chainl1 :: forall a. PP0 -> BinL a a a -> PP a -> PP a
chainl1 PP0
opP BinL a a a
opL PP a
xP = BinL a a a -> BinL a a [a]
forall a b. BinL a a b -> BinL a a [b]
catanal K7 Tr (a -> a -> r) (a -> r)
BinL a a a
opL K7 Tr (a -> [a] -> r) (a -> r)
-> K7 Tr r (a -> [a] -> r) -> K7 Tr r (a -> r)
forall (p :: * -> * -> *) b c a.
Category p =>
K7 p b c -> K7 p a b -> K7 p a c
--> K7 Tr ([a] -> r) (a -> [a] -> r)
PP a
xP K7 Tr ([a] -> r) (a -> [a] -> r)
-> K7 Tr r ([a] -> r) -> K7 Tr r (a -> [a] -> r)
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PP a -> PP [a]
forall a. PP a -> PP [a]
many (K7 Tr (a -> r) (a -> r)
PP0
opP K7 Tr (a -> r) (a -> r) -> K7 Tr r (a -> r) -> K7 Tr r (a -> r)
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. K7 Tr r (a -> r)
PP a
xP)

-- | @chainr p op x@ matches zero or more occurrences of @p@, separated by @op@.
-- Returns a value obtained by a /right associative/ application of all
-- functions returned by @op@ to the values returned by @p@. If there are zero
-- occurrences of @p@, the value @x@ is returned.
chainr :: PP0 -> BinL a a a -> PP a -> a -> PP a
chainr :: forall a. PP0 -> BinL a a a -> PP a -> a -> PP a
chainr PP0
opP BinL a a a
opL PP a
xP a
dflt = PP0 -> BinL a a a -> PP a -> PP a
forall a. PP0 -> BinL a a a -> PP a -> PP a
chainr1 K7 Tr r r
PP0
opP K7 Tr (a -> a -> r) (a -> r)
BinL a a a
opL K7 Tr r (a -> r)
PP a
xP K7 Tr r (a -> r) -> K7 Tr r (a -> r) -> K7 Tr r (a -> r)
forall a. Semigroup a => a -> a -> a
<> a -> PP0 -> PP a
forall a. a -> PP0 -> PP a
set a
dflt K7 Tr r r
PP0
nothing

-- | Match a right-associative chain of infix operators.
chainr1 :: PP0 -> BinL a a a -> PP a -> PP a
chainr1 :: forall a. PP0 -> BinL a a a -> PP a -> PP a
chainr1 PP0
opP BinL a a a
opL PP a
xP = BinL a a a -> BinL a a [a]
forall b a. BinL b a b -> BinL b b [a]
catanar K7 Tr (a -> a -> r) (a -> r)
BinL a a a
opL K7 Tr (a -> [a] -> r) (a -> r)
-> K7 Tr r (a -> [a] -> r) -> K7 Tr r (a -> r)
forall (p :: * -> * -> *) b c a.
Category p =>
K7 p b c -> K7 p a b -> K7 p a c
--> K7 Tr ([a] -> r) (a -> [a] -> r)
PP a
xP K7 Tr ([a] -> r) (a -> [a] -> r)
-> K7 Tr r ([a] -> r) -> K7 Tr r (a -> [a] -> r)
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PP a -> PP [a]
forall a. PP a -> PP [a]
many (K7 Tr (a -> r) (a -> r)
PP0
opP K7 Tr (a -> r) (a -> r) -> K7 Tr r (a -> r) -> K7 Tr r (a -> r)
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. K7 Tr r (a -> r)
PP a
xP)

-- | @notFollowedBy p@ only succeeds when @p@ fails. This combinator does not
-- consume\/produce any input.
notFollowedBy :: PP0 -> PP0
notFollowedBy :: PP0 -> PP0
notFollowedBy PP0
p = () -> PP () -> PP0
forall a. a -> PP a -> PP0
unset () (PP () -> PP0) -> PP () -> PP0
forall a b. (a -> b) -> a -> b
$ () -> PP0 -> PP ()
forall a. a -> PP0 -> PP a
set () (K7 Tr r r
PP0
p K7 Tr r r -> K7 Tr r r -> K7 Tr r r
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. K7 Tr r r
forall a. Monoid a => a
mempty) K7 Tr r (() -> r) -> K7 Tr r (() -> r) -> K7 Tr r (() -> r)
forall a. Semigroup a => a -> a -> a
<> () -> PP0 -> PP ()
forall a. a -> PP0 -> PP a
set () K7 Tr r r
PP0
nothing

-- | Applies first argument zero or more times until second argument succeeds.
manyTill :: PP a -> PP0 -> PP [a]
manyTill :: forall a. PP a -> PP0 -> PP [a]
manyTill PP a
xP PP0
endP = K7 Tr r ([a] -> r)
forall a r. K7 Tr r ([a] -> r)
nilL K7 Tr r ([a] -> r) -> K7 Tr r r -> K7 Tr r ([a] -> r)
forall (p :: * -> * -> *) b c a.
Category p =>
K7 p b c -> K7 p a b -> K7 p a c
--> K7 Tr r r
PP0
endP K7 Tr r ([a] -> r) -> K7 Tr r ([a] -> r) -> K7 Tr r ([a] -> r)
forall a. Semigroup a => a -> a -> a
<> K7 Tr (a -> [a] -> r) ([a] -> r)
forall a r. K7 Tr (a -> [a] -> r) ([a] -> r)
consL K7 Tr (a -> [a] -> r) ([a] -> r)
-> K7 Tr r (a -> [a] -> r) -> K7 Tr r ([a] -> r)
forall (p :: * -> * -> *) b c a.
Category p =>
K7 p b c -> K7 p a b -> K7 p a c
--> K7 Tr ([a] -> r) (a -> [a] -> r)
PP a
xP K7 Tr ([a] -> r) (a -> [a] -> r)
-> K7 Tr r ([a] -> r) -> K7 Tr r (a -> [a] -> r)
forall b c a. K7 Tr b c -> K7 Tr a b -> K7 Tr a c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. PP a -> PP0 -> PP [a]
forall a. PP a -> PP0 -> PP [a]
manyTill K7 Tr r (a -> r)
PP a
xP K7 Tr r r
PP0
endP