-- |
-- Module: Staversion.Internal.Aggregate
-- Description: aggregation of multiple versions
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. End-users should not use it.__
module Staversion.Internal.Aggregate
       ( -- * Top-level function
         aggregateResults,
         -- * Aggregators
         Aggregator,
         VersionRange,
         showVersionRange,
         aggOr,
         aggPvpMajor,
         aggPvpMinor,
         -- * Utility
         groupAllPreservingOrderBy,
         -- * Low-level functions
         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


-- | Aggregate some 'Version's into a 'VersionRange'.
type Aggregator = NonEmpty Version -> VersionRange

-- | Let Cabal convert 'VersionRange' to 'String'
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)
                             -- ^ The comparator that determines if the two elements are in the same group.
                             -- This comparator must be transitive, like '(==)'.
                          -> [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


-- | Aggregator of ORed versions.
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

-- | Aggregate versions to the range that the versions cover in a PVP
-- sense. This aggregator sets the upper bound to a major version,
-- which means it assumes major-version bump is not
-- backward-compatible.
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] -- because [x] and [x,0] is equivalent
  makeUpper (a
x : a
y : [a]
_) = [a
x, a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
1]

-- | Aggregate versions to the range that versions cover in a PVP
-- sense. This aggregator sets the upper bound to a minor version,
-- which means it assumes minor-version bump is not
-- backward-compatible.
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

-- | Aggregate 'Result's with the given 'Aggregator'. It first groups
-- 'Result's based on its 'resultFor' field, and then each group is
-- aggregated into an 'AggregatedResult'.
--
-- If it fails, it returns an empty list of 'AggregatedResult'. It
-- also returns a list of 'LogEntry's to report warnings and errors.
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

-- | Aggregate one or more maps between 'PackageName' and 'Version'.
--
-- The input 'Maybe' 'Version's should all be 'Just'. 'Nothing' version
-- is warned and ignored. If the input versions are all 'Nothing', the
-- result version range is 'Nothing'.
--
-- The 'PackageName' lists in the input must be consistent (i.e. they
-- all must be the same list.) If not, it returns 'Nothing' map and an
-- error is logged.
aggregatePackageVersions :: Aggregator
                         -> NonEmpty (String, [(PackageName, Maybe Version)])
                         -- ^ (@label@, @version map@). @label@ is used for error logs.
                         -> (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

-- | Aggregateion monad
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