Add command to apply minor package updates

psc-package/Main.hs

@@ -7,6 +7,7 @@
 
 module Main where
 
+import qualified Control.Foldl as Foldl
 import qualified Data.Aeson as Aeson
 import           Data.Aeson.Encode.Pretty
 import           Data.Foldable (fold, for_, traverse_)
@@ -15,17 +16,20 @@ import qualified Data.Map as Map
 import           Data.Maybe (fromMaybe, mapMaybe)
 import qualified Data.Set as Set
 import           Data.Text (pack)
+import qualified Data.Text as T
+import           Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Builder as TB
-import           Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.Read as TR
 import           Data.Traversable (for)
 import           Data.Version (showVersion)
 import qualified Filesystem.Path.CurrentOS as Path
 import           GHC.Generics (Generic)
 import qualified Options.Applicative as Opts
 import qualified Paths_purescript as Paths
 import qualified System.IO as IO
-import           Turtle hiding (fold)
+import           Turtle hiding (fold, s, x)
+import qualified Turtle
 
 packageFile :: Path.FilePath
 packageFile = "psc-package.json"
@@ -61,8 +65,8 @@ readPackageFile = do
       exit (ExitFailure 1)
     Just pkg -> return pkg
 
-encodePrettyToText :: Aeson.ToJSON json => json -> Text
-encodePrettyToText =
+packageConfigToJSON :: PackageConfig -> Text
+packageConfigToJSON =
     TL.toStrict
     . TB.toLazyText
     . encodePrettyToTextBuilder' config
@@ -76,10 +80,18 @@ encodePrettyToText =
                             ]
                }
 
+packageSetToJSON :: PackageSet -> Text
+packageSetToJSON =
+    TL.toStrict
+    . TB.toLazyText
+    . encodePrettyToTextBuilder' config
+  where
+    config = defConfig { confCompare = compare }
+
 writePackageFile :: PackageConfig -> IO ()
 writePackageFile =
   writeTextFile packageFile
-  . encodePrettyToText
+  . packageConfigToJSON
 
 data PackageInfo = PackageInfo
   { repo         :: Text
@@ -108,6 +120,18 @@ cloneShallow from ref into =
        , pathToTextUnsafe into
        ] empty .||. exit (ExitFailure 1)
 
+listRemoteTags
+  :: Text
+  -- ^ repo
+  -> Turtle.Shell Text
+listRemoteTags from =
+  inproc "git"
+         [ "ls-remote"
+         , "-q"
+         , "-t"
+         , from
+         ] empty
+
 getPackageSet :: PackageConfig -> IO ()
 getPackageSet PackageConfig{ source, set } = do
   let pkgDir = ".psc-package" </> fromText set </> ".set"
@@ -128,6 +152,11 @@ readPackageSet PackageConfig{ set } = do
       exit (ExitFailure 1)
     Just db -> return db
 
+writePackageSet :: PackageConfig -> PackageSet -> IO ()
+writePackageSet PackageConfig{ set } =
+  let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json"
+  in writeTextFile dbFile . packageSetToJSON
+
 installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath
 installOrUpdate set pkgName PackageInfo{ repo, version } = do
   echo ("Updating " <> pkgName)
@@ -233,6 +262,84 @@ exec exeName = do
         (map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths))
         empty
 
