{-# LANGUAGE CPP                   #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}

{-| This module contains Dhall's parser combinators
-}

module Dhall.Parser.Combinators
    ( Parser(..)
    , SourcedException(..)
    , laxSrcEq
    , count
    , range
    , option
    , star
    , plus
    , satisfy
    , Dhall.Parser.Combinators.takeWhile
    , takeWhile1
    , toMap
    , toMapWith
    , base
    ) where


import Control.Applicative     (Alternative (..), liftA2)
import Control.Exception       (Exception)
import Control.Monad           (MonadPlus (..))
import Data.String             (IsString (..))
import Data.Text               (Text)
import Data.Void               (Void)
import Dhall.Map               (Map)
import Dhall.Src               (Src (..))
import Prettyprinter           (Pretty (..))
import Text.Parser.Combinators (try, (<?>))
import Text.Parser.Token       (TokenParsing (..))

import qualified Control.Monad.Fail
import qualified Data.Char                   as Char
import qualified Data.Text
import qualified Dhall.Map
import qualified Dhall.Pretty
import qualified Prettyprinter.Render.String as Pretty
import qualified Text.Megaparsec
import qualified Text.Megaparsec.Char
import qualified Text.Parser.Char
import qualified Text.Parser.Combinators
import qualified Text.Parser.Token.Style

-- | An exception annotated with a `Src` span
data SourcedException e = SourcedException Src e

instance Exception e => Exception (SourcedException e)

instance Show e => Show (SourcedException e) where
    show :: SourcedException e -> String
show (SourcedException Src
source e
exception) =
            e -> String
forall a. Show a => a -> String
show e
exception
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<>  SimpleDocStream Any -> String
forall ann. SimpleDocStream ann -> String
Pretty.renderString
                (Doc Any -> SimpleDocStream Any
forall ann. Doc ann -> SimpleDocStream ann
Dhall.Pretty.layout (Src -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Src
source))

-- | Doesn't force the 'Data.Text.Text' part
laxSrcEq :: Src -> Src -> Bool
laxSrcEq :: Src -> Src -> Bool
laxSrcEq (Src SourcePos
p SourcePos
q Text
_) (Src SourcePos
p' SourcePos
q' Text
_) = SourcePos -> SourcePos -> Bool
eq SourcePos
p SourcePos
p' Bool -> Bool -> Bool
&& SourcePos -> SourcePos -> Bool
eq SourcePos
q SourcePos
q'
  where
    -- Don't compare filename (which is FilePath = String)
    eq  :: Text.Megaparsec.SourcePos -> Text.Megaparsec.SourcePos -> Bool
    eq :: SourcePos -> SourcePos -> Bool
eq (Text.Megaparsec.SourcePos String
_ Pos
a Pos
b) (Text.Megaparsec.SourcePos String
_ Pos
a' Pos
b') =
        Pos
a Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
a' Bool -> Bool -> Bool
&& Pos
b Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
b'
{-# INLINE laxSrcEq #-}

{-| A `Parser` that is almost identical to
    @"Text.Megaparsec".`Text.Megaparsec.Parsec`@ except treating Haskell-style
    comments as whitespace
-}
newtype Parser a = Parser { Parser a -> Parsec Void Text a
unParser :: Text.Megaparsec.Parsec Void Text a }

instance Functor Parser where
    fmap :: (a -> b) -> Parser a -> Parser b
fmap a -> b
f (Parser Parsec Void Text a
x) = Parsec Void Text b -> Parser b
forall a. Parsec Void Text a -> Parser a
Parser ((a -> b) -> Parsec Void Text a -> Parsec Void Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Parsec Void Text a
x)
    {-# INLINE fmap #-}

    a
f <$ :: a -> Parser b -> Parser a
<$ Parser Parsec Void Text b
x = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (a
f a -> Parsec Void Text b -> Parsec Void Text a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parsec Void Text b
x)
    {-# INLINE (<$) #-}

instance Applicative Parser where
    pure :: a -> Parser a
pure = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a -> Parser a)
-> (a -> Parsec Void Text a) -> a -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Parsec Void Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE pure #-}

    Parser Parsec Void Text (a -> b)
f <*> :: Parser (a -> b) -> Parser a -> Parser b
<*> Parser Parsec Void Text a
x = Parsec Void Text b -> Parser b
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text (a -> b)
f Parsec Void Text (a -> b)
-> Parsec Void Text a -> Parsec Void Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Void Text a
x)
    {-# INLINE (<*>) #-}

    Parser Parsec Void Text a
a <* :: Parser a -> Parser b -> Parser a
<* Parser Parsec Void Text b
b = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a
a Parsec Void Text a -> Parsec Void Text b -> Parsec Void Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parsec Void Text b
b)
    {-# INLINE (<*) #-}

    Parser Parsec Void Text a
a *> :: Parser a -> Parser b -> Parser b
*> Parser Parsec Void Text b
b = Parsec Void Text b -> Parser b
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a
a Parsec Void Text a -> Parsec Void Text b -> Parsec Void Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text b
b)
    {-# INLINE (*>) #-}

instance Monad Parser where
    return :: a -> Parser a
return = a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    {-# INLINE return #-}

    >> :: Parser a -> Parser b -> Parser b
(>>) = Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    {-# INLINE (>>) #-}

    Parser Parsec Void Text a
n >>= :: Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
k = Parsec Void Text b -> Parser b
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a
n Parsec Void Text a
-> (a -> Parsec Void Text b) -> Parsec Void Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser b -> Parsec Void Text b
forall a. Parser a -> Parsec Void Text a
unParser (Parser b -> Parsec Void Text b)
-> (a -> Parser b) -> a -> Parsec Void Text b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Parser b
k)
    {-# INLINE (>>=) #-}

#if !(MIN_VERSION_base(4,13,0))
    fail = Control.Monad.Fail.fail
    {-# INLINE fail #-}
#endif

instance Control.Monad.Fail.MonadFail Parser where
    fail :: String -> Parser a
fail = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a -> Parser a)
-> (String -> Parsec Void Text a) -> String -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parsec Void Text a
forall (m :: * -> *) a. MonadFail m => String -> m a
Control.Monad.Fail.fail
    {-# INLINE fail #-}

instance Alternative Parser where
    empty :: Parser a
empty = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser Parsec Void Text a
forall (f :: * -> *) a. Alternative f => f a
empty
    -- {-# INLINE empty #-}

    Parser Parsec Void Text a
a <|> :: Parser a -> Parser a -> Parser a
<|> Parser Parsec Void Text a
b = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a
a Parsec Void Text a -> Parsec Void Text a -> Parsec Void Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Void Text a
b)
    -- {-# INLINE (<|>) #-}

    some :: Parser a -> Parser [a]
some (Parser Parsec Void Text a
a) = Parsec Void Text [a] -> Parser [a]
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a -> Parsec Void Text [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some Parsec Void Text a
a)
    -- {-# INLINE some #-}

    many :: Parser a -> Parser [a]
many (Parser Parsec Void Text a
a) = Parsec Void Text [a] -> Parser [a]
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a -> Parsec Void Text [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parsec Void Text a
a)
    -- {-# INLINE many #-}

instance MonadPlus Parser where
    mzero :: Parser a
mzero = Parser a
forall (f :: * -> *) a. Alternative f => f a
empty
    -- {-# INLINE mzero #-}

    mplus :: Parser a -> Parser a -> Parser a
mplus = Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
    -- {-# INLINE mplus #-}

instance Text.Megaparsec.MonadParsec Void Text Parser where
    parseError :: ParseError Text Void -> Parser a
parseError ParseError Text Void
e = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (ParseError Text Void -> Parsec Void Text a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
Text.Megaparsec.parseError ParseError Text Void
e)

    label :: String -> Parser a -> Parser a
label String
l (Parser Parsec Void Text a
p) = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (String -> Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
Text.Megaparsec.label String
l Parsec Void Text a
p)

    hidden :: Parser a -> Parser a
hidden (Parser Parsec Void Text a
p) = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Text.Megaparsec.hidden Parsec Void Text a
p)

    try :: Parser a -> Parser a
try (Parser Parsec Void Text a
p) = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Text.Megaparsec.try Parsec Void Text a
p)

    lookAhead :: Parser a -> Parser a
lookAhead (Parser Parsec Void Text a
p) = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Text.Megaparsec.lookAhead Parsec Void Text a
p)

    notFollowedBy :: Parser a -> Parser ()
notFollowedBy (Parser Parsec Void Text a
p) = Parsec Void Text () -> Parser ()
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a -> Parsec Void Text ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
Text.Megaparsec.notFollowedBy Parsec Void Text a
p)

    withRecovery :: (ParseError Text Void -> Parser a) -> Parser a -> Parser a
withRecovery ParseError Text Void -> Parser a
e (Parser Parsec Void Text a
p) = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser ((ParseError Text Void -> Parsec Void Text a)
-> Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(ParseError s e -> m a) -> m a -> m a
Text.Megaparsec.withRecovery (Parser a -> Parsec Void Text a
forall a. Parser a -> Parsec Void Text a
unParser (Parser a -> Parsec Void Text a)
-> (ParseError Text Void -> Parser a)
-> ParseError Text Void
-> Parsec Void Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError Text Void -> Parser a
e) Parsec Void Text a
p)

    observing :: Parser a -> Parser (Either (ParseError Text Void) a)
observing (Parser Parsec Void Text a
p) = Parsec Void Text (Either (ParseError Text Void) a)
-> Parser (Either (ParseError Text Void) a)
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text a
-> Parsec Void Text (Either (ParseError Text Void) a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Either (ParseError s e) a)
Text.Megaparsec.observing Parsec Void Text a
p)

    eof :: Parser ()
eof = Parsec Void Text () -> Parser ()
forall a. Parsec Void Text a -> Parser a
Parser Parsec Void Text ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Text.Megaparsec.eof

    token :: (Token Text -> Maybe a) -> Set (ErrorItem (Token Text)) -> Parser a
token Token Text -> Maybe a
f Set (ErrorItem (Token Text))
e = Parsec Void Text a -> Parser a
forall a. Parsec Void Text a -> Parser a
Parser ((Token Text -> Maybe a)
-> Set (ErrorItem (Token Text)) -> Parsec Void Text a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Maybe a) -> Set (ErrorItem (Token s)) -> m a
Text.Megaparsec.token Token Text -> Maybe a
f Set (ErrorItem (Token Text))
e)

    tokens :: (Tokens Text -> Tokens Text -> Bool)
-> Tokens Text -> Parser (Tokens Text)
tokens Tokens Text -> Tokens Text -> Bool
f Tokens Text
ts = Parsec Void Text Text -> Parser Text
forall a. Parsec Void Text a -> Parser a
Parser ((Tokens Text -> Tokens Text -> Bool)
-> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Tokens s -> Tokens s -> Bool) -> Tokens s -> m (Tokens s)
Text.Megaparsec.tokens Tokens Text -> Tokens Text -> Bool
f Tokens Text
ts)

    takeWhileP :: Maybe String -> (Token Text -> Bool) -> Parser (Tokens Text)
takeWhileP Maybe String
s Token Text -> Bool
f = Parsec Void Text Text -> Parser Text
forall a. Parsec Void Text a -> Parser a
Parser (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Text.Megaparsec.takeWhileP Maybe String
s Token Text -> Bool
f)

    takeWhile1P :: Maybe String -> (Token Text -> Bool) -> Parser (Tokens Text)
takeWhile1P Maybe String
s Token Text -> Bool
f = Parsec Void Text Text -> Parser Text
forall a. Parsec Void Text a -> Parser a
Parser (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Text.Megaparsec.takeWhile1P Maybe String
s Token Text -> Bool
f)

    takeP :: Maybe String -> Int -> Parser (Tokens Text)
takeP Maybe String
s Int
n = Parsec Void Text Text -> Parser Text
forall a. Parsec Void Text a -> Parser a
Parser (Maybe String -> Int -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> Int -> m (Tokens s)
Text.Megaparsec.takeP Maybe String
s Int
n)

    getParserState :: Parser (State Text Void)
getParserState = Parsec Void Text (State Text Void) -> Parser (State Text Void)
forall a. Parsec Void Text a -> Parser a
Parser Parsec Void Text (State Text Void)
forall e s (m :: * -> *). MonadParsec e s m => m (State s e)
Text.Megaparsec.getParserState
    {-# INLINE getParserState #-}

    updateParserState :: (State Text Void -> State Text Void) -> Parser ()
updateParserState State Text Void -> State Text Void
f = Parsec Void Text () -> Parser ()
forall a. Parsec Void Text a -> Parser a
Parser ((State Text Void -> State Text Void) -> Parsec Void Text ()
forall e s (m :: * -> *).
MonadParsec e s m =>
(State s e -> State s e) -> m ()
Text.Megaparsec.updateParserState State Text Void -> State Text Void
f)

instance Semigroup a => Semigroup (Parser a) where
    <> :: Parser a -> Parser a -> Parser a
(<>) = (a -> a -> a) -> Parser a -> Parser a -> Parser 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
(<>)

instance (Semigroup a, Monoid a) => Monoid (Parser a) where
    mempty :: Parser a
mempty = a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

instance IsString a => IsString (Parser a) where
    fromString :: String -> Parser a
fromString String
x = String -> a
forall a. IsString a => String -> a
fromString String
x a -> Parser Text -> Parser a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens Text -> Parser (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Text.Megaparsec.Char.string (String -> Text
forall a. IsString a => String -> a
fromString String
x)

instance Text.Parser.Combinators.Parsing Parser where
  try :: Parser a -> Parser a
try = Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
Text.Megaparsec.try

  <?> :: Parser a -> String -> Parser a
(<?>) = Parser a -> String -> Parser a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
(Text.Megaparsec.<?>)

  skipMany :: Parser a -> Parser ()
skipMany = Parser a -> Parser ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
Text.Megaparsec.skipMany

  skipSome :: Parser a -> Parser ()
skipSome = Parser a -> Parser ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
Text.Megaparsec.skipSome

  unexpected :: String -> Parser a
unexpected = String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

  eof :: Parser ()
eof = Parsec Void Text () -> Parser ()
forall a. Parsec Void Text a -> Parser a
Parser Parsec Void Text ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
Text.Megaparsec.eof

  notFollowedBy :: Parser a -> Parser ()
notFollowedBy = Parser a -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
Text.Megaparsec.notFollowedBy

instance Text.Parser.Char.CharParsing Parser where
  satisfy :: (Char -> Bool) -> Parser Char
satisfy = Parsec Void Text Char -> Parser Char
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text Char -> Parser Char)
-> ((Char -> Bool) -> Parsec Void Text Char)
-> (Char -> Bool)
-> Parser Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Parsec Void Text Char
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
Text.Megaparsec.satisfy

  char :: Char -> Parser Char
char = Char -> Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Text.Megaparsec.Char.char

  notChar :: Char -> Parser Char
notChar = Char -> Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Text.Megaparsec.Char.char

  anyChar :: Parser Char
anyChar = Parser Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
Text.Megaparsec.anySingle

  string :: String -> Parser String
string = (Text -> String) -> Parser Text -> Parser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
Data.Text.unpack (Parser Text -> Parser String)
-> (String -> Parser Text) -> String -> Parser String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Text.Megaparsec.Char.string (Text -> Parser Text) -> (String -> Text) -> String -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

  text :: Text -> Parser Text
text = Text -> Parser Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
Text.Megaparsec.Char.string

instance TokenParsing Parser where
    someSpace :: Parser ()
someSpace =
        Parser () -> CommentStyle -> Parser ()
forall (m :: * -> *). CharParsing m => m () -> CommentStyle -> m ()
Text.Parser.Token.Style.buildSomeSpaceParser
            (Parsec Void Text () -> Parser ()
forall a. Parsec Void Text a -> Parser a
Parser (Parsec Void Text Char -> Parsec Void Text ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
Text.Megaparsec.skipSome ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
Text.Megaparsec.satisfy Char -> Bool
Token Text -> Bool
Char.isSpace)))
            CommentStyle
Text.Parser.Token.Style.haskellCommentStyle

    highlight :: Highlight -> Parser a -> Parser a
highlight Highlight
_ = Parser a -> Parser a
forall a. a -> a
id

    semi :: Parser Char
semi = Parser Char -> Parser Char
forall (m :: * -> *) a. TokenParsing m => m a -> m a
token (Token Text -> Parser (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
Text.Megaparsec.Char.char Char
Token Text
';' Parser Char -> String -> Parser Char
forall (m :: * -> *) a. Parsing m => m a -> String -> m a
<?> String
";")

-- | @count n p@ parses @n@ occurrences of @p@
count :: (Semigroup a, Monoid a) => Int -> Parser a -> Parser a
count :: Int -> Parser a -> Parser a
count Int
n Parser a
parser = [Parser a] -> Parser a
forall a. Monoid a => [a] -> a
mconcat (Int -> Parser a -> [Parser a]
forall a. Int -> a -> [a]
replicate Int
n Parser a
parser)

-- | @range lo hi p@ parses @n@ ocurrences of @p@ where @lo <= n <= hi@
range :: (Semigroup a, Monoid a) => Int -> Int -> Parser a -> Parser a
range :: Int -> Int -> Parser a -> Parser a
range Int
minimumBound Int
maximumMatches Parser a
parser =
    Int -> Parser a -> Parser a
forall a. (Semigroup a, Monoid a) => Int -> Parser a -> Parser a
count Int
minimumBound Parser a
parser Parser a -> Parser a -> Parser a
forall a. Semigroup a => a -> a -> a
<> Int -> Parser a
forall t. (Eq t, Num t) => t -> Parser a
loop Int
maximumMatches
  where
    loop :: t -> Parser a
loop t
0 = Parser a
forall a. Monoid a => a
mempty
    loop t
n = (Parser a
parser Parser a -> Parser a -> Parser a
forall a. Semigroup a => a -> a -> a
<> t -> Parser a
loop (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1)) Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser a
forall a. Monoid a => a
mempty

-- | @option p@ tries to apply parser @p@ returning @mempty@ if parsing failed
option :: (Alternative f, Monoid a) => f a -> f a
option :: f a -> f a
option f a
p = f a
p f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

-- | @star p@ tries to apply a parser @0@ or more times
star :: (Alternative f, Monoid a) => f a -> f a
star :: f a -> f a
star f a
p = f a -> f a
forall (f :: * -> *) a. (Alternative f, Monoid a) => f a -> f a
plus f a
p f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty

-- | @plus p@ tries to apply a parser @1@ or more times
plus :: (Alternative f, Monoid a) => f a -> f a
plus :: f a -> f a
plus f a
p = a -> a -> a
forall a. Monoid a => a -> a -> a
mappend (a -> a -> a) -> f a -> f (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
p f (a -> a) -> f a -> f a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a -> f a
forall (f :: * -> *) a. (Alternative f, Monoid a) => f a -> f a
star f a
p

-- | @satisfy p@ creates a parser that consumes and return the next character
--   if it satisfies the predicate @p@
satisfy :: (Char -> Bool) -> Parser Text
satisfy :: (Char -> Bool) -> Parser Text
satisfy = (Char -> Text) -> Parser Char -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Text
Data.Text.singleton (Parser Char -> Parser Text)
-> ((Char -> Bool) -> Parser Char) -> (Char -> Bool) -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Parser Char
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
Text.Parser.Char.satisfy

-- | @takeWhile p@ creates a parser that accepts the longest sequence of characters
--   that match the given predicate possibly returning an empty sequence
takeWhile :: (Char -> Bool) -> Parser Text
takeWhile :: (Char -> Bool) -> Parser Text
takeWhile Char -> Bool
predicate = Parsec Void Text Text -> Parser Text
forall a. Parsec Void Text a -> Parser a
Parser (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Text.Megaparsec.takeWhileP Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
predicate)

-- | @takeWhile1 p@ creates a parser that accepts the longest sequence of characters
--   that match the given predicate. It fails when no character was consumed
takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
predicate = Parsec Void Text Text -> Parser Text
forall a. Parsec Void Text a -> Parser a
Parser (Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
Text.Megaparsec.takeWhile1P Maybe String
forall a. Maybe a
Nothing Char -> Bool
Token Text -> Bool
predicate)

-- | Creates a map with the given key-value pairs, failing if there was a
--   duplicate key.
toMap :: [(Text, a)] -> Parser (Map Text a)
toMap :: [(Text, a)] -> Parser (Map Text a)
toMap [(Text, a)]
kvs = (Text -> Parser a -> Parser a)
-> Map Text (Parser a) -> Parser (Map Text a)
forall k (f :: * -> *) a b.
(Ord k, Applicative f) =>
(k -> a -> f b) -> Map k a -> f (Map k b)
Dhall.Map.unorderedTraverseWithKey (\Text
_k Parser a
v -> Parser a
v) Map Text (Parser a)
m
  where
    m :: Map Text (Parser a)
m = (Text -> Parser a -> Parser a -> Parser a)
-> [(Text, Parser a)] -> Map Text (Parser a)
forall k v. Ord k => (k -> v -> v -> v) -> [(k, v)] -> Map k v
Dhall.Map.fromListWithKey Text -> Parser a -> Parser a -> Parser a
forall (m :: * -> *) p p a. Parsing m => Text -> p -> p -> m a
err (((Text, a) -> (Text, Parser a))
-> [(Text, a)] -> [(Text, Parser a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, a
v) -> (Text
k, a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v)) [(Text, a)]
kvs)

    err :: Text -> p -> p -> m a
err Text
k p
_v1 p
_v2 = String -> m a
forall (m :: * -> *) a. Parsing m => String -> m a
Text.Parser.Combinators.unexpected
                        (String
"duplicate field: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Data.Text.unpack Text
k)

-- | Creates a 'Map Text a' using the provided combining function and the
--   key-value pairs
toMapWith
    :: (Text -> Parser a -> Parser a -> Parser a)
    -> [(Text, a)]
    -> Parser (Map Text a)
toMapWith :: (Text -> Parser a -> Parser a -> Parser a)
-> [(Text, a)] -> Parser (Map Text a)
toMapWith Text -> Parser a -> Parser a -> Parser a
combine [(Text, a)]
kvs = Map Text (Parser a) -> Parser (Map Text a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Map Text (Parser a)
m
  where
    m :: Map Text (Parser a)
m = (Text -> Parser a -> Parser a -> Parser a)
-> [(Text, Parser a)] -> Map Text (Parser a)
forall k v. Ord k => (k -> v -> v -> v) -> [(k, v)] -> Map k v
Dhall.Map.fromListWithKey Text -> Parser a -> Parser a -> Parser a
combine (((Text, a) -> (Text, Parser a))
-> [(Text, a)] -> [(Text, Parser a)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, a
v) -> (Text
k, a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v)) [(Text, a)]
kvs)

-- | Convert a list of digits to the equivalent number
base :: Num n => [Char] -> n -> n
String
digits base :: String -> n -> n
`base` n
b = (n -> n -> n) -> n -> [n] -> n
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl n -> n -> n
snoc n
0 ((Char -> n) -> String -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> n) -> (Char -> Int) -> Char -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToNumber) String
digits)
  where
    snoc :: n -> n -> n
snoc n
result n
number = n
result n -> n -> n
forall a. Num a => a -> a -> a
* n
b n -> n -> n
forall a. Num a => a -> a -> a
+ n
number

    digitToNumber :: Char -> Int
digitToNumber Char
c
        | Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Int
0x0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
Char.ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
Char.ord Char
'0'
        | Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F' = Int
0xA Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
Char.ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
Char.ord Char
'A'
        | Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' = Int
0xa Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
Char.ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
Char.ord Char
'a'
        | Bool
otherwise = String -> Int
forall a. HasCallStack => String -> a
error String
"Invalid hexadecimal digit"