{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}

module Data.Medea.Parser.Spec.Object
  ( Specification (..),
    parseSpecification,
  )
where

import Control.Monad (when)
import Data.Functor (($>))
import Data.Maybe (isJust)
import Data.Medea.Parser.Primitive
  ( Identifier,
    ReservedIdentifier (..),
    parseIdentifier,
    parseKeyVal,
    parseLine,
    parseReserved,
  )
import qualified Data.Medea.Parser.Spec.Property as Property
import Data.Medea.Parser.Types (MedeaParser, ParseError (..))
import Data.Vector (Vector)
import qualified Data.Vector as V
import Text.Megaparsec
  ( MonadParsec (..),
    customFailure,
    many,
    option,
    try,
  )

data Specification = Specification
  { Specification -> Vector Specification
properties :: {-# UNPACK #-} !(Vector Property.Specification),
    Specification -> Bool
additionalAllowed :: !Bool,
    Specification -> Maybe Identifier
additionalSchema :: !(Maybe Identifier)
  }
  deriving stock (Specification -> Specification -> Bool
(Specification -> Specification -> Bool)
-> (Specification -> Specification -> Bool) -> Eq Specification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Specification -> Specification -> Bool
$c/= :: Specification -> Specification -> Bool
== :: Specification -> Specification -> Bool
$c== :: Specification -> Specification -> Bool
Eq)

parseSpecification :: MedeaParser Specification
parseSpecification :: MedeaParser Specification
parseSpecification = do
  Identifier
_ <- Int -> MedeaParser Identifier -> MedeaParser Identifier
forall a. Int -> MedeaParser a -> MedeaParser a
parseLine Int
4 (ReservedIdentifier -> MedeaParser Identifier
parseReserved ReservedIdentifier
RProperties)
  Vector Specification
props <- MedeaParser (Vector Specification)
parseProperties
  Bool
additionalAllowed' <- MedeaParser Bool
parseAdditionalAllowed
  Maybe Identifier
additionalSchema' <- MedeaParser (Maybe Identifier)
parseAdditionalSchema
  Bool
-> ParsecT ParseError Text Identity ()
-> ParsecT ParseError Text Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
additionalAllowed' Bool -> Bool -> Bool
&& Maybe Identifier -> Bool
forall a. Maybe a -> Bool
isJust Maybe Identifier
additionalSchema') (ParsecT ParseError Text Identity ()
 -> ParsecT ParseError Text Identity ())
-> ParsecT ParseError Text Identity ()
-> ParsecT ParseError Text Identity ()
forall a b. (a -> b) -> a -> b
$
    ParseError -> ParsecT ParseError Text Identity ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure ParseError
ConflictingSpecRequirements
  Specification -> MedeaParser Specification
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Specification -> MedeaParser Specification)
-> Specification -> MedeaParser Specification
forall a b. (a -> b) -> a -> b
$ Vector Specification -> Bool -> Maybe Identifier -> Specification
Specification Vector Specification
props Bool
additionalAllowed' Maybe Identifier
additionalSchema'

parseProperties :: MedeaParser (Vector Property.Specification)
parseProperties :: MedeaParser (Vector Specification)
parseProperties = [Specification] -> Vector Specification
forall a. [a] -> Vector a
V.fromList ([Specification] -> Vector Specification)
-> ParsecT ParseError Text Identity [Specification]
-> MedeaParser (Vector Specification)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ParseError Text Identity Specification
-> ParsecT ParseError Text Identity [Specification]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT ParseError Text Identity Specification
-> ParsecT ParseError Text Identity Specification
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT ParseError Text Identity Specification
Property.parseSpecification)

parseAdditionalAllowed :: MedeaParser Bool
parseAdditionalAllowed :: MedeaParser Bool
parseAdditionalAllowed =
  Bool -> MedeaParser Bool -> MedeaParser Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (MedeaParser Bool -> MedeaParser Bool)
-> (MedeaParser Bool -> MedeaParser Bool)
-> MedeaParser Bool
-> MedeaParser Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MedeaParser Bool -> MedeaParser Bool
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (MedeaParser Bool -> MedeaParser Bool)
-> (MedeaParser Bool -> MedeaParser Bool)
-> MedeaParser Bool
-> MedeaParser Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> MedeaParser Bool -> MedeaParser Bool
forall a. Int -> MedeaParser a -> MedeaParser a
parseLine Int
8 (MedeaParser Bool -> MedeaParser Bool)
-> MedeaParser Bool -> MedeaParser Bool
forall a b. (a -> b) -> a -> b
$
    ReservedIdentifier -> MedeaParser Identifier
parseReserved ReservedIdentifier
RAdditionalPropertiesAllowed MedeaParser Identifier -> Bool -> MedeaParser Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True

parseAdditionalSchema :: MedeaParser (Maybe Identifier)
parseAdditionalSchema :: MedeaParser (Maybe Identifier)
parseAdditionalSchema =
  Maybe Identifier
-> MedeaParser (Maybe Identifier) -> MedeaParser (Maybe Identifier)
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Maybe Identifier
forall a. Maybe a
Nothing (MedeaParser (Maybe Identifier) -> MedeaParser (Maybe Identifier))
-> (MedeaParser Identifier -> MedeaParser (Maybe Identifier))
-> MedeaParser Identifier
-> MedeaParser (Maybe Identifier)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identifier -> Maybe Identifier)
-> MedeaParser Identifier -> MedeaParser (Maybe Identifier)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identifier -> Maybe Identifier
forall a. a -> Maybe a
Just (MedeaParser Identifier -> MedeaParser (Maybe Identifier))
-> (MedeaParser Identifier -> MedeaParser Identifier)
-> MedeaParser Identifier
-> MedeaParser (Maybe Identifier)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MedeaParser Identifier -> MedeaParser Identifier
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (MedeaParser Identifier -> MedeaParser Identifier)
-> (MedeaParser Identifier -> MedeaParser Identifier)
-> MedeaParser Identifier
-> MedeaParser Identifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> MedeaParser Identifier -> MedeaParser Identifier
forall a. Int -> MedeaParser a -> MedeaParser a
parseLine Int
8 (MedeaParser Identifier -> MedeaParser (Maybe Identifier))
-> MedeaParser Identifier -> MedeaParser (Maybe Identifier)
forall a b. (a -> b) -> a -> b
$
    ReservedIdentifier
-> MedeaParser Identifier -> MedeaParser Identifier
forall a. ReservedIdentifier -> MedeaParser a -> MedeaParser a
parseKeyVal ReservedIdentifier
RAdditionalPropertySchema MedeaParser Identifier
parseIdentifier