Don't implicitly smuggle in config options

Fixes #775

app/ghcup/GHCup/OptParse/Config.hs

@@ -59,7 +59,7 @@ data ConfigCommand
     --[ Parsers ]--
     ---------------
 
-          
+
 configP :: Parser ConfigCommand
 configP = subparser
       (  command "init" initP
@@ -120,21 +120,38 @@ formatConfig :: UserSettings -> String
 formatConfig = UTF8.toString . Y.encode
 
 
-updateSettings :: UserSettings -> Settings -> Settings
-updateSettings UserSettings{..} Settings{..} =
-   let cache'      = fromMaybe cache uCache
-       metaCache'  = fromMaybe metaCache uMetaCache
-       metaMode'   = fromMaybe metaMode uMetaMode
-       noVerify'   = fromMaybe noVerify uNoVerify
-       keepDirs'   = fromMaybe keepDirs uKeepDirs
-       downloader' = fromMaybe downloader uDownloader
-       verbose'    = fromMaybe verbose uVerbose
-       urlSource'  = fromMaybe urlSource uUrlSource
-       noNetwork'  = fromMaybe noNetwork uNoNetwork
-       gpgSetting' = fromMaybe gpgSetting uGPGSetting
-       platformOverride' = uPlatformOverride <|> platformOverride
-       mirrors' = fromMaybe mirrors uMirrors
-   in Settings cache' metaCache' metaMode' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor platformOverride' mirrors'
+updateSettings :: UserSettings -> UserSettings -> UserSettings
+updateSettings usl usr =
+   let cache'      = uCache usl      <|> uCache usr
+       metaCache'  = uMetaCache usl  <|> uMetaCache usr
+       metaMode'   = uMetaMode usl   <|> uMetaMode usr
+       noVerify'   = uNoVerify usl   <|> uNoVerify usr
+       verbose'    = uVerbose usl    <|> uVerbose usr
+       keepDirs'   = uKeepDirs usl   <|> uKeepDirs usr
+       downloader' = uDownloader usl <|> uDownloader usr
+       urlSource'  = uUrlSource usl  <|> uUrlSource usr
+       noNetwork'  = uNoNetwork usl  <|> uNoNetwork usr
+       gpgSetting' = uGPGSetting usl <|> uGPGSetting usr
+       platformOverride' = uPlatformOverride usl <|> uPlatformOverride usr
+       mirrors' = uMirrors usl <|> uMirrors usr
+   in UserSettings cache' metaCache' metaMode' noVerify' verbose' keepDirs' downloader' (updateKeyBindings (uKeyBindings usl) (uKeyBindings usr)) urlSource' noNetwork' gpgSetting' 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
+         }
 
 
 
@@ -151,10 +168,11 @@ config :: forall m. ( Monad m
           )
      => ConfigCommand
      -> Settings
+     -> UserSettings
      -> KeyBindings
      -> (ReaderT LeanAppState m () -> m ())
      -> m ExitCode
-config configCommand settings keybindings runLogger = case configCommand of
+config configCommand settings userConf keybindings runLogger = case configCommand of
   InitConfig -> do
     path <- getConfigFilePath
     liftIO $ writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
@@ -203,9 +221,9 @@ config configCommand settings keybindings runLogger = case configCommand of
  where
   doConfig :: MonadIO m => UserSettings -> m ()
   doConfig usersettings = do
-    let settings' = updateSettings usersettings settings
+    let settings' = updateSettings usersettings userConf
     path <- liftIO getConfigFilePath
-    liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
+    liftIO $ writeFile path $ formatConfig $ settings'
     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)
+toSettings :: Options -> IO (Settings, KeyBindings, UserSettings)
 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 $ mergeConf options userConf noColor
+  pure $ (\(s', k) -> (s', k, userConf)) $ 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) <- toSettings opt
+          (settings, keybindings, userConf) <- 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 keybindings runLogger
+            Config configCommand       -> config configCommand settings userConf keybindings runLogger
             Whereis whereisOptions
                     whereisCommand     -> whereis whereisCommand whereisOptions runAppState leanAppstate runLogger
             Upgrade uOpts force' fatal -> upgrade uOpts force' fatal dirs runAppState runLogger

lib/GHCup/Prelude/File/Posix.hs

@@ -279,11 +279,11 @@ removeEmptyDirectory = PD.removeDirectory
 
 -- | Create an 'Unfold' of directory contents.
 unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath)
-unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return)
+unfoldDirContents = U.bracket (liftIO . openDirStreamPortable) (liftIO . closeDirStreamPortable) (Unfold step return)
  where
   {-# INLINE [0] step #-}
   step dirstream = do
-    (typ, e) <- liftIO $ readDirEnt dirstream
+    (typ, e) <- liftIO $ readDirEntPortable dirstream
     return $ if
       | null e    -> D.Stop
       | "." == e  -> D.Skip dirstream
@@ -308,8 +308,8 @@ getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""
   step (_, Nothing, []) = return D.Stop
 
   step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do
-    (dt, f) <- liftIO $ readDirEnt dirstream
-    if | FD.dtUnknown == dt -> do
+    (dt, f) <- liftIO $ readDirEntPortable dirstream
+    if | f == "" -> do
            runIOFinalizer finalizer
            return $ D.Skip (topdir, Nothing, dirs)
        | f == "." || f == ".."
@@ -323,8 +323,8 @@ getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""
 
   acquire dir =
     withRunInIO $ \run -> mask_ $ run $ do
-        dirstream <- liftIO $ openDirStream dir
-        ref <- newIOFinalizer (liftIO $ closeDirStream dirstream)
+        dirstream <- liftIO $ openDirStreamPortable dir
+        ref <- newIOFinalizer (liftIO $ closeDirStreamPortable dirstream)
         return (dirstream, ref)
 
 getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m)

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

