{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}

{-|
Module      :  Data.Aeson.Schema.TH.Parse
Maintainer  :  Brandon Chinn <brandonchinn178@gmail.com>
Stability   :  experimental
Portability :  portable

Definitions for parsing input text in QuasiQuoters.
-}
module Data.Aeson.Schema.TH.Parse where

import Control.Monad (MonadPlus, void)

import Data.Functor (($>))
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Void (Void)
import Text.Megaparsec hiding (sepBy1, sepEndBy1, some)
import qualified Text.Megaparsec as Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L

type Parser = Parsec Void String

runParserFail :: (MonadFail m) => Parser a -> String -> m a
runParserFail :: forall (m :: * -> *) a. MonadFail m => Parser a -> String -> m a
runParserFail Parser a
parser String
s = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser Parser a
parser String
s String
s

{- SchemaDef -}

data SchemaDef
  = SchemaDefType String
  | SchemaDefMaybe SchemaDef
  | SchemaDefTry SchemaDef
  | SchemaDefList SchemaDef
  | SchemaDefInclude String
  | SchemaDefObj (NonEmpty SchemaDefObjItem)
  | SchemaDefUnion (NonEmpty SchemaDef)
  deriving (Int -> SchemaDef -> ShowS
[SchemaDef] -> ShowS
SchemaDef -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaDef] -> ShowS
$cshowList :: [SchemaDef] -> ShowS
show :: SchemaDef -> String
$cshow :: SchemaDef -> String
showsPrec :: Int -> SchemaDef -> ShowS
$cshowsPrec :: Int -> SchemaDef -> ShowS
Show)

data SchemaDefObjItem
  = SchemaDefObjPair (SchemaDefObjKey, SchemaDef)
  | SchemaDefObjExtend String
  deriving (Int -> SchemaDefObjItem -> ShowS
[SchemaDefObjItem] -> ShowS
SchemaDefObjItem -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaDefObjItem] -> ShowS
$cshowList :: [SchemaDefObjItem] -> ShowS
show :: SchemaDefObjItem -> String
$cshow :: SchemaDefObjItem -> String
showsPrec :: Int -> SchemaDefObjItem -> ShowS
$cshowsPrec :: Int -> SchemaDefObjItem -> ShowS
Show)

data SchemaDefObjKey
  = SchemaDefObjKeyNormal String
  | SchemaDefObjKeyPhantom String
  deriving (Int -> SchemaDefObjKey -> ShowS
[SchemaDefObjKey] -> ShowS
SchemaDefObjKey -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SchemaDefObjKey] -> ShowS
$cshowList :: [SchemaDefObjKey] -> ShowS
show :: SchemaDefObjKey -> String
$cshow :: SchemaDefObjKey -> String
showsPrec :: Int -> SchemaDefObjKey -> ShowS
$cshowsPrec :: Int -> SchemaDefObjKey -> ShowS
Show)

parseSchemaDef :: (MonadFail m) => String -> m SchemaDef
parseSchemaDef :: forall (m :: * -> *). MonadFail m => String -> m SchemaDef
parseSchemaDef = forall (m :: * -> *) a. MonadFail m => Parser a -> String -> m a
runParserFail forall a b. (a -> b) -> a -> b
$ do
  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  SchemaDef
def <- Parser SchemaDef
parseSchemaDefWithUnions
  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  forall (m :: * -> *) a. Monad m => a -> m a
return SchemaDef
def
  where
    parseSchemaDefWithUnions :: Parser SchemaDef
parseSchemaDefWithUnions =
      let parseSchemaUnion :: NonEmpty SchemaDef -> SchemaDef
parseSchemaUnion NonEmpty SchemaDef
schemaDefs
            | forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty SchemaDef
schemaDefs forall a. Eq a => a -> a -> Bool
== Int
1 = forall a. NonEmpty a -> a
NonEmpty.head NonEmpty SchemaDef
schemaDefs
            | Bool
otherwise = NonEmpty SchemaDef -> SchemaDef
SchemaDefUnion NonEmpty SchemaDef
schemaDefs
       in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty SchemaDef -> SchemaDef
parseSchemaUnion forall a b. (a -> b) -> a -> b
$ Parser SchemaDef
parseSchemaDefWithoutUnions forall (f :: * -> *) a sep.
MonadPlus f =>
f a -> f sep -> f (NonEmpty a)
`sepBy1` String -> Parser ()
lexeme String
"|"

    parseSchemaDefWithoutUnions :: Parser SchemaDef
