{-|
Module      :  Data.Aeson.Schema.TH.Parse
Maintainer  :  Brandon Chinn <brandon@leapyear.io>
Stability   :  experimental
Portability :  portable

Definitions for parsing input text in QuasiQuoters.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RecordWildCards #-}

module Data.Aeson.Schema.TH.Parse where

import Control.Monad (MonadPlus, void)
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
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

#if !MIN_VERSION_megaparsec(7,0,0)
errorBundlePretty :: (Ord t, ShowToken t, ShowErrorComponent e) => ParseError t e -> String
errorBundlePretty = parseErrorPretty
#endif

runParserFail :: MonadFail m => Parser a -> String -> m a
runParserFail :: Parser a -> String -> m a
runParserFail Parser a
parser String
s = (ParseErrorBundle String Void -> m a)
-> (a -> m a) -> Either (ParseErrorBundle String Void) a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a)
-> (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ParseErrorBundle String Void) a -> m a)
-> Either (ParseErrorBundle String Void) a -> m a
forall a b. (a -> b) -> a -> b
$ Parser a
-> String -> String -> Either (ParseErrorBundle String Void) a
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
(Int -> SchemaDef -> ShowS)
-> (SchemaDef -> String)
-> ([SchemaDef] -> ShowS)
-> Show SchemaDef
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
(Int -> SchemaDefObjItem -> ShowS)
-> (SchemaDefObjItem -> String)
-> ([SchemaDefObjItem] -> ShowS)
-> Show SchemaDefObjItem
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
(Int -> SchemaDefObjKey -> ShowS)
-> (SchemaDefObjKey -> String)
-> ([SchemaDefObjKey] -> ShowS)
-> Show SchemaDefObjKey
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 :: String -> m SchemaDef
parseSchemaDef = Parser SchemaDef -> String -> m SchemaDef
forall (m :: * -> *) a. MonadFail m => Parser a -> String -> m a
runParserFail (Parser SchemaDef -> String -> m SchemaDef)
-> Parser SchemaDef -> String -> m SchemaDef
forall a b. (a -> b) -> a -> b
$ do
  ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  SchemaDef
def <- Parser SchemaDef
parseSchemaDefWithUnions
  ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  ParsecT Void String Identity () -> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  SchemaDef -> Parser SchemaDef
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
            | NonEmpty SchemaDef -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty SchemaDef
schemaDefs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = NonEmpty SchemaDef -> SchemaDef
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty SchemaDef
schemaDefs
            | Bool
otherwise = NonEmpty SchemaDef -> SchemaDef
SchemaDefUnion NonEmpty SchemaDef
schemaDefs
      in (NonEmpty SchemaDef -> SchemaDef)
-> ParsecT Void String Identity (NonEmpty SchemaDef)
-> Parser SchemaDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty SchemaDef -> SchemaDef
parseSchemaUnion (ParsecT Void String Identity (NonEmpty SchemaDef)
 -> Parser SchemaDef)
-> ParsecT Void String Identity (NonEmpty SchemaDef)
-> Parser SchemaDef
forall a b. (a -> b) -> a -> b
$ Parser SchemaDef
parseSchemaDefWithoutUnions Parser SchemaDef
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity (NonEmpty SchemaDef)
forall (f :: * -> *) a sep.
MonadPlus f =>
f a -> f sep -> f (NonEmpty a)
`sepBy1` String -> ParsecT Void String Identity ()
lexeme String
"|"

    parseSchemaDefWithoutUnions :: Parser SchemaDef
