From 98dc77b397d1342ed6391f030e09a8e90c4e86ef Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Sat, 16 Feb 2019 17:51:42 +0200 Subject: [PATCH] Skip some duplicated work while fetching dependencies (#112) --- app/Spago/Build.hs | 6 +++--- app/Spago/Config.hs | 2 +- app/Spago/PackageSet.hs | 14 +++++++------- app/Spago/Packages.hs | 23 ++++++++++++++--------- 4 files changed, 25 insertions(+), 20 deletions(-) diff --git a/app/Spago/Build.hs b/app/Spago/Build.hs index 66269c65c..8340ddeff 100644 --- a/app/Spago/Build.hs +++ b/app/Spago/Build.hs @@ -18,7 +18,7 @@ import System.IO (hPutStrLn) import qualified Turtle as T hiding (die, echo) import qualified Spago.Config as Config -import Spago.Packages as Packages +import qualified Spago.Packages as Packages import qualified Spago.Purs as Purs import Spago.Turtle @@ -44,8 +44,8 @@ prepareBundleDefaults maybeModuleName maybeTargetPath = (moduleName, targetPath) build :: (Maybe Int) -> [Purs.SourcePath] -> [Purs.ExtraArg] -> IO () build maybeLimit sourcePaths passthroughArgs = do config <- Config.ensureConfig - install maybeLimit mempty deps <- Packages.getProjectDeps config + Packages.fetchPackages maybeLimit deps let globs = Packages.getGlobs deps <> defaultSourcePaths <> sourcePaths Purs.compile globs passthroughArgs @@ -53,7 +53,7 @@ build maybeLimit sourcePaths passthroughArgs = do repl :: [Purs.SourcePath] -> [Purs.ExtraArg] -> IO () repl sourcePaths passthroughArgs = do config <- Config.ensureConfig - deps <- getProjectDeps config + deps <- Packages.getProjectDeps config let globs = Packages.getGlobs deps <> defaultSourcePaths <> sourcePaths Purs.repl globs passthroughArgs diff --git a/app/Spago/Config.hs b/app/Spago/Config.hs index da9fa9452..1197eb0bb 100644 --- a/app/Spago/Config.hs +++ b/app/Spago/Config.hs @@ -165,7 +165,7 @@ withConfigAST transform = do -- apply the transformation if config is valid RawConfig{..} <- case rawConfig of Right conf -> pure $ transform conf - Left err -> die $ Messages.failedToParseFile pathText err + Left err -> die $ Messages.failedToParseFile pathText err -- return the new AST from the new config let diff --git a/app/Spago/PackageSet.hs b/app/Spago/PackageSet.hs index 2aa690938..f7b2c7def 100644 --- a/app/Spago/PackageSet.hs +++ b/app/Spago/PackageSet.hs @@ -46,9 +46,9 @@ newtype PackageName = PackageName { packageName :: Text } -- | A spacchetti package. data Package = Package - { dependencies :: [PackageName] -- ^ list of dependency package names - , repo :: Repo -- ^ the remote git repository or the local path - , version :: Text -- ^ version string (also functions as a git ref) + { dependencies :: ![PackageName] -- ^ list of dependency package names + , repo :: !Repo -- ^ the remote git repository or the local path + , version :: !Text -- ^ version string (also functions as a git ref) } deriving (Eq, Show, Generic) @@ -60,8 +60,8 @@ type PackageSet = Map PackageName Package -- | We consider a "Repo" a "box of source to include in the build" -- This can have different nature: data Repo - = Local Text -- ^ A local path - | Remote Text -- ^ The address of a remote git repository + = Local !Text -- ^ A local path + | Remote !Text -- ^ The address of a remote git repository deriving (Eq, Show, Generic) instance ToJSON Repo @@ -102,8 +102,8 @@ freeze = do data RawPackageSet = RawPackageSet - { mkPackage :: Dhall.Import - , upstream :: Dhall.Import + { mkPackage :: !Dhall.Import + , upstream :: !Dhall.Import -- TODO: add additions and overrides if needed } deriving (Show, Generic) diff --git a/app/Spago/Packages.hs b/app/Spago/Packages.hs index e67b36706..a0bdc184f 100644 --- a/app/Spago/Packages.hs +++ b/app/Spago/Packages.hs @@ -6,6 +6,7 @@ module Spago.Packages , listPackages , getGlobs , getProjectDeps + , fetchPackages , PackageSet.upgradeSpacchetti , PackageSet.freeze , PackageSet.PackageName(..) @@ -15,6 +16,7 @@ module Spago.Packages import qualified Control.Concurrent.Async.Pool as Async import Control.Exception (SomeException, handle) import Data.Foldable (fold, for_, traverse_) +import Control.Monad (filterM) import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe (fromMaybe) @@ -145,13 +147,20 @@ fetchPackage pair@(PackageName{..}, Package{ repo = Remote repo, ..} ) = do fetchPackages :: Maybe Int -> [(PackageName, Package)] -> IO () -fetchPackages maybeLimit deps = do +fetchPackages maybeLimit allDeps = do PackageSet.checkPursIsUpToDate - echoStr $ "Installing " <> show (List.length deps) <> " dependencies." - Async.withTaskGroup limit $ \taskGroup -> do - asyncs <- for deps $ \dep -> Async.async taskGroup $ fetchPackage dep + echoStr $ "Installing " <> show (List.length allDeps) <> " dependencies." + + -- We try to fetch a dep only if their dir doesn't exist + depsToFetch <- (flip filterM) allDeps $ \dep -> do + exists <- T.testdir $ T.fromText $ getPackageDir dep + pure $ not exists + + -- By default we make one thread per dep to fetch, but this can be limited + Async.withTaskGroup (fromMaybe (length depsToFetch) maybeLimit) $ \taskGroup -> do + asyncs <- for depsToFetch $ \dep -> Async.async taskGroup $ fetchPackage dep handle (handler asyncs) $ for_ asyncs Async.wait echo "Installation complete." where @@ -171,10 +180,6 @@ fetchPackages maybeLimit deps = do Async.waitCatch async die "Installation failed." - -- We run a pretty high amount of threads by default, but this can be - -- limited by specifying an option - limit = fromMaybe 100 maybeLimit - -- | Return all the transitive dependencies of the current project getProjectDeps :: Config -> IO [(PackageName, Package)] @@ -193,7 +198,7 @@ getTransitiveDeps packageSet deps = case Map.lookup dep packageSet of Nothing -> die $ "Package " <> Text.pack (show dep) <> " was missing from the package set." - Just info@Package{ .. } -> do + Just info@Package{..} -> do m <- fold <$> traverse (go (Set.insert dep seen)) dependencies pure (Map.insert dep info m)