-- 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 -> FilePath
package_dir :: FilePath
  , Context -> [Text]
ghcflags :: [Text]
  , Context -> Text
ghcpath :: Text
  , Context -> FilePath
srcdir :: FilePath
  }

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

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

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

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

-- note that any formatting in these messages are stripped
help_ghcflags :: String
help_ghcflags :: FilePath
help_ghcflags = FilePath
"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 :: e -> m (Maybe a) -> ExceptT e m a
failWithM e
e m (Maybe a)
ma = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> m (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ (Either e a -> (a -> Either e a) -> Maybe a -> Either e a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e a
forall a b. a -> Either a b
Left e
e) a -> Either e a
forall a b. b -> Either a b
Right) (Maybe a -> Either e a) -> m (Maybe a) -> m (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe a)
ma