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')
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
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."
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