{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- | Copyright: (c) 2020-2021 berberman
-- SPDX-License-Identifier: MIT
-- Maintainer: berberman <berberman@yandex.com>
-- Stability: experimental
-- Portability: portable
-- This module provides core functionality of @uusi@.
-- It exports the core function 'uusiGenericPackageDescription', and some functions to create 'Uusi'.
module Distribution.Uusi.Core
  ( uusiGenericPackageDescription,
    allToAnyVersion,
    removeByName,
    overwriteByName,
    replaceByName,
    buildableByName,
    optionsByName,
    addOptionsForAll,
    removeOptionsForAll,
  )
where

import Data.List ((\\))
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Distribution.Compiler (PerCompilerFlavor (..))
import Distribution.Types.CondTree (CondTree, mapTreeConstrs, mapTreeData)
import Distribution.Types.Dependency (Dependency)
import Distribution.Types.Lens
import Distribution.Types.PackageName (PackageName, unPackageName)
import Distribution.Types.UnqualComponentName
import Distribution.Types.VersionRange (VersionRange, anyVersion)
import Distribution.Uusi.Types
import Distribution.Uusi.Utils
import Distribution.Uusi.Lens

-----------------------------------------------------------------------------

-- | Create 'Action' that removes all version constraints
allToAnyVersion :: Uusi
allToAnyVersion :: Uusi
allToAnyVersion = forall tag.
tag -> (PackageName -> Bool) -> VersionRange -> Action tag
SetVersion Text
"All dependencies" (forall a b. a -> b -> a
const Bool
True) VersionRange
anyVersion

-- | Create 'Action' that removes a dependency by given its name
removeByName :: PackageName -> Uusi
removeByName :: PackageName -> Uusi
removeByName PackageName
name = forall tag. tag -> (PackageName -> Bool) -> Action tag
Remove (PackageName -> String
unPackageName PackageName
name forall a b. a -> (a -> b) -> b
|> String -> Text
T.pack) (forall a. Eq a => a -> a -> Bool
== PackageName
name)

-- | Create 'Action' that overwrites a dependency's version range
overwriteByName :: PackageName -> VersionRange -> Uusi
overwriteByName :: PackageName -> VersionRange -> Uusi
overwriteByName PackageName
name = forall tag.
tag -> (PackageName -> Bool) -> VersionRange -> Action tag
SetVersion (PackageName -> String
unPackageName PackageName
name forall a b. a -> (a -> b) -> b
|> String -> Text
T.pack) (forall a. Eq a => a -> a -> Bool
== PackageName
name)

-- | Create 'Action' that replaces a dependency with a set of packages
replaceByName :: PackageName -> [(PackageName, VersionRange)] -> Uusi
replaceByName :: PackageName -> [(PackageName, VersionRange)] -> Uusi
replaceByName PackageName
name [(PackageName, VersionRange)]
t = forall tag.
tag -> (PackageName -> Bool) -> [VersionedPackage] -> Action tag
Replace (PackageName -> String
unPackageName PackageName
name forall a b. a -> (a -> b) -> b
|> String -> Text
T.pack) (forall a. Eq a => a -> a -> Bool
== PackageName
name) (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PackageName -> VersionRange -> VersionedPackage
VersionedPackage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PackageName, VersionRange)]
t)

-- | Create 'Action' that sets the buildable of a component (not library)
buildableByName :: UnqualComponentName -> Bool -> Uusi
buildableByName :: UnqualComponentName -> Bool -> Uusi
buildableByName UnqualComponentName
name = forall tag.
tag -> (UnqualComponentName -> Bool) -> Bool -> Action tag
SetBuildable (UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name forall a b. a -> (a -> b) -> b
|> String -> Text
T.pack) (forall a. Eq a => a -> a -> Bool
== UnqualComponentName
name)

-- | Create 'Action' that modifies ghc-options of a component (or the library, if @name == "library"@)
optionsByName :: UnqualComponentName -> Op [String] -> Uusi
optionsByName :: UnqualComponentName -> Op [String] -> Uusi
optionsByName UnqualComponentName
name = forall tag.
tag -> (UnqualComponentName -> Bool) -> Op [String] -> Action tag
ModifyBuiltOptions (UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name forall a b. a -> (a -> b) -> b
|> String -> Text
T.pack) (forall a. Eq a => a -> a -> Bool
== UnqualComponentName
name)

