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 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 = 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
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
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]
makeUpper (a
x : a
y : [a]
_) = [a
x, a
y forall a. Num a => a -> a -> a
+ a
1]
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
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
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 = 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
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