{-# LANGUAGE FlexibleContexts #-}

module FlatBuffers.Internal.Compiler.ParserIO where

import Control.Monad (when)
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State (MonadState, execStateT, get, put)
import Data.Coerce (coerce)
import Data.Foldable (traverse_)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import FlatBuffers.Internal.Compiler.Display (display)
import FlatBuffers.Internal.Compiler.Parser (schema)
import FlatBuffers.Internal.Compiler.SyntaxTree
  (FileTree(..), Include(..), Schema, StringLiteral(..), includes)
import System.Directory qualified as Dir
import System.FilePath qualified as FP
import Text.Megaparsec (errorBundlePretty, parse)

parseSchemas ::
     MonadIO m
  => MonadError String m
  => FilePath -- ^ Filepath of the root schema. It must be a path relative to the project root or an absolute path.
  -> [FilePath] -- ^ Directories to search for @include@s.
  -> m (FileTree Schema)
parseSchemas :: forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
String -> [String] -> m (FileTree Schema)
parseSchemas String
rootFilePath [String]
includeDirs = do
  String
fileContent <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
rootFilePath
  case Parsec Void String Schema
-> String -> String -> Either (ParseErrorBundle String Void) Schema
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void String Schema
schema String
rootFilePath String
fileContent of
    Left ParseErrorBundle String Void
err -> String -> m (FileTree Schema)
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m (FileTree Schema)) -> String -> m (FileTree Schema)
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
err
    Right Schema
rootSchema -> do
      String
rootFilePathCanon <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
Dir.canonicalizePath String
rootFilePath
      let importedFilePaths :: [String]
importedFilePaths = Text -> String
T.unpack (Text -> String) -> (Include -> Text) -> Include -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Include -> Text
forall a b. Coercible a b => a -> b
coerce (Include -> String) -> [Include] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema -> [Include]
includes Schema
rootSchema

      Map String Schema
importedSchemas <- (StateT (Map String Schema) m ()
 -> Map String Schema -> m (Map String Schema))
-> Map String Schema
-> StateT (Map String Schema) m ()
-> m (Map String Schema)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Map String Schema) m ()
-> Map String Schema -> m (Map String Schema)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Map String Schema
forall k a. Map k a
Map.empty (StateT (Map String Schema) m () -> m (Map String Schema))
-> StateT (Map String Schema) m () -> m (Map String Schema)
forall a b. (a -> b) -> a -> b
$
                            (String -> StateT (Map String Schema) m ())
-> [String] -> StateT (Map String Schema) m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
                              ([String] -> String -> String -> StateT (Map String Schema) m ()
forall (m :: * -> *).
(MonadState (Map String Schema) m, MonadIO m,
 MonadError String m) =>
[String] -> String -> String -> m ()
parseImportedSchema [String]
includeDirs String
rootFilePathCanon)
                              [String]
importedFilePaths
      FileTree Schema -> m (FileTree Schema)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileTree
            { fileTreeFilePath :: String
fileTreeFilePath = String
rootFilePathCanon
            , fileTreeRoot :: Schema
fileTreeRoot     = Schema
rootSchema
            , fileTreeForest :: Map String Schema
fileTreeForest   = Map String Schema
importedSchemas
            }

parseImportedSchema ::
     MonadState (Map FilePath Schema) m
  => MonadIO m
  => MonadError String m
  => [FilePath]
  -> FilePath
  -> FilePath
  -> m ()
parseImportedSchema :: forall (m :: * -> *).
(MonadState (Map String Schema) m, MonadIO m,
 MonadError String m) =>
[String] -> String -> String -> m ()
parseImportedSchema [String]
includeDirs String
rootFilePathCanon String
filePath =
  String -> String -> m ()
go String
rootFilePathCanon String
filePath
  where
    go :: String -> String -> m ()
go String
parentSchemaPath String
filePath = do

      let parentSchemaDir :: String
parentSchemaDir = String -> String
FP.takeDirectory String
parentSchemaPath
      let dirCandidates :: [String]
dirCandidates = String
parentSchemaDir String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
includeDirs

      Maybe String
actualFilePathCanonMaybe <- IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> m (Maybe String))
-> IO (Maybe String) -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> String -> IO (Maybe String)
Dir.findFile [String]
dirCandidates String
filePath IO (Maybe String)
-> (Maybe String -> IO (Maybe String)) -> IO (Maybe String)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO String) -> Maybe String -> IO (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse String -> IO String
Dir.canonicalizePath

      case Maybe String
actualFilePathCanonMaybe of
        Maybe String
Nothing -> String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
          String
"File '"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
filePath
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' (imported from '"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
parentSchemaPath
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"') not found.\nSearched in these directories: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Display a => a -> String
display [String]
dirCandidates
        Just String
actualFilePathCanon -> do
          Map String Schema
importedSchemas <- m (Map String Schema)
forall s (m :: * -> *). MonadState s m => m s
get
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
actualFilePathCanon String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
rootFilePathCanon Bool -> Bool -> Bool
&& String
actualFilePathCanon String -> Map String Schema -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map String Schema
importedSchemas) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            String
fileContent <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
actualFilePathCanon
            case Parsec Void String Schema
-> String -> String -> Either (ParseErrorBundle String Void) Schema
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void String Schema
schema String
actualFilePathCanon String
fileContent of
              Left ParseErrorBundle String Void
err -> String -> m ()
forall a. String -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle String Void
err
              Right Schema
importedSchema -> do
                Map String Schema -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (String -> Schema -> Map String Schema -> Map String Schema
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
actualFilePathCanon Schema
importedSchema Map String Schema
importedSchemas)
                (Include -> m ()) -> [Include] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (String -> String -> m ()
go String
actualFilePathCanon (String -> m ()) -> (Include -> String) -> Include -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Include -> Text) -> Include -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Include -> Text
forall a b. Coercible a b => a -> b
coerce) (Schema -> [Include]
includes Schema
importedSchema)