-- |
-- Generic helpers for HeadedMegaparsec.
module PostgresqlSyntax.Extras.HeadedMegaparsec where

import Control.Applicative.Combinators hiding (some)
import Control.Applicative.Combinators.NonEmpty
import qualified Data.Text as Text
import HeadedMegaparsec hiding (string)
import PostgresqlSyntax.Prelude hiding (bit, expr, filter, head, many, option, some, sortBy, tail, try)
import Text.Megaparsec (Parsec, Stream, TraversableStream, VisualStream)
import qualified Text.Megaparsec as Megaparsec
import qualified Text.Megaparsec.Char as MegaparsecChar
import qualified Text.Megaparsec.Char.Lexer as MegaparsecLexer

-- $setup
-- >>> testParser parser = either putStr print . run parser

-- * Executors

run :: (Ord err, VisualStream strm, TraversableStream strm, Megaparsec.ShowErrorComponent err) => HeadedParsec err strm a -> strm -> Either String a
run :: HeadedParsec err strm a -> strm -> Either String a
run HeadedParsec err strm a
p = (ParseErrorBundle strm err -> String)
-> Either (ParseErrorBundle strm err) a -> Either String a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle strm err -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
Megaparsec.errorBundlePretty (Either (ParseErrorBundle strm err) a -> Either String a)
-> (strm -> Either (ParseErrorBundle strm err) a)
-> strm
-> Either String a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parsec err strm a
-> String -> strm -> Either (ParseErrorBundle strm err) a
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Megaparsec.runParser (HeadedParsec err strm a -> Parsec err strm a
forall err strm a.
(Ord err, Stream strm) =>
HeadedParsec err strm a -> Parsec err strm a
toParsec HeadedParsec err strm a
p Parsec err strm a
-> ParsecT err strm Identity () -> Parsec err strm a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT err strm Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof) String
""

-- * Primitives

-- |
-- Lifted megaparsec\'s `Megaparsec.eof`.
eof :: (Ord err, Stream strm) => HeadedParsec err strm ()
eof :: HeadedParsec err strm ()
eof = Parsec err strm () -> HeadedParsec err strm ()
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse Parsec err strm ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Megaparsec.eof

-- |
-- Lifted megaparsec\'s `Megaparsec.space`.
space :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm ()
space :: HeadedParsec err strm ()
space = Parsec err strm () -> HeadedParsec err strm ()
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse Parsec err strm ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MegaparsecChar.space

-- |
-- Lifted megaparsec\'s `Megaparsec.space1`.
space1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm ()
space1 :: HeadedParsec err strm ()
space1 = Parsec err strm () -> HeadedParsec err strm ()
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse Parsec err strm ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
MegaparsecChar.space1

-- |
-- Lifted megaparsec\'s `Megaparsec.char`.
char :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => Char -> HeadedParsec err strm Char
char :: Char -> HeadedParsec err strm Char
char Char
a = Parsec err strm Char -> HeadedParsec err strm Char
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse (Token strm -> ParsecT err strm Identity (Token strm)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
MegaparsecChar.char Char
Token strm
a)

-- |
-- Lifted megaparsec\'s `Megaparsec.char'`.
char' :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => Char -> HeadedParsec err strm Char
char' :: Char -> HeadedParsec err strm Char
char' Char
a = Parsec err strm Char -> HeadedParsec err strm Char
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse (Token strm -> ParsecT err strm Identity (Token strm)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
MegaparsecChar.char' Char
Token strm
a)

-- |
-- Lifted megaparsec\'s `Megaparsec.string`.
string :: (Ord err, Stream strm) => Megaparsec.Tokens strm -> HeadedParsec err strm (Megaparsec.Tokens strm)
string :: Tokens strm -> HeadedParsec err strm (Tokens strm)
string = Parsec err strm (Tokens strm)
-> HeadedParsec err strm (Tokens strm)
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse (Parsec err strm (Tokens strm)
 -> HeadedParsec err strm (Tokens strm))
-> (Tokens strm -> Parsec err strm (Tokens strm))
-> Tokens strm
-> HeadedParsec err strm (Tokens strm)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Tokens strm -> Parsec err strm (Tokens strm)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
MegaparsecChar.string

-- |
-- Lifted megaparsec\'s `Megaparsec.string'`.
string' :: (Ord err, Stream strm, FoldCase (Megaparsec.Tokens strm)) => Megaparsec.Tokens strm -> HeadedParsec err strm (Megaparsec.Tokens strm)
string' :: Tokens strm -> HeadedParsec err strm (Tokens strm)
string' = Parsec err strm (Tokens strm)
-> HeadedParsec err strm (Tokens strm)
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse (Parsec err strm (Tokens strm)
 -> HeadedParsec err strm (Tokens strm))
-> (Tokens strm -> Parsec err strm (Tokens strm))
-> Tokens strm
-> HeadedParsec err strm (Tokens strm)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Tokens strm -> Parsec err strm (Tokens strm)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
MegaparsecChar.string'

-- |
-- Lifted megaparsec\'s `Megaparsec.takeWhileP`.
takeWhileP :: (Ord err, Stream strm) => Maybe String -> (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Tokens strm)
takeWhileP :: Maybe String
-> (Token strm -> Bool) -> HeadedParsec err strm (Tokens strm)
takeWhileP Maybe String
label Token strm -> Bool
predicate = Parsec err strm (Tokens strm)
-> HeadedParsec err strm (Tokens strm)
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse (Maybe String
-> (Token strm -> Bool) -> Parsec err strm (Tokens strm)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhileP Maybe String
label Token strm -> Bool
predicate)

