{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module Data.Medea.Loader
( LoaderError (..),
buildSchema,
loadSchemaFromFile,
loadSchemaFromHandle,
)
where
import Control.Monad.Except (runExcept)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString, hGetContents, readFile)
import Data.Medea.Analysis
( AnalysisError (..),
compileSchemata,
)
import Data.Medea.Parser.Primitive (toText, unwrap)
import qualified Data.Medea.Parser.Spec.Schemata as Schemata
import Data.Medea.Parser.Types (ParseError)
import Data.Medea.Schema (Schema (..))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8')
import System.IO (Handle)
import Text.Megaparsec (ParseErrorBundle, parse)
import Prelude hiding (readFile)
data LoaderError
=
NotUtf8
|
ParsingFailed
!(ParseErrorBundle Text ParseError)
|
StartSchemaMissing
|
SelfTypingSchema
|
MultipleSchemaDefinition
{-# UNPACK #-} !Text
|
MissingSchemaDefinition
{-# UNPACK #-} !Text
{-# UNPACK #-} !Text
|
SchemaNameReserved
{-# UNPACK #-} !Text
|
IsolatedSchemata
{-# UNPACK #-} !Text
|
MissingPropSchemaDefinition
{-# UNPACK #-} !Text
{-# UNPACK #-} !Text
|
MinimumLengthGreaterThanMaximum
{-# UNPACK #-} !Text
|
MultiplePropSchemaDefinition
{-# UNPACK #-} !Text
{-# UNPACK #-} !Text
|
MissingListSchemaDefinition
{-# UNPACK #-} !Text
{-# UNPACK #-} !Text
|
MissingTupleSchemaDefinition
{-# UNPACK #-} !Text
{-# UNPACK #-} !Text
|
PropertySpecWithoutObjectType
{-# UNPACK #-} !Text
|
ListSpecWithoutArrayType
{-# UNPACK #-} !Text
|
TupleSpecWithoutArrayType
{-# UNPACK #-} !Text
|
StringSpecWithoutStringType
{-# UNPACK #-} !Text
deriving stock (Eq, Show)
buildSchema :: ByteString -> Either LoaderError Schema
buildSchema bs = do
utf8 <- parseUtf8 bs
spec <- fromUtf8 ":memory:" utf8
analyze spec
loadSchemaFromFile :: (MonadIO m) => FilePath -> m (Either LoaderError Schema)
loadSchemaFromFile fp = do
contents <- liftIO . readFile $ fp
pure (parseUtf8 contents >>= fromUtf8 fp >>= analyze)
loadSchemaFromHandle :: (MonadIO m) => Handle -> m (Either LoaderError Schema)
loadSchemaFromHandle h = do
contents <- liftIO . hGetContents $ h
pure (parseUtf8 contents >>= fromUtf8 (show h) >>= analyze)
parseUtf8 :: ByteString -> Either LoaderError Text
parseUtf8 = either (const (Left NotUtf8)) pure . decodeUtf8'
fromUtf8 :: String -> Text -> Either LoaderError Schemata.Specification
fromUtf8 sourceName utf8 =
case parse Schemata.parseSpecification sourceName utf8 of
Left err -> Left . ParsingFailed $ err
Right scm -> pure scm
analyze :: Schemata.Specification -> Either LoaderError Schema
analyze = bimap translateError Schema . runExcept . compileSchemata
where
translateError = \case
DuplicateSchemaName ident -> MultipleSchemaDefinition . toText $ ident
NoStartSchema -> StartSchemaMissing
DanglingTypeReference danglingRef parSchema ->
MissingSchemaDefinition (toText danglingRef) (toText parSchema)
TypeRelationIsCyclic -> SelfTypingSchema
ReservedDefined ident -> SchemaNameReserved . toText $ ident
DefinedButNotUsed ident -> IsolatedSchemata . toText $ ident
MinMoreThanMax ident -> MinimumLengthGreaterThanMaximum . toText $ ident
DanglingTypeRefProp danglingRef parSchema ->
MissingPropSchemaDefinition (toText danglingRef) (toText parSchema)
DanglingTypeRefList danglingRef parSchema ->
MissingListSchemaDefinition (toText danglingRef) (toText parSchema)
DanglingTypeRefTuple danglingRef parSchema ->
MissingTupleSchemaDefinition (toText danglingRef) (toText parSchema)
DuplicatePropName ident prop ->
MultiplePropSchemaDefinition (toText ident) (unwrap prop)
PropertyWithoutObject schema ->
PropertySpecWithoutObjectType . toText $ schema
ListWithoutArray schema -> ListSpecWithoutArrayType . toText $ schema
TupleWithoutArray schema -> TupleSpecWithoutArrayType . toText $ schema
StringValsWithoutString schema ->
StringSpecWithoutStringType . toText $ schema