diff --git a/CHANGELOG.md b/CHANGELOG.md index 47046ca30..c4e90d34e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,6 +24,7 @@ New features: - `spago run` now recognizes backend specified in the configuration file and calls the backend with `--run` argument. - documentation now includes a step-by-step guide on setting up a Spago/Parcel project (#456) - documentation now includes a step-by-step guide on setting up a Spago/Node and Spago/Webpack project (#456-extra) +- moved warning and error logs to stderr, adjusted logging strategy (#256) - `spago path` returns output path so that it can be shared with tools such as `purs-loader` Bugfixes: diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 7e43a3e00..cb81002cb 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -83,6 +83,15 @@ $ npm install -g bower $ stack test ``` +note: if you receive the following error from running tests: +hGetContents: invalid argument (invalid byte sequence) + +You may be missing an environment variable. try the following + +```bash +$ LC_ALL=en_US.iso88591 +$ stack test +``` ## Merging changes diff --git a/app/Curator.hs b/app/Curator.hs index 8ef64ef6e..9a606cd04 100644 --- a/app/Curator.hs +++ b/app/Curator.hs @@ -117,11 +117,11 @@ main = do Env.setEnv "GIT_TERMINAL_PROMPT" "0" -- Read GitHub Auth Token - echo "Reading GitHub token.." + output "Reading GitHub token.." token <- (GitHub.OAuth . Encoding.encodeUtf8 . Text.pack) <$> Env.getEnv "SPACCHETTIBOTTI_TOKEN" -- Prepare data folder that will contain the temp copies of the repos - echo "Creating 'data' folder" + output "Creating 'data' folder" mktree "data" -- Start spawning threads @@ -159,7 +159,7 @@ main = do let threadLoop = do pullChan <- atomically $ Chan.dupTChan bus forever $ atomically (Chan.readTChan pullChan) >>= thread - echo $ "Spawning thread " <> tshow name + output $ "Spawning thread " <> tshow name void $ Concurrent.forkIO $ catch threadLoop $ \(err :: SomeException) -> do -- TODO: use logError from RIO instead of this crap {- @@ -171,7 +171,7 @@ main = do <> (BSL.fromStrict . Encoding.encodeUtf8 . tshow) err <> "\n\n\n" -} - echo $ "Thread " <> tshow name <> " broke, restarting.." + output $ "Thread " <> tshow name <> " broke, restarting.." spawnThread name thread @@ -183,13 +183,13 @@ main = do getLatestRelease :: GitHub.AuthMethod am => am -> GitHubAddress -> IO (Either GitHub.Error GitHub.Release) getLatestRelease token address@(Address owner repo) = do - echo $ "Getting latest release for " <> tshow address + output $ "Getting latest release for " <> tshow address GitHub.executeRequest token $ GitHub.latestReleaseR owner repo getTags :: GitHub.AuthMethod am => am -> GitHubAddress -> IO (Either GitHub.Error (Maybe Tag, (Map Tag CommitHash))) getTags token address@(Address owner repo) = do - echo $ "Getting tags for " <> tshow address + output $ "Getting tags for " <> tshow address res <- GitHub.executeRequest token $ GitHub.tagsForR owner repo GitHub.FetchAll let f vec = ( (Tag . GitHub.tagName) <$> vec Vector.!? 0 @@ -206,7 +206,7 @@ getTags token address@(Address owner repo) = do getCommits :: GitHub.AuthMethod am => am -> GitHubAddress -> IO (Either GitHub.Error [CommitHash]) getCommits token address@(Address owner repo) = do - echo $ "Getting commits for " <> tshow address + output $ "Getting commits for " <> tshow address res <- GitHub.executeRequest token $ GitHub.commitsForR owner repo GitHub.FetchAll pure $ fmap (Vector.toList . fmap (CommitHash . GitHub.untagName . GitHub.commitSha)) res @@ -275,7 +275,7 @@ checkLatestRelease token address RefreshState = getLatestRelease token address > -- We don't do anything if we have a release saved and it's the current one Just currentRelease | currentRelease == releaseTagName -> pure () _ -> do - echo $ "Found a new release for " <> tshow address <> ": " <> releaseTagName + output $ "Found a new release for " <> tshow address <> ": " <> releaseTagName atomically $ Chan.writeTChan bus $ NewRepoRelease address releaseTagName checkLatestRelease _ _ _ = pure () @@ -298,18 +298,18 @@ spagoUpdatePackageSets _ _ = pure () -- the package on the bus. metadataFetcher :: GitHub.AuthMethod am => am -> Message -> IO () metadataFetcher token RefreshState = do - echo "Downloading and parsing package set.." + output "Downloading and parsing package set.." packageSet <- fetchPackageSet atomically $ Chan.writeTChan bus $ NewPackageSet packageSet let packages = Map.toList packageSet - echoStr $ "Fetching metadata for " <> show (length packages) <> " packages" + outputStr $ "Fetching metadata for " <> show (length packages) <> " packages" -- Call GitHub for all these packages and get metadata for them metadata <- Async.withTaskGroup 10 $ \taskGroup -> do asyncs <- for packages (Async.async taskGroup . fetchRepoMetadata) for asyncs Async.wait - echo "Fetched all metadata." + output "Fetched all metadata." atomically $ Chan.writeTChan bus $ NewMetadata $ foldMap (uncurry Map.singleton) metadata where @@ -325,7 +325,7 @@ metadataFetcher token RefreshState = do False -> repoUrl address = Address (GitHub.mkName Proxy owner) (GitHub.mkName Proxy repo) - echo $ "Retry " <> tshow rsIterNumber <> ": fetching tags and commits for " <> tshow address + output $ "Retry " <> tshow rsIterNumber <> ": fetching tags and commits for " <> tshow address !eitherTags <- getTags token address !eitherCommits <- getCommits token address @@ -356,9 +356,9 @@ metadataUpdater (NewMetadata metadata) = do let writeMetadata :: GHC.IO.FilePath -> IO () writeMetadata tempfolder = do path <- makeAbsolute (tempfolder "metadataV1new.json") - echo $ "Writing metadata to file: " <> tshow path + output $ "Writing metadata to file: " <> tshow path BSL.writeFile path $ encodePretty metadata - echo "Done." + output "Done." let commitMessage = "Update GitHub index file" runAndPushMaster metadataRepo commitMessage @@ -377,7 +377,7 @@ packageSetCommenter token (NewVerification result) = do case maybePR of Nothing -> do - echo "Could not find an open PR, waiting 5 mins.." + output "Could not find an open PR, waiting 5 mins.." Concurrent.threadDelay (5 * 60 * 1000000) atomically $ Chan.writeTChan bus $ NewVerification result Just GitHub.PullRequest{..} -> do @@ -404,8 +404,8 @@ packageSetCommenter token (NewVerification result) = do ] let (Address owner repo) = packageSetsRepo (GitHub.executeRequest token $ GitHub.createCommentR owner repo pullRequestNumber commentBody) >>= \case - Left err -> echo $ "Something went wrong while commenting. Error: " <> tshow err - Right _ -> echo "Commented on the open PR" + Left err -> output $ "Something went wrong while commenting. Error: " <> tshow err + Right _ -> output "Commented on the open PR" packageSetCommenter _ _ = pure () @@ -458,13 +458,13 @@ packageSetsUpdater token (NewMetadata newMetadata) = do let patchVersions path = do for_ (Map.toList newVersionsWithBanned) $ \(packageName, (tag, owner)) -> do - echo $ "Patching version for " <> tshow packageName + output $ "Patching version for " <> tshow packageName withAST (Text.pack $ path "src" "groups" Text.unpack (Text.toLower owner) <> ".dhall") $ updateVersion packageName tag - echo "Verifying new set. This might take a LONG while.." + output "Verifying new set. This might take a LONG while.." result <- runWithCwd path "cd src; spago init; spago verify-set" - echo "Verified packages, spamming the channel with the result.." + output "Verified packages, spamming the channel with the result.." atomically $ Chan.writeTChan bus $ NewVerification result let commands = @@ -473,10 +473,10 @@ packageSetsUpdater token (NewMetadata newMetadata) = do , "git add src/groups" ] - echo $ "Found " <> tshow (length newVersions) <> " packages to update" + output $ "Found " <> tshow (length newVersions) <> " packages to update" when (length newVersions > 0) $ do - echo $ tshow newVersions + output $ tshow newVersions -- If we have more than one package to update, let's see if we already have an -- open PR to package-sets. If we do we can just commit there maybePR <- getPullRequestForUser token "spacchettibotti" packageSetsRepo @@ -514,7 +514,7 @@ packageSetsUpdater token (NewMetadata newMetadata) = do , Time.diffUTCTime lastCommitTime lastCommentTime > 0 ] let patchVersions' path = shouldVerifyAgain path >>= \case - False -> echo "Skipping verification as there's nothing new under the sun.." + False -> output "Skipping verification as there's nothing new under the sun.." True -> do patchVersions path updatePullRequestBody token packageSetsRepo pullRequestNumber $ mkBody newVersions' newBanned @@ -598,16 +598,16 @@ runAndOpenPR token PullRequest{ prAddress = address@Address{..}, ..} preAction c = unlessM pullRequestExists (runInClonedRepo address prBranchName prTitle preAction commands openPR) where openPR = do - echo "Pushed a new commit, opening PR.." + output "Pushed a new commit, opening PR.." response <- GitHub.executeRequest token $ GitHub.createPullRequestR owner repo $ GitHub.CreatePullRequest prTitle prBody prBranchName "master" case response of - Right _ -> echo "Created PR 🎉" - Left err' -> echoStr $ "Error while creating PR: " <> show err' + Right _ -> output "Created PR 🎉" + Left err' -> outputStr $ "Error while creating PR: " <> show err' pullRequestExists = do - echo $ "Checking if we ever opened a PR " <> surroundQuote prTitle + output $ "Checking if we ever opened a PR " <> surroundQuote prTitle oldPRs <- GitHub.executeRequest token $ GitHub.pullRequestsForR owner repo @@ -615,13 +615,13 @@ runAndOpenPR token PullRequest{ prAddress = address@Address{..}, ..} preAction c GitHub.FetchAll case oldPRs of Left err -> do - echoStr $ "Error: " <> show err + outputStr $ "Error: " <> show err pure True Right prs | not $ Vector.null prs -> do - echo "PR was opened, skipping.." + output "PR was opened, skipping.." pure True Right _ -> do - echo "No previous PRs found, opening one.." + output "No previous PRs found, opening one.." pure False @@ -635,28 +635,28 @@ runInClonedRepo address@Address{..} branchName commit preAction commands postAct if code /= ExitSuccess then do failure - echo out - echo err + output out + output err else success (code, _out, _err) <- runWithCwd path $ "git clone git@github.com:" <> GitHub.untagName owner <> "/" <> GitHub.untagName repo <> ".git" if code /= ExitSuccess - then echo "Error while cloning repo" + then output "Error while cloning repo" else do - echo $ "Cloned " <> tshow address + output $ "Cloned " <> tshow address -- Configure the repo: set the git identity to spacchettibotti and switch to the branch runInRepo [ "git config --local user.name 'Spacchettibotti'" , "git config --local user.email 'spacchettibotti@ferrai.io'" , "git checkout " <> branchName <> " || git checkout -b " <> branchName ] - (echo "Failed to configure the repo") + (output "Failed to configure the repo") -- If the setup was fine, run the setup code before running the commands (preAction =<< makeAbsolute (path repoPath)) -- Run the commands we wanted to run runInRepo commands - (echo "Something was off while running commands..") + (output "Something was off while running commands..") -- Check if anything actually changed or got staged (runInRepo [ "git diff --staged --exit-code" ] @@ -664,14 +664,14 @@ runInClonedRepo address@Address{..} branchName commit preAction commands postAct [ "git commit -m '" <> commit <> "'" , "git push --set-upstream origin " <> branchName ] - (echo "Failed to commit!") + (output "Failed to commit!") postAction) - (echo "Nothing to commit, skipping..")) + (output "Nothing to commit, skipping..")) runWithCwd :: MonadIO io => GHC.IO.FilePath -> Text -> io (ExitCode, Text, Text) runWithCwd cwd cmd = do - echo $ "Running in path " <> Text.pack cwd <> ": `" <> cmd <> "`" + output $ "Running in path " <> Text.pack cwd <> ": `" <> cmd <> "`" let processWithNewCwd = (Process.shell (Text.unpack cmd)) { Process.cwd = Just cwd } systemStrictWithErr processWithNewCwd empty @@ -686,10 +686,10 @@ withAST :: MonadIO m => Text -> (Expr -> m Expr) -> m () withAST path transform = do rawConfig <- liftIO $ Dhall.readRawExpr path case rawConfig of - Nothing -> echo $ "Could not find file " <> path + Nothing -> output $ "Could not find file " <> path Just (header, expr) -> do newExpr <- transformMExpr transform expr - echo $ "Done. Updating the \"" <> path <> "\" file.." + output $ "Done. Updating the \"" <> path <> "\" file.." writeTextFile path $ Dhall.prettyWithHeader header newExpr <> "\n" liftIO $ Dhall.format path where diff --git a/src/Spago/Bower.hs b/src/Spago/Bower.hs index 20c55e864..14139a189 100644 --- a/src/Spago/Bower.hs +++ b/src/Spago/Bower.hs @@ -47,7 +47,7 @@ runBower args = do generateBowerJson :: Spago m => m ByteString.ByteString generateBowerJson = do - echo "Generating a new Bower config using the package set versions.." + output "Generating a new Bower config using the package set versions.." config@Config{..} <- Config.ensureConfig PublishConfig{..} <- throws publishConfig @@ -68,13 +68,13 @@ generateBowerJson = do when ignored $ do die $ path <> " is being ignored by git - change this before continuing" - echo "Generated a valid Bower config using the package set" + output "Generated a valid Bower config using the package set" pure bowerJson runBowerInstall :: Spago m => m () runBowerInstall = do - echo "Running `bower install` so `pulp publish` can read resolved versions from it" + output "Running `bower install` so `pulp publish` can read resolved versions from it" shell "bower install --silent" empty >>= \case ExitSuccess -> pure () ExitFailure _ -> die "Failed to run `bower install` on your package" diff --git a/src/Spago/Build.hs b/src/Spago/Build.hs index 470e91613..918e44316 100644 --- a/src/Spago/Build.hs +++ b/src/Spago/Build.hs @@ -85,7 +85,7 @@ prepareBundleDefaults maybeModuleName maybeTargetPath = (moduleName, targetPath) -- eventually running some other action after the build build :: Spago m => BuildOptions -> Maybe (m ()) -> m () build buildOpts@BuildOptions{..} maybePostBuild = do - echoDebug "Running `spago build`" + logDebug "Running `spago build`" config@Config.Config{ packageSet = Types.PackageSet{..}, ..} <- Config.ensureConfig deps <- Packages.getProjectDeps config case noInstall of @@ -119,7 +119,7 @@ build buildOpts@BuildOptions{..} maybePostBuild = do case NonEmpty.nonEmpty (psMismatches <> jsMismatches) of Nothing -> pure () - Just mismatches -> echo $ Messages.globsDoNotMatchWhenWatching $ NonEmpty.nub $ Text.pack <$> mismatches + Just mismatches -> output $ Messages.globsDoNotMatchWhenWatching $ NonEmpty.nub $ Text.pack <$> mismatches absolutePSGlobs <- traverse makeAbsolute psMatches absoluteJSGlobs <- traverse makeAbsolute jsMatches @@ -154,7 +154,7 @@ repl -> Packages.DepsOnly -> m () repl cacheFlag newPackages sourcePaths pursArgs depsOnly = do - echoDebug "Running `spago repl`" + logDebug "Running `spago repl`" try Config.ensureConfig >>= \case Right config@Config.Config{..} -> do @@ -162,7 +162,7 @@ repl cacheFlag newPackages sourcePaths pursArgs depsOnly = do let globs = Packages.getGlobs deps depsOnly configSourcePaths <> sourcePaths Purs.repl globs pursArgs Left (err :: SomeException) -> do - echoDebug $ tshow err + logDebug $ tshow err cacheDir <- GlobalCache.getGlobalCacheDir Temp.withTempDirectory cacheDir "spago-repl-tmp" $ \dir -> do Turtle.cd (Turtle.decodeString dir) @@ -207,7 +207,7 @@ runBackend -> [Purs.ExtraArg] -> m () runBackend maybeBackend defaultModuleName maybeSuccessMessage failureMessage maybeModuleName buildOpts extraArgs = do - echoDebug $ "Running with backend: " <> fromMaybe "nodejs" maybeBackend + logDebug $ "Running with backend: " <> fromMaybe "nodejs" maybeBackend let postBuild = maybe (nodeAction =<< getOutputPath buildOpts) backendAction maybeBackend build buildOpts (Just postBuild) where @@ -218,15 +218,15 @@ runBackend maybeBackend defaultModuleName maybeSuccessMessage failureMessage may in "#!/usr/bin/env node\n\n" <> "require('../" <> Text.pack path <> "/" <> Purs.unModuleName moduleName <> "').main()" nodeCmd = "node .spago/run.js " <> nodeArgs nodeAction outputPath' = do - echoDebug "Writing .spago/run.js" + logDebug "Writing .spago/run.js" writeTextFile ".spago/run.js" (nodeContents outputPath') chmod executable ".spago/run.js" shell nodeCmd empty >>= \case - ExitSuccess -> maybe (pure ()) echo maybeSuccessMessage + ExitSuccess -> maybe (pure ()) output maybeSuccessMessage ExitFailure n -> die $ failureMessage <> "exit code: " <> repr n backendAction backend = Turtle.proc backend (["--run" {-, Purs.unModuleName moduleName-}] <> fmap Purs.unExtraArg extraArgs) empty >>= \case - ExitSuccess -> maybe (pure ()) echo maybeSuccessMessage + ExitSuccess -> maybe (pure ()) output maybeSuccessMessage ExitFailure n -> die $ failureMessage <> "Backend " <> surroundQuote backend <> " exited with error:" <> repr n -- | Bundle the project to a js file @@ -254,18 +254,18 @@ bundleModule -> BuildOptions -> m () bundleModule maybeModuleName maybeTargetPath noBuild buildOpts = do - echoDebug "Running `bundleModule`" + logDebug "Running `bundleModule`" let (moduleName, targetPath) = prepareBundleDefaults maybeModuleName maybeTargetPath jsExport = Text.unpack $ "\nmodule.exports = PS[\""<> Purs.unModuleName moduleName <> "\"];" bundleAction = do - echo "Bundling first..." + output "Bundling first..." Purs.bundle Purs.WithoutMain moduleName targetPath -- Here we append the CommonJS export line at the end of the bundle try (with (appendonly $ pathFromText $ Purs.unTargetPath targetPath) (flip hPutStrLn jsExport)) >>= \case - Right _ -> echo $ "Make module succeeded and output file to " <> Purs.unTargetPath targetPath + Right _ -> output $ "Make module succeeded and output file to " <> Purs.unTargetPath targetPath Left (n :: SomeException) -> die $ "Make module failed: " <> repr n case noBuild of DoBuild -> build buildOpts (Just bundleAction) @@ -289,29 +289,29 @@ docs -> OpenDocs -> m () docs format sourcePaths depsOnly noSearch open = do - echoDebug "Running `spago docs`" + logDebug "Running `spago docs`" config@Config.Config{..} <- Config.ensureConfig deps <- Packages.getProjectDeps config - echo "Generating documentation for the project. This might take a while..." + output "Generating documentation for the project. This might take a while..." Purs.docs docsFormat $ Packages.getGlobs deps depsOnly configSourcePaths <> sourcePaths when isHTMLFormat $ do when (noSearch == AddSearch) $ do - echo "Making the documentation searchable..." + output "Making the documentation searchable..." writeTextFile ".spago/purescript-docs-search" Templates.docsSearch writeTextFile ".spago/docs-search-app.js" Templates.docsSearchApp let cmd = "node .spago/purescript-docs-search build-index" - echoDebug $ "Running `" <> cmd <> "`" + logDebug $ "Running `" <> cmd <> "`" shell cmd empty >>= \case ExitSuccess -> pure () - ExitFailure n -> echo $ "Failed while trying to make the documentation searchable: " <> repr n + ExitFailure n -> output $ "Failed while trying to make the documentation searchable: " <> repr n link <- linkToIndexHtml let linkText = "Link: " <> link - echo linkText + output linkText when (open == DoOpenDocs) $ do - echo "Opening in browser..." + output "Opening in browser..." () <$ openLink link where @@ -330,7 +330,7 @@ search = do config@Config.Config{..} <- Config.ensureConfig deps <- Packages.getProjectDeps config - echo "Building module metadata..." + output "Building module metadata..." Purs.compile (Packages.getGlobs deps Packages.AllSources configSourcePaths) [ Purs.ExtraArg "--codegen" @@ -339,7 +339,7 @@ search = do writeTextFile ".spago/purescript-docs-search" Templates.docsSearch let cmd = "node .spago/purescript-docs-search search" - echoDebug $ "Running `" <> cmd <> "`" + logDebug $ "Running `" <> cmd <> "`" viewShell $ callCommand $ Text.unpack cmd @@ -376,7 +376,7 @@ showOutputPath => BuildOptions -> m () showOutputPath buildOptions = - echoStr =<< getOutputPathOrDefault buildOptions + outputStr =<< getOutputPathOrDefault buildOptions showPaths :: Spago m @@ -396,7 +396,7 @@ showAllPaths buildOptions = traverse_ showPath =<< getAllPaths buildOptions where showPath (a,b) - = echo (a <> ": " <> b) + = output (a <> ": " <> b) getAllPaths :: Spago m @@ -440,7 +440,7 @@ getBuildArgsForSharedFolder buildOpts = do = Purs.ExtraArg . Text.pack . ("--output " <>) if any isOutputFlag pursArgs' then do - echo "Output path set explicitly - not using shared output path" + output "Output path set explicitly - not using shared output path" pure pursArgs' else do outputFolder <- getOutputPath buildOpts diff --git a/src/Spago/Config.hs b/src/Spago/Config.hs index 89ad52005..7ad5891eb 100644 --- a/src/Spago/Config.hs +++ b/src/Spago/Config.hs @@ -182,9 +182,9 @@ makeConfig force comments = do -- first, read the psc-package file content content <- readTextFile PscPackage.configPath case eitherDecodeStrict $ Text.encodeUtf8 content of - Left err -> echo $ Messages.failedToReadPscFile err + Left err -> output $ Messages.failedToReadPscFile err Right pscConfig -> do - echo "Found a \"psc-package.json\" file, migrating to a new Spago config.." + output "Found a \"psc-package.json\" file, migrating to a new Spago config.." -- try to update the dependencies (will fail if not found in package set) let pscPackages = map PackageSet.PackageName $ PscPackage.depends pscConfig config <- ensureConfig @@ -196,7 +196,7 @@ makeConfig force comments = do case eitherDecodeStrict $ Text.encodeUtf8 content of Left err -> die $ Messages.failedToParseFile path err Right packageMeta -> do - echo "Found a \"bower.json\" file, migrating to a new Spago config.." + output "Found a \"bower.json\" file, migrating to a new Spago config.." -- then try to update the dependencies. We'll migrates the ones that we can, -- and print a message to the user to fix the missing ones config@Config{..} <- ensureConfig @@ -206,10 +206,10 @@ makeConfig force comments = do if null bowerErrors then do - echo "All Bower dependencies are in the set! 🎉" - echo $ "You can now safely delete your " <> surroundQuote "bower.json" + output "All Bower dependencies are in the set! 🎉" + output $ "You can now safely delete your " <> surroundQuote "bower.json" else do - echo $ showBowerErrors bowerErrors + output $ showBowerErrors bowerErrors void $ withConfigAST (\e -> addRawDeps config bowerPackages $ updateName bowerName e) @@ -297,7 +297,7 @@ addRawDeps config newPackages r@(Dhall.RecordLit kvs) = case Dhall.Map.lookup "d $ Seq.sort $ nubSeq (Seq.fromList newPackages <> fmap PackageSet.PackageName oldPackages) pure $ Dhall.RecordLit $ Dhall.Map.insert "dependencies" newDepsExpr kvs Just pkgs -> do - echo $ Messages.failedToAddDeps $ NonEmpty.map PackageSet.packageName pkgs + output $ Messages.failedToAddDeps $ NonEmpty.map PackageSet.packageName pkgs pure r where packagesDB = PackageSet.packagesDB $ packageSet config @@ -309,10 +309,10 @@ addRawDeps config newPackages r@(Dhall.RecordLit kvs) = case Dhall.Map.lookup "d where seens = Seq.scanl (flip Set.insert) Set.empty xs Just _ -> do - echo "WARNING: Failed to add dependencies. The `dependencies` field wasn't a List of Strings." + logWarning "Failed to add dependencies. The `dependencies` field wasn't a List of Strings." pure r Nothing -> do - echo "WARNING: Failed to add dependencies. You should have a record with the `dependencies` key for this to work." + logWarning "Failed to add dependencies. You should have a record with the `dependencies` key for this to work." pure r addRawDeps _ _ other = pure other @@ -356,7 +356,7 @@ withConfigAST transform = do let exprHasChanged = Dhall.Core.denote expr /= newExpr if exprHasChanged then liftIO $ Dhall.writeRawExpr path (header, newExpr) - else echoDebug "Transformed config is the same as the read one, not overwriting it" + else logDebug "Transformed config is the same as the read one, not overwriting it" pure exprHasChanged @@ -380,4 +380,4 @@ addDependencies :: Spago m => Config -> [PackageName] -> m () addDependencies config newPackages = do configHasChanged <- withConfigAST $ addRawDeps config newPackages unless configHasChanged $ - echo "WARNING: configuration file was not updated." + logWarning "configuration file was not updated." diff --git a/src/Spago/DryRun.hs b/src/Spago/DryRun.hs index e674f8171..a7f96e06c 100644 --- a/src/Spago/DryRun.hs +++ b/src/Spago/DryRun.hs @@ -19,10 +19,10 @@ data DryAction m runDryActions :: Spago m => DryRun -> NonEmpty (DryAction m) -> m () runDryActions DryRun dryActions = do - echo "\nWARNING: this is a dry run, so these side effects were not performed:" - for_ dryActions $ \DryAction{..} -> echo $ "* " <> dryMessage - echo "\nUse the `--no-dry-run` flag to run them" + logWarning "this is a dry run, so these side effects were not performed:" + for_ dryActions $ \DryAction{..} -> output $ "* " <> dryMessage + output "\nUse the `--no-dry-run` flag to run them" runDryActions NoDryRun dryActions = do for_ dryActions $ \DryAction{..} -> do - echo $ "** Running action: " <> dryMessage + output $ "** Running action: " <> dryMessage dryAction diff --git a/src/Spago/FetchPackage.hs b/src/Spago/FetchPackage.hs index f2811f500..5f31e9fae 100644 --- a/src/Spago/FetchPackage.hs +++ b/src/Spago/FetchPackage.hs @@ -42,7 +42,7 @@ fetchPackages -> Maybe Version.SemVer -> m () fetchPackages globalCacheFlag allDeps minPursVersion = do - echoDebug "Running `fetchPackages`" + logDebug "Running `fetchPackages`" PackageSet.checkPursIsUpToDate minPursVersion @@ -60,7 +60,7 @@ fetchPackages globalCacheFlag allDeps minPursVersion = do -- Note: it might be empty depending on the cacheFlag let nOfDeps = List.length depsToFetch when (nOfDeps > 0) $ do - echoStr $ "Installing " <> show nOfDeps <> " dependencies." + outputStr $ "Installing " <> show nOfDeps <> " dependencies." metadata <- GlobalCache.getMetadata globalCacheFlag limit <- asks globalJobs @@ -68,7 +68,7 @@ fetchPackages globalCacheFlag allDeps minPursVersion = do asyncs <- for depsToFetch (async' taskGroup . fetchPackage metadata) liftIO $ handle (handler asyncs) (for_ asyncs Async.wait) - echo "Installation complete." + output "Installation complete." where -- Here we have this weird exception handling so that threads can clean after @@ -94,9 +94,9 @@ fetchPackages globalCacheFlag allDeps minPursVersion = do -- If it's a local directory do nothing fetchPackage :: Spago m => GlobalCache.ReposMetadataV1 -> (PackageName, Package) -> m () fetchPackage _ (PackageName package, Package { location = Local{..}, .. }) = - echo $ Messages.foundLocalPackage package localPath + output $ Messages.foundLocalPackage package localPath fetchPackage metadata pair@(packageName'@PackageName{..}, Package{ location = Remote{..}, .. } ) = do - echoDebug $ "Fetching package " <> packageName + logDebug $ "Fetching package " <> packageName globalDir <- GlobalCache.getGlobalCacheDir let packageDir = getPackageDir packageName' version packageGlobalCacheDir = globalDir packageDir @@ -110,7 +110,7 @@ fetchPackage metadata pair@(packageName'@PackageName{..}, Package{ location = Re -- * if a Package is in the global cache, copy it to the local cache if inGlobalCache then do - echo $ "Copying from global cache: " <> quotedName + output $ "Copying from global cache: " <> quotedName cptree packageGlobalCacheDir downloadDir assertDirectory (localCacheDir Text.unpack packageName) mv downloadDir packageLocalCacheDir @@ -123,18 +123,18 @@ fetchPackage metadata pair@(packageName'@PackageName{..}, Package{ location = Re -- then atomically move it to the correct cache location. Since -- `mv` will not move folders across filesystems, this temp -- is created inside globalDir, guaranteeing the same filesystem. - echo $ "Installing and globally caching " <> quotedName + output $ "Installing and globally caching " <> quotedName let resultDir2 = globalTemp "download2" assertDirectory resultDir2 cptree resultDir resultDir2 catch (mv resultDir2 packageGlobalCacheDir) $ \(err :: SomeException) -> - echoDebug $ Messages.failedToCopyToGlobalCache err + output $ Messages.failedToCopyToGlobalCache err mv resultDir packageLocalCacheDir -- * if not, run a series of git commands to get the code, and move it to local cache let nonCacheableCallback :: Spago m => m () nonCacheableCallback = do - echo $ "Installing " <> quotedName + output $ "Installing " <> quotedName -- Here we set the package directory as the cwd of the new process. -- This is the "right" way to do it (instead of using e.g. diff --git a/src/Spago/Git.hs b/src/Spago/Git.hs index bd9d8900d..75fe9feae 100644 --- a/src/Spago/Git.hs +++ b/src/Spago/Git.hs @@ -24,7 +24,7 @@ hasCleanWorkingTree = do (code, stdout, stderr) <- Turtle.procStrictWithErr "git" ["status", "--porcelain"] empty when (code /= ExitSuccess) $ do - echoDebug $ "git status stderr: " <> stderr + logDebug $ "git status stderr: " <> stderr die "Unable to check git status. Perhaps git is not installed or this is not a git repository?" pure $ stdout == "" diff --git a/src/Spago/GitHub.hs b/src/Spago/GitHub.hs index 89d51313a..78269e595 100644 --- a/src/Spago/GitHub.hs +++ b/src/Spago/GitHub.hs @@ -28,9 +28,9 @@ login = do case maybeToken of Nothing -> die Messages.getNewGitHubToken Just (Text.pack -> token) -> do - echo "Token read, authenticating with GitHub.." + output "Token read, authenticating with GitHub.." username <- getUsername token - echo $ "Successfully authenticated as " <> surroundQuote username + output $ "Successfully authenticated as " <> surroundQuote username writeTextFile (Text.pack $ globalCacheDir tokenCacheFile) token where getUsername token = do @@ -64,7 +64,7 @@ getLatestPackageSetsTag = do let readTagCache = try $ readTextFile $ pathFromText $ Text.pack globalPathToCachedTag let downloadTagToCache = try (Retry.recoverAll (Retry.fullJitterBackoff 50000 <> Retry.limitRetries 5) $ \_ -> getLatestRelease1 <|> getLatestRelease2) >>= \case - Left (err :: SomeException) -> echoDebug $ Messages.failedToReachGitHub err + Left (err :: SomeException) -> logDebug $ Messages.failedToReachGitHub err Right releaseTagName -> writeTagCache releaseTagName whenM (shouldRefreshFile globalPathToCachedTag) downloadTagToCache @@ -78,14 +78,14 @@ getLatestPackageSetsTag = do f <- case hush maybeToken of Nothing -> pure GitHub.executeRequest' Just token -> do - echoDebug "Using cached GitHub token for getting the latest release.." + logDebug "Using cached GitHub token for getting the latest release.." pure $ GitHub.executeRequest (GitHub.OAuth $ Data.Text.Encoding.encodeUtf8 token) result <- liftIO $ f $ GitHub.latestReleaseR "purescript" "package-sets" case result of Right GitHub.Release{..} -> return releaseTagName Left err -> do - echo $ Messages.failedToReachGitHub err + logWarning $ Messages.failedToReachGitHub err empty -- | The idea here is that we go to the `latest` endpoint, and then get redirected @@ -101,5 +101,5 @@ getLatestPackageSetsTag = do case Http.getResponseHeader "Location" response of [redirectUrl] -> return $ last $ Text.splitOn "/" $ Data.Text.Encoding.decodeUtf8 redirectUrl _ -> do - echoStr $ "Error following GitHub redirect, response:\n\n" <> show response + outputStr $ "Error following GitHub redirect, response:\n\n" <> show response empty diff --git a/src/Spago/GlobalCache.hs b/src/Spago/GlobalCache.hs index af478dd71..71eaee16f 100644 --- a/src/Spago/GlobalCache.hs +++ b/src/Spago/GlobalCache.hs @@ -52,7 +52,7 @@ globallyCache -> (m ()) -> m () globallyCache (packageName, Repo url, ref) downloadDir metadata cacheableCallback notCacheableCallback = do - echoDebug $ "Running `globallyCache`: " <> tshow packageName <> " " <> url <> " " <> ref + logDebug $ "Running `globallyCache`: " <> tshow packageName <> " " <> url <> " " <> ref case (Text.stripPrefix "https://github.com/" url) >>= (Text.stripSuffix ".git") >>= (Just . Text.split (== '/')) of @@ -61,13 +61,13 @@ globallyCache (packageName, Repo url, ref) downloadDir metadata cacheableCallbac Nothing -> notCacheableCallback -- TODO: nice error? Just _ -> do let archiveUrl = "https://github.com/" <> owner <> "/" <> repo <> "/archive/" <> ref <> ".tar.gz" - echoDebug $ "About to fetch tarball for " <> archiveUrl + logDebug $ "About to fetch tarball for " <> archiveUrl fetchTarball downloadDir archiveUrl Just resultDir <- Turtle.fold (Turtle.ls $ Turtle.decodeString downloadDir) Fold.head cacheableCallback $ Turtle.encodeString resultDir where _ -> do - echo $ "WARNING: Not caching repo, because URL doesn't have the form of 'https://github.com//.git': " <> url + logWarning $ "Not caching repo, because URL doesn't have the form of 'https://github.com//.git': " <> url notCacheableCallback -- TODO: error? where isTag = do @@ -85,11 +85,11 @@ globallyCache (packageName, Repo url, ref) downloadDir metadata cacheableCallbac -- | Download the GitHub Index cache from the `package-sets-metadata` repo getMetadata :: Spago m => Maybe CacheFlag -> m ReposMetadataV1 getMetadata cacheFlag = do - echoDebug "Running `getMetadata`" + logDebug "Running `getMetadata`" globalCacheDir <- getGlobalCacheDir - echoDebug $ "Global cache directory: " <> Text.pack globalCacheDir + logDebug $ "Global cache directory: " <> Text.pack globalCacheDir let metaURL = "https://raw.githubusercontent.com/spacchetti/package-sets-metadata/master/metadataV1.json" @@ -102,14 +102,14 @@ getMetadata cacheFlag = do downloadMeta = handleAny (\err -> do - echoDebug $ "Metadata fetch failed with exception: " <> tshow err - echo "WARNING: Unable to download GitHub metadata, global cache will be disabled" + logDebug $ "Metadata fetch failed with exception: " <> tshow err + output "WARNING: Unable to download GitHub metadata, global cache will be disabled" pure mempty) (do metaBS <- Http.getResponseBody `fmap` Http.httpBS metaURL case decodeStrict' metaBS of Nothing -> do - echo "WARNING: Unable to parse GitHub metadata, global cache will be disabled" + logWarning "Unable to parse GitHub metadata, global cache will be disabled" pure mempty Just meta -> do assertDirectory globalCacheDir @@ -121,21 +121,21 @@ getMetadata cacheFlag = do Just SkipCache -> pure mempty -- If we need to download a new cache we can skip checking the local filesystem Just NewCache -> do - echo "Downloading a new packages cache metadata from GitHub.." + output "Downloading a new packages cache metadata from GitHub.." downloadMeta -- Otherwise we check first Nothing -> do - echo "Searching for packages cache metadata.." + output "Searching for packages cache metadata.." -- Check if the metadata is in global cache and fresher than 1 day shouldRefreshFile globalPathToMeta >>= \case -- If we should not download it, read from file False -> do - echo "Recent packages cache metadata found, using it.." + output "Recent packages cache metadata found, using it.." fmap maybeToMonoid $ liftIO $ decodeFileStrict globalPathToMeta -- Otherwise download it, write it to file, and return it True -> do - echo "Unable to find packages cache metadata, downloading from GitHub.." + output "Unable to find packages cache metadata, downloading from GitHub.." downloadMeta @@ -146,14 +146,14 @@ getMetadata cacheFlag = do -- - (on Windows) the folder pointed by `LocalAppData` getGlobalCacheDir :: Spago m => m FilePath.FilePath getGlobalCacheDir = do - echoDebug "Running `getGlobalCacheDir`" + logDebug "Running `getGlobalCacheDir`" getXdgDirectory XdgCache "spago" <|> pure ".spago-global-cache" -- | Fetch the tarball at `archiveUrl` and unpack it into `destination` fetchTarball :: Spago m => FilePath.FilePath -> Text -> m () fetchTarball destination archiveUrl = do - echoDebug $ "Fetching " <> archiveUrl + logDebug $ "Fetching " <> archiveUrl tarballUrl <- Http.parseRequest $ Text.unpack archiveUrl lbs <- fmap Http.getResponseBody (Http.httpLBS tarballUrl) liftIO $ Tar.unpack destination $ Tar.read $ GZip.decompress lbs diff --git a/src/Spago/Messages.hs b/src/Spago/Messages.hs index e265c1a42..4a91094e1 100644 --- a/src/Spago/Messages.hs +++ b/src/Spago/Messages.hs @@ -120,9 +120,9 @@ failedToParseFile file err = makeMessage ] failedToParseCommandOutput :: Text -> Text -> Text -failedToParseCommandOutput command output = makeMessage +failedToParseCommandOutput command outputText = makeMessage [ "Failed to parse '" <> command <> "' output: " - , surroundQuote output + , surroundQuote outputText ] failedToReachGitHub :: Show a => a -> Text diff --git a/src/Spago/PackageSet.hs b/src/Spago/PackageSet.hs index 2d1cdf89d..cbac65f39 100644 --- a/src/Spago/PackageSet.hs +++ b/src/Spago/PackageSet.hs @@ -35,7 +35,7 @@ makePackageSetFile force comments = do hasPackagesDhall <- testfile packagesPath if force || not hasPackagesDhall then writeTextFile packagesPath $ Dhall.processComments comments Templates.packagesDhall - else echo $ Messages.foundExistingProject packagesPath + else output $ Messages.foundExistingProject packagesPath Dhall.format packagesPath @@ -48,19 +48,19 @@ makePackageSetFile force comments = do -- - if all of this succeeds, it will regenerate the hashes and write to file upgradePackageSet :: Spago m => m () upgradePackageSet = do - echoDebug "Running `spago upgrade-set`" + logDebug "Running `spago upgrade-set`" GitHub.getLatestPackageSetsTag >>= \case Right tag -> updateTag tag Left (err :: SomeException) -> do - echo "WARNING: was not possible to upgrade the package-sets release" - echoDebug $ "Error: " <> tshow err + output "WARNING: was not possible to upgrade the package-sets release" + logDebug $ "Error: " <> tshow err where updateTag :: Spago m => Text -> m () updateTag releaseTagName = do let quotedTag = surroundQuote releaseTagName - echoDebug $ "Found the most recent tag for \"purescript/package-sets\": " <> quotedTag + logDebug $ "Found the most recent tag for \"purescript/package-sets\": " <> quotedTag rawPackageSet <- liftIO $ Dhall.readRawExpr packagesPath case rawPackageSet of Nothing -> die Messages.cannotFindPackages @@ -68,11 +68,11 @@ upgradePackageSet = do Just (_, expr) | (currentTag:_) <- foldMap getCurrentTag expr , currentTag == releaseTagName - -> echo $ "Skipping package set version upgrade, already on latest version: " <> quotedTag + -> output $ "Skipping package set version upgrade, already on latest version: " <> quotedTag Just (header, expr) -> do - echo $ "Upgrading the package set version to " <> quotedTag + output $ "Upgrading the package set version to " <> quotedTag let newExpr = fmap (upgradeImports releaseTagName) expr - echo $ Messages.upgradingPackageSet releaseTagName + output $ Messages.upgradingPackageSet releaseTagName liftIO $ Dhall.writeRawExpr packagesPath (header, newExpr) -- If everything is fine, refreeze the imports freeze packagesPath @@ -175,13 +175,13 @@ upgradePackageSet = do checkPursIsUpToDate :: Spago m => Maybe Version.SemVer -> m () checkPursIsUpToDate packagesMinPursVersion = do - echoDebug "Checking if `purs` is up to date" + logDebug "Checking if `purs` is up to date" maybeCompilerVersion <- Purs.version case (maybeCompilerVersion, packagesMinPursVersion) of (Just compilerVersion, Just pursVersionFromPackageSet) -> performCheck compilerVersion pursVersionFromPackageSet other -> do - echo "WARNING: unable to parse compiler and package set versions, not checking if `purs` is compatible with it.." - echoDebug $ "Versions we got: " <> tshow other + logWarning "unable to parse compiler and package set versions, not checking if `purs` is compatible with it.." + logDebug $ "Versions we got: " <> tshow other where -- | The check is successful only when the installed compiler is "slightly" -- greater (or equal of course) to the minimum version. E.g. fine cases are: @@ -237,7 +237,7 @@ rootPackagePath _ = Nothing -- | so we build into an output folder where our root packages.dhall lives findRootOutputPath :: Spago m => System.IO.FilePath -> m (Maybe System.IO.FilePath) findRootOutputPath path = do - echoDebug "Locating root path of packages.dhall" + logDebug "Locating root path of packages.dhall" imports <- liftIO $ Dhall.readImports $ Text.pack path let localImports = mapMaybe rootPackagePath imports pure $ flip System.FilePath.replaceFileName "output" <$> findRootPath localImports @@ -249,7 +249,7 @@ findRootPath = Safe.minimumByMay (comparing (length . System.FilePath.splitSearc -- | Freeze the package set remote imports so they will be cached freeze :: Spago m => System.IO.FilePath -> m () freeze path = do - echo Messages.freezePackageSet + output Messages.freezePackageSet liftIO $ Dhall.Freeze.freeze (Dhall.InputFile path) @@ -262,10 +262,10 @@ freeze path = do -- | Freeze the file if any of the remote imports are not frozen ensureFrozen :: Spago m => System.IO.FilePath -> m () ensureFrozen path = do - echoDebug "Ensuring that the package set is frozen" + logDebug "Ensuring that the package set is frozen" imports <- liftIO $ Dhall.readImports $ Text.pack path let areRemotesFrozen = foldMap isRemoteFrozen imports case areRemotesFrozen of - [] -> echo Messages.failedToCheckPackageSetFrozen + [] -> output Messages.failedToCheckPackageSetFrozen remotes -> unless (and remotes) $ traverse_ (maybe (pure ()) freeze . localImportPath) imports diff --git a/src/Spago/Packages.hs b/src/Spago/Packages.hs index 7a8c843bb..4ea9dc94a 100644 --- a/src/Spago/Packages.hs +++ b/src/Spago/Packages.hs @@ -48,7 +48,7 @@ import Spago.Types as PackageSet -- - create an example `test` folder (if needed) initProject :: Spago m => Bool -> Dhall.TemplateComments -> m () initProject force comments = do - echo "Initializing a sample project or migrating an existing one.." + output "Initializing a sample project or migrating an existing one.." -- packages.dhall and spago.dhall overwrite can be forced PackageSet.makePackageSetFile force comments @@ -68,22 +68,22 @@ initProject force comments = do copyIfNotExists ".gitignore" Templates.gitignore - echo "Set up a local Spago project." - echo "Try running `spago build`" + output "Set up a local Spago project." + output "Try running `spago build`" where whenDirNotExists dir action = do let dirPath = pathFromText dir dirExists <- testdir dirPath case dirExists of - True -> echo $ Messages.foundExistingDirectory dir + True -> output $ Messages.foundExistingDirectory dir False -> do mktree dirPath action copyIfNotExists dest srcTemplate = do testfile dest >>= \case - True -> echo $ Messages.foundExistingFile dest + True -> output $ Messages.foundExistingFile dest False -> writeTextFile dest srcTemplate @@ -131,7 +131,7 @@ getProjectDeps Config{..} = getTransitiveDeps packageSet dependencies -- | Return the transitive dependencies of a list of packages getTransitiveDeps :: Spago m => PackageSet -> [PackageName] -> m [(PackageName, Package)] getTransitiveDeps PackageSet{..} deps = do - echoDebug "Getting transitive deps" + logDebug "Getting transitive deps" let (packageMap, notFoundErrors, cycleErrors) = State.evalState (fold <$> traverse (go mempty) deps) mempty handleErrors (Map.toList packageMap) (Set.toList notFoundErrors) (Set.toList cycleErrors) @@ -193,7 +193,7 @@ getReverseDeps packageSet@PackageSet{..} dep = do -- | Fetch all dependencies into `.spago/` install :: Spago m => Maybe CacheFlag -> [PackageName] -> m () install cacheFlag newPackages = do - echoDebug "Running `spago install`" + logDebug "Running `spago install`" config@Config{ packageSet = PackageSet{..}, ..} <- Config.ensureConfig existingNewPackages <- reportMissingPackages $ classifyPackages packagesDB newPackages @@ -218,7 +218,7 @@ reportMissingPackages (PackagesLookupResult found foundWithoutPrefix notFound) = <> (Text.intercalate "\n" . fmap (\(NotFoundError p) -> " - " <> packageName p) $ List.sort notFound) for_ foundWithoutPrefix $ \(FoundWithoutPrefix sansPrefix) -> - echo $ "WARNING: the package 'purescript-" <> packageName sansPrefix <> "' was not found in your package set, but '" + output $ "WARNING: the package 'purescript-" <> packageName sansPrefix <> "' was not found in your package set, but '" <> packageName sansPrefix <> "' was. Using that instead." pure found @@ -269,7 +269,7 @@ encodeJsonPackageOutput = LT.toStrict . LT.decodeUtf8 . Aeson.encode -- | A list of the packages that can be added to this project listPackages :: Spago m => Maybe PackagesFilter -> JsonFlag -> m () listPackages packagesFilter jsonFlag = do - echoDebug "Running `listPackages`" + logDebug "Running `listPackages`" Config{packageSet = packageSet@PackageSet{..}, ..} <- Config.ensureConfig packagesToList :: [(PackageName, Package)] <- case packagesFilter of Nothing -> pure $ Map.toList packagesDB @@ -278,8 +278,8 @@ listPackages packagesFilter jsonFlag = do $ Map.restrictKeys packagesDB (Set.fromList dependencies) case packagesToList of - [] -> echo "There are no dependencies listed in your spago.dhall" - _ -> traverse_ echo $ formatPackageNames packagesToList + [] -> output "There are no dependencies listed in your spago.dhall" + _ -> traverse_ output $ formatPackageNames packagesToList where formatPackageNames = case jsonFlag of @@ -332,10 +332,10 @@ listPackages packagesFilter jsonFlag = do -- | Get source globs of dependencies listed in `spago.dhall` sources :: Spago m => m () sources = do - echoDebug "Running `spago sources`" + logDebug "Running `spago sources`" config <- Config.ensureConfig deps <- getProjectDeps config - traverse_ echo + traverse_ output $ fmap Purs.unSourcePath $ getGlobs deps AllSources $ Config.configSourcePaths config @@ -345,7 +345,7 @@ data CheckModulesUnique = DoCheckModulesUnique | NoCheckModulesUnique verify :: Spago m => Maybe CacheFlag -> CheckModulesUnique -> Maybe PackageName -> m () verify cacheFlag chkModsUniq maybePackage = do - echoDebug "Running `spago verify`" + logDebug "Running `spago verify`" Config{ packageSet = packageSet@PackageSet{..}, ..} <- Config.ensureConfig case maybePackage of -- If no package is specified, verify all of them @@ -369,7 +369,7 @@ verify cacheFlag chkModsUniq maybePackage = do where verifyPackages :: Spago m => PackageSet -> [(PackageName, Package)] -> m () verifyPackages packageSet packages = do - echo $ Messages.verifying $ length packages + output $ Messages.verifying $ length packages traverse_ (verifyPackage packageSet) (fst <$> packages) verifyPackage :: Spago m => PackageSet -> PackageName -> m () @@ -378,15 +378,15 @@ verify cacheFlag chkModsUniq maybePackage = do let globs = getGlobs deps DepsOnly [] quotedName = surroundQuote $ packageName name Fetch.fetchPackages cacheFlag deps packagesMinPursVersion - echo $ "Verifying package " <> quotedName + output $ "Verifying package " <> quotedName Purs.compile globs [] - echo $ "Successfully verified " <> quotedName + output $ "Successfully verified " <> quotedName compileEverything :: Spago m => PackageSet -> m () compileEverything PackageSet{..} = do let deps = Map.toList packagesDB globs = getGlobs deps DepsOnly [] Fetch.fetchPackages cacheFlag deps packagesMinPursVersion - echo "Compiling everything (will fail if module names conflict)" + output "Compiling everything (will fail if module names conflict)" Purs.compile globs [] - echo "Successfully compiled everything" + output "Successfully compiled everything" diff --git a/src/Spago/Prelude.hs b/src/Spago/Prelude.hs index 317bd54c8..a151cabb9 100644 --- a/src/Spago/Prelude.hs +++ b/src/Spago/Prelude.hs @@ -1,8 +1,5 @@ module Spago.Prelude - ( echo - , echoStr - , echoDebug - , tshow + ( tshow , die , Dhall.Core.throws , hush @@ -83,6 +80,11 @@ module Spago.Prelude , whenM , unlessM , pretty + , output + , outputStr + , logDebug + , logWarning + , logError ) where @@ -164,25 +166,36 @@ type Spago m = , MonadMask m ) -echo :: MonadIO m => Text -> m () -echo = Turtle.printf (Turtle.s Turtle.% "\n") +output :: MonadIO m => Text -> m () +output = Turtle.printf (Turtle.s Turtle.% "\n") -echoStr :: MonadIO m => String -> m () -echoStr = echo . Text.pack +outputStr :: MonadIO m => String -> m () +outputStr = output . Text.pack -tshow :: Show a => a -> Text -tshow = Text.pack . show +logStderr :: MonadIO m => String -> m () +logStderr = liftIO . System.IO.hPutStrLn System.IO.stderr + +logText :: MonadIO m => Text -> m () +logText = logStderr . Text.unpack -echoDebug :: Spago m => Text -> m () -echoDebug str = do +logDebug :: Spago m => Text -> m () +logDebug str = do hasDebug <- asks globalDebug - Turtle.when hasDebug $ do - echo str + when hasDebug $ do + logText $ str + +logWarning :: MonadIO m => Text -> m () +logWarning = logText . ("WARNING: " <>) + +logError :: MonadIO m => Text -> m () +logError = logText . ("ERROR: " <>) + +tshow :: Show a => a -> Text +tshow = Text.pack . show die :: MonadThrow m => Text -> m a die reason = throwM $ SpagoError reason - -- | Suppress the 'Left' value of an 'Either' hush :: Either a b -> Maybe b hush = either (const Nothing) Just @@ -290,7 +303,7 @@ shouldRefreshFile path = (tryIO $ liftIO $ do >>= \case Right v -> pure v Left err -> do - echoDebug $ "Unable to read file " <> Text.pack path <> ". Error was: " <> tshow err + logDebug $ "Unable to read file " <> Text.pack path <> ". Error was: " <> tshow err pure True diff --git a/src/Spago/Purs.hs b/src/Spago/Purs.hs index ab614cf82..1ffb49b01 100644 --- a/src/Spago/Purs.hs +++ b/src/Spago/Purs.hs @@ -42,7 +42,7 @@ compile sourcePaths extraArgs = do Right _ -> pure "psa" Left (_err :: SomeException) -> pure "purs" - echoDebug $ "Compiling with " <> surroundQuote purs + logDebug $ "Compiling with " <> surroundQuote purs let paths = Text.intercalate " " $ surroundQuote <$> map unSourcePath sourcePaths @@ -124,14 +124,14 @@ versionImpl purs = do parsed = versionText >>= (hush . Version.semver) when (isNothing parsed) $ do - echo $ Messages.failedToParseCommandOutput (purs <> " --version") fullVersionText + output $ Messages.failedToParseCommandOutput (purs <> " --version") fullVersionText pure parsed runWithOutput :: Spago m => Text -> Text -> Text -> m () runWithOutput command success failure = do - echoDebug $ "Running command: `" <> command <> "`" + logDebug $ "Running command: `" <> command <> "`" liftIO $ shell command empty >>= \case - ExitSuccess -> echo success + ExitSuccess -> output success ExitFailure _ -> die failure diff --git a/src/Spago/Version.hs b/src/Spago/Version.hs index db3600c48..dad88edee 100644 --- a/src/Spago/Version.hs +++ b/src/Spago/Version.hs @@ -59,10 +59,10 @@ getCurrentVersion = do case Safe.maximumMay tags of Nothing -> do - echo $ "No git version tags found, so assuming current version is " <> unparseVersion mempty + output $ "No git version tags found, so assuming current version is " <> unparseVersion mempty pure mempty Just maxVersion -> do - echo $ "Found current version from git tag: " <> unparseVersion maxVersion + output $ "Found current version from git tag: " <> unparseVersion maxVersion pure maxVersion @@ -88,7 +88,7 @@ tagNewVersion oldVersion newVersion = do newVersionTag = unparseVersion newVersion Git.commitAndTag newVersionTag $ oldVersionTag <> " → " <> newVersionTag - echo $ "Git tag created for new version: " <> newVersionTag + output $ "Git tag created for new version: " <> newVersionTag -- | Bump and tag a new version in preparation for release. @@ -103,7 +103,7 @@ bumpVersion dryRun spec = do let writeBowerAction = DryAction "write the new config to the `bower.json` file and try to install its dependencies" $ do - echo $ "Writing the new Bower config to " <> surroundQuote Bower.path + output $ "Writing the new Bower config to " <> surroundQuote Bower.path liftIO $ ByteString.writeFile Bower.path newBowerConfig Bower.runBowerInstall clean <- Git.hasCleanWorkingTree diff --git a/src/Spago/Watch.hs b/src/Spago/Watch.hs index 53e65c055..26bf8b321 100644 --- a/src/Spago/Watch.hs +++ b/src/Spago/Watch.hs @@ -68,7 +68,7 @@ fileWatchConf watchConfig shouldClear inner = withManagerConf watchConfig $ \man when (shouldClear == DoClear) $ liftIO $ do clearScreen setCursorPosition 0 0 - mapM_ echoStr maybeMsg + mapM_ outputStr maybeMsg let onChange event = do timeNow <- liftIO getCurrentTime @@ -136,25 +136,25 @@ fileWatchConf watchConfig shouldClear inner = withManagerConf watchConfig $ \man let watchInput :: Spago m => m () watchInput = do line <- liftIO $ unpack . toLower . pack <$> getLine - if line == "quit" then echo "Leaving watch mode." + if line == "quit" then output "Leaving watch mode." else do liftIO $ case line of "help" -> do - echo "" - echo "help: display this help" - echo "quit: exit" - echo "build: force a rebuild" - echo "watched: display watched files" + output "" + output "help: display this help" + output "quit: exit" + output "build: force a rebuild" + output "watched: display watched files" "build" -> do redisplay Nothing atomically $ writeTVar dirtyVar True "watched" -> do watch' <- readTVarIO allGlobs - mapM_ echoStr (Glob.decompile <$> Set.toList watch') + mapM_ outputStr (Glob.decompile <$> Set.toList watch') "" -> do redisplay Nothing atomically $ writeTVar dirtyVar True - _ -> echoStr $ concat + _ -> outputStr $ concat [ "Unknown command: " , show line , ". Try 'help'" @@ -170,10 +170,10 @@ fileWatchConf watchConfig shouldClear inner = withManagerConf watchConfig $ \man eres :: Either SomeException () <- try $ inner setWatched case eres of - Left e -> echoStr $ show e - _ -> echo "Success! Waiting for next file change." + Left e -> outputStr $ show e + _ -> output "Success! Waiting for next file change." - echo "Type help for available commands. Press enter to force a rebuild." + output "Type help for available commands. Press enter to force a rebuild." globToParent :: Glob.Pattern -> FilePath diff --git a/test/SpagoSpec.hs b/test/SpagoSpec.hs index b2b38ac33..cdb49d9f5 100644 --- a/test/SpagoSpec.hs +++ b/test/SpagoSpec.hs @@ -9,9 +9,11 @@ import Test.Hspec (Spec, around_, describe, it, shouldBe, shou import Turtle (ExitCode (..), cd, cp, decodeString, empty, mkdir, mktree, mv, readTextFile, rm, shell, shellStrictWithErr, testdir, writeTextFile) -import Utils (checkFileHasInfix, checkFixture, outputShouldEqual, - readFixture, runFor, shouldBeFailure, shouldBeFailureOutput, - shouldBeSuccess, shouldBeSuccessOutput, spago, withCwd) +import Utils (checkFileHasInfix, checkFixture, readFixture, runFor, + shouldBeFailure, shouldBeFailureOutput, shouldBeSuccess, + shouldBeSuccessOutput, shouldBeSuccessOutputWithErr, spago, withCwd, + outputShouldEqual) + setup :: IO () -> IO () @@ -95,7 +97,7 @@ spec = around_ setup $ do spago ["init"] >>= shouldBeSuccess spago ["install"] >>= shouldBeSuccess - spago ["install", "effect"] >>= shouldBeSuccessOutput "spago-install-existing-dep-warning.txt" + spago ["install", "effect"] >>= shouldBeSuccessOutputWithErr "spago-install-existing-dep-output.txt" "spago-install-existing-dep-warning.txt" it "Spago should strip 'purescript-' prefix and give warning if package without prefix is present in package set" $ do @@ -168,7 +170,7 @@ spec = around_ setup $ do spago ["init"] >>= shouldBeSuccess writeTextFile "alternative2.dhall" "./spago.dhall // { sources = [ \"src/**/*.purs\" ] }\n" spago ["-x", "alternative2.dhall", "install", "simple-json"] >>= shouldBeSuccess - spago ["-x", "alternative2.dhall", "install", "simple-json"] >>= shouldBeSuccessOutput "alternative2install.txt" + spago ["-x", "alternative2.dhall", "install", "simple-json"] >>= shouldBeSuccessOutputWithErr "alternative2install.txt" "alternative2install-warning.txt" checkFixture "alternative2.dhall" it "Spago should install successfully when there are local dependencies sharing the same packages.dhall" $ do @@ -521,16 +523,15 @@ spec = around_ setup $ do spago ["build"] >>= shouldBeSuccess shell "psa --version" empty >>= \case - ExitSuccess -> spago ["-v", "run"] >>= shouldBeSuccessOutput "run-output.txt" - ExitFailure _ -> spago ["-v", "run"] >>= shouldBeSuccessOutput "run-output-psa-not-installed.txt" + ExitSuccess -> spago ["-v", "run"] >>= shouldBeSuccessOutputWithErr "run-output.txt" "run-output-err.txt" + ExitFailure _ -> spago ["-v", "run"] >>= shouldBeSuccessOutputWithErr "run-output-psa-not-installed.txt" "run-output-psa-not-installed-err.txt" it "Spago should be able to not use `psa`" $ do spago ["init"] >>= shouldBeSuccess spago ["--no-psa", "build"] >>= shouldBeSuccess spago ["--no-psa", "build"] >>= shouldBeSuccess - spago ["-v", "--no-psa", "run"] >>= shouldBeSuccessOutput "run-no-psa.txt" - + spago ["-v", "--no-psa", "run"] >>= shouldBeSuccessOutputWithErr "run-no-psa.txt" "run-no-psa-err.txt" describe "spago bundle" $ do @@ -598,6 +599,7 @@ spec = around_ setup $ do rm "packages.dhall" writeTextFile "packages.dhall" $ "../packages.dhall" spago ["path", "output"] >>= outputShouldEqual "./../output\n" + pure () it "Spago should output the local path when no overrides" $ do diff --git a/test/Utils.hs b/test/Utils.hs index db67c89f1..d6efbcc75 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -13,6 +13,7 @@ module Utils , shouldBeSuccess , shouldBeSuccessInfix , shouldBeSuccessOutput + , shouldBeSuccessOutputWithErr , shouldBeEmptySuccess , spago , withCwd @@ -27,6 +28,7 @@ import qualified System.Process as Process import Test.Hspec (HasCallStack, shouldBe, shouldSatisfy) import Turtle (ExitCode (..), FilePath, Text, cd, empty, encodeString, inproc, limit, procStrictWithErr, pwd, readTextFile, strict) +import Data.Char (isControl) withCwd :: FilePath -> IO () -> IO () withCwd dir cmd = do @@ -63,6 +65,14 @@ shouldBeSuccessOutput expected (code, stdout, _stderr) = do code `shouldBe` ExitSuccess stdout `shouldBe` expectedStdout +shouldBeSuccessOutputWithErr :: HasCallStack => FilePath -> FilePath -> (ExitCode, Text, Text) -> IO () +shouldBeSuccessOutputWithErr expected expectedErr (code, stdout, stderr) = do + expectedStdout <- readFixture expected + expectedStderr <- readFixture expectedErr + code `shouldBe` ExitSuccess + stdout `shouldBe` expectedStdout + stderr `shouldBe` expectedStderr + shouldBeSuccessInfix :: HasCallStack => Text -> (ExitCode, Text, Text) -> IO () shouldBeSuccessInfix expected (code, stdout, _stderr) = do code `shouldBe` ExitSuccess diff --git a/test/fixtures/alternative2install-warning.txt b/test/fixtures/alternative2install-warning.txt new file mode 100644 index 000000000..e014990fc --- /dev/null +++ b/test/fixtures/alternative2install-warning.txt @@ -0,0 +1,2 @@ +WARNING: Failed to add dependencies. You should have a record with the `dependencies` key for this to work. +WARNING: configuration file was not updated. diff --git a/test/fixtures/alternative2install.txt b/test/fixtures/alternative2install.txt index 2a4b5cc0e..c9d6c6305 100644 --- a/test/fixtures/alternative2install.txt +++ b/test/fixtures/alternative2install.txt @@ -1,3 +1 @@ -WARNING: Failed to add dependencies. You should have a record with the `dependencies` key for this to work. -WARNING: configuration file was not updated. Installation complete. diff --git a/test/fixtures/run-no-psa-err.txt b/test/fixtures/run-no-psa-err.txt new file mode 100644 index 000000000..b1bc03521 --- /dev/null +++ b/test/fixtures/run-no-psa-err.txt @@ -0,0 +1,15 @@ +Transformed config is the same as the read one, not overwriting it +Ensuring that the package set is frozen +Running with backend: nodejs +Running `spago build` +Transformed config is the same as the read one, not overwriting it +Ensuring that the package set is frozen +Getting transitive deps +Running `fetchPackages` +Checking if `purs` is up to date +Running `getGlobalCacheDir` +Locating root path of packages.dhall +Compiling with "purs" +Running command: `purs compile --output ./output ".spago/console/v4.2.0/src/**/*.purs" ".spago/effect/v2.0.1/src/**/*.purs" ".spago/prelude/v4.1.1/src/**/*.purs" ".spago/psci-support/v4.0.0/src/**/*.purs" "src/**/*.purs" "test/**/*.purs"` +Locating root path of packages.dhall +Writing .spago/run.js diff --git a/test/fixtures/run-no-psa.txt b/test/fixtures/run-no-psa.txt index 05778e256..f8b3c4c9d 100644 --- a/test/fixtures/run-no-psa.txt +++ b/test/fixtures/run-no-psa.txt @@ -1,18 +1,3 @@ 🍝 -Transformed config is the same as the read one, not overwriting it -Ensuring that the package set is frozen -Running with backend: nodejs -Running `spago build` -Transformed config is the same as the read one, not overwriting it -Ensuring that the package set is frozen -Getting transitive deps -Running `fetchPackages` -Checking if `purs` is up to date -Running `getGlobalCacheDir` Installation complete. -Locating root path of packages.dhall -Compiling with "purs" -Running command: `purs compile --output ./output ".spago/console/v4.2.0/src/**/*.purs" ".spago/effect/v2.0.1/src/**/*.purs" ".spago/prelude/v4.1.1/src/**/*.purs" ".spago/psci-support/v4.0.0/src/**/*.purs" "src/**/*.purs" "test/**/*.purs"` Build succeeded. -Locating root path of packages.dhall -Writing .spago/run.js diff --git a/test/fixtures/run-output-err.txt b/test/fixtures/run-output-err.txt new file mode 100644 index 000000000..7c1d42727 --- /dev/null +++ b/test/fixtures/run-output-err.txt @@ -0,0 +1,18 @@ +Transformed config is the same as the read one, not overwriting it +Ensuring that the package set is frozen +Running with backend: nodejs +Running `spago build` +Transformed config is the same as the read one, not overwriting it +Ensuring that the package set is frozen +Getting transitive deps +Running `fetchPackages` +Checking if `purs` is up to date +Running `getGlobalCacheDir` +Locating root path of packages.dhall +Compiling with "psa" +Running command: `psa compile --output ./output ".spago/console/v4.2.0/src/**/*.purs" ".spago/effect/v2.0.1/src/**/*.purs" ".spago/prelude/v4.1.1/src/**/*.purs" ".spago/psci-support/v4.0.0/src/**/*.purs" "src/**/*.purs" "test/**/*.purs"` + Src Lib All +Warnings 0 0 0 +Errors 0 0 0 +Locating root path of packages.dhall +Writing .spago/run.js diff --git a/test/fixtures/run-output-psa-not-installed-err.txt b/test/fixtures/run-output-psa-not-installed-err.txt new file mode 100644 index 000000000..b1bc03521 --- /dev/null +++ b/test/fixtures/run-output-psa-not-installed-err.txt @@ -0,0 +1,15 @@ +Transformed config is the same as the read one, not overwriting it +Ensuring that the package set is frozen +Running with backend: nodejs +Running `spago build` +Transformed config is the same as the read one, not overwriting it +Ensuring that the package set is frozen +Getting transitive deps +Running `fetchPackages` +Checking if `purs` is up to date +Running `getGlobalCacheDir` +Locating root path of packages.dhall +Compiling with "purs" +Running command: `purs compile --output ./output ".spago/console/v4.2.0/src/**/*.purs" ".spago/effect/v2.0.1/src/**/*.purs" ".spago/prelude/v4.1.1/src/**/*.purs" ".spago/psci-support/v4.0.0/src/**/*.purs" "src/**/*.purs" "test/**/*.purs"` +Locating root path of packages.dhall +Writing .spago/run.js diff --git a/test/fixtures/run-output-psa-not-installed.txt b/test/fixtures/run-output-psa-not-installed.txt index 05778e256..f8b3c4c9d 100644 --- a/test/fixtures/run-output-psa-not-installed.txt +++ b/test/fixtures/run-output-psa-not-installed.txt @@ -1,18 +1,3 @@ 🍝 -Transformed config is the same as the read one, not overwriting it -Ensuring that the package set is frozen -Running with backend: nodejs -Running `spago build` -Transformed config is the same as the read one, not overwriting it -Ensuring that the package set is frozen -Getting transitive deps -Running `fetchPackages` -Checking if `purs` is up to date -Running `getGlobalCacheDir` Installation complete. -Locating root path of packages.dhall -Compiling with "purs" -Running command: `purs compile --output ./output ".spago/console/v4.2.0/src/**/*.purs" ".spago/effect/v2.0.1/src/**/*.purs" ".spago/prelude/v4.1.1/src/**/*.purs" ".spago/psci-support/v4.0.0/src/**/*.purs" "src/**/*.purs" "test/**/*.purs"` Build succeeded. -Locating root path of packages.dhall -Writing .spago/run.js diff --git a/test/fixtures/run-output.txt b/test/fixtures/run-output.txt index e2a8ddd99..f8b3c4c9d 100644 --- a/test/fixtures/run-output.txt +++ b/test/fixtures/run-output.txt @@ -1,18 +1,3 @@ 🍝 -Transformed config is the same as the read one, not overwriting it -Ensuring that the package set is frozen -Running with backend: nodejs -Running `spago build` -Transformed config is the same as the read one, not overwriting it -Ensuring that the package set is frozen -Getting transitive deps -Running `fetchPackages` -Checking if `purs` is up to date -Running `getGlobalCacheDir` Installation complete. -Locating root path of packages.dhall -Compiling with "psa" -Running command: `psa compile --output ./output ".spago/console/v4.2.0/src/**/*.purs" ".spago/effect/v2.0.1/src/**/*.purs" ".spago/prelude/v4.1.1/src/**/*.purs" ".spago/psci-support/v4.0.0/src/**/*.purs" "src/**/*.purs" "test/**/*.purs"` Build succeeded. -Locating root path of packages.dhall -Writing .spago/run.js diff --git a/test/fixtures/spago-install-existing-dep-output.txt b/test/fixtures/spago-install-existing-dep-output.txt new file mode 100644 index 000000000..c9d6c6305 --- /dev/null +++ b/test/fixtures/spago-install-existing-dep-output.txt @@ -0,0 +1 @@ +Installation complete. diff --git a/test/fixtures/spago-install-existing-dep-warning.txt b/test/fixtures/spago-install-existing-dep-warning.txt index 5feb72645..9122e82e7 100644 --- a/test/fixtures/spago-install-existing-dep-warning.txt +++ b/test/fixtures/spago-install-existing-dep-warning.txt @@ -1,2 +1 @@ WARNING: configuration file was not updated. -Installation complete.