module GHC.ParMake.Parse (getModuleDeps, depsListToDeps)
where
import Control.Concurrent
import Control.Monad
import Data.Char (isAlphaNum, isSpace)
import Data.Functor ((<$>))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import System.Exit (ExitCode(..))
import System.FilePath ((</>))
import System.IO.Temp (withSystemTempDirectory)
import Distribution.Compat.ReadP
import GHC.ParMake.Types (Dep(..))
import GHC.ParMake.Util (Verbosity, debug', fatal,
defaultOutputHooks, runProcess)
parseModuleName :: ReadP r String
parseModuleName = munch1 (\c -> isAlphaNum c || c == '.'
|| c == '-' || c == '/' || c == '_')
parseLine :: String -> Maybe (String, String)
parseLine l = case [ r | (r, rest) <- readP_to_S parser l, all isSpace rest] of
[] -> Nothing
[r] -> Just r
_ -> Nothing
where
parser = do skipSpaces
m <- parseModuleName
skipSpaces
_ <- char ':'
skipSpaces
d <- parseModuleName
skipSpaces
return (m,d)
trimLines :: [String] -> [String]
trimLines ls = [ l | l <- ls, isValidLine l]
where
isValidLine ('#':_) = False
isValidLine _ = True
getModuleDeps :: Verbosity
-> FilePath
-> [String]
-> [FilePath]
-> IO [Dep]
getModuleDeps v ghcPath ghcArgs files =
withSystemTempDirectory "ghc-parmake" $ \tmpDir -> do
let tmpFileInternal = tmpDir </> "depends.internal.mk"
tmpFileExternal = tmpDir </> "depends.external.mk"
let ghcArgsInternal = files ++ ("-M":"-dep-makefile":tmpFileInternal:ghcArgs)
ghcArgsExternal = files ++
("-M":"-dep-makefile":tmpFileExternal:"-include-pkg-deps":ghcArgs)
let getInternalMakeDeps = do
debug' v $ "Running compiler with -M to get internal module deps: "
++ ghcPath ++ " " ++ show ghcArgsInternal
failOnError <$> runProcess defaultOutputHooks Nothing
ghcPath ghcArgsInternal
parseDepsFromFile tmpFileInternal
let getAllMakeDeps = do
debug' v $ "Running compiler with '-M -include-pkg-deps' "
++ "to get external module deps: "
++ ghcPath ++ " " ++ show ghcArgsExternal
failOnError <$> runProcess defaultOutputHooks Nothing
ghcPath ghcArgsExternal
parseDepsFromFile tmpFileExternal
[internalMakeDeps, allMakeDeps] <- parallelIO [ getInternalMakeDeps
, getAllMakeDeps ]
let depsIntAll = mergeValues (groupByTarget internalMakeDeps)
(groupByTarget allMakeDeps)
return [ Dep target int (intExt `diff` int)
| (target, (int, intExt)) <- Map.toList depsIntAll ]
where
failOnError (ExitSuccess ) = ()
failOnError (ExitFailure n) =
fatal $ "ghc -M exited with status " ++ show n
parseDepsFromFile :: FilePath -> IO [(String, String)]
parseDepsFromFile file = catMaybes . map parseLine . trimLines . lines
<$> readFile file
diff :: (Ord a) => [a] -> [a] -> [a]
xs `diff` ys = filter (`Set.member` diffSet) xs
where
diffSet = Set.fromList xs `Set.difference` Set.fromList ys
parallelIO :: [IO a] -> IO [a]
parallelIO ios = do
mvars <- forM ios $ \io -> do m <- newEmptyMVar
_ <- forkIO $ io >>= putMVar m
return m
mapM readMVar mvars
groupByTarget :: (Ord target) => [(target, dep)] -> Map target [dep]
groupByTarget deps = Map.fromListWith (++) [ (t, [d]) | (t, d) <- deps ]
mergeValues :: (Ord k) => Map k [a] -> Map k [b] -> Map k ([a], [b])
mergeValues m1 m2 = Map.unionWith (\(a,b) (x,y) -> (a ++ x, b ++ y))
(fmap (, []) m1)
(fmap ([], ) m2)
depsListToDeps :: [(FilePath, FilePath)] -> [Dep]
depsListToDeps l = [ Dep t ds [] | (t, ds) <- Map.toList (groupByTarget l) ]