{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
module HsInspect.Util where
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
import qualified GHC.Utils.Outputable as GHC
#elif MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Utils.Outputable as GHC
import qualified GHC.Driver.Session as GHC
#else
import qualified DynFlags as GHC
import qualified Outputable as GHC
#endif
import qualified GHC as GHC
import Control.Monad.IO.Class
import Data.List (find, isSuffixOf, nub)
import Data.Maybe (catMaybes)
import Data.Set (Set)
import qualified Data.Set as Set
import System.Directory (doesDirectoryExist, listDirectory, makeAbsolute)
import System.FilePath (takeDirectory, takeFileName, (</>))
homeSources :: GHC.GhcMonad m => m [FilePath]
homeSources :: forall (m :: * -> *). GhcMonad m => m [FilePath]
homeSources = do
DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
[FilePath]
paths <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> IO FilePath
makeAbsolute forall a b. (a -> b) -> a -> b
$ DynFlags -> [FilePath]
GHC.importPaths DynFlags
dflags
let infer :: FilePath -> m [FilePath]
infer FilePath
dir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO [FilePath]
walkSuffix FilePath
".hs" FilePath
dir
forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}. MonadIO m => FilePath -> m [FilePath]
infer [FilePath]
paths
showGhc :: (GHC.Outputable a) => a -> String
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)
showGhc :: forall a. Outputable a => a -> FilePath
showGhc = forall a. Outputable a => a -> FilePath
GHC.showPprUnsafe
#else
showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags
#endif
getTargetModules :: GHC.GhcMonad m => m (Set GHC.ModuleName)
getTargetModules :: forall (m :: * -> *). GhcMonad m => m (Set ModuleName)
getTargetModules = do
[Target]
args <- forall (m :: * -> *). GhcMonad m => m [Target]
GHC.getTargets
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ Target -> Maybe ModuleName
getModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Target]
args
where
getModule :: GHC.Target -> Maybe GHC.ModuleName
getModule :: Target -> Maybe ModuleName
getModule GHC.Target{TargetId
targetId :: Target -> TargetId
targetId :: TargetId
GHC.targetId} = case TargetId
targetId of
GHC.TargetModule ModuleName
m -> forall a. a -> Maybe a
Just ModuleName
m
GHC.TargetFile FilePath
_ Maybe Phase
_ -> forall a. Maybe a
Nothing
locateDominating :: (String -> Bool) -> FilePath -> IO (Maybe FilePath)
locateDominating :: (FilePath -> Bool) -> FilePath -> IO (Maybe FilePath)
locateDominating FilePath -> Bool
p FilePath
dir = do
[FilePath]
files <- FilePath -> IO [FilePath]
listDirectory FilePath
dir
let parent :: FilePath
parent = FilePath -> FilePath
takeDirectory FilePath
dir
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find FilePath -> Bool
p forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeFileName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
files of
Just FilePath
file -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
file
Maybe FilePath
Nothing ->
if FilePath
parent forall a. Eq a => a -> a -> Bool
== FilePath
dir
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
else (FilePath -> Bool) -> FilePath -> IO (Maybe FilePath)
locateDominating FilePath -> Bool
p FilePath
parent
locateDominatingDir :: (String -> Bool) -> FilePath -> IO (Maybe FilePath)
locateDominatingDir :: (FilePath -> Bool) -> FilePath -> IO (Maybe FilePath)
locateDominatingDir FilePath -> Bool
p FilePath
dir = do
Maybe FilePath
file' <- (FilePath -> Bool) -> FilePath -> IO (Maybe FilePath)
locateDominating FilePath -> Bool
p FilePath
dir
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
file'
walkSuffix :: String -> FilePath -> IO [FilePath]
walkSuffix :: FilePath -> FilePath -> IO [FilePath]
walkSuffix FilePath
suffix FilePath
dir = forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath
suffix forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
walk FilePath
dir
walk :: FilePath -> IO [FilePath]
walk :: FilePath -> IO [FilePath]
walk FilePath
dir = do
Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
dir
if Bool
isDir
then do
[FilePath]
fs <- FilePath -> IO [FilePath]
listDirectory FilePath
dir
let base :: FilePath
base = FilePath
dir forall a. Semigroup a => a -> a -> a
<> FilePath
"/"
qfs :: [FilePath]
qfs = (FilePath
base forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath]
fs
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM FilePath -> IO [FilePath]
walk [FilePath]
qfs
else forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
dir]
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
op = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> m [b] -> m [b]
f (forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
where
f :: a -> m [b] -> m [b]
f a
x m [b]
xs = do
[b]
x' <- a -> m [b]
op a
x
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [b]
x'
then m [b]
xs
else do
[b]
xs' <- m [b]
xs
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [b]
x' forall a. [a] -> [a] -> [a]
++ [b]
xs'
split :: (a -> Bool) -> [a] -> [[a]]
split :: forall a. (a -> Bool) -> [a] -> [[a]]
split a -> Bool
_ [] = [[]]
split a -> Bool
f (a
x : [a]
xs) | a -> Bool
f a
x = [] forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [[a]]
split a -> Bool
f [a]
xs
| [a]
y : [[a]]
ys <- forall a. (a -> Bool) -> [a] -> [[a]]
split a -> Bool
f [a]
xs = (a
x forall a. a -> [a] -> [a]
: [a]
y) forall a. a -> [a] -> [a]
: [[a]]
ys
| Bool
otherwise = [[]]