Test fuckup

.github/scripts/bootstrap.sh

@@ -13,6 +13,4 @@ git describe --always
 ./scripts/bootstrap/bootstrap-haskell
 
 [ "$(ghc --numeric-version)" = "${BOOTSTRAP_HASKELL_GHC_VERSION}" ]
-# https://github.com/actions/runner-images/issues/7061
-[ "$(ghcup config | grep --color=never meta-mode)" = "meta-mode: Lax" ]
 

.github/scripts/test.sh

@@ -190,7 +190,7 @@ sha=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
 # invalidate access time timer, which is 5minutes, so we re-download
 touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
 # redownload same file with some newlines added
-raw_eghcup -s https://raw.githubusercontent.com/haskell/ghcup-metadata/exp/ghcup-0.0.7.yaml list
+raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
 # snapshot new yaml and etags file
 etag2=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
 sha2=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
@@ -200,7 +200,7 @@ sha2=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
 # invalidate access time timer, which is 5minutes, but don't expect a re-download
 touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
 # this time, we expect the same hash and etag
-raw_eghcup -s https://raw.githubusercontent.com/haskell/ghcup-metadata/exp/ghcup-0.0.7.yaml list
+raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
 etag3=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
 sha3=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
 [ "${etag2}" = "${etag3}" ]

.github/workflows/bootstrap.yaml

@@ -25,10 +25,6 @@ jobs:
         include:
           - os: ubuntu-latest
             DISTRO: Ubuntu
-          - os: macOS-10.15
-            DISTRO: na
-          - os: windows-latest
-            DISTRO: na
     steps:
       - name: Checkout code
         uses: actions/checkout@v3
@@ -38,18 +34,10 @@ jobs:
       - if: runner.os == 'Linux'
         name: Run bootstrap
         run: |
-          sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential curl gzip
+          ls -lah /usr/local/.ghcup
-          sh ./.github/scripts/bootstrap.sh
+          ls -lah /usr/local/.ghcup/cache
+          cat /usr/local/.ghcup/config.yaml
+          ghcup --version
+          ghcup -v install cabal 3.8.1.0
         env:
           DISTRO: ${{ matrix.DISTRO }}
-
-      - if: runner.os == 'macOS'
-        name: Run bootstrap
-        run: sh ./.github/scripts/bootstrap.sh
-        env:
-          DISTRO: ${{ matrix.DISTRO }}
-
-      - if: runner.os == 'Windows'
-        name: Run bootstrap
-        run: ./scripts/bootstrap/bootstrap-haskell.ps1 -InstallDir ${GITHUB_WORKSPACE} -BootstrapUrl ${GITHUB_WORKSPACE}/bootstrap-haskell -InBash
-        shell: pwsh

app/ghcup/GHCup/OptParse/Config.hs

@@ -51,7 +51,7 @@ data ConfigCommand
   = ShowConfig
   | SetConfig String (Maybe String)
   | InitConfig
-  | AddReleaseChannel Bool URI
+  | AddReleaseChannel URI
 
 
 
@@ -59,7 +59,7 @@ data ConfigCommand
     --[ Parsers ]--
     ---------------
 
