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(..)