parseSchemaDefWithoutUnions = [Parser SchemaDef] -> Parser SchemaDef
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
      [ ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> Parser SchemaDef
-> Parser SchemaDef
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> ParsecT Void String Identity ()
lexeme String
"{") (String -> ParsecT Void String Identity ()
lexeme String
"}") (Parser SchemaDef -> Parser SchemaDef)
-> Parser SchemaDef -> Parser SchemaDef
forall a b. (a -> b) -> a -> b
$ NonEmpty SchemaDefObjItem -> SchemaDef
SchemaDefObj (NonEmpty SchemaDefObjItem -> SchemaDef)
-> ParsecT Void String Identity (NonEmpty SchemaDefObjItem)
-> Parser SchemaDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity (NonEmpty SchemaDefObjItem)
parseSchemaDefObjItems
      , ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> Parser SchemaDef
-> Parser SchemaDef
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> ParsecT Void String Identity ()
lexeme String
"(") (String -> ParsecT Void String Identity ()
lexeme String
")") Parser SchemaDef
parseSchemaDefWithUnions
      , String -> ParsecT Void String Identity ()
lexeme String
"Maybe" ParsecT Void String Identity ()
-> Parser SchemaDef -> Parser SchemaDef
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SchemaDef -> SchemaDef
SchemaDefMaybe (SchemaDef -> SchemaDef) -> Parser SchemaDef -> Parser SchemaDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SchemaDef
parseSchemaDefWithoutUnions)
      , String -> ParsecT Void String Identity ()
lexeme String
"Try" ParsecT Void String Identity ()
-> Parser SchemaDef -> Parser SchemaDef
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SchemaDef -> SchemaDef
SchemaDefTry (SchemaDef -> SchemaDef) -> Parser SchemaDef -> Parser SchemaDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SchemaDef
parseSchemaDefWithoutUnions)
      , String -> ParsecT Void String Identity ()
lexeme String
"List" ParsecT Void String Identity ()
-> Parser SchemaDef -> Parser SchemaDef
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SchemaDef -> SchemaDef
SchemaDefList (SchemaDef -> SchemaDef) -> Parser SchemaDef -> Parser SchemaDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SchemaDef
parseSchemaDefWithoutUnions)
      , String -> SchemaDef
SchemaDefType (String -> SchemaDef)
-> ParsecT Void String Identity String -> Parser SchemaDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> ParsecT Void String Identity String
identifier Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
      , String -> SchemaDef
SchemaDefInclude (String -> SchemaDef)
-> ParsecT Void String Identity String -> Parser SchemaDef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
parseSchemaReference
      ] Parser SchemaDef
-> ParsecT Void String Identity () -> Parser SchemaDef
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
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 ParsecT Void String Identity SchemaDefObjItem
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity (NonEmpty SchemaDefObjItem)
forall (f :: * -> *) a sep.
MonadPlus f =>
f a -> f sep -> f (NonEmpty a)
`sepEndBy1` String -> ParsecT Void String Identity ()
lexeme String
","
    parseSchemaDefObjItem :: ParsecT Void String Identity SchemaDefObjItem
parseSchemaDefObjItem = [ParsecT Void String Identity SchemaDefObjItem]
-> ParsecT Void String Identity SchemaDefObjItem
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
      [ (SchemaDefObjKey, SchemaDef) -> SchemaDefObjItem
SchemaDefObjPair ((SchemaDefObjKey, SchemaDef) -> SchemaDefObjItem)
-> ParsecT Void String Identity (SchemaDefObjKey, SchemaDef)
-> ParsecT Void String Identity SchemaDefObjItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity (SchemaDefObjKey, SchemaDef)
parseSchemaDefPair
      , String -> SchemaDefObjItem
SchemaDefObjExtend (String -> SchemaDefObjItem)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity SchemaDefObjItem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
parseSchemaReference
      ] ParsecT Void String Identity SchemaDefObjItem
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity SchemaDefObjItem
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
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 <- [ParsecT Void String Identity SchemaDefObjKey]
-> ParsecT Void String Identity SchemaDefObjKey
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
        [ String -> SchemaDefObjKey
SchemaDefObjKeyNormal (String -> SchemaDefObjKey)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity SchemaDefObjKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
jsonKey
        , String -> SchemaDefObjKey
SchemaDefObjKeyPhantom (String -> SchemaDefObjKey)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity SchemaDefObjKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> ParsecT Void String Identity ()
lexeme' String
"[") (String -> ParsecT Void String Identity ()
lexeme' String
"]") ParsecT Void String Identity String
jsonKey'
        ]
      String -> ParsecT Void String Identity ()
