Merge pull request #5725 from mpilgrem/lsTools

Add `stack ls tools` subcommand

Author: mpilgrem

ChangeLog.md

@@ -33,6 +33,7 @@ Other enhancements:
   [#809](https://github.com/commercialhaskell/stack/issues/809)
 * Add the possibility of a `sh` script to customise fully GHC installation. See
   [#5585](https://github.com/commercialhaskell/stack/pull/5585)
+* `tools` subcommand added to `stack ls`, to list stack's installed tools.
 
 Bug fixes:
 

src/Stack/Ls.hs

@@ -12,10 +12,11 @@ module Stack.Ls
 import Control.Exception (throw)
 import Data.Aeson
 import Data.Array.IArray ((//), elems)
+import Distribution.Package (mkPackageName)
 import Stack.Prelude hiding (Snapshot (..), SnapName (..))
 import qualified Data.Aeson.Types as A
 import qualified Data.List as L
-import Data.Text hiding (pack, intercalate)
+import Data.Text hiding (filter, intercalate, pack, reverse)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Data.Vector as V
@@ -24,17 +25,20 @@ import qualified Options.Applicative as OA
 import Options.Applicative (idm)
 import Options.Applicative.Builder.Extra (boolFlags)
 import Path
+import RIO.List (sort)
 import RIO.PrettyPrint (useColorL)
 import RIO.PrettyPrint.DefaultStyles (defaultStyles)
 import RIO.PrettyPrint.Types (StyleSpec)
 import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), stylesUpdateL)
 import Stack.Dot
 import Stack.Runners
 import Stack.Options.DotParser (listDepsOptsParser)
+import Stack.Setup.Installed (Tool (..), filterTools, listInstalled, toolString)
 import Stack.Types.Config
 import System.Console.ANSI.Codes (SGR (Reset), setSGRCode, sgrToCode)
 import System.Process.Pager (pageText)
 import System.Directory (listDirectory)
+import System.IO (putStrLn)
 
 data LsView
     = Local
@@ -50,6 +54,7 @@ data LsCmds
     = LsSnapshot SnapshotOpts
     | LsDependencies ListDepsOpts
     | LsStyles ListStylesOpts
+    | LsTools ListToolsOpts
 
 data SnapshotOpts = SnapshotOpts
     { soptViewType :: LsView
@@ -63,12 +68,17 @@ data ListStylesOpts = ListStylesOpts
     , coptExample :: Bool
     } deriving (Eq, Ord, Show)
 
+newtype ListToolsOpts = ListToolsOpts
+    { toptFilter  :: String
+    }
+
 newtype LsCmdOpts = LsCmdOpts
     { lsView :: LsCmds
     }
 
 lsParser :: OA.Parser LsCmdOpts
-lsParser = LsCmdOpts <$> OA.hsubparser (lsSnapCmd <> lsDepsCmd <> lsStylesCmd)
+lsParser = LsCmdOpts
+    <$> OA.hsubparser (lsSnapCmd <> lsDepsCmd <> lsStylesCmd <> lsToolsCmd)
 
 lsCmdOptsParser :: OA.Parser LsCmds
 lsCmdOptsParser = LsSnapshot <$> lsViewSnapCmd
@@ -79,6 +89,9 @@ lsDepOptsParser = LsDependencies <$> listDepsOptsParser
 lsStylesOptsParser :: OA.Parser LsCmds
 lsStylesOptsParser = LsStyles <$> listStylesOptsParser
 
+lsToolsOptsParser :: OA.Parser LsCmds
+lsToolsOptsParser = LsTools <$> listToolsOptsParser
+
 listStylesOptsParser :: OA.Parser ListStylesOpts
 listStylesOptsParser = ListStylesOpts
     <$> boolFlags False
@@ -98,6 +111,16 @@ listStylesOptsParser = ListStylesOpts
                   \report"
                   idm
 
+listToolsOptsParser :: OA.Parser ListToolsOpts
+listToolsOptsParser = ListToolsOpts
+    <$> OA.strOption
+            ( OA.long "filter"
+           <> OA.metavar "TOOL_NAME"
+           <> OA.value ""
+           <> OA.help "Filter by a tool name (eg 'ghc', 'ghc-git' or 'msys2') \
+                      \- case sensitive. The default is no filter"
+            )
+
 lsViewSnapCmd :: OA.Parser SnapshotOpts
 lsViewSnapCmd =
     SnapshotOpts <$>
@@ -135,6 +158,12 @@ lsStylesCmd =
                  (OA.progDesc "View stack's output styles (alias for \
                               \'stack-colors')"))
 
+lsToolsCmd :: OA.Mod OA.CommandFields LsCmds
+lsToolsCmd =
+    OA.command
+        "tools"
+        (OA.info lsToolsOptsParser (OA.progDesc "View stack's installed tools"))
+
 data Snapshot = Snapshot
     { snapId :: Text
     , snapTitle :: Text
@@ -242,6 +271,7 @@ handleLocal lsOpts = do
                 _ -> liftIO $ displayLocalSnapshot isStdoutTerminal snapData
         LsDependencies _ -> return ()
         LsStyles _ -> return ()
+        LsTools _ -> return ()
 
 handleRemote
     :: HasRunner env
@@ -266,6 +296,7 @@ handleRemote lsOpts = do
                 _ -> liftIO $ displaySnapshotData isStdoutTerminal snapData
         LsDependencies _ -> return ()
         LsStyles _ -> return ()
+        LsTools _ -> return ()
   where
     urlInfo = "https://www.stackage.org/snapshots"
 
@@ -278,6 +309,7 @@ lsCmd lsOpts =
                 Remote -> handleRemote lsOpts
         LsDependencies depOpts -> listDependenciesCmd False depOpts
         LsStyles stylesOpts -> withConfig NoReexec $ listStylesCmd stylesOpts
+        LsTools toolsOpts -> withConfig NoReexec $ listToolsCmd toolsOpts
 
 -- | List the dependencies
 listDependenciesCmd :: Bool -> ListDepsOpts -> RIO Runner ()
@@ -325,3 +357,17 @@ listStylesCmd opts = do
         example = " " <> ansi <> "Example" <> reset
         ansi = fromString $ setSGRCode sgrs
         reset = fromString $ setSGRCode [Reset]
+
+-- | List stack's installed tools, sorted (see instance of 'Ord' for 'Tool').
+listToolsCmd :: ListToolsOpts -> RIO Config ()
+listToolsCmd opts = do
+    localPrograms <- view $ configL.to configLocalPrograms
+    installed <- sort <$> listInstalled localPrograms
+    let wanted = case toptFilter opts of
+            [] -> installed
+            "ghc-git" -> [t | t@(ToolGhcGit _ _) <- installed]
+            pkgName -> filtered pkgName installed
+    liftIO $ mapM_ (putStrLn . toolString) wanted
+  where
+    filtered pkgName installed = Tool <$>
+        filterTools (mkPackageName pkgName) (const True) installed

src/Stack/Path.hs

@@ -158,7 +158,7 @@ paths =
     , ( "PATH environment variable"
       , "bin-path"
       , WithoutHaddocks $ T.pack . intercalate [FP.searchPathSeparator] . view exeSearchPathL)
-    , ( "Install location for GHC and other core tools"
+    , ( "Install location for GHC and other core tools (see 'stack ls tools' command)"
       , "programs"
       , WithoutHaddocks $ view (configL.to configLocalPrograms.to toFilePathNoTrailingSep.to T.pack))
     , ( "Compiler binary (e.g. ghc)"

src/Stack/Setup.hs

@@ -44,7 +44,6 @@ import              Data.Conduit.Lazy (lazyConsume)
 import qualified    Data.Conduit.List as CL
 import              Data.Conduit.Process.Typed (createSource)
 import              Data.Conduit.Zlib          (ungzip)
-import              Data.Foldable (maximumBy)
 #if !MIN_VERSION_aeson(2,0,0)
 import qualified    Data.HashMap.Strict as HashMap
 #endif
@@ -87,7 +86,10 @@ import              Stack.Constants.Config (distRelativeDir)
 import              Stack.GhcPkg (createDatabase, getGlobalDB, mkGhcPackagePath, ghcPkgPathEnvVar)
 import              Stack.Prelude hiding (Display (..))
 import              Stack.SourceMap
-import              Stack.Setup.Installed
+import              Stack.Setup.Installed (Tool (..), extraDirs, filterTools,
+                                          installDir, getCompilerVersion,
+                                          listInstalled, markInstalled, tempInstallDir,
+                                          toolString, unmarkInstalled)
 import              Stack.Storage.User (loadCompilerPaths, saveCompilerPaths)
 import              Stack.Types.Build
 import              Stack.Types.Compiler
@@ -1161,18 +1163,8 @@ getInstalledTool :: [Tool]            -- ^ already installed
                  -> PackageName       -- ^ package to find
                  -> (Version -> Bool) -- ^ which versions are acceptable
                  -> Maybe Tool
-getInstalledTool installed name goodVersion =
-    if null available
-        then Nothing
-        else Just $ Tool $ maximumBy (comparing pkgVersion) available
-  where
-    available = mapMaybe goodPackage installed
-    goodPackage (Tool pi') =
-        if pkgName pi' == name &&
-           goodVersion (pkgVersion pi')
-            then Just pi'
-            else Nothing
-    goodPackage _ = Nothing
+getInstalledTool installed name goodVersion = Tool <$>
+  maximumByMaybe (comparing pkgVersion) (filterTools name goodVersion installed)
 
 downloadAndInstallTool :: (HasTerm env, HasBuildConfig env)
                        => Path Abs Dir

src/Stack/Setup/Installed.hs

@@ -15,6 +15,7 @@ module Stack.Setup.Installed
     , toolString
     , toolNameString
     , parseToolText
+    , filterTools
     , extraDirs
     , installDir
     , tempInstallDir
@@ -40,6 +41,22 @@ data Tool
     | ToolGhcGit !Text !Text   -- ^ e.g. ghc-git-COMMIT_ID-FLAVOUR
     deriving (Eq)
 
+-- | 'Tool' values are ordered by name (being @ghc-git@, for @ToolGhcGit _ _@)
+-- alphabetically and then by version (later versions are ordered before
+-- earlier versions, where applicable).
+instance Ord Tool where
+  compare (Tool pkgId1) (Tool pkgId2) = if pkgName1 == pkgName2
+      then compare pkgVersion2 pkgVersion1 -- Later versions ordered first
+      else compare pkgName1 pkgName2
+    where
+      PackageIdentifier pkgName1 pkgVersion1 = pkgId1
+      PackageIdentifier pkgName2 pkgVersion2 = pkgId2
+  compare (Tool pkgId) (ToolGhcGit _ _) = compare (pkgName pkgId) "ghc-git"
+  compare (ToolGhcGit _ _) (Tool pkgId) = compare "ghc-git" (pkgName pkgId)
+  compare (ToolGhcGit c1 f1) (ToolGhcGit c2 f2) = if f1 == f2
+      then compare c1 c2
+      else compare f1 f2
+
 toolString :: Tool -> String
 toolString (Tool ident) = packageIdentifierString ident
 toolString (ToolGhcGit commit flavour) = "ghc-git-" ++ T.unpack commit ++ "-" ++ T.unpack flavour
@@ -83,6 +100,15 @@ listInstalled programsPath = do
         x <- T.stripSuffix ".installed" $ T.pack $ toFilePath $ filename fp
         parseToolText x
 
+filterTools :: PackageName       -- ^ package to find
+            -> (Version -> Bool) -- ^ which versions are acceptable
+            -> [Tool]            -- ^ tools to filter
+            -> [PackageIdentifier]
+filterTools name goodVersion installed =
+    [ pkgId | Tool pkgId <- installed
+            , pkgName pkgId == name
+            , goodVersion (pkgVersion pkgId) ]
+
 getCompilerVersion
   :: (HasProcessContext env, HasLogFunc env)
   => WhichCompiler

src/main/Main.hs

@@ -242,7 +242,7 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions
                     Stack.Path.path
                     Stack.Path.pathParser
         addCommand' "ls"
-                    "List command. (Supports snapshots, dependencies and stack's styles)"
+                    "List command. (Supports snapshots, dependencies, stack's styles and installed tools)"
                     lsCmd
                     lsParser
         addCommand' "unpack"