-
+          
 configP :: Parser ConfigCommand
 configP = subparser
       (  command "init" initP
@@ -74,7 +74,7 @@ configP = subparser
   showP = info (pure ShowConfig) (progDesc "Show current config (default)")
   setP  = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
   argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
-  addP  = info (AddReleaseChannel <$> switch (long "force" <> help "Delete existing entry (if any) and append instead of failing") <*> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
+  addP  = info (AddReleaseChannel <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
     (progDesc "Add a release channel from a URI")
 
 
@@ -120,38 +120,21 @@ formatConfig :: UserSettings -> String
 formatConfig = UTF8.toString . Y.encode
 
 
-updateSettings :: UserSettings -> UserSettings -> UserSettings
+updateSettings :: UserSettings -> Settings -> Settings
-updateSettings usl usr =
+updateSettings UserSettings{..} Settings{..} =
-   let cache'      = uCache usl      <|> uCache usr
+   let cache'      = fromMaybe cache uCache
-       metaCache'  = uMetaCache usl  <|> uMetaCache usr
+       metaCache'  = fromMaybe metaCache uMetaCache
-       metaMode'   = uMetaMode usl   <|> uMetaMode usr
+       metaMode'   = fromMaybe metaMode uMetaMode
-       noVerify'   = uNoVerify usl   <|> uNoVerify usr
+       noVerify'   = fromMaybe noVerify uNoVerify
-       verbose'    = uVerbose usl    <|> uVerbose usr
+       keepDirs'   = fromMaybe keepDirs uKeepDirs
-       keepDirs'   = uKeepDirs usl   <|> uKeepDirs usr
+       downloader' = fromMaybe downloader uDownloader
-       downloader' = uDownloader usl <|> uDownloader usr
+       verbose'    = fromMaybe verbose uVerbose
-       urlSource'  = uUrlSource usl  <|> uUrlSource usr
+       urlSource'  = fromMaybe urlSource uUrlSource
-       noNetwork'  = uNoNetwork usl  <|> uNoNetwork usr
+       noNetwork'  = fromMaybe noNetwork uNoNetwork
-       gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
+       gpgSetting' = fromMaybe gpgSetting uGPGSetting
-       platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
+       platformOverride' = uPlatformOverride <|> platformOverride
-       mirrors' = uMirrors usl <|> uMirrors usr
+       mirrors' = fromMaybe mirrors uMirrors
-   in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' platformOverride' mirrors'
+   in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' mirrors'
- where
-  updateKeyBindings :: Maybe UserKeyBindings -> Maybe UserKeyBindings -> Maybe UserKeyBindings
-  updateKeyBindings Nothing Nothing = Nothing
-  updateKeyBindings (Just kbl) Nothing = Just kbl
-  updateKeyBindings Nothing (Just kbr) = Just kbr
-  updateKeyBindings (Just kbl) (Just kbr) =
-       Just $ UserKeyBindings {
-           kUp = kUp kbl <|> kUp kbr
-         , kDown = kDown kbl <|> kDown kbr
-         , kQuit = kQuit kbl <|> kQuit kbr
-         , kInstall = kInstall kbl <|> kInstall kbr
-         , kUninstall = kUninstall kbl <|> kUninstall kbr
-         , kSet = kSet kbl <|> kSet kbr
-         , kChangelog = kChangelog kbl <|> kChangelog kbr
-         , kShowAll = kShowAll kbl <|> kShowAll kbr
-         , kShowAllTools = kShowAllTools kbl <|> kShowAllTools kbr
-         }
 
 
 
@@ -159,9 +142,6 @@ updateSettings usl usr =
     --[ Entrypoint ]--
     ------------------
 
-data Duplicate = Duplicate     -- ^ there is a duplicate somewhere in the middle
-               | NoDuplicate   -- ^ there is no duplicate
-               | DuplicateLast -- ^ there's a duplicate, but it's the last element
 
 
 config :: forall m. ( Monad m
@@ -171,11 +151,10 @@ config :: forall m. ( Monad m
           )
      => ConfigCommand
      -> Settings
-     -> UserSettings
      -> KeyBindings
      -> (ReaderT LeanAppState m () -> m ())
      -> m ExitCode
-config configCommand settings userConf keybindings runLogger = case configCommand of
+config configCommand settings keybindings runLogger = case configCommand of
   InitConfig -> do
     path <- getConfigFilePath
     liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
@@ -206,55 +185,27 @@ config configCommand settings userConf keybindings runLogger = case configComman
         pure $ ExitFailure 65
       VLeft _ -> pure $ ExitFailure 65
 
-  AddReleaseChannel force uri -> do
+  AddReleaseChannel uri -> do
-    r <- runE @'[DuplicateReleaseChannel] $ do
+    case urlSource settings of
-      case urlSource settings of
+      AddSource xs -> do
-        AddSource xs -> do
+        doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })
-          case checkDuplicate xs (Right uri) of
+        pure ExitSuccess
-            Duplicate
+      GHCupURL -> do
-              | not force -> throwE (DuplicateReleaseChannel uri)
+        doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
-            DuplicateLast -> pure ()
+        pure ExitSuccess
-            _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (appendUnique xs (Right uri)) })
+      OwnSource xs -> do
-        GHCupURL -> do
+        doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (xs <> [Right uri]) })
-          lift $ doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
+        pure ExitSuccess
-          pure ()
+      OwnSpec spec -> do
-        OwnSource xs -> do
+        doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource ([Left spec, Right uri]) })
-          case checkDuplicate xs (Right uri) of
-            Duplicate
-              | not force -> throwE (DuplicateReleaseChannel uri)
-            DuplicateLast -> pure ()
-            _ -> lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource (appendUnique xs (Right uri)) })
-        OwnSpec spec -> do
-          lift $ doConfig (defaultUserSettings { uUrlSource = Just $ OwnSource [Left spec, Right uri] })
-          pure ()
-    case r of
-      VRight _ -> do
         pure ExitSuccess
