Improve cli interface with partial versions

Fixes #243

app/ghcup/Main.hs

@@ -49,7 +49,6 @@ import           Data.Char
 import           Data.Either
 import           Data.Functor
 import           Data.List                      ( intercalate, nub, sort, sortBy )
-import           Data.List.NonEmpty             (NonEmpty ((:|)))
 import           Data.Maybe
 import           Data.Text                      ( Text )
 import           Data.Versions           hiding ( str )
@@ -2749,13 +2748,15 @@ fromVersion' SetRecommended tool = do
 fromVersion' (SetToolVersion v) tool = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
   let vi = getVersionInfo (_tvVersion v) tool dls
-  case pvp $ prettyVer (_tvVersion v) of
+  case pvp $ prettyVer (_tvVersion v) of -- need to be strict here
     Left _ -> pure (v, vi)
-    Right (PVP (major' :|[minor'])) ->
+    Right pvpIn ->
-      case getLatestGHCFor (fromIntegral major') (fromIntegral minor') dls of
+      lift (getLatestToolFor tool pvpIn dls) >>= \case
-        Just (v', vi') -> pure (GHCTargetVersion (_tvTarget v) v', Just vi')
+        Just (pvp_, vi') -> do
+          v' <- lift $ pvpToVersion pvp_
+          when (v' /= (_tvVersion v)) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
+          pure (GHCTargetVersion (_tvTarget v) v', Just vi')
         Nothing -> pure (v, vi)
-    Right _ -> pure (v, vi)
 fromVersion' (SetToolTag Latest) tool = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
   (\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool

lib/GHCup.hs

@@ -59,6 +59,7 @@ import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.List
 import           Data.Maybe
+import           Data.List.NonEmpty             ( NonEmpty((:|)) )
 import           Data.String                    ( fromString )
 import           Data.Text                      ( Text )
 import           Data.Time.Clock
@@ -511,7 +512,7 @@ installCabalUnpacked path inst mver' forceInstall = do
   unless forceInstall          -- Overwrite it when it IS a force install
     (liftE $ throwIfFileAlreadyExists destPath)
     
-  copyFileE
+  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
     (path </> cabalFile <> exeExt)
     destPath
   lift $ chmod_755 destPath
@@ -661,7 +662,7 @@ installHLSUnpacked path inst mver' forceInstall = do
     unless forceInstall   -- if it is a force install, overwrite it.
       (liftE $ throwIfFileAlreadyExists destPath)
       
-    copyFileE
+    handleIO (throwE . CopyError . show) $ liftIO $ copyFile
       srcPath
       destPath
     lift $ chmod_755 destPath
@@ -677,7 +678,7 @@ installHLSUnpacked path inst mver' forceInstall = do
   unless forceInstall
     (liftE $ throwIfFileAlreadyExists destWrapperPath)
       
-  copyFileE
+  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
     srcWrapperPath
     destWrapperPath
     
@@ -849,37 +850,35 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
       cp <- case cabalProject of
         Just cp
           | isAbsolute cp -> do
-              copyFileE cp (workdir </> "cabal.project")
+              handleIO (throwE . CopyError . show) $ liftIO $ copyFile cp (workdir </> "cabal.project")
               pure "cabal.project"
           | otherwise -> pure (takeFileName cp)
         Nothing -> pure "cabal.project"
-      forM_ cabalProjectLocal $ \cpl -> copyFileE cpl (workdir </> cp <.> "local")
+      forM_ cabalProjectLocal $ \cpl -> handleIO (throwE . CopyError . show) $ liftIO $ copyFile cpl (workdir </> cp <.> "local")
-
-      let targets = ["exe:haskell-language-server", "exe:haskell-language-server-wrapper"]
 
       artifacts <- forM (sort ghcs) $ \ghc -> do
         let ghcInstallDir = installDir </> T.unpack (prettyVer ghc)
-        liftIO $ createDirRecursive' ghcInstallDir
+        liftIO $ createDirRecursive' installDir
         lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc
         liftE $ lEM @_ @'[ProcessError] $
-          execLogged "cabal" ( [ "v2-build"
+          execLogged "cabal" ( [ "v2-install"
                                , "-w"
                                , "ghc-" <> T.unpack (prettyVer ghc)
+                               , "--install-method=copy"
                                ] ++
                                maybe [] (\j -> ["--jobs=" <> show j]) jobs ++
-                               [ "--project-file=" <> cp
+                               [ "--overwrite-policy=always"
-                               ] ++ targets
+                               , "--disable-profiling"
+                               , "--disable-tests"
+                               , "--enable-split-sections"
+                               , "--enable-executable-stripping"
+                               , "--enable-executable-static"
+                               , "--installdir=" <> ghcInstallDir
+                               , "--project-file=" <> cp
+                               , "exe:haskell-language-server"
+                               , "exe:haskell-language-server-wrapper"]
                              )
           (Just workdir) "cabal" Nothing
-        forM_ targets $ \target -> do
-          let cabal = "cabal"
-              args = ["list-bin", target]
-          CapturedProcess{..} <- lift $ executeOut cabal args  (Just workdir) 
-          case _exitCode of
-            ExitFailure i -> throwE (NonZeroExit i cabal args)
-            _ -> pure ()
-          let cbin = stripNewlineEnd . T.unpack . decUTF8Safe' $ _stdOut
-          copyFileE cbin (ghcInstallDir </> takeFileName cbin)
         pure ghcInstallDir
 
       forM_ artifacts $ \artifact -> do
@@ -1040,7 +1039,7 @@ installStackUnpacked path inst mver' forceInstall = do
   unless forceInstall
     (liftE $ throwIfFileAlreadyExists destPath)
       
-  copyFileE
+  handleIO (throwE . CopyError . show) $ liftIO $ copyFile
     (path </> stackFile <> exeExt)
     destPath
   lift $ chmod_755 destPath
@@ -1575,7 +1574,7 @@ listVersions lt' criteria = do
 
   currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult
   currentGHCup av =
-    let currentVer = pvpToVersion ghcUpVer
+    let currentVer = fromJust $ pvpToVersion ghcUpVer
         listVer    = Map.lookup currentVer av
         latestVer  = fst <$> headOf (getTagged Latest) av
         recommendedVer = fst <$> headOf (getTagged Latest) av
@@ -1733,7 +1732,7 @@ rmGHCVer ver = do
       (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
     $ fmap Just
     $ getMajorMinorV (_tvVersion ver)
-  forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
+  forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver))
     >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
 
   Dirs {..} <- lift getDirs
@@ -2411,7 +2410,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
                             <> ".tar"
                             <> takeExtension tar)
     let tarPath = cacheDir </> tarName
-    copyFileE (workdir </> tar)
+    handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
                                                              tarPath
     lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
     pure tarPath
@@ -2541,6 +2540,7 @@ upgradeGHCup :: ( MonadMask m
                 , MonadCatch m
                 , HasLog env
                 , MonadThrow m
+                , MonadFail m
                 , MonadResource m
                 , MonadIO m
                 , MonadUnliftIO m
@@ -2565,7 +2565,8 @@ upgradeGHCup mtarget force' = do
 
   lift $ logInfo "Upgrading GHCup..."
   let latestVer = fromJust $ fst <$> getLatest dls GHCup
-  when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
+  (Just ghcupPVPVer) <- pure $ pvpToVersion ghcUpVer
+  when (not force' && (latestVer <= ghcupPVPVer)) $ throwE NoUpdate
   dli   <- liftE $ getDownloadInfo GHCup latestVer
   tmp   <- lift withGHCupTmpDir
   let fn = "ghcup" <> exeExt
@@ -2577,7 +2578,7 @@ upgradeGHCup mtarget force' = do
   lift $ logDebug $ "rm -f " <> T.pack destFile
   lift $ hideError NoSuchThing $ recycleFile destFile
   lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
-  copyFileE p
+  handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
                                                            destFile
   lift $ chmod_755 destFile
 
@@ -2628,7 +2629,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
     handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
     $ fmap Just
     $ getMajorMinorV _tvVersion
-  forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
+  forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget)
     >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY)
 
 

lib/GHCup/Utils.hs

@@ -86,8 +86,37 @@ import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Text.Megaparsec               as MP
+import qualified Data.List.NonEmpty            as NE
 
 
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> :set -XDataKinds
+-- >>> :set -XTypeApplications
+-- >>> :set -XQuasiQuotes
+-- >>> import System.Directory
+-- >>> import URI.ByteString
+-- >>> import qualified Data.Text as T
+-- >>> import GHCup.Utils.Prelude
+-- >>> import GHCup.Download
+-- >>> import GHCup.Version
+-- >>> import GHCup.Errors
+-- >>> import GHCup.Types
+-- >>> import GHCup.Types.Optics
+-- >>> import Optics
+-- >>> import GHCup.Utils.Version.QQ
+-- >>> import qualified Data.Text.Encoding as E
+-- >>> import Control.Monad.Reader
+-- >>> import Haskus.Utils.Variant.Excepts
+-- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow )
+-- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False }
+-- >>> dirs' <- getAllDirs
+-- >>> let installedVersions = [ ([pver|8.10.7|], Nothing), ([pver|8.10.4|], Nothing), ([pver|8.8.4|], Nothing), ([pver|8.8.3|], Nothing) ]
+-- >>> let settings = Settings True False Never Curl False GHCupURL True GPGNone False
+-- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc
+-- >>> cwd <- getCurrentDirectory
+-- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL)
+-- >>> (VRight r) <- (fmap . fmap) _ghcupDownloads $ flip runReaderT leanAppState . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError] $ liftE $ getBase ref
 
 
 
