From 4e577d023954e5a46de0065ebb5f70ef37c985fd Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Thu, 14 Feb 2019 18:52:25 +0200 Subject: [PATCH 1/2] Skip some duplicated work while fetching dependencies --- app/Spago/Build.hs | 6 +++--- app/Spago/Config.hs | 2 +- app/Spago/PackageSet.hs | 4 ++-- app/Spago/Packages.hs | 23 ++++++++++++++--------- 4 files changed, 20 insertions(+), 15 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 80bcc41f7..a03c3544d 100644 --- a/app/Spago/PackageSet.hs +++ b/app/Spago/PackageSet.hs @@ -94,8 +94,8 @@ makePackageSetFile force = 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 48ff966f1..a35ed304d 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.PackageName(..) , PackagesFilter(..) @@ -14,6 +15,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) @@ -144,13 +146,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 @@ -170,10 +179,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)] @@ -192,7 +197,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) From 20cc48e3f729d6257f30a706977bd0e399c830c6 Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Thu, 14 Feb 2019 19:00:33 +0200 Subject: [PATCH 2/2] Make the Package fields strict --- app/Spago/PackageSet.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/app/Spago/PackageSet.hs b/app/Spago/PackageSet.hs index a03c3544d..fbbd7d4da 100644 --- a/app/Spago/PackageSet.hs +++ b/app/Spago/PackageSet.hs @@ -45,9 +45,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) @@ -59,8 +59,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