prune-juice 0.6 → 0.7

raw patch · 21 files changed

+908/−166 lines, 21 filesdep +regex-compatdep +text-ansiPVP ok

version bump matches the API change (PVP)

Dependencies added: regex-compat, text-ansi

API changes (from Hackage documentation)

Files

• app/main.hs +64/−18
• cabal.project +1/−0
• prune-juice.cabal +64/−57
• src/Data/Prune/Apply.hs +63/−0
• src/Data/Prune/ApplyStrategy/Safe.hs +99/−0
• src/Data/Prune/ApplyStrategy/Smart.hs +88/−0
• src/Data/Prune/Cabal.hs +31/−16
• src/Data/Prune/Confirm.hs +22/−0
• src/Data/Prune/Dependency.hs +26/−18
• src/Data/Prune/File.hs +3/−1
• src/Data/Prune/ImportParser.hs +4/−29
• src/Data/Prune/Section/Parser.hs +120/−0
• src/Data/Prune/Section/Types.hs +26/−0
• src/Data/Prune/Stack.hs +1/−0
• src/Data/Prune/Types.hs +65/−4
• stack.yaml +2/−2
• test/Data/Prune/ApplyStrategy/SmartSpec.hs +72/−0
• test/Data/Prune/ImportParserSpec.hs +0/−21
• test/Data/Prune/Section/ParserSpec.hs +138/−0
• test/fixtures/test.cabal +15/−0
• test/main.hs +4/−0