@@ -10,9 +10,20 @@
 module GHCup.Prelude.File.Posix.Traversals (
 -- lower-level stuff
   readDirEnt
+, readDirEntPortable
+, openDirStreamPortable
+, closeDirStreamPortable
 , unpackDirStream
+, DirStreamPortable
 ) where
 
+#include <limits.h>
+#include <stdlib.h>
+#include <dirent.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
 
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative ((<$>))
@@ -28,6 +39,7 @@ import Foreign.Storable
 import System.Posix
 import Foreign (alloca)
 import System.Posix.Internals (peekFilePath)
+import System.FilePath
 
 
 
@@ -90,3 +102,31 @@ readDirEnt (unpackDirStream -> dirp) =
                     then return (dtUnknown, mempty)
                     else throwErrno "readDirEnt"
 
+
+newtype DirStreamPortable = DirStreamPortable (FilePath, DirStream)
+
+openDirStreamPortable :: FilePath -> IO DirStreamPortable
+openDirStreamPortable fp = do
+  dirs <- openDirStream fp
+  pure $ DirStreamPortable (fp, dirs)
+
+closeDirStreamPortable :: DirStreamPortable -> IO ()
+closeDirStreamPortable (DirStreamPortable (_, dirs)) = closeDirStream dirs
+
+readDirEntPortable :: DirStreamPortable -> IO (DirType, FilePath)
+readDirEntPortable (DirStreamPortable (basedir, dirs)) = do
+  (dt, fp) <- readDirEnt dirs
+  case (dt, fp) of
+    (DirType #{const DT_UNKNOWN}, _)
+      | fp /= "" -> do
+          stat <- getSymbolicLinkStatus (basedir </> fp)
+          pure $ (, fp) $ if | isBlockDevice stat     -> DirType #{const DT_BLK}
+                             | isCharacterDevice stat -> DirType #{const DT_CHR}
+                             | isDirectory stat       -> DirType #{const DT_DIR}
+                             | isNamedPipe stat       -> DirType #{const DT_FIFO}
+                             | isSymbolicLink stat    -> DirType #{const DT_LNK}
+                             | isRegularFile stat     -> DirType #{const DT_REG}
+                             | isSocket stat          -> DirType #{const DT_SOCK}
+                             | otherwise              -> DirType #{const DT_UNKNOWN}
+    _ -> pure (dt, fp)
+

scripts/bootstrap/bootstrap-haskell

@@ -284,14 +284,6 @@ download_ghcup() {
 			esac
 			;;
         "FreeBSD"|"freebsd")
-            if freebsd-version | grep -E '^12.*' ; then
-                freebsd_ver=12
-            elif freebsd-version | grep -E '^13.*' ; then
-                freebsd_ver=13
-            else
-                die "Unsupported FreeBSD version! Please report a bug at https://github.com/haskell/ghcup-hs/issues"
-            fi
-
 			case "${arch}" in
 				x86_64|amd64)
 					;;
@@ -301,7 +293,7 @@ download_ghcup() {
 				*) die "Unknown architecture: ${arch}"
 					;;
 			esac
-			_url=${GHCUP_BASE_URL}/${ghver}/x86_64-freebsd${freebsd_ver}-ghcup-${ghver}
+			_url=${GHCUP_BASE_URL}/${ghver}/x86_64-portbld-freebsd-ghcup-${ghver}
             ;;
         "Darwin"|"darwin")
 			case "${arch}" in

test/GHCup/Prelude/File/Posix/TraversalsSpec.hs

@@ -24,11 +24,11 @@ spec = do
   -- https://github.com/haskell/ghcup-hs/issues/415
   describe "GHCup.Prelude.File.Posix.Traversals" $ do
     it "readDirEnt" $ do
-      dirstream <- liftIO $ openDirStream "test/data"
-      (dt1, fp1) <- readDirEnt dirstream
-      (dt2, fp2) <- readDirEnt dirstream
-      (dt3, fp3) <- readDirEnt dirstream
-      (dt4, fp4) <- readDirEnt dirstream
+      dirstream <- liftIO $ openDirStreamPortable "test/data"
+      (dt1, fp1) <- readDirEntPortable dirstream
+      (dt2, fp2) <- readDirEntPortable dirstream
+      (dt3, fp3) <- readDirEntPortable dirstream
+      (dt4, fp4) <- readDirEntPortable dirstream
       let xs = sortOn snd [ (dt1, fp1), (dt2, fp2)
                           , (dt3, fp3), (dt4, fp4)
                           ]