{-# 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]
-> 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)