-- |
-- Lifted megaparsec\'s `Megaparsec.takeWhile1P`.
takeWhile1P :: (Ord err, Stream strm) => Maybe String -> (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Tokens strm)
takeWhile1P :: Maybe String
-> (Token strm -> Bool) -> HeadedParsec err strm (Tokens strm)
takeWhile1P Maybe String
label Token strm -> Bool
predicate = Parsec err strm (Tokens strm)
-> HeadedParsec err strm (Tokens strm)
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse (Maybe String
-> (Token strm -> Bool) -> Parsec err strm (Tokens strm)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Megaparsec.takeWhile1P Maybe String
label Token strm -> Bool
predicate)

satisfy :: (Ord err, Stream strm) => (Megaparsec.Token strm -> Bool) -> HeadedParsec err strm (Megaparsec.Token strm)
satisfy :: (Token strm -> Bool) -> HeadedParsec err strm (Token strm)
satisfy = Parsec err strm (Token strm) -> HeadedParsec err strm (Token strm)
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse (Parsec err strm (Token strm)
 -> HeadedParsec err strm (Token strm))
-> ((Token strm -> Bool) -> Parsec err strm (Token strm))
-> (Token strm -> Bool)
-> HeadedParsec err strm (Token strm)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Token strm -> Bool) -> Parsec err strm (Token strm)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
Megaparsec.satisfy

decimal :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char, Integral decimal) => HeadedParsec err strm decimal
decimal :: HeadedParsec err strm decimal
decimal = Parsec err strm decimal -> HeadedParsec err strm decimal
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse Parsec err strm decimal
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
MegaparsecLexer.decimal

float :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char, RealFloat float) => HeadedParsec err strm float
float :: HeadedParsec err strm float
float = Parsec err strm float -> HeadedParsec err strm float
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse Parsec err strm float
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, RealFloat a) =>
m a
MegaparsecLexer.float

-- * Combinators

sep1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separtor -> HeadedParsec err strm a -> HeadedParsec err strm (NonEmpty a)
sep1 :: HeadedParsec err strm separtor
-> HeadedParsec err strm a -> HeadedParsec err strm (NonEmpty a)
sep1 HeadedParsec err strm separtor
_separator HeadedParsec err strm a
_parser = do
  a
_head <- HeadedParsec err strm a
_parser
  HeadedParsec err strm ()
forall strm err. Stream strm => HeadedParsec err strm ()
endHead
  [a]
_tail <- HeadedParsec err strm a -> HeadedParsec err strm [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (HeadedParsec err strm a -> HeadedParsec err strm [a])
-> HeadedParsec err strm a -> HeadedParsec err strm [a]
forall a b. (a -> b) -> a -> b
$ HeadedParsec err strm separtor
_separator HeadedParsec err strm separtor
-> HeadedParsec err strm a -> HeadedParsec err strm a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> HeadedParsec err strm a
_parser
  return (a
_head a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
_tail)

sepEnd1 :: (Ord err, Stream strm, Megaparsec.Token strm ~ Char) => HeadedParsec err strm separator -> HeadedParsec err strm end -> HeadedParsec err strm el -> HeadedParsec err strm (NonEmpty el, end)
sepEnd1 :: HeadedParsec err strm separator
-> HeadedParsec err strm end
-> HeadedParsec err strm el
-> HeadedParsec err strm (NonEmpty el, end)
sepEnd1 HeadedParsec err strm separator
sepP HeadedParsec err strm end
endP HeadedParsec err strm el
elP = do
  el
headEl <- HeadedParsec err strm el
elP
  let loop :: [el] -> HeadedParsec err strm (NonEmpty el, end)
loop ![el]
list = do
        HeadedParsec err strm separator
sepP
        [HeadedParsec err strm (NonEmpty el, end)]
-> HeadedParsec err strm (NonEmpty el, end)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
          [ do
              end
end <- HeadedParsec err strm end
endP
              return (el
headEl el -> [el] -> NonEmpty el
forall a. a -> [a] -> NonEmpty a
:| [el] -> [el]
forall a. [a] -> [a]
reverse [el]
list, end
end),
            do
              el
el <- HeadedParsec err strm el
elP
              [el] -> HeadedParsec err strm (NonEmpty el, end)
loop (el
el el -> [el] -> [el]
forall a. a -> [a] -> [a]
: [el]
list)
          ]
   in [el] -> HeadedParsec err strm (NonEmpty el, end)
loop []

notFollowedBy :: (Ord err, Stream strm) => HeadedParsec err strm a -> HeadedParsec err strm ()
notFollowedBy :: HeadedParsec err strm a -> HeadedParsec err strm ()
notFollowedBy HeadedParsec err strm a
a = Parsec err strm () -> HeadedParsec err strm ()
forall err strm a.
(Ord err, Stream strm) =>
Parsec err strm a -> HeadedParsec err strm a
parse (ParsecT err strm Identity a -> Parsec err strm ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
Megaparsec.notFollowedBy (HeadedParsec err strm a -> ParsecT err strm Identity a
forall err strm a.
(Ord err, Stream strm) =>
HeadedParsec err strm a -> Parsec err strm a
toParsec HeadedParsec err strm a
a))