-- | Create 'Action' that appends @opts@ to ghc-options of all components and the library
addOptionsForAll :: [String] -> Uusi
addOptionsForAll :: [String] -> Uusi
addOptionsForAll [String]
opts =
  forall tag.
tag -> (UnqualComponentName -> Bool) -> Op [String] -> Action tag
ModifyBuiltOptions
    (Text
"Add " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show [String]
opts) forall a. Semigroup a => a -> a -> a
<> Text
" to all components and the library")
    (forall a b. a -> b -> a
const Bool
True)
    (forall a. Semigroup a => a -> a -> a
<> [String]
opts)

-- | Create 'Action' that removes @opts@ from ghc-options of all components and the library
removeOptionsForAll :: [String] -> Uusi
removeOptionsForAll :: [String] -> Uusi
removeOptionsForAll [String]
opts =
  forall tag.
tag -> (UnqualComponentName -> Bool) -> Op [String] -> Action tag
ModifyBuiltOptions
    (Text
"Remove " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show [String]
opts) forall a. Semigroup a => a -> a -> a
<> Text
" from all components and the library")
    (forall a b. a -> b -> a
const Bool
True)
    (forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
opts))

-----------------------------------------------------------------------------

uusiRange' :: HasVersionedPackage a => Uusi -> Op a
uusiRange' :: forall a. HasVersionedPackage a => Uusi -> Op a
uusiRange' (SetVersion Text
_ PackageName -> Bool
p VersionRange
range) a
x
  | PackageName -> Bool
p forall a b. (a -> b) -> a -> b
$ a
x forall s a. s -> Getting a s a -> a
^. forall a. HasVersionedPackage a => Lens' a PackageName
myPkgName = a
x forall a b. a -> (a -> b) -> b
& forall a. HasVersionedPackage a => Lens' a VersionRange
myVersionRange forall s t a b. ASetter s t a b -> b -> s -> t
.~ VersionRange
range
  | Bool
otherwise = a
x
uusiRange' Uusi
_ a
x = a
x

uusiRange :: HasVersionedPackage a => Uusis -> Op a
uusiRange :: forall a. HasVersionedPackage a => Uusis -> Op a
uusiRange Uusis
actions = forall a. [Op a] -> Op a
chain forall a b. (a -> b) -> a -> b
<| forall a. HasVersionedPackage a => Uusi -> Op a
uusiRange' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uusis
actions

uusiReplace' :: HasVersionedPackage a => Uusi -> a -> [a]
uusiReplace' :: forall a. HasVersionedPackage a => Uusi -> a -> [a]
uusiReplace' (Replace Text
_ PackageName -> Bool
p [VersionedPackage]
targets) a
x
  | PackageName -> Bool
p forall a b. (a -> b) -> a -> b
$ a
x forall s a. s -> Getting a s a -> a
^. forall a. HasVersionedPackage a => Lens' a PackageName
myPkgName =
    ( \VersionedPackage
t ->
        a
x
          forall a b. a -> (a -> b) -> b
& forall a. HasVersionedPackage a => Lens' a PackageName
myPkgName forall s t a b. ASetter s t a b -> b -> s -> t
.~ VersionedPackage
t forall s a. s -> Getting a s a -> a
^. forall a. HasVersionedPackage a => Lens' a PackageName
myPkgName
          forall a b. a -> (a -> b) -> b
& forall a. HasVersionedPackage a => Lens' a VersionRange
myVersionRange forall s t a b. ASetter s t a b -> b -> s -> t
.~ VersionedPackage
t forall s a. s -> Getting a s a -> a
^. forall a. HasVersionedPackage a => Lens' a VersionRange
myVersionRange
    )
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VersionedPackage]
targets
  | Bool
otherwise = []
uusiReplace' Uusi
_ a
_ = []

uusiReplace :: (HasVersionedPackage a, Eq a) => Uusis -> Op [a]
uusiReplace :: forall a. (HasVersionedPackage a, Eq a) => Uusis -> Op [a]
uusiReplace Uusis
actions [a]
t =
  let k :: [(a, Maybe a)]
k = [(a
r', if Bool
success then forall a. a -> Maybe a
Just a
x else forall a. Maybe a
Nothing) | a
x <- [a]
t, Uusi
a <- Uusis
actions, let r :: [a]
r = forall a. HasVersionedPackage a => Uusi -> a -> [a]
uusiReplace' Uusi
a a
x, let success :: Bool
success = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
r, a
r' <- [a]
r]
      kf :: [a]
kf = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Maybe a)]
k
      ks :: [a]
