{-# 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 s = either (fail . errorBundlePretty) return $ runParser parser s s
data SchemaDef
= SchemaDefType String
| SchemaDefMaybe SchemaDef
| SchemaDefTry SchemaDef
| SchemaDefList SchemaDef
| SchemaDefInclude String
| SchemaDefObj (NonEmpty SchemaDefObjItem)
| SchemaDefUnion (NonEmpty SchemaDef)
deriving (Show)
data SchemaDefObjItem
= SchemaDefObjPair (SchemaDefObjKey, SchemaDef)
| SchemaDefObjExtend String
deriving (Show)
data SchemaDefObjKey
= SchemaDefObjKeyNormal String
| SchemaDefObjKeyPhantom String
deriving (Show)
parseSchemaDef :: MonadFail m => String -> m SchemaDef
parseSchemaDef = runParserFail $ do
space
def <- parseSchemaDefWithUnions
space
void eof
return def
where
parseSchemaDefWithUnions =
let parseSchemaUnion schemaDefs
| length schemaDefs == 1 = NonEmpty.head schemaDefs
| otherwise = SchemaDefUnion schemaDefs
in fmap parseSchemaUnion $ parseSchemaDefWithoutUnions `sepBy1` lexeme "|"
parseSchemaDefWithoutUnions = choice
[ between (lexeme "{") (lexeme "}") $ SchemaDefObj <$> parseSchemaDefObjItems
, between (lexeme "(") (lexeme ")") parseSchemaDefWithUnions
, lexeme "Maybe" *> (SchemaDefMaybe <$> parseSchemaDefWithoutUnions)
, lexeme "Try" *> (SchemaDefTry <$> parseSchemaDefWithoutUnions)
, lexeme "List" *> (SchemaDefList <$> parseSchemaDefWithoutUnions)
, SchemaDefType <$> identifier upperChar
, SchemaDefInclude <$> parseSchemaReference
] <* space
parseSchemaDefObjItems = parseSchemaDefObjItem `sepEndBy1` lexeme ","
parseSchemaDefObjItem = choice
[ SchemaDefObjPair <$> parseSchemaDefPair
, SchemaDefObjExtend <$> parseSchemaReference
] <* space
parseSchemaDefPair = do
key <- choice
[ SchemaDefObjKeyNormal <$> jsonKey
, SchemaDefObjKeyPhantom <$> between (lexeme' "[") (lexeme' "]") jsonKey'
]
lexeme ":"
value <- parseSchemaDefWithUnions
return (key, value)
parseSchemaReference = char '#' *> namespacedIdentifier upperChar
data GetterExp = GetterExp
{ start :: Maybe String
, getterOps :: GetterOps
} deriving (Show)
parseGetterExp :: MonadFail m => String -> m GetterExp
parseGetterExp = runParserFail $ do
space
start <- optional $ namespacedIdentifier lowerChar
getterOps <- parseGetterOps
space
void eof
return GetterExp{..}
data UnwrapSchema = UnwrapSchema
{ startSchema :: String
, getterOps :: GetterOps
} deriving (Show)
parseUnwrapSchema :: MonadFail m => String -> m UnwrapSchema
parseUnwrapSchema = runParserFail $ do
space
startSchema <- namespacedIdentifier upperChar
getterOps <- parseGetterOps
space
void eof
return UnwrapSchema{..}
type GetterOps = NonEmpty GetterOperation
parseGetterOps :: Parser GetterOps
parseGetterOps = someWith [parseGetterOp, parseGetterOpSuffix]
data GetterOperation
= GetterKey String
| GetterBang
| GetterMapList
| GetterMapMaybe
| GetterBranch Int
| GetterList (NonEmpty GetterOps)
| GetterTuple (NonEmpty GetterOps)
deriving (Show)
parseGetterOp :: Parser GetterOperation
parseGetterOp = choice
[ lexeme "!" $> GetterBang
, lexeme "[]" $> GetterMapList
, lexeme "?" $> GetterMapMaybe
, lexeme "@" *> (GetterBranch . read . NonEmpty.toList <$> some digitChar)
, optional (lexeme ".") *> (GetterKey <$> jsonKey)
]
parseGetterOpSuffix :: Parser GetterOperation
parseGetterOpSuffix = optional (lexeme ".") *> choice
[ fmap GetterList $ between (lexeme "[") (lexeme "]") $ parseGetterOps `sepBy1` lexeme ","
, fmap GetterTuple $ between (lexeme "(") (lexeme ")") $ parseGetterOps `sepBy1` lexeme ","
]
identifier :: Parser Char -> Parser String
identifier start = (:) <$> start <*> many (alphaNumChar <|> char '\'')
lexeme :: String -> Parser ()
lexeme = lexemeUsingLineComment $ L.skipLineComment "//"
lexeme' :: String -> Parser ()
lexeme' = lexemeUsingLineComment empty
lexemeUsingLineComment :: Parser () -> String -> Parser ()
lexemeUsingLineComment lineComment = void . L.lexeme (L.space space1 lineComment empty) . string
namespacedIdentifier :: Parser Char -> Parser String
namespacedIdentifier start = choice [lexeme "(" *> namespaced <* lexeme ")", ident]
where
ident = identifier start
namespaced = intercalate "." <$> manyAndEnd (identifier upperChar <* lexeme ".") ident
manyAndEnd p end = choice
[ try $ p >>= \x -> (x:) <$> manyAndEnd p end
, (:[]) <$> end
]
jsonKey :: Parser String
jsonKey = choice [char '"' *> jsonKey' <* char '"', jsonKey']
jsonKey' :: Parser String
jsonKey' = fmap NonEmpty.toList $ some $ choice
[ try $ char '\\' *> anySingle'
, noneOf $ [' ', '\\', '"'] ++ schemaChars ++ getChars
]
where
#if MIN_VERSION_megaparsec(7,0,0)
anySingle' = anySingle
#else
anySingle' = anyChar
#endif
getChars = "!?[](),.@"
schemaChars = ":{}#"
some :: MonadPlus f => f a -> f (NonEmpty a)
some p = NonEmpty.fromList <$> Megaparsec.some p
sepBy1 :: MonadPlus f => f a -> f sep -> f (NonEmpty a)
sepBy1 p sep = NonEmpty.fromList <$> Megaparsec.sepBy1 p sep
sepEndBy1 :: MonadPlus f => f a -> f sep -> f (NonEmpty a)
sepEndBy1 p sep = NonEmpty.fromList <$> Megaparsec.sepEndBy1 p sep
someWith :: MonadParsec e s m => [m a] -> m (NonEmpty a)
someWith ps = do
as <- concatMapM (many . try) ps
maybe empty return $ NonEmpty.nonEmpty as
where
concatMapM f = fmap concat . mapM f