{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Trustworthy #-}
module ReWire.HSE.Parse (tryParseInDir) where

import ReWire.Error
import ReWire.HSE.SrcLoc () -- the `Annotation SrcLoc` instance.

import qualified Data.Text as Txt
import Language.Haskell.Exts (parseFileWithMode, ParseResult (..), defaultParseMode, ParseMode (..))
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist, doesDirectoryExist)

import safe Control.Monad.IO.Class (liftIO, MonadIO)
import safe Language.Haskell.Exts.SrcLoc (SrcSpanInfo, SrcLoc (..))
import safe Language.Haskell.Exts.Syntax (Module (..))

tryParseInDir :: (MonadIO m, MonadError AstError m) => FilePath -> FilePath -> m (Maybe (FilePath, Module SrcSpanInfo))
tryParseInDir :: forall (m :: * -> *).
(MonadIO m, MonadError AstError m) =>
FilePath -> FilePath -> m (Maybe (FilePath, Module SrcSpanInfo))
tryParseInDir FilePath
fp FilePath
dp = do
      dExists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
dp
      if not dExists then pure Nothing else do
            oldCwd <- liftIO getCurrentDirectory
            liftIO $ setCurrentDirectory dp
            exists <- liftIO $ doesFileExist fp
            result <- if not exists then pure Nothing else do
                  pr <- liftIO parse
                  Just . (dp, ) <$> pr2Err pr
            liftIO $ setCurrentDirectory oldCwd
            pure result

      where pr2Err :: MonadError AstError m => ParseResult a -> m a
            pr2Err :: forall (m :: * -> *) a.
MonadError AstError m =>
ParseResult a -> m a
pr2Err = \ case
                  ParseOk a
p                       -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
p
                  ParseFailed (SrcLoc FilePath
"" Int
r Int
c) FilePath
msg -> SrcLoc -> Text -> m a
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt (FilePath -> Int -> Int -> SrcLoc
SrcLoc FilePath
fp Int
r Int
c) (FilePath -> Text
Txt.pack FilePath
msg)
                  ParseFailed SrcLoc
l FilePath
msg               -> SrcLoc -> Text -> m a
forall (m :: * -> *) an a.
(MonadError AstError m, Annotation an) =>
an -> Text -> m a
failAt SrcLoc
l (FilePath -> Text
Txt.pack FilePath
msg)

            parse :: IO (ParseResult (Module SrcSpanInfo))
            parse :: IO (ParseResult (Module SrcSpanInfo))
parse = ParseMode -> FilePath -> IO (ParseResult (Module SrcSpanInfo))
parseFileWithMode ParseMode
defaultParseMode { parseFilename = fp, fixities = Nothing } FilePath
fp