-      VLeft e -> do
-        runLogger $ logError $ T.pack $ prettyHFError e
-        pure $ ExitFailure 15
 
  where
-  checkDuplicate :: Eq a => [a] -> a -> Duplicate
-  checkDuplicate xs a
-    | last xs == a = DuplicateLast
-    | a `elem` xs  = Duplicate
-    | otherwise    = NoDuplicate
-
-  -- appends the element to the end of the list, but also removes it from the existing list
-  appendUnique :: Eq a => [a] -> a -> [a]
-  appendUnique xs' e = go xs'
-   where
-    go [] = [e]
-    go (x:xs)
-      | x == e    =     go xs -- skip
-      | otherwise = x : go xs
-
   doConfig :: MonadIO m => UserSettings -> m ()
   doConfig usersettings = do
-    let settings' = updateSettings usersettings userConf
+    let settings' = updateSettings usersettings settings
     path <- liftIO getConfigFilePath
-    liftIO $ writeFile path $ formatConfig $ settings'
+    liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
     runLogger $ logDebug $ T.pack $ show settings'
     pure ()
 

app/ghcup/Main.hs

@@ -63,7 +63,7 @@ import qualified GHCup.Types                   as Types
 
 
 
-toSettings :: Options -> IO (Settings, KeyBindings, UserSettings)
+toSettings :: Options -> IO (Settings, KeyBindings)
 toSettings options = do
   noColor <- isJust <$> lookupEnv "NO_COLOR"
   userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case
@@ -73,7 +73,7 @@ toSettings options = do
       pure defaultUserSettings
     _ -> do
       die "Unexpected error!"
-  pure $ (\(s', k) -> (s', k, userConf)) $ mergeConf options userConf noColor
+  pure $ mergeConf options userConf noColor
  where
    mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings)
    mergeConf Options{..} UserSettings{..} noColor =
@@ -176,7 +176,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
           -- create ~/.ghcup dir
           ensureDirectories dirs
 
-          (settings, keybindings, userConf) <- toSettings opt
+          (settings, keybindings) <- toSettings opt
 
           -- logger interpreter
           logfile <- runReaderT initGHCupFileLogging dirs
@@ -303,7 +303,7 @@ Report bugs at <https://github.com/haskell/ghcup-hs/issues>|]
             Rm rmCommand               -> rm rmCommand runAppState runLogger
             DInfo                      -> dinfo runAppState runLogger
             Compile compileCommand     -> compile compileCommand settings dirs runAppState runLogger
-            Config configCommand       -> config configCommand settings userConf keybindings runLogger
+            Config configCommand       -> config configCommand settings keybindings runLogger
             Whereis whereisOptions
                     whereisCommand     -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
             Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger

lib/GHCup/Errors.hs

@@ -35,8 +35,6 @@ import           URI.ByteString
 
 import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
-import qualified Data.Text.Encoding            as E
-import qualified Data.Text.Encoding.Error      as E
 import           Data.Data (Proxy(..))
 
 
@@ -84,7 +82,6 @@ allHFError = unlines allErrors
     , let proxy = Proxy :: Proxy HadrianNotFound in format proxy
     , let proxy = Proxy :: Proxy ToolShadowed in format proxy
     , let proxy = Proxy :: Proxy ContentLengthError in format proxy
-    , let proxy = Proxy :: Proxy DuplicateReleaseChannel in format proxy
     , ""
     , "# high level errors (4000+)"
     , let proxy = Proxy :: Proxy DownloadFailed in format proxy