lexeme String
":"
      SchemaDef
value <- Parser SchemaDef
parseSchemaDefWithUnions
      (SchemaDefObjKey, SchemaDef)
-> ParsecT Void String Identity (SchemaDefObjKey, SchemaDef)
forall (m :: * -> *) a. Monad m => a -> m a
return (SchemaDefObjKey
key, SchemaDef
value)
    parseSchemaReference :: ParsecT Void String Identity String
parseSchemaReference = Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'#' Parser Char
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char -> ParsecT Void String Identity String
namespacedIdentifier Parser Char
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
(Int -> GetterExp -> ShowS)
-> (GetterExp -> String)
-> ([GetterExp] -> ShowS)
-> Show GetterExp
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 :: String -> m GetterExp
parseGetterExp = Parser GetterExp -> String -> m GetterExp
forall (m :: * -> *) a. MonadFail m => Parser a -> String -> m a
runParserFail (Parser GetterExp -> String -> m GetterExp)
-> Parser GetterExp -> String -> m GetterExp
forall a b. (a -> b) -> a -> b
$ do
  ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  Maybe String
start <- ParsecT Void String Identity String
-> ParsecT Void String Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void String Identity String
 -> ParsecT Void String Identity (Maybe String))
-> ParsecT Void String Identity String
-> ParsecT Void String Identity (Maybe String)
forall a b. (a -> b) -> a -> b
$ Parser Char -> ParsecT Void String Identity String
namespacedIdentifier Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar
  GetterOps
getterOps <- Parser GetterOps
parseGetterOps
  ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  ParsecT Void String Identity () -> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  GetterExp -> Parser GetterExp
forall (m :: * -> *) a. Monad m => a -> m a
return GetterExp :: Maybe String -> GetterOps -> GetterExp
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
(Int -> UnwrapSchema -> ShowS)
-> (UnwrapSchema -> String)
-> ([UnwrapSchema] -> ShowS)
-> Show UnwrapSchema
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 :: String -> m UnwrapSchema
parseUnwrapSchema = Parser UnwrapSchema -> String -> m UnwrapSchema
forall (m :: * -> *) a. MonadFail m => Parser a -> String -> m a
runParserFail (Parser UnwrapSchema -> String -> m UnwrapSchema)
-> Parser UnwrapSchema -> String -> m UnwrapSchema
forall a b. (a -> b) -> a -> b
$ do
  ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  String
startSchema <- Parser Char -> ParsecT Void String Identity String
namespacedIdentifier Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar
  GetterOps
getterOps <- Parser GetterOps
parseGetterOps
  ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  ParsecT Void String Identity () -> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void String Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  UnwrapSchema -> Parser UnwrapSchema
forall (m :: * -> *) a. Monad m => a -> m a
return UnwrapSchema :: String -> GetterOps -> UnwrapSchema
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 = [ParsecT Void String Identity GetterOperation] -> Parser GetterOps
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
(Int -> GetterOperation -> ShowS)
-> (GetterOperation -> String)
-> ([GetterOperation] -> ShowS)
-> Show GetterOperation
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 = [ParsecT Void String Identity GetterOperation]
-> ParsecT Void String Identity GetterOperation
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ String -> ParsecT Void String Identity ()
lexeme String
"!" ParsecT Void String Identity ()
-> GetterOperation -> ParsecT Void String Identity GetterOperation
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> GetterOperation
GetterBang
  , String -> ParsecT Void String Identity ()
lexeme String
"[]" ParsecT Void String Identity ()
-> GetterOperation -> ParsecT Void String Identity GetterOperation
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> GetterOperation
GetterMapList
  , String -> ParsecT Void String Identity ()
