{-# LANGUAGE ScopedTypeVariables #-}

module StaticLS.HI.File (
    readHiFile,
    srcFilePathToHiFilePath,
    getModIfaceFromTdi,
    tdiToHiFilePath,
    modToHiFile,
) where

import Control.Exception
import Control.Monad
import Control.Monad.IO.Unlift (MonadIO, liftIO)
import Control.Monad.Trans.Maybe (MaybeT (..))
import qualified Data.Set as Set
import qualified GHC
import qualified GHC.Iface.Binary as GHC
import qualified GHC.Platform as GHC
import qualified GHC.Platform.Profile as GHC
import qualified GHC.Types.Name.Cache as GHC
import qualified Language.LSP.Protocol.Types as LSP
import StaticLS.FilePath
import StaticLS.SrcFiles
import StaticLS.StaticEnv
import System.FilePath ((</>))

getModIfaceFromTdi :: (HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> MaybeT m GHC.ModIface
getModIfaceFromTdi :: forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> MaybeT m ModIface
getModIfaceFromTdi = m (Maybe ModIface) -> MaybeT m ModIface
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe ModIface) -> MaybeT m ModIface)
-> (FilePath -> m (Maybe ModIface))
-> FilePath
-> MaybeT m ModIface
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> m (Maybe ModIface)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe ModIface)
readHiFile (FilePath -> MaybeT m ModIface)
-> (TextDocumentIdentifier -> MaybeT m FilePath)
-> TextDocumentIdentifier
-> MaybeT m ModIface
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< TextDocumentIdentifier -> MaybeT m FilePath
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> MaybeT m FilePath
tdiToHiFilePath

tdiToHiFilePath :: (HasStaticEnv m, MonadIO m) => LSP.TextDocumentIdentifier -> MaybeT m HiFilePath
tdiToHiFilePath :: forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
TextDocumentIdentifier -> MaybeT m FilePath
tdiToHiFilePath = FilePath -> MaybeT m FilePath
forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
FilePath -> MaybeT m FilePath
srcFilePathToHiFilePath (FilePath -> MaybeT m FilePath)
-> (TextDocumentIdentifier -> MaybeT m FilePath)
-> TextDocumentIdentifier
-> MaybeT m FilePath
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (m (Maybe FilePath) -> MaybeT m FilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe FilePath) -> MaybeT m FilePath)
-> (TextDocumentIdentifier -> m (Maybe FilePath))
-> TextDocumentIdentifier
-> MaybeT m FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> m (Maybe FilePath)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> m (Maybe FilePath))
-> (TextDocumentIdentifier -> Maybe FilePath)
-> TextDocumentIdentifier
-> m (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> Maybe FilePath
LSP.uriToFilePath (Uri -> Maybe FilePath)
-> (TextDocumentIdentifier -> Uri)
-> TextDocumentIdentifier
-> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (._uri))

modToHiFile :: (HasStaticEnv m, MonadIO m) => GHC.ModuleName -> MaybeT m HiFilePath
modToHiFile :: forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
ModuleName -> MaybeT m FilePath
modToHiFile ModuleName
modName = do
    StaticEnv
staticEnv <- MaybeT m StaticEnv
forall (m :: * -> *). HasStaticEnv m => m StaticEnv
getStaticEnv
    let hiFiles :: FilePath
hiFiles = StaticEnv
staticEnv.hiFilesPath
    FilePath -> MaybeT m FilePath
forall a. a -> MaybeT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> MaybeT m FilePath) -> FilePath -> MaybeT m FilePath
forall a b. (a -> b) -> a -> b
$ StaticEnv
staticEnv.wsRoot FilePath -> FilePath -> FilePath
</> FilePath
hiFiles FilePath -> FilePath -> FilePath
</> ModuleName -> FilePath -> FilePath
modToFilePath ModuleName
modName FilePath
".hi"

-- | Only supports 64 bit platforms
readHiFile :: (MonadIO m) => FilePath -> m (Maybe GHC.ModIface)
readHiFile :: forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe ModIface)
readHiFile FilePath
filePath = do
    NameCache
nameCache <- IO NameCache -> m NameCache
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NameCache -> m NameCache) -> IO NameCache -> m NameCache
forall a b. (a -> b) -> a -> b
$ Char -> [Name] -> IO NameCache
GHC.initNameCache Char
'a' []
    IO (Maybe ModIface) -> m (Maybe ModIface)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ModIface) -> m (Maybe ModIface))
-> IO (Maybe ModIface) -> m (Maybe ModIface)
forall a b. (a -> b) -> a -> b
$
        ( ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just
            (ModIface -> Maybe ModIface) -> IO ModIface -> IO (Maybe ModIface)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Profile
-> NameCache
-> CheckHiWay
-> TraceBinIFace
-> FilePath
-> IO ModIface
GHC.readBinIface
                GHC.Profile
                    { profilePlatform :: Platform
GHC.profilePlatform = Platform
GHC.genericPlatform
                    , profileWays :: Ways
GHC.profileWays = Ways
forall a. Set a
Set.empty
                    }
                NameCache
nameCache
                CheckHiWay
GHC.IgnoreHiWay
                TraceBinIFace
GHC.QuietBinIFace
                FilePath
filePath
        )
            IO (Maybe ModIface)
-> (IOException -> IO (Maybe ModIface)) -> IO (Maybe ModIface)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
_ :: IOException) -> Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ModIface
forall a. Maybe a
Nothing)
            IO (Maybe ModIface)
-> (GhcException -> IO (Maybe ModIface)) -> IO (Maybe ModIface)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(GhcException
_ :: GHC.GhcException) -> Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ModIface
forall a. Maybe a
Nothing)
            IO (Maybe ModIface)
-> (SomeException -> IO (Maybe ModIface)) -> IO (Maybe ModIface)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SomeException
_ :: SomeException) -> Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ModIface
forall a. Maybe a
Nothing)

srcFilePathToHiFilePath :: (HasStaticEnv m, MonadIO m) => SrcFilePath -> MaybeT m HiFilePath
srcFilePathToHiFilePath :: forall (m :: * -> *).
(HasStaticEnv m, MonadIO m) =>
FilePath -> MaybeT m FilePath
srcFilePathToHiFilePath FilePath
srcPath = do
    StaticEnv
staticEnv <- MaybeT m StaticEnv
forall (m :: * -> *). HasStaticEnv m => m StaticEnv
getStaticEnv
    let hiFiles :: FilePath
hiFiles = StaticEnv
staticEnv.hiFilesPath
        hiDir :: FilePath
hiDir = StaticEnv
staticEnv.wsRoot FilePath -> FilePath -> FilePath
</> FilePath
hiFiles
    FilePath -> FilePath -> FilePath -> FilePath -> MaybeT m FilePath
forall (m :: * -> *).
MonadIO m =>
FilePath -> FilePath -> FilePath -> FilePath -> MaybeT m FilePath
subRootExtensionFilepath StaticEnv
staticEnv.wsRoot FilePath
hiDir FilePath
".hi" FilePath
srcPath