-- |
-- 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 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 = 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 forall a. a -> [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 forall a. a -> [a] -> NonEmpty a
:| (a
cur_head forall a. a -> [a] -> [a]
: [a]
cur_rest)) forall a. a -> [a] -> [a]
: [NonEmpty a]
heads) forall a. [a] -> [a] -> [a]
++ [NonEmpty a]
rest 
      else [NonEmpty a] -> [NonEmpty a] -> [NonEmpty a]
update ([NonEmpty a]
heads forall a. [a] -> [a] -> [a]
++ [NonEmpty a
cur]) [NonEmpty a]
rest


-- | Aggregator of ORed versions.
aggOr :: Aggregator
aggOr :: Aggregator
aggOr = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 VersionRange -> VersionRange -> VersionRange
V.unionVersionRanges forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> VersionRange
V.thisVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => NonEmpty a -> NonEmpty a
NL.nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ forall {a}. Num a => [a] -> [a]
makeUpper where
  makeUpper :: [a] -> [a]
makeUpper [] = 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 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 forall a b. (a -> b) -> a -> b
$ forall {a}. Num a => [a] -> [a]
makeUpper where
  makeUpper :: [a] -> [a]
makeUpper [] = 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 VersionRange -> VersionRange -> VersionRange
V.unionVersionRanges forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> VersionRange
toRange forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => NonEmpty a -> NonEmpty a
NL.nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => NonEmpty a -> NonEmpty a
NL.sort where
  toRange :: Version -> VersionRange
toRange Version
v = VersionIntervals -> VersionRange
V.fromVersionIntervals 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 forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
normalizeTralingZeroes forall a b. (a -> b) -> a -> b
$ Version -> [Int]
V.versionNumbers Version
v
    vu :: Version
vu = [Int] -> Version
V.mkVersion forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
makeUpper 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 forall a. a -> [a] -> [a]
: (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall {a}. (Eq a, Num a) => [[a]] -> [[a]]
dropTrailingZeros forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [[a]]
List.group [Int]
rest) where
  dropTrailingZeros :: [[a]] -> [[a]]
dropTrailingZeros [] = []
  dropTrailingZeros [[a]]
groups = if forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Eq a => a -> a -> Bool
== a
0) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [[a]]
groups
                             then forall a. [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 = forall {a}. AggM [a] -> ([a], [LogEntry])
unMonad
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NonEmpty Result -> AggM [AggregatedResult]
aggregateInSameQuery'
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupAllPreservingOrderBy (forall a. Eq a => a -> a -> 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 = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. NonEmpty a -> [a]
NL.toList forall a b. (a -> b) -> a -> b
$ Aggregator -> NonEmpty Result -> AggM (NonEmpty AggregatedResult)
aggregateInSameQuery Aggregator
aggregate NonEmpty Result
results)
                                    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return []
    unMonad :: AggM [a] -> ([a], [LogEntry])
unMonad = (\(Maybe [a]
magg, [LogEntry]
logs) -> (forall {a}. Maybe [a] -> [a]
toList Maybe [a]
magg, [LogEntry]
logs)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> AggM (NonEmpty AggregatedResult)
aggregateInSameQuery Aggregator
aggregate NonEmpty Result
results = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) AggregatedResult -> AggregatedResult
nubAggregatedSources forall a b. (a -> b) -> a -> b
$ AggM (NonEmpty AggregatedResult)
impl where
  impl :: AggM (NonEmpty AggregatedResult)
impl = case [Result] -> ([(Result, String)], [(Result, ResultBody)])
partitionResults forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NL.toList NonEmpty Result
results of
    ([], []) -> 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
      forall {t :: * -> *}.
Foldable t =>
t (Result, String) -> MaybeT (State [LogEntry]) ()
warnLefts [(Result, String)]
lefts
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AggregatedResult { aggResultIn :: NonEmpty ResultSource
aggResultIn = (Result -> ResultSource
resultIn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Result, String)
left_head forall a. a -> [a] -> NonEmpty a
:| [(Result, String)]
left_rest),
                                           aggResultFor :: Query
aggResultFor = Result -> Query
resultFor forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ (Result, String)
left_head,
                                           aggResultBody :: Either String (ResultBody' (Maybe VersionRange))
aggResultBody = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ (Result, String)
left_head
                                         }
    ([(Result, String)]
lefts, ((Result, ResultBody)
right_head : [(Result, ResultBody)]
right_rest)) -> do
      forall {t :: * -> *}.
Foldable t =>
t (Result, String) -> MaybeT (State [LogEntry]) ()
warnLefts [(Result, String)]
lefts
      NonEmpty (Result, ResultBody) -> AggM (NonEmpty AggregatedResult)
aggregateRights ((Result, ResultBody)
right_head forall a. a -> [a] -> NonEmpty a
:| [(Result, ResultBody)]
right_rest)
  warnLefts :: t (Result, String) -> MaybeT (State [LogEntry]) ()
warnLefts t (Result, String)
lefts = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ t (Result, String)
lefts forall a b. (a -> b) -> a -> b
$ \(Result
left_ret, String
left_err) -> do
    String -> MaybeT (State [LogEntry]) ()
warn (String
"Error for " forall a. [a] -> [a] -> [a]
++ Result -> String
makeLabel Result
left_ret forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
left_err)
  makeLabel :: Result -> String
makeLabel Result
r = String
"Result in " forall a. [a] -> [a] -> [a]
++ (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ ResultSource -> Text
resultSourceDesc forall a b. (a -> b) -> a -> b
$ Result -> ResultSource
resultIn Result
r)
                forall a. [a] -> [a] -> [a]
++ String
", for " forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Result -> Query
resultFor Result
r)
  aggregateRights :: NonEmpty (Result, ResultBody) -> AggM (NonEmpty AggregatedResult)
aggregateRights NonEmpty (Result, ResultBody)
rights = do
    NonEmpty ResultBody -> MaybeT (State [LogEntry]) ()
checkConsistentBodies forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd NonEmpty (Result, ResultBody)
rights
    NonEmpty (NonEmpty (Result, ResultBody))
right_groups <- forall a. [a] -> AggM (NonEmpty a)
toNonEmpty forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupAllPreservingOrderBy (forall a. ResultBody' a -> ResultBody' a -> Bool
isSameBodyGroup forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NL.toList NonEmpty (Result, ResultBody)
rights
    forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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 = 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
                  forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Result
result, ResultBody
body) -> (Result -> String
makeLabel Result
result forall a. [a] -> [a] -> [a]
++ forall {a}. ResultBody' a -> String
makeBodyLabel ResultBody
body, ResultBody
body)) forall a b. (a -> b) -> a -> b
$ NonEmpty (Result, ResultBody)
group
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 " forall a. [a] -> [a] -> [a]
++ 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 forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NL.head NonEmpty Result
results,
                       aggResultBody :: Either String (ResultBody' (Maybe VersionRange))
aggResultBody = 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 :: NonEmpty ResultSource
aggResultIn = forall a. Eq a => NonEmpty a -> NonEmpty a
NL.nub forall a b. (a -> b) -> a -> b
$ AggregatedResult -> NonEmpty ResultSource
aggResultIn AggregatedResult
input }

partitionResults :: [Result] -> ([(Result, ErrorMsg)], [(Result, ResultBody)])
partitionResults :: [Result] -> ([(Result, String)], [(Result, ResultBody)])
partitionResults = 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) forall a. a -> [a] -> [a]
: [(Result, String)]
lefts, [(Result, ResultBody)]
rights)
    Right ResultBody
body -> ([(Result, String)]
lefts, (Result
ret, ResultBody
body) 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 forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Bool -> All
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. ResultBody' a -> Bool
isSimple) [ResultBody]
rest
  (CabalResultBody String
_ Target
_ [(Text, Maybe Version)]
_ :| [ResultBody]
rest) -> All -> MaybeT (State [LogEntry]) ()
expectTrue forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Bool -> All
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    expectTrue All
_ = 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 forall a. Eq a => a -> a -> Bool
== String
fp_b) Bool -> Bool -> Bool
&& (Target
t_a 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 =
  forall {a}.
[(Text, a)] -> MaybeT (State [LogEntry]) (ResultBody' a)
makeBody forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Aggregator
-> NonEmpty (String, [(Text, Maybe Version)])
-> AggM [(Text, Maybe VersionRange)]
aggregatePackageVersionsM Aggregator
aggregate forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a}. (a, ResultBody' a) -> (a, [(Text, a)])
toPmap 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, forall a. ResultBody' a -> [(Text, a)]
pmapInBody ResultBody' a
body)
    makeBody :: [(Text, a)] -> MaybeT (State [LogEntry]) (ResultBody' a)
makeBody [(Text, a)]
range_pmap = case 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)] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Text -> a -> ResultBody' a
SimpleResultBody Text
pname a
vrange
        [(Text, a)]
_ -> forall a. String -> AggM a
bailWithError String
"Fatal: aggregateGroupedBodies somehow lost SimpleResultBody package pairs."
      (String
_, CabalResultBody String
fp Target
target [(Text, Maybe Version)]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 [] = forall (m :: * -> *) a. MonadPlus m => m a
mzero
toNonEmpty (a
h:[a]
rest) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ a
h 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 = forall a. AggM a -> (Maybe a, [LogEntry])
runAggM forall a b. (a -> b) -> a -> b
$ Aggregator
-> NonEmpty (String, [(Text, Maybe Version)])
-> AggM [(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)])
-> AggM [(Text, Maybe VersionRange)]
aggregatePackageVersionsM Aggregator
aggregate NonEmpty (String, [(Text, Maybe Version)])
pmaps = do
  [Text]
ref_plist <- NonEmpty [Text] -> AggM [Text]
consistentPackageList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
_, [(Text, Maybe Version)]
pmap) -> forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, Maybe Version)]
pmap) forall a b. (a -> b) -> a -> b
$ NonEmpty (String, [(Text, Maybe Version)])
pmaps
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
ref_plist) forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Aggregator
aggregate forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NonEmpty (String, [(Text, Maybe Version)])
-> Text -> AggM (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 = forall {a} {a}. (a, [a]) -> (a, [a])
reverseLogs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
State.runState [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT where
  reverseLogs :: (a, [a]) -> (a, [a])
reverseLogs (a
ret, [a]
logs) = (a
ret, forall a. [a] -> [a]
reverse [a]
logs)

warn :: String -> AggM ()
warn :: String -> MaybeT (State [LogEntry]) ()
warn String
msg = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (LogEntry
entry 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 = (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (LogEntry
entry forall a. a -> [a] -> [a]
:)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Text] -> MaybeT (State [LogEntry]) ()
check [[Text]]
rest forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 forall a. Eq a => a -> a -> Bool
== [Text]
ref_list
                   then forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   else forall a. String -> AggM a
bailWithError ( String
"package lists are inconsistent:"
                                        forall a. [a] -> [a] -> [a]
++ String
" reference list: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Text]
ref_list
                                        forall a. [a] -> [a] -> [a]
++ String
", inconsitent list: " forall a. [a] -> [a] -> [a]
++ 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 -> AggM (Maybe (NonEmpty Version))
collectJustVersions NonEmpty (String, [(Text, Maybe Version)])
pmaps Text
pname = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. [a] -> Maybe (NonEmpty a)
toMaybeNonEmpty forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM 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 forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
pname [(Text, Maybe a)]
pmap of
                         Just (Just a
v) -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
v forall a. a -> [a] -> [a]
: [a]
acc)
                         Maybe (Maybe a)
_ -> String -> MaybeT (State [LogEntry]) ()
warn (String
"missing version for package "
                                    forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
pname forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
label) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [a]
acc
  toMaybeNonEmpty :: [a] -> Maybe (NonEmpty a)
toMaybeNonEmpty [] = forall a. Maybe a
Nothing
  toMaybeNonEmpty (a
h : [a]
rest) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ a
h forall a. a -> [a] -> NonEmpty a
:| [a]
rest