Merge remote-tracking branch 'origin/merge-requests/70'

app/ghcup/Main.hs

@@ -192,10 +192,10 @@ data ChangeLogOptions = ChangeLogOptions
 -- by default. For example:
 --
 -- > invertableSwitch "recursive" True (help "do not recurse into directories")
--- 
+--
--- This example makes --recursive enabled by default, so 
+-- This example makes --recursive enabled by default, so
 -- the help is shown only for --no-recursive.
-invertableSwitch 
+invertableSwitch
     :: String              -- ^ long option
     -> Char                -- ^ short option for the non-default option
     -> Bool                -- ^ is switch enabled by default?
@@ -363,7 +363,7 @@ com =
           (  command
               "install-cabal"
               ((info
-                 ((InstallCabalLegacy <$> installOpts) <**> helper)
+                 ((InstallCabalLegacy <$> installOpts (Just Cabal)) <**> helper)
                  (  progDesc "Install or update cabal"
                  <> footerDoc (Just $ text installCabalFooter)
                  )
@@ -413,7 +413,7 @@ installParser =
           "ghc"
           (   InstallGHC
           <$> (info
-                (installOpts <**> helper)
+                (installOpts (Just GHC) <**> helper)
                 (  progDesc "Install GHC"
                 <> footerDoc (Just $ text installGHCFooter)
                 )
@@ -423,7 +423,7 @@ installParser =
            "cabal"
            (   InstallCabal
            <$> (info
-                 (installOpts <**> helper)
+                 (installOpts (Just Cabal) <**> helper)
                  (  progDesc "Install Cabal"
                  <> footerDoc (Just $ text installCabalFooter)
                  )
@@ -433,7 +433,7 @@ installParser =
            "hls"
            (   InstallHLS
            <$> (info
-                 (installOpts <**> helper)
+                 (installOpts (Just HLS) <**> helper)
                  (  progDesc "Install haskell-languge-server"
                  <> footerDoc (Just $ text installHLSFooter)
                  )
@@ -441,7 +441,7 @@ installParser =
            )
       )
     )
-    <|> (Right <$> installOpts)
+    <|> (Right <$> installOpts Nothing)
  where
   installHLSFooter :: String
   installHLSFooter = [s|Discussion:
@@ -472,8 +472,8 @@ Examples:
   ghcup install ghc -u https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-fedora27-linux.tar.xz?job=validate-x86_64-linux-fedora27 head|]
 
 
-installOpts :: Parser InstallOptions
+installOpts :: Maybe Tool -> Parser InstallOptions
-installOpts =
+installOpts tool =
   (\p (u, v) b -> InstallOptions v p u b)
     <$> (optional
           (option
@@ -495,9 +495,9 @@ installOpts =
                     )
                   )
                 )
-            <*> (Just <$> toolVersionArgument)
+            <*> (Just <$> toolVersionArgument True Nothing tool)
             )
-        <|> ((,) <$> pure Nothing <*> optional toolVersionArgument)
+        <|> (pure (Nothing, Nothing))
         )
     <*> flag
           False
@@ -514,7 +514,7 @@ setParser =
           "ghc"
           (   SetGHC
           <$> (info
-                (setOpts <**> helper)
+                (setOpts (Just GHC) <**> helper)
                 (  progDesc "Set GHC version"
                 <> footerDoc (Just $ text setGHCFooter)
                 )
@@ -524,7 +524,7 @@ setParser =
            "cabal"
            (   SetCabal
            <$> (info
-                 (setOpts <**> helper)
+                 (setOpts (Just Cabal) <**> helper)
                  (  progDesc "Set Cabal version"
                  <> footerDoc (Just $ text setCabalFooter)
                  )
@@ -534,7 +534,7 @@ setParser =
            "hls"
            (   SetHLS
            <$> (info
-                 (setOpts <**> helper)
+                 (setOpts (Just HLS) <**> helper)
                  (  progDesc "Set haskell-language-server version"
                  <> footerDoc (Just $ text setHLSFooter)
                  )
@@ -542,7 +542,7 @@ setParser =
            )
       )
     )
-    <|> (Right <$> setOpts)
+    <|> (Right <$> setOpts Nothing)
  where
   setGHCFooter :: String
   setGHCFooter = [s|Discussion:
@@ -559,8 +559,8 @@ setParser =
     Sets the the current haskell-language-server version.|]
 
 
-setOpts :: Parser SetOptions
+setOpts :: Maybe Tool -> Parser SetOptions
-setOpts = SetOptions <$> optional toolVersionArgument
+setOpts tool = SetOptions <$> optional (toolVersionArgument False (Just ListInstalled) tool)
 
 listOpts :: Parser ListOptions
 listOpts =
@@ -592,29 +592,29 @@ rmParser =
   (Left <$> subparser
       (  command
           "ghc"
-          (RmGHC <$> (info (rmOpts <**> helper) (progDesc "Remove GHC version")))
+          (RmGHC <$> (info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version")))
       <> command
            "cabal"
            (   RmCabal
-           <$> (info (versionParser' <**> helper)
+           <$> (info (versionParser' False (Just ListInstalled) (Just Cabal) <**> helper)
                      (progDesc "Remove Cabal version")
                )
            )
       <> command
            "hls"
            (   RmHLS
-           <$> (info (versionParser' <**> helper)
+           <$> (info (versionParser' False (Just ListInstalled) (Just HLS) <**> helper)
                      (progDesc "Remove haskell-language-server version")
                )
            )
       )
     )
-    <|> (Right <$> rmOpts)
+    <|> (Right <$> rmOpts Nothing)
 
 
 
-rmOpts :: Parser RmOptions
+rmOpts :: Maybe Tool -> Parser RmOptions
-rmOpts = RmOptions <$> versionArgument
+rmOpts tool = RmOptions <$> versionArgument False (Just ListInstalled) tool
 
 
 changelogP :: Parser ChangeLogOptions
@@ -636,7 +636,7 @@ changelogP =
             )
           )
         )
-    <*> optional toolVersionArgument
+    <*> optional (toolVersionArgument True Nothing Nothing)
 
 compileP :: Parser CompileCommand
 compileP = subparser
@@ -765,13 +765,72 @@ toolVersionParser = verP' <|> toolP
           )
 
 -- | same as toolVersionParser, except as an argument.
-toolVersionArgument :: Parser ToolVersion
+toolVersionArgument :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser ToolVersion
-toolVersionArgument =
+toolVersionArgument networkSensitive criteria tool =
-  argument (eitherReader toolVersionEither) (metavar "VERSION|TAG")
+  argument (eitherReader toolVersionEither) (metavar "VERSION|TAG" <> completer tagCompleter <> foldMap (completer . versionCompleter networkSensitive criteria) tool)
 
 
-versionArgument :: Parser GHCTargetVersion
+versionArgument :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser GHCTargetVersion
-versionArgument = argument (eitherReader tVersionEither) (metavar "VERSION")
+versionArgument networkSensitive criteria tool = argument (eitherReader tVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter networkSensitive criteria) tool)
+
+
+tagCompleter :: Completer
+tagCompleter =
+  listCompleter [
+    "recommended", "latest"
+  ]
+
+
+versionCompleter :: Bool -> Maybe ListCriteria -> Tool -> Completer
+versionCompleter networkSensitive criteria tool =
+  listIOCompleter $ do
+    let
+      loggerConfig =
+        LoggerConfig
+          { lcPrintDebug = False
+          , colorOutter  = mempty
+          , rawOutter    = mempty
+          }
+
+      runLogger =
+        myLoggerT loggerConfig
+
+      downloadWithUserSource = do
+        userConf <- runE @'[ JSONError ] ghcupConfigFile
+        getDownloadsF $
+          veitherCont (const GHCupURL) (fromMaybe GHCupURL . uUrlSource) userConf
+
+    mpFreq <-
+      runLogger . runE $
+        platformRequest
+
+    forFold mpFreq $ \pfreq -> do
+      dirs <- getDirs
+      let
+        simpleSettings =
+          Settings False False Never Curl False GHCupURL
+        simpleAppState =
+          AppState simpleSettings dirs defaultKeyBindings
+        runEnv =
+          runLogger . flip runReaderT simpleAppState
+
+      mGhcUpInfo <-
+        runEnv . runE $
+          if networkSensitive then do
+            downloadWithUserSource
+          else
+            catchE
+              (\(FileDoesNotExistError _) -> downloadWithUserSource)
+              readFromCache
+
+      forFold mGhcUpInfo $ \(GHCupInfo _ dls) -> do
+        installedVersions <-
+          runEnv $
+            listVersions dls (Just tool) criteria pfreq
+
+        return $
+          T.unpack . prettyVer . lVer <$> installedVersions
+
 
 versionParser :: Parser GHCTargetVersion
 versionParser = option
@@ -779,10 +838,10 @@ versionParser = option
   (short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
   )
 
-versionParser' :: Parser Version
+versionParser' :: Bool -> Maybe ListCriteria -> Maybe Tool -> Parser Version
-versionParser' = argument
+versionParser' networkSensitive criteria tool = argument
-  (eitherReader (bimap show id . version . T.pack))
+  (eitherReader (first show . version . T.pack))
-  (metavar "VERSION")
+  (metavar "VERSION"  <> foldMap (completer . versionCompleter networkSensitive criteria) tool)
 
 
 tagEither :: String -> Either String Tag
@@ -792,7 +851,7 @@ tagEither s' = case fmap toLower s' of
   ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of
                                   Right x -> Right (Base x)
                                   Left  _ -> Left [i|Invalid PVP version for base #{ver'}|]
-  other         -> Left ([i|Unknown tag #{other}|])
+  other         -> Left [i|Unknown tag #{other}|]
 
 
 tVersionEither :: String -> Either String GHCTargetVersion

lib/GHCup/Download.hs

@@ -137,30 +137,8 @@ getDownloadsF urlSource = do
       bsExt <- reThrowAll DownloadFailed $ downloadBS uri
       ext <- lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bsExt)
       pure (mergeGhcupInfo base ext)
- where
-  readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
-                => Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
-  readFromCache = do
-    AppState {dirs = Dirs {..}} <- lift ask
-    lift $ $(logWarn)
-      [i|Could not get download info, trying cached version (this may not be recent!)|]
-    let path = view pathL' ghcupURL
-    yaml_file <- (cacheDir </>) <$> urlBaseName path
-    bs        <-
-      handleIO' NoSuchThing
-                (\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
-      $ liftIO
-      $ readFile yaml_file
-    lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
 
-  getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
+    where
-          => Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
-  getBase =
-    handleIO (\_ -> readFromCache)
-    $ catchE @_ @'[JSONError, FileDoesNotExistError]
-        (\(DownloadFailed _) -> readFromCache)
-    $ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
-      >>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
 
   mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
                  -> GHCupInfo -- ^ extension overwriting the base
@@ -172,6 +150,32 @@ getDownloadsF urlSource = do
                            ) base
     in GHCupInfo tr new
 
+
+readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
+              => Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
+readFromCache = do
+  AppState {dirs = Dirs {..}} <- lift ask
+  lift $ $(logWarn)
+    [i|Could not get download info, trying cached version (this may not be recent!)|]
+  let path = view pathL' ghcupURL
+  yaml_file <- (cacheDir </>) <$> urlBaseName path
+  bs        <-
+    handleIO' NoSuchThing
+              (\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
+    $ liftIO
+    $ readFile yaml_file
+  lE' JSONDecodeError $ bimap show id $ Y.decodeEither' (L.toStrict bs)
+
+
+getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m, MonadReader AppState m)
+        => Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
+getBase =
+  handleIO (\_ -> readFromCache)
+  $ catchE @_ @'[JSONError, FileDoesNotExistError]
+      (\(DownloadFailed _) -> readFromCache)
+  $ ((reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed $ smartDl ghcupURL)
+    >>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict))
+    where
   -- First check if the json file is in the ~/.ghcup/cache dir
   -- and check it's access time. If it has been accessed within the
   -- last 5 minutes, just reuse it.
@@ -209,8 +213,8 @@ getDownloadsF urlSource = do
       then do
         accessTime <-
           PF.accessTimeHiRes
-            <$> (liftIO $ PF.getFileStatus (toFilePath json_file))
+            <$> liftIO (PF.getFileStatus (toFilePath json_file))
-        currentTime <- liftIO $ getPOSIXTime
+        currentTime <- liftIO getPOSIXTime
 
         -- access time won't work on most linuxes, but we can try regardless
         if (currentTime - accessTime) > 300

lib/GHCup/Utils.hs

@@ -808,3 +808,12 @@ getVersionInfo v' tool dls =
     % _head
     )
     dls
+
+
+-- Gathering monoidal values
+traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
+traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
+
+-- | Gathering monoidal values
+forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
+forFold = flip traverseFold

lib/GHCup/Utils/Dirs.hs

@@ -185,9 +185,9 @@ getDirs = do
 ghcupConfigFile :: (MonadIO m)
                 => Excepts '[JSONError] m UserSettings
 ghcupConfigFile = do
-  confDir <- liftIO $ ghcupConfigDir
+  confDir <- liftIO ghcupConfigDir
   let file = confDir </> [rel|config.yaml|]
-  bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ fmap Just $ readFile file 
+  bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
   case bs of
       Nothing -> pure defaultUserSettings
       Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs'