{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}

module StaticLS.StaticEnv (
    initStaticEnv,
    runStaticLs,
    getStaticEnv,
    runHieDbExceptT,
    runHieDbMaybeT,
    StaticEnv (..),
    StaticLs,
    HieDbPath,
    HieFilePath,
    HasStaticEnv,
)
where

import Control.Exception (Exception, IOException, SomeException, catch)
import Control.Monad.IO.Unlift (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader (..))
import Control.Monad.Trans.Except (ExceptT (..))
import Control.Monad.Trans.Maybe (MaybeT (..), exceptToMaybeT)
import Control.Monad.Trans.Reader (ReaderT (..))
import Database.SQLite.Simple (SQLError)
import qualified GHC
import qualified GHC.Paths as GHC
import qualified GHC.Types.Name.Cache as GHC
import qualified HieDb
import StaticLS.StaticEnv.Options (StaticEnvOptions (..))
import System.FilePath ((</>))

runStaticLs :: StaticEnv -> StaticLs a -> IO a
runStaticLs :: forall a. StaticEnv -> StaticLs a -> IO a
runStaticLs = (StaticLs a -> StaticEnv -> IO a)
-> StaticEnv -> StaticLs a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StaticLs a -> StaticEnv -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

type HieDbPath = FilePath
type HieFilePath = FilePath

data HieDbException
    = HieDbIOException IOException
    | HieDbSqlException SQLError
    | HieDbNoHieDbSourceException
    | HieDbOtherException
    deriving (Int -> HieDbException -> ShowS
[HieDbException] -> ShowS
HieDbException -> String
(Int -> HieDbException -> ShowS)
-> (HieDbException -> String)
-> ([HieDbException] -> ShowS)
-> Show HieDbException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HieDbException -> ShowS
showsPrec :: Int -> HieDbException -> ShowS
$cshow :: HieDbException -> String
show :: HieDbException -> String
$cshowList :: [HieDbException] -> ShowS
showList :: [HieDbException] -> ShowS
Show)

instance Exception HieDbException

-- | Static environment used to fetch data
data StaticEnv = StaticEnv
    { StaticEnv -> Maybe String
hieDbPath :: Maybe HieDbPath
    -- ^ Path to the hiedb file
    , StaticEnv -> Maybe String
hieFilesPath :: Maybe HieFilePath
    , StaticEnv -> HscEnv
hscEnv :: GHC.HscEnv
    -- ^ static ghc compiler environment
    , StaticEnv -> NameCache
nameCache :: GHC.NameCache
    -- ^ name cache - used for reading hie files
    , StaticEnv -> String
wsRoot :: FilePath
    -- ^ workspace root
    }

type StaticLs = ReaderT StaticEnv IO

type HasStaticEnv = MonadReader StaticEnv

getStaticEnv :: (HasStaticEnv m) => m StaticEnv
getStaticEnv :: forall (m :: * -> *). HasStaticEnv m => m StaticEnv
getStaticEnv = m StaticEnv
forall r (m :: * -> *). MonadReader r m => m r
ask

initStaticEnv :: FilePath -> StaticEnvOptions -> IO StaticEnv
initStaticEnv :: String -> StaticEnvOptions -> IO StaticEnv
initStaticEnv String
wsRoot StaticEnvOptions
staticEnvOptions =
    do
        let databasePath :: Maybe String
databasePath = ShowS -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
wsRoot String -> ShowS
</>) StaticEnvOptions
staticEnvOptions.optionHieDbPath
            hieFilesPath :: Maybe String
hieFilesPath = ShowS -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
wsRoot String -> ShowS
</>) StaticEnvOptions
staticEnvOptions.optionHieFilesPath
        -- TODO: find out if this is safe to do or if we should just use GhcT
        HscEnv
hscEnv <- Maybe String -> Ghc HscEnv -> IO HscEnv
forall a. Maybe String -> Ghc a -> IO a
GHC.runGhc (String -> Maybe String
forall a. a -> Maybe a
Just String
GHC.libdir) Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
        -- TODO: not sure what the first parameter to name cache is - find out
        NameCache
nameCache <- Char -> [Name] -> IO NameCache
GHC.initNameCache Char
'a' []

        let serverStaticEnv :: StaticEnv
serverStaticEnv =
                StaticEnv
                    { $sel:hieDbPath:StaticEnv :: Maybe String
hieDbPath = Maybe String
databasePath
                    , $sel:hieFilesPath:StaticEnv :: Maybe String
hieFilesPath = Maybe String
hieFilesPath
                    , $sel:hscEnv:StaticEnv :: HscEnv
hscEnv = HscEnv
hscEnv
                    , $sel:nameCache:StaticEnv :: NameCache
nameCache = NameCache
nameCache
                    , $sel:wsRoot:StaticEnv :: String
wsRoot = String
wsRoot
                    }
        StaticEnv -> IO StaticEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StaticEnv
serverStaticEnv

-- | Run an hiedb action in an exceptT
runHieDbExceptT :: (HasStaticEnv m, MonadIO m) => (HieDb.HieDb -> IO a) -> ExceptT HieDbException m a
runHieDbExceptT :: forall (m :: * -> *) a.
(HasStaticEnv m, MonadIO m) =>
(HieDb -> IO a) -> ExceptT HieDbException m a
runHieDbExceptT HieDb -> IO a
hieDbFn =
    ExceptT HieDbException m StaticEnv
