module StackRunAuto where
import Control.Concurrent.Async
import Control.Lens
import Data.Aeson.Lens
import Data.List.Utils (uniq)
import Data.Maybe (catMaybes)
import Data.Monoid
import Data.String.Utils
import qualified Data.Text as Text (pack, unpack)
import Data.Time.Clock
import Development.ExtractDependencies
import Development.FileModules
import Network.Wreq (defaults, getWith, param,
responseBody)
import System.Directory
import System.Exit
import System.FilePath
import System.IO (hPutStrLn, stderr)
import System.Process
data Options = Options { optsFileName :: FilePath
, optsExtras :: [String]
, optsFlags :: [String]
}
run :: Options -> IO ()
run Options{..} = do
modules <- fileModulesVerbose optsFileName
packages <- catMaybes <$> mapConcurrently modulePackageVerbose modules
allPackages <- mapConcurrently extractDependenciesVerbose (uniq packages)
let argList = map ("--package " ++)
(filter isValidPackage
(uniq (packages ++ concat allPackages ++ optsExtras)))
cmd = unwords [ "stack runghc "
, unwords optsFlags
, optsFileName
, unwords argList
]
putStrLn cmd
ph <- runCommand cmd
waitForProcess ph >>= exitWith
timed :: String -> IO a -> IO a
timed msg action = do
start <- getCurrentTime
ret <- action
end <- getCurrentTime
putStrLn $ msg ++ " (" ++ show (diffUTCTime end start) ++ ")"
return ret
isValidPackage :: String -> Bool
isValidPackage "rts" = False
isValidPackage _ = True
fileModulesVerbose :: String -> IO [String]
fileModulesVerbose optsFileName = timed "---> Parsed imports" $ do
putStrLn $ "Parsing " ++ optsFileName
uniq <$> fileModulesRecur optsFileName
extractDependenciesVerbose :: String -> IO [String]
extractDependenciesVerbose pkg = timed ("---> Found dependencies for " ++ pkg) $ do
putStrLn $ "Finding dependencies for " ++ pkg ++ "..."
extractDependenciesCached pkg
extractDependenciesCached :: String -> IO [String]
extractDependenciesCached = cached "extract-dependencies" extractDependencies
modulePackageVerbose :: String -> IO (Maybe String)
modulePackageVerbose "" = do
putStrLn "Skipping parse error (empty string)..."
return Nothing
modulePackageVerbose m = timed ("---> Found package for " ++ m) $ do
putStrLn $ "Finding package for " ++ m ++ "..."
modulePackageCached m
cached :: (Read b, Show b) => String -> (FilePath -> IO b) -> FilePath -> IO b
cached name fn arg = do
home <- getHomeDirectory
let cacheDir = home </> ".stack-run-auto" </> name
cachePth = cacheDir </> arg
createDirectoryIfMissing True cacheDir
exists <- doesFileExist cachePth
if exists
then read <$> readFile cachePth
else do
r <- fn arg
writeFile cachePth (show r)
return r
modulePackageCached :: String -> IO (Maybe String)
modulePackageCached = cached "module-package" modulePackage
modulePackage :: String -> IO (Maybe String)
modulePackage m = do
let url = "http://hayoo.fh-wedel.de/json"
opts = defaults & param "query" .~ ["module:" <> Text.pack m]
res <- getWith opts url
let result = res ^.. responseBody . key "result" . values
moduleResults = filter isModuleResult result
case moduleResults of
[] -> do
let errMsg = "No package found for " ++ m
hPutStrLn stderr errMsg
let mparts = split "." m
if not (null mparts)
then modulePackageVerbose (join "." (init mparts))
else error $ "Couldn't resolve package for " ++ m
(p:_) -> do
let pkg = Text.unpack (p ^. key "resultPackage" . _String)
return (Just pkg)
where
isModuleResult r = r ^. key "resultType" . _String == "module"