module Hix.Data.VersionBounds where

import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (Object, String), object, (.:?), (.=))
import Data.Aeson.Types (typeMismatch)
import Distribution.Pretty (Pretty (pretty))
import Distribution.Version (
  Version,
  VersionRange,
  earlierVersion,
  intersectVersionRanges,
  orEarlierVersion,
  orLaterVersion,
  simplifyVersionRange,
  thisVersion,
  )

import Hix.Class.EncodeNix (EncodeNix)
import Hix.Data.Json (aesonParsec, jsonParsec)
import Hix.Data.Version (range0)
import Hix.Pretty (showP)
import Hix.Version (lowerVersion, upperVersion)

data Bound =
  BoundLower
  |
  BoundUpper
  deriving stock (Bound -> Bound -> Bool
(Bound -> Bound -> Bool) -> (Bound -> Bound -> Bool) -> Eq Bound
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Bound -> Bound -> Bool
== :: Bound -> Bound -> Bool
$c/= :: Bound -> Bound -> Bool
/= :: Bound -> Bound -> Bool
Eq, Int -> Bound -> ShowS
[Bound] -> ShowS
Bound -> String
(Int -> Bound -> ShowS)
-> (Bound -> String) -> ([Bound] -> ShowS) -> Show Bound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Bound -> ShowS
showsPrec :: Int -> Bound -> ShowS
$cshow :: Bound -> String
show :: Bound -> String
$cshowList :: [Bound] -> ShowS
showList :: [Bound] -> ShowS
Show, (forall x. Bound -> Rep Bound x)
-> (forall x. Rep Bound x -> Bound) -> Generic Bound
forall x. Rep Bound x -> Bound
forall x. Bound -> Rep Bound x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Bound -> Rep Bound x
from :: forall x. Bound -> Rep Bound x
$cto :: forall x. Rep Bound x -> Bound
to :: forall x. Rep Bound x -> Bound
Generic)

instance Pretty Bound where
  pretty :: Bound -> Doc
pretty = \case
    Bound
BoundLower -> Doc
"lower"
    Bound
BoundUpper -> Doc
"upper"

data VersionBounds =
  VersionBounds {
    VersionBounds -> Maybe Version
lower :: Maybe Version,
    VersionBounds -> Maybe Version
upper :: Maybe Version
  }
  deriving stock (VersionBounds -> VersionBounds -> Bool
(VersionBounds -> VersionBounds -> Bool)
-> (VersionBounds -> VersionBounds -> Bool) -> Eq VersionBounds
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionBounds -> VersionBounds -> Bool
== :: VersionBounds -> VersionBounds -> Bool
$c/= :: VersionBounds -> VersionBounds -> Bool
/= :: VersionBounds -> VersionBounds -> Bool
Eq, Int -> VersionBounds -> ShowS
[VersionBounds] -> ShowS
VersionBounds -> String
(Int -> VersionBounds -> ShowS)
-> (VersionBounds -> String)
-> ([VersionBounds] -> ShowS)
-> Show VersionBounds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionBounds -> ShowS
showsPrec :: Int -> VersionBounds -> ShowS
$cshow :: VersionBounds -> String
show :: VersionBounds -> String
$cshowList :: [VersionBounds] -> ShowS
showList :: [VersionBounds] -> ShowS
Show, (forall x. VersionBounds -> Rep VersionBounds x)
-> (forall x. Rep VersionBounds x -> VersionBounds)
-> Generic VersionBounds
forall x. Rep VersionBounds x -> VersionBounds
forall x. VersionBounds -> Rep VersionBounds x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. VersionBounds -> Rep VersionBounds x
from :: forall x. VersionBounds -> Rep VersionBounds x
$cto :: forall x. Rep VersionBounds x -> VersionBounds
to :: forall x. Rep VersionBounds x -> VersionBounds
Generic)
  deriving anyclass (VersionBounds -> Expr
(VersionBounds -> Expr) -> EncodeNix VersionBounds
forall a. (a -> Expr) -> EncodeNix a
$cencodeNix :: VersionBounds -> Expr
encodeNix :: VersionBounds -> Expr
EncodeNix)

instance Semigroup VersionBounds where
  VersionBounds
left <> :: VersionBounds -> VersionBounds -> VersionBounds
<> VersionBounds
right = VersionBounds {lower :: Maybe Version
lower = VersionBounds
left.lower Maybe Version -> Maybe Version -> Maybe Version
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> VersionBounds
right.lower, upper :: Maybe Version
upper = VersionBounds
left.upper Maybe Version -> Maybe Version -> Maybe Version
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> VersionBounds
right.upper}

instance Monoid VersionBounds where
  mempty :: VersionBounds
mempty = VersionBounds {lower :: Maybe Version
lower = Maybe Version
forall a. Maybe a
Nothing, upper :: Maybe Version
upper = Maybe Version
forall a. Maybe a
Nothing}

