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

module Data.Medea.Loader
  ( LoaderError (..),
    buildSchema,
    loadSchemaFromFile,
    loadSchemaFromHandle,
  )
where

import Control.Monad.Except (MonadError (..), runExcept)
import Control.Monad.IO.Class (MonadIO (..))
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)

-- | Possible errors from loading Medea schemata.
data LoaderError
  = -- | The data provided wasn't UTF-8.
    NotUtf8
  | -- | Parsing failed.
    ParsingFailed
      !(ParseErrorBundle Text ParseError) -- ^ The errors we got. 
  | -- | No schema labelled @$start@ was provided.
    StartSchemaMissing
  | -- | A schema was typed in terms of itself.
    SelfTypingSchema
  | -- | A schema was defined more than once.
    MultipleSchemaDefinition 
      {-# UNPACK #-} !Text -- ^ The multiply-defined schema name.
  | -- | We expected a schema, but couldn't find it. 
    MissingSchemaDefinition 
      {-# UNPACK #-} !Text -- ^ Name of the schema we were expecting. 
      {-# UNPACK #-} !Text -- ^ Name of the schema that referenced it.
  | -- | A schema was named with a reserved identifier (other than @start@). 
    SchemaNameReserved 
      {-# UNPACK #-} !Text -- ^ The schema name.
  | -- | An isolated schema was found.
    IsolatedSchemata 
      {-# UNPACK #-} !Text -- ^ The schema name.
  | -- | A property schema refers to a non-existent schema.
    MissingPropSchemaDefinition 
      {-# UNPACK #-} !Text -- ^ Name of the non-existent schema being referenced.
      {-# UNPACK #-} !Text -- ^ Name of the referencing schema.
  | -- | A minimum length specification was more than its corresponding 
    -- maximum length specification.
    MinimumLengthGreaterThanMaximum 
      {-# UNPACK #-} !Text -- ^ The name of the schema with the faulty specification.
  | -- | A property was specified more than once. 
    MultiplePropSchemaDefinition 
      {-# UNPACK #-} !Text -- ^ Name of the parent schema.
      {-# UNPACK #-} !Text -- ^ Name of the property that was defined more than once.
  | -- | A list specification did not provide an element type. 
    MissingListSchemaDefinition 
      {-# UNPACK #-} !Text -- ^ Name of the missing list element type schema. 
      {-# UNPACK #-} !Text -- ^ Name of the parent schema.
  | -- | A tuple specification does not provide a positional schema. 
    MissingTupleSchemaDefinition 
      {-# UNPACK #-} !Text -- ^ Name of the missing tuple positional schema. 
      {-# UNPACK #-} !Text -- ^ Name of the parent schema.
  | -- | Schema had a property specification, but no @$object@ type.
    PropertySpecWithoutObjectType 
      {-# UNPACK #-} !Text -- ^ Schema name.
  | -- | Schema had a list specification, but no @$array@ type.
    ListSpecWithoutArrayType 
      {-# UNPACK #-} !Text -- ^ Schema name.
  | -- | Schema had a tuple specification, but no @$array@ type.
    TupleSpecWithoutArrayType 
      {-# UNPACK #-} !Text -- ^ Schema name.
  | -- | Schema had a string specification, but no @$string@ type.
    StringSpecWithoutStringType 
      {-# UNPACK #-} !Text -- ^ Schema name.
  deriving stock (LoaderError -> LoaderError -> Bool
(LoaderError -> LoaderError -> Bool)
-> (LoaderError -> LoaderError -> Bool) -> Eq LoaderError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LoaderError -> LoaderError -> Bool
$c/= :: LoaderError -> LoaderError -> Bool
== :: LoaderError -> LoaderError -> Bool
$c== :: LoaderError -> LoaderError -> Bool
Eq, Int -> LoaderError -> ShowS
[LoaderError] -> ShowS
LoaderError -> String
(Int -> LoaderError -> ShowS)
-> (LoaderError -> String)
-> ([LoaderError] -> ShowS)
-> Show LoaderError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoaderError] -> ShowS
$cshowList :: [LoaderError] -> ShowS
show :: LoaderError -> String
$cshow :: LoaderError -> String
showsPrec :: Int -> LoaderError -> ShowS
$cshowsPrec :: Int -> LoaderError -> ShowS
Show)

-- | Attempt to produce a schema from UTF-8 data in memory.
buildSchema ::
  (MonadError LoaderError m) =>
  ByteString ->
  m Schema
buildSchema :: ByteString -> m Schema
buildSchema ByteString
bs = do
  Text
utf8 <- ByteString -> m Text
forall (m :: * -> *).
MonadError LoaderError m =>
ByteString -> m Text
parseUtf8 ByteString
bs
  Specification
spec <- String -> Text -> m Specification
forall (m :: * -> *).
MonadError LoaderError m =>
String -> Text -> m Specification
fromUtf8 String
":memory:" Text
utf8
  Specification -> m Schema
forall (m :: * -> *).
MonadError LoaderError m =>
Specification -> m Schema
analyze Specification
spec

-- | Parse and process a Medea schema graph file.
loadSchemaFromFile ::
  (MonadIO m, MonadError LoaderError m) =>
  FilePath ->
  m Schema
loadSchemaFromFile :: String -> m Schema
loadSchemaFromFile String
fp = do
  ByteString
contents <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (String -> IO ByteString) -> String -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
readFile (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ String
fp
  Text
utf8 <- ByteString -> m Text
forall (m :: * -> *).
MonadError LoaderError m =>
ByteString -> m Text
parseUtf8 ByteString
contents
  Specification
spec <- String -> Text -> m Specification
forall (m :: * -> *).
MonadError LoaderError m =>
String -> Text -> m Specification
fromUtf8 String
fp Text
utf8
  Specification -> m Schema
forall (m :: * -> *).
MonadError LoaderError m =>
Specification -> m Schema
analyze Specification
spec

-- | Load data corresponding to a Medea schema graph file from a 'Handle'.
loadSchemaFromHandle ::
  (MonadIO m, MonadError LoaderError m) =>
  Handle ->
  m Schema
loadSchemaFromHandle :: Handle -> m Schema
loadSchemaFromHandle Handle
h = do
  ByteString
contents <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (Handle -> IO ByteString) -> Handle -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ByteString
hGetContents (Handle -> m ByteString) -> Handle -> m ByteString
forall a b. (a -> b) -> a -> b
$ Handle
h
  Text
utf8 <- ByteString -> m Text
forall (m :: * -> *).
MonadError LoaderError m =>
ByteString -> m Text
parseUtf8 ByteString
contents
  Specification
spec <- String -> Text -> m Specification
forall (m :: * -> *).
MonadError LoaderError m =>
String -> Text -> m Specification
fromUtf8 (Handle -> String
forall a. Show a => a -> String
show Handle
h) Text
utf8
  Specification -> m Schema
forall (m :: * -> *).
MonadError LoaderError m =>
Specification -> m Schema
analyze Specification
spec

-- Helper

parseUtf8 ::
  (MonadError LoaderError m) =>
  ByteString ->
  m Text
parseUtf8 :: ByteString -> m Text
parseUtf8 = (UnicodeException -> m Text)
-> (Text -> m Text) -> Either UnicodeException Text -> m Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m Text -> UnicodeException -> m Text
forall a b. a -> b -> a
const (LoaderError -> m Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError LoaderError
NotUtf8)) Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UnicodeException Text -> m Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
decodeUtf8'

fromUtf8 ::
  (MonadError LoaderError m) =>
  String ->
  Text ->
  m Schemata.Specification
fromUtf8 :: String -> Text -> m Specification
fromUtf8 String
sourceName Text
utf8 =
  case Parsec ParseError Text Specification
-> String
-> Text
-> Either (ParseErrorBundle Text ParseError) Specification
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec ParseError Text Specification
Schemata.parseSpecification String
sourceName Text
utf8 of
    Left ParseErrorBundle Text ParseError
err -> LoaderError -> m Specification
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Specification)
-> (ParseErrorBundle Text ParseError -> LoaderError)
-> ParseErrorBundle Text ParseError
-> m Specification
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text ParseError -> LoaderError
ParsingFailed (ParseErrorBundle Text ParseError -> m Specification)
-> ParseErrorBundle Text ParseError -> m Specification
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text ParseError
err
    Right Specification
scm -> Specification -> m Specification
forall (f :: * -> *) a. Applicative f => a -> f a
pure Specification
scm

analyze ::
  (MonadError LoaderError m) =>
  Schemata.Specification ->
  m Schema
analyze :: Specification -> m Schema
analyze Specification
scm = case Except AnalysisError (Map Identifier CompiledSchema)
-> Either AnalysisError (Map Identifier CompiledSchema)
forall e a. Except e a -> Either e a
runExcept (Except AnalysisError (Map Identifier CompiledSchema)
 -> Either AnalysisError (Map Identifier CompiledSchema))
-> Except AnalysisError (Map Identifier CompiledSchema)
-> Either AnalysisError (Map Identifier CompiledSchema)
forall a b. (a -> b) -> a -> b
$ Specification
-> Except AnalysisError (Map Identifier CompiledSchema)
forall (m :: * -> *).
MonadError AnalysisError m =>
Specification -> m (Map Identifier CompiledSchema)
compileSchemata Specification
scm of
  Left (DuplicateSchemaName Identifier
ident) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> LoaderError
MultipleSchemaDefinition (Identifier -> Text
toText Identifier
ident)
  Left AnalysisError
NoStartSchema -> LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError LoaderError
StartSchemaMissing
  Left (DanglingTypeReference Identifier
danglingRef Identifier
parSchema) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LoaderError
MissingSchemaDefinition (Identifier -> Text
toText Identifier
danglingRef) (Identifier -> Text
toText Identifier
parSchema)
  Left AnalysisError
TypeRelationIsCyclic -> LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError LoaderError
SelfTypingSchema
  Left (ReservedDefined Identifier
ident) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> LoaderError
SchemaNameReserved (Identifier -> Text
toText Identifier
ident)
  Left (DefinedButNotUsed Identifier
ident) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> LoaderError
IsolatedSchemata (Identifier -> Text
toText Identifier
ident)
  Left (DanglingTypeRefProp Identifier
danglingRef Identifier
parSchema) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LoaderError
MissingPropSchemaDefinition (Identifier -> Text
toText Identifier
danglingRef) (Identifier -> Text
toText Identifier
parSchema)
  Left (MinMoreThanMax Identifier
ident) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> LoaderError
MinimumLengthGreaterThanMaximum (Identifier -> Text
toText Identifier
ident)
  Left (DuplicatePropName Identifier
ident MedeaString
prop) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$
      Text -> Text -> LoaderError
MultiplePropSchemaDefinition (Identifier -> Text
toText Identifier
ident) (MedeaString -> Text
unwrap MedeaString
prop)
  Left (DanglingTypeRefList Identifier
danglingRef Identifier
parSchema) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LoaderError
MissingListSchemaDefinition (Identifier -> Text
toText Identifier
danglingRef) (Identifier -> Text
toText Identifier
parSchema)
  Left (DanglingTypeRefTuple Identifier
danglingRef Identifier
parSchema) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LoaderError
MissingTupleSchemaDefinition (Identifier -> Text
toText Identifier
danglingRef) (Identifier -> Text
toText Identifier
parSchema)
  Left (PropertyWithoutObject Identifier
schema) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> LoaderError
PropertySpecWithoutObjectType (Identifier -> Text
toText Identifier
schema)
  Left (ListWithoutArray Identifier
schema) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> LoaderError
ListSpecWithoutArrayType (Identifier -> Text
toText Identifier
schema)
  Left (TupleWithoutArray Identifier
schema) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> LoaderError
TupleSpecWithoutArrayType (Identifier -> Text
toText Identifier
schema)
  Left (StringValsWithoutString Identifier
schema) ->
    LoaderError -> m Schema
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LoaderError -> m Schema) -> LoaderError -> m Schema
forall a b. (a -> b) -> a -> b
$ Text -> LoaderError
StringSpecWithoutStringType (Identifier -> Text
toText Identifier
schema)
  Right Map Identifier CompiledSchema
g -> Schema -> m Schema
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> m Schema)
-> (Map Identifier CompiledSchema -> Schema)
-> Map Identifier CompiledSchema
-> m Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Identifier CompiledSchema -> Schema
Schema (Map Identifier CompiledSchema -> m Schema)
-> Map Identifier CompiledSchema -> m Schema
forall a b. (a -> b) -> a -> b
$ Map Identifier CompiledSchema
g