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