parseSchemaDefWithoutUnions =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> Parser ()
lexeme String
"{") (String -> Parser ()
lexeme String
"}") forall a b. (a -> b) -> a -> b
$ NonEmpty SchemaDefObjItem -> SchemaDef
SchemaDefObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity (NonEmpty SchemaDefObjItem)
parseSchemaDefObjItems
        , forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> Parser ()
lexeme String
"(") (String -> Parser ()
lexeme String
")") Parser SchemaDef
parseSchemaDefWithUnions
        , String -> Parser ()
lexeme String
"Maybe" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SchemaDef -> SchemaDef
SchemaDefMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SchemaDef
parseSchemaDefWithoutUnions)
        , String -> Parser ()
lexeme String
"Try" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SchemaDef -> SchemaDef
SchemaDefTry forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SchemaDef
parseSchemaDefWithoutUnions)
        , String -> Parser ()
lexeme String
"List" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SchemaDef -> SchemaDef
SchemaDefList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SchemaDef
parseSchemaDefWithoutUnions)
        , String -> SchemaDef
SchemaDefType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> Parser String
identifier forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
        , String -> SchemaDef
SchemaDefInclude forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
parseSchemaReference
        ]
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space -- allow any trailing spaces
    parseSchemaDefObjItems :: ParsecT Void String Identity (NonEmpty SchemaDefObjItem)
parseSchemaDefObjItems = ParsecT Void String Identity SchemaDefObjItem
parseSchemaDefObjItem forall (f :: * -> *) a sep.
MonadPlus f =>
f a -> f sep -> f (NonEmpty a)
`sepEndBy1` String -> Parser ()
lexeme String
","
    parseSchemaDefObjItem :: ParsecT Void String Identity SchemaDefObjItem
parseSchemaDefObjItem =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ (SchemaDefObjKey, SchemaDef) -> SchemaDefObjItem
SchemaDefObjPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity (SchemaDefObjKey, SchemaDef)
parseSchemaDefPair
        , String -> SchemaDefObjItem
SchemaDefObjExtend forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
parseSchemaReference
        ]
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space -- allow any trailing spaces
    parseSchemaDefPair :: ParsecT Void String Identity (SchemaDefObjKey, SchemaDef)
parseSchemaDefPair = do
      SchemaDefObjKey
key <-
        forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
          [ String -> SchemaDefObjKey
SchemaDefObjKeyNormal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
jsonKey
          , String -> SchemaDefObjKey
SchemaDefObjKeyPhantom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> Parser ()
lexeme' String
"[") (String -> Parser ()
lexeme' String
"]") Parser String
jsonKey'
          ]
      String -> Parser ()
lexeme String
":"
      SchemaDef
value <- Parser SchemaDef
parseSchemaDefWithUnions
      forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaDefObjKey
key, SchemaDef
value)
    parseSchemaReference :: Parser String
parseSchemaReference = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char -> Parser String
namespacedIdentifier forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar

{- GetterExp -}

data GetterExp = GetterExp
  { GetterExp -> Maybe String
start :: Maybe String
  , GetterExp -> GetterOps
getterOps :: GetterOps
  }
  deriving (Int -> GetterExp -> ShowS
[GetterExp] -> ShowS
GetterExp -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetterExp] -> ShowS
$cshowList :: [GetterExp] -> ShowS
show :: GetterExp -> String
$cshow :: GetterExp -> String
showsPrec :: Int -> GetterExp -> ShowS
$cshowsPrec :: Int -> GetterExp -> ShowS
Show)

parseGetterExp :: (MonadFail m) => String -> m GetterExp
parseGetterExp :: forall (m :: * -> *). MonadFail m => String -> m GetterExp
parseGetterExp = forall (m :: * -> *) a. MonadFail m => Parser a -> String -> m a
runParserFail forall a b. (a -> b) -> a -> b
$ do
  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  Maybe String
start <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Parser Char -> Parser String
namespacedIdentifier forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar
  GetterOps
getterOps <- Parser GetterOps
parseGetterOps
  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  forall (m :: * -> *) a. Monad m => a -> m a
return GetterExp{Maybe String
GetterOps
getterOps :: GetterOps
start :: Maybe String
$sel:getterOps:GetterExp :: GetterOps
$sel:start:GetterExp :: Maybe String
..}

{- UnwrapSchema -}

data UnwrapSchema = UnwrapSchema
  { UnwrapSchema -> String
startSchema :: String
  , UnwrapSchema -> GetterOps
getterOps :: GetterOps
  }
  deriving (Int -> UnwrapSchema -> ShowS
[UnwrapSchema] -> ShowS
UnwrapSchema -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnwrapSchema] -> ShowS
$cshowList :: [UnwrapSchema] -> ShowS
show :: UnwrapSchema -> String
$cshow :: UnwrapSchema -> String
showsPrec :: Int -> UnwrapSchema -> ShowS
$cshowsPrec :: Int -> UnwrapSchema -> ShowS
Show)

