Remove cabal-install-parsers wrt #1092

Author: hasufell

app/ghcup/Main.hs

@@ -10,7 +10,7 @@
 
 module Main where
 
-import           PlanJson
+import           GHCup.PlanJson
 
 #if defined(BRICK)
 import           GHCup.BrickMain (brickMain)

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,13 +113,15 @@ library
   exposed-modules:
     GHCup
     GHCup.Cabal
+    GHCup.CabalConfig
     GHCup.Download
     GHCup.Download.Utils
     GHCup.Errors
     GHCup.GHC
     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

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

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)
+    appState    .= constructList ad newAppSettings (Just current_app_state)

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")
+

app/ghcup/PlanJson.hs renamed to lib/GHCup/PlanJson.hs

@@ -1,4 +1,4 @@
-module PlanJson where
+module GHCup.PlanJson where
 
 import Control.Monad (unless)
 import System.FilePath