@@ -7,20 +7,23 @@   ( LogLevel(LevelDebug, LevelError, LevelInfo), defaultOutput, logInfo, runLoggingT   ) import Control.Monad.State (execStateT, put)-import Data.Foldable (for_, traverse_)+import Data.Foldable (foldrM, for_) import Data.Set (Set)-import Data.Text (Text, pack, unpack)-import Data.Traversable (for)+import Data.Text (Text, pack) import System.Exit (ExitCode(ExitFailure, ExitSuccess), exitWith) import System.FilePath.Posix ((</>)) import System.IO (stdout) import qualified Data.Set as Set import qualified Options.Applicative as Opt +import Data.Prune.Apply (Apply(ApplySafe, ApplySmart), SomeApply(SomeApply), runApply, writeApply) import Data.Prune.Cabal (findCabalFiles, parseCabalFiles, parseCabalProjectFile)+import Data.Prune.Confirm (confirm) import Data.Prune.Dependency (getDependencyByModule) import Data.Prune.ImportParser (getCompilableUsedDependencies)+import Data.Prune.Section.Parser (readCabalSections) import Data.Prune.Stack (parseStackYaml)+import qualified Data.Prune.Confirm as Confirm import qualified Data.Prune.Types as T  data Opts = Opts@@ -31,13 +34,21 @@   , optsPackages :: [Text]   , optsVerbosity :: T.Verbosity   , optsBuildSystem :: Maybe T.BuildSystem+  , optsApply :: Bool+  , optsNoVerify :: Bool+  , optsStrategy :: T.ApplyStrategy   }  defaultIgnoreList :: Set T.DependencyName defaultIgnoreList = Set.fromList   [ T.DependencyName "base" -- ignore base because it's needed for info modules etc+  , T.DependencyName "hedgehog" -- ignore because some packages use hedgehog discovery   , T.DependencyName "hspec" -- ignore because some packages use hspec discovery+  , T.DependencyName "hspec-discover" -- ignore because some packages use hspec discovery   , T.DependencyName "tasty" -- ignore because some packages use tasty discovery+  , T.DependencyName "tasty-hedgehog" -- ignore because some packages use tasty discovery+  , T.DependencyName "tasty-hspec" -- ignore because some packages use tasty discovery+  , T.DependencyName "tasty-hunit" -- ignore because some packages use tasty discovery   ]  verbosityToLogLevel :: T.Verbosity -> Maybe LogLevel@@ -81,11 +92,30 @@         Opt.long "build-system"           <> Opt.metavar "BUILD_SYSTEM"           <> Opt.help ("Build system to use instead of inference (one of " <> show T.allBuildSystems <> ")") ) )+      <*> Opt.switch (+        Opt.long "apply"+          <> Opt.help "Apply changes" )+      <*> Opt.switch (+        Opt.long "no-verify"+          <> Opt.help "Do not ask for verification when applying (implies --apply)" )+      <*> Opt.option (Opt.maybeReader T.parseApplyStrategy) (+        Opt.long "strategy"+          <> Opt.help ("Strategy to use to apply (one of " <> show T.allApplyStrategies <> ")")+          <> Opt.value T.ApplyStrategySmart+          <> Opt.showDefault )  main :: IO () main = do   Opts {..} <- parseArgs +  let shouldApply = T.validateShouldApply (optsApply, optsNoVerify)++  when (shouldApply == T.ShouldApply) $ do+    putStrLn $ Confirm.warn "Applying results ignores package.yaml files"+    putStrLn $ Confirm.warn "In addition, it could result in unexpected changes to cabal files"+    T.unlessM (confirm "Do you want to continue? (Y/n)") $+      exitWith ExitSuccess+   let ignoreList = Set.fromList optsExtraIgnoreList <> if optsNoDefaultIgnore then mempty else defaultIgnoreList       logger ma = runLoggingT ma $ case verbosityToLogLevel optsVerbosity of         Nothing -> \_ _ _ _ -> pure ()@@ -104,21 +134,37 @@     packages <- parseCabalFiles packageDirs ignoreList optsPackages      dependencyByModule <- getDependencyByModule optsProjectRoot buildSystem packages-    flip execStateT ExitSuccess $ for_ packages $ \T.Package {..} -> do+    flip execStateT ExitSuccess $ for_ packages $ \package@T.Package {..} -> do++      apInit <- case optsStrategy of+        T.ApplyStrategySafe -> pure $ SomeApply $ ApplySafe packageFile packageDescription mempty+        T.ApplyStrategySmart -> do+          let onFailure str = do+                liftIO $ putStrLn $ Confirm.err $ "Failed to parse cabal sections for " <> packageFile <> " due to " <> str+                put $ ExitFailure 1+                pure mempty+          sections <- either onFailure pure =<< liftIO (readCabalSections packageFile)+          pure $ SomeApply $ ApplySmart packageFile sections mempty+       let addSelf = if optsNoIgnoreSelf then id else Set.insert (T.DependencyName packageName)-      baseUsedDependencies <- fmap mconcat . for packageCompilables $ \compilable@T.Compilable {..} -> do-        usedDependencies <- addSelf <$> getCompilableUsedDependencies dependencyByModule compilable-        let (baseUsedDependencies, otherUsedDependencies) = Set.partition (flip Set.member packageBaseDependencies) usedDependencies-            otherUnusedDependencies = Set.difference compilableDependencies otherUsedDependencies-        unless (Set.null otherUnusedDependencies) $ do-          liftIO . putStrLn . unpack $ "Some unused dependencies for " <> pack (show compilableType) <> " " <> T.unCompilableName compilableName <> " in package " <> packageName-          traverse_ (liftIO . putStrLn . unpack . ("  " <>) . T.unDependencyName) $ Set.toList otherUnusedDependencies-          put $ ExitFailure 1-        pure baseUsedDependencies-      let baseUnusedDependencies = Set.difference packageBaseDependencies baseUsedDependencies-      unless (Set.null baseUnusedDependencies) $ do-        liftIO . putStrLn . unpack $ "Some unused base dependencies for package " <> packageName-        liftIO . traverse_ (putStrLn . unpack . ("  " <>) . T.unDependencyName) $ Set.toList baseUnusedDependencies-        put $ ExitFailure 1+          runCompilable compilable@T.Compilable {..} (oldShouldFail, oldUsed, oldStrip) = do+            usedDependencies <- addSelf <$> getCompilableUsedDependencies dependencyByModule compilable+            let (baseUsedDependencies, otherUsedDependencies) = Set.partition (flip Set.member packageBaseDependencies) usedDependencies+                otherUnusedDependencies = Set.difference compilableDependencies otherUsedDependencies+            case Set.null otherUnusedDependencies of+              True -> pure (oldShouldFail, baseUsedDependencies <> oldUsed, oldStrip)+              False -> do+                (shouldFail, strip) <- liftIO $ runApply oldStrip package otherUnusedDependencies (Just compilable) shouldApply+                pure (shouldFail || oldShouldFail, baseUsedDependencies <> oldUsed, strip)+      (targetsShouldFail, targetsUsedDependencies, targetsStrip) <- foldrM runCompilable (False, mempty, apInit) packageCompilables++      let baseUnusedDependencies = Set.difference packageBaseDependencies targetsUsedDependencies+      (finalShouldFail, stripFinal) <- case Set.null baseUnusedDependencies of+        True -> pure (False, targetsStrip)+        False -> liftIO $ runApply targetsStrip package baseUnusedDependencies Nothing shouldApply++      when (targetsShouldFail || finalShouldFail) $ put $ ExitFailure 1+      unless (shouldApply == T.ShouldNotApply) $+        liftIO $ writeApply stripFinal    exitWith code

@@ -1,1 +1,2 @@ packages: ./*.cabal+constraints: cabal-install-parsers == 0.4

@@ -1,13 +1,6 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.33.0.------ see: https://github.com/sol/hpack------ hash: 93117bc7273e5f6aa8627881ccd3fa5e2d539f8e2ee55d15800a5a118b3f1346-+cabal-version:  3.0 name:           prune-juice-version:        0.6+version:        0.7 synopsis:       Prune unused Haskell dependencies description:    Prune unused Haskell dependencies - see README at <https://github.com/dfithian/prune-juice#readme> category:       Development@@ -23,25 +16,50 @@     cabal.project     prune-juice.cabal     test/fixtures/ghc-pkg.txt+    test/fixtures/test.cabal  source-repository head   type: git   location: https://github.com/dfithian/prune-juice -library-  exposed-modules:-      Data.Prune.Cabal-      Data.Prune.Dependency-      Data.Prune.File-      Data.Prune.ImportParser-      Data.Prune.Stack-      Data.Prune.Types-  other-modules:-      Paths_prune_juice-  hs-source-dirs:-      src-  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric DerivingStrategies DerivingVia EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns+common ghc-options   ghc-options: -Wall -fwarn-tabs -fwarn-redundant-constraints -Wincomplete-uni-patterns -eventlog++common ghc-exe-options+  ghc-options: -Wall -fwarn-tabs -fwarn-redundant-constraints -Wincomplete-uni-patterns -eventlog -threaded -rtsopts "-with-rtsopts=-N -T"++common options+  default-extensions:+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveDataTypeable+      DeriveGeneric+      DerivingStrategies+      DerivingVia+      EmptyDataDecls+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      NoImplicitPrelude+      NoMonomorphismRestriction+      OverloadedStrings+      QuasiQuotes+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeOperators+      ViewPatterns   build-depends:       Cabal     , aeson@@ -55,66 +73,55 @@     , monad-logger     , mtl     , process+    , regex-compat     , text+    , text-ansi     , yaml   default-language: Haskell2010 +library+  import: options, ghc-options+  exposed-modules:+      Data.Prune.Apply+      Data.Prune.Cabal+      Data.Prune.ApplyStrategy.Safe+      Data.Prune.ApplyStrategy.Smart+      Data.Prune.Confirm+      Data.Prune.Dependency+      Data.Prune.File+      Data.Prune.ImportParser+      Data.Prune.Section.Parser+      Data.Prune.Section.Types+      Data.Prune.Stack+      Data.Prune.Types+  hs-source-dirs:+      src+ executable prune-juice+  import: options, ghc-exe-options   main-is: main.hs-  other-modules:-      Paths_prune_juice   hs-source-dirs:       app-  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric DerivingStrategies DerivingVia EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns   ghc-options: -Wall -fwarn-tabs -fwarn-redundant-constraints -Wincomplete-uni-patterns -eventlog   build-depends:-      Cabal-    , aeson-    , base <5.0-    , bytestring-    , cabal-install-parsers-    , containers-    , directory-    , filepath-    , megaparsec-    , monad-logger-    , mtl     , optparse-applicative-    , process     , prune-juice-    , text-    , yaml-  default-language: Haskell2010  test-suite test+  import: options, ghc-exe-options   type: exitcode-stdio-1.0   main-is: main.hs   other-modules:+      Data.Prune.ApplyStrategy.SmartSpec       Data.Prune.CabalSpec       Data.Prune.DependencySpec       Data.Prune.ImportParserSpec-      Paths_prune_juice+      Data.Prune.Section.ParserSpec   hs-source-dirs:       test-  default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveGeneric DerivingStrategies DerivingVia EmptyDataDecls FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns   ghc-options: -Wall -fwarn-tabs -fwarn-redundant-constraints -Wincomplete-uni-patterns -eventlog   build-depends:-      Cabal-    , aeson-    , base <5.0-    , bytestring-    , cabal-install-parsers-    , containers-    , directory     , file-embed     , file-path-th-    , filepath     , hspec-    , megaparsec-    , monad-logger-    , mtl-    , process     , prune-juice-    , text-    , yaml-  default-language: Haskell2010

@@ -0,0 +1,63 @@+-- |Description: Apply changes according to the provided 'T.ApplyStrategy'.+module Data.Prune.Apply where++import Prelude++import Data.Foldable (traverse_)+import Data.Monoid (Endo(Endo), appEndo)+import Data.Set (Set)+import Data.Text (pack, unpack)+import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription)+import qualified Data.Set as Set++import Data.Prune.ApplyStrategy.Safe (stripGenericPackageDescription)+import Data.Prune.ApplyStrategy.Smart (stripSections)+import Data.Prune.Confirm (confirm)+import Data.Prune.Section.Parser (writeCabalSections)+import Distribution.Types.GenericPackageDescription (GenericPackageDescription)+import qualified Data.Prune.Confirm as Confirm+import qualified Data.Prune.Section.Types as T+import qualified Data.Prune.Types as T++-- |Continuation GADT for applying changes to a cabal file.+data Apply (a :: T.ApplyStrategy) where+  ApplySafe :: FilePath -> GenericPackageDescription -> Endo GenericPackageDescription -> Apply 'T.ApplyStrategySafe+  ApplySmart :: FilePath -> [T.Section] -> Endo [T.Section] -> Apply 'T.ApplyStrategySmart++-- |Wrap 'Apply' in a data type so that it can be passed to functions without escaping the inner type.+data SomeApply = forall (a :: T.ApplyStrategy). SomeApply { unSomeApply :: Apply a }++-- |Iterate on a cabal file by pruning one target at a time. Return whether the command-line call to @prune-juice@ should fail.+runApply :: SomeApply -> T.Package -> Set T.DependencyName -> Maybe T.Compilable -> T.ShouldApply -> IO (Bool, SomeApply)+runApply (SomeApply ap) T.Package {..} dependencies compilableMay = \case+  T.ShouldNotApply -> do+    printDependencies+    pure (True, applyNoop)+  T.ShouldApply -> do+    printDependencies+    confirm "Apply these changes? (Y/n)" >>= \case+      False -> pure (False, applyNoop)+      True -> pure (False, applyOnce)+  T.ShouldApplyNoVerify -> do+    printDependencies+    pure (False, applyOnce)+  where+    printDependencies = case compilableMay of+      Nothing -> do+        putStrLn . Confirm.warn . unpack $ "Some unused base dependencies for package " <> packageName+        traverse_ (putStrLn . unpack . ("  " <>) . T.unDependencyName) $ Set.toList dependencies+      Just T.Compilable {..} -> do+        putStrLn . Confirm.warn . unpack $ "Some unused dependencies for " <> pack (show compilableType) <> " " <> T.unCompilableName compilableName <> " in package " <> packageName+        traverse_ (putStrLn . unpack . ("  " <>) . T.unDependencyName) $ Set.toList dependencies+    applyNoop = case ap of+      ApplySafe x y z -> SomeApply $ ApplySafe x y z+      ApplySmart x y z -> SomeApply $ ApplySmart x y z+    applyOnce = case ap of+      ApplySafe x y z -> SomeApply $ ApplySafe x y $ z <> Endo (\w -> stripGenericPackageDescription w dependencies compilableMay)+      ApplySmart x y z -> SomeApply $ ApplySmart x y $ z <> Endo (\w -> stripSections w dependencies compilableMay)++-- |Write the series of changes to the cabal file.+writeApply :: SomeApply -> IO ()+writeApply (SomeApply ap) = case ap of+  ApplySafe fp description endo -> writeGenericPackageDescription fp (appEndo endo description)+  ApplySmart fp parsed endo -> writeCabalSections fp (appEndo endo parsed)

@@ -0,0 +1,99 @@+-- |Description: Apply @prune-juice@ to cabal files safely, with the understanding that the file formatting will change.+module Data.Prune.ApplyStrategy.Safe where++import Prelude++import Data.Set (Set)+import Distribution.Types.Benchmark (Benchmark)+import Distribution.Types.BuildInfo (BuildInfo)+import Distribution.Types.CondTree (CondTree)+import Distribution.Types.Dependency (Dependency)+import Distribution.Types.Executable (Executable)+import Distribution.Types.GenericPackageDescription (GenericPackageDescription)+import Distribution.Types.Library (Library)+import Distribution.Types.TestSuite (TestSuite)+import Distribution.Types.UnqualComponentName (UnqualComponentName)+import qualified Data.Set as Set+import qualified Distribution.Types.Benchmark as Benchmark+import qualified Distribution.Types.BuildInfo as BuildInfo+import qualified Distribution.Types.CondTree as CondTree+import qualified Distribution.Types.Executable as Executable+import qualified Distribution.Types.GenericPackageDescription as GenericPackageDescription+import qualified Distribution.Types.Library as Library+import qualified Distribution.Types.TestSuite as TestSuite++import qualified Data.Prune.Types as T++-- |Filter out dependencies.+stripDependencies :: Set T.DependencyName -> [Dependency] -> [Dependency]+stripDependencies dependencies = foldr go mempty+  where+    go next accum = case Set.member (T.mkDependencyName next) dependencies of+      True -> accum+      False -> next:accum++-- |Strip dependencies from a single target.+stripBuildInfo :: Set T.DependencyName -> BuildInfo -> BuildInfo+stripBuildInfo dependencies buildInfo = buildInfo+  { BuildInfo.targetBuildDepends = stripDependencies dependencies (BuildInfo.targetBuildDepends buildInfo)+  }++-- |Strip dependencies from a library.+stripLibrary :: Set T.DependencyName -> Library -> Library+stripLibrary dependencies lib = lib+  { Library.libBuildInfo = stripBuildInfo dependencies (Library.libBuildInfo lib)+  }++-- |Strip dependencies from an executable.+stripExecutable :: Set T.DependencyName -> Executable -> Executable+stripExecutable dependencies exe = exe+  { Executable.buildInfo = stripBuildInfo dependencies (Executable.buildInfo exe)+  }++-- |Strip dependencies from a test suite.+stripTestSuite :: Set T.DependencyName -> TestSuite -> TestSuite+stripTestSuite dependencies test = test+  { TestSuite.testBuildInfo = stripBuildInfo dependencies (TestSuite.testBuildInfo test)+  }++-- |Strip dependencies from a benchmark.+stripBenchmark :: Set T.DependencyName -> Benchmark -> Benchmark+stripBenchmark dependencies bench = bench+  { Benchmark.benchmarkBuildInfo = stripBuildInfo dependencies (Benchmark.benchmarkBuildInfo bench)+  }++-- |Strip dependencies from a single target.+stripCondTree :: (b -> b) -> CondTree a [Dependency] b -> CondTree a [Dependency] b+stripCondTree f condTree = condTree+  { CondTree.condTreeData = f (CondTree.condTreeData condTree)+  }++-- |Strip dependencies from multiple targets.+stripCondTrees :: (b -> b) -> T.CompilableName -> [(UnqualComponentName, CondTree a [Dependency] b)] -> [(UnqualComponentName, CondTree a [Dependency] b)]+stripCondTrees f compilableName = foldr go mempty+  where+    go next accum = case compilableName == T.mkCompilableName (fst next) of+      True -> (fst next, stripCondTree f (snd next)):accum+      False -> next:accum++-- |Strip dependencies from a package.+stripGenericPackageDescription :: GenericPackageDescription -> Set T.DependencyName -> Maybe T.Compilable -> GenericPackageDescription+stripGenericPackageDescription genericPackageDescription dependencies = \case+  Nothing -> case GenericPackageDescription.condLibrary genericPackageDescription of+    Nothing -> genericPackageDescription+    Just lib -> genericPackageDescription+      { GenericPackageDescription.condLibrary = Just (stripCondTree (stripLibrary dependencies) lib)+      }+  Just T.Compilable {..} -> case compilableType of+    T.CompilableTypeLibrary -> genericPackageDescription+      { GenericPackageDescription.condSubLibraries = stripCondTrees (stripLibrary dependencies) compilableName (GenericPackageDescription.condSubLibraries genericPackageDescription)+      }+    T.CompilableTypeExecutable -> genericPackageDescription+      { GenericPackageDescription.condExecutables = stripCondTrees (stripExecutable dependencies) compilableName (GenericPackageDescription.condExecutables genericPackageDescription)+      }+    T.CompilableTypeTest -> genericPackageDescription+      { GenericPackageDescription.condTestSuites = stripCondTrees (stripTestSuite dependencies) compilableName (GenericPackageDescription.condTestSuites genericPackageDescription)+      }+    T.CompilableTypeBenchmark -> genericPackageDescription+      { GenericPackageDescription.condBenchmarks = stripCondTrees (stripBenchmark dependencies) compilableName (GenericPackageDescription.condBenchmarks genericPackageDescription)+      }

@@ -0,0 +1,88 @@+-- |Description: Apply @prune-juice@ to cabal files, attempting to overwrite /only/ the dependencies portions.+module Data.Prune.ApplyStrategy.Smart where++import Prelude++import Control.Arrow (second)+import Data.Function (fix)+import Data.List (intercalate)+import Data.Maybe (mapMaybe)+import Data.Set (Set)+import Data.Text (pack, splitOn, unpack)+import Text.Regex (Regex, matchRegex, mkRegex)+import qualified Data.Set as Set++import qualified Data.Prune.Section.Types as T+import qualified Data.Prune.Types as T++-- |A type for which target we're trying to strip.+data StripTarget+  = StripTargetBaseLibrary+  -- ^ The base library+  | StripTargetCompilable T.Compilable+  -- ^ Any @library@, @executable@, @test-suite@, @benchmark@, etc stanza.+  | StripTargetCommonStanza (Set T.CommonName)+  -- ^ Any @common@ stanza matching the set.++-- |Regex for dependency names like @base <5.0@.+dependencyNameRegex :: Regex+dependencyNameRegex = mkRegex "^ *([a-zA-Z0-9\\-]+).*$"++-- |Parse a dependency name from a string.+matchDependencyName :: String -> Maybe T.DependencyName+matchDependencyName str = Just . T.DependencyName . pack =<< T.headMay =<< matchRegex dependencyNameRegex str++-- |Strip matching dependencies from a single line.+stripOneBuildDepends :: String -> Set T.DependencyName -> Maybe String+stripOneBuildDepends input dependencies =+  let output = intercalate "," . mapMaybe go . fmap unpack . splitOn "," . pack $ input+  in case not (null output) && all ((==) ' ') output of+      True -> Nothing+      False -> Just output+  where+    go x = case matchDependencyName x of+      Nothing -> Just x+      Just dep -> case Set.member dep dependencies of+        True -> Nothing+        False -> Just x++-- |Strip matching dependencies from a @build-depends@ section.+stripBuildDepends :: [String] -> Set T.DependencyName -> [String]+stripBuildDepends buildDepends dependencies = mapMaybe (\x -> stripOneBuildDepends x dependencies) buildDepends++-- |Strip matching dependencies from a nested section.+stripNestedSection :: T.NestedSection -> Set T.DependencyName -> (T.NestedSection, Set T.CommonName)+stripNestedSection nested dependencies = case nested of+  T.BuildDependsNestedSection numSpaces buildDepends -> (T.BuildDependsNestedSection numSpaces (stripBuildDepends buildDepends dependencies), mempty)+  T.ImportNestedSection numSpaces imports ->+    let common = Set.fromList $ T.CommonName <$> mconcat (fmap (splitOn "," . pack) (words (unwords imports)))+    in (T.ImportNestedSection numSpaces imports, common)+  other -> (other, mempty)++-- |Strip matching dependencies from many nested sections.+stripNestedSections :: [T.NestedSection] -> Set T.DependencyName -> ([T.NestedSection], Set T.CommonName)+stripNestedSections nested dependencies = second mconcat $ unzip $ fmap (\x -> stripNestedSection x dependencies) nested++-- |Strip dependencies from any top-level section.+stripSection :: T.Section -> Set T.DependencyName -> StripTarget -> (T.Section, Set T.CommonName)+stripSection section dependencies target = case (section, target) of+  (T.TargetSection T.CompilableTypeLibrary Nothing nested, StripTargetBaseLibrary) ->+    let (newNested, common) = stripNestedSections nested dependencies+    in (T.TargetSection T.CompilableTypeLibrary Nothing newNested, common)+  (T.TargetSection typ (Just name) nested, StripTargetCompilable T.Compilable {..}) | typ == compilableType && name == compilableName ->+    let (newNested, common) = stripNestedSections nested dependencies+    in (T.TargetSection typ (Just name) newNested, common)+  (T.CommonSection name nested, StripTargetCommonStanza common) | Set.member name common ->+    let (newNested, newCommon) = stripNestedSections nested dependencies+    in (T.CommonSection name newNested, newCommon)+  (other, _) -> (other, mempty)++-- |Strip dependencies from many top-level sections.+stripSections :: [T.Section] -> Set T.DependencyName -> Maybe T.Compilable -> [T.Section]+stripSections sections dependencies compilableMay =+  let run target = second mconcat . unzip . fmap (\x -> stripSection x dependencies target)+      firstTarget = maybe StripTargetBaseLibrary StripTargetCompilable compilableMay+      firstPass = run firstTarget sections+  in flip fix firstPass $ \recur -> \case+       (final, none) | Set.null none -> final+       (next, common) -> recur (run (StripTargetCommonStanza common) next)

@@ -1,3 +1,5 @@+-- |Description: Utilities for extracting cabal info to the canonical types in "Data.Prune.Types".+{-# LANGUAGE CPP #-} module Data.Prune.Cabal where  import Prelude@@ -18,6 +20,7 @@ import Distribution.Types.Executable (Executable) import Distribution.Types.Library (Library) import Distribution.Types.TestSuite (TestSuite)+import Distribution.Types.UnqualComponentName (UnqualComponentName) import System.Directory (listDirectory) import System.FilePath.Posix ((</>), isExtensionOf, takeDirectory, takeFileName) import qualified Data.Set as Set@@ -25,7 +28,6 @@ import qualified Distribution.Types.BenchmarkInterface as BenchmarkInterface import qualified Distribution.Types.BuildInfo as BuildInfo import qualified Distribution.Types.CondTree as CondTree-import qualified Distribution.Types.Dependency as Dependency import qualified Distribution.Types.Executable as Executable import qualified Distribution.Types.GenericPackageDescription as GenericPackageDescription import qualified Distribution.Types.Library as Library@@ -35,13 +37,16 @@ import qualified Distribution.Types.TestSuite as TestSuite import qualified Distribution.Types.TestSuiteInterface as TestSuiteInterface import qualified Distribution.Types.UnqualComponentName as UnqualComponentName+#if MIN_VERSION_Cabal(3,6,0)+import qualified Distribution.Utils.Path as UtilsPath+#endif import qualified Distribution.Verbosity as Verbosity  import qualified Data.Prune.Types as T  -- |Get the dependencies for a thing to compile. getDependencyNames :: Set T.DependencyName -> [Dependency] -> Set T.DependencyName-getDependencyNames ignores = flip Set.difference ignores . Set.fromList . map (T.DependencyName . pack.  PackageName.unPackageName . Dependency.depPkgName)+getDependencyNames ignores = flip Set.difference ignores . Set.fromList . map T.mkDependencyName  -- |Get the Haskell source files to compile. getSourceFiles :: FilePath -> Maybe FilePath -> BuildInfo -> IO (Set FilePath)@@ -49,28 +54,34 @@   let hsSourceDirs = BuildInfo.hsSourceDirs buildInfo   allFiles <- case null hsSourceDirs of     True -> Set.filter (flip elem (takeFileName <$> maybeToList mainMay) . takeFileName) <$> listFilesRecursive fp-    False -> fmap mconcat . for hsSourceDirs $ \dir -> listFilesRecursive $ fp </> dir+    False -> fmap mconcat . for hsSourceDirs $ \dir -> listFilesRecursive $ fp </> dirToPath dir   pure $ Set.filter (\fp2 -> any ($ fp2) [isExtensionOf "hs", isExtensionOf "lhs", isExtensionOf "hs-boot"]) allFiles+  where+#if MIN_VERSION_Cabal(3,6,0)+    dirToPath = UtilsPath.getSymbolicPath+#else+    dirToPath = id+#endif  -- |Parse a library to compile.-getLibraryCompilable :: FilePath -> Set T.DependencyName -> Text -> CondTree a [Dependency] Library -> IO T.Compilable+getLibraryCompilable :: FilePath -> Set T.DependencyName -> UnqualComponentName -> CondTree a [Dependency] Library -> IO T.Compilable getLibraryCompilable fp ignores name tree = do-  let compilableName = T.CompilableName name+  let compilableName = T.mkCompilableName name   sourceFiles <- getSourceFiles fp Nothing . Library.libBuildInfo . CondTree.condTreeData $ tree   pure $ T.Compilable compilableName T.CompilableTypeLibrary (getDependencyNames ignores $ CondTree.condTreeConstraints tree) sourceFiles  -- |Parse an executable to compile.-getExecutableCompilable :: FilePath -> Set T.DependencyName -> Text -> CondTree a [Dependency] Executable -> IO T.Compilable+getExecutableCompilable :: FilePath -> Set T.DependencyName -> UnqualComponentName -> CondTree a [Dependency] Executable -> IO T.Compilable getExecutableCompilable fp ignores name tree = do-  let compilableName = T.CompilableName name+  let compilableName = T.mkCompilableName name       mainMay = Just . Executable.modulePath . CondTree.condTreeData $ tree   sourceFiles <- getSourceFiles fp mainMay . Executable.buildInfo . CondTree.condTreeData $ tree   pure $ T.Compilable compilableName T.CompilableTypeExecutable (getDependencyNames ignores $ CondTree.condTreeConstraints tree) sourceFiles  -- |Parse a test to compile.-getTestCompilable :: FilePath -> Set T.DependencyName -> Text -> CondTree a [Dependency] TestSuite -> IO T.Compilable+getTestCompilable :: FilePath -> Set T.DependencyName -> UnqualComponentName -> CondTree a [Dependency] TestSuite -> IO T.Compilable getTestCompilable fp ignores name tree = do-  let compilableName = T.CompilableName name+  let compilableName = T.mkCompilableName name       mainMay = case TestSuite.testInterface $ CondTree.condTreeData tree of         TestSuiteInterface.TestSuiteExeV10 _ exe -> Just exe         TestSuiteInterface.TestSuiteLibV09 _ _ -> Nothing@@ -79,9 +90,9 @@   pure $ T.Compilable compilableName T.CompilableTypeTest (getDependencyNames ignores $ CondTree.condTreeConstraints tree) sourceFiles  -- |Parse a benchmark to compile.-getBenchmarkCompilable :: FilePath -> Set T.DependencyName -> Text -> CondTree a [Dependency] Benchmark -> IO T.Compilable+getBenchmarkCompilable :: FilePath -> Set T.DependencyName -> UnqualComponentName -> CondTree a [Dependency] Benchmark -> IO T.Compilable getBenchmarkCompilable fp ignores name tree = do-  let compilableName = T.CompilableName name+  let compilableName = T.mkCompilableName name       mainMay = case Benchmark.benchmarkInterface $ CondTree.condTreeData tree of         BenchmarkInterface.BenchmarkExeV10 _ exe -> Just exe         BenchmarkInterface.BenchmarkUnsupported _ -> Nothing@@ -108,14 +119,17 @@             [] -> mempty             x:xs -> foldr Set.intersection x xs       packageDescription = GenericPackageDescription.packageDescription genericPackageDescription+      unqualComponentName = UnqualComponentName.mkUnqualComponentName . PackageName.unPackageName . PackageId.pkgName . PackageDescription.package $ packageDescription       packageName = pack . PackageName.unPackageName . PackageId.pkgName . PackageDescription.package $ packageDescription-  libraries         <- traverse (getLibraryCompilable    fp (ignores <> baseDependencies) packageName) . maybeToList . GenericPackageDescription.condLibrary $ genericPackageDescription-  internalLibraries <- traverse (getLibraryCompilable    fp (ignores <> baseDependencies) <$> pack . UnqualComponentName.unUnqualComponentName . fst <*> snd) . GenericPackageDescription.condSubLibraries $ genericPackageDescription-  executables       <- traverse (getExecutableCompilable fp (ignores <> baseDependencies) <$> pack . UnqualComponentName.unUnqualComponentName . fst <*> snd) . GenericPackageDescription.condExecutables $ genericPackageDescription-  tests             <- traverse (getTestCompilable       fp (ignores <> baseDependencies) <$> pack . UnqualComponentName.unUnqualComponentName . fst <*> snd) . GenericPackageDescription.condTestSuites $ genericPackageDescription-  benchmarks        <- traverse (getBenchmarkCompilable  fp (ignores <> baseDependencies) <$> pack . UnqualComponentName.unUnqualComponentName . fst <*> snd) . GenericPackageDescription.condBenchmarks $ genericPackageDescription+  libraries         <- traverse (getLibraryCompilable    fp (ignores <> baseDependencies) unqualComponentName) . maybeToList . GenericPackageDescription.condLibrary $ genericPackageDescription+  internalLibraries <- traverse (getLibraryCompilable    fp (ignores <> baseDependencies) <$> fst <*> snd) . GenericPackageDescription.condSubLibraries $ genericPackageDescription+  executables       <- traverse (getExecutableCompilable fp (ignores <> baseDependencies) <$> fst <*> snd) . GenericPackageDescription.condExecutables $ genericPackageDescription+  tests             <- traverse (getTestCompilable       fp (ignores <> baseDependencies) <$> fst <*> snd) . GenericPackageDescription.condTestSuites $ genericPackageDescription+  benchmarks        <- traverse (getBenchmarkCompilable  fp (ignores <> baseDependencies) <$> fst <*> snd) . GenericPackageDescription.condBenchmarks $ genericPackageDescription   pure T.Package     { packageName = packageName+    , packageFile = fp </> cabalFile+    , packageDescription = genericPackageDescription     , packageBaseDependencies = baseDependencies     , packageCompilables = libraries <> internalLibraries <> executables <> tests <> benchmarks     }@@ -128,6 +142,7 @@   $logDebug $ "Parsed packages " <> pack (show toReturn)   pure toReturn +-- |Find cabal files under the project root. findCabalFiles :: FilePath -> IO (T.BuildSystem, [FilePath]) findCabalFiles projectRoot = do   (T.Cabal,) . map takeDirectory . filter (isExtensionOf "cabal") . Set.toList <$> listFilesRecursive projectRoot

@@ -0,0 +1,22 @@+-- |Description: IO utilities for user interaction.+module Data.Prune.Confirm where++import Prelude++import Data.Char (toLower)+import Data.Text (pack, unpack)+import qualified Data.Text.ANSI as Text.ANSI++err, warn, bold :: String -> String+err = unpack . Text.ANSI.bold . Text.ANSI.red . pack+warn = unpack . Text.ANSI.bold . Text.ANSI.yellow . pack+bold = unpack . Text.ANSI.bold . pack++-- |Require the user to confirm before continuing.+confirm :: String -> IO Bool+confirm msg = do+  putStrLn $ bold msg+  getLine >>= \case+    yes | fmap toLower yes `elem` ["y", "yes"] -> pure True+    no | fmap toLower no `elem` ["n", "no"] -> pure False+    _ -> putStrLn (bold "Please answer Y/n") >> confirm msg

@@ -1,4 +1,4 @@--- |Load dependencies for a project using `ghc-pkg`.+-- |Description: Load dependencies for a project using @ghc-pkg@. module Data.Prune.Dependency where  import Prelude hiding (unwords, words)@@ -11,32 +11,39 @@ import Data.Map (Map) import Data.Maybe (catMaybes) import Data.Set (Set)-import Data.Text (Text, pack, splitOn, strip, unpack, unwords, words)+import Data.Text (Text, pack, splitOn, strip, unpack, words)+import Data.Text.Encoding (encodeUtf8)+import Distribution.InstalledPackageInfo (parseInstalledPackageInfo) import System.Directory (doesDirectoryExist) import System.FilePath.Posix ((</>)) import System.Process (readProcess) import qualified Data.Map as Map import qualified Data.Set as Set+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+import qualified Distribution.ModuleName as ModuleName+import qualified Distribution.Types.ExposedModule as ExposedModule+import qualified Distribution.Types.PackageId as PackageId+import qualified Distribution.Types.PackageName as PackageName -import Data.Prune.ImportParser (parseDependencyName, parseExposedModules) import qualified Data.Prune.Types as T +-- |Parse a single package output from @ghc-pkg@. parsePkg :: (MonadLogger m) => Text -> m (Maybe (T.DependencyName, Set T.ModuleName))-parsePkg s = do-  let dependencyNameInput = unpack . unwords . dropWhile (not . (==) "name:") . words . strip $ s-      moduleNamesInput = unpack . unwords . dropWhile (not . (==) "exposed-modules:") . words . strip $ s-  dependencyNameMay <- case parseDependencyName dependencyNameInput of-    Left err -> do-      $logError $ "Failed to parse dependency name due to " <> pack (show err) <> "; original input " <> pack dependencyNameInput-      pure Nothing-    Right x -> pure x-  moduleNames <- case parseExposedModules moduleNamesInput of-    Left err -> do-      $logError $ "Failed to parse module names due to " <> pack (show err) <> "; original input " <> pack moduleNamesInput-      pure mempty-    Right x -> pure x-  pure $ (, moduleNames) <$> dependencyNameMay+parsePkg s = case parseInstalledPackageInfo (encodeUtf8 s) of+  Left err -> do+    $logError $ "Failed to parse package due to " <> pack (show err) <> "; original input " <> s+    pure Nothing+  Right (_, installedPackageInfo) ->+    let packageName = PackageName.unPackageName . PackageId.pkgName . InstalledPackageInfo.sourcePackageId $ installedPackageInfo+        moduleNames = Set.fromList . fmap (T.ModuleName . pack . intercalate "." . ModuleName.components . ExposedModule.exposedName) . InstalledPackageInfo.exposedModules $ installedPackageInfo+    in case null packageName of+      True -> do+        $logError $ "Failed to parse package because the name was missing; original input " <> s+        pure Nothing+      False ->+        pure $ Just (T.DependencyName $ pack packageName, moduleNames) +-- |Get the combined dump for the locations cabal uses for @ghc-pkg@. getCabalRawGhcPkgs :: FilePath -> IO String getCabalRawGhcPkgs projectRoot = do   cabalConfig <- readConfig@@ -53,10 +60,11 @@     False -> pure Nothing   pure . intercalate "\n---\n" . catMaybes $ [Just defaultPkgs, Just cabalPkgs, localPkgs] +-- |Get the combined dump for the locations stack uses for @ghc-pkg@. getStackRawGhcPkgs :: IO String getStackRawGhcPkgs = readProcess "stack" ["exec", "ghc-pkg", "dump"] "" --- |For the dependencies listed in the specified packages, load `ghc-pkg` and inspect the `exposed-modules` field.+-- |For the dependencies listed in the specified packages, load @ghc-pkg@ and inspect the @exposed-modules@ field. -- Return a map of module to dependency name. getDependencyByModule :: (MonadIO m, MonadLogger m) => FilePath -> T.BuildSystem -> [T.Package] -> m (Map T.ModuleName (Set T.DependencyName)) getDependencyByModule projectRoot buildSystem packages = do

@@ -1,7 +1,9 @@+-- |Description: File utilities. module Data.Prune.File where  import Prelude +import Control.Applicative ((<|>)) import Data.Set (Set) import Data.Traversable (for) import System.Directory (doesDirectoryExist, listDirectory, pathIsSymbolicLink)@@ -11,7 +13,7 @@ -- |Recursively list files in a directory, ignoring symlinks. listFilesRecursive :: FilePath -> IO (Set FilePath) listFilesRecursive dir = do-  dirs <- listDirectory dir+  dirs <- listDirectory dir <|> pure mempty   fmap mconcat . for dirs $ \case     -- don't include "hidden" directories, i.e. those that start with a '.'     '.' : _ -> pure mempty

@@ -1,9 +1,9 @@--- |Utilities for parsing imports from Haskell source files.+-- |Description: Utilities for parsing imports from Haskell source files. module Data.Prune.ImportParser where  import Prelude -import Control.Applicative ((<|>), optional, some)+import Control.Applicative ((<|>), optional) import Control.Arrow (left) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO)@@ -15,8 +15,8 @@ import Data.Text (pack) import Data.Traversable (for) import Data.Void (Void)-import Text.Megaparsec (Parsec, between, oneOf, parse)-import Text.Megaparsec.Char (alphaNumChar, char, space, string, symbolChar, upperChar)+import Text.Megaparsec (Parsec, between, oneOf, parse, some)+import Text.Megaparsec.Char (alphaNumChar, char, space, string, symbolChar) import qualified Data.Map as Map import qualified Data.Set as Set @@ -45,9 +45,6 @@ symbol :: Parser String symbol = padded symbol' -moduleName :: Parser String-moduleName = padded $ fmap mconcat $ some $ fmap mconcat $ sequence [(:[]) <$> upperChar, symbol']- pkgName :: Parser String pkgName = some (alphaNumChar <|> char '-') @@ -58,33 +55,11 @@   *> optional (void (padded (quoted pkgName)) *> space)   *> (T.ModuleName . pack <$> (symbol <* space)) -dependencyName :: Parser T.DependencyName-dependencyName = void (string "name:") *> space-  *> (T.DependencyName . pack <$> pkgName)--exposedModules :: Parser (Set T.ModuleName)-exposedModules = void (string "exposed-modules:") *> space-  *> (Set.fromList <$> some (T.ModuleName . pack <$> moduleName))- -- |Parse a Haskell source file's imports. parseFileImports :: FilePath -> IO (Either String (Set T.ModuleName)) parseFileImports fp = do   left show . fmap Set.fromList . traverse (parse oneImport fp) . filter (isPrefixOf "import ") . lines     <$> readFile fp---- |Parse name from the `ghc-pkg` field description.-parseDependencyName :: String -> Either String (Maybe T.DependencyName)-parseDependencyName input =-  if null input-    then Right Nothing-    else left show . fmap Just . parse dependencyName "" $ input---- |Parse exposed modules from the `ghc-pkg` field description.-parseExposedModules :: String -> Either String (Set T.ModuleName)-parseExposedModules input =-  if null input-    then pure mempty-    else left show $ parse exposedModules "" input  -- |Get the dependencies used by a list of modules imported by a Haskell source file. getUsedDependencies :: Map T.ModuleName (Set T.DependencyName) -> Set T.ModuleName -> Set T.DependencyName

@@ -0,0 +1,120 @@+-- |Description: Parser for the "Data.Prune.ApplyStrategy.Smart" strategy.+module Data.Prune.Section.Parser where++import Prelude++import Control.Applicative ((<|>))+import Control.Arrow (left)+import Control.Monad (void)+import Data.Text (pack, unpack)+import Data.Void (Void)+import Text.Megaparsec (Parsec, many, noneOf, parse, some, try)+import Text.Megaparsec.Char (alphaNumChar, char, eol, hspace, hspace1, string)++import qualified Data.Prune.Section.Types as T+import qualified Data.Prune.Types as T++type Parser = Parsec Void String++targetName :: Parser T.CompilableName+targetName = T.CompilableName . pack <$> some (alphaNumChar <|> char '-')++restOfLine :: Parser String+restOfLine = many (noneOf ("\r\n" :: String)) <* eol++emptyLine :: Parser String+emptyLine = "" <$ eol++-- |Parse an indented line with @indentedLine numSpaces@, failing if the line isn't indented to @numSpaces@.+indentedLine :: Int -> Parser String+indentedLine numSpaces = do+  spaces <- many (char ' ')+  let n = length spaces+  case n <= numSpaces of+    True -> fail $ "indentation: " <> show n <> " (expected " <> show numSpaces <> ")"+    False -> (spaces <>) <$> restOfLine++-- |Parse many indented lines with @indentedLines numSpaces@, traversing empty lines until the line isn't indented to @numSpaces@.+indentedLines :: Int -> Parser [String]+indentedLines numSpaces = (:) <$> restOfLine <*> many (try (indentedLine numSpaces <|> emptyLine))++nestedSection :: Parser T.NestedSection+nestedSection = do+  numSpaces <- length <$> some (char ' ')+  let buildDepends = do+        void $ string "build-depends:"+        T.BuildDependsNestedSection numSpaces <$> indentedLines numSpaces+      import_ = do+        void $ string "import:"+        T.ImportNestedSection numSpaces <$> indentedLines numSpaces+      other = T.OtherNestedSection numSpaces <$> indentedLines numSpaces+  buildDepends <|> import_ <|> other++nestedSections :: Parser [T.NestedSection]+nestedSections = some nestedSection++section :: Parser T.Section+section =+  let lib = do+        void $ string "library"+        hspace+        void eol+        T.TargetSection T.CompilableTypeLibrary Nothing <$> nestedSections+      target typ typName = do+        void $ string typName+        hspace1+        name <- targetName+        hspace+        void eol+        T.TargetSection typ (Just name) <$> nestedSections+      common = do+        void $ string "common"+        hspace1+        name <- T.CommonName . pack <$> restOfLine+        T.CommonSection name <$> nestedSections+      sublib = target T.CompilableTypeLibrary "library"+      exe = target T.CompilableTypeExecutable "executable"+      test = target T.CompilableTypeTest "test-suite"+      bench = target T.CompilableTypeBenchmark "benchmark"+      other = T.OtherSection <$> indentedLines 0+  in lib <|> sublib <|> exe <|> test <|> bench <|> common <|> other++sections :: Parser [T.Section]+sections = some section++-- |Parse using 'sections'.+parseCabalSections :: String -> Either String [T.Section]+parseCabalSections = left show . parse sections ""++-- |Render sections. @parseCabalSections . renderCabalSections@ should be equivalent to @Right@.+renderCabalSections :: [T.Section] -> String+renderCabalSections = foldr go mempty+  where+    go2 next accum = case next of+      T.BuildDependsNestedSection numSpaces dependencies -> replicate numSpaces ' ' <> "build-depends:" <> unlines dependencies <> accum+      T.ImportNestedSection numSpaces imports -> replicate numSpaces ' ' <> "import:" <> unlines imports <> accum+      T.OtherNestedSection numSpaces rest -> replicate numSpaces ' ' <> unlines rest <> accum+    go next accum =+      let str = case next of+            T.TargetSection compilableType compilableNameMay nested ->+              let sectionType = case compilableType of+                    T.CompilableTypeLibrary -> "library"+                    T.CompilableTypeExecutable -> "executable"+                    T.CompilableTypeTest -> "test-suite"+                    T.CompilableTypeBenchmark -> "benchmark"+                  sectionName = case compilableNameMay of+                    Nothing -> ""+                    Just (T.CompilableName name) -> " " <> unpack name+              in sectionType <> sectionName <> "\n" <> foldr go2 mempty nested+            T.CommonSection (T.CommonName name) nested ->+              "common " <> unpack name <> "\n" <> foldr go2 mempty nested+            T.OtherSection xs -> unlines xs+      in str <> accum++-- |Read sections from a file using 'parseCabalSections'.+readCabalSections :: FilePath -> IO (Either String [T.Section])+readCabalSections cabalFile = parseCabalSections <$> readFile cabalFile++-- |Write sections to a file using 'renderCabalSections'.+writeCabalSections :: FilePath -> [T.Section] -> IO ()+writeCabalSections cabalFile = writeFile cabalFile . renderCabalSections

@@ -0,0 +1,26 @@+-- |Description: AST for the "Data.Prune.ApplyStrategy.Smart" strategy.+module Data.Prune.Section.Types where++import Prelude++import Data.Text (Text)++import qualified Data.Prune.Types as T++-- |The name of a @common@ stanza.+newtype CommonName = CommonName { unCommonName :: Text }+  deriving (Eq, Ord, Show)++-- |An indented section.+data NestedSection+  = BuildDependsNestedSection Int [String]+  | ImportNestedSection Int [String]+  | OtherNestedSection Int [String]+  deriving (Eq, Ord, Show)++-- |A top-level section.+data Section+  = TargetSection T.CompilableType (Maybe T.CompilableName) [NestedSection]+  | CommonSection CommonName [NestedSection]+  | OtherSection [String]+  deriving (Eq, Ord, Show)

@@ -1,3 +1,4 @@+-- |Description: Utilities for extracting stack info to the canonical types in "Data.Prune.Types". module Data.Prune.Stack where  import Prelude

@@ -1,11 +1,17 @@--- |Types for pruning.+-- |Description: Types for pruning. module Data.Prune.Types where  import Prelude  import Data.Aeson ((.:), FromJSON, parseJSON, withObject) import Data.Set (Set)-import Data.Text (Text, unpack)+import Data.Text (Text, pack, unpack)+import Distribution.Types.Dependency (Dependency)+import Distribution.Types.GenericPackageDescription (GenericPackageDescription)+import Distribution.Types.UnqualComponentName (UnqualComponentName)+import qualified Distribution.Types.Dependency as Dependency+import qualified Distribution.Types.PackageName as PackageName+import qualified Distribution.Types.UnqualComponentName as UnqualComponentName  data BuildSystem = Stack | CabalProject | Cabal   deriving (Eq, Ord, Bounded, Enum)@@ -76,7 +82,7 @@ instance Show DependencyName where   show = unpack . unDependencyName --- |A qualified module name, like `Foo.Bar`+-- |A qualified module name, like @Foo.Bar@ data ModuleName = ModuleName { unModuleName :: Text }   deriving (Eq, Ord) @@ -96,12 +102,17 @@  data Package = Package   { packageName :: Text+  -- ^ The name of the package.+  , packageFile :: FilePath+  -- ^ The location of the cabal file.+  , packageDescription :: GenericPackageDescription+  -- ^ The path to the config file.   , packageBaseDependencies :: Set DependencyName   -- ^ The list of common dependencies.   , packageCompilables :: [Compilable]   -- ^ The things to compile in the package.   }-  deriving (Eq, Ord, Show)+  deriving (Eq, Show)  data StackYaml = StackYaml   { stackYamlPackages :: [FilePath]@@ -114,6 +125,47 @@     StackYaml       <$> obj .: "packages" +data ShouldApply = ShouldNotApply | ShouldApply | ShouldApplyNoVerify+  deriving (Eq, Ord, Bounded, Enum)++instance Show ShouldApply where+  show = \case+    ShouldNotApply -> "no-apply"+    ShouldApply -> "apply"+    ShouldApplyNoVerify -> "apply-no-verify"++validateShouldApply :: (Bool, Bool) -> ShouldApply+validateShouldApply = \case+  (_, True) -> ShouldApplyNoVerify+  (True, False) -> ShouldApply+  (False, False) -> ShouldNotApply++allApply :: [ShouldApply]+allApply = [minBound..maxBound]++data ApplyStrategy = ApplyStrategySafe | ApplyStrategySmart+  deriving (Eq, Ord, Bounded, Enum)++instance Show ApplyStrategy where+  show = \case+    ApplyStrategySafe -> "safe"+    ApplyStrategySmart -> "smart"++parseApplyStrategy :: String -> Maybe ApplyStrategy+parseApplyStrategy = \case+  "safe" -> Just ApplyStrategySafe+  "smart" -> Just ApplyStrategySmart+  _ -> Nothing++allApplyStrategies :: [ApplyStrategy]+allApplyStrategies = [minBound..maxBound]++mkDependencyName :: Dependency -> DependencyName+mkDependencyName = DependencyName . pack . PackageName.unPackageName . Dependency.depPkgName++mkCompilableName :: UnqualComponentName -> CompilableName+mkCompilableName = CompilableName . pack . UnqualComponentName.unUnqualComponentName+ headMay :: [a] -> Maybe a headMay = \case   [] -> Nothing@@ -121,3 +173,12 @@  lastMay :: [a] -> Maybe a lastMay = headMay . reverse++ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM b t f = do x <- b; if x then t else f++whenM :: Monad m => m Bool -> m () -> m ()+whenM b t = ifM b t (pure ())++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM b = whenM (not <$> b)

@@ -1,5 +1,5 @@-resolver: lts-17.5+resolver: lts-18.13 packages:   - . extra-deps:-- cabal-install-parsers-0.3.0.1+- cabal-install-parsers-0.4

@@ -0,0 +1,72 @@+module Data.Prune.ApplyStrategy.SmartSpec where++import Prelude++import Test.Hspec (Spec, describe, it, shouldBe)+import qualified Data.Set as Set++import qualified Data.Prune.Section.Types as T+import qualified Data.Prune.Types as T++-- the module being tested+import Data.Prune.ApplyStrategy.Smart++spec :: Spec+spec = describe "Data.Prune.ApplyStrategy.Smart" $ do+  let base = "  , base <5.0"+      containers = "  , containers"+      mtl = "  , mtl"+      hspec = "  , hspec"+      foo = "  , foo"+      bar = "  , bar"+      nested = T.BuildDependsNestedSection 0 [base, containers, mtl]+      nestedFoo = T.BuildDependsNestedSection 0 [base, containers, mtl, foo]+      nestedBar = T.BuildDependsNestedSection 0 [bar]+      nestedHspec = T.BuildDependsNestedSection 0 [base, containers, mtl, hspec]+      import_ = T.ImportNestedSection 0 [" options"]+      lib = T.TargetSection T.CompilableTypeLibrary Nothing [nested, import_]+      exe = T.TargetSection T.CompilableTypeExecutable (Just (T.CompilableName "foo")) [nestedFoo]+      test = T.TargetSection T.CompilableTypeTest (Just (T.CompilableName "test")) [nestedHspec]+      common = T.CommonSection (T.CommonName "options") [nestedBar]+      allSections = [lib, exe, test, common]++  describe "dependency name regex" $ do+    it "matches a name" $+      matchDependencyName "  base  " `shouldBe` Just (T.DependencyName "base")++    it "matches a name with a version" $+      matchDependencyName "  base <5.0  " `shouldBe` Just (T.DependencyName "base")++  it "strips base out" $ do+    let expected = (T.BuildDependsNestedSection 0 [containers, mtl], mempty)+        actual = stripNestedSection nested (Set.singleton (T.DependencyName "base"))+    actual `shouldBe` expected++  it "strips containers out" $ do+    let expected = (T.BuildDependsNestedSection 0 [base, mtl], mempty)+        actual = stripNestedSection nested (Set.singleton (T.DependencyName "containers"))+    actual `shouldBe` expected++  it "locates a library" $ do+    let expected = T.TargetSection T.CompilableTypeLibrary Nothing [T.BuildDependsNestedSection 0 [containers, mtl], import_]+        actual = stripSections allSections (Set.singleton (T.DependencyName "base")) Nothing+    actual `shouldBe` [expected, exe, test, common]++  it "locates an executable" $ do+    let name = T.CompilableName "foo"+        compilable = T.Compilable name T.CompilableTypeExecutable mempty mempty+        expected = T.TargetSection T.CompilableTypeExecutable (Just name) [T.BuildDependsNestedSection 0 [base, containers, mtl]]+        actual = stripSections allSections (Set.singleton (T.DependencyName "foo")) (Just compilable)+    actual `shouldBe` [lib, expected, test, common]++  it "locates a test suite" $ do+    let name = T.CompilableName "test"+        compilable = T.Compilable name T.CompilableTypeTest mempty mempty+        expected = T.TargetSection T.CompilableTypeTest (Just name) [T.BuildDependsNestedSection 0 [base, containers, mtl]]+        actual = stripSections allSections (Set.singleton (T.DependencyName "hspec")) (Just compilable)+    actual `shouldBe` [lib, exe, expected, common]++  it "locates an import in a library" $ do+    let expected = T.CommonSection (T.CommonName "options") [T.BuildDependsNestedSection 0 []]+        actual = stripSections allSections (Set.singleton (T.DependencyName "bar")) Nothing+    actual `shouldBe` [lib, exe, test, expected]

@@ -4,7 +4,6 @@  import Test.Hspec (Spec, describe, it, shouldBe) import Text.Megaparsec (parse)-import qualified Data.Set as Set  import qualified Data.Prune.Types as T @@ -30,23 +29,3 @@    it "should parse something complicated" $ do     parse oneImport "" "import   qualified   \"foobar\"   Foo.Bar   as   Baz (foo, bar) " `shouldBe` Right (T.ModuleName "Foo.Bar")--  it "should parse dependency name" $ do-    parse dependencyName "" "name: foo-bar" `shouldBe` Right (T.DependencyName "foo-bar")--  it "should parse exposed modules - single line" $ do-    parse exposedModules "" "exposed-modules: Hpack Hpack.Config Hpack.Render Hpack.Yaml"-      `shouldBe` Right (Set.fromList [T.ModuleName "Hpack", T.ModuleName "Hpack.Config", T.ModuleName "Hpack.Render", T.ModuleName "Hpack.Yaml"])--  it "should parse exposed modules - multiline" $ do-    parse exposedModules "" "exposed-modules: Text.Megaparsec Text.Megaparsec.Byte\n\-                                              \Text.Megaparsec.Byte.Lexer Text.Megaparsec.Char\n\-                                              \Text.Megaparsec.Char.Lexer Text.Megaparsec.Debug\n\-                                              \Text.Megaparsec.Error Text.Megaparsec.Error.Builder\n\-                                              \Text.Megaparsec.Internal Text.Megaparsec.Pos Text.Megaparsec.Stream"-      `shouldBe` Right ( Set.fromList-        [ T.ModuleName "Text.Megaparsec", T.ModuleName "Text.Megaparsec.Byte"-        , T.ModuleName "Text.Megaparsec.Byte.Lexer", T.ModuleName "Text.Megaparsec.Char"-        , T.ModuleName "Text.Megaparsec.Char.Lexer", T.ModuleName "Text.Megaparsec.Debug"-        , T.ModuleName "Text.Megaparsec.Error", T.ModuleName "Text.Megaparsec.Error.Builder"-        , T.ModuleName "Text.Megaparsec.Internal", T.ModuleName "Text.Megaparsec.Pos", T.ModuleName "Text.Megaparsec.Stream" ] )

@@ -0,0 +1,138 @@+module Data.Prune.Section.ParserSpec where++import Prelude++import Data.Either (isLeft)+import System.FilePath.TH (fileRelativeToAbsolute)+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)+import Text.Megaparsec (parse)++import Data.Prune.ApplyStrategy.Smart (stripSections)+import qualified Data.Prune.Section.Types as T+import qualified Data.Prune.Types as T++-- the module being tested+import Data.Prune.Section.Parser++buildDependsNestedSection, importNestedSection, otherNestedSection :: T.NestedSection+buildDependsNestedSection = T.BuildDependsNestedSection 2 ["", "    , base <5.0"]+importNestedSection = T.ImportNestedSection 2 [" foo, bar"]+otherNestedSection = T.OtherNestedSection 2 ["default-language: Haskell2010"]++librarySection, executableSection, commonSection, otherSection :: T.Section+librarySection = T.TargetSection T.CompilableTypeLibrary Nothing [importNestedSection, buildDependsNestedSection, otherNestedSection]+executableSection = T.TargetSection T.CompilableTypeExecutable (Just (T.CompilableName "prune-juice")) [buildDependsNestedSection, otherNestedSection]+commonSection = T.CommonSection (T.CommonName "foo") [buildDependsNestedSection, otherNestedSection]+otherSection = T.OtherSection ["name: prune-juice"]++buildDependsNestedExample, importNestedExample, otherNestedExample+  , libraryExample, executableExample, commonExample, otherExample :: String+buildDependsNestedExample = unlines+  [ "  build-depends:"+  , "    , base <5.0"+  ]+importNestedExample = unlines+  [ "  import: foo, bar"+  ]+otherNestedExample = unlines+  [ "  default-language: Haskell2010"+  ]+libraryExample = unlines+  [ "library"+  , "  import: foo, bar"+  , "  build-depends:"+  , "    , base <5.0"+  , "  default-language: Haskell2010"+  ]+executableExample = unlines+  [ "executable prune-juice"+  , "  build-depends:"+  , "    , base <5.0"+  , "  default-language: Haskell2010"+  ]+commonExample = unlines+  [ "common foo"+  , "  build-depends:"+  , "    , base <5.0"+  , "  default-language: Haskell2010"+  ]+otherExample = unlines+  [ "name: prune-juice"+  ]++spec :: Spec+spec = describe "Data.Prune.Section.Parser" $ do+  let cabalFile = $(fileRelativeToAbsolute "../../../../prune-juice.cabal")+      commonFile = $(fileRelativeToAbsolute "../../../fixtures/test.cabal")++  it "should parse a target name" $+    parse targetName "" "prune-juice" `shouldBe` Right (T.CompilableName "prune-juice")++  it "should parse the rest of the line" $+    parse restOfLine "" "foo\n" `shouldBe` Right "foo"++  it "should parse an indented line" $+    parse (indentedLine 0) "" " foo\n" `shouldBe` Right " foo"++  it "should not parse a non-indented line" $+    parse (indentedLine 0) "" "foo\n" `shouldSatisfy` isLeft++  it "should parse indented lines" $+    parse (indentedLines 0) "" "foo\n bar\nbaz\n" `shouldBe` Right ["foo", " bar"]++  it "should parse a build depends nested section" $+    parse nestedSection "" buildDependsNestedExample `shouldBe` Right buildDependsNestedSection++  it "should parse an import nested section" $+    parse nestedSection "" importNestedExample `shouldBe` Right importNestedSection++  it "should parse an other nested section" $+    parse nestedSection "" otherNestedExample `shouldBe` Right otherNestedSection++  it "should parse a library section" $+    parse section "" libraryExample `shouldBe` Right librarySection++  it "should parse an executable section" $+    parse section "" executableExample `shouldBe` Right executableSection++  it "should parse a common section" $+    parse section "" commonExample `shouldBe` Right commonSection++  it "should parse an other section" $+    parse section "" otherExample `shouldBe` Right otherSection++  it "should parse multiple sections" $+    parse sections "" (libraryExample <> executableExample <> commonExample <> otherExample) `shouldBe` Right [librarySection, executableSection, commonSection, otherSection]++  it "should parse and output the same thing" $ do+    input <- readFile cabalFile+    xs <- either fail pure $ parseCabalSections input+    xs `shouldSatisfy` not . null+    renderCabalSections xs `shouldBe` input++  it "should parse and output the same thing after applying a trivial change" $ do+    input <- readFile cabalFile+    xs <- either fail (\ys -> pure (stripSections ys mempty Nothing)) $ parseCabalSections input+    xs `shouldSatisfy` not . null+    renderCabalSections xs `shouldBe` input++  it "should parse a cabal file with common stanzas" $ do+    input <- readCabalSections commonFile+    input `shouldBe` Right+      [ T.CommonSection (T.CommonName "global-options")+          [ T.OtherNestedSection 2 ["default-language: Haskell2010", ""]+          ]+      , T.CommonSection (T.CommonName "options")+          [ T.ImportNestedSection 2 [" global-options"]+          , T.BuildDependsNestedSection 2 [" base", ""]+          ]+      , T.CommonSection (T.CommonName "global-exe-options")+          [ T.OtherNestedSection 2 ["ghc-options: -threaded", ""]+          ]+      , T.TargetSection T.CompilableTypeLibrary Nothing+          [ T.ImportNestedSection 2 [" options", ""]+          ]+      , T.TargetSection T.CompilableTypeExecutable (Just (T.CompilableName "exe"))+          [ T.ImportNestedSection 2 [" options, global-exe-options"]+          ]+      ]

@@ -0,0 +1,15 @@+common global-options+  default-language: Haskell2010++common options+  import: global-options+  build-depends: base++common global-exe-options+  ghc-options: -threaded++library+  import: options++executable exe+  import: options, global-exe-options

@@ -2,12 +2,16 @@  import Test.Hspec (hspec) +import qualified Data.Prune.ApplyStrategy.SmartSpec import qualified Data.Prune.CabalSpec import qualified Data.Prune.DependencySpec import qualified Data.Prune.ImportParserSpec+import qualified Data.Prune.Section.ParserSpec  main :: IO () main = hspec $ do   Data.Prune.CabalSpec.spec   Data.Prune.DependencySpec.spec   Data.Prune.ImportParserSpec.spec+  Data.Prune.Section.ParserSpec.spec+  Data.Prune.ApplyStrategy.SmartSpec.spec