lexeme String
"?" ParsecT Void String Identity ()
-> GetterOperation -> ParsecT Void String Identity GetterOperation
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> GetterOperation
GetterMapMaybe
  , String -> ParsecT Void String Identity ()
lexeme String
"@" ParsecT Void String Identity ()
-> ParsecT Void String Identity GetterOperation
-> ParsecT Void String Identity GetterOperation
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> GetterOperation
GetterBranch (Int -> GetterOperation)
-> (NonEmpty Char -> Int) -> NonEmpty Char -> GetterOperation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall a. Read a => String -> a
read (String -> Int)
-> (NonEmpty Char -> String) -> NonEmpty Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Char -> String
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty Char -> GetterOperation)
-> ParsecT Void String Identity (NonEmpty Char)
-> ParsecT Void String Identity GetterOperation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char -> ParsecT Void String Identity (NonEmpty Char)
forall (f :: * -> *) a. MonadPlus f => f a -> f (NonEmpty a)
some Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar)
  , ParsecT Void String Identity ()
-> ParsecT Void String Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (String -> ParsecT Void String Identity ()
lexeme String
".") ParsecT Void String Identity (Maybe ())
-> ParsecT Void String Identity GetterOperation
-> ParsecT Void String Identity GetterOperation
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> GetterOperation
GetterKey (String -> GetterOperation)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity GetterOperation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
jsonKey)
  ]

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

{- Parser primitives -}

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

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

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

lexemeUsingLineComment :: Parser () -> String -> Parser ()
lexemeUsingLineComment :: ParsecT Void String Identity ()
-> String -> ParsecT Void String Identity ()
lexemeUsingLineComment ParsecT Void String Identity ()
lineComment = ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity String
 -> ParsecT Void String Identity ())
-> (String -> ParsecT Void String Identity String)
-> String
-> ParsecT Void String Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void String Identity ()
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme (ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 ParsecT Void String Identity ()
lineComment ParsecT Void String Identity ()
forall (f :: * -> *) a. Alternative f => f a
empty) (ParsecT Void String Identity String
 -> ParsecT Void String Identity String)
-> (String -> ParsecT Void String Identity String)
-> String
-> ParsecT Void String Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParsecT Void String Identity String
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 -> ParsecT Void String Identity String
namespacedIdentifier Parser Char
start = [ParsecT Void String Identity String]
-> ParsecT Void String Identity String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [String -> ParsecT Void String Identity ()
lexeme String
"(" ParsecT Void String Identity ()
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity String
namespaced ParsecT Void String Identity String
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> ParsecT Void String Identity ()
lexeme String
")", ParsecT Void String Identity String
ident]
  where
    ident :: ParsecT Void String Identity String
ident = Parser Char -> ParsecT Void String Identity String
identifier Parser Char
start
    namespaced :: ParsecT Void String Identity String
namespaced = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String)
-> ParsecT Void String Identity [String]
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity [String]
forall (m :: * -> *) e s a.
MonadParsec e s m =>
m a -> m a -> m [a]
manyAndEnd (Parser Char -> ParsecT Void String Identity String
identifier Parser Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar ParsecT Void String Identity String
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> ParsecT Void String Identity ()
lexeme String
".") ParsecT Void String Identity String
ident
    manyAndEnd :: m a -> m a -> m [a]
