-- |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 :: Regex
dependencyNameRegex = String -> Regex
mkRegex String
"^ *([a-zA-Z0-9\\-]+).*$"

-- |Parse a dependency name from a string.
matchDependencyName :: String -> Maybe T.DependencyName
matchDependencyName :: String -> Maybe DependencyName
matchDependencyName String
str = DependencyName -> Maybe DependencyName
forall a. a -> Maybe a
Just (DependencyName -> Maybe DependencyName)
-> (String -> DependencyName) -> String -> Maybe DependencyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DependencyName
T.DependencyName (Text -> DependencyName)
-> (String -> Text) -> String -> DependencyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Maybe DependencyName)
-> Maybe String -> Maybe DependencyName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> Maybe String
forall a. [a] -> Maybe a
T.headMay ([String] -> Maybe String) -> Maybe [String] -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Regex -> String -> Maybe [String]
matchRegex Regex
dependencyNameRegex String
str

-- |Strip matching dependencies from a single line.
stripOneBuildDepends :: String -> Set T.DependencyName -> Maybe String
stripOneBuildDepends :: String -> Set DependencyName -> Maybe String
stripOneBuildDepends String
input Set DependencyName
dependencies =
  let output :: String
output = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe String
go ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
unpack ([Text] -> [String]) -> (String -> [Text]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
splitOn Text
"," (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
input
  in case Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
output) Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) Char
' ') String
output of
      Bool
True -> Maybe String
forall a. Maybe a
Nothing
      Bool
False -> String -> Maybe String
forall a. a -> Maybe a
Just String
output
  where
    go :: String -> Maybe String
go String
x = case String -> Maybe DependencyName
matchDependencyName String
x of
      Maybe DependencyName
Nothing -> String -> Maybe String
forall a. a -> Maybe a
Just String
x
      Just DependencyName
dep -> case DependencyName -> Set DependencyName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member DependencyName
dep Set DependencyName
dependencies of
        Bool
True -> Maybe String
forall a. Maybe a
Nothing
        Bool
False -> String -> Maybe String
forall a. a -> Maybe a
Just String
x

-- |Strip matching dependencies from a @build-depends@ section.
stripBuildDepends :: [String] -> Set T.DependencyName -> [String]
stripBuildDepends :: [String] -> Set DependencyName -> [String]
stripBuildDepends [String]
buildDepends Set DependencyName
dependencies = (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\String
x -> String -> Set DependencyName -> Maybe String
stripOneBuildDepends String
x Set DependencyName
dependencies) [String]
buildDepends

-- |Strip matching dependencies from a nested section.
stripNestedSection :: T.NestedSection -> Set T.DependencyName -> (T.NestedSection, Set T.CommonName)
stripNestedSection :: NestedSection
-> Set DependencyName -> (NestedSection, Set CommonName)
stripNestedSection NestedSection
nested Set DependencyName
dependencies = case NestedSection
nested of
  T.BuildDependsNestedSection Int
numSpaces [String]
buildDepends -> (Int -> [String] -> NestedSection
T.BuildDependsNestedSection Int
numSpaces ([String] -> Set DependencyName -> [String]
stripBuildDepends [String]
buildDepends Set DependencyName
dependencies), Set CommonName
forall a. Monoid a => a
mempty)
  T.ImportNestedSection Int
numSpaces [String]
imports ->
    let common :: Set CommonName