forall (m :: * -> *). HasStaticEnv m => m StaticEnv
getStaticEnv
        ExceptT HieDbException m StaticEnv
-> (StaticEnv -> ExceptT HieDbException m a)
-> ExceptT HieDbException m a
forall a b.
ExceptT HieDbException m a
-> (a -> ExceptT HieDbException m b) -> ExceptT HieDbException m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \StaticEnv
staticEnv ->
            ExceptT HieDbException m a
-> (String -> ExceptT HieDbException m a)
-> Maybe String
-> ExceptT HieDbException m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (m (Either HieDbException a) -> ExceptT HieDbException m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either HieDbException a) -> ExceptT HieDbException m a)
-> (HieDbException -> m (Either HieDbException a))
-> HieDbException
-> ExceptT HieDbException m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either HieDbException a -> m (Either HieDbException a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HieDbException a -> m (Either HieDbException a))
-> (HieDbException -> Either HieDbException a)
-> HieDbException
-> m (Either HieDbException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieDbException -> Either HieDbException a
forall a b. a -> Either a b
Left (HieDbException -> ExceptT HieDbException m a)
-> HieDbException -> ExceptT HieDbException m a
forall a b. (a -> b) -> a -> b
$ HieDbException
HieDbNoHieDbSourceException)
                ( \String
hiedbPath ->
                    m (Either HieDbException a) -> ExceptT HieDbException m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either HieDbException a) -> ExceptT HieDbException m a)
-> (IO (Either HieDbException a) -> m (Either HieDbException a))
-> IO (Either HieDbException a)
-> ExceptT HieDbException m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either HieDbException a) -> m (Either HieDbException a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either HieDbException a) -> ExceptT HieDbException m a)
-> IO (Either HieDbException a) -> ExceptT HieDbException m a
forall a b. (a -> b) -> a -> b
$
                        String
-> (HieDb -> IO (Either HieDbException a))
-> IO (Either HieDbException a)
forall a. String -> (HieDb -> IO a) -> IO a
HieDb.withHieDb String
hiedbPath ((a -> Either HieDbException a)
-> IO a -> IO (Either HieDbException a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either HieDbException a
forall a b. b -> Either a b
Right (IO a -> IO (Either HieDbException a))
-> (HieDb -> IO a) -> HieDb -> IO (Either HieDbException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieDb -> IO a
hieDbFn)
                            IO (Either HieDbException a)
-> (IOException -> IO (Either HieDbException a))
-> IO (Either HieDbException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Either HieDbException a -> IO (Either HieDbException a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HieDbException a -> IO (Either HieDbException a))
-> (IOException -> Either HieDbException a)
-> IOException
-> IO (Either HieDbException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieDbException -> Either HieDbException a
forall a b. a -> Either a b
Left (HieDbException -> Either HieDbException a)
-> (IOException -> HieDbException)
-> IOException
-> Either HieDbException a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> HieDbException
HieDbIOException)
                            IO (Either HieDbException a)
-> (SQLError -> IO (Either HieDbException a))
-> IO (Either HieDbException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Either HieDbException a -> IO (Either HieDbException a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HieDbException a -> IO (Either HieDbException a))
-> (SQLError -> Either HieDbException a)
-> SQLError
-> IO (Either HieDbException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieDbException -> Either HieDbException a
forall a b. a -> Either a b
Left (HieDbException -> Either HieDbException a)
-> (SQLError -> HieDbException)
-> SQLError
-> Either HieDbException a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQLError -> HieDbException
HieDbSqlException)
                            IO (Either HieDbException a)
-> (SomeException -> IO (Either HieDbException a))
-> IO (Either HieDbException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SomeException
_ :: SomeException) -> Either HieDbException a -> IO (Either HieDbException a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HieDbException a -> IO (Either HieDbException a))
-> (HieDbException -> Either HieDbException a)
-> HieDbException
-> IO (Either HieDbException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieDbException -> Either HieDbException a
forall a b. a -> Either a b
Left (HieDbException -> IO (Either HieDbException a))
-> HieDbException -> IO (Either HieDbException a)
forall a b. (a -> b) -> a -> b
$ HieDbException
HieDbOtherException)
                )
                StaticEnv
staticEnv.hieDbPath

-- | Run an hiedb action with the MaybeT Monad
runHieDbMaybeT :: (HasStaticEnv m, MonadIO m) => (HieDb.HieDb -> IO a) -> MaybeT m a
runHieDbMaybeT :: forall (m :: * -> *) a.
(HasStaticEnv m, MonadIO m) =>
(HieDb -> IO a) -> MaybeT m a
runHieDbMaybeT = ExceptT HieDbException m a -> MaybeT m a
forall (m :: * -> *) e a. Functor m => ExceptT e m a -> MaybeT m a
exceptToMaybeT (ExceptT HieDbException m a -> MaybeT m a)
-> ((HieDb -> IO a) -> ExceptT HieDbException m a)
-> (HieDb -> IO a)
-> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HieDb -> IO a) -> ExceptT HieDbException m a
forall (m :: * -> *) a.
(HasStaticEnv m, MonadIO m) =>
(HieDb -> IO a) -> ExceptT HieDbException m a
runHieDbExceptT