ks = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, Maybe a)]
k
   in -- TODO: this is ugly
      [a]
kf forall a. Semigroup a => a -> a -> a
<> ([a]
t forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
ks)

uusiRemove :: HasVersionedPackage a => Uusis -> Op [a]
uusiRemove :: forall a. HasVersionedPackage a => Uusis -> Op [a]
uusiRemove Uusis
actions [a]
t = let ps :: [PackageName -> Bool]
ps = [PackageName -> Bool
p | (Remove Text
_ PackageName -> Bool
p) <- Uusis
actions] in forall a. (a -> Bool) -> [a] -> [a]
filter (\a
x -> forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
<| forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
<| (a
x forall s a. s -> Getting a s a -> a
^. forall a. HasVersionedPackage a => Lens' a PackageName
myPkgName))) [PackageName -> Bool]
ps) [a]
t

uusiBuildable :: HasBuildInfo a => Uusis -> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiBuildable :: forall a.
HasBuildInfo a =>
Uusis -> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiBuildable Uusis
actions (UnqualComponentName, CondTree ConfVar [Dependency] a)
t
  | (UnqualComponentName
name, CondTree ConfVar [Dependency] a
tree) <- (UnqualComponentName, CondTree ConfVar [Dependency] a)
t,
    (Bool
b : [Bool]
_) <- [Bool
b | (SetBuildable Text
_ UnqualComponentName -> Bool
p Bool
b) <- Uusis
actions, UnqualComponentName -> Bool
p UnqualComponentName
name] =
    (UnqualComponentName
name, forall a b v c. (a -> b) -> CondTree v c a -> CondTree v c b
mapTreeData (forall a. HasBuildInfo a => Lens' a BuildInfo
buildInfo forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. HasBuildInfo a => Lens' a Bool
buildable forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
b) CondTree ConfVar [Dependency] a
tree)
  | Bool
otherwise = (UnqualComponentName, CondTree ConfVar [Dependency] a)
t

uusiOptions' :: HasBuildInfo a => Action tag -> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiOptions' :: forall a tag.
HasBuildInfo a =>
Action tag
-> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiOptions' (ModifyBuiltOptions tag
_ UnqualComponentName -> Bool
p Op [String]
f) (UnqualComponentName, CondTree ConfVar [Dependency] a)
x
  | (UnqualComponentName
name, CondTree ConfVar [Dependency] a
tree) <- (UnqualComponentName, CondTree ConfVar [Dependency] a)
x,
    UnqualComponentName -> Bool
p UnqualComponentName
name =
    (UnqualComponentName
name, forall a b v c. (a -> b) -> CondTree v c a -> CondTree v c b
mapTreeData (forall a. HasBuildInfo a => Lens' a BuildInfo
buildInfo forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. HasBuildInfo a => Lens' a (PerCompilerFlavor [String])
options forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \(PerCompilerFlavor [String]
ghc [String]
ghcjs) -> forall v. v -> v -> PerCompilerFlavor v
PerCompilerFlavor (Op [String]
f [String]
ghc) [String]
ghcjs) CondTree ConfVar [Dependency] a
tree)
uusiOptions' Action tag
_ (UnqualComponentName, CondTree ConfVar [Dependency] a)
x = (UnqualComponentName, CondTree ConfVar [Dependency] a)
x

uusiOptions :: HasBuildInfo a => [Action tag] -> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiOptions :: forall a tag.
HasBuildInfo a =>
[Action tag]
-> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiOptions [Action tag]
actions = forall a. [Op a] -> Op a
chain forall a b. (a -> b) -> a -> b
<| forall a tag.
HasBuildInfo a =>
Action tag
-> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiOptions' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Action tag]
actions

-----------------------------------------------------------------------------

uusiBuildInfo :: Uusis -> Op BuildInfo
uusiBuildInfo :: Uusis -> BuildInfo -> BuildInfo
uusiBuildInfo Uusis
actions BuildInfo
i =
  BuildInfo
i
    forall a b. a -> (a -> b) -> b
|> (forall a. HasBuildInfo a => Lens' a [Dependency]
targetBuildDepends forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. HasVersionedPackage a => Uusis -> Op a
uusiRange Uusis
actions) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (HasVersionedPackage a, Eq a) => Uusis -> Op [a]
uusiReplace Uusis
actions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasVersionedPackage a => Uusis -> Op [a]
uusiRemove Uusis
actions)
    forall a b. a -> (a -> b) -> b
