Remove cabal-plan wrt #1092

Author: hasufell

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

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
+

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