{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
module HsInspect.Util where
import Data.List (intercalate)
import Data.List (isSuffixOf)
import Data.Maybe (catMaybes)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified GHC as GHC
import qualified Module as GHC
import System.Directory (doesDirectoryExist, listDirectory)
normaliseUnitId :: GHC.UnitId -> String
normaliseUnitId (GHC.unitIdString -> unitid) =
case reverse $ split ('-' ==) unitid of
"inplace" : _ -> unitid
_ : version : pkg ->
if any ('.' ==) version
then intercalate "-" (pkg <> [version])
else unitid
_ -> unitid
getTargetModules :: GHC.GhcMonad m => m (Set GHC.ModuleName)
getTargetModules = do
args <- GHC.getTargets
pure . Set.fromList . catMaybes $ getModule <$> args
where
getModule :: GHC.Target -> Maybe GHC.ModuleName
getModule GHC.Target{GHC.targetId} = case targetId of
GHC.TargetModule m -> Just m
GHC.TargetFile _ _ -> Nothing
walkSuffix :: String -> FilePath -> IO [FilePath]
walkSuffix suffix dir = filter (suffix `isSuffixOf`) <$> walk dir
walk :: FilePath -> IO [FilePath]
walk dir = do
isDir <- doesDirectoryExist dir
if isDir
then do
fs <- listDirectory dir
let base = dir <> "/"
qfs = (base <>) <$> fs
concatMapM walk qfs
else pure [dir]
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM op = foldr f (pure [])
where
f x xs = do
x' <- op x
if null x'
then xs
else do
xs' <- xs
pure $ x' ++ xs'
split :: (a -> Bool) -> [a] -> [[a]]
split _ [] = [[]]
split f (x : xs) | f x = [] : split f xs
| y : ys <- split f xs = (x : y) : ys
| otherwise = [[]]