{-# 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

-- returns the first file that matches the predicate
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

-- the first parent directory where a file or directory name matches the predicate
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]

-- from extra
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'

-- from extra
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 = [[]] -- never happens