@@ -643,19 +640,6 @@ instance HFErrorProject ContentLengthError where
   eBase _ = 340
   eDesc _ = "File content length verification failed"
 
-data DuplicateReleaseChannel = DuplicateReleaseChannel URI
-  deriving Show
-
-instance HFErrorProject DuplicateReleaseChannel where
-  eBase _ = 350
-  eDesc _ = "Duplicate release channel detected when adding URI.\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."
-
-instance Pretty DuplicateReleaseChannel where
-  pPrint (DuplicateReleaseChannel uri) =
-    text $ "Duplicate release channel detected when adding: \n  "
-      <> (T.unpack . E.decodeUtf8With E.lenientDecode . serializeURIRef') uri
-      <> "\nGiving up. You can use '--force' to remove and append the duplicate URI (this may change order/semantics)."
-
     -------------------------
     --[ High-level errors ]--
     -------------------------

lib/GHCup/Prelude/File/Posix/Traversals.hsc

@@ -117,15 +117,7 @@ readDirEntPortable :: DirStreamPortable -> IO (DirType, FilePath)
 readDirEntPortable (DirStreamPortable (basedir, dirs)) = do
   (dt, fp) <- readDirEnt dirs
   case (dt, fp) of
-    (DirType #{const DT_BLK}, _)     -> pure (dt, fp)
+    (DirType #{const DT_UNKNOWN}, _)
-    (DirType #{const DT_CHR}, _)     -> pure (dt, fp)
-    (DirType #{const DT_DIR}, _)     -> pure (dt, fp)
-    (DirType #{const DT_FIFO}, _)    -> pure (dt, fp)
-    (DirType #{const DT_LNK}, _)     -> pure (dt, fp)
-    (DirType #{const DT_REG}, _)     -> pure (dt, fp)
-    (DirType #{const DT_SOCK}, _)    -> pure (dt, fp)
-    (DirType #{const DT_UNKNOWN}, _) -> pure (dt, fp)
-    (_, _)
       | fp /= "" -> do
           stat <- getSymbolicLinkStatus (basedir </> fp)
           pure $ (, fp) $ if | isBlockDevice stat     -> DirType #{const DT_BLK}
@@ -136,4 +128,5 @@ readDirEntPortable (DirStreamPortable (basedir, dirs)) = do
                              | isRegularFile stat     -> DirType #{const DT_REG}
                              | isSocket stat          -> DirType #{const DT_SOCK}
                              | otherwise              -> DirType #{const DT_UNKNOWN}
+    _ -> pure (dt, fp)
 

lib/GHCup/Types.hs

@@ -66,7 +66,7 @@ data GHCupInfo = GHCupInfo
   , _ghcupDownloads   :: GHCupDownloads
   , _globalTools      :: Map GlobalTool DownloadInfo
   }
-  deriving (Show, GHC.Generic, Eq)
+  deriving (Show, GHC.Generic)
 
 instance NFData GHCupInfo
 
@@ -87,7 +87,7 @@ data Requirements = Requirements
   { _distroPKGs :: [Text]
   , _notes      :: Text
   }
-  deriving (Show, GHC.Generic, Eq)
+  deriving (Show, GHC.Generic)
 
 instance NFData Requirements
 

scripts/bootstrap/bootstrap-haskell

@@ -119,10 +119,6 @@ edo() {
     "$@" || die "\"$*\" failed!"
 }
 
-eghcup_raw() {
-	"${GHCUP_BIN}/ghcup" "$@" || die "\"ghcup $*\" failed!"
-}
-
 eghcup() {
 	_eghcup "$@"
 }
@@ -385,10 +381,10 @@ download_ghcup() {
     edo . "${GHCUP_DIR}"/env
     case "${BOOTSTRAP_HASKELL_DOWNLOADER}" in
         "curl")
-            eghcup_raw config set downloader Curl
+            eghcup config set downloader Curl
             ;;
         "wget")
-            eghcup_raw config set downloader Wget
+            eghcup config set downloader Wget
             ;;
         *)
             die "Unknown downloader: ${BOOTSTRAP_HASKELL_DOWNLOADER}"