From 165be573c42b93a51c4fdc5b98c32954a3a84267 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Fri, 13 Nov 2020 00:55:41 +0700 Subject: [PATCH] Ignore source files that are used as `main` when inferring modules (fixes #188) --- src/Hpack/Config.hs | 55 ++++++++++---- src/Hpack/Module.hs | 18 ++++- src/Path.hs | 4 + test/EndToEndSpec.hs | 159 ++++++++++++++++++++++++++++++++++++++- test/Hpack/ModuleSpec.hs | 19 ++++- 5 files changed, 230 insertions(+), 25 deletions(-) diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs index 63deee7e..f5e031ec 100644 --- a/src/Hpack/Config.hs +++ b/src/Hpack/Config.hs @@ -1096,6 +1096,19 @@ toExecutableMap name executables mExecutable = do type GlobalOptions = CommonOptions CSources CxxSources JsSources Empty +executableSectionMainCandidates :: Section ExecutableSection -> [FilePath] +executableSectionMainCandidates sect = case sectionAll sectionSourceDirs sect of + [] -> mains + sourceDirs -> [src main | main <- mains, src <- sourceDirs] + where + mains :: [FilePath] + mains = concatMap sectionMain sect + + sectionMain :: ExecutableSection -> [FilePath] + sectionMain exec = case parseMain <$> executableSectionMain exec of + Just (file, []) -> [file] + _ -> [] + toPackage_ :: MonadIO m => FilePath -> Product GlobalOptions (PackageConfig CSources CxxSources JsSources) -> Warnings m (Package, String) toPackage_ dir (Product g PackageConfig{..}) = do executableMap <- toExecutableMap packageName_ packageConfigExecutables packageConfigExecutable @@ -1111,15 +1124,26 @@ toPackage_ dir (Product g PackageConfig{..}) = do toSections :: (Monad m, Monoid a) => Maybe (Map String (WithCommonOptions CSources CxxSources JsSources a)) -> Warnings m (Map String (Section a)) toSections = maybe (return mempty) (traverse toSect) - toLib = liftIO . toLibrary dir packageName_ - toExecutables = toSections >=> traverse (liftIO . toExecutable dir packageName_) + executableSections <- toSections executableMap + testSections <- toSections packageConfigTests + benchmarkSections <- toSections packageConfigBenchmarks + + let + exclude :: [FilePath] + exclude = concatMap (concatMap executableSectionMainCandidates) [executableSections, testSections, benchmarkSections] + + toLib :: MonadIO m => Section LibrarySection -> Warnings m (Section Library) + toLib = liftIO . toLibrary dir packageName_ exclude + + toExecutables :: MonadIO m => Map String (Section ExecutableSection) -> Warnings m (Map String (Section Executable)) + toExecutables = traverse (liftIO . toExecutable dir packageName_ exclude) mLibrary <- traverse (toSect >=> toLib) packageConfigLibrary internalLibraries <- toSections packageConfigInternalLibraries >>= traverse toLib - executables <- toExecutables executableMap - tests <- toExecutables packageConfigTests - benchmarks <- toExecutables packageConfigBenchmarks + executables <- toExecutables executableSections + tests <- toExecutables testSections + benchmarks <- toExecutables benchmarkSections licenseFileExists <- liftIO $ doesFileExist (dir "LICENSE") @@ -1292,8 +1316,8 @@ getLibraryModules Library{..} = libraryExposedModules ++ libraryOtherModules getExecutableModules :: Executable -> [Module] getExecutableModules Executable{..} = executableOtherModules -listModules :: FilePath -> Section a -> IO [Module] -listModules dir Section{..} = concat <$> mapM (getModules dir) sectionSourceDirs +listModules :: FilePath -> [FilePath] -> Section a -> IO [Module] +listModules dir exclude Section{..} = concat <$> mapM (getModules dir exclude) sectionSourceDirs removeConditionalsThatAreAlwaysFalse :: Section a -> Section a removeConditionalsThatAreAlwaysFalse sect = sect { @@ -1305,19 +1329,20 @@ removeConditionalsThatAreAlwaysFalse sect = sect { inferModules :: FilePath -> String + -> [FilePath] -> (a -> [Module]) -> (b -> [Module]) -> ([Module] -> [Module] -> a -> b) -> ([Module] -> a -> b) -> Section a -> IO (Section b) -inferModules dir packageName_ getMentionedModules getInferredModules fromData fromConditionals = fmap removeConditionalsThatAreAlwaysFalse . traverseSectionAndConditionals +inferModules dir packageName_ exclude getMentionedModules getInferredModules fromData fromConditionals = fmap removeConditionalsThatAreAlwaysFalse . traverseSectionAndConditionals (fromConfigSection fromData [pathsModuleFromPackageName packageName_]) (fromConfigSection (\ [] -> fromConditionals) []) [] where fromConfigSection fromConfig pathsModule_ outerModules sect@Section{sectionData = conf} = do - modules <- listModules dir sect + modules <- listModules dir exclude sect let mentionedModules = concatMap getMentionedModules sect inferableModules = (modules \\ outerModules) \\ mentionedModules @@ -1325,9 +1350,9 @@ inferModules dir packageName_ getMentionedModules getInferredModules fromData fr r = fromConfig pathsModule inferableModules conf return (outerModules ++ getInferredModules r, r) -toLibrary :: FilePath -> String -> Section LibrarySection -> IO (Section Library) -toLibrary dir name = - inferModules dir name getMentionedLibraryModules getLibraryModules fromLibrarySectionTopLevel fromLibrarySectionInConditional +toLibrary :: FilePath -> String -> [FilePath] -> Section LibrarySection -> IO (Section Library) +toLibrary dir name exclude = + inferModules dir name exclude getMentionedLibraryModules getLibraryModules fromLibrarySectionTopLevel fromLibrarySectionInConditional where fromLibrarySectionTopLevel :: [Module] -> [Module] -> LibrarySection -> Library fromLibrarySectionTopLevel pathsModule inferableModules LibrarySection{..} = @@ -1369,9 +1394,9 @@ getMentionedExecutableModules :: ExecutableSection -> [Module] getMentionedExecutableModules (ExecutableSection main otherModules generatedModules)= maybe id (:) (toModule . Path.fromFilePath <$> main) $ fromMaybeList (otherModules <> generatedModules) -toExecutable :: FilePath -> String -> Section ExecutableSection -> IO (Section Executable) -toExecutable dir packageName_ = - inferModules dir packageName_ getMentionedExecutableModules getExecutableModules fromExecutableSection (fromExecutableSection []) +toExecutable :: FilePath -> String -> [FilePath] -> Section ExecutableSection -> IO (Section Executable) +toExecutable dir packageName_ exclude = + inferModules dir packageName_ exclude getMentionedExecutableModules getExecutableModules fromExecutableSection (fromExecutableSection []) . expandMain where fromExecutableSection :: [Module] -> [Module] -> ExecutableSection -> Executable diff --git a/src/Hpack/Module.hs b/src/Hpack/Module.hs index cc849919..d9019448 100644 --- a/src/Hpack/Module.hs +++ b/src/Hpack/Module.hs @@ -11,6 +11,7 @@ module Hpack.Module ( ) where import Data.String +import Data.Maybe import System.FilePath import qualified System.Directory as Directory import Control.Monad @@ -40,8 +41,8 @@ toModule path = case reverse $ Path.components path of [] -> Module "" file : dirs -> Module . intercalate "." . reverse $ dropExtension file : dirs -getModules :: FilePath -> FilePath -> IO [Module] -getModules dir literalSrc = sortModules <$> do +getModules :: FilePath -> [FilePath] -> FilePath -> IO [Module] +getModules dir exclude literalSrc = sortModules <$> do exists <- Directory.doesDirectoryExist (dir literalSrc) if exists then do @@ -59,7 +60,18 @@ getModules dir literalSrc = sortModules <$> do | srcIsProjectRoot = filter (/= "Setup") | otherwise = id - toModules <$> getModuleFilesRecursive canonicalSrc + stripSrc :: Path -> Maybe Path + stripSrc + | srcIsProjectRoot = Just + | otherwise = Path.stripPrefix (Path.fromFilePath literalSrc) + + excludePaths :: [Path] + excludePaths = mapMaybe (stripSrc . Path.fromFilePath) exclude + + shouldExclude :: Path -> Bool + shouldExclude = (`elem` excludePaths) + + toModules . filter (not . shouldExclude) <$> getModuleFilesRecursive canonicalSrc else return [] sortModules :: [Module] -> [Module] diff --git a/src/Path.hs b/src/Path.hs index c6b44bb2..9e09aa40 100644 --- a/src/Path.hs +++ b/src/Path.hs @@ -1,5 +1,6 @@ module Path where +import qualified Data.List as List import System.FilePath import Data.String @@ -23,3 +24,6 @@ instance IsString Path where newtype PathComponent = PathComponent {unPathComponent :: String} deriving Eq + +stripPrefix :: Path -> Path -> Maybe Path +stripPrefix (Path xs) (Path ys) = Path <$> List.stripPrefix xs ys diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs index 227de42b..fb6cc93d 100644 --- a/test/EndToEndSpec.hs +++ b/test/EndToEndSpec.hs @@ -1047,6 +1047,144 @@ spec = around_ (inTempDirectoryNamed "foo") $ do |]) {packageCabalVersion = "3.0"} context "when inferring modules" $ do + context "with source files that are used as `main`" $ do + let rendersTo :: HasCallStack => String -> Package -> Expectation + rendersTo = shouldRenderTo_ (removeDefaultLanguage . removePathsModule) + + it "ignores these source files" $ do + touch "src/Main.hs" + touch "src/A.hs" + touch "src/B.hs" + [i| + library: + source-dirs: src + executable: + main: src/Main.hs + |] `rendersTo` package [i| + library + exposed-modules: + A + B + hs-source-dirs: + src + executable foo + main-is: src/Main.hs + |] + + context "with source-dirs" $ do + it "takes these source-dirs into account when ignoring source files" $ do + touch "test/Doctest.hs" + touch "test/Spec.hs" + touch "test/Spec/FooSpec.hs" + [i| + source-dirs: test + tests: + doctest: + main: Doctest.hs + spec: + main: Spec.hs + |] `rendersTo` package [i| + test-suite doctest + type: exitcode-stdio-1.0 + main-is: Doctest.hs + hs-source-dirs: + test + other-modules: + Spec.FooSpec + Paths_foo + test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + other-modules: + Spec.FooSpec + Paths_foo + |] + + context "with `main` inside conditionals" $ do + it "ignores these source files" $ do + touch "src/Foo.hs" + touch "src/Windows.hs" + touch "src/Linux.hs" + [i| + library: + source-dirs: src + executable: + when: + condition: os(windows) + then: + main: src/Windows.hs + else: + main: src/Linux.hs + |] `rendersTo` package [i| + library + hs-source-dirs: + src + exposed-modules: + Foo + executable foo + if os(windows) + main-is: src/Windows.hs + else + main-is: src/Linux.hs + |] + + context "with source-dirs inside conditionals" $ do + it "takes these source-dirs into account when ignoring source files" $ do + touch "src/Foo.hs" + touch "src/windows/Foo.hs" + touch "src/linux/Foo.hs" + [i| + library: + source-dirs: src + + executable: + main: src/Foo.hs + when: + condition: os(windows) + then: + source-dirs: windows + else: + source-dirs: linux + |] `rendersTo` package [i| + library + hs-source-dirs: + src + exposed-modules: + Foo + executable foo + main-is: src/Foo.hs + if os(windows) + hs-source-dirs: + windows + else + hs-source-dirs: + linux + |] + + context "when `main` is a custom entry point" $ do + it "does not ignore these source files" $ do + touch "src/Foo.x" + touch "src/Foo.hs" + [i| + source-dirs: src + library: {} + executable: + main: Foo.x + |] `rendersTo` package [i| + library + exposed-modules: + Foo + hs-source-dirs: + src + executable foo + hs-source-dirs: + src + main-is: Foo.hs + ghc-options: -main-is Foo.x + |] + context "with a library" $ do it "ignores duplicate source directories" $ do touch "src/Foo.hs" @@ -1685,16 +1823,29 @@ instance Show RenderResult where show (RenderResult warnings output) = unlines (map ("WARNING: " ++) warnings) ++ output shouldRenderTo :: HasCallStack => String -> Package -> Expectation -shouldRenderTo input p = do +shouldRenderTo = shouldRenderTo_ id + +shouldRenderTo_ :: HasCallStack => ([String] -> [String]) -> String -> Package -> Expectation +shouldRenderTo_ modifyOutput input p = do writeFile packageConfig ("name: foo\n" ++ unindent input) let currentDirectory = ".working-directory" createDirectory currentDirectory withCurrentDirectory currentDirectory $ do (warnings, output) <- run ".." (".." packageConfig) expected - RenderResult warnings (dropEmptyLines output) `shouldBe` RenderResult (packageWarnings p) expected + RenderResult warnings (mapLines (modifyOutput . dropEmptyLines) output) `shouldBe` RenderResult (packageWarnings p) expected where - expected = dropEmptyLines (renderPackage p) - dropEmptyLines = unlines . filter (not . null) . lines + expected = mapLines dropEmptyLines (renderPackage p) + dropEmptyLines = filter (not . null) + mapLines f = unlines . f . lines + +removeDefaultLanguage :: [String] -> [String] +removeDefaultLanguage = filter (/= " default-language: Haskell2010") + +removePathsModule :: [String] -> [String] +removePathsModule = \ case + " other-modules:" : " Paths_foo" : xs -> removePathsModule xs + x : xs -> x : removePathsModule xs + [] -> [] shouldWarn :: HasCallStack => String -> [String] -> Expectation shouldWarn input expected = do diff --git a/test/Hpack/ModuleSpec.hs b/test/Hpack/ModuleSpec.hs index b3cb8e87..bd205821 100644 --- a/test/Hpack/ModuleSpec.hs +++ b/test/Hpack/ModuleSpec.hs @@ -12,19 +12,32 @@ spec = do touch (dir "src/Foo.hs") touch (dir "src/Bar/Baz.hs") touch (dir "src/Setup.hs") - getModules dir "src" >>= (`shouldMatchList` ["Foo", "Bar.Baz", "Setup"]) + getModules dir [] "src" >>= (`shouldMatchList` ["Foo", "Bar.Baz", "Setup"]) context "when source directory is '.'" $ do it "ignores Setup" $ \dir -> do touch (dir "Foo.hs") touch (dir "Setup.hs") - getModules dir "." `shouldReturn` ["Foo"] + getModules dir [] "." `shouldReturn` ["Foo"] context "when source directory is './.'" $ do it "ignores Setup" $ \dir -> do touch (dir "Foo.hs") touch (dir "Setup.hs") - getModules dir "./." `shouldReturn` ["Foo"] + getModules dir [] "./." `shouldReturn` ["Foo"] + + context "with a list of paths to exclude" $ do + it "does not return files in that list" $ \dir -> do + touch (dir "src/Foo.hs") + touch (dir "src/Bar.hs") + let exclude = ["src/Foo.hs"] + getModules dir exclude "src" >>= (`shouldMatchList` ["Bar"]) + + it "works for '.'" $ \dir -> do + touch (dir "Foo.hs") + touch (dir "Bar.hs") + let exclude = ["Foo.hs"] + getModules dir exclude "." >>= (`shouldMatchList` ["Bar"]) describe "toModule" $ do it "maps a Path to a Module" $ do