unsafeVersionBoundsFromRange :: VersionRange -> VersionBounds
unsafeVersionBoundsFromRange :: VersionRange -> VersionBounds
unsafeVersionBoundsFromRange VersionRange
range =
  VersionBounds {lower :: Maybe Version
lower = VersionRange -> Maybe Version
lowerVersion VersionRange
range, upper :: Maybe Version
upper = VersionRange -> Maybe Version
upperVersion VersionRange
range}

instance FromJSON VersionBounds where
  parseJSON :: Value -> Parser VersionBounds
parseJSON = \case
    String Text
s -> do
      VersionRange
range <- String -> Parser VersionRange
forall a. Parsec a => String -> Parser a
aesonParsec (Text -> String
forall a. ToString a => a -> String
toString Text
s)
      pure (VersionRange -> VersionBounds
unsafeVersionBoundsFromRange VersionRange
range)
    Object Object
o -> do
      Maybe Version
lower <- (JsonParsec Version -> Version)
-> Maybe (JsonParsec Version) -> Maybe Version
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonParsec Version -> Version
forall a. JsonParsec a -> a
jsonParsec (Maybe (JsonParsec Version) -> Maybe Version)
-> Parser (Maybe (JsonParsec Version)) -> Parser (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe (JsonParsec Version))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"lower"
      Maybe Version
upper <- (JsonParsec Version -> Version)
-> Maybe (JsonParsec Version) -> Maybe Version
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JsonParsec Version -> Version
forall a. JsonParsec a -> a
jsonParsec (Maybe (JsonParsec Version) -> Maybe Version)
-> Parser (Maybe (JsonParsec Version)) -> Parser (Maybe Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe (JsonParsec Version))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"upper"
      pure VersionBounds {Maybe Version
lower :: Maybe Version
upper :: Maybe Version
lower :: Maybe Version
upper :: Maybe Version
..}
    Value
v -> do
      let
        expected :: String
expected =
          String
"a managed bound as either a string containing a Cabal-style range or an object with 'lower' and/or 'upper'"
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          String
" as keys and simple versions as values"
      String -> Value -> Parser VersionBounds
forall a. String -> Value -> Parser a
typeMismatch String
expected Value
v

instance ToJSON VersionBounds where
  toJSON :: VersionBounds -> Value
toJSON VersionBounds {Maybe Version
lower :: VersionBounds -> Maybe Version
upper :: VersionBounds -> Maybe Version
lower :: Maybe Version
upper :: Maybe Version
..} =
    [Pair] -> Value
object [
      Key
"lower" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Text -> Value
forall a. ToJSON a => a -> Value
toJSON (forall b a. (Pretty a, IsString b) => a -> b
showP @Text (Version -> Text) -> Maybe Version -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Version
lower),
      Key
"upper" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Text -> Value
forall a. ToJSON a => a -> Value
toJSON (forall b a. (Pretty a, IsString b) => a -> b
showP @Text (Version -> Text) -> Maybe Version -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Version
upper)
    ]

maybeRange ::
  (Bound -> Version -> VersionRange) ->
  VersionBounds ->
  Maybe VersionRange
maybeRange :: (Bound -> Version -> VersionRange)
-> VersionBounds -> Maybe VersionRange
maybeRange Bound -> Version -> VersionRange
mkRange VersionBounds
bounds
  | Just Version
l <- VersionBounds
bounds.lower
  , Just Version
u <- VersionBounds
bounds.upper
  , Version
u Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<= Version
l
  = VersionRange -> Maybe VersionRange
forall a. a -> Maybe a
Just (Version -> VersionRange
thisVersion Version
l)

  | Just VersionRange
l <- Maybe VersionRange
lower
  , Just VersionRange
u <- Maybe VersionRange
upper
  = VersionRange -> Maybe VersionRange
forall a. a -> Maybe a
Just (VersionRange -> VersionRange
simplifyVersionRange (VersionRange -> VersionRange -> VersionRange
intersectVersionRanges VersionRange
l VersionRange
u))

  | Just VersionRange
l <- Maybe VersionRange
lower
  , Maybe VersionRange
Nothing <- Maybe VersionRange
upper
  = VersionRange -> Maybe VersionRange
forall a. a -> Maybe a
Just VersionRange
l

  | Maybe VersionRange
Nothing <- Maybe VersionRange
lower
  , Just VersionRange
u <- Maybe VersionRange
upper
  = VersionRange -> Maybe VersionRange
forall a. a -> Maybe a
Just VersionRange
u

  | Maybe VersionRange
Nothing <- Maybe VersionRange
lower
  , Maybe VersionRange
Nothing <- Maybe VersionRange
upper
  = Maybe VersionRange
forall a. Maybe a
Nothing
  where
    lower :: Maybe VersionRange
lower = Bound -> Version -> VersionRange
mkRange Bound
BoundLower (Version -> VersionRange) -> Maybe Version -> Maybe VersionRange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VersionBounds
bounds.lower
    upper :: Maybe VersionRange
upper = Bound -> Version -> VersionRange
mkRange Bound
BoundUpper (Version -> VersionRange) -> Maybe Version -> Maybe VersionRange
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VersionBounds
bounds.upper

-- | Return a @==lower@ range for invalid bounds.
-- The constructors prevent this from happening, so it's maybe for tests?
-- Probably better to make the type abstract and crash.
maybeMajorRange ::
  VersionBounds ->
  Maybe VersionRange
maybeMajorRange :: VersionBounds -> Maybe VersionRange
maybeMajorRange =
  (Bound -> Version -> VersionRange)
-> VersionBounds -> Maybe VersionRange
maybeRange \case
    Bound
BoundLower -> Version -> VersionRange
orLaterVersion
    Bound
BoundUpper -> Version -> VersionRange
earlierVersion

majorRange :: VersionBounds -> VersionRange
majorRange :: VersionBounds -> VersionRange
majorRange = VersionRange -> Maybe VersionRange -> VersionRange
forall a. a -> Maybe a -> a
fromMaybe VersionRange
range0 (Maybe VersionRange -> VersionRange)
-> (VersionBounds -> Maybe VersionRange)
-> VersionBounds
-> VersionRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionBounds -> Maybe VersionRange
maybeMajorRange

instance Pretty VersionBounds where
  pretty :: VersionBounds -> Doc
pretty = VersionRange -> Doc
forall a. Pretty a => a -> Doc
pretty (VersionRange -> Doc)
-> (VersionBounds -> VersionRange) -> VersionBounds -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionBounds -> VersionRange
majorRange

maybeInclusiveRange :: VersionBounds -> Maybe VersionRange
maybeInclusiveRange :: VersionBounds -> Maybe VersionRange
maybeInclusiveRange =
  (Bound -> Version -> VersionRange)
-> VersionBounds -> Maybe VersionRange
maybeRange \case
    Bound
BoundLower -> Version -> VersionRange
orLaterVersion
    Bound
BoundUpper -> Version -> VersionRange
orEarlierVersion

inclusiveRange :: VersionBounds -> VersionRange
inclusiveRange :: VersionBounds -> VersionRange
inclusiveRange = VersionRange -> Maybe VersionRange -> VersionRange
forall a. a -> Maybe a -> a
fromMaybe VersionRange
range0 (Maybe VersionRange -> VersionRange)
-> (VersionBounds -> Maybe VersionRange)
-> VersionBounds
-> VersionRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionBounds -> Maybe VersionRange
maybeInclusiveRange

anyBounds :: VersionBounds
anyBounds :: VersionBounds
anyBounds =
  VersionBounds {lower :: Maybe Version
lower = Maybe Version
forall a. Maybe a
Nothing, upper :: Maybe Version
upper = Maybe Version
forall a. Maybe a
Nothing}

versionBounds :: Version -> Version -> VersionBounds
versionBounds :: Version -> Version -> VersionBounds
versionBounds Version
lower Version
upper =
  VersionBounds {lower :: Maybe Version
lower = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
lower, upper :: Maybe Version
upper = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
upper}

fromLower :: Version -> VersionBounds
fromLower :: Version -> VersionBounds
fromLower Version
lower =
  VersionBounds {lower :: Maybe Version
lower = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
lower, upper :: Maybe Version
upper = Maybe Version
forall a. Maybe a
Nothing}

fromUpper :: Version -> VersionBounds
fromUpper :: Version -> VersionBounds
fromUpper Version
upper =
  VersionBounds {lower :: Maybe Version
lower = Maybe Version
forall a. Maybe a
Nothing, upper :: Maybe Version
upper = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
upper}

exactVersion :: Version -> VersionBounds
exactVersion :: Version -> VersionBounds
exactVersion Version
version = Version -> Version -> VersionBounds
versionBounds Version
version Version
version

withLower :: Version -> VersionBounds -> VersionBounds
withLower :: Version -> VersionBounds -> VersionBounds
withLower Version
lower VersionBounds {Maybe Version
upper :: VersionBounds -> Maybe Version
upper :: Maybe Version
upper} =
  VersionBounds {lower :: Maybe Version
lower = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
lower, upper :: Maybe Version
upper = Version -> Maybe Version
clamp (Version -> Maybe Version) -> Maybe Version -> Maybe Version
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Version
upper}
  where
    clamp :: Version -> Maybe Version
clamp Version
old | Version
old Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
lower = Maybe Version
forall a. Maybe a
Nothing
              | Bool
otherwise = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
old

withUpper :: Version -> VersionBounds -> VersionBounds
withUpper :: Version -> VersionBounds -> VersionBounds
withUpper Version
upper VersionBounds {Maybe Version
lower :: VersionBounds -> Maybe Version
lower :: Maybe Version
lower} =
  VersionBounds {lower :: Maybe Version
lower = Version -> Maybe Version
clamp (Version -> Maybe Version) -> Maybe Version -> Maybe Version
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Version
lower, upper :: Maybe Version
upper = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
upper}
  where
    clamp :: Version -> Maybe Version
clamp Version
old | Version
old Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
upper = Maybe Version
forall a. Maybe a
Nothing
              | Bool
otherwise = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
old