module Hix.Managed.Data.Constraints where

import qualified Data.Map.Strict as Map
import Distribution.Pretty (Pretty (pretty))
import Distribution.Version (VersionRange)
import GHC.Exts (IsList)
import Text.PrettyPrint (Doc, parens, (<+>))

import Hix.Class.Map (LookupMaybe, NMap, nPretty)
import Hix.Data.PackageName (PackageName)
import Hix.Data.VersionBounds (VersionBounds, anyBounds, inclusiveRange)
import Hix.Pretty (prettyL)

-- | Left-biased semigroup op.
--
-- TODO it might be sensible to split the non-mutation deps out of this type so it can be keyed by @MutableDep@.
data MutationConstraints =
  MutationConstraints {
    -- | This used to be an abstraction, but there was no use case for it.
    -- Now it is hardcoded to use inclusive bounds for both, so a potential new mutation handler cannot customize that.
    -- All handlers only evolve one of the bounds, while this now allows both to be changed.
    MutationConstraints -> VersionBounds
mutation :: VersionBounds,

    -- | Prefer the oldest possible version.
    MutationConstraints -> Maybe Bool
oldest :: Maybe Bool,

    -- | Prefer the installed version.
    MutationConstraints -> Maybe Bool
installed :: Maybe Bool,

    -- | Concrete bounds overrides from user config.
    MutationConstraints -> Maybe VersionRange
force :: Maybe VersionRange,

    -- | Prefer a concrete version range.
    MutationConstraints -> Maybe VersionRange
prefer :: Maybe VersionRange
  }
  deriving stock (MutationConstraints -> MutationConstraints -> Bool
(MutationConstraints -> MutationConstraints -> Bool)
-> (MutationConstraints -> MutationConstraints -> Bool)
-> Eq MutationConstraints
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MutationConstraints -> MutationConstraints -> Bool
== :: MutationConstraints -> MutationConstraints -> Bool
$c/= :: MutationConstraints -> MutationConstraints -> Bool
/= :: MutationConstraints -> MutationConstraints -> Bool
Eq, Int -> MutationConstraints -> ShowS
[MutationConstraints] -> ShowS
MutationConstraints -> String
(Int -> MutationConstraints -> ShowS)
-> (MutationConstraints -> String)
-> ([MutationConstraints] -> ShowS)
-> Show MutationConstraints
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MutationConstraints -> ShowS
showsPrec :: Int -> MutationConstraints -> ShowS
$cshow :: MutationConstraints -> String
show :: MutationConstraints -> String
$cshowList :: [MutationConstraints] -> ShowS
showList :: [MutationConstraints] -> ShowS
Show, (forall x. MutationConstraints -> Rep MutationConstraints x)
-> (forall x. Rep MutationConstraints x -> MutationConstraints)
-> Generic MutationConstraints
forall x. Rep MutationConstraints x -> MutationConstraints
forall x. MutationConstraints -> Rep MutationConstraints x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MutationConstraints -> Rep MutationConstraints x
from :: forall x. MutationConstraints -> Rep MutationConstraints x
$cto :: forall x. Rep MutationConstraints x -> MutationConstraints
to :: forall x. Rep MutationConstraints x -> MutationConstraints
Generic)

instance Pretty MutationConstraints where
  pretty :: MutationConstraints -> Doc
pretty MutationConstraints {VersionBounds
mutation :: MutationConstraints -> VersionBounds
mutation :: VersionBounds
mutation, Maybe Bool
oldest :: MutationConstraints -> Maybe Bool
oldest :: Maybe Bool
oldest, Maybe Bool
installed :: MutationConstraints -> Maybe Bool
installed :: Maybe Bool
installed, Maybe VersionRange
force :: MutationConstraints -> Maybe VersionRange
force :: Maybe VersionRange
force, Maybe VersionRange
prefer :: MutationConstraints -> Maybe VersionRange
prefer :: Maybe VersionRange
prefer} =
    VersionRange -> Doc
forall a. Pretty a => a -> Doc
pretty (VersionBounds -> VersionRange
inclusiveRange VersionBounds
mutation) Doc -> Doc -> Doc
<+>
    [(Doc, Maybe Bool)] -> Doc
