Look up remote imports dynamically when doing frozen check

CHANGELOG.md

@@ -22,6 +22,7 @@ Bugfixes:
 - Fix failure to copy to global cache on a different filesystem (#385)
 - Fix watch function on Windows (issue with paths) (#387, #380)
 - "Quit" command in watch mode now actually quits (#390, #389)
+- Look up remote imports dynamically when doing frozen check (#349)
 
 ## [0.9.0] - 2019-07-30
 

app/Spago.hs

@@ -384,7 +384,7 @@ main = do
  Verify cacheConfig package -> Spago.Packages.verify cacheConfig (Just package)
  VerifySet cacheConfig -> Spago.Packages.verify cacheConfig Nothing
  PackageSetUpgrade -> Spago.Packages.upgradePackageSet
- Freeze -> Spago.Packages.freeze
+ Freeze -> Spago.Packages.freeze Spago.Packages.packagesPath
  Build buildOptions -> Spago.Build.build buildOptions Nothing
  Test modName buildOptions nodeArgs -> Spago.Build.test modName buildOptions nodeArgs
  BumpVersion dryRun spec -> Spago.Version.bumpVersion dryRun spec

package.yaml

@@ -42,49 +42,49 @@ default-extensions:
 library:
  source-dirs: src
  dependencies:
- - base >= 4.7 && < 5
- - text < 1.3
- - Cabal
- - turtle
- - either
- - filepath
- - file-embed
- - template-haskell
  - aeson
  - aeson-pretty
- - containers
+ - ansi-terminal
+ - async-pool
+ - base >= 4.7 && < 5
  - bower-json
+ - bytestring
+ - Cabal
+ - containers
  - dhall
  - dhall-json
- - bytestring
- - prettyprinter
- - async-pool
- - process
- - network-uri
- - versions
- - lens-family-core
- - safe
- - fsnotify
- - Glob
- - stm
  - directory >= 1.3.4.0
- - mtl
+ - either
  - exceptions
- - unliftio
- - vector
- - temporary
- - zlib
- - tar
+ - file-embed
+ - filepath
  - foldl
+ - fsnotify
+ - github
+ - Glob
  - http-client
  - http-conduit
- - time
- - either
+ - lens-family-core
+ - mtl
+ - network-uri
+ - prettyprinter
+ - process
+ - retry
+ - safe
  - semver-range
- - ansi-terminal
+ - stm
+ - tar
+ - template-haskell
+ - temporary
+ - text < 1.3
+ - time
+ - transformers
+ - turtle
+ - unliftio
  - unordered-containers
- - retry
- - github
+ - vector
+ - versions
+ - zlib
 
 executables:
  spago:
@@ -97,11 +97,11 @@ executables:
  - -rtsopts
  - -with-rtsopts=-N
  dependencies:
- - spago
  - base >= 4.7 && < 5
+ - optparse-applicative
+ - spago
  - text < 1.3
  - turtle
- - optparse-applicative
 
  spago-curator:
  main: Curator.hs
@@ -113,24 +113,24 @@ executables:
  - -rtsopts
  - -with-rtsopts=-N
  dependencies:
- - spago
- - base >= 4.7 && < 5
- - text < 1.3
- - turtle
- - filepath
  - aeson-pretty
+ - async-pool
+ - base >= 4.7 && < 5
+ - bytestring
  - containers
  - dhall
- - bytestring
- - async-pool
- - process
+ - filepath
  - github
  - lens-family-core
+ - process
+ - retry
+ - spago
  - stm
- - vector
  - temporary
- - retry
+ - text < 1.3
  - time
+ - turtle
+ - vector
 
 tests:
  spec:
@@ -141,12 +141,12 @@ tests:
  - -with-rtsopts=-N
  dependencies:
  - base >= 4.7 && < 5
- - text < 1.3
- - turtle
- - process
+ - containers
  - directory
- - temporary
  - extra
- - containers
+ - process
  - QuickCheck
  - spago
+ - temporary
+ - text < 1.3
+ - turtle

src/Spago/Config.hs

@@ -96,10 +96,10 @@ parsePackage (Dhall.App (Dhall.Field union "Local") (Dhall.TextLit (Dhall.Chunks
  Dhall.inputWithSettings
  (set Dhall.rootDirectory (Text.unpack localPath) Dhall.defaultInputSettings)
  dependenciesType
- (Dhall.pretty newExpr)
+ (pretty newExpr)
  let location = PackageSet.Local{..}
  pure PackageSet.Package{..}
-parsePackage expr = die $ Messages.failedToParsePackage $ Dhall.pretty expr
+parsePackage expr = die $ Messages.failedToParsePackage $ pretty expr
 
 
 -- | Tries to read in a Spago Config
@@ -151,7 +151,7 @@ ensureConfig = do
  die $ Messages.cannotFindConfig
  try parseConfig >>= \case
  Right config -> do
- PackageSet.ensureFrozen
+ PackageSet.ensureFrozen $ Text.unpack path
  pure config
  Left (err :: Dhall.ReadError Dhall.TypeCheck.X) -> throwM err
 

src/Spago/Dhall.hs

@@ -6,6 +6,7 @@ module Spago.Dhall
 
 import Spago.Prelude
 
+import qualified Control.Monad.Trans.State.Strict as State
 import qualified Data.Text as Text
 import qualified Data.Text.Prettyprint.Doc as Pretty
 import qualified Data.Text.Prettyprint.Doc.Render.Text as PrettyText
@@ -17,6 +18,7 @@ import qualified Dhall.Map
 import qualified Dhall.Parser as Parser
 import qualified Dhall.Pretty
 import Dhall.TypeCheck (X, typeOf)
+import qualified Lens.Family
 
 type DhallExpr a = Dhall.Expr Parser.Src a
 
@@ -33,19 +35,31 @@ format pathText = liftIO $
  path = Just $ Text.unpack pathText
 
 
--- | Prettyprint a Dhall expression
-pretty :: Pretty.Pretty a => DhallExpr a -> Dhall.Text
-pretty = PrettyText.renderStrict
- . Pretty.layoutPretty Pretty.defaultLayoutOptions
- . Pretty.pretty
-
 -- | Prettyprint a Dhall expression adding a comment on top
 prettyWithHeader :: Pretty.Pretty a => Text -> DhallExpr a -> Dhall.Text
 prettyWithHeader header expr = do
  let doc = Pretty.pretty header <> Pretty.pretty expr
  PrettyText.renderStrict $ Pretty.layoutSmart Pretty.defaultLayoutOptions doc
 
 
+-- | Return a list of all imports starting from a particular file
+readImports :: Text -> IO [Dhall.Import]
+readImports pathText = do
+ fileContents <- readTextFile $ pathFromText pathText
+ expr <- throws $ Parser.exprFromText mempty fileContents
+ (_, status) <- load expr
+ let graph = Lens.Family.view Dhall.Import.graph status
+ pure $ childImport <$> graph
+ where
+ load expr
+ = State.runStateT
+ (Dhall.Import.loadWith expr)
+ (Dhall.Import.emptyStatus ".")
+
+ childImport
+ = Dhall.Import.chainedImport . Dhall.Import.child
+
+
 readRawExpr :: Text -> IO (Maybe (Text, DhallExpr Dhall.Import))
 readRawExpr pathText = do
  exists <- testfile pathText

src/Spago/Messages.hs

@@ -152,6 +152,11 @@ freezePackageSet = makeMessage
  [ "Generating new hashes for the package set file so it will be cached.. (this might take some time)"
  ]
 
+failedToCheckPackageSetFrozen :: Text
+failedToCheckPackageSetFrozen = makeMessage
+ [ "WARNING: wasn't able to check if your package set import is frozen"
+ ]
+
 failedToCopyToGlobalCache :: Show a => a -> Text
 failedToCopyToGlobalCache err = makeMessage
  [ "WARNING: was not able to copy the download to the global cache."

src/Spago/PackageSet.hs

@@ -4,11 +4,12 @@ module Spago.PackageSet
  , makePackageSetFile
  , freeze
  , ensureFrozen
- , path
+ , packagesPath
  ) where
 
 import Spago.Prelude
 
+import qualified Data.Text as Text
 import qualified Data.Versions as Version
 import Dhall.Binary (defaultStandardVersion)
 import qualified Dhall.Freeze
@@ -19,20 +20,21 @@ import qualified Spago.GitHub as GitHub
 import Spago.Messages as Messages
 import qualified Spago.Purs as Purs
 import qualified Spago.Templates as Templates
+import qualified System.IO
 
 
-path :: IsString t => t
-path = "packages.dhall"
+packagesPath :: IsString t => t
+packagesPath = "packages.dhall"
 
 
 -- | Tries to create the `packages.dhall` file if needed
 makePackageSetFile :: Spago m => Bool -> m ()
 makePackageSetFile force = do
- hasPackagesDhall <- testfile path
+ hasPackagesDhall <- testfile packagesPath
  if force || not hasPackagesDhall
- then writeTextFile path Templates.packagesDhall
- else echo $ Messages.foundExistingProject path
- Dhall.format path
+ then writeTextFile packagesPath Templates.packagesDhall
+ else echo $ Messages.foundExistingProject packagesPath
+ Dhall.format packagesPath
 
 
 -- | Tries to upgrade the Package-Sets release of the local package set.
@@ -57,7 +59,7 @@ upgradePackageSet = do
  updateTag releaseTagName = do
  let quotedTag = surroundQuote releaseTagName
  echoDebug $ "Found the most recent tag for \"purescript/package-sets\": " <> quotedTag
- rawPackageSet <- liftIO $ Dhall.readRawExpr path
+ rawPackageSet <- liftIO $ Dhall.readRawExpr packagesPath
  case rawPackageSet of
  Nothing -> die Messages.cannotFindPackages
  -- Skip the check if the tag is already the newest
@@ -69,9 +71,9 @@ upgradePackageSet = do
  echo $ "Upgrading the package set version to " <> quotedTag
  let newExpr = fmap (upgradeImports releaseTagName) expr
  echo $ Messages.upgradingPackageSet releaseTagName
- liftIO $ Dhall.writeRawExpr path (header, newExpr)
+ liftIO $ Dhall.writeRawExpr packagesPath (header, newExpr)
  -- If everything is fine, refreeze the imports
- freeze
+ freeze packagesPath
 
  getCurrentTag :: Dhall.Import -> [Text]
  getCurrentTag Dhall.Import
@@ -202,16 +204,26 @@ isRemoteFrozen :: Dhall.Import -> [Bool]
 isRemoteFrozen (Dhall.Import
  { importHashed = Dhall.ImportHashed
  { importType = Dhall.Remote _
+ , hash
  , ..
  }
  , ..
  }) = [isJust hash]
 isRemoteFrozen _ = []
 
 
+localImportPath :: Dhall.Import -> Maybe System.IO.FilePath
+localImportPath (Dhall.Import
+ { importHashed = Dhall.ImportHashed
+ { importType = localImport@(Dhall.Local _ _)
+ }
+ }) = Just $ Text.unpack $ pretty localImport
+localImportPath _ = Nothing
+
+
 -- | Freeze the package set remote imports so they will be cached
-freeze :: Spago m => m ()
-freeze = do
+freeze :: Spago m => System.IO.FilePath -> m ()
+freeze path = do
  echo Messages.freezePackageSet
  liftIO $
  Dhall.Freeze.freeze
@@ -223,13 +235,12 @@ freeze = do
 
 
 -- | Freeze the file if any of the remote imports are not frozen
-ensureFrozen :: Spago m => m ()
-ensureFrozen = do
+ensureFrozen :: Spago m => System.IO.FilePath -> m ()
+ensureFrozen path = do
  echoDebug "Ensuring that the package set is frozen"
- rawPackageSet <- liftIO $ Dhall.readRawExpr path
- case rawPackageSet of
- Nothing -> echo "WARNING: wasn't able to check if your package set file is frozen"
- Just (_header, expr) -> do
- let areRemotesFrozen = foldMap isRemoteFrozen expr
- unless (and areRemotesFrozen) $ do
- freeze
+ imports <- liftIO $ Dhall.readImports $ Text.pack path
+ let areRemotesFrozen = foldMap isRemoteFrozen imports
+ case areRemotesFrozen of
+ [] -> echo Messages.failedToCheckPackageSetFrozen
+ remotes -> unless (and remotes) $
+ traverse_ (maybe (pure ()) freeze . localImportPath) imports

src/Spago/Packages.hs

@@ -9,6 +9,7 @@ module Spago.Packages
  , getProjectDeps
  , PackageSet.upgradePackageSet
  , PackageSet.freeze
+ , PackageSet.packagesPath
  , PackagesFilter(..)
  , JsonFlag(..)
  , DepsOnly(..)