+checkForUpdates :: Bool -> Bool -> IO ()
+checkForUpdates applyMinorUpdates applyMajorUpdates = do
+    pkg <- readPackageFile
+    db <- readPackageSet pkg
+
+    echo ("Checking " <> pack (show (Map.size db)) <> " packages for updates.")
+    echo "Warning: this could take some time!"
+
+    newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do
+      echo ("Checking package " <> name)
+      tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list
+      let tags = mapMaybe parseTag tagLines
+      newVersion <- case parseVersion version of
+        Just parts ->
+          let applyMinor =
+                case filter (isMinorReleaseFrom parts) tags of
+                  [] -> pure version
+                  minorReleases -> do
+                    echo ("New minor release available")
+                    case applyMinorUpdates of
+                      True -> do
+                        let latestMinorRelease = maximum minorReleases
+                        pure ("v" <> T.intercalate "." (map (pack . show) latestMinorRelease))
+                      False -> pure version
+              applyMajor =
+                case filter (isMajorReleaseFrom parts) tags of
+                  [] -> applyMinor
+                  newReleases -> do
+                    echo ("New major release available")
+                    case applyMajorUpdates of
+                      True -> do
+                        let latestRelease = maximum newReleases
+                        pure ("v" <> T.intercalate "." (map (pack . show) latestRelease))
+                      False -> applyMinor
+          in applyMajor
+        _ -> do
+          echo "Unable to parse version string"
+          pure version
+      pure (name, p { version = newVersion }))
+
+    when (applyMinorUpdates || applyMajorUpdates)
+      (writePackageSet pkg newDb)
+  where
+    parseTag :: Text -> Maybe [Int]
+    parseTag line =
+      case T.splitOn "\t" line of
+        [_sha, ref] ->
+          case T.stripPrefix "refs/tags/" ref of
+            Just tag ->
+              case parseVersion tag of
+                Just parts -> pure parts
+                _ -> Nothing
+            _ -> Nothing
+        _ -> Nothing
+
+    parseVersion :: Text -> Maybe [Int]
+    parseVersion ref =
+      case T.stripPrefix "v" ref of
+        Just tag ->
+          traverse parseDecimal (T.splitOn "." tag)
+        _ -> Nothing
+
+    parseDecimal :: Text -> Maybe Int
+    parseDecimal s =
+      case TR.decimal s of
+        Right (n, "") -> Just n
+        _ -> Nothing
+
+    isMajorReleaseFrom :: [Int] -> [Int] -> Bool
+    isMajorReleaseFrom (0 : xs) (0 : ys) = isMajorReleaseFrom xs ys
+    isMajorReleaseFrom (x : _)  (y : _)  = y > x
+    isMajorReleaseFrom _        _        = False
+
+    isMinorReleaseFrom :: [Int] -> [Int] -> Bool
+    isMinorReleaseFrom (0 : xs) (0 : ys) = isMinorReleaseFrom xs ys
+    isMinorReleaseFrom (x : xs) (y : ys) = y == x && ys > xs
+    isMinorReleaseFrom _        _        = False
+
 verifyPackageSet :: IO ()
 verifyPackageSet = do
   pkg <- readPackageFile
@@ -292,6 +399,9 @@ main = do
         , Opts.command "available"
             (Opts.info (pure listPackages)
             (Opts.progDesc "List all packages available in the package set"))
+        , Opts.command "updates"
+            (Opts.info (checkForUpdates <$> apply <*> applyMajor)
+            (Opts.progDesc "Check all packages in the package set for new releases"))
         , Opts.command "verify-set"
             (Opts.info (pure verifyPackageSet)
             (Opts.progDesc "Verify that the packages in the package set build correctly"))
@@ -300,3 +410,11 @@ main = do
         pkg = Opts.strArgument $
              Opts.metavar "PACKAGE"
           <> Opts.help "The name of the package to install"
+
+        apply = Opts.switch $
+             Opts.long "apply"
+          <> Opts.help "Apply all minor package updates"
+
+        applyMajor = Opts.switch $
+             Opts.long "apply-breaking"
+          <> Opts.help "Apply all major package updates"

src/Language/PureScript/Publish.hs

@@ -196,10 +196,9 @@ getVersionFromGitTag = do
   where
   trimWhitespace =
     dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
-  parseMay str =
-    (str,) <$> D.parseVersion' (dropPrefix "v" str)
-  dropPrefix prefix str =
-    fromMaybe str (stripPrefix prefix str)
+  parseMay str = do
+    digits <- stripPrefix "v" str
+    (str,) <$> D.parseVersion' digits
 
 getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
 getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract

src/Language/PureScript/Publish/ErrorsWarnings.hs

@@ -148,9 +148,8 @@ displayUserError e = case e of
             , "version."
             ])
         , spacer
-        , para "Note: tagged versions must be in one of the following forms:"
-        , indented (para "* v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")")
-        , indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")")
+        , para "Note: tagged versions must be in the form"
+        , indented (para "v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")")
         , spacer
         , para (concat
            [ "If the version you are publishing is not yet tagged, you might "