common = [CommonName] -> Set CommonName
forall a. Ord a => [a] -> Set a
Set.fromList ([CommonName] -> Set CommonName) -> [CommonName] -> Set CommonName
forall a b. (a -> b) -> a -> b
$ Text -> CommonName
T.CommonName (Text -> CommonName) -> [Text] -> [CommonName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Text]] -> [Text]
forall a. Monoid a => [a] -> a
mconcat ((String -> [Text]) -> [String] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> [Text]
splitOn Text
"," (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (String -> [String]
words ([String] -> String
unwords [String]
imports)))
    in (Int -> [String] -> NestedSection
T.ImportNestedSection Int
numSpaces [String]
imports, Set CommonName
common)
  NestedSection
other -> (NestedSection
other, Set CommonName
forall a. Monoid a => a
mempty)

-- |Strip matching dependencies from many nested sections.
stripNestedSections :: [T.NestedSection] -> Set T.DependencyName -> ([T.NestedSection], Set T.CommonName)
stripNestedSections :: [NestedSection]
-> Set DependencyName -> ([NestedSection], Set CommonName)
stripNestedSections [NestedSection]
nested Set DependencyName
dependencies = ([Set CommonName] -> Set CommonName)
-> ([NestedSection], [Set CommonName])
-> ([NestedSection], Set CommonName)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [Set CommonName] -> Set CommonName
forall a. Monoid a => [a] -> a
mconcat (([NestedSection], [Set CommonName])
 -> ([NestedSection], Set CommonName))
-> ([NestedSection], [Set CommonName])
-> ([NestedSection], Set CommonName)
forall a b. (a -> b) -> a -> b
$ [(NestedSection, Set CommonName)]
-> ([NestedSection], [Set CommonName])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(NestedSection, Set CommonName)]
 -> ([NestedSection], [Set CommonName]))