@@ -559,34 +588,83 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
   Just (x, y) -> x == major' && y == minor'
   Nothing     -> False
 
+-- | Match PVP prefix.
+--
+-- >>> matchPVPrefix [pver|8.8|] [pver|8.8.4|]
+-- True
+-- >>> matchPVPrefix [pver|8|] [pver|8.8.4|]
+-- True
+-- >>> matchPVPrefix [pver|8.10|] [pver|8.8.4|]
+-- False
+-- >>> matchPVPrefix [pver|8.10|] [pver|8.10.7|]
+-- True
+matchPVPrefix :: PVP -> PVP -> Bool
+matchPVPrefix (toL -> prefix) (toL -> full) = and $ zipWith (==) prefix full
 
--- | Get the latest installed full GHC version that satisfies X.Y.
+toL :: PVP -> [Int]
--- This reads `ghcupGHCBaseDir`.
+toL (PVP inner) = fmap fromIntegral $ NE.toList inner
-getGHCForMajor :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
+
-               => Int        -- ^ major version component
+
-               -> Int        -- ^ minor version component
+-- | Get the latest installed full GHC version that satisfies the given (possibly partial)
-               -> Maybe Text -- ^ the target triple
+-- PVP version.
-               -> m (Maybe GHCTargetVersion)
+getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
-getGHCForMajor major' minor' mt = do
+             => PVP
+             -> Maybe Text -- ^ the target triple
+             -> m (Maybe GHCTargetVersion)
+getGHCForPVP pvpIn mt = do
   ghcs <- rights <$> getInstalledGHCs
