{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Domain.Bounds
  ( Bounds,
    BoundsByName,
    versionBounds,
    updateDepBounds,
    getBound,
    Bound (..),
    Restriction (..),
    printUpperBound,
    hasBounds,
    boundsScore,
    boundsBetter,
  )
where

import Control.Monad.Except (MonadError)
import Data.Aeson
  ( FromJSON (..),
    ToJSON (..),
    Value (..),
  )
import Data.List (maximum, minimum)
import HWM.Core.Formatting (Format (..), formatList)
import HWM.Core.Has (Has)
import HWM.Core.Parsing (Parse (..), fromToString, removeHead, sepBy, unconsM)
import HWM.Core.Pkg (PkgName)
import HWM.Core.Result (Issue)
import HWM.Core.Version (Bump (..), Version, dropPatch, nextVersion)
import HWM.Runtime.Cache (Cache, getVersions)
import Relude

data Restriction = Min | Max deriving (Int -> Restriction -> ShowS
[Restriction] -> ShowS
Restriction -> String
(Int -> Restriction -> ShowS)
-> (Restriction -> String)
-> ([Restriction] -> ShowS)
-> Show Restriction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Restriction -> ShowS
showsPrec :: Int -> Restriction -> ShowS
$cshow :: Restriction -> String
show :: Restriction -> String
$cshowList :: [Restriction] -> ShowS
showList :: [Restriction] -> ShowS
Show, Restriction -> Restriction -> Bool
(Restriction -> Restriction -> Bool)
-> (Restriction -> Restriction -> Bool) -> Eq Restriction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Restriction -> Restriction -> Bool
== :: Restriction -> Restriction -> Bool
$c/= :: Restriction -> Restriction -> Bool
/= :: Restriction -> Restriction -> Bool
Eq, Eq Restriction
Eq Restriction =>
(Restriction -> Restriction -> Ordering)
-> (Restriction -> Restriction -> Bool)
-> (Restriction -> Restriction -> Bool)
-> (Restriction -> Restriction -> Bool)
-> (Restriction -> Restriction -> Bool)
-> (Restriction -> Restriction -> Restriction)
-> (Restriction -> Restriction -> Restriction)
-> Ord Restriction
Restriction -> Restriction -> Bool
Restriction -> Restriction -> Ordering
Restriction -> Restriction -> Restriction
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Restriction -> Restriction -> Ordering
compare :: Restriction -> Restriction -> Ordering
$c< :: Restriction -> Restriction -> Bool
< :: Restriction -> Restriction -> Bool
$c<= :: Restriction -> Restriction -> Bool
<= :: Restriction -> Restriction -> Bool
$c> :: Restriction -> Restriction -> Bool
> :: Restriction -> Restriction -> Bool
$c>= :: Restriction -> Restriction -> Bool
>= :: Restriction -> Restriction -> Bool
$cmax :: Restriction -> Restriction -> Restriction
max :: Restriction -> Restriction -> Restriction
$cmin :: Restriction -> Restriction -> Restriction
min :: Restriction -> Restriction -> Restriction
Ord)

instance Parse Restriction where
  parse :: forall (m :: * -> *). MonadFail m => Text -> m Restriction
parse Text
">" = Restriction -> m Restriction
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Restriction
Min -- > 0.7.0
  parse Text
"<" = Restriction -> m Restriction
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Restriction
Max -- <  1.0.0
  parse Text
x = String -> m Restriction
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unsorted bound type" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
x)

instance ToString Restriction where
  toString :: Restriction -> String
toString Restriction
Min = String
">" -- >  0.7.0
  toString Restriction
Max = String
"<" -- <  1.0.0

instance ToText Restriction where
  toText :: Restriction -> Text
toText = Restriction -> Text
forall a. ToString a => a -> Text
fromToString

data Bound = Bound
  { Bound -> Restriction
restriction :: Restriction,
    Bound -> Bool
orEquals :: Bool,
    Bound -> Version
version :: Version
  }
  deriving (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, 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)

instance Format Bound where
  format :: Bound -> Text
format Bound {Bool
Version
Restriction
restriction :: Bound -> Restriction
orEquals :: Bound -> Bool
version :: Bound -> Version
restriction :: Restriction
orEquals :: Bool
version :: Version
..} = [Text] -> Text
forall t. IsText t "unwords" => [t] -> t
unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Restriction -> Text
forall a. ToText a => a -> Text
toText Restriction
restriction Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
eq) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Version -> Text
forall a. ToText a => a -> Text
toText Version
version]
    where
      eq :: Text
eq = if Bool
orEquals then Text
"=" else Text
""

instance Ord Bound where
  compare :: Bound -> Bound -> Ordering
compare Bound
a Bound
b =
    Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Bound -> Version
version Bound
a) (Bound -> Version
version Bound
b)
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Restriction -> Restriction -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Bound -> Restriction
restriction Bound
a) (Bound -> Restriction
restriction Bound
b)
      Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Bound -> Bool
orEquals Bound
a) (Bound -> Bool
orEquals Bound
b)

instance Parse Bound where
  parse :: forall (m :: * -> *). MonadFail m => Text -> m Bound
parse Text
txt = do
    (Text
ch, Text
str) <- String -> Text -> m (Text, Text)
forall (m :: * -> *).
MonadFail m =>
String -> Text -> m (Text, Text)
unconsM String
"unsorted bound type" Text
txt
    let (Bool
orEquals, Text
value) = Char -> Text -> (Bool, Text)
removeHead Char
'=' Text
str
    Restriction
restriction <- Text -> m Restriction
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Restriction
parse Text
ch
    Version
version <- Text -> m Version
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Version
parse Text
value
    Bound -> m Bound
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bound {Bool
Version
Restriction
restriction :: Restriction
orEquals :: Bool
version :: Version
orEquals :: Bool
restriction :: Restriction
version :: Version
..}

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

type BoundsByName = '[]

instance Parse Bounds where
  parse :: forall (m :: * -> *). MonadFail m => Text -> m Bounds
parse Text
"" = Bounds -> m Bounds
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bounds -> m Bounds) -> Bounds -> m Bounds
forall a b. (a -> b) -> a -> b
$ [Bound] -> Bounds
Bounds []
  parse Text
str = [Bound] -> Bounds
Bounds ([Bound] -> Bounds) -> m [Bound] -> m Bounds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> m [Bound]
forall (m :: * -> *) a.
(MonadFail m, Parse a) =>
Text -> Text -> m [a]
sepBy Text
"&&" Text
str

instance Format Bounds where
  format :: Bounds -> Text
format (Bounds [Bound]
xs) = Text -> [Bound] -> Text
forall a. Format a => Text -> [a] -> Text
formatList Text
" && " ([Bound] -> Text) -> [Bound] -> Text
forall a b. (a -> b) -> a -> b
$ [Bound] -> [Bound]
forall a. Ord a => [a] -> [a]
sort [Bound]
xs

instance ToString Bounds where
  toString :: Bounds -> String
toString = Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (Bounds -> Text) -> Bounds -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bounds -> Text
forall a. Format a => a -> Text
format

instance FromJSON Bounds where
  parseJSON :: Value -> Parser Bounds
parseJSON (String Text
p) = Text -> Parser Bounds
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Bounds
parse Text
p
  parseJSON Value
v = String -> Parser Bounds
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Bounds) -> String -> Parser Bounds
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. IsString a => String -> a
fromString (String
"cant parse Bounds expected string got" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString (Value -> Text
forall a. Format a => a -> Text
format Value
v))

instance ToJSON Bounds where
  toJSON :: Bounds -> Value
toJSON = Text -> Value
String (Text -> Value) -> (Bounds -> Text) -> Bounds -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bounds -> Text
forall a. ToString a => a -> Text
fromToString

versionBounds :: Version -> Bounds
versionBounds :: Version -> Bounds
versionBounds Version
version =
  [Bound] -> Bounds
Bounds
    [ Restriction -> Bool -> Version -> Bound
Bound Restriction
Min Bool
True (Version -> Version
dropPatch Version
version),
      Restriction -> Bool -> Version -> Bound
Bound Restriction
Max Bool
False (Bump -> Version -> Version
nextVersion Bump
Minor Version
version)
    ]

getBound :: Restriction -> Bounds -> [Bound]
getBound :: Restriction -> Bounds -> [Bound]
getBound Restriction
v (Bounds [Bound]
xs) = Maybe Bound -> [Bound]
forall a. Maybe a -> [a]
maybeToList (Maybe Bound -> [Bound]) -> Maybe Bound -> [Bound]
forall a b. (a -> b) -> a -> b
$ (Bound -> Bool) -> [Bound] -> Maybe Bound
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Bound {Bool
Version
Restriction
restriction :: Bound -> Restriction
orEquals :: Bound -> Bool
version :: Bound -> Version
restriction :: Restriction
orEquals :: Bool
version :: Version
..} -> Restriction
restriction Restriction -> Restriction -> Bool
forall a. Eq a => a -> a -> Bool
== Restriction
v) [Bound]
xs

printUpperBound :: Bounds -> Text
printUpperBound :: Bounds -> Text
printUpperBound Bounds
bounds = case Restriction -> Bounds -> [Bound]
getBound Restriction
Max Bounds
bounds of
  [Bound {Version
version :: Bound -> Version
version :: Version
version}] -> Version -> Text
forall a. Format a => a -> Text
format Version
version
  [Bound]
_ -> Text
""

hasBounds :: Bounds -> Bool
hasBounds :: Bounds -> Bool
hasBounds Bounds
b =
  let lower :: [Bound]
lower = Restriction -> Bounds -> [Bound]
getBound Restriction
Min Bounds
b
      upper :: [Bound]
upper = Restriction -> Bounds -> [Bound]
getBound Restriction
Max Bounds
b
   in Bool -> Bool
not ([Bound] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bound]
lower Bool -> Bool -> Bool
&& [Bound] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bound]
upper)

boundsScore :: Bounds -> Int
boundsScore :: Bounds -> Int
boundsScore Bounds
b = [Bound] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Restriction -> Bounds -> [Bound]
getBound Restriction
Min Bounds
b) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Bound] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Restriction -> Bounds -> [Bound]
getBound Restriction
Max Bounds
b)

boundsBetter :: Bounds -> Bounds -> Bool
boundsBetter :: Bounds -> Bounds -> Bool
boundsBetter Bounds
a Bounds
b = Bounds -> Int
boundsScore Bounds
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Bounds -> Int
boundsScore Bounds
b

getLatest :: (MonadIO m, MonadError Issue m, MonadReader env m, Has env Cache) => PkgName -> m Bound
getLatest :: forall (m :: * -> *) env.
(MonadIO m, MonadError Issue m, MonadReader env m,
 Has env Cache) =>
PkgName -> m Bound
getLatest = (NonEmpty Version -> Bound) -> m (NonEmpty Version) -> m Bound
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Restriction -> Bool -> Version -> Bound
Bound Restriction
Max Bool
True (Version -> Bound)
-> (NonEmpty Version -> Version) -> NonEmpty Version -> Bound
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Version -> Version
forall (f :: * -> *) a. IsNonEmpty f a a "head" => f a -> a
head) (m (NonEmpty Version) -> m Bound)
-> (PkgName -> m (NonEmpty Version)) -> PkgName -> m Bound
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PkgName -> m (NonEmpty Version)
forall (m :: * -> *) env.
(MonadIO m, MonadError Issue m, MonadReader env m,
 Has env Cache) =>
PkgName -> m (NonEmpty Version)
getVersions

updateDepBounds :: (MonadIO m, MonadError Issue m, MonadReader env m, Has env Cache) => PkgName -> Bounds -> m Bounds
updateDepBounds :: forall (m :: * -> *) env.
(MonadIO m, MonadError Issue m, MonadReader env m,
 Has env Cache) =>
PkgName -> Bounds -> m Bounds
updateDepBounds PkgName
name Bounds
bounds = do
  Bound
latest <- PkgName -> m Bound
forall (m :: * -> *) env.
(MonadIO m, MonadError Issue m, MonadReader env m,
 Has env Cache) =>
PkgName -> m Bound
getLatest PkgName
name
  let upper :: [Bound]
upper = Restriction -> Bounds -> [Bound]
getBound Restriction
Max Bounds
bounds
  let newVersion :: Bound
newVersion = [Bound] -> Bound
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Bound
latest Bound -> [Bound] -> [Bound]
forall a. a -> [a] -> [a]
: [Bound]
upper)
  [Bound]
_min <- PkgName -> Bounds -> m [Bound]
forall (m :: * -> *) env.
(MonadIO m, MonadError Issue m, MonadReader env m,
 Has env Cache) =>
PkgName -> Bounds -> m [Bound]
initiateMin PkgName
name Bounds
bounds
  Bounds -> m Bounds
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Bound] -> Bounds
Bounds ([Bound]
_min [Bound] -> [Bound] -> [Bound]
forall a. Semigroup a => a -> a -> a
<> [Bound
newVersion]))

initiateMin :: (MonadIO m, MonadError Issue m, MonadReader env m, Has env Cache) => PkgName -> Bounds -> m [Bound]
initiateMin :: forall (m :: * -> *) env.
(MonadIO m, MonadError Issue m, MonadReader env m,
 Has env Cache) =>
PkgName -> Bounds -> m [Bound]
initiateMin PkgName
name Bounds
bounds = do
  let mi :: [Bound]
mi = Restriction -> Bounds -> [Bound]
getBound Restriction
Min Bounds
bounds
  if [Bound] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Bound]
mi
    then do
      NonEmpty Bound
ls <- (Version -> Bound) -> NonEmpty Version -> NonEmpty Bound
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Restriction -> Bool -> Version -> Bound
Bound Restriction
Min Bool
True) (NonEmpty Version -> NonEmpty Bound)
-> m (NonEmpty Version) -> m (NonEmpty Bound)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PkgName -> m (NonEmpty Version)
forall (m :: * -> *) env.
(MonadIO m, MonadError Issue m, MonadReader env m,
 Has env Cache) =>
PkgName -> m (NonEmpty Version)
getVersions PkgName
name
      [Bound] -> m [Bound]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NonEmpty Bound -> Bound
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum NonEmpty Bound
ls]
    else [Bound] -> m [Bound]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Bound]
mi