module Staversion.Internal.Aggregate
(
aggregateResults,
Aggregator,
VersionRange,
showVersionRange,
aggOr,
aggPvpMajor,
aggPvpMinor,
groupAllPreservingOrderBy,
aggregatePackageVersions
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import qualified Control.Monad.Trans.State.Strict as State
import Control.Monad (mzero, forM_)
import Control.Applicative ((<$>), (<|>))
import Data.Foldable (foldrM, foldr1)
import Data.Function (on)
import Data.Maybe (fromJust)
import Data.Monoid (mconcat, All(All))
import Data.List (lookup)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NL
import Data.Text (unpack)
import Data.Traversable (traverse)
import qualified Text.PrettyPrint as Pretty
import Staversion.Internal.Cabal (Target(..))
import Staversion.Internal.Query (PackageName, ErrorMsg)
import Staversion.Internal.Log (LogEntry(..), LogLevel(..))
import Staversion.Internal.Result (Result(..), AggregatedResult(..), ResultBody, ResultBody'(..), resultSourceDesc)
import Staversion.Internal.Version (Version, mkVersion, VersionRange, docVersionRange)
import qualified Staversion.Internal.Version as V
type Aggregator = NonEmpty Version -> VersionRange
showVersionRange :: VersionRange -> String
showVersionRange :: VersionRange -> String
showVersionRange = Doc -> String
Pretty.render (Doc -> String) -> (VersionRange -> Doc) -> VersionRange -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> Doc
docVersionRange
groupAllPreservingOrderBy :: (a -> a -> Bool)
-> [a] -> [NonEmpty a]
groupAllPreservingOrderBy :: forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupAllPreservingOrderBy a -> a -> Bool
sameGroup = (a -> [NonEmpty a] -> [NonEmpty a])
-> [NonEmpty a] -> [a] -> [NonEmpty a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> [NonEmpty a] -> [NonEmpty a]
f [] where
f :: a -> [NonEmpty a] -> [NonEmpty a]
f a
item [NonEmpty a]
acc = [NonEmpty a] -> [NonEmpty a] -> [NonEmpty a]
update [] [NonEmpty a]
acc where
update :: [NonEmpty a] -> [NonEmpty a] -> [NonEmpty a]
update [NonEmpty a]
heads [] = (a
item a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| []) NonEmpty a -> [NonEmpty a] -> [NonEmpty a]
forall a. a -> [a] -> [a]
: [NonEmpty a]
heads
update [NonEmpty a]
heads (cur :: NonEmpty a
cur@(a
cur_head :| [a]
cur_rest) : [NonEmpty a]
rest) =
if a -> a -> Bool
sameGroup a
item a
cur_head
then ((a
item a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| (a
cur_head a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
cur_rest)) NonEmpty a -> [NonEmpty a] -> [NonEmpty a]
forall a. a -> [a] -> [a]
: [NonEmpty a]
heads) [NonEmpty a] -> [NonEmpty a] -> [NonEmpty a]
forall a. [a] -> [a] -> [a]
++ [NonEmpty a]
rest
else [NonEmpty a] -> [NonEmpty a] -> [NonEmpty a]
update ([NonEmpty a]
heads [NonEmpty a] -> [NonEmpty a] -> [NonEmpty a]
forall a. [a] -> [a] -> [a]
++ [NonEmpty a
cur]) [NonEmpty a]
rest
aggOr :: Aggregator
aggOr :: Aggregator
aggOr = (VersionRange -> VersionRange -> VersionRange)
-> NonEmpty VersionRange -> VersionRange
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 VersionRange -> VersionRange -> VersionRange
V.unionVersionRanges (NonEmpty VersionRange -> VersionRange)
-> (NonEmpty Version -> NonEmpty VersionRange) -> Aggregator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version -> VersionRange)
-> NonEmpty Version -> NonEmpty VersionRange
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> VersionRange
V.thisVersion (NonEmpty Version -> NonEmpty VersionRange)
-> (NonEmpty Version -> NonEmpty Version)
-> NonEmpty Version
-> NonEmpty VersionRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Version -> NonEmpty Version
forall a. Eq a => NonEmpty a -> NonEmpty a
NL.nub (NonEmpty Version -> NonEmpty Version)
-> (NonEmpty Version -> NonEmpty Version)
-> NonEmpty Version
-> NonEmpty Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Version -> NonEmpty Version
forall a. Ord a => NonEmpty a -> NonEmpty a
NL.sort
aggPvpMajor :: Aggregator
aggPvpMajor :: Aggregator
aggPvpMajor = ([Int] -> [Int]) -> Aggregator
aggPvpGeneral (([Int] -> [Int]) -> Aggregator) -> ([Int] -> [Int]) -> Aggregator
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall {a}. Num a => [a] -> [a]
makeUpper where
makeUpper :: [a] -> [a]
makeUpper [] = String -> [a]
forall a. HasCallStack => String -> a
error String
"version must not be empty."
makeUpper [a
x] = [a
x, a
1]
makeUpper (a
x : a
y : [a]
_) = [a
x, a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
1]
aggPvpMinor :: Aggregator
aggPvpMinor :: Aggregator
aggPvpMinor = ([Int] -> [Int]) -> Aggregator
aggPvpGeneral (([Int] -> [Int]) -> Aggregator) -> ([Int] -> [Int]) -> Aggregator
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall {a}. Num a => [a] -> [a]
makeUpper where
makeUpper :: [a] -> [a]
makeUpper [] = String -> [a]
forall a. HasCallStack => String -> a
error String
"version must not be empty."
makeUpper [a
x] = [a
x, a
0, a
1]
makeUpper [a
x,a
y] = [a
x, a
y, a
1]
makeUpper (a
x : a
y : a
z : [a]
_) = [a
x, a
y, a
z a -> a -> a
forall a. Num a => a -> a -> a
+ a
1]
aggPvpGeneral :: ([Int] -> [Int]) -> Aggregator
aggPvpGeneral :: ([Int] -> [Int]) -> Aggregator
aggPvpGeneral [Int] -> [Int]
makeUpper = VersionRange -> VersionRange
V.simplifyVersionRange (VersionRange -> VersionRange) -> Aggregator -> Aggregator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VersionRange -> VersionRange -> VersionRange)
-> NonEmpty VersionRange -> VersionRange
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 VersionRange -> VersionRange -> VersionRange
V.unionVersionRanges (NonEmpty VersionRange -> VersionRange)
-> (NonEmpty Version -> NonEmpty VersionRange) -> Aggregator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version -> VersionRange)
-> NonEmpty Version -> NonEmpty VersionRange
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> VersionRange
toRange (NonEmpty Version -> NonEmpty VersionRange)
-> (NonEmpty Version -> NonEmpty Version)
-> NonEmpty Version
-> NonEmpty VersionRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Version -> NonEmpty Version
forall a. Eq a => NonEmpty a -> NonEmpty a
NL.nub (NonEmpty Version -> NonEmpty Version)
-> (NonEmpty Version -> NonEmpty Version)
-> NonEmpty Version
-> NonEmpty Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Version -> NonEmpty Version
forall a. Ord a => NonEmpty a -> NonEmpty a
NL.sort where
toRange :: Version -> VersionRange
toRange Version
v = VersionIntervals -> VersionRange
V.fromVersionIntervals (VersionIntervals -> VersionRange)
-> VersionIntervals -> VersionRange
forall a b. (a -> b) -> a -> b
$ [VersionInterval] -> VersionIntervals
V.mkVersionIntervals [(Version -> Bound -> LowerBound
V.LowerBound Version
norm_v Bound
V.InclusiveBound, Version -> Bound -> UpperBound
V.UpperBound Version
vu Bound
V.ExclusiveBound)] where
norm_v :: Version
norm_v = [Int] -> Version
V.mkVersion ([Int] -> Version) -> [Int] -> Version
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
normalizeTralingZeroes ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Version -> [Int]
V.versionNumbers Version
v
vu :: Version
vu = [Int] -> Version
V.mkVersion ([Int] -> Version) -> [Int] -> Version
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
makeUpper ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Version -> [Int]
V.versionNumbers Version
norm_v
normalizeTralingZeroes :: [Int] -> [Int]
normalizeTralingZeroes :: [Int] -> [Int]
normalizeTralingZeroes [] = []
normalizeTralingZeroes (Int
head_v : [Int]
rest) = Int
head_v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ([[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Int]] -> [Int]) -> [[Int]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[Int]] -> [[Int]]
forall {a}. (Eq a, Num a) => [[a]] -> [[a]]
dropTrailingZeros ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [Int] -> [[Int]]
forall a. Eq a => [a] -> [[a]]
List.group [Int]
rest) where
dropTrailingZeros :: [[a]] -> [[a]]
dropTrailingZeros [] = []
dropTrailingZeros [[a]]
groups = if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0) ([a] -> [Bool]) -> [a] -> [Bool]
forall a b. (a -> b) -> a -> b
$ [[a]] -> [a]
forall a. HasCallStack => [a] -> a
last [[a]]
groups
then [[a]] -> [[a]]
forall a. HasCallStack => [a] -> [a]
init [[a]]
groups
else [[a]]
groups
aggregateResults :: Aggregator -> [Result] -> ([AggregatedResult], [LogEntry])
aggregateResults :: Aggregator -> [Result] -> ([AggregatedResult], [LogEntry])
aggregateResults Aggregator
aggregate = AggM [AggregatedResult] -> ([AggregatedResult], [LogEntry])
forall {a}. AggM [a] -> ([a], [LogEntry])
unMonad
(AggM [AggregatedResult] -> ([AggregatedResult], [LogEntry]))
-> ([Result] -> AggM [AggregatedResult])
-> [Result]
-> ([AggregatedResult], [LogEntry])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[AggregatedResult]] -> [AggregatedResult])
-> MaybeT (State [LogEntry]) [[AggregatedResult]]
-> AggM [AggregatedResult]
forall a b.
(a -> b)
-> MaybeT (State [LogEntry]) a -> MaybeT (State [LogEntry]) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[AggregatedResult]] -> [AggregatedResult]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
(MaybeT (State [LogEntry]) [[AggregatedResult]]
-> AggM [AggregatedResult])
-> ([Result] -> MaybeT (State [LogEntry]) [[AggregatedResult]])
-> [Result]
-> AggM [AggregatedResult]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Result -> AggM [AggregatedResult])
-> [NonEmpty Result]
-> MaybeT (State [LogEntry]) [[AggregatedResult]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM NonEmpty Result -> AggM [AggregatedResult]
aggregateInSameQuery'
([NonEmpty Result]
-> MaybeT (State [LogEntry]) [[AggregatedResult]])
-> ([Result] -> [NonEmpty Result])
-> [Result]
-> MaybeT (State [LogEntry]) [[AggregatedResult]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result -> Result -> Bool) -> [Result] -> [NonEmpty Result]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupAllPreservingOrderBy (Query -> Query -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Query -> Query -> Bool)
-> (Result -> Query) -> Result -> Result -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Result -> Query
resultFor)
where
aggregateInSameQuery' :: NonEmpty Result -> AggM [AggregatedResult]
aggregateInSameQuery' NonEmpty Result
results = ((NonEmpty AggregatedResult -> [AggregatedResult])
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
-> AggM [AggregatedResult]
forall a b.
(a -> b)
-> MaybeT (State [LogEntry]) a -> MaybeT (State [LogEntry]) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty AggregatedResult -> [AggregatedResult]
forall a. NonEmpty a -> [a]
NL.toList (MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
-> AggM [AggregatedResult])
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
-> AggM [AggregatedResult]
forall a b. (a -> b) -> a -> b
$ Aggregator
-> NonEmpty Result
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
aggregateInSameQuery Aggregator
aggregate NonEmpty Result
results)
AggM [AggregatedResult]
-> AggM [AggregatedResult] -> AggM [AggregatedResult]
forall a.
MaybeT (State [LogEntry]) a
-> MaybeT (State [LogEntry]) a -> MaybeT (State [LogEntry]) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [AggregatedResult] -> AggM [AggregatedResult]
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
unMonad :: AggM [a] -> ([a], [LogEntry])
unMonad = (\(Maybe [a]
magg, [LogEntry]
logs) -> (Maybe [a] -> [a]
forall {a}. Maybe [a] -> [a]
toList Maybe [a]
magg, [LogEntry]
logs)) ((Maybe [a], [LogEntry]) -> ([a], [LogEntry]))
-> (AggM [a] -> (Maybe [a], [LogEntry]))
-> AggM [a]
-> ([a], [LogEntry])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AggM [a] -> (Maybe [a], [LogEntry])
forall a. AggM a -> (Maybe a, [LogEntry])
runAggM
toList :: Maybe [a] -> [a]
toList Maybe [a]
Nothing = []
toList (Just [a]
list) = [a]
list
aggregateInSameQuery :: Aggregator -> NonEmpty Result -> AggM (NonEmpty AggregatedResult)
aggregateInSameQuery :: Aggregator
-> NonEmpty Result
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
aggregateInSameQuery Aggregator
aggregate NonEmpty Result
results = ((NonEmpty AggregatedResult -> NonEmpty AggregatedResult)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
forall a b.
(a -> b)
-> MaybeT (State [LogEntry]) a -> MaybeT (State [LogEntry]) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NonEmpty AggregatedResult -> NonEmpty AggregatedResult)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult))
-> ((AggregatedResult -> AggregatedResult)
-> NonEmpty AggregatedResult -> NonEmpty AggregatedResult)
-> (AggregatedResult -> AggregatedResult)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AggregatedResult -> AggregatedResult)
-> NonEmpty AggregatedResult -> NonEmpty AggregatedResult
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) AggregatedResult -> AggregatedResult
nubAggregatedSources (MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult))
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
forall a b. (a -> b) -> a -> b
$ MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
impl where
impl :: MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
impl = case [Result] -> ([(Result, String)], [(Result, ResultBody)])
partitionResults ([Result] -> ([(Result, String)], [(Result, ResultBody)]))
-> [Result] -> ([(Result, String)], [(Result, ResultBody)])
forall a b. (a -> b) -> a -> b
$ NonEmpty Result -> [Result]
forall a. NonEmpty a -> [a]
NL.toList NonEmpty Result
results of
([], []) -> String -> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
forall a. HasCallStack => String -> a
error String
"there must be at least one Result"
(lefts :: [(Result, String)]
lefts@((Result, String)
left_head : [(Result, String)]
left_rest), []) -> do
[(Result, String)] -> MaybeT (State [LogEntry]) ()
forall {t :: * -> *}.
Foldable t =>
t (Result, String) -> MaybeT (State [LogEntry]) ()
warnLefts [(Result, String)]
lefts
NonEmpty AggregatedResult
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty AggregatedResult
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult))
-> NonEmpty AggregatedResult
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
forall a b. (a -> b) -> a -> b
$ AggregatedResult -> NonEmpty AggregatedResult
forall a. a -> NonEmpty a
forall (m :: * -> *) a. Monad m => a -> m a
return (AggregatedResult -> NonEmpty AggregatedResult)
-> AggregatedResult -> NonEmpty AggregatedResult
forall a b. (a -> b) -> a -> b
$ AggregatedResult { aggResultIn :: NonEmpty ResultSource
aggResultIn = (Result -> ResultSource
resultIn (Result -> ResultSource)
-> ((Result, String) -> Result) -> (Result, String) -> ResultSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result, String) -> Result
forall a b. (a, b) -> a
fst) ((Result, String) -> ResultSource)
-> NonEmpty (Result, String) -> NonEmpty ResultSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Result, String)
left_head (Result, String) -> [(Result, String)] -> NonEmpty (Result, String)
forall a. a -> [a] -> NonEmpty a
:| [(Result, String)]
left_rest),
aggResultFor :: Query
aggResultFor = Result -> Query
resultFor (Result -> Query) -> Result -> Query
forall a b. (a -> b) -> a -> b
$ (Result, String) -> Result
forall a b. (a, b) -> a
fst ((Result, String) -> Result) -> (Result, String) -> Result
forall a b. (a -> b) -> a -> b
$ (Result, String)
left_head,
aggResultBody :: Either String (ResultBody' (Maybe VersionRange))
aggResultBody = String -> Either String (ResultBody' (Maybe VersionRange))
forall a b. a -> Either a b
Left (String -> Either String (ResultBody' (Maybe VersionRange)))
-> String -> Either String (ResultBody' (Maybe VersionRange))
forall a b. (a -> b) -> a -> b
$ (Result, String) -> String
forall a b. (a, b) -> b
snd ((Result, String) -> String) -> (Result, String) -> String
forall a b. (a -> b) -> a -> b
$ (Result, String)
left_head
}
([(Result, String)]
lefts, ((Result, ResultBody)
right_head : [(Result, ResultBody)]
right_rest)) -> do
[(Result, String)] -> MaybeT (State [LogEntry]) ()
forall {t :: * -> *}.
Foldable t =>
t (Result, String) -> MaybeT (State [LogEntry]) ()
warnLefts [(Result, String)]
lefts
NonEmpty (Result, ResultBody)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
aggregateRights ((Result, ResultBody)
right_head (Result, ResultBody)
-> [(Result, ResultBody)] -> NonEmpty (Result, ResultBody)
forall a. a -> [a] -> NonEmpty a
:| [(Result, ResultBody)]
right_rest)
warnLefts :: t (Result, String) -> MaybeT (State [LogEntry]) ()
warnLefts t (Result, String)
lefts = t (Result, String)
-> ((Result, String) -> MaybeT (State [LogEntry]) ())
-> MaybeT (State [LogEntry]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (Result, String)
lefts (((Result, String) -> MaybeT (State [LogEntry]) ())
-> MaybeT (State [LogEntry]) ())
-> ((Result, String) -> MaybeT (State [LogEntry]) ())
-> MaybeT (State [LogEntry]) ()
forall a b. (a -> b) -> a -> b
$ \(Result
left_ret, String
left_err) -> do
String -> MaybeT (State [LogEntry]) ()
warn (String
"Error for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Result -> String
makeLabel Result
left_ret String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
left_err)
makeLabel :: Result -> String
makeLabel Result
r = String
"Result in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ResultSource -> Text
resultSourceDesc (ResultSource -> Text) -> ResultSource -> Text
forall a b. (a -> b) -> a -> b
$ Result -> ResultSource
resultIn Result
r)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Query -> String
forall a. Show a => a -> String
show (Query -> String) -> Query -> String
forall a b. (a -> b) -> a -> b
$ Result -> Query
resultFor Result
r)
aggregateRights :: NonEmpty (Result, ResultBody)
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
aggregateRights NonEmpty (Result, ResultBody)
rights = do
NonEmpty ResultBody -> MaybeT (State [LogEntry]) ()
checkConsistentBodies (NonEmpty ResultBody -> MaybeT (State [LogEntry]) ())
-> NonEmpty ResultBody -> MaybeT (State [LogEntry]) ()
forall a b. (a -> b) -> a -> b
$ ((Result, ResultBody) -> ResultBody)
-> NonEmpty (Result, ResultBody) -> NonEmpty ResultBody
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Result, ResultBody) -> ResultBody
forall a b. (a, b) -> b
snd NonEmpty (Result, ResultBody)
rights
NonEmpty (NonEmpty (Result, ResultBody))
right_groups <- [NonEmpty (Result, ResultBody)]
-> AggM (NonEmpty (NonEmpty (Result, ResultBody)))
forall a. [a] -> AggM (NonEmpty a)
toNonEmpty ([NonEmpty (Result, ResultBody)]
-> AggM (NonEmpty (NonEmpty (Result, ResultBody))))
-> [NonEmpty (Result, ResultBody)]
-> AggM (NonEmpty (NonEmpty (Result, ResultBody)))
forall a b. (a -> b) -> a -> b
$ ((Result, ResultBody) -> (Result, ResultBody) -> Bool)
-> [(Result, ResultBody)] -> [NonEmpty (Result, ResultBody)]
forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupAllPreservingOrderBy (ResultBody -> ResultBody -> Bool
forall a. ResultBody' a -> ResultBody' a -> Bool
isSameBodyGroup (ResultBody -> ResultBody -> Bool)
-> ((Result, ResultBody) -> ResultBody)
-> (Result, ResultBody)
-> (Result, ResultBody)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Result, ResultBody) -> ResultBody
forall a b. (a, b) -> b
snd) ([(Result, ResultBody)] -> [NonEmpty (Result, ResultBody)])
-> [(Result, ResultBody)] -> [NonEmpty (Result, ResultBody)]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Result, ResultBody) -> [(Result, ResultBody)]
forall a. NonEmpty a -> [a]
NL.toList NonEmpty (Result, ResultBody)
rights
(NonEmpty (Result, ResultBody)
-> MaybeT (State [LogEntry]) AggregatedResult)
-> NonEmpty (NonEmpty (Result, ResultBody))
-> MaybeT (State [LogEntry]) (NonEmpty AggregatedResult)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse NonEmpty (Result, ResultBody)
-> MaybeT (State [LogEntry]) AggregatedResult
aggregateGroup NonEmpty (NonEmpty (Result, ResultBody))
right_groups
aggregateGroup :: NonEmpty (Result, ResultBody)
-> MaybeT (State [LogEntry]) AggregatedResult
aggregateGroup NonEmpty (Result, ResultBody)
group = do
let agg_source :: NonEmpty ResultSource
agg_source = ((Result, ResultBody) -> ResultSource)
-> NonEmpty (Result, ResultBody) -> NonEmpty ResultSource
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Result
ret, ResultBody
_) -> Result -> ResultSource
resultIn Result
ret) NonEmpty (Result, ResultBody)
group
ResultBody' (Maybe VersionRange)
range_body <- Aggregator
-> NonEmpty (String, ResultBody)
-> AggM (ResultBody' (Maybe VersionRange))
aggregateGroupedBodies Aggregator
aggregate
(NonEmpty (String, ResultBody)
-> AggM (ResultBody' (Maybe VersionRange)))
-> NonEmpty (String, ResultBody)
-> AggM (ResultBody' (Maybe VersionRange))
forall a b. (a -> b) -> a -> b
$ ((Result, ResultBody) -> (String, ResultBody))
-> NonEmpty (Result, ResultBody) -> NonEmpty (String, ResultBody)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Result
result, ResultBody
body) -> (Result -> String
makeLabel Result
result String -> String -> String
forall a. [a] -> [a] -> [a]
++ ResultBody -> String
forall {a}. ResultBody' a -> String
makeBodyLabel ResultBody
body, ResultBody
body)) (NonEmpty (Result, ResultBody) -> NonEmpty (String, ResultBody))
-> NonEmpty (Result, ResultBody) -> NonEmpty (String, ResultBody)
forall a b. (a -> b) -> a -> b
$ NonEmpty (Result, ResultBody)
group
AggregatedResult -> MaybeT (State [LogEntry]) AggregatedResult
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (AggregatedResult -> MaybeT (State [LogEntry]) AggregatedResult)
-> AggregatedResult -> MaybeT (State [LogEntry]) AggregatedResult
forall a b. (a -> b) -> a -> b
$ NonEmpty ResultSource
-> ResultBody' (Maybe VersionRange) -> AggregatedResult
makeAggregatedResult NonEmpty ResultSource
agg_source ResultBody' (Maybe VersionRange)
range_body
makeBodyLabel :: ResultBody' a -> String
makeBodyLabel (SimpleResultBody Text
_ a
_) = String
""
makeBodyLabel (CabalResultBody String
_ Target
target [(Text, a)]
_) = String
", target " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Target -> String
forall a. Show a => a -> String
show Target
target
makeAggregatedResult :: NonEmpty ResultSource
-> ResultBody' (Maybe VersionRange) -> AggregatedResult
makeAggregatedResult NonEmpty ResultSource
agg_source ResultBody' (Maybe VersionRange)
range_body =
AggregatedResult { aggResultIn :: NonEmpty ResultSource
aggResultIn = NonEmpty ResultSource
agg_source,
aggResultFor :: Query
aggResultFor = Result -> Query
resultFor (Result -> Query) -> Result -> Query
forall a b. (a -> b) -> a -> b
$ NonEmpty Result -> Result
forall a. NonEmpty a -> a
NL.head NonEmpty Result
results,
aggResultBody :: Either String (ResultBody' (Maybe VersionRange))
aggResultBody = ResultBody' (Maybe VersionRange)
-> Either String (ResultBody' (Maybe VersionRange))
forall a b. b -> Either a b
Right ResultBody' (Maybe VersionRange)
range_body
}
nubAggregatedSources :: AggregatedResult -> AggregatedResult
nubAggregatedSources :: AggregatedResult -> AggregatedResult
nubAggregatedSources AggregatedResult
input = AggregatedResult
input { aggResultIn = NL.nub $ aggResultIn input }
partitionResults :: [Result] -> ([(Result, ErrorMsg)], [(Result, ResultBody)])
partitionResults :: [Result] -> ([(Result, String)], [(Result, ResultBody)])
partitionResults = (Result
-> ([(Result, String)], [(Result, ResultBody)])
-> ([(Result, String)], [(Result, ResultBody)]))
-> ([(Result, String)], [(Result, ResultBody)])
-> [Result]
-> ([(Result, String)], [(Result, ResultBody)])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Result
-> ([(Result, String)], [(Result, ResultBody)])
-> ([(Result, String)], [(Result, ResultBody)])
f ([], []) where
f :: Result
-> ([(Result, String)], [(Result, ResultBody)])
-> ([(Result, String)], [(Result, ResultBody)])
f Result
ret ([(Result, String)]
lefts, [(Result, ResultBody)]
rights) = case Result -> Either String ResultBody
resultBody Result
ret of
Left String
err -> ((Result
ret, String
err) (Result, String) -> [(Result, String)] -> [(Result, String)]
forall a. a -> [a] -> [a]
: [(Result, String)]
lefts, [(Result, ResultBody)]
rights)
Right ResultBody
body -> ([(Result, String)]
lefts, (Result
ret, ResultBody
body) (Result, ResultBody)
-> [(Result, ResultBody)] -> [(Result, ResultBody)]
forall a. a -> [a] -> [a]
: [(Result, ResultBody)]
rights)
checkConsistentBodies :: NonEmpty ResultBody -> AggM ()
checkConsistentBodies :: NonEmpty ResultBody -> MaybeT (State [LogEntry]) ()
checkConsistentBodies NonEmpty ResultBody
bodies = case NonEmpty ResultBody
bodies of
(SimpleResultBody Text
_ Maybe Version
_ :| [ResultBody]
rest) -> All -> MaybeT (State [LogEntry]) ()
expectTrue (All -> MaybeT (State [LogEntry]) ())
-> All -> MaybeT (State [LogEntry]) ()
forall a b. (a -> b) -> a -> b
$ [All] -> All
forall a. Monoid a => [a] -> a
mconcat ([All] -> All) -> [All] -> All
forall a b. (a -> b) -> a -> b
$ (ResultBody -> All) -> [ResultBody] -> [All]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> All
All (Bool -> All) -> (ResultBody -> Bool) -> ResultBody -> All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultBody -> Bool
forall {a}. ResultBody' a -> Bool
isSimple) [ResultBody]
rest
(CabalResultBody String
_ Target
_ [(Text, Maybe Version)]
_ :| [ResultBody]
rest) -> All -> MaybeT (State [LogEntry]) ()
expectTrue (All -> MaybeT (State [LogEntry]) ())
-> All -> MaybeT (State [LogEntry]) ()
forall a b. (a -> b) -> a -> b
$ [All] -> All
forall a. Monoid a => [a] -> a
mconcat ([All] -> All) -> [All] -> All
forall a b. (a -> b) -> a -> b
$ (ResultBody -> All) -> [ResultBody] -> [All]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> All
All (Bool -> All) -> (ResultBody -> Bool) -> ResultBody -> All
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultBody -> Bool
forall {a}. ResultBody' a -> Bool
isCabal) [ResultBody]
rest
where
isSimple :: ResultBody' a -> Bool
isSimple (SimpleResultBody Text
_ a
_) = Bool
True
isSimple ResultBody' a
_ = Bool
False
isCabal :: ResultBody' a -> Bool
isCabal (CabalResultBody String
_ Target
_ [(Text, a)]
_) = Bool
True
isCabal ResultBody' a
_ = Bool
False
expectTrue :: All -> MaybeT (State [LogEntry]) ()
expectTrue (All Bool
True) = () -> MaybeT (State [LogEntry]) ()
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
expectTrue All
_ = String -> MaybeT (State [LogEntry]) ()
forall a. String -> AggM a
bailWithError String
"different types of results are mixed."
isSameBodyGroup :: ResultBody' a -> ResultBody' a -> Bool
isSameBodyGroup :: forall a. ResultBody' a -> ResultBody' a -> Bool
isSameBodyGroup (SimpleResultBody Text
_ a
_) (SimpleResultBody Text
_ a
_) = Bool
True
isSameBodyGroup (CabalResultBody String
fp_a Target
t_a [(Text, a)]
_) (CabalResultBody String
fp_b Target
t_b [(Text, a)]
_) = (String
fp_a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fp_b) Bool -> Bool -> Bool
&& (Target
t_a Target -> Target -> Bool
forall a. Eq a => a -> a -> Bool
== Target
t_b)
isSameBodyGroup ResultBody' a
_ ResultBody' a
_ = Bool
False
pmapInBody :: ResultBody' a -> [(PackageName, a)]
pmapInBody :: forall a. ResultBody' a -> [(Text, a)]
pmapInBody (SimpleResultBody Text
pname a
val) = [(Text
pname, a
val)]
pmapInBody (CabalResultBody String
_ Target
_ [(Text, a)]
pmap) = [(Text, a)]
pmap
aggregateGroupedBodies :: Aggregator
-> NonEmpty (String, ResultBody' (Maybe Version))
-> AggM (ResultBody' (Maybe VersionRange))
aggregateGroupedBodies :: Aggregator
-> NonEmpty (String, ResultBody)
-> AggM (ResultBody' (Maybe VersionRange))
aggregateGroupedBodies Aggregator
aggregate NonEmpty (String, ResultBody)
ver_bodies =
[(Text, Maybe VersionRange)]
-> AggM (ResultBody' (Maybe VersionRange))
forall {a}.
[(Text, a)] -> MaybeT (State [LogEntry]) (ResultBody' a)
makeBody ([(Text, Maybe VersionRange)]
-> AggM (ResultBody' (Maybe VersionRange)))
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
-> AggM (ResultBody' (Maybe VersionRange))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Aggregator
-> NonEmpty (String, [(Text, Maybe Version)])
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
aggregatePackageVersionsM Aggregator
aggregate (NonEmpty (String, [(Text, Maybe Version)])
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)])
-> NonEmpty (String, [(Text, Maybe Version)])
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
forall a b. (a -> b) -> a -> b
$ ((String, ResultBody) -> (String, [(Text, Maybe Version)]))
-> NonEmpty (String, ResultBody)
-> NonEmpty (String, [(Text, Maybe Version)])
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, ResultBody) -> (String, [(Text, Maybe Version)])
forall {a} {a}. (a, ResultBody' a) -> (a, [(Text, a)])
toPmap (NonEmpty (String, ResultBody)
-> NonEmpty (String, [(Text, Maybe Version)]))
-> NonEmpty (String, ResultBody)
-> NonEmpty (String, [(Text, Maybe Version)])
forall a b. (a -> b) -> a -> b
$ NonEmpty (String, ResultBody)
ver_bodies)
where
toPmap :: (a, ResultBody' a) -> (a, [(Text, a)])
toPmap (a
label, ResultBody' a
body) = (a
label, ResultBody' a -> [(Text, a)]
forall a. ResultBody' a -> [(Text, a)]
pmapInBody ResultBody' a
body)
makeBody :: [(Text, a)] -> MaybeT (State [LogEntry]) (ResultBody' a)
makeBody [(Text, a)]
range_pmap = case NonEmpty (String, ResultBody) -> (String, ResultBody)
forall a. NonEmpty a -> a
NL.head NonEmpty (String, ResultBody)
ver_bodies of
(String
_, SimpleResultBody Text
_ Maybe Version
_) -> case [(Text, a)]
range_pmap of
[(Text
pname, a
vrange)] -> ResultBody' a -> MaybeT (State [LogEntry]) (ResultBody' a)
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultBody' a -> MaybeT (State [LogEntry]) (ResultBody' a))
-> ResultBody' a -> MaybeT (State [LogEntry]) (ResultBody' a)
forall a b. (a -> b) -> a -> b
$ Text -> a -> ResultBody' a
forall a. Text -> a -> ResultBody' a
SimpleResultBody Text
pname a
vrange
[(Text, a)]
_ -> String -> MaybeT (State [LogEntry]) (ResultBody' a)
forall a. String -> AggM a
bailWithError String
"Fatal: aggregateGroupedBodies somehow lost SimpleResultBody package pairs."
(String
_, CabalResultBody String
fp Target
target [(Text, Maybe Version)]
_) -> ResultBody' a -> MaybeT (State [LogEntry]) (ResultBody' a)
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultBody' a -> MaybeT (State [LogEntry]) (ResultBody' a))
-> ResultBody' a -> MaybeT (State [LogEntry]) (ResultBody' a)
forall a b. (a -> b) -> a -> b
$ String -> Target -> [(Text, a)] -> ResultBody' a
forall a. String -> Target -> [(Text, a)] -> ResultBody' a
CabalResultBody String
fp Target
target [(Text, a)]
range_pmap
toNonEmpty :: [a] -> AggM (NonEmpty a)
toNonEmpty :: forall a. [a] -> AggM (NonEmpty a)
toNonEmpty [] = MaybeT (State [LogEntry]) (NonEmpty a)
forall a. MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
toNonEmpty (a
h:[a]
rest) = NonEmpty a -> MaybeT (State [LogEntry]) (NonEmpty a)
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (NonEmpty a -> MaybeT (State [LogEntry]) (NonEmpty a))
-> NonEmpty a -> MaybeT (State [LogEntry]) (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ a
h a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
rest
aggregatePackageVersions :: Aggregator
-> NonEmpty (String, [(PackageName, Maybe Version)])
-> (Maybe [(PackageName, Maybe VersionRange)], [LogEntry])
aggregatePackageVersions :: Aggregator
-> NonEmpty (String, [(Text, Maybe Version)])
-> (Maybe [(Text, Maybe VersionRange)], [LogEntry])
aggregatePackageVersions Aggregator
ag NonEmpty (String, [(Text, Maybe Version)])
pm = MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
-> (Maybe [(Text, Maybe VersionRange)], [LogEntry])
forall a. AggM a -> (Maybe a, [LogEntry])
runAggM (MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
-> (Maybe [(Text, Maybe VersionRange)], [LogEntry]))
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
-> (Maybe [(Text, Maybe VersionRange)], [LogEntry])
forall a b. (a -> b) -> a -> b
$ Aggregator
-> NonEmpty (String, [(Text, Maybe Version)])
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
aggregatePackageVersionsM Aggregator
ag NonEmpty (String, [(Text, Maybe Version)])
pm
aggregatePackageVersionsM :: Aggregator
-> NonEmpty (String, [(PackageName, Maybe Version)])
-> AggM [(PackageName, Maybe VersionRange)]
aggregatePackageVersionsM :: Aggregator
-> NonEmpty (String, [(Text, Maybe Version)])
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
aggregatePackageVersionsM Aggregator
aggregate NonEmpty (String, [(Text, Maybe Version)])
pmaps = do
[Text]
ref_plist <- NonEmpty [Text] -> AggM [Text]
consistentPackageList (NonEmpty [Text] -> AggM [Text]) -> NonEmpty [Text] -> AggM [Text]
forall a b. (a -> b) -> a -> b
$ ((String, [(Text, Maybe Version)]) -> [Text])
-> NonEmpty (String, [(Text, Maybe Version)]) -> NonEmpty [Text]
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
_, [(Text, Maybe Version)]
pmap) -> ((Text, Maybe Version) -> Text)
-> [(Text, Maybe Version)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Maybe Version) -> Text
forall a b. (a, b) -> a
fst [(Text, Maybe Version)]
pmap) (NonEmpty (String, [(Text, Maybe Version)]) -> NonEmpty [Text])
-> NonEmpty (String, [(Text, Maybe Version)]) -> NonEmpty [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty (String, [(Text, Maybe Version)])
pmaps
([Maybe VersionRange] -> [(Text, Maybe VersionRange)])
-> MaybeT (State [LogEntry]) [Maybe VersionRange]
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
forall a b.
(a -> b)
-> MaybeT (State [LogEntry]) a -> MaybeT (State [LogEntry]) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> [Maybe VersionRange] -> [(Text, Maybe VersionRange)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ref_plist) (MaybeT (State [LogEntry]) [Maybe VersionRange]
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)])
-> MaybeT (State [LogEntry]) [Maybe VersionRange]
-> MaybeT (State [LogEntry]) [(Text, Maybe VersionRange)]
forall a b. (a -> b) -> a -> b
$ (([Maybe (NonEmpty Version)] -> [Maybe VersionRange])
-> MaybeT (State [LogEntry]) [Maybe (NonEmpty Version)]
-> MaybeT (State [LogEntry]) [Maybe VersionRange]
forall a b.
(a -> b)
-> MaybeT (State [LogEntry]) a -> MaybeT (State [LogEntry]) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Maybe (NonEmpty Version)] -> [Maybe VersionRange])
-> MaybeT (State [LogEntry]) [Maybe (NonEmpty Version)]
-> MaybeT (State [LogEntry]) [Maybe VersionRange])
-> (Aggregator
-> [Maybe (NonEmpty Version)] -> [Maybe VersionRange])
-> Aggregator
-> MaybeT (State [LogEntry]) [Maybe (NonEmpty Version)]
-> MaybeT (State [LogEntry]) [Maybe VersionRange]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (NonEmpty Version) -> Maybe VersionRange)
-> [Maybe (NonEmpty Version)] -> [Maybe VersionRange]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe (NonEmpty Version) -> Maybe VersionRange)
-> [Maybe (NonEmpty Version)] -> [Maybe VersionRange])
-> (Aggregator -> Maybe (NonEmpty Version) -> Maybe VersionRange)
-> Aggregator
-> [Maybe (NonEmpty Version)]
-> [Maybe VersionRange]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Aggregator -> Maybe (NonEmpty Version) -> Maybe VersionRange
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Aggregator
aggregate (MaybeT (State [LogEntry]) [Maybe (NonEmpty Version)]
-> MaybeT (State [LogEntry]) [Maybe VersionRange])
-> MaybeT (State [LogEntry]) [Maybe (NonEmpty Version)]
-> MaybeT (State [LogEntry]) [Maybe VersionRange]
forall a b. (a -> b) -> a -> b
$ (Text -> MaybeT (State [LogEntry]) (Maybe (NonEmpty Version)))
-> [Text] -> MaybeT (State [LogEntry]) [Maybe (NonEmpty Version)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (NonEmpty (String, [(Text, Maybe Version)])
-> Text -> MaybeT (State [LogEntry]) (Maybe (NonEmpty Version))
collectJustVersions NonEmpty (String, [(Text, Maybe Version)])
pmaps) [Text]
ref_plist
type AggM = MaybeT (State.State [LogEntry])
runAggM :: AggM a -> (Maybe a, [LogEntry])
runAggM :: forall a. AggM a -> (Maybe a, [LogEntry])
runAggM = (Maybe a, [LogEntry]) -> (Maybe a, [LogEntry])
forall {a} {a}. (a, [a]) -> (a, [a])
reverseLogs ((Maybe a, [LogEntry]) -> (Maybe a, [LogEntry]))
-> (AggM a -> (Maybe a, [LogEntry]))
-> AggM a
-> (Maybe a, [LogEntry])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State [LogEntry] (Maybe a) -> [LogEntry] -> (Maybe a, [LogEntry]))
-> [LogEntry]
-> State [LogEntry] (Maybe a)
-> (Maybe a, [LogEntry])
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [LogEntry] (Maybe a) -> [LogEntry] -> (Maybe a, [LogEntry])
forall s a. State s a -> s -> (a, s)
State.runState [] (State [LogEntry] (Maybe a) -> (Maybe a, [LogEntry]))
-> (AggM a -> State [LogEntry] (Maybe a))
-> AggM a
-> (Maybe a, [LogEntry])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AggM a -> State [LogEntry] (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT where
reverseLogs :: (a, [a]) -> (a, [a])
reverseLogs (a
ret, [a]
logs) = (a
ret, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
logs)
warn :: String -> AggM ()
warn :: String -> MaybeT (State [LogEntry]) ()
warn String
msg = State [LogEntry] () -> MaybeT (State [LogEntry]) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State [LogEntry] () -> MaybeT (State [LogEntry]) ())
-> State [LogEntry] () -> MaybeT (State [LogEntry]) ()
forall a b. (a -> b) -> a -> b
$ ([LogEntry] -> [LogEntry]) -> State [LogEntry] ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (LogEntry
entry LogEntry -> [LogEntry] -> [LogEntry]
forall a. a -> [a] -> [a]
:) where
entry :: LogEntry
entry = LogEntry { logLevel :: LogLevel
logLevel = LogLevel
LogWarn,
logMessage :: String
logMessage = String
msg
}
bailWithError :: String -> AggM a
bailWithError :: forall a. String -> AggM a
bailWithError String
err_msg = (State [LogEntry] () -> MaybeT (State [LogEntry]) ()
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State [LogEntry] () -> MaybeT (State [LogEntry]) ())
-> State [LogEntry] () -> MaybeT (State [LogEntry]) ()
forall a b. (a -> b) -> a -> b
$ ([LogEntry] -> [LogEntry]) -> State [LogEntry] ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (LogEntry
entry LogEntry -> [LogEntry] -> [LogEntry]
forall a. a -> [a] -> [a]
:)) MaybeT (State [LogEntry]) ()
-> MaybeT (State [LogEntry]) a -> MaybeT (State [LogEntry]) a
forall a b.
MaybeT (State [LogEntry]) a
-> MaybeT (State [LogEntry]) b -> MaybeT (State [LogEntry]) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MaybeT (State [LogEntry]) a
forall a. MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero where
entry :: LogEntry
entry = LogEntry { logLevel :: LogLevel
logLevel = LogLevel
LogError,
logMessage :: String
logMessage = String
err_msg
}
consistentPackageList :: NonEmpty [PackageName] -> AggM [PackageName]
consistentPackageList :: NonEmpty [Text] -> AggM [Text]
consistentPackageList ([Text]
ref_list :| [[Text]]
rest) = ([Text] -> MaybeT (State [LogEntry]) ())
-> [[Text]] -> MaybeT (State [LogEntry]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Text] -> MaybeT (State [LogEntry]) ()
check [[Text]]
rest MaybeT (State [LogEntry]) () -> AggM [Text] -> AggM [Text]
forall a b.
MaybeT (State [LogEntry]) a
-> MaybeT (State [LogEntry]) b -> MaybeT (State [LogEntry]) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Text] -> AggM [Text]
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
ref_list where
check :: [Text] -> MaybeT (State [LogEntry]) ()
check [Text]
cur_list = if [Text]
cur_list [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text]
ref_list
then () -> MaybeT (State [LogEntry]) ()
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else String -> MaybeT (State [LogEntry]) ()
forall a. String -> AggM a
bailWithError ( String
"package lists are inconsistent:"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" reference list: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
ref_list
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", inconsitent list: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
cur_list
)
collectJustVersions :: NonEmpty (String, [(PackageName, Maybe Version)])
-> PackageName
-> AggM (Maybe (NonEmpty Version))
collectJustVersions :: NonEmpty (String, [(Text, Maybe Version)])
-> Text -> MaybeT (State [LogEntry]) (Maybe (NonEmpty Version))
collectJustVersions NonEmpty (String, [(Text, Maybe Version)])
pmaps Text
pname = ([Version] -> Maybe (NonEmpty Version))
-> MaybeT (State [LogEntry]) [Version]
-> MaybeT (State [LogEntry]) (Maybe (NonEmpty Version))
forall a b.
(a -> b)
-> MaybeT (State [LogEntry]) a -> MaybeT (State [LogEntry]) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Version] -> Maybe (NonEmpty Version)
forall {a}. [a] -> Maybe (NonEmpty a)
toMaybeNonEmpty (MaybeT (State [LogEntry]) [Version]
-> MaybeT (State [LogEntry]) (Maybe (NonEmpty Version)))
-> MaybeT (State [LogEntry]) [Version]
-> MaybeT (State [LogEntry]) (Maybe (NonEmpty Version))
forall a b. (a -> b) -> a -> b
$ ((String, [(Text, Maybe Version)])
-> [Version] -> MaybeT (State [LogEntry]) [Version])
-> [Version]
-> NonEmpty (String, [(Text, Maybe Version)])
-> MaybeT (State [LogEntry]) [Version]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (String, [(Text, Maybe Version)])
-> [Version] -> MaybeT (State [LogEntry]) [Version]
forall {a}.
(String, [(Text, Maybe a)]) -> [a] -> MaybeT (State [LogEntry]) [a]
f [] NonEmpty (String, [(Text, Maybe Version)])
pmaps where
f :: (String, [(Text, Maybe a)]) -> [a] -> MaybeT (State [LogEntry]) [a]
f (String
label, [(Text, Maybe a)]
pmap) [a]
acc = case Text -> [(Text, Maybe a)] -> Maybe (Maybe a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
pname [(Text, Maybe a)]
pmap of
Just (Just a
v) -> [a] -> MaybeT (State [LogEntry]) [a]
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc)
Maybe (Maybe a)
_ -> String -> MaybeT (State [LogEntry]) ()
warn (String
"missing version for package "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
label) MaybeT (State [LogEntry]) ()
-> MaybeT (State [LogEntry]) [a] -> MaybeT (State [LogEntry]) [a]
forall a b.
MaybeT (State [LogEntry]) a
-> MaybeT (State [LogEntry]) b -> MaybeT (State [LogEntry]) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [a] -> MaybeT (State [LogEntry]) [a]
forall a. a -> MaybeT (State [LogEntry]) a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
acc
toMaybeNonEmpty :: [a] -> Maybe (NonEmpty a)
toMaybeNonEmpty [] = Maybe (NonEmpty a)
forall a. Maybe a
Nothing
toMaybeNonEmpty (a
h : [a]
rest) = NonEmpty a -> Maybe (NonEmpty a)
forall a. a -> Maybe a
Just (NonEmpty a -> Maybe (NonEmpty a))
-> NonEmpty a -> Maybe (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ a
h a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
rest