|> (forall a. HasBuildInfo a => Lens' a [ExeDependency]
buildToolDepends forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. HasVersionedPackage a => Uusis -> Op a
uusiRange Uusis
actions) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (HasVersionedPackage a, Eq a) => Uusis -> Op [a]
uusiReplace Uusis
actions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasVersionedPackage a => Uusis -> Op [a]
uusiRemove Uusis
actions)
    forall a b. a -> (a -> b) -> b
|> (forall a. HasBuildInfo a => Lens' a [LegacyExeDependency]
buildTools forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. HasVersionedPackage a => Uusis -> Op a
uusiRange Uusis
actions) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (HasVersionedPackage a, Eq a) => Uusis -> Op [a]
uusiReplace Uusis
actions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasVersionedPackage a => Uusis -> Op [a]
uusiRemove Uusis
actions)

uusiCondTree :: (HasBuildInfo a) => Uusis -> Op (CondTree ConfVar [Dependency] a)
uusiCondTree :: forall a.
HasBuildInfo a =>
Uusis -> Op (CondTree ConfVar [Dependency] a)
uusiCondTree Uusis
actions = forall a b v c. (a -> b) -> CondTree v c a -> CondTree v c b
mapTreeData (forall a. HasBuildInfo a => Lens' a BuildInfo
buildInfo forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Uusis -> BuildInfo -> BuildInfo
uusiBuildInfo Uusis
actions) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c d v a. (c -> d) -> CondTree v c a -> CondTree v d a
mapTreeConstrs (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. HasVersionedPackage a => Uusis -> Op a
uusiRange Uusis
actions) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (HasVersionedPackage a, Eq a) => Uusis -> Op [a]
uusiReplace Uusis
actions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasVersionedPackage a => Uusis -> Op [a]
uusiRemove Uusis
actions)

-- | The core function of @uusi@.
uusiGenericPackageDescription ::
  -- | A list of 'Action' to apply
  Uusis ->
  Op GenericPackageDescription
uusiGenericPackageDescription :: Uusis -> Op GenericPackageDescription
uusiGenericPackageDescription Uusis
actions GenericPackageDescription
cabal =
  GenericPackageDescription
cabal
    forall a b. a -> (a -> b) -> b
|> (Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
condExecutables forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {f :: * -> *} {a}.
(Functor f, HasBuildInfo a) =>
f (UnqualComponentName, CondTree ConfVar [Dependency] a)
-> f (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiTrees)
    forall a b. a -> (a -> b) -> b
|> (Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
condTestSuites forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {f :: * -> *} {a}.
(Functor f, HasBuildInfo a) =>
f (UnqualComponentName, CondTree ConfVar [Dependency] a)
-> f (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiTrees)
    forall a b. a -> (a -> b) -> b
|> (Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
condBenchmarks forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {f :: * -> *} {a}.
(Functor f, HasBuildInfo a) =>
f (UnqualComponentName, CondTree ConfVar [Dependency] a)
-> f (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiTrees)
    forall a b. a -> (a -> b) -> b
|> (Lens'
  GenericPackageDescription
  [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
condSubLibraries forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {f :: * -> *} {a}.
(Functor f, HasBuildInfo a) =>
f (UnqualComponentName, CondTree ConfVar [Dependency] a)
-> f (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiTrees)
    forall a b. a -> (a -> b) -> b
|> (Lens'
  GenericPackageDescription
  (Maybe (CondTree ConfVar [Dependency] Library))
condLibrary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => ASetter (f a) (f b) a b
mapped forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a.
HasBuildInfo a =>
Uusis -> Op (CondTree ConfVar [Dependency] a)
uusiCondTree Uusis
actions forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a tag.
HasBuildInfo a =>
[Action tag]
-> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiOptions Uusis
actions forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName
"library",)))
  where
    uusiTrees :: f (UnqualComponentName, CondTree ConfVar [Dependency] a)
-> f (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiTrees f (UnqualComponentName, CondTree ConfVar [Dependency] a)
trees = f (UnqualComponentName, CondTree ConfVar [Dependency] a)
trees forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall c a b. Lens (c, a) (c, b) a b
_2 forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a.
HasBuildInfo a =>
Uusis -> Op (CondTree ConfVar [Dependency] a)
uusiCondTree Uusis
actions forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a.
HasBuildInfo a =>
Uusis -> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiBuildable Uusis
actions forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a tag.
HasBuildInfo a =>
[Action tag]
-> Op (UnqualComponentName, CondTree ConfVar [Dependency] a)
uusiOptions Uusis
actions