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