cabal-plan 0.3.0.0 → 0.4.0.0

raw patch · 5 files changed

+439/−50 lines, 5 filesdep +Cabaldep +tardep +zlibdep ~aesondep ~basedep ~base-compatPVP ok

version bump matches the API change (PVP)

Dependencies added: Cabal, tar, zlib

Dependency ranges changed: aeson, base, base-compat, base-orphans, containers, directory, filepath

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• cabal-plan.cabal +26/−11
• src-exe/LicenseReport.hs +271/−0
• src-exe/cabal-plan.hs +61/−8
• src/Cabal/Plan.hs +69/−31

@@ -1,5 +1,17 @@ # Revision history for `cabal-plan` +## 0.4.0.0++### `lib:cabal-plan` Library++* New `SearchPlanJson` type to specify strategy for locating `plan.json`+* Add `SearchPlanJson` parameter to `findAndDecodePlanJson` function and change return type+* Expose separate `findProjectRoot` operation++### `exe:cabal-plan` Executable++* New command `license-report` (requires Cabal flag `license-report` to be active)+ ## 0.3.0.0  ### `lib:cabal-plan` Library

@@ -1,6 +1,6 @@ cabal-version:       2.0 name:                cabal-plan-version:             0.3.0.0+version:             0.4.0.0  synopsis:            Library and utiltity for processing cabal's plan.json file description: {@@ -21,7 +21,8 @@ build-type:          Simple  tested-with:-  GHC==8.2.1,+  GHC==8.4.3,+  GHC==8.2.2,   GHC==8.0.2,   GHC==7.10.3,   GHC==7.8.4,@@ -37,6 +38,11 @@   -- IOW, emulate https://github.com/haskell/cabal/issues/4660   description: Enable @exe:cabal-plan@ component +flag license-report+  description: Enable @license-report@ sub-command (only relevant when the @exe@ flag is active)+  manual: True+  default: False+ flag _   description: Enable underlining of primary unit-ids   manual: True@@ -49,8 +55,8 @@                        RecordWildCards   exposed-modules:     Cabal.Plan -  build-depends:       base              (>= 4.6 && <4.10) || ^>= 4.10-                     , aeson             ^>= 1.2.0+  build-depends:       base              (>= 4.6 && <4.10) || ^>= 4.10 || ^>=4.11+                     , aeson             ^>= 1.2.0 || ^>= 1.3.0 || ^>=1.4.0.0                      , bytestring        ^>= 0.10.0                      , containers        ^>= 0.5.0                      , text              ^>= 1.2.2@@ -67,9 +73,9 @@   other-extensions:    RankNTypes ScopedTypeVariables RecordWildCards   exposed-modules:     Topograph -  build-depends:       base              (>= 4.6 && <4.10) || ^>= 4.10-                     , base-compat       ^>= 0.9.3-                     , base-orphans      ^>= 0.6+  build-depends:       base              (>= 4.6 && <4.10) || ^>= 4.10 || ^>= 4.11+                     , base-compat       ^>= 0.9.3 || ^>=0.10.1+                     , base-orphans      ^>= 0.6 || ^>=0.7 || ^>=0.8                      , containers        ^>= 0.5.0                      , vector            ^>= 0.12.0.1 @@ -79,8 +85,10 @@   default-language:    Haskell2010   other-extensions:    RecordWildCards -  main-is: src-exe/cabal-plan.hs-  other-modules: Paths_cabal_plan+  hs-source-dirs: src-exe+  main-is: cabal-plan.hs+  other-modules: Paths_cabal_plan, LicenseReport+  autogen-modules: Paths_cabal_plan    if flag(exe)     -- dependencies w/ inherited version ranges via 'cabal-plan' library@@ -90,15 +98,22 @@                  , text                  , containers                  , bytestring+                 , directory      -- dependencies which require version bounds     build-depends: mtl            ^>= 2.2.1-                 , ansi-terminal  ^>= 0.6.2-                 , base-compat    ^>= 0.9.3+                 , ansi-terminal  ^>= 0.6.2 || ^>= 0.8.0.2+                 , base-compat    ^>= 0.9.3 || ^>=0.10.1                  , optparse-applicative ^>= 0.13.0 || ^>= 0.14.0                  , parsec         ^>= 3.1.11                  , vector         ^>= 0.12.0.1 ++    if flag(license-report)+      build-depends: Cabal    ^>= 2.2.0.1+                   , tar      ^>= 0.5.1.0+                   , zlib     ^>= 0.6.2+                   , filepath ^>= 1.4.1.2      if !impl(ghc >= 8.0)       build-depends:

@@ -0,0 +1,271 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++-- | Implements @cabal-plan license-report@ functionality+module LicenseReport+    ( generateLicenseReport+    ) where++#if defined(MIN_VERSION_Cabal)+import           Cabal.Plan+import qualified Codec.Archive.Tar                      as Tar+import qualified Codec.Archive.Tar.Entry                as Tar+import qualified Codec.Compression.GZip                 as GZip+import           Control.Monad.Compat                   (forM, forM_, guard, unless, when)+import qualified Data.ByteString.Lazy                   as BSL+import qualified Data.ByteString                        as BS+import           Data.Map                               (Map)+import           Data.List                              (nub)+import qualified Data.Map                               as Map+import           Data.Semigroup+import           Data.Set                               (Set)+import qualified Data.Set                               as Set+import qualified Data.Text                              as T+import qualified Data.Text.IO                           as T+import qualified Data.Version                           as DV+import           Distribution.PackageDescription+import           Distribution.PackageDescription.Parsec+import           Distribution.Pretty+import           System.Directory+import           System.FilePath+import           System.IO                              (stderr)+import           Text.ParserCombinators.ReadP+import           Prelude ()+import           Prelude.Compat++-- | Read tarball lazily (and possibly decompress)+readTarEntries :: FilePath -> IO [Tar.Entry]+readTarEntries idxtar = do+    es <- case takeExtension idxtar of+            ".gz"  -> Tar.read . GZip.decompress <$> BSL.readFile idxtar+            ".tar" -> Tar.read                   <$> BSL.readFile idxtar+            ext    -> error ("unknown extension " ++ show ext)++    return (Tar.foldEntries (:) [] (\err -> error ("readTarEntries " ++ show err)) es)++fp2pid :: FilePath -> Maybe PkgId+fp2pid fn0 = do+  [pns,pvs,rest] <- Just (splitDirectories fn0)+  guard (rest == pns <.> "cabal")+  pv <- parseVer pvs+  pure (PkgId (PkgName $ T.pack pns) pv)+++parseVer :: String -> Maybe Ver+parseVer str = case reverse $ readP_to_S DV.parseVersion str of+  (ver, "") : _ | not (null (DV.versionBranch ver)), all (>= 0) (DV.versionBranch ver)+      -> Just (Ver $ DV.versionBranch ver)+  _   -> Nothing+++readHackageIndex :: IO [(PkgId, BSL.ByteString)]+readHackageIndex = do+    -- TODO: expose package index configuration as CLI flag+    cabalPkgCacheDir <- getAppUserDataDirectory "cabal/packages/hackage.haskell.org"+    ents <- readTarEntries (cabalPkgCacheDir </> "01-index.tar")++    pure [ (maybe (error $ show n) id $ fp2pid n,bsl)+         | e@(Tar.Entry { Tar.entryContent = Tar.NormalFile bsl _ }) <- ents+         , let n = Tar.entryPath e+         , takeExtension n == ".cabal"+         ]++getLicenseFiles :: PkgId -> UnitId -> [FilePath] -> IO [BS.ByteString]+getLicenseFiles compilerId (UnitId uidt) fns = do+  storeDir <- getAppUserDataDirectory "cabal/store"+  let docDir = storeDir </> T.unpack (dispPkgId compilerId) </> T.unpack uidt </> "share" </> "doc"+  forM fns $ \fn -> BS.readFile (docDir </> fn)++{- WARNING: the code that follows will make you cry; a safety pig is provided below for your benefit.++                         _+ _._ _..._ .-',     _.._(`))+'-. `     '  /-._.-'    ',/+   )         \            '.+  / _    _    |             \+ |  a    a    /              |+ \   .-.                     ;+  '-('' ).-'       ,'       ;+     '-;           |      .'+        \           \    /+        | 7  .__  _.-\   \+        | |  |  ``/  /`  /+       /,_|  |   /,_/   /+          /,_/      '`-'++-}++-- TODO: emit report to Text or Text builder+generateLicenseReport :: Maybe FilePath -> PlanJson -> UnitId -> CompName -> IO ()+generateLicenseReport mlicdir plan uid0 cn0 = do+    let pidsOfInterest = Set.fromList (map uPId (Map.elems $ pjUnits plan))++    indexDb <- Map.fromList . filter (flip Set.member pidsOfInterest . fst) <$> readHackageIndex++    let -- generally, units belonging to the same package as 'root'+        rootPkgUnits = [ u | u@(Unit { uPId = PkgId pn' _ }) <- Map.elems (pjUnits plan), pn' == pn0 ]+        rootPkgUnitIds = Set.fromList (map uId rootPkgUnits)++        -- the component of interest+        Just root@Unit { uPId = PkgId pn0 _ } = Map.lookup uid0 (pjUnits plan)++        fwdDeps = planJsonIdGraph' plan+        revDeps = invertMap fwdDeps++    let transUids = transDeps fwdDeps (uId root) Set.\\ rootPkgUnitIds++        indirectDeps = Set.fromList [ u | u <- Set.toList transUids, Set.null (Map.findWithDefault mempty u revDeps `Set.intersection` rootPkgUnitIds) ]++        directDeps = transUids Set.\\ indirectDeps+++    let printInfo :: UnitId -> IO ()+        printInfo uid = do+          let Just u = Map.lookup uid (pjUnits plan)++              PkgId (PkgName pn) pv = uPId u++          case BSL.toStrict <$> Map.lookup (uPId u) indexDb of+            Nothing+              | PkgId (PkgName "rts") _ <- uPId u -> pure ()+              | otherwise -> fail (show u)++            Just x -> do+              gpd <- maybe (fail "parseGenericPackageDescriptionMaybe") pure $+                     parseGenericPackageDescriptionMaybe x++              let desc = escapeDesc $ synopsis $ packageDescription gpd+                  lic  = license  $ packageDescription gpd+                  -- cr   = copyright $ packageDescription gpd+                  lfs  = licenseFiles $ packageDescription gpd++                  usedBy = Set.fromList [ uPId (Map.findWithDefault undefined unit (pjUnits plan))+                                        | unit <- Set.toList (Map.findWithDefault mempty uid revDeps)+                                        , unit `Set.member` (directDeps <> indirectDeps)+                                        ]++              let url = "http://hackage.haskell.org/package/" <> dispPkgId (uPId u)++                  isB = uType u == UnitTypeBuiltin++                  -- special core libs whose reverse deps are too noisy+                  baseLibs = ["base", "ghc-prim", "integer-gmp", "integer-simple", "rts"]++                  licurl = case lfs of+                             [] -> url+                             (l:_)+                               | Just licdir <- mlicdir, uType u == UnitTypeGlobal -> T.pack (licdir </> T.unpack (dispPkgId (uPId u)) </> takeFileName l)+                               | otherwise              -> url <> "/src/" <> T.pack l++              T.putStrLn $ mconcat+                [ if isB then "| **`" else "| `", pn, if isB then "`** | [`" else "` | [`", dispVer pv, "`](", url , ")", " | "+                , "[`", T.pack (prettyShow lic), "`](", licurl , ")", " | "+                , T.pack desc, " | "+                , if pn `elem` baseLibs then "*(core library)*"+                  else T.intercalate ", " [ T.singleton '`' <> (j :: T.Text) <> "`" | PkgId (z@(PkgName j)) _ <- Set.toList usedBy,  z /= pn0], " |"+                ]++              -- print (pn, pv, prettyShow lic, cr, lfs, [ j | PkgId (PkgName j) _ <- Set.toList usedBy ])++              forM_ mlicdir $ \licdir -> do++                case uType u of+                  UnitTypeGlobal -> do+                    let lfs' = nub (map takeFileName lfs)++                    when (length lfs' /= length lfs) $ do+                      T.hPutStrLn stderr ("WARNING: Overlapping license filenames for " <> dispPkgId (uPId u))++                    crdat <- getLicenseFiles (pjCompilerId plan) uid lfs'++                    forM_ (zip lfs' crdat) $ \(fn,txt) -> do+                      let d = licdir </> T.unpack (dispPkgId (uPId u))+                      createDirectoryIfMissing True d+                      BS.writeFile (d </> fn) txt++                    -- forM_ crdat $ print+                    pure ()++                  -- TODO:+                  --   UnitTypeBuiltin+                  --   UnitTypeLocal+                  --   UnitTypeInplace++                  UnitTypeBuiltin -> T.hPutStrLn stderr ("WARNING: license files for " <> dispPkgId (uPId u) <> " (global/GHC bundled) not copied")+                  UnitTypeLocal   -> T.hPutStrLn stderr ("WARNING: license files for " <> dispPkgId (uPId u) <> " (project-local package) not copied")+                  UnitTypeInplace -> T.hPutStrLn stderr ("WARNING: license files for " <> dispPkgId (uPId u) <> " (project-inplace package) not copied")++                unless (length lfs == Set.size (Set.fromList lfs)) $+                  fail ("internal invariant broken for " <> show (uPId u))++          pure ()++    T.putStrLn "# Dependency License Report"+    T.putStrLn ""+    T.putStrLn ("Bold-faced **`package-name`**s denote standard libraries bundled with `" <> dispPkgId (pjCompilerId plan) <> "`.")+    T.putStrLn ""++    T.putStrLn ("## Direct dependencies of `" <> unPkgN pn0 <> ":" <> dispCompName cn0 <> "`")+    T.putStrLn ""+    T.putStrLn "| Name | Version | [SPDX](https://spdx.org/licenses/) License Id | Description | Also depended upon by |"+    T.putStrLn "| --- | --- | --- | --- | --- |"+    forM_ directDeps $ printInfo+    T.putStrLn ""++    T.putStrLn "## Indirect transitive dependencies"+    T.putStrLn ""+    T.putStrLn "| Name | Version | [SPDX](https://spdx.org/licenses/) License Id | Description | Depended upon by |"+    T.putStrLn "| --- | --- | --- | --- | --- |"+    forM_ indirectDeps $ printInfo+    T.putStrLn ""++    pure ()++escapeDesc :: String -> String+escapeDesc []          = []+escapeDesc ('\n':rest) = ' ':escapeDesc rest+escapeDesc ('|':rest)  = '\\':'|':escapeDesc rest+escapeDesc (x:xs)      = x:escapeDesc xs++unPkgN :: PkgName -> T.Text+unPkgN (PkgName t) = t++planItemAllLibDeps :: Unit -> Set.Set UnitId+planItemAllLibDeps Unit{..} = mconcat [ ciLibDeps | (cn,CompInfo{..}) <- Map.toList uComps, wantC cn ]+  where+    wantC (CompNameSetup)   = False+    wantC (CompNameTest _)  = False+    wantC (CompNameBench _) = False+    wantC _                 = True++planJsonIdGraph':: PlanJson -> Map UnitId (Set UnitId)+planJsonIdGraph' PlanJson{..} = Map.fromList [ (uId unit, planItemAllLibDeps unit) | unit <- Map.elems pjUnits ]++++invertMap :: Ord k => Map k (Set k) -> Map k (Set k)+invertMap m0 = Map.fromListWith mappend [ (v, Set.singleton k) | (k,vs) <- Map.toList m0, v <- Set.toList vs ]++transDeps :: Map UnitId (Set UnitId) -> UnitId -> Set UnitId+transDeps g n0 = go mempty [n0]+  where+    go :: Set UnitId -> [UnitId] -> Set UnitId+    go acc [] = acc+    go acc (n:ns)+      | Set.member n acc = go acc ns+      | otherwise = go (Set.insert n acc) (ns ++ Set.toList (Map.findWithDefault undefined n g))++#else++----------------------------------------------------------------------------+import           Cabal.Plan+import           System.Exit+import           System.IO++generateLicenseReport :: Maybe FilePath -> PlanJson -> UnitId -> CompName -> IO ()+generateLicenseReport _ _ _ _ = do+  hPutStrLn stderr "ERROR: `cabal-plan license-report` sub-command not available! Please recompile/reinstall `cabal-plan` with the `license-report` Cabal flag activated."+  exitFailure++#endif

@@ -7,7 +7,7 @@ import           Prelude                     () import           Prelude.Compat -import           Control.Monad.Compat        (guard, unless, when)+import           Control.Monad.Compat        (forM_, guard, unless, when) import           Control.Monad.RWS.Strict    (RWS, evalRWS, gets, modify', tell) import           Control.Monad.ST            (runST) import           Data.Char                   (isAlphaNum)@@ -32,6 +32,7 @@ import           Data.Version import           Options.Applicative import           System.Console.ANSI+import           System.Directory            (getCurrentDirectory) import           System.Exit                 (exitFailure) import           System.IO                   (hPutStrLn, stderr) import qualified Text.Parsec                 as P@@ -39,6 +40,7 @@ import qualified Topograph                   as TG  import           Cabal.Plan+import           LicenseReport               (generateLicenseReport) import           Paths_cabal_plan            (version)  haveUnderlineSupport :: Bool@@ -62,6 +64,7 @@     | ListBinsCommand MatchCount [Pattern]     | DotCommand Bool Bool [Highlight]     | TopoCommand Bool+    | LicenseReport (Maybe FilePath) Pattern  ------------------------------------------------------------------------------- -- Pattern@@ -111,7 +114,7 @@  patternCompleter :: Bool -> Completer patternCompleter onlyWithExes = mkCompleter $ \pfx -> do-    (plan, _) <- findAndDecodePlanJson Nothing+    plan <- getCurrentDirectory >>= findAndDecodePlanJson . ProjectRelativeToDir     let tpfx  = T.pack pfx         components = findComponents plan @@ -234,10 +237,17 @@ main :: IO () main = do     GlobalOptions{..} <- execParser $ info (helper <*> optVersion <*> optParser) fullDesc-    val@(plan, _) <- findAndDecodePlanJson buildDir+    (searchMethod, mProjRoot) <- case buildDir of+            Just dir -> pure (InBuildDir dir, Nothing)+            Nothing -> do+                cwd <- getCurrentDirectory+                root <- findProjectRoot cwd+                pure (ProjectRelativeToDir cwd, root)++    plan <- findAndDecodePlanJson searchMethod     case cmd of-      InfoCommand -> doInfo val-      ShowCommand -> print val+      InfoCommand -> doInfo mProjRoot plan+      ShowCommand -> mapM_ print mProjRoot >> print plan       ListBinsCommand count pats -> do           let bins = doListBin plan pats           case (count, bins) of@@ -254,6 +264,7 @@       FingerprintCommand -> doFingerprint plan       DotCommand tred tredWeights highlights -> doDot optsShowBuiltin optsShowGlobal plan tred tredWeights highlights       TopoCommand rev -> doTopo optsShowBuiltin optsShowGlobal plan rev+      LicenseReport mfp pat -> doLicenseReport mfp pat   where     optVersion = infoOption ("cabal-plan " ++ showVersion version)                             (long "version" <> help "output version information and exit")@@ -300,6 +311,11 @@               <$> switchM                   [ long "reverse", help "Reverse order" ]               <**> helper+        , subCommand "license-report" "Generate license report for a component" $ LicenseReport+              <$> optional (strOption $ mconcat [ long "licensedir", metavar "DIR", help "Write per-package license documents to folder" ])+              <*> patternParser+                  [ metavar "PATTERN", help "Pattern to match.", completer $ patternCompleter False ]+              <**> helper         ]      defaultCommand = pure InfoCommand@@ -357,9 +373,10 @@ -- info ------------------------------------------------------------------------------- -doInfo :: (PlanJson, FilePath) -> IO ()-doInfo (plan,projbase) = do-    putStrLn ("using '" ++ projbase ++ "' as project root")+doInfo :: Maybe FilePath -> PlanJson -> IO ()+doInfo mProjbase plan = do+    forM_ mProjbase $ \projbase ->+        putStrLn ("using '" ++ projbase ++ "' as project root")     putStrLn ""     putStrLn "Tree"     putStrLn "~~~~"@@ -659,6 +676,42 @@     dispCompName' :: CompName -> T.Text     dispCompName' CompNameLib = ""     dispCompName' cname       = ":" <> dispCompName cname++-------------------------------------------------------------------------------+-- license-report+-------------------------------------------------------------------------------++doLicenseReport :: Maybe FilePath -> Pattern -> IO ()+doLicenseReport mlicdir pat = do+    plan <- getCurrentDirectory >>= findAndDecodePlanJson . ProjectRelativeToDir++    case findUnit plan of+      [] -> do+        hPutStrLn stderr "No matches found."+        exitFailure++      lst@(_:_:_) -> do+        hPutStrLn stderr "Multiple matching components found:"+        forM_ lst $ \(pat', uid, cn) -> do+          hPutStrLn stderr ("- " ++ T.unpack pat' ++ "   " ++ show (uid, cn))+        exitFailure++      [(_,uid,cn)] -> generateLicenseReport mlicdir plan uid cn++  where+    findUnit plan = do+        (_, Unit{..}) <- M.toList $ pjUnits plan+        (cn, _) <- M.toList $ uComps++        let PkgId pn@(PkgName pnT) _ = uPId+            g = case cn of+                CompNameLib -> pnT <> T.pack":lib:" <> pnT+                _           -> pnT <> T.pack":" <> dispCompName cn++        guard (getAny $ checkPattern pat pn cn)++        pure (g, uId, cn)+  ------------------------------------------------------------------------------- -- topo

@@ -36,7 +36,9 @@     , planJsonIdRoots      -- * Convenience functions+    , SearchPlanJson(..)     , findAndDecodePlanJson+    , findProjectRoot     , decodePlanJson     ) where @@ -49,7 +51,6 @@ import           Data.List import           Data.Map                     (Map) import qualified Data.Map                     as M-import           Data.Maybe                   (fromMaybe) import           Data.Monoid import           Data.Set                     (Set) import qualified Data.Set                     as S@@ -57,7 +58,7 @@ import qualified Data.Text                    as T import qualified Data.Text.Encoding           as T import qualified Data.Version                 as DV-import           System.Directory+import qualified System.Directory             as Dir import           System.FilePath import           Text.ParserCombinators.ReadP @@ -273,38 +274,58 @@ ---------------------------------------------------------------------------- -- Convenience helper --- | Locates the project root for cabal project in scope for the current--- working directory.+-- | Where/how to search for the plan.json file.+data SearchPlanJson+    = ProjectRelativeToDir FilePath -- ^ Find the project root relative to+                                    --   specified directory and look for+                                    --   plan.json there.+    | InBuildDir FilePath           -- ^ Look for plan.json in specified build+                                    --   directory.+    deriving (Eq, Show, Read)++-- | Locates the project root for cabal project relative to specified+-- directory. -- -- @plan.json@ is located from either the optional build dir argument, or in -- the default directory (@dist-newstyle@) relative to the project root. -- -- The folder assumed to be the project-root is returned as well. --+-- This function determines the project root in a slightly more liberal manner+-- than cabal-install. If no cabal.project is found, cabal-install assumes an+-- implicit cabal.project if the current directory contains any *.cabal files.+--+-- This function looks for any *.cabal files in directories above the current+-- one and behaves as if there is an implicit cabal.project in that directory+-- when looking for a plan.json.+-- -- Throws 'IO' exceptions on errors. -- findAndDecodePlanJson-    :: Maybe FilePath -- ^ Optional build dir to look in.-    -> IO (PlanJson, FilePath)-findAndDecodePlanJson mBuildDir = do-    projbase <- findProjRoot+    :: SearchPlanJson+    -> IO PlanJson+findAndDecodePlanJson searchLoc = do+    distFolder <- case searchLoc of+        InBuildDir builddir -> pure builddir+        ProjectRelativeToDir fp -> do+            mRoot <- findProjectRoot fp+            case mRoot of+                Nothing -> fail ("missing project root relative to: " ++ fp)+                Just dir -> pure $ dir </> "dist-newstyle" -    let distFolder = fromMaybe (projbase </> "dist-newstyle") mBuildDir-    haveDistFolder <- doesDirectoryExist distFolder+    haveDistFolder <- Dir.doesDirectoryExist distFolder      unless haveDistFolder $         fail ("missing " ++ show distFolder ++ " folder; do you need to run 'cabal new-build'?")      let planJsonFn = distFolder </> "cache" </> "plan.json" -    havePlanJson <- doesFileExist planJsonFn+    havePlanJson <- Dir.doesFileExist planJsonFn      unless havePlanJson $         fail "missing 'plan.json' file; do you need to run 'cabal new-build'?" -    plan <- decodePlanJson planJsonFn--    pure (plan, projbase)+    decodePlanJson planJsonFn  -- | Decodes @plan.json@ file location provided as 'FilePath' --@@ -318,36 +339,53 @@     jsraw <- B.readFile planJsonFn     either fail pure $ eitherDecodeStrict' jsraw --- Find project root, this emulates cabal's current heuristic------ TODO: currently fallsback to CWD if no cabal.project is found; fallback to locating $pkg.cabal files instead-findProjRoot :: IO FilePath-findProjRoot = do-    cwd  <- getCurrentDirectory--    let tst d = do let fn = d </> "cabal.project"-                   ex <- doesFileExist fn-                   if ex then pure (Just fn) else pure Nothing+-- | 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 <- Dir.canonicalizePath dir+    let checkCabalProject d = do+            ex <- Dir.doesFileExist fn+            return $ if ex then Just d else Nothing+          where+            fn = d </> "cabal.project" -    md <- walkUpFolders tst cwd+        checkCabal d = do+            files <- listDirectory d+            return $ if any (isExtensionOf ".cabal") files+                        then Just d+                        else Nothing -    pure (maybe cwd fst md)+    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 <$> Dir.getDirectoryContents fp+      where+        isSpecialDir f = f /= "." && f /= ".." -walkUpFolders :: (FilePath -> IO (Maybe a)) -> FilePath -> IO (Maybe (FilePath,a))+walkUpFolders+    :: (FilePath -> IO (Maybe a)) -> FilePath -> IO (Maybe a) walkUpFolders dtest d0 = do-    home <- getHomeDirectory+    home <- Dir.getHomeDirectory      let go d | d == home  = pure Nothing              | isDrive d  = pure Nothing              | otherwise  = do                    t <- dtest d                    case t of-                     Just a  -> pure $ Just (d, a)-                     Nothing -> go (takeDirectory d)+                     Nothing -> go $ takeDirectory d+                     x@Just{} -> pure x      go d0-  parseVer :: Text -> Maybe Ver parseVer str = case reverse $ readP_to_S DV.parseVersion (T.unpack str) of