From e05676a41f6ac49563678dac466eb701c456cd5c Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 5 Jul 2024 23:53:13 +0800 Subject: [PATCH] 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 deaf874a..5e1e6e13 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 d97d615d..a9c441f8 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 @@ -725,4 +724,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