diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/cabal-plan.cabal b/cabal-plan.cabal --- a/cabal-plan.cabal +++ b/cabal-plan.cabal @@ -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: diff --git a/src-exe/LicenseReport.hs b/src-exe/LicenseReport.hs new file mode 100644 --- /dev/null +++ b/src-exe/LicenseReport.hs @@ -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 diff --git a/src-exe/cabal-plan.hs b/src-exe/cabal-plan.hs --- a/src-exe/cabal-plan.hs +++ b/src-exe/cabal-plan.hs @@ -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 diff --git a/src/Cabal/Plan.hs b/src/Cabal/Plan.hs --- a/src/Cabal/Plan.hs +++ b/src/Cabal/Plan.hs @@ -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