parseUnwrapSchema :: (MonadFail m) => String -> m UnwrapSchema
parseUnwrapSchema :: forall (m :: * -> *). MonadFail m => String -> m UnwrapSchema
parseUnwrapSchema = forall (m :: * -> *) a. MonadFail m => Parser a -> String -> m a
runParserFail forall a b. (a -> b) -> a -> b
$ do
  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  String
startSchema <- Parser Char -> Parser String
namespacedIdentifier forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
  GetterOps
getterOps <- Parser GetterOps
parseGetterOps
  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  forall (m :: * -> *) a. Monad m => a -> m a
return UnwrapSchema{String
GetterOps
getterOps :: GetterOps
startSchema :: String
$sel:getterOps:UnwrapSchema :: GetterOps
$sel:startSchema:UnwrapSchema :: String
..}

{- GetterOps -}

-- | A non-empty list of GetterOperations.
--
--  Invariant: Any GetterList/GetterTuple operations MUST be last.
type GetterOps = NonEmpty GetterOperation

parseGetterOps :: Parser GetterOps
parseGetterOps :: Parser GetterOps
parseGetterOps = forall e s (m :: * -> *) a.
MonadParsec e s m =>
[m a] -> m (NonEmpty a)
someWith [ParsecT Void String Identity GetterOperation
parseGetterOp, ParsecT Void String Identity GetterOperation
parseGetterOpSuffix]

data GetterOperation
  = GetterKey String
  | GetterBang
  | GetterMapList
  | GetterMapMaybe
  | GetterBranch Int
  | -- suffixes
    GetterList (NonEmpty GetterOps)
  | GetterTuple (NonEmpty GetterOps)
  deriving (Int -> GetterOperation -> ShowS
[GetterOperation] -> ShowS
GetterOperation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GetterOperation] -> ShowS
$cshowList :: [GetterOperation] -> ShowS
show :: GetterOperation -> String
$cshow :: GetterOperation -> String
showsPrec :: Int -> GetterOperation -> ShowS
$cshowsPrec :: Int -> GetterOperation -> ShowS
Show)

parseGetterOp :: Parser GetterOperation
parseGetterOp :: ParsecT Void String Identity GetterOperation
parseGetterOp =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ String -> Parser ()
lexeme String
"!" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> GetterOperation
GetterBang
    , String -> Parser ()
lexeme String
"[]" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> GetterOperation
GetterMapList
    , String -> Parser ()
lexeme String
"?" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> GetterOperation
GetterMapMaybe
    , String -> Parser ()
lexeme String
"@" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> GetterOperation
GetterBranch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NonEmpty.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. MonadPlus f => f a -> f (NonEmpty a)
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar)
    , forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String -> Parser ()
lexeme String
".") forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> GetterOperation
GetterKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
jsonKey)
    ]

parseGetterOpSuffix :: Parser GetterOperation
parseGetterOpSuffix :: ParsecT Void String Identity GetterOperation
parseGetterOpSuffix =
  forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String -> Parser ()
lexeme String
".")
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
      [ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty GetterOps -> GetterOperation
GetterList forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> Parser ()
lexeme String
"[") (String -> Parser ()
lexeme String
"]") forall a b. (a -> b) -> a -> b
$ Parser GetterOps
parseGetterOps forall (f :: * -> *) a sep.
MonadPlus f =>
f a -> f sep -> f (NonEmpty a)
`sepBy1` String -> Parser ()
lexeme String
","
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty GetterOps -> GetterOperation
GetterTuple forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> Parser ()
lexeme String
"(") (String -> Parser ()
lexeme String
")") forall a b. (a -> b) -> a -> b
$ Parser GetterOps
parseGetterOps forall (f :: * -> *) a sep.
MonadPlus f =>
f a -> f sep -> f (NonEmpty a)
`sepBy1` String -> Parser ()
lexeme String
","
      ]

{- Parser primitives -}

-- | A Haskell identifier, with the given first character.
identifier :: Parser Char -> Parser String
identifier :: Parser Char -> Parser String
identifier Parser Char
start = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
start forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\'')

lexeme :: String -> Parser ()
lexeme :: String -> Parser ()
lexeme = Parser () -> String -> Parser ()
lexemeUsingLineComment forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment String
"//"

-- | Same as 'lexeme', but without parsing comments.
lexeme' :: String -> Parser ()
lexeme' :: String -> Parser ()
lexeme' = Parser () -> String -> Parser ()
lexemeUsingLineComment forall (f :: * -> *) a. Alternative f => f a
empty