-> [(NestedSection, Set CommonName)]
-> ([NestedSection], [Set CommonName])
forall a b. (a -> b) -> a -> b
$ (NestedSection -> (NestedSection, Set CommonName))
-> [NestedSection] -> [(NestedSection, Set CommonName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NestedSection
x -> NestedSection
-> Set DependencyName -> (NestedSection, Set CommonName)
stripNestedSection NestedSection
x Set DependencyName
dependencies) [NestedSection]
nested

-- |Strip dependencies from any top-level section.
stripSection :: T.Section -> Set T.DependencyName -> StripTarget -> (T.Section, Set T.CommonName)
stripSection :: Section
-> Set DependencyName -> StripTarget -> (Section, Set CommonName)
stripSection Section
section Set DependencyName
dependencies StripTarget
target = case (Section
section, StripTarget
target) of
  (T.TargetSection CompilableType
T.CompilableTypeLibrary Maybe CompilableName
Nothing [NestedSection]
nested, StripTarget
StripTargetBaseLibrary) ->
    let ([NestedSection]
newNested, Set CommonName
common) = [NestedSection]
-> Set DependencyName -> ([NestedSection], Set CommonName)
stripNestedSections [NestedSection]
nested Set DependencyName
dependencies
    in (CompilableType
-> Maybe CompilableName -> [NestedSection] -> Section
T.TargetSection CompilableType
T.CompilableTypeLibrary Maybe CompilableName
forall a. Maybe a
Nothing [NestedSection]
newNested, Set CommonName
common)
  (T.TargetSection CompilableType
typ (Just CompilableName
name) [NestedSection]
nested, StripTargetCompilable T.Compilable {Set String
Set DependencyName
CompilableName
CompilableType
compilableFiles :: Compilable -> Set String
compilableDependencies :: Compilable -> Set DependencyName
compilableType :: Compilable -> CompilableType
compilableName :: Compilable -> CompilableName
compilableFiles :: Set String
compilableDependencies :: Set DependencyName
compilableType :: CompilableType
compilableName :: CompilableName
..}) | CompilableType
typ CompilableType -> CompilableType -> Bool
forall a. Eq a => a -> a -> Bool
== CompilableType
compilableType Bool -> Bool -> Bool
&& CompilableName
name CompilableName -> CompilableName -> Bool
forall a. Eq a => a -> a -> Bool
== CompilableName
compilableName ->
    let ([NestedSection]
newNested, Set CommonName
common) = [NestedSection]
-> Set DependencyName -> ([NestedSection], Set CommonName)
stripNestedSections [NestedSection]
nested Set DependencyName
dependencies
    in (CompilableType
-> Maybe CompilableName -> [NestedSection] -> Section
T.TargetSection CompilableType
typ (CompilableName -> Maybe CompilableName
forall a. a -> Maybe a
Just CompilableName
name) [NestedSection]
newNested, Set CommonName
common)
  (T.CommonSection CommonName
name [NestedSection]
nested, StripTargetCommonStanza Set CommonName
common) | CommonName -> Set CommonName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member CommonName
name Set CommonName
common ->
    let ([NestedSection]
newNested, Set CommonName
newCommon) = [NestedSection]
-> Set DependencyName -> ([NestedSection], Set CommonName)
stripNestedSections [NestedSection]
nested Set DependencyName
dependencies
    in (CommonName -> [NestedSection] -> Section
T.CommonSection CommonName
name [NestedSection]
newNested, Set CommonName
newCommon)
  (Section
other, StripTarget
_) -> (Section
other, Set CommonName
forall a. Monoid a => a
mempty)

-- |Strip dependencies from many top-level sections.
stripSections :: [T.Section] -> Set T.DependencyName -> Maybe T.Compilable -> [T.Section]
stripSections :: [Section] -> Set DependencyName -> Maybe Compilable -> [Section]
stripSections [Section]
sections Set DependencyName
dependencies Maybe Compilable
compilableMay =
  let run :: StripTarget -> [Section] -> ([Section], Set CommonName)
run StripTarget
target = ([Set CommonName] -> Set CommonName)
-> ([Section], [Set CommonName]) -> ([Section], Set CommonName)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [Set CommonName] -> Set CommonName
forall a. Monoid a => [a] -> a
mconcat (([Section], [Set CommonName]) -> ([Section], Set CommonName))
-> ([Section] -> ([Section], [Set CommonName]))
-> [Section]
-> ([Section], Set CommonName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Section, Set CommonName)] -> ([Section], [Set CommonName])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Section, Set CommonName)] -> ([Section], [Set CommonName]))
-> ([Section] -> [(Section, Set CommonName)])
-> [Section]
-> ([Section], [Set CommonName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Section -> (Section, Set CommonName))
-> [Section] -> [(Section, Set CommonName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Section
x -> Section
-> Set DependencyName -> StripTarget -> (Section, Set CommonName)
stripSection Section
x Set DependencyName
dependencies StripTarget
target)
      firstTarget :: StripTarget
firstTarget = StripTarget
-> (Compilable -> StripTarget) -> Maybe Compilable -> StripTarget
forall b a. b -> (a -> b) -> Maybe a -> b
maybe StripTarget
StripTargetBaseLibrary Compilable -> StripTarget
StripTargetCompilable Maybe Compilable
compilableMay
      firstPass :: ([Section], Set CommonName)
firstPass = StripTarget -> [Section] -> ([Section], Set CommonName)
run StripTarget
firstTarget [Section]
sections
  in (((([Section], Set CommonName) -> [Section])
  -> ([Section], Set CommonName) -> [Section])
 -> ([Section], Set CommonName) -> [Section])
-> ([Section], Set CommonName)
-> ((([Section], Set CommonName) -> [Section])
    -> ([Section], Set CommonName) -> [Section])
-> [Section]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((([Section], Set CommonName) -> [Section])
 -> ([Section], Set CommonName) -> [Section])
-> ([Section], Set CommonName) -> [Section]
forall a. (a -> a) -> a
fix ([Section], Set CommonName)
firstPass (((([Section], Set CommonName) -> [Section])
  -> ([Section], Set CommonName) -> [Section])
 -> [Section])
-> ((([Section], Set CommonName) -> [Section])
    -> ([Section], Set CommonName) -> [Section])
-> [Section]
forall a b. (a -> b) -> a -> b
$ \([Section], Set CommonName) -> [Section]
recur -> \case
       ([Section]
final, Set CommonName
none) | Set CommonName -> Bool
forall a. Set a -> Bool
Set.null Set CommonName
none -> [Section]
final
       ([Section]
next, Set CommonName
common) -> ([Section], Set CommonName) -> [Section]
recur (StripTarget -> [Section] -> ([Section], Set CommonName)
run (Set CommonName -> StripTarget
StripTargetCommonStanza Set CommonName
common) [Section]
next)