From 245743b2c9984a505e3683544b5800fadb36c841 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 5 Jul 2024 22:37:01 +0800 Subject: [PATCH 1/3] Remove cabal-plan wrt #1092 --- app/ghcup/Main.hs | 6 ++-- app/ghcup/PlanJson.hs | 79 +++++++++++++++++++++++++++++++++++++++++++ ghcup.cabal | 2 +- 3 files changed, 83 insertions(+), 4 deletions(-) create mode 100644 app/ghcup/PlanJson.hs diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index d56e212e..ccc1ed8b 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -10,6 +10,8 @@ module Main where +import PlanJson + #if defined(BRICK) import GHCup.BrickMain (brickMain) #endif @@ -30,7 +32,6 @@ import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ import GHCup.Version -import Cabal.Plan ( findPlanJson, SearchPlanJson(..) ) import Control.Concurrent import Control.Concurrent.Async import Control.Exception.Safe @@ -113,11 +114,10 @@ toSettings options = do } - plan_json :: String plan_json = $( do (fp, c) <- runIO (handleIO (\_ -> pure ("", "")) $ do - fp <- findPlanJson (ProjectRelativeToDir ".") + fp <- findPlanJson "." c <- B.readFile fp (Just res) <- pure $ decodeStrict' @Value c pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res)) diff --git a/app/ghcup/PlanJson.hs b/app/ghcup/PlanJson.hs new file mode 100644 index 00000000..45ca5e5f --- /dev/null +++ b/app/ghcup/PlanJson.hs @@ -0,0 +1,79 @@ +module PlanJson where + +import Control.Monad (unless) +import System.FilePath +import System.Directory + +findPlanJson + :: FilePath + -> IO FilePath +findPlanJson fp = do + planJsonFn <- do + mRoot <- findProjectRoot fp + case mRoot of + Nothing -> fail ("missing project root relative to: " ++ fp) + Just dir -> fromBuilddir $ dir "dist-newstyle" + + havePlanJson <- doesFileExist planJsonFn + + unless havePlanJson $ + fail "missing 'plan.json' file; do you need to run 'cabal new-build'?" + + return planJsonFn + where + fromBuilddir distFolder = do + haveDistFolder <- doesDirectoryExist distFolder + + unless haveDistFolder $ + fail ("missing " ++ show distFolder ++ " folder; do you need to run 'cabal new-build'?") + + return $ distFolder "cache" "plan.json" + + +-- | Find project root relative to a directory, this emulates cabal's current +-- heuristic, but is slightly more liberal. If no cabal.project is found, +-- cabal-install looks for *.cabal files in the specified directory only. This +-- function also considers *.cabal files in directories higher up in the +-- hierarchy. +findProjectRoot :: FilePath -> IO (Maybe FilePath) +findProjectRoot dir = do + normalisedPath <- canonicalizePath dir + let checkCabalProject d = do + ex <- doesFileExist fn + return $ if ex then Just d else Nothing + where + fn = d "cabal.project" + + checkCabal d = do + files <- listDirectory' d + return $ if any (isExtensionOf' ".cabal") files + then Just d + else Nothing + + result <- walkUpFolders checkCabalProject normalisedPath + case result of + Just rootDir -> pure $ Just rootDir + Nothing -> walkUpFolders checkCabal normalisedPath + where + isExtensionOf' :: String -> FilePath -> Bool + isExtensionOf' ext fp = ext == takeExtension fp + + listDirectory' :: FilePath -> IO [FilePath] + listDirectory' fp = filter isSpecialDir <$> getDirectoryContents fp + where + isSpecialDir f = f /= "." && f /= ".." + +walkUpFolders :: (FilePath -> IO (Maybe a)) -> FilePath -> IO (Maybe a) +walkUpFolders dtest d0 = do + home <- getHomeDirectory + + let go d | d == home = pure Nothing + | isDrive d = pure Nothing + | otherwise = do + t <- dtest d + case t of + Nothing -> go $ takeDirectory d + x@Just{} -> pure x + + go d0 + diff --git a/ghcup.cabal b/ghcup.cabal index 0833da98..abe927a4 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -71,7 +71,6 @@ common app-common-depends , base >=4.12 && <5 , bytestring >=0.10 && <0.12 , cabal-install-parsers >=0.4.5 - , cabal-plan ^>=0.7.2 , containers ^>=0.6 , deepseq ^>=1.4 , directory ^>=1.3.6.0 @@ -378,6 +377,7 @@ executable ghcup main-is: Main.hs hs-source-dirs: app/ghcup + other-modules: PlanJson default-language: Haskell2010 default-extensions: LambdaCase From 30d2272640c78299c86403153f35e58f48edaf4b Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 5 Jul 2024 23:53:13 +0800 Subject: [PATCH 2/3] Remove cabal-install-parsers wrt #1092 --- app/ghcup/Main.hs | 2 +- ghcup.cabal | 6 +- lib-opt/GHCup/OptParse/Common.hs | 5 +- lib-tui/GHCup/Brick/Actions.hs | 7 +- lib/GHCup/CabalConfig.hs | 107 +++++++++++++++++++++++++++ {app/ghcup => lib/GHCup}/PlanJson.hs | 2 +- 6 files changed, 118 insertions(+), 11 deletions(-) create mode 100644 lib/GHCup/CabalConfig.hs rename {app/ghcup => lib/GHCup}/PlanJson.hs (98%) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index ccc1ed8b..0d55328c 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -10,7 +10,7 @@ module Main where -import PlanJson +import GHCup.PlanJson #if defined(BRICK) import GHCup.BrickMain (brickMain) diff --git a/ghcup.cabal b/ghcup.cabal index abe927a4..a10ffcc7 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -70,7 +70,6 @@ common app-common-depends , async ^>=2.2.3 , base >=4.12 && <5 , bytestring >=0.10 && <0.12 - , cabal-install-parsers >=0.4.5 , containers ^>=0.6 , deepseq ^>=1.4 , directory ^>=1.3.6.0 @@ -114,6 +113,7 @@ library exposed-modules: GHCup GHCup.Cabal + GHCup.CabalConfig GHCup.Download GHCup.Download.Utils GHCup.Errors @@ -121,6 +121,7 @@ library GHCup.HLS GHCup.List GHCup.Platform + GHCup.PlanJson GHCup.Prelude GHCup.Prelude.File GHCup.Prelude.File.Search @@ -180,6 +181,7 @@ library , bytestring >=0.10 && <0.12 , bz2 ^>=1.0.1.1 , Cabal ^>=3.0.0.0 || ^>=3.2.0.0 || ^>=3.4.0.0 || ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 + , Cabal-syntax ^>=3.6.0.0 || ^>=3.8.0.0 || ^>= 3.10.0.0 || ^>= 3.12.0.0 , case-insensitive ^>=1.2.1.0 , casing ^>=0.1.4.1 , containers ^>=0.6 @@ -197,6 +199,7 @@ library , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2 , os-release ^>=1.0.0 + , parsec , pretty ^>=1.1.3.1 , pretty-terminal ^>=0.1.0.0 , regex-posix ^>=0.96 @@ -377,7 +380,6 @@ executable ghcup main-is: Main.hs hs-source-dirs: app/ghcup - other-modules: PlanJson default-language: Haskell2010 default-extensions: LambdaCase diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index 14433875..17cadb3f 100644 --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -11,6 +11,7 @@ module GHCup.OptParse.Common where import GHCup +import GHCup.CabalConfig import GHCup.Download import GHCup.Platform import GHCup.Types @@ -25,7 +26,6 @@ import Control.DeepSeq import Control.Concurrent import Control.Concurrent.Async import Control.Exception.Safe -import Control.Monad.Identity (Identity(..)) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif @@ -60,7 +60,6 @@ import qualified Data.Text as T import qualified System.FilePath.Posix as FP import GHCup.Version import Control.Exception (evaluate) -import qualified Cabal.Config as CC -------------- --[ Parser ]-- @@ -500,6 +499,6 @@ checkForUpdates = do logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m () logGHCPostRm ghcVer = do cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store") - (runIdentity . CC.cfgStoreDir <$> CC.readConfig) + getStoreDir let storeGhcDir = cabalStore ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer)) logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index d9497c3a..870b412f 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -12,6 +12,7 @@ module GHCup.Brick.Actions where import GHCup +import GHCup.CabalConfig import GHCup.Download import GHCup.Errors import GHCup.Types.Optics ( getDirs, getPlatformReq, HasLog ) @@ -44,7 +45,6 @@ import Control.Monad.Trans.Resource import Data.Bool import Data.Functor import Data.Function ( (&), on) -import Data.Functor.Identity import Data.List import Data.Maybe import Data.IORef (IORef, readIORef, newIORef, modifyIORef) @@ -81,7 +81,6 @@ import Control.Concurrent (threadDelay) import qualified GHCup.GHC as GHC import qualified GHCup.Utils.Parsers as Utils import qualified GHCup.HLS as HLS -import qualified Cabal.Config as CC @@ -414,7 +413,7 @@ set' input@(_, ListResult {..}) = do logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m () logGHCPostRm ghcVer = do cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store") - (runIdentity . CC.cfgStoreDir <$> CC.readConfig) + getStoreDir let storeGhcDir = cabalStore ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer)) logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir @@ -735,4 +734,4 @@ keyHandlers KeyBindings {..} = ad <- use appData current_app_state <- use appState appSettings .= newAppSettings - appState .= constructList ad newAppSettings (Just current_app_state) \ No newline at end of file + appState .= constructList ad newAppSettings (Just current_app_state) diff --git a/lib/GHCup/CabalConfig.hs b/lib/GHCup/CabalConfig.hs new file mode 100644 index 00000000..01c576e1 --- /dev/null +++ b/lib/GHCup/CabalConfig.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHCup.CabalConfig (getStoreDir) where + +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty) +import Data.Map (Map) +import System.Directory (getAppUserDataDirectory) +import System.Environment (lookupEnv) +import System.FilePath (()) + +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as M +import qualified Distribution.CabalSpecVersion as C +import qualified Distribution.FieldGrammar as C +import qualified Distribution.FieldGrammar.Parsec as C +import qualified Distribution.Fields as C +import qualified Distribution.Fields.LexerMonad as C +import qualified Distribution.Parsec as C +import qualified Distribution.Utils.Generic as C +import qualified Text.Parsec as P + +import Data.Foldable (for_) +import Distribution.Parsec.Error + + + + +getStoreDir :: IO FilePath +getStoreDir = do + fp <- findConfig + bs <- BS.readFile fp + either (fail . show . fmap (showPError fp)) resolveConfig (parseConfig bs) + +------------------------------------------------------------------------------- +-- Find config +------------------------------------------------------------------------------- + +-- | Find the @~\/.cabal\/config@ file. +findConfig :: IO FilePath +findConfig = do + env <- lookupEnv "CABAL_CONFIG" + case env of + Just p -> return p + Nothing -> do + cabalDir <- findCabalDir + return (cabalDir "config") + +-- | Find the @~\/.cabal@ dir. +findCabalDir :: IO FilePath +findCabalDir = do + cabalDirVar <- lookupEnv "CABAL_DIR" + maybe (getAppUserDataDirectory "cabal") return cabalDirVar + + +------------------------------------------------------------------------------- +-- Parsing +------------------------------------------------------------------------------- + +-- | Parse @~\/.cabal\/config@ file. +parseConfig :: ByteString -> Either (NonEmpty PError) (Maybe FilePath) +parseConfig = parseWith $ \fields0 -> do + let (fields1, _) = C.partitionFields fields0 + let fields2 = M.filterWithKey (\k _ -> k `elem` knownFields) fields1 + parse fields2 + where + knownFields = C.fieldGrammarKnownFieldList grammar + + parse :: Map C.FieldName [C.NamelessField C.Position] + -> C.ParseResult (Maybe FilePath) + parse fields = C.parseFieldGrammar C.cabalSpecLatest fields grammar + +grammar :: C.ParsecFieldGrammar (Maybe FilePath) (Maybe FilePath) +grammar = mempty + <$> C.optionalFieldAla "store-dir" C.FilePathNT id + +parseWith + :: ([C.Field C.Position] -> C.ParseResult a) -- ^ parse + -> ByteString -- ^ contents + -> Either (NonEmpty PError) a +parseWith parser bs = case C.runParseResult result of + (_, Right x) -> Right x + (_, Left (_, es)) -> Left es + where + result = case C.readFields' bs of + Left perr -> C.parseFatalFailure pos (show perr) where + ppos = P.errorPos perr + pos = C.Position (P.sourceLine ppos) (P.sourceColumn ppos) + Right (fields, lexWarnings) -> do + C.parseWarnings (C.toPWarnings lexWarnings) + for_ (C.validateUTF8 bs) $ \pos -> + C.parseWarning C.zeroPos C.PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos + parser fields + +------------------------------------------------------------------------------- +-- Resolving +------------------------------------------------------------------------------- + +-- | Fill the default in @~\/.cabal\/config@ file. +resolveConfig :: Maybe FilePath -> IO FilePath +resolveConfig (Just fp) = pure fp +resolveConfig Nothing = do + c <- findCabalDir + return (c "store") + diff --git a/app/ghcup/PlanJson.hs b/lib/GHCup/PlanJson.hs similarity index 98% rename from app/ghcup/PlanJson.hs rename to lib/GHCup/PlanJson.hs index 45ca5e5f..51c05230 100644 --- a/app/ghcup/PlanJson.hs +++ b/lib/GHCup/PlanJson.hs @@ -1,4 +1,4 @@ -module PlanJson where +module GHCup.PlanJson where import Control.Monad (unless) import System.FilePath From 0f38f032bbcc0f292a1d97983689679963d482ad Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 5 Jul 2024 23:57:20 +0800 Subject: [PATCH 3/3] Point to correct store dir when XDG is used Fixes #1089 --- lib/GHCup/CabalConfig.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lib/GHCup/CabalConfig.hs b/lib/GHCup/CabalConfig.hs index 01c576e1..70da0ae0 100644 --- a/lib/GHCup/CabalConfig.hs +++ b/lib/GHCup/CabalConfig.hs @@ -7,7 +7,7 @@ module GHCup.CabalConfig (getStoreDir) where import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) -import System.Directory (getAppUserDataDirectory) +import System.Directory (getAppUserDataDirectory, doesDirectoryExist, getXdgDirectory, XdgDirectory(XdgConfig)) import System.Environment (lookupEnv) import System.FilePath (()) @@ -52,7 +52,11 @@ findConfig = do findCabalDir :: IO FilePath findCabalDir = do cabalDirVar <- lookupEnv "CABAL_DIR" - maybe (getAppUserDataDirectory "cabal") return cabalDirVar + appDir <- getAppUserDataDirectory "cabal" + isXdg <- not <$> doesDirectoryExist appDir + if | Just dir <- cabalDirVar -> pure dir + | isXdg -> getXdgDirectory XdgConfig "cabal" + | otherwise -> pure appDir -------------------------------------------------------------------------------