lexemeUsingLineComment :: Parser () -> String -> Parser ()
lexemeUsingLineComment :: Parser () -> String -> Parser ()
lexemeUsingLineComment Parser ()
lineComment = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme (forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 Parser ()
lineComment forall (f :: * -> *) a. Alternative f => f a
empty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string

-- | Parses `identifier`, but if parentheses are provided, parses a namespaced identifier.
namespacedIdentifier :: Parser Char -> Parser String
namespacedIdentifier :: Parser Char -> Parser String
namespacedIdentifier Parser Char
start = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> Parser ()
lexeme String
"(" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
namespaced forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser ()
lexeme String
")", Parser String
ident]
  where
    ident :: Parser String
ident = Parser Char -> Parser String
identifier Parser Char
start
    namespaced :: Parser String
namespaced = forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {e} {s} {a}.
MonadParsec e s m =>
m a -> m a -> m [a]
manyAndEnd (Parser Char -> Parser String
identifier forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser ()
lexeme String
".") Parser String
ident
    manyAndEnd :: m a -> m a -> m [a]
manyAndEnd m a
p m a
end =
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ m a
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> (a
x forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> m a -> m [a]
manyAndEnd m a
p m a
end
        , (forall a. a -> [a] -> [a]
: []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
end
        ]

-- | An optionally quoted JSON key.
jsonKey :: Parser String
jsonKey :: Parser String
jsonKey = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser String
jsonKey' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'"', Parser String
jsonKey']

-- | A string that can be used as a JSON key.
jsonKey' :: Parser String
jsonKey' :: Parser String
jsonKey' =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. NonEmpty a -> [a]
NonEmpty.toList forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. MonadPlus f => f a -> f (NonEmpty a)
some forall a b. (a -> b) -> a -> b
$
      forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
        , forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf forall a b. (a -> b) -> a -> b
$ [Char
' ', Char
'\\', Char
'"'] forall a. [a] -> [a] -> [a]
++ String
schemaChars forall a. [a] -> [a] -> [a]
++ String
getChars
        ]
  where
    -- characters that cause ambiguity when parsing 'get' expressions
    getChars :: String
getChars = String
"!?[](),.@"
    -- characters that should not indicate the start of a key when parsing 'schema' definitions
    schemaChars :: String
schemaChars = String
":{}#"

{- Parsing utilities -}

-- | Same as 'Megaparsec.some', except returns a 'NonEmpty'
some :: (MonadPlus f) => f a -> f (NonEmpty a)
some :: forall (f :: * -> *) a. MonadPlus f => f a -> f (NonEmpty a)
some f a
p = forall a. [a] -> NonEmpty a
NonEmpty.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
Megaparsec.some f a
p

-- | Same as 'Megaparsec.sepBy1', except returns a 'NonEmpty'
sepBy1 :: (MonadPlus f) => f a -> f sep -> f (NonEmpty a)
sepBy1 :: forall (f :: * -> *) a sep.
MonadPlus f =>
f a -> f sep -> f (NonEmpty a)
sepBy1 f a
p f sep
sep = forall a. [a] -> NonEmpty a
NonEmpty.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
Megaparsec.sepBy1 f a
p f sep
sep

-- | Same as 'Megaparsec.sepEndBy1', except returns a 'NonEmpty'
sepEndBy1 :: (MonadPlus f) => f a -> f sep -> f (NonEmpty a)
sepEndBy1 :: forall (f :: * -> *) a sep.
MonadPlus f =>
f a -> f sep -> f (NonEmpty a)
sepEndBy1 f a
p f sep
sep = forall a. [a] -> NonEmpty a
NonEmpty.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
Megaparsec.sepEndBy1 f a
p f sep
sep

-- | Return a non-empty list containing elements from the given parsers in order.
--
--  i.e. for `someWith [p1, p2, p3]`, elements parsed with `p1` will come before
--  elements parsed with `p2` and `p3`, etc.
--
--  An individual parser in the list may not parse anything, but at least one parser must return
--  something.
someWith :: (MonadParsec e s m) => [m a] -> m (NonEmpty a)
someWith :: forall e s (m :: * -> *) a.
MonadParsec e s m =>
[m a] -> m (NonEmpty a)
someWith [m a]
ps = do
  [a]
as <- forall {t :: * -> *} {f :: * -> *} {a} {a}.
(Traversable t, Monad f) =>
(a -> f [a]) -> t a -> f [a]
concatMapM (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) [m a]
ps
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (f :: * -> *) a. Alternative f => f a
empty forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [a]
as
  where
    concatMapM :: (a -> f [a]) -> t a -> f [a]
concatMapM a -> f [a]
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> f [a]
f