Skip some duplicated work while fetching dependencies (purescript#112)

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,16 +44,16 @@ 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
 
 -- | Start a repl
 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
 

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

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)
 

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)