manyAndEnd m a
p m a
end = [m [a]] -> m [a]
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
      [ m [a] -> m [a]
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (m [a] -> m [a]) -> m [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ m a
p m a -> (a -> m [a]) -> m [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> m [a] -> m [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
      , (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) (a -> [a]) -> m a -> m [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 :: ParsecT Void String Identity String
jsonKey = [ParsecT Void String Identity String]
-> ParsecT Void String Identity String
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"' Parser Char
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity String
jsonKey' ParsecT Void String Identity String
-> Parser Char -> ParsecT Void String Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'"', ParsecT Void String Identity String
jsonKey']

-- | A string that can be used as a JSON key.
jsonKey' :: Parser String
jsonKey' :: ParsecT Void String Identity String
jsonKey' = (NonEmpty Char -> String)
-> ParsecT Void String Identity (NonEmpty Char)
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Char -> String
forall a. NonEmpty a -> [a]
NonEmpty.toList (ParsecT Void String Identity (NonEmpty Char)
 -> ParsecT Void String Identity String)
-> ParsecT Void String Identity (NonEmpty Char)
-> ParsecT Void String Identity String
forall a b. (a -> b) -> a -> b
$ Parser Char -> ParsecT Void String Identity (NonEmpty Char)
forall (f :: * -> *) a. MonadPlus f => f a -> f (NonEmpty a)
some (Parser Char -> ParsecT Void String Identity (NonEmpty Char))
-> Parser Char -> ParsecT Void String Identity (NonEmpty Char)
forall a b. (a -> b) -> a -> b
$ [Parser Char] -> Parser Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ Parser Char -> Parser Char
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser Char -> Parser Char) -> Parser Char -> Parser Char
forall a b. (a -> b) -> a -> b
$ Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'\\' Parser Char -> Parser Char -> Parser Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char
ParsecT Void String Identity (Token String)
anySingle'
  , [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf ([Token String] -> ParsecT Void String Identity (Token String))
-> [Token String] -> ParsecT Void String Identity (Token String)
forall a b. (a -> b) -> a -> b
$ [Char
' ', Char
'\\', Char
'"'] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
schemaChars String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
getChars
  ]
  where
#if MIN_VERSION_megaparsec(7,0,0)
    anySingle' :: ParsecT Void String Identity (Token String)
anySingle' = ParsecT Void String Identity (Token String)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
#else
    anySingle' = anyChar
#endif

    -- 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 :: f a -> f (NonEmpty a)
some f a
p = [a] -> NonEmpty a
forall a. [a] -> NonEmpty a
NonEmpty.fromList ([a] -> NonEmpty a) -> f [a] -> f (NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> f [a]
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 :: f a -> f sep -> f (NonEmpty a)
sepBy1 f a
p f sep
sep = [a] -> NonEmpty a
forall a. [a] -> NonEmpty a
NonEmpty.fromList ([a] -> NonEmpty a) -> f [a] -> f (NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> f sep -> f [a]
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 :: f a -> f sep -> f (NonEmpty a)
sepEndBy1 f a
p f sep
sep = [a] -> NonEmpty a
forall a. [a] -> NonEmpty a
NonEmpty.fromList ([a] -> NonEmpty a) -> f [a] -> f (NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> f sep -> f [a]
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 :: [m a] -> m (NonEmpty a)
someWith [m a]
ps = do
  [a]
as <- (m a -> m [a]) -> [m a] -> m [a]
forall (t :: * -> *) (f :: * -> *) a a.
(Traversable t, Monad f) =>
(a -> f [a]) -> t a -> f [a]
concatMapM (m a -> m [a]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (m a -> m [a]) -> (m a -> m a) -> m a -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try) [m a]
ps
  m (NonEmpty a)
-> (NonEmpty a -> m (NonEmpty a))
-> Maybe (NonEmpty a)
-> m (NonEmpty a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (NonEmpty a)
forall (f :: * -> *) a. Alternative f => f a
empty NonEmpty a -> m (NonEmpty a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (NonEmpty a) -> m (NonEmpty a))
-> Maybe (NonEmpty a) -> m (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [a]
as
  where
    concatMapM :: (a -> f [a]) -> t a -> f [a]
concatMapM a -> f [a]
f = (t [a] -> [a]) -> f (t [a]) -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t [a] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (f (t [a]) -> f [a]) -> (t a -> f (t [a])) -> t a -> f [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f [a]) -> t a -> f (t [a])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> f [a]
f