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

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

-- 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
  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]

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

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