flags [(Doc
"oldest", Maybe Bool
oldest), (Doc
"installed", Maybe Bool
installed)] Doc -> Doc -> Doc
<+>
    (VersionRange -> Doc) -> Maybe VersionRange -> Doc
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap VersionRange -> Doc
forall a. Pretty a => a -> Doc
pref Maybe VersionRange
prefer Doc -> Doc -> Doc
<+>
    (VersionRange -> Doc) -> Maybe VersionRange -> Doc
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap VersionRange -> Doc
forall a. Pretty a => a -> Doc
spec Maybe VersionRange
force
    where
      flags :: [(Doc, Maybe Bool)] -> Doc
      flags :: [(Doc, Maybe Bool)] -> Doc
flags =
        ((Doc, Maybe Bool) -> Maybe Doc) -> [(Doc, Maybe Bool)] -> [Doc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Doc, Maybe Bool) -> Maybe Doc
forall {a}. (a, Maybe Bool) -> Maybe a
flag ([(Doc, Maybe Bool)] -> [Doc])
-> ([Doc] -> Doc) -> [(Doc, Maybe Bool)] -> Doc
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
          [] -> Doc
forall a. Monoid a => a
mempty
          [Doc]
fs -> Doc -> Doc
parens ([Doc] -> Doc
forall (t :: * -> *) a. (Pretty a, Foldable t) => t a -> Doc
prettyL [Doc]
fs)

      flag :: (a, Maybe Bool) -> Maybe a
flag = \case
        (a
desc, Just Bool
True) -> a -> Maybe a
forall a. a -> Maybe a
Just a
desc
        (a, Maybe Bool)
_ -> Maybe a
forall a. Maybe a
Nothing

      pref :: a -> Doc
pref a
v = Doc
"~" Doc -> Doc -> Doc
<+> a -> Doc
forall a. Pretty a => a -> Doc
pretty a
v
      spec :: a -> Doc
spec a
v = Doc
"+" Doc -> Doc -> Doc
<+> a -> Doc
forall a. Pretty a => a -> Doc
pretty a
v

instance Semigroup MutationConstraints where
  MutationConstraints
l <> :: MutationConstraints -> MutationConstraints -> MutationConstraints
<> MutationConstraints
r =
    MutationConstraints {
      mutation :: VersionBounds
mutation = MutationConstraints
l.mutation VersionBounds -> VersionBounds -> VersionBounds
forall a. Semigroup a => a -> a -> a
<> MutationConstraints
l.mutation,
      oldest :: Maybe Bool
oldest = MutationConstraints
l.oldest Maybe Bool -> Maybe Bool -> Maybe Bool
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MutationConstraints
r.oldest,
      installed :: Maybe Bool
installed = MutationConstraints
l.installed Maybe Bool -> Maybe Bool -> Maybe Bool
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MutationConstraints
r.installed,
      force :: Maybe VersionRange
force = MutationConstraints
l.force Maybe VersionRange -> Maybe VersionRange -> Maybe VersionRange
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MutationConstraints
r.force,
      prefer :: Maybe VersionRange
prefer = MutationConstraints
l.prefer Maybe VersionRange -> Maybe VersionRange -> Maybe VersionRange
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MutationConstraints
r.prefer
    }

instance Monoid MutationConstraints where
  mempty :: MutationConstraints
mempty =
    MutationConstraints {
      mutation :: VersionBounds
mutation = VersionBounds
anyBounds,
      oldest :: Maybe Bool
oldest = Maybe Bool
forall a. Maybe a
Nothing,
      installed :: Maybe Bool
installed = Maybe Bool
forall a. Maybe a
Nothing,
      force :: Maybe VersionRange
force = Maybe VersionRange
forall a. Maybe a
Nothing,
      prefer :: Maybe VersionRange
prefer = Maybe VersionRange
forall a. Maybe a
Nothing
    }

newtype EnvConstraints =
  EnvConstraints (Map PackageName MutationConstraints)
  deriving stock (EnvConstraints -> EnvConstraints -> Bool
(EnvConstraints -> EnvConstraints -> Bool)
-> (EnvConstraints -> EnvConstraints -> Bool) -> Eq EnvConstraints
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EnvConstraints -> EnvConstraints -> Bool
== :: EnvConstraints -> EnvConstraints -> Bool
$c/= :: EnvConstraints -> EnvConstraints -> Bool
/= :: EnvConstraints -> EnvConstraints -> Bool
Eq, Int -> EnvConstraints -> ShowS
[EnvConstraints] -> ShowS
EnvConstraints -> String
(Int -> EnvConstraints -> ShowS)
-> (EnvConstraints -> String)
-> ([EnvConstraints] -> ShowS)
-> Show EnvConstraints
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EnvConstraints -> ShowS
showsPrec :: Int -> EnvConstraints -> ShowS
$cshow :: EnvConstraints -> String
show :: EnvConstraints -> String
$cshowList :: [EnvConstraints] -> ShowS
showList :: [EnvConstraints] -> ShowS
Show, (forall x. EnvConstraints -> Rep EnvConstraints x)
-> (forall x. Rep EnvConstraints x -> EnvConstraints)
-> Generic EnvConstraints
forall x. Rep EnvConstraints x -> EnvConstraints
forall x. EnvConstraints -> Rep EnvConstraints x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EnvConstraints -> Rep EnvConstraints x
from :: forall x. EnvConstraints -> Rep EnvConstraints x
$cto :: forall x. Rep EnvConstraints x -> EnvConstraints
to :: forall x. Rep EnvConstraints x -> EnvConstraints
Generic)
  deriving newtype (Semigroup EnvConstraints
EnvConstraints
Semigroup EnvConstraints =>
EnvConstraints
-> (EnvConstraints -> EnvConstraints -> EnvConstraints)
-> ([EnvConstraints] -> EnvConstraints)
-> Monoid EnvConstraints
[EnvConstraints] -> EnvConstraints
EnvConstraints -> EnvConstraints -> EnvConstraints
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: EnvConstraints
mempty :: EnvConstraints
$cmappend :: EnvConstraints -> EnvConstraints -> EnvConstraints
mappend :: EnvConstraints -> EnvConstraints -> EnvConstraints
$cmconcat :: [EnvConstraints] -> EnvConstraints
mconcat :: [EnvConstraints] -> EnvConstraints
Monoid, Int -> [Item EnvConstraints] -> EnvConstraints
[Item EnvConstraints] -> EnvConstraints
EnvConstraints -> [Item EnvConstraints]
([Item EnvConstraints] -> EnvConstraints)
-> (Int -> [Item EnvConstraints] -> EnvConstraints)
-> (EnvConstraints -> [Item EnvConstraints])
-> IsList EnvConstraints
forall l.
([Item l] -> l)
-> (Int -> [Item l] -> l) -> (l -> [Item l]) -> IsList l
$cfromList :: [Item EnvConstraints] -> EnvConstraints
fromList :: [Item EnvConstraints] -> EnvConstraints
$cfromListN :: Int -> [Item EnvConstraints] -> EnvConstraints
fromListN :: Int -> [Item EnvConstraints] -> EnvConstraints
$ctoList :: EnvConstraints -> [Item EnvConstraints]
toList :: EnvConstraints -> [Item EnvConstraints]
IsList)

instance Semigroup EnvConstraints where
  EnvConstraints Map PackageName MutationConstraints
l <> :: EnvConstraints -> EnvConstraints -> EnvConstraints
<> EnvConstraints Map PackageName MutationConstraints
r = Map PackageName MutationConstraints -> EnvConstraints
EnvConstraints ((MutationConstraints -> MutationConstraints -> MutationConstraints)
-> Map PackageName MutationConstraints
-> Map PackageName MutationConstraints
-> Map PackageName MutationConstraints
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith MutationConstraints -> MutationConstraints -> MutationConstraints
forall a. Semigroup a => a -> a -> a
(<>) Map PackageName MutationConstraints
l Map PackageName MutationConstraints
r)

instance NMap EnvConstraints PackageName MutationConstraints LookupMaybe where

instance Pretty EnvConstraints where
  pretty :: EnvConstraints -> Doc
pretty = EnvConstraints -> Doc
forall k v map sort.
(Pretty k, Pretty v, NMap map k v sort) =>
map -> Doc
nPretty