+  -- we're permissive here... failed parse just means we have no match anyway
+  let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do
+        pvp_ <- versionToPVP _tvVersion
+        pure (pvp_, _tvTarget)
 
-  pure
+  getGHCForPVP' pvpIn ghcs' mt
-    . lastMay
+
-    . sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
+-- | Like 'getGHCForPVP', except with explicit input parameter.
-    . filter
+--
-        (\GHCTargetVersion {..} ->
+-- >>> fmap prettyShow $ getGHCForPVP' [pver|8|] installedVersions Nothing
-          _tvTarget == mt && matchMajor _tvVersion major' minor'
+-- "Just 8.10.7"
-        )
+-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing
-    $ ghcs
+-- "Just 8.8.4"
+-- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing
+-- "Just 8.10.4"
+getGHCForPVP' :: MonadThrow m
+             => PVP
+             -> [(PVP, Maybe Text)] -- ^ installed GHCs
+             -> Maybe Text          -- ^ the target triple
+             -> m (Maybe GHCTargetVersion)
+getGHCForPVP' pvpIn ghcs' mt = do
+  let mResult = lastMay
+                  . sortBy (\(x, _) (y, _) -> compare x y)
+                  . filter
+                      (\(pvp_, target) ->
+                        target == mt && matchPVPrefix pvp_ pvpIn
+                      )
+                  $ ghcs'
+  forM mResult $ \(pvp_, target) -> do
+    ver' <- pvpToVersion pvp_
+    pure (GHCTargetVersion target ver')
 
 
--- | Get the latest available ghc for X.Y major version.
+-- | Get the latest available ghc for the given PVP version, which
-getLatestGHCFor :: Int -- ^ major version component
+-- may only contain parts.
-                -> Int -- ^ minor version component
+--
-                -> GHCupDownloads
+-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8|] r
-                -> Maybe (Version, VersionInfo)
+-- Just (PVP {_pComponents = 8 :| [10,7]})
-getLatestGHCFor major' minor' dls =
+-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8|] r
-  preview (ix GHC % to Map.toDescList) dls >>= lastMay . filter (\(v, _) -> matchMajor v major' minor')
+-- Just (PVP {_pComponents = 8 :| [8,4]})
+-- >>> (fmap . fmap) fst $ getLatestToolFor GHC [pver|8.8.4|] r
+-- Just (PVP {_pComponents = 8 :| [8,4]})
+getLatestToolFor :: MonadThrow m
+                 => Tool
+                 -> PVP
+                 -> GHCupDownloads
+                 -> m (Maybe (PVP, VersionInfo))
+getLatestToolFor tool pvpIn dls = do
+  let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
+  let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls
+  pure . headMay . filter (\(v, _) -> matchPVPrefix pvpIn v) $ ps
+
 
 
 

lib/GHCup/Utils/Prelude.hs

@@ -22,9 +22,9 @@ module GHCup.Utils.Prelude where
 #if defined(IS_WINDOWS)
 import           GHCup.Types
 #endif
+import           GHCup.Errors
 import           GHCup.Types.Optics
 import {-# SOURCE #-} GHCup.Utils.Logger
-import           GHCup.Errors
 
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -33,13 +33,14 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd )
+import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf )
 import           Data.Maybe
 import           Data.Foldable
+import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
 import           Data.String
 import           Data.Text                      ( Text )
 import           Data.Versions
-import           Data.Word8
+import           Data.Word8                  hiding ( isDigit )
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
@@ -60,6 +61,7 @@ import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
 import qualified Data.List.Split               as Split
+import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Text.Encoding.Error      as E
@@ -297,12 +299,28 @@ removeLensFieldLabel str' =
   maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
 
 
-pvpToVersion :: PVP -> Version
+pvpToVersion :: MonadThrow m => PVP -> m Version
 pvpToVersion =
-  either (\_ -> error "Couldn't convert PVP to Version") id
+  either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . prettyPVP
-    . version
-    . prettyPVP
 
+versionToPVP :: MonadThrow m => Version -> m PVP
+versionToPVP v = either (\_ -> alternative v) pure . pvp . prettyVer $ v
+ where
+  alternative :: MonadThrow m => Version -> m PVP
+  alternative v' = case NE.takeWhile isDigit (_vChunks v') of
+    [] -> throwM $ ParseError "Couldn't convert Version to PVP"
+    xs -> pure $ pvpFromList (unsafeDigit <$> xs)
+
+  isDigit :: VChunk -> Bool
+  isDigit (Digits _ :| []) = True
+  isDigit _                = False
+
+  unsafeDigit :: VChunk -> Int
+  unsafeDigit (Digits x :| []) = fromIntegral x
+  unsafeDigit _ = error "unsafeDigit: wrong input"
+
+pvpFromList :: [Int] -> PVP
+pvpFromList = PVP . NE.fromList . fmap fromIntegral
 
 -- | Safe 'decodeUtf8With'. Replaces an invalid input byte with
 -- the Unicode replacement character U+FFFD.
@@ -510,10 +528,6 @@ recover action =
 #endif
 
 
-copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
-copyFileE from = handleIO (throwE . CopyError . show) . liftIO . copyFile from
-
-
 -- | Gathering monoidal values
 --
 -- >>> traverseFold (pure . (:["0"])) ["1","2"]
@@ -534,8 +548,6 @@ forFold = \t -> (`traverseFold` t)
 --
 -- >>> stripNewline "foo\n\n\n"
 -- "foo"
--- >>> stripNewline "foo\n\n\nfoo"
--- "foofoo"
 -- >>> stripNewline "foo\r"
 -- "foo"
 -- >>> stripNewline "foo"
@@ -547,29 +559,10 @@ stripNewline :: String -> String
 stripNewline = filter (`notElem` "\n\r")
 
 
--- | Strip @\\r@ and @\\n@ from end of 'String'.
---
--- >>> stripNewlineEnd "foo\n\n\n"
--- "foo"
--- >>> stripNewlineEnd "foo\n\n\nfoo"
--- "foo\n\n\nfoo"
--- >>> stripNewlineEnd "foo\r"
--- "foo"
--- >>> stripNewlineEnd "foo"
--- "foo"
---
--- prop> \t -> stripNewlineEnd (t <> "\n") === stripNewlineEnd t
--- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewlineEnd t == t
-stripNewlineEnd :: String -> String
-stripNewlineEnd = dropWhileEnd (`elem` "\n\r")
-
-
 -- | Strip @\\r@ and @\\n@ from 'Text's
 --
 -- >>> stripNewline' "foo\n\n\n"
 -- "foo"
--- >>> stripNewline' "foo\n\n\nfoo"
--- "foofoo"
 -- >>> stripNewline' "foo\r"
 -- "foo"
 -- >>> stripNewline' "foo"