content: {-# 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 parser s = either (fail . errorBundlePretty) return $ runParser parser s s
  
  {- SchemaDef -}
  
  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 -- allow any trailing spaces
      parseSchemaDefObjItems = parseSchemaDefObjItem `sepEndBy1` lexeme ","
      parseSchemaDefObjItem =
        choice
          [ SchemaDefObjPair <$> parseSchemaDefPair
          , SchemaDefObjExtend <$> parseSchemaReference
          ]
          <* space -- allow any trailing spaces
      parseSchemaDefPair = do
        key <-
          choice
            [ SchemaDefObjKeyNormal <$> jsonKey
            , SchemaDefObjKeyPhantom <$> between (lexeme' "[") (lexeme' "]") jsonKey'
            ]
        lexeme ":"
        value <- parseSchemaDefWithUnions
        return (key, value)
      parseSchemaReference = char '#' *> namespacedIdentifier upperChar
  
  {- GetterExp -}
  
  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{..}
  
  {- UnwrapSchema -}
  
  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{..}
  
  {- GetterOps -}
  
  -- | A non-empty list of GetterOperations.
  --
  --  Invariant: Any GetterList/GetterTuple operations MUST be last.
  type GetterOps = NonEmpty GetterOperation
  
  parseGetterOps :: Parser GetterOps
  parseGetterOps = someWith [parseGetterOp, parseGetterOpSuffix]
  
  data GetterOperation
    = GetterKey String
    | GetterBang
    | GetterMapList
    | GetterMapMaybe
    | GetterBranch Int
    | -- suffixes
      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 ","
        ]
  
  {- Parser primitives -}
  
  -- | A Haskell identifier, with the given first character.
  identifier :: Parser Char -> Parser String
  identifier start = (:) <$> start <*> many (alphaNumChar <|> char '\'')
  
  lexeme :: String -> Parser ()
  lexeme = lexemeUsingLineComment $ L.skipLineComment "//"
  
  -- | Same as 'lexeme', but without parsing comments.
  lexeme' :: String -> Parser ()
  lexeme' = lexemeUsingLineComment empty
  
  lexemeUsingLineComment :: Parser () -> String -> Parser ()
  lexemeUsingLineComment lineComment = void . L.lexeme (L.space space1 lineComment empty) . string
  
  -- | Parses `identifier`, but if parentheses are provided, parses a namespaced identifier.
  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
          ]
  
  -- | An optionally quoted JSON key.
  jsonKey :: Parser String
  jsonKey = choice [char '"' *> jsonKey' <* char '"', jsonKey']
  
  -- | A string that can be used as a JSON key.
  jsonKey' :: Parser String
  jsonKey' =
    fmap NonEmpty.toList $
      some $
        choice
          [ try $ char '\\' *> anySingle
          , noneOf $ [' ', '\\', '"'] ++ schemaChars ++ getChars
          ]
    where
      -- characters that cause ambiguity when parsing 'get' expressions
      getChars = "!?[](),.@"
      -- characters that should not indicate the start of a key when parsing 'schema' definitions
      schemaChars = ":{}#"
  
  {- Parsing utilities -}
  
  -- | Same as 'Megaparsec.some', except returns a 'NonEmpty'
  some :: (MonadPlus f) => f a -> f (NonEmpty a)
  some p = NonEmpty.fromList <$> Megaparsec.some p
  
  -- | Same as 'Megaparsec.sepBy1', except returns a 'NonEmpty'
  sepBy1 :: (MonadPlus f) => f a -> f sep -> f (NonEmpty a)
  sepBy1 p sep = NonEmpty.fromList <$> Megaparsec.sepBy1 p sep
  
  -- | Same as 'Megaparsec.sepEndBy1', except returns a 'NonEmpty'
  sepEndBy1 :: (MonadPlus f) => f a -> f sep -> f (NonEmpty a)
  sepEndBy1 p sep = NonEmpty.fromList <$> Megaparsec.sepEndBy1 p 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 ps = do
    as <- concatMapM (many . try) ps
    maybe empty return $ NonEmpty.nonEmpty as
    where
      concatMapM f = fmap concat . mapM f
  