-- Calls to the hsinspect binary must have some context, which typically must be
-- discovered from the file that the user is currently visiting.
--
-- This module gathers the definition of the context and the logic to infer it,
-- which assumes that .cabal (or package.yaml) and .ghc.flags files are present.
module HsInspect.Context where

import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Except (ExceptT(..))
import Data.List (isSuffixOf)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import HsInspect.Util (locateDominating, locateDominatingDir)
import System.FilePath

data Context = Context
  { Context -> String
package_dir :: FilePath
  , Context -> [Text]
ghcflags :: [Text]
  , Context -> Text
ghcpath :: Text
  , Context -> String
srcdir :: FilePath
  }

findContext :: FilePath -> ExceptT String IO Context
findContext :: String -> ExceptT String IO Context
findContext String
src = do
  String
ghcflags' <- String -> ExceptT String IO String
discoverGhcflags String
src
  String
ghcpath' <- String -> ExceptT String IO String
discoverGhcpath String
src
  let readWords :: String -> ExceptT String IO [Text]
readWords String
file = Text -> [Text]
T.words forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExceptT String IO Text
readFile' String
file
      readFile' :: String -> ExceptT String IO Text
readFile' = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
T.readFile
  Text
ghcpath <- String -> ExceptT String IO Text
readFile' String
ghcpath'
  String -> [Text] -> Text -> String -> Context
Context forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExceptT String IO String
discoverPackageDir String
src forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> ExceptT String IO [Text]
readWords String
ghcflags' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
ghcpath forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> String
takeDirectory String
ghcflags')

-- c.f. haskell-tng--compile-dominating-package
discoverPackageDir :: FilePath -> ExceptT String IO FilePath
discoverPackageDir :: String -> ExceptT String IO String
discoverPackageDir String
file = do
  let dir :: String
dir = String -> String
takeDirectory String
file
      isCabal :: String -> Bool
isCabal = (String
".cabal" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`)
      isHpack :: String -> Bool
isHpack = (String
"package.yaml" forall a. Eq a => a -> a -> Bool
==)
  forall (m :: * -> *) e a.
Applicative m =>
e -> m (Maybe a) -> ExceptT e m a
failWithM String
"There must be a .cabal or package.yaml" forall a b. (a -> b) -> a -> b
$
    (String -> Bool) -> String -> IO (Maybe String)
locateDominatingDir (\String
f -> String -> Bool
isCabal String
f Bool -> Bool -> Bool
|| String -> Bool
isHpack String
f) String
dir

discoverGhcflags :: FilePath -> ExceptT String IO FilePath
discoverGhcflags :: String -> ExceptT String IO String
discoverGhcflags String
file = do
  let dir :: String
dir = String -> String
takeDirectory String
file
  forall (m :: * -> *) e a.
Applicative m =>
e -> m (Maybe a) -> ExceptT e m a
failWithM (String
"There must be a .ghc.flags file. " forall a. [a] -> [a] -> [a]
++ String
help_ghcflags) forall a b. (a -> b) -> a -> b
$
   (String -> Bool) -> String -> IO (Maybe String)
locateDominating (String
".ghc.flags" forall a. Eq a => a -> a -> Bool
==) String
dir

discoverGhcpath :: FilePath -> ExceptT String IO FilePath
discoverGhcpath :: String -> ExceptT String IO String
discoverGhcpath String
file = do
  let dir :: String
dir = String -> String
takeDirectory String
file
  forall (m :: * -> *) e a.
Applicative m =>
e -> m (Maybe a) -> ExceptT e m a
failWithM (String
"There must be a .ghc.path file. " forall a. [a] -> [a] -> [a]
++ String
help_ghcflags) forall a b. (a -> b) -> a -> b
$
    (String -> Bool) -> String -> IO (Maybe String)
locateDominating (String
".ghc.path" forall a. Eq a => a -> a -> Bool
==) String
dir

-- note that any formatting in these messages are stripped
help_ghcflags :: String
help_ghcflags :: String
help_ghcflags = String
"The cause of this error could be that this package has not been compiled yet, \
                \or the ghcflags compiler plugin has not been installed for this package. \
                \See https://gitlab.com/tseenshe/hsinspect#installation for more details."

-- from Control.Error.Util
failWithM :: Applicative m => e -> m (Maybe a) -> ExceptT e m a
failWithM :: forall (m :: * -> *) e a.
Applicative m =>
e -> m (Maybe a) -> ExceptT e m a
failWithM e
e m (Maybe a)
ma = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left e
e) forall a b. b -> Either a b
Right) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe a)
ma