diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,17 @@ `stan` uses [PVP Versioning][1]. The change log is available [on GitHub][2]. +## 0.2.1.0 + +* Fix high memory usage in finding Cabal files + + See: + https://github.com/kowainik/stan/pull/586#issuecomment-2906713949 + + Thanks to @0rphee + +* Support `clay-0.16` + ## 0.2.0.0 * Add the following inspections: diff --git a/src/Stan/Cabal.hs b/src/Stan/Cabal.hs --- a/src/Stan/Cabal.hs +++ b/src/Stan/Cabal.hs @@ -6,6 +6,11 @@ Functions to work with cabal files and cabal extension maps. -} +{-# LANGUAGE CPP #-} +#ifdef MIN_VERSION_directory_ospath_streaming +{-# LANGUAGE QuasiQuotes #-} +#endif + module Stan.Cabal ( createCabalExtensionsMap , usedCabalFiles @@ -19,14 +24,22 @@ import Control.Exception (catch) import Extensions (CabalException, ExtensionsError (..), ExtensionsResult, ParsedExtensions (..), mergeAnyExtensions, parseCabalFileExtensions) -import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, listDirectory, - makeRelativeToCurrentDirectory) -import System.FilePath (takeExtension, ()) -import System.IO.Unsafe (unsafeInterleaveIO) +import System.Directory (doesFileExist, makeRelativeToCurrentDirectory) import Stan.Hie.Compat (HieFile (..)) import qualified Data.Map.Strict as Map +#ifndef MIN_VERSION_directory_ospath_streaming +import System.IO.Unsafe (unsafeInterleaveIO) +import qualified System.Directory as FilePath +import qualified System.FilePath as FilePath +#else +import qualified System.OsPath as OsPath +import qualified System.Directory.OsPath as OsPath +import qualified System.Directory.OsPath.Streaming as OPS +import qualified System.Directory.OsPath.Types as OPS +import qualified Data.Set as S +#endif {- | Gets the list of @.cabal@ file paths that were used in the project. @@ -84,46 +97,92 @@ subdirectories. It returns maximum 1 @.cabal@ file from each directory. -} findCabalFiles :: IO [FilePath] -findCabalFiles = do - dir <- getCurrentDirectory - curDirCabal <- findCabalFileDir dir - dirs <- getSubdirsRecursive dir - subDirsCabals <- mapM findCabalFileDir dirs - pure $ catMaybes $ curDirCabal : subDirsCabals +findCabalFiles = +#ifndef MIN_VERSION_directory_ospath_streaming + findCabalFilesFilePath +#else + findCabalFilesStreaming +#endif --- | Find a @.cabal@ file in the given directory. --- TODO: better error handling in stan. -findCabalFileDir :: FilePath -> IO (Maybe FilePath) -findCabalFileDir dir = do - dirContent <- listDirectory dir - let cabalFiles = filter isCabal dirContent - pure $ case cabalFiles of - [] -> Nothing -- throwError $ NoCabalFile dirPath - [cabalFile] -> Just $ dir cabalFile - x:_xs -> Just x -- throwError $ MultipleCabalFiles (x :| xs) +#ifndef MIN_VERSION_directory_ospath_streaming +findCabalFilesFilePath :: IO [FilePath] +findCabalFilesFilePath = do + dir <- FilePath.getCurrentDirectory + curDirCabal <- findCabalFileFilePath dir + dirs <- getSubdirsRecursiveFilePath dir + subDirsCabals <- mapM findCabalFileFilePath dirs + pure $ catMaybes $ curDirCabal : subDirsCabals where - isCabal :: FilePath -> Bool - isCabal p = takeExtension p == ".cabal" + -- | Find a @.cabal@ file in the given directory. + -- TODO: better error handling in stan. + findCabalFileFilePath :: FilePath -> IO (Maybe FilePath) + findCabalFileFilePath dir = do + dirContent <- FilePath.listDirectory dir + let cabalFiles = filter isCabal dirContent + pure $ case cabalFiles of + [] -> Nothing + cabalFile : _ -> Just $ dir FilePath. cabalFile + where + isCabal :: FilePath -> Bool + isCabal p = FilePath.takeExtension p == ".cabal" -getSubdirsRecursive :: FilePath -> IO [FilePath] -getSubdirsRecursive fp = do - all' <- filter nonGenDir <$> listDirectory fp - dirs <- filterM doesDirectoryExist (mkRel <$> all') - case dirs of - [] -> pure [] - ds -> do - -- unsafeInterleaveIO is required here for performance reasons - next <- unsafeInterleaveIO $ foldMapA getSubdirsRecursive ds - pure $ dirs ++ next + getSubdirsRecursiveFilePath :: FilePath -> IO [FilePath] + getSubdirsRecursiveFilePath fp = do + all' <- filter nonGenDir <$> FilePath.listDirectory fp + dirs <- filterM FilePath.doesDirectoryExist (mkRel <$> all') + case dirs of + [] -> pure [] + ds -> do + -- unsafeInterleaveIO is required here for performance reasons + next <- unsafeInterleaveIO $ foldMapA getSubdirsRecursiveFilePath ds + pure $ dirs ++ next + where + nonGenDir :: FilePath -> Bool + nonGenDir d = + d /= "dist" + && d /= "dist-newstyle" + && d /= ".stack-work" + && d /= ".git" + + mkRel :: FilePath -> FilePath + mkRel = (fp FilePath.) + +#else +-- Fix for https://github.com/haskell/haskell-language-server/issues/4515 +findCabalFilesStreaming :: IO [FilePath] +findCabalFilesStreaming = do + setRef <- newIORef S.empty -- stores the directories where we already found 1 cabal file + root <- OsPath.getCurrentDirectory + traverse OsPath.decodeFS =<< + OPS.listContentsRecFold + Nothing -- Depth limit + (\_ _ (OPS.Relative _dirRelPath) (OPS.Basename dirBasename) _symlinkType _consDirToList traverseThisSubdir rest -> + if visitCurrSubdirPred dirBasename -- if this condition is satisfied + then traverseThisSubdir rest -- True -> then this subdir will be traversed + else rest -- False -> else, this subdir will not be traversed + ) -- how to fold this directory and its children, given its path + (\_ _ (OPS.Relative path) (OPS.Basename fileBasename) _ft -> do + let parentDir = OsPath.takeDirectory path + set <- readIORef setRef + if not (S.member parentDir set) && collectPred fileBasename -- if this condition is satisfied + then do + writeIORef setRef $ S.insert parentDir set -- we add the parentDir of this file, to prevent adding more than 1 .cabal file + pure (Just path) -- True -> then this path will be added to the results (because @path@ is already relative, we no longer need @mkRel@) + else pure Nothing -- False -> else, this path wont be added + ) + (Identity root) -- (f a), list of roots to search in where - nonGenDir :: FilePath -> Bool - nonGenDir d = - d /= "dist" - && d /= "dist-newstyle" - && d /= ".stack-work" + visitCurrSubdirPred :: OsPath.OsPath -> Bool + visitCurrSubdirPred d = + d /= [OsPath.osp|dist|] + && d /= [OsPath.osp|dist-newstyle|] + && d /= [OsPath.osp|.stack-work|] + && d /= [OsPath.osp|.git|] - mkRel :: FilePath -> FilePath - mkRel = (fp ) + collectPred :: OsPath.OsPath -> Bool + collectPred p = + OsPath.takeExtension p == [OsPath.osp|.cabal|] +#endif mergeParsedExtensions :: Either ExtensionsError ParsedExtensions diff --git a/src/Stan/Report/Css.hs b/src/Stan/Report/Css.hs --- a/src/Stan/Report/Css.hs +++ b/src/Stan/Report/Css.hs @@ -15,7 +15,7 @@ import Prelude hiding (div, rem, (&), (**)) -import Clay hiding (brown, cols, grid, border, borderRight, borderTop, borderLeft, borderBottom) +import Clay hiding ((%), brown, cols, grid, border, borderRight, borderTop, borderLeft, borderBottom) import qualified Clay import qualified Clay.Media as M diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -12,3 +12,8 @@ - trial-0.0.0.0@sha256:eaefa22bf10b04a9149ef0231cfd5e42ff47534221d4cf4ad3d7653090c54d23,4410 - trial-optparse-applicative-0.0.0.0@sha256:3ca376f1361a3b623a52b8db8e178cdca5f2e6e3954d217b874a9af823ab6c06,2540 - trial-tomland-0.0.0.0@sha256:5dc32bd4003dc84565170e316576eb7a0c1cea3e8b8b3815d5f509b4a40577fd,2541 +- directory-ospath-streaming-0.2.2@sha256:8931b9ce6e63bf6202dc0c992ae3e6f2ad8e7f4b6eb69994ac6d512c6c9c0f77,3410 + +flags: + directory-ospath-streaming: + os-string: false diff --git a/stan.cabal b/stan.cabal --- a/stan.cabal +++ b/stan.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: stan -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Haskell STatic ANalyser description: Stan is a Haskell __ST__atic __AN__alysis CLI tool. @@ -31,6 +31,12 @@ type: git location: https://github.com/kowainik/stan.git +flag directory-ospath-streaming + default: True + manual: False + description: + Whether to use directory-ospath-streaming. Should be false with 9.6 > ghc. + common common-options build-depends: base >= 4.13 && < 4.22 && (< 4.16.3.0 || >= 4.17) -- ^^ .hie files don't contain enough type @@ -143,7 +149,7 @@ , base64 >= 0.4.1 && < 1.1 , blaze-html ^>= 0.9.1 , bytestring >= 0.10 && < 0.13 - , clay >= 0.14 && < 0.16 + , clay >= 0.14 && < 0.17 , colourista >= 0.1 && < 0.3 , containers >= 0.5 && < 0.8 , cryptohash-sha1 ^>= 0.11 @@ -163,6 +169,9 @@ , trial ^>= 0.0.0.0 , trial-optparse-applicative ^>= 0.0.0.0 , trial-tomland ^>= 0.0.0.0 + if flag(directory-ospath-streaming) + build-depends: + directory-ospath-streaming ^>= 0.2 executable stan import: common-options