{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module FlatBuffers.Internal.Compiler.ParserIO where

import           Control.Monad                            ( when )
import           Control.Monad.Except                     ( MonadError, MonadIO, liftIO, throwError )
import           Control.Monad.State                      ( MonadState, execStateT, get, put )

import           Data.Coerce                              ( coerce )
import           Data.Foldable                            ( traverse_ )
import           Data.Map.Strict                          ( Map )
import qualified Data.Map.Strict                          as Map
import qualified Data.Text                                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 qualified System.Directory                         as Dir
import qualified System.FilePath                          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 :: FilePath -> [FilePath] -> m (FileTree Schema)
parseSchemas FilePath
rootFilePath [FilePath]
includeDirs = do
  FilePath
fileContent <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
rootFilePath
  case Parsec Void FilePath Schema
-> FilePath
-> FilePath
-> Either (ParseErrorBundle FilePath Void) Schema
forall e s a.
Parsec e s a -> FilePath -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void FilePath Schema
schema FilePath
rootFilePath FilePath
fileContent of
    Left ParseErrorBundle FilePath Void
err -> FilePath -> m (FileTree Schema)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FilePath -> m (FileTree Schema))
-> FilePath -> m (FileTree Schema)
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle FilePath Void -> FilePath
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> FilePath
errorBundlePretty ParseErrorBundle FilePath Void
err
    Right Schema
rootSchema -> do
      FilePath
rootFilePathCanon <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
Dir.canonicalizePath FilePath
rootFilePath
      let importedFilePaths :: [FilePath]
importedFilePaths = Text -> FilePath
T.unpack (Text -> FilePath) -> (Include -> Text) -> Include -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Include -> Text
coerce (Include -> FilePath) -> [Include] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema -> [Include]
includes Schema
rootSchema

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

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

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

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

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