diff options
author | Daniel Gröber <dxld@darkboxed.org> | 2018-06-17 00:56:56 +0200 |
---|---|---|
committer | Daniel Gröber <dxld@darkboxed.org> | 2018-06-17 02:08:49 +0200 |
commit | 6517d6b68a8bee9fd7c5712751bd4310129ea992 (patch) | |
tree | 7a352881c142fe346e1d364676dfb1ae1f01f4fa | |
parent | 4e3bc8374cad8291406edd61da12896077c3747a (diff) |
Fix libexec path guessing when using new-build
-rw-r--r-- | cabal-helper.cabal | 2 | ||||
-rw-r--r-- | lib/Distribution/Helper.hs | 93 |
2 files changed, 76 insertions, 19 deletions
diff --git a/cabal-helper.cabal b/cabal-helper.cabal index 32e26dc..55942f7 100644 --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -98,6 +98,8 @@ library build-depends: base < 5 && >= 4.7 build-depends: Cabal < 2.3 && >= 2.0 || < 1.26 && >= 1.14 + , cabal-plan < 0.4 && >= 0.3.0.0 + , containers < 1 && >= 0.5.5.1 , directory < 1.4 && >= 1.2.1.0 , filepath < 1.5 && >= 1.3.0.0 , transformers < 0.6 && >= 0.3.0.0 diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index 7dbfb2f..0c2adeb 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -15,7 +15,8 @@ -- along with this program. If not, see <http://www.gnu.org/licenses/>. {-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds, - GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor + GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor, + NamedFieldPuns, OverloadedStrings #-} {-| @@ -97,6 +98,7 @@ module Distribution.Helper ( , module Data.Functor.Apply ) where +import Cabal.Plan import Control.Applicative import Control.Monad import Control.Monad.IO.Class @@ -106,8 +108,10 @@ import Control.Exception as E import Data.Char import Data.List import Data.Maybe +import qualified Data.Map as Map import Data.Version import Data.Typeable +import Data.Function import Data.Functor.Apply import Distribution.Simple.BuildPaths (exeExtension) import System.Environment @@ -436,7 +440,7 @@ writeAutogenFiles qe = -- | Get the path to the sandbox package-db in a project getSandboxPkgDb :: (FilePath -> [String] -> String -> IO String) - -> FilePath + -> String -- ^ Cabal build platform, i.e. @buildPlatform@ -> Version -- ^ GHC version (@cProjectVersion@ is your friend) @@ -471,25 +475,76 @@ findLibexecExe = do if exists then return exe else do - mdir <- tryFindCabalHelperTreeLibexecDir - case mdir of + mdir <- tryFindCabalHelperTreeDistDir + dir <- case mdir of Nothing -> - error $ throw $ LibexecNotFoundError exeName libexecdir + throwIO $ LibexecNotFoundError exeName libexecdir Just dir -> - return $ dir </> "dist" </> "build" </> exeName </> exeName - -tryFindCabalHelperTreeLibexecDir :: IO (Maybe FilePath) -tryFindCabalHelperTreeLibexecDir = do - exe <- getExecutablePath' - dir <- case takeFileName exe of - "ghc" -> do -- we're probably in ghci; try CWD - getCurrentDirectory - _ -> - return $ (!!4) $ iterate takeDirectory exe - exists <- doesFileExist $ dir </> "cabal-helper.cabal" - return $ if exists - then Just dir - else Nothing + return dir + + return $ dir </> "build" </> exeName </> exeName + +findPlanJson :: FilePath -> IO (Maybe FilePath) +findPlanJson base = + findFile (map (</> "cache") $ parents base) "plan.json" + +parents :: FilePath -> [FilePath] +parents path = takeWhile (not . (`elem` ["", "."]) . dropDrive) dirs + where dirs = iterate takeDirectory path + +data DistDir = DistDir { ddType :: DistDirType, unDistDir :: FilePath } + deriving (Eq, Ord, Read, Show) +data DistDirType = NewBuildDist | OldBuildDist + deriving (Eq, Ord, Read, Show) + +tryFindCabalHelperTreeDistDir :: IO (Maybe FilePath) +tryFindCabalHelperTreeDistDir = do + exe <- canonicalizePath =<< getExecutablePath' + mplan <- findPlanJson exe + cwd <- getCurrentDirectory + + let candidates = sortBy (compare `on` ddType) $ concat + [ maybeToList $ DistDir NewBuildDist <$> mplan + , [ DistDir OldBuildDist $ (!!3) $ iterate takeDirectory exe ] + , if takeFileName exe == "ghc" -- we're probably in ghci; try CWD + then [ DistDir NewBuildDist $ cwd </> "dist-newstyle" + , DistDir NewBuildDist $ cwd </> "dist" + , DistDir OldBuildDist $ cwd </> "dist" + ] + else [] + ] + + distdirs + <- filterM isDistDir candidates + >>= mapM toOldBuildDistDir + + return $ fmap unDistDir $ join $ listToMaybe $ distdirs + +isCabalHelperSourceDir :: FilePath -> IO Bool +isCabalHelperSourceDir dir = + doesFileExist $ dir </> "cabal-helper.cabal" + +isDistDir :: DistDir -> IO Bool +isDistDir (DistDir NewBuildDist dir) = + doesFileExist (dir </> "cache" </> "plan.json") +isDistDir (DistDir OldBuildDist dir) = + doesFileExist (dir </> "setup-config") + +toOldBuildDistDir :: DistDir -> IO (Maybe DistDir) +toOldBuildDistDir (DistDir NewBuildDist dir) = do + PlanJson {pjUnits} <- decodePlanJson $ dir </> "cache" </> "plan.json" + let munit = find isCabalHelperUnit $ Map.elems pjUnits + return $ DistDir OldBuildDist <$> join ((\Unit { uDistDir = mdistdir } -> mdistdir) <$> munit) + where + isCabalHelperUnit + Unit { uPId = PkgId (PkgName n) _ + , uType = UnitTypeLocal + } | n == "cabal-helper" = True + isCabalHelperUnit _ = False +toOldBuildDistDir x = return $ Just x + + + libexecNotFoundError :: String -- ^ Name of the executable we were trying to -- find |