staversion 0.1.3.2 → 0.1.4.0
raw patch · 15 files changed
+970/−122 lines, 15 filesdep +Cabaldep +ansi-wl-pprintdep +prettydep ~hspecdep ~megaparsec
Dependencies added: Cabal, ansi-wl-pprint, pretty, semigroups
Dependency ranges changed: hspec, megaparsec
Files
- ChangeLog.md +7/−0
- README.md +37/−4
- src/Staversion/Internal/Aggregate.hs +239/−0
- src/Staversion/Internal/Cabal.hs +8/−1
- src/Staversion/Internal/Command.hs +54/−4
- src/Staversion/Internal/Exec.hs +58/−38
- src/Staversion/Internal/Format.hs +36/−24
- src/Staversion/Internal/Log.hs +11/−2
- src/Staversion/Internal/Result.hs +54/−9
- staversion.cabal +11/−4
- test/NetworkTest.hs +9/−7
- test/Staversion/Internal/AggregateSpec.hs +354/−0
- test/Staversion/Internal/ExecSpec.hs +40/−17
- test/Staversion/Internal/FormatSpec.hs +51/−11
- test/Staversion/Internal/TestUtil.hs +1/−1
ChangeLog.md view
@@ -1,5 +1,12 @@ # Revision history for staversion +## 0.1.4.0 -- 2017-04-08++* Add `--aggregate` option, which aggregates versions in different LTS resolvers.+ There are `or` and `pvp` aggregators.+* Bug fix: when it fails to load a given .cabal file, now it continues processing the next target.++ ## 0.1.3.2 -- 2017-01-05 * Fix dependency lower bound for `base`.
README.md view
@@ -26,15 +26,15 @@ conduit ==1.2.6.1, base ==4.8.2.0 - ------ lts-6- conduit ==1.2.8,+ ------ lts-6 (lts-6.31)+ conduit ==1.2.9.1, base ==4.8.2.0 staversion first reads build plan YAML files that are stored locally in your computer, then it tries to fetch them over network. ## Package version in Hackage -You can also look up the latest version numbers hosted on hackage.+You can also look up the latest version numbers hosted on hackage with `--hackage` (`-H`) option. $ staversion --hackage conduit base ------ latest in hackage@@ -67,10 +67,43 @@ (snip) +## Package version ranges over different resolvers +With `--aggregate` (`-a`) option, you can aggregate version numbers in different resolvers into a version range using the given aggregation rule.++For example, `or` rule just concatenates versions with `(||)` condition.++ $ staversion --aggregate or -r lts-5 -r lts-6 -r lts-7 -H aeson+ ------ lts-5 (lts-5.18), lts-6 (lts-6.31), lts-7 (lts-7.20), latest in hackage+ aeson ==0.9.0.1 || ==0.11.3.0 || ==1.1.1.0++`pvp` rule aggregates versions into a range that should be compatible with the obtained versions in terms of PVP (Package Versioning Policy.)++ $ staversion --aggregate pvp -r lts-5 -r lts-6 -r lts-7 -H aeson+ ------ lts-5 (lts-5.18), lts-6 (lts-6.31), lts-7 (lts-7.20), latest in hackage+ aeson >=0.9.0.1 && <0.10 || >=0.11.3.0 && <0.12 || >=1.1.1.0 && <1.2++You can use `--aggregate` option with querying .cabal files.++ $ staversion --aggregate pvp -r lts-6 -r lts-7 -r lts-8 staversion.cabal + ------ lts-6 (lts-6.31), lts-7 (lts-7.20), lts-8 (lts-8.8)+ -- staversion.cabal - library+ base >=4.8.2.0 && <4.9 || >=4.9.0.0 && <4.10,+ unordered-containers >=0.2.7.2 && <0.3,+ aeson >=0.11.3.0 && <0.12 || >=1.0.2.1 && <1.1,+ text >=1.2.2.1 && <1.3,+ bytestring >=0.10.6.0 && <0.11,+ yaml >=0.8.22 && <0.9,+ filepath >=1.4.0.0 && <1.5,+ directory >=1.2.2.0 && <1.3 || >=1.3.0.0 && <1.4,+ optparse-applicative >=0.12.1.0 && <0.13 || >=0.13.2.0 && <0.14,+ containers >=0.5.6.2 && <0.6,+ + (snip)++ ## TODO -- Show version number ranges supported by the given resolvers. - Cache build plans in some local storage (SQLite?) ## Author
+ src/Staversion/Internal/Aggregate.hs view
@@ -0,0 +1,239 @@+-- |+-- 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,+ aggPvp,+ -- * 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 Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NL+import Data.Text (unpack)+import Data.Traversable (traverse)+import Data.Version (Version, makeVersion)+import Distribution.Version (VersionRange)+import qualified Distribution.Version as V+import qualified Distribution.Text as DT+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)++-- | Aggregate some 'Version's into a 'VersionRange'.+type Aggregator = NonEmpty Version -> VersionRange++showVersionRange :: VersionRange -> String+showVersionRange = Pretty.render . DT.disp++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 sameGroup = foldr f [] where+ f item acc = update [] acc where+ update heads [] = (item :| []) : heads+ update heads (cur@(cur_head :| cur_rest) : rest) =+ if sameGroup item cur_head+ then ((item :| (cur_head : cur_rest)) : heads) ++ rest + else update (heads ++ [cur]) rest+++-- | Aggregator of ORed versions.+aggOr :: Aggregator+aggOr = foldr1 V.unionVersionRanges . fmap V.thisVersion . NL.nub . NL.sort++-- | Aggregate versions to the range that the versions cover in a+-- (strict) PVP sense.+aggPvp :: Aggregator+aggPvp = V.simplifyVersionRange . foldr1 V.unionVersionRanges . fmap toRange . NL.nub . NL.sort where+ toRange v = fromJust $ fmap V.fromVersionIntervals $ V.mkVersionIntervals [(V.LowerBound v V.InclusiveBound, V.UpperBound vu V.ExclusiveBound)] where+ vu = makeVersion $ case V.versionBranch v of+ [] -> error "versionBranch must not be empty."+ [x] -> [x, 0]+ (x : y : _) -> [x, y + 1]++-- | 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 aggregate = unMonad+ . fmap concat+ . mapM aggregateInSameQuery'+ . groupAllPreservingOrderBy ((==) `on` resultFor)+ where+ aggregateInSameQuery' results = (fmap NL.toList $ aggregateInSameQuery aggregate results)+ <|> return []+ unMonad = (\(magg, logs) -> (toList magg, logs)) . runAggM+ toList Nothing = []+ toList (Just list) = list++aggregateInSameQuery :: Aggregator -> NonEmpty Result -> AggM (NonEmpty AggregatedResult)+aggregateInSameQuery aggregate results = (fmap . fmap) nubAggregatedSources $ impl where+ impl = case partitionResults $ NL.toList results of+ ([], []) -> error "there must be at least one Result"+ (lefts@(left_head : left_rest), []) -> do+ warnLefts lefts+ return $ return $ AggregatedResult { aggResultIn = (resultIn . fst) <$> (left_head :| left_rest),+ aggResultFor = resultFor $ fst $ left_head,+ aggResultBody = Left $ snd $ left_head+ }+ (lefts, (right_head : right_rest)) -> do+ warnLefts lefts+ aggregateRights (right_head :| right_rest)+ warnLefts lefts = forM_ lefts $ \(left_ret, left_err) -> do+ warn ("Error for " ++ makeLabel left_ret ++ ": " ++ left_err)+ makeLabel r = "Result in " ++ (unpack $ resultSourceDesc $ resultIn r)+ ++ ", for " ++ (show $ resultFor r)+ aggregateRights rights = do+ checkConsistentBodies $ fmap snd rights+ right_groups <- toNonEmpty $ groupAllPreservingOrderBy (isSameBodyGroup `on` snd) $ NL.toList rights+ traverse aggregateGroup right_groups+ aggregateGroup group = do+ let agg_source = fmap (\(ret, _) -> resultIn ret) group+ range_body <- aggregateGroupedBodies aggregate+ $ fmap (\(result, body) -> (makeLabel result ++ makeBodyLabel body, body)) $ group+ return $ makeAggregatedResult agg_source range_body+ makeBodyLabel (SimpleResultBody _ _) = ""+ makeBodyLabel (CabalResultBody _ target _) = ", target " ++ show target+ makeAggregatedResult agg_source range_body =+ AggregatedResult { aggResultIn = agg_source,+ aggResultFor = resultFor $ NL.head results,+ aggResultBody = Right range_body+ }++nubAggregatedSources :: AggregatedResult -> AggregatedResult+nubAggregatedSources input = input { aggResultIn = NL.nub $ aggResultIn input }++partitionResults :: [Result] -> ([(Result, ErrorMsg)], [(Result, ResultBody)])+partitionResults = foldr f ([], []) where+ f ret (lefts, rights) = case resultBody ret of+ Left err -> ((ret, err) : lefts, rights)+ Right body -> (lefts, (ret, body) : rights)++checkConsistentBodies :: NonEmpty ResultBody -> AggM ()+checkConsistentBodies bodies = case bodies of+ (SimpleResultBody _ _ :| rest) -> expectTrue $ mconcat $ map (All . isSimple) rest+ (CabalResultBody _ _ _ :| rest) -> expectTrue $ mconcat $ map (All . isCabal) rest+ where+ isSimple (SimpleResultBody _ _) = True+ isSimple _ = False+ isCabal (CabalResultBody _ _ _) = True+ isCabal _ = False+ expectTrue (All True) = return ()+ expectTrue _ = bailWithError "different types of results are mixed."++isSameBodyGroup :: ResultBody' a -> ResultBody' a -> Bool+isSameBodyGroup (SimpleResultBody _ _) (SimpleResultBody _ _) = True+isSameBodyGroup (CabalResultBody fp_a t_a _) (CabalResultBody fp_b t_b _) = (fp_a == fp_b) && (t_a == t_b)+isSameBodyGroup _ _ = False++pmapInBody :: ResultBody' a -> [(PackageName, a)]+pmapInBody (SimpleResultBody pname val) = [(pname, val)]+pmapInBody (CabalResultBody _ _ pmap) = pmap++aggregateGroupedBodies :: Aggregator+ -> NonEmpty (String, ResultBody' (Maybe Version))+ -> AggM (ResultBody' (Maybe VersionRange))+aggregateGroupedBodies aggregate ver_bodies =+ makeBody =<< (aggregatePackageVersionsM aggregate $ fmap toPmap $ ver_bodies)+ where+ toPmap (label, body) = (label, pmapInBody body)+ makeBody range_pmap = case NL.head ver_bodies of+ (_, SimpleResultBody _ _) -> case range_pmap of+ [(pname, vrange)] -> return $ SimpleResultBody pname vrange+ _ -> bailWithError "Fatal: aggregateGroupedBodies somehow lost SimpleResultBody package pairs."+ (_, CabalResultBody fp target _) -> return $ CabalResultBody fp target range_pmap++toNonEmpty :: [a] -> AggM (NonEmpty a)+toNonEmpty [] = mzero+toNonEmpty (h:rest) = return $ h :| 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 ag pm = runAggM $ aggregatePackageVersionsM ag pm+++aggregatePackageVersionsM :: Aggregator+ -> NonEmpty (String, [(PackageName, Maybe Version)])+ -> AggM [(PackageName, Maybe VersionRange)]+aggregatePackageVersionsM aggregate pmaps = do+ ref_plist <- consistentPackageList $ fmap (\(_, pmap) -> map fst pmap) $ pmaps+ fmap (zip ref_plist) $ (fmap . fmap . fmap) aggregate $ mapM (collectJustVersions pmaps) ref_plist++-- | Aggregateion monad+type AggM = MaybeT (State.State [LogEntry])++runAggM :: AggM a -> (Maybe a, [LogEntry])+runAggM = reverseLogs . flip State.runState [] . runMaybeT where+ reverseLogs (ret, logs) = (ret, reverse logs)++warn :: String -> AggM ()+warn msg = lift $ State.modify (entry :) where+ entry = LogEntry { logLevel = LogWarn,+ logMessage = msg+ }++bailWithError :: String -> AggM a+bailWithError err_msg = (lift $ State.modify (entry :)) >> mzero where+ entry = LogEntry { logLevel = LogError,+ logMessage = err_msg+ }++consistentPackageList :: NonEmpty [PackageName] -> AggM [PackageName]+consistentPackageList (ref_list :| rest) = mapM_ check rest >> return ref_list where+ check cur_list = if cur_list == ref_list+ then return ()+ else bailWithError ( "package lists are inconsistent:"+ ++ " reference list: " ++ show ref_list+ ++ ", inconsitent list: " ++ show cur_list+ )++collectJustVersions :: NonEmpty (String, [(PackageName, Maybe Version)])+ -> PackageName+ -> AggM (Maybe (NonEmpty Version))+collectJustVersions pmaps pname = fmap toMaybeNonEmpty $ foldrM f [] pmaps where+ f (label, pmap) acc = case lookup pname pmap of+ Just (Just v) -> return (v : acc)+ _ -> warn ("missing version for package "+ ++ show pname ++ ": " ++ label) >> return acc+ toMaybeNonEmpty [] = Nothing+ toMaybeNonEmpty (h : rest) = Just $ h :| rest
src/Staversion/Internal/Cabal.hs view
@@ -11,6 +11,8 @@ ) where import Control.Applicative ((<*), (*>), (<|>), (<*>), many, some)+import Control.Exception (IOException)+import qualified Control.Exception as Exception import Control.Monad (void, mzero, forM) import Data.Bifunctor (first) import Data.Char (isAlpha, isDigit, toLower, isSpace)@@ -40,7 +42,12 @@ } deriving (Show,Eq,Ord) loadCabalFile :: FilePath -> IO (Either ErrorMsg [BuildDepends])-loadCabalFile cabal_filepath = first show <$> P.runParser (cabalParser <* P.eof) cabal_filepath <$> TIO.readFile cabal_filepath+loadCabalFile cabal_filepath = handleIOError $ first show <$> parseContent <$> readContent where+ readContent = TIO.readFile cabal_filepath+ parseContent = P.runParser (cabalParser <* P.eof) cabal_filepath+ handleIOError = Exception.handle h where+ h :: IOException -> IO (Either ErrorMsg [BuildDepends])+ h = return . Left . show isLineSpace :: Char -> Bool isLineSpace ' ' = True
src/Staversion/Internal/Command.hs view
@@ -10,14 +10,18 @@ ) where import Control.Applicative ((<$>), (<*>), optional, some, (<|>))-import Data.Monoid (mconcat)+import Data.Function (on)+import Data.Monoid (mconcat, (<>)) import Data.Text (pack) import Data.Version (showVersion) import qualified Options.Applicative as Opt import qualified Paths_staversion as MyInfo import System.Directory (getHomeDirectory) import System.FilePath ((</>))+import qualified Text.PrettyPrint.ANSI.Leijen as Pretty +import Staversion.Internal.Aggregate (Aggregator)+import qualified Staversion.Internal.Aggregate as Agg import Staversion.Internal.Log ( LogLevel(..), Logger(loggerThreshold), defaultLogger )@@ -39,9 +43,11 @@ -- ^ package sources to search commQueries :: [Query], -- ^ package queries- commAllowNetwork :: Bool+ commAllowNetwork :: Bool, -- ^ if 'True', it accesses the Internet to query build plans etc.- } deriving (Show)+ commAggregator :: Maybe Aggregator+ -- ^ if 'Just', do aggregation over the results.+ } -- | Default values for 'Command'. data DefCommand = DefCommand { defBuildPlanDir :: FilePath@@ -55,7 +61,7 @@ commandParser :: DefCommand -> Opt.Parser Command-commandParser def_comm = Command <$> build_plan_dir <*> logger <*> sources <*> queries <*> network where+commandParser def_comm = Command <$> build_plan_dir <*> logger <*> sources <*> queries <*> network <*> aggregate where logger = makeLogger <$> is_verbose makeLogger True = defaultLogger { loggerThreshold = Just LogDebug } makeLogger False = defaultLogger@@ -95,6 +101,50 @@ no_network = Opt.switch $ mconcat [ Opt.long "no-network", Opt.help "Forbid network access." ]+ aggregate = optional $ Opt.option (maybeReader "AGGREGATOR" parseAggregator)+ $ mconcat [ Opt.long "aggregate",+ Opt.short 'a',+ Opt.metavar "AGGREGATOR",+ Opt.helpDoc $ Just $ docAggregators "AGGREGATOR"+ ]++maybeReader :: String -> (String -> Maybe a) -> Opt.ReadM a+maybeReader metavar mfunc = do+ got <- Opt.str+ case mfunc got of+ Nothing -> Opt.readerError ("Unknown " ++ metavar ++ ": " ++ got)+ Just v -> return v++data AggregatorSpec =+ AggregatorSpec { aggSpecFunc :: Aggregator,+ aggSpecSymbol :: String,+ aggSpecDesc :: String+ }++aggregators :: [AggregatorSpec]+aggregators = [ AggregatorSpec Agg.aggOr "or" "concatenate versions with (||).",+ AggregatorSpec Agg.aggPvp "pvp" ( "aggregate versions to a range that is supposed to be "+ ++ "compatible with the given versions "+ ++ "in terms of PVP (Package Versioning Policy.)"+ )+ ]++parseAggregator :: String -> Maybe Aggregator+parseAggregator symbol = toMaybe $ filter (\spec -> aggSpecSymbol spec == symbol) aggregators where+ toMaybe [] = Nothing+ toMaybe (a : _) = Just $ aggSpecFunc a++wrapped :: String -> Pretty.Doc+wrapped = Pretty.fillSep . map Pretty.text . words++docAggregators :: String -> Pretty.Doc+docAggregators metaver = Pretty.vsep $ (foreword :) $ map docForAgg aggregators where+ foreword = wrapped ( "Aggregate version results over different resolvers."+ ++ " Possible " ++ metaver ++ " is:"+ )+ docForAgg AggregatorSpec {aggSpecSymbol = symbol, aggSpecDesc = desc} =+ Pretty.hang 2 $ wrapped ("\"" <> symbol <> "\": " <> desc)+ programDescription :: Opt.Parser a -> Opt.ParserInfo a programDescription parser =
src/Staversion/Internal/Exec.hs view
@@ -12,6 +12,8 @@ ) where import Control.Applicative ((<$>))+import Control.Monad (mapM_)+import Data.Either (rights) import Data.Function (on) import Data.List (groupBy, nub) import Data.Text (unpack)@@ -26,21 +28,30 @@ ( parseCommandArgs, Command(..) )-import Staversion.Internal.Format (formatResultsCabal)-import Staversion.Internal.Log (logDebug, logError, Logger)+import qualified Staversion.Internal.Format as Format+import Staversion.Internal.Log (logDebug, logError, Logger, putLogEntry) import Staversion.Internal.Query ( Query(..), PackageSource(..), PackageName, ErrorMsg )-import Staversion.Internal.Result (Result(..), ResultBody(..))+import Staversion.Internal.Result (Result(..), ResultBody, ResultBody'(..), ResultSource(..)) import Staversion.Internal.Cabal (BuildDepends(..), loadCabalFile) main :: IO () main = do comm <- parseCommandArgs- (TLIO.putStr . formatResultsCabal) =<< (processCommand comm)+ showFormatResult comm =<< formatResults comm =<< (processCommand comm)+ where+ formatResults comm results = case commAggregator comm of+ Nothing -> return (Format.formatResultsCabal results, [])+ Just agg -> do+ logDebug (commLogger comm) ("Results before aggregation: " ++ show results)+ return $ Format.formatResultsCabalAggregated agg results+ showFormatResult comm (formatted, logs) = do+ mapM_ (putLogEntry $ commLogger comm) logs+ TLIO.putStr formatted -data ResolvedQuery = RQueryOne Query PackageName- | RQueryCabal Query FilePath BuildDepends+data ResolvedQuery = RQueryOne PackageName+ | RQueryCabal FilePath BuildDepends deriving (Show, Eq, Ord) processCommand :: Command -> IO [Result]@@ -50,52 +61,61 @@ _processCommandWithCustomBuildPlanManager customBPM comm = impl where impl = do bp_man <- customBPM =<< newBuildPlanManager (commBuildPlanDir comm) (commLogger comm) (commAllowNetwork comm)- rqueries <- resolveQueries' logger $ commQueries comm- fmap concat $ mapM (processQueriesIn bp_man rqueries) $ commSources comm+ query_pairs <- resolveQueries' logger $ commQueries comm+ fmap concat $ mapM (processQueriesIn bp_man query_pairs) $ commSources comm logger = commLogger comm- processQueriesIn bp_man rqueries source = do- let queried_names = nub $ concat $ map getQueriedPackageNames $ rqueries+ processQueriesIn bp_man query_pairs source = do+ let queried_names = nub $ concat $ map (getQueriedPackageNames) $ rights $ map snd $ query_pairs logDebug logger ("Retrieve package source " ++ show source) e_build_plan <- loadBuildPlan bp_man queried_names source logBuildPlanResult e_build_plan- return $ map (makeResult source e_build_plan) $ rqueries- makeResult source e_build_plan rquery = case e_build_plan of- Left error_msg -> Result { resultIn = source, resultReallyIn = Nothing,- resultFor = originalQuery rquery, resultBody = Left error_msg- }- Right build_plan -> Result { resultIn = source,- resultReallyIn = if source == real_source then Nothing else Just real_source,- resultFor = originalQuery rquery,- resultBody = Right $ searchVersions build_plan rquery- }- where real_source = buildPlanSource build_plan+ return $ map (makeResult source e_build_plan) $ query_pairs+ makeResult source e_build_plan (orig_query, e_rquery) = case (e_build_plan, e_rquery) of+ (Left error_msg, _) -> resultForBody $ Left error_msg+ (Right _, Left error_msg) -> resultForBody $ Left error_msg+ (Right build_plan, Right rquery) -> resultForBody $ Right $ searchVersions build_plan rquery+ where+ resultForBody body =+ Result { resultIn = ResultSource { resultSourceQueried = source,+ resultSourceReal = realSource e_build_plan+ },+ resultFor = orig_query,+ resultBody = body+ } logBuildPlanResult (Right _) = logDebug logger ("Successfully retrieved build plan.") logBuildPlanResult (Left error_msg) = logError logger ("Failed to load build plan: " ++ error_msg) -resolveQueries' :: Logger -> [Query] -> IO [ResolvedQuery]-resolveQueries' logger = fmap concat . mapM resolveQ where- resolveQ query = reportAndFilterError =<< resolveQuery logger query- reportAndFilterError (Left err) = logError logger err >> return []- reportAndFilterError (Right ret) = return ret+realSource :: Either e BuildPlan -> Maybe PackageSource+realSource (Left _) = Nothing+realSource (Right bp) = Just $ buildPlanSource bp +resolveQueries' :: Logger -> [Query] -> IO [(Query, Either ErrorMsg ResolvedQuery)]+resolveQueries' logger = fmap concat . mapM resolveToList where+ resolveToList query = do+ eret <- resolveQuery logger query+ case eret of+ Right rqueries -> return $ map (\rq -> (query, Right rq)) rqueries+ Left err -> return $ [(query, Left err)]+ resolveQuery :: Logger -> Query -> IO (Either ErrorMsg [ResolvedQuery])-resolveQuery _ q@(QueryName name) = return $ Right $ [RQueryOne q name]-resolveQuery logger q@(QueryCabalFile file) = do+resolveQuery _ (QueryName name) = return $ Right $ [RQueryOne name]+resolveQuery logger (QueryCabalFile file) = do logDebug logger ("Load " ++ file ++ " for build-depends fields.")- (fmap . fmap) processBuildDependsList $ loadCabalFile file+ e_rquery <- (fmap . fmap) processBuildDependsList $ loadCabalFile file+ reportError e_rquery+ return e_rquery where- processBuildDependsList = map (RQueryCabal q file) . filter ((0 <) . length . depsPackages)--originalQuery :: ResolvedQuery -> Query-originalQuery (RQueryOne q _) = q-originalQuery (RQueryCabal q _ _) = q+ processBuildDependsList = map (RQueryCabal file) . filter ((0 <) . length . depsPackages)+ reportError e_rquery = case e_rquery of+ Left err -> logError logger err+ Right _ -> return () searchVersions :: BuildPlan -> ResolvedQuery -> ResultBody-searchVersions build_plan (RQueryOne _ package_name) = SimpleResultBody package_name $ packageVersion build_plan package_name-searchVersions build_plan (RQueryCabal _ cabal_file build_deps) = CabalResultBody cabal_file target ret_list where+searchVersions build_plan (RQueryOne package_name) = SimpleResultBody package_name $ packageVersion build_plan package_name+searchVersions build_plan (RQueryCabal cabal_file build_deps) = CabalResultBody cabal_file target ret_list where target = depsTarget build_deps ret_list = map (\pname -> (pname, packageVersion build_plan pname)) $ depsPackages build_deps getQueriedPackageNames :: ResolvedQuery -> [PackageName]-getQueriedPackageNames (RQueryOne _ n) = [n]-getQueriedPackageNames (RQueryCabal _ _ bd) = depsPackages bd+getQueriedPackageNames (RQueryOne n) = [n]+getQueriedPackageNames (RQueryCabal _ bd) = depsPackages bd
src/Staversion/Internal/Format.hs view
@@ -5,36 +5,45 @@ -- -- __This is an internal module. End-users should not use it.__ module Staversion.Internal.Format- ( formatResultsCabal+ ( formatResultsCabal,+ formatResultsCabalAggregated ) where +import Data.Foldable (fold) import Data.Function (on) import Data.List (intersperse)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NL import Data.Monoid (mempty, mconcat, (<>)) import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder (Builder, toLazyText, fromText, fromString)-import Data.Version (showVersion, Version)+import Distribution.Version (VersionRange) +import Staversion.Internal.Aggregate+ ( Aggregator, showVersionRange, groupAllPreservingOrderBy,+ aggregateResults+ ) import Staversion.Internal.Query ( Query(..), sourceDesc, PackageName )-import Staversion.Internal.Result (Result(..), ResultBody(..))+import Staversion.Internal.Result+ ( Result(..), ResultBody'(..), ResultSource(..), resultSourceDesc,+ AggregatedResult(..), singletonResult+ ) import Staversion.Internal.Cabal (Target(..))+import Staversion.Internal.Log (LogEntry) -- | format 'Result's like it's in build-depends in .cabal files. formatResultsCabal :: [Result] -> TL.Text-formatResultsCabal = toLazyText . mconcat . map formatResultBlock . makeSourceBlocks+formatResultsCabal = formatAggregatedResults . map singletonResult -groupAllPreservingOrderBy :: (a -> a -> Bool) -> [a] -> [[a]]-groupAllPreservingOrderBy sameGroup = map snd . foldr f [] where- f item acc = update [] acc where- update heads [] = (item, [item]) : heads- update heads (cur@(cur_item, cur_list) : rest) =- if sameGroup item cur_item- then ((cur_item, item : cur_list) : heads) ++ rest - else update (heads ++ [cur]) rest+-- | aggregate 'Result's and format them like it's in build-depends in+-- .cabal files.+formatResultsCabalAggregated :: Aggregator -> [Result] -> (TL.Text, [LogEntry])+formatResultsCabalAggregated aggregator = (\(aggs, logs) -> (formatAggregatedResults aggs, logs))+ . aggregateResults aggregator -- | 'Left' lines and 'Right' lines are handled differently by -- 'formatResultBlock'. It puts commas at the right places assuming@@ -44,27 +53,30 @@ data ResultBlock = RBHead Builder [ResultBlock] -- ^ header and child blocks | RBLines [ResultLine] -- ^ a block, which consists of some lines. -makeSourceBlocks :: [Result] -> [ResultBlock]-makeSourceBlocks = map sourceBlock . groupAllPreservingOrderBy ((==) `on` resultIn) where- sourceBlock [] = RBLines []- sourceBlock results@(head_ret : _) = RBHead header $ makeQueryBlocks results where- header = "------ " <> (fromText $ sourceDesc $ resultIn head_ret) <> header_real_source- header_real_source = maybe "" fromText $ resultReallyIn head_ret >>= \real_source -> do- return (" (" <> sourceDesc real_source <> ")")+formatAggregatedResults :: [AggregatedResult] -> TL.Text+formatAggregatedResults = toLazyText . mconcat . map formatResultBlock . makeSourceBlocks -makeQueryBlocks :: [Result] -> [ResultBlock]+makeSourceBlocks :: [AggregatedResult] -> [ResultBlock]+makeSourceBlocks = map sourceBlock . groupAllPreservingOrderBy ((==) `on` aggResultIn) where+ sourceBlock results@(head_ret :| _) = RBHead header $ makeQueryBlocks $ NL.toList results where+ header = "------ " <> (fold $ NL.intersperse ", " $ fmap sourceHeader $ aggResultIn head_ret)++sourceHeader :: ResultSource -> Builder+sourceHeader = fromText . resultSourceDesc++makeQueryBlocks :: [AggregatedResult] -> [ResultBlock] makeQueryBlocks = uncurry prependLines . foldr f ([], []) where prependLines blocks [] = blocks prependLines blocks rlines = (RBLines rlines) : blocks- f ret (blocks, rlines) = case (resultFor ret, resultBody ret) of+ f ret (blocks, rlines) = case (aggResultFor ret, aggResultBody ret) of (_, Right (SimpleResultBody name mver)) -> (blocks, (versionLine name mver) : rlines) (_, Right (CabalResultBody file target pairs)) -> (cabalFileSuccessBlock file target pairs : prependLines blocks rlines, []) ((QueryName name), Left _) -> (blocks, (packageErrorLine name) : rlines) ((QueryCabalFile file), Left _) -> (cabalFileErrorBlock file : prependLines blocks rlines, []) -versionLine :: PackageName -> Maybe Version -> ResultLine+versionLine :: PackageName -> Maybe VersionRange -> ResultLine versionLine name Nothing = Left $ "-- " <> fromText name <> " N/A"-versionLine name (Just ver) = Right $ fromText name <> " ==" <> (fromString $ showVersion ver)+versionLine name (Just ver_range) = Right $ fromText name <> " " <> (fromString $ showVersionRange ver_range) packageErrorLine :: PackageName -> ResultLine packageErrorLine name = Left $ "-- " <> fromText name <> " ERROR"@@ -73,7 +85,7 @@ cabalFileErrorBlock file = RBLines [Left line] where line = "-- " <> fromString file <> " ERROR" -cabalFileSuccessBlock :: FilePath -> Target -> [(PackageName, Maybe Version)] -> ResultBlock+cabalFileSuccessBlock :: FilePath -> Target -> [(PackageName, Maybe VersionRange)] -> ResultBlock cabalFileSuccessBlock file target pairs = RBHead header [RBLines $ map (uncurry versionLine) pairs] where header = "-- " <> fromString file <> " - " <> target_text target_text = case target of
src/Staversion/Internal/Log.hs view
@@ -6,9 +6,11 @@ -- module Staversion.Internal.Log ( LogLevel(..),+ LogEntry(..), Logger(loggerThreshold), defaultLogger, putLog,+ putLogEntry, logDebug, logInfo, logWarn,@@ -27,6 +29,10 @@ | LogError deriving (Show,Eq,Ord,Enum,Bounded) +data LogEntry = LogEntry { logLevel :: LogLevel,+ logMessage :: String+ } deriving (Show,Eq,Ord)+ data Logger = Logger { loggerThreshold :: Maybe LogLevel, -- ^ If 'Nothing', logging is disabled. loggerPutLogRaw :: LogLevel -> String -> IO ()@@ -52,6 +58,9 @@ mthreshold = loggerThreshold logger msg = toLabel level ++ " " ++ raw_msg +putLogEntry :: Logger -> LogEntry -> IO ()+putLogEntry logger entry = putLog logger (logLevel entry) (logMessage entry)+ logDebug :: Logger -> String -> IO () logDebug = flip putLog $ LogDebug @@ -65,9 +74,9 @@ logError = flip putLog $ LogError -- | FOR TEST: the IORef is the history of logged messages.-_mockLogger :: IO (Logger, IORef [(LogLevel, String)])+_mockLogger :: IO (Logger, IORef [LogEntry]) _mockLogger = do history <- newIORef []- let puts level msg = modifyIORef history (++ [(level, msg)])+ let puts level msg = modifyIORef history (++ [LogEntry level msg]) return $ (defaultLogger { loggerPutLogRaw = puts }, history)
src/Staversion/Internal/Result.hs view
@@ -6,23 +6,68 @@ -- __This is an internal module. End-users should not use it.__ module Staversion.Internal.Result ( Result(..),- ResultBody(..)+ ResultSource(..),+ resultSourceDesc,+ ResultBody,+ ResultBody'(..),+ AggregatedResult(..),+ singletonResult ) where +import Data.List.NonEmpty (NonEmpty(..))+import Data.Monoid ((<>))+import Data.Text (Text) import Data.Version (Version)+import Distribution.Version (VersionRange, thisVersion) import Staversion.Internal.Query- ( Query, PackageSource, ErrorMsg, PackageName+ ( Query, PackageSource, ErrorMsg, PackageName,+ sourceDesc ) import Staversion.Internal.Cabal (Target) -- | Result for a query.-data Result = Result { resultIn :: PackageSource,+data Result = Result { resultIn :: ResultSource, resultFor :: Query,- resultReallyIn :: Maybe PackageSource,- -- ^ the true PackageSource resolved (or redirected) from 'resultIn', if any. resultBody :: Either ErrorMsg ResultBody- } deriving (Show,Eq)+ } deriving (Show,Eq,Ord) -data ResultBody = SimpleResultBody PackageName (Maybe Version)- | CabalResultBody FilePath Target [(PackageName, (Maybe Version))]- deriving (Show,Eq)+data ResultSource =+ ResultSource { resultSourceQueried :: PackageSource,+ -- ^ the 'PackageSource' queried by user.+ resultSourceReal :: Maybe PackageSource+ -- ^ the real (exact) 'PackageSource' resolved.+ } deriving (Show,Eq,Ord)++resultSourceDesc :: ResultSource -> Text+resultSourceDesc src = query_source <> real_source where+ query_source = sourceDesc $ resultSourceQueried $ src+ real_source = case resultSourceReal src of+ Nothing -> ""+ Just real_psource -> if real_psource == resultSourceQueried src+ then ""+ else " (" <> sourceDesc real_psource <> ")"++-- | For backward-compatibility.+type ResultBody = ResultBody' (Maybe Version)++data ResultBody' a = SimpleResultBody PackageName a+ | CabalResultBody FilePath Target [(PackageName, a)]+ deriving (Show,Eq,Ord)++instance Functor ResultBody' where+ fmap f (SimpleResultBody n a) = SimpleResultBody n (f a)+ fmap f (CabalResultBody fp t pairs) = CabalResultBody fp t (map (\(n, a) -> (n, f a)) pairs)++-- | Results for a query aggregated over different sources.+data AggregatedResult =+ AggregatedResult { aggResultIn :: NonEmpty ResultSource,+ aggResultFor :: Query,+ aggResultBody :: Either ErrorMsg (ResultBody' (Maybe VersionRange))+ } deriving (Show,Eq)++-- | Create an 'AggregatedResult' that includes just one 'Result'.+singletonResult :: Result -> AggregatedResult+singletonResult ret = AggregatedResult { aggResultIn = (resultIn ret :| []),+ aggResultFor = resultFor ret,+ aggResultBody = (fmap . fmap . fmap) thisVersion $ resultBody ret+ }
staversion.cabal view
@@ -1,5 +1,5 @@ name: staversion-version: 0.1.3.2+version: 0.1.4.0 author: Toshio Ito <debug.ito@gmail.com> maintainer: Toshio Ito <debug.ito@gmail.com> license: BSD3@@ -41,7 +41,8 @@ Staversion.Internal.Command, Staversion.Internal.Log, Staversion.Internal.Exec,- Staversion.Internal.Format+ Staversion.Internal.Format,+ Staversion.Internal.Aggregate other-modules: Paths_staversion, Staversion.Internal.HTTP build-depends: base >=4.8 && <4.10,@@ -59,7 +60,11 @@ http-types >=0.8.6 && <0.10, transformers >=0.3.0 && <0.6, transformers-compat >=0.4.0 && <0.6,- megaparsec >=4.2.0 && <5.2+ megaparsec >=4.2.0 && <5.3,+ semigroups >=0.18.0.1 && <0.19,+ Cabal >=1.22.6.0 && <1.25,+ pretty >=1.1.2.0 && <1.2,+ ansi-wl-pprint >=0.6.7.3 && <0.7 executable staversion default-language: Haskell2010@@ -86,9 +91,11 @@ Staversion.Internal.ExecSpec, Staversion.Internal.FormatSpec, Staversion.Internal.CabalSpec,+ Staversion.Internal.AggregateSpec, Staversion.Internal.TestUtil build-depends: base, staversion, text, filepath, bytestring,- hspec >=2.1.7 && <2.4,+ Cabal, semigroups,+ hspec >=2.1.7, QuickCheck >=2.8.1 && <2.10 flag network-test
test/NetworkTest.hs view
@@ -30,7 +30,7 @@ import Staversion.Internal.Query ( PackageSource(..), ErrorMsg, Query(..) )-import Staversion.Internal.Result (Result(..), ResultBody(..))+import Staversion.Internal.Result (Result(..), ResultBody'(..), ResultSource(..)) main :: IO () main = hspec spec@@ -122,17 +122,18 @@ commLogger = quietLogger, commSources = [SourceStackage "lts-3"], commQueries = [QueryName "base"],- commAllowNetwork = True+ commAllowNetwork = True,+ commAggregator = Nothing } [ret] <- processCommand comm- resultIn ret `shouldBe` SourceStackage "lts-3"+ (resultSourceQueried . resultIn) ret `shouldBe` SourceStackage "lts-3" resultFor ret `shouldBe` QueryName "base" case resultBody ret of Right (SimpleResultBody got_name (Just got_version)) -> do got_name `shouldBe` "base" got_version `shouldSatisfy` (>= ver [4,8,1,0]) body -> expectationFailure ("Unexpected body: " ++ show body)- case resultReallyIn ret of+ case (resultSourceReal . resultIn) ret of Just source -> source `shouldBeAboveLTSMinor` (3,22) ret_really_in -> expectationFailure ("Unexpected resultReallyIn: " ++ show ret_really_in) @@ -141,12 +142,13 @@ commLogger = quietLogger, commSources = [SourceHackage], commQueries = [QueryName "base"],- commAllowNetwork = True+ commAllowNetwork = True,+ commAggregator = Nothing } [ret] <- processCommand comm- resultIn ret `shouldBe` SourceHackage+ (resultSourceQueried . resultIn) ret `shouldBe` SourceHackage resultFor ret `shouldBe` QueryName "base"- resultReallyIn ret `shouldBe` Nothing+ (resultSourceReal . resultIn) ret `shouldBe` Just SourceHackage case resultBody ret of Right (SimpleResultBody got_name (Just got_version)) -> do got_name `shouldBe` "base"
+ test/Staversion/Internal/AggregateSpec.hs view
@@ -0,0 +1,354 @@+module Staversion.Internal.AggregateSpec (main,spec) where++import Data.Char (toLower)+import Data.List (isInfixOf)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NL+import Data.Maybe (fromJust)+import Data.Monoid (All(..))+import qualified Distribution.Version as V+import Test.Hspec++import Staversion.Internal.Aggregate+ ( Aggregator,+ showVersionRange,+ aggOr,+ aggPvp,+ aggregateResults,+ aggregatePackageVersions+ )+import Staversion.Internal.Log (LogEntry(..), LogLevel(..))+import Staversion.Internal.Query (Resolver, PackageSource(..), Query(..), PackageName)+import Staversion.Internal.Cabal (Target(..))+import Staversion.Internal.Result+ ( Result(..), ResultSource(..), AggregatedResult(..),+ ResultBody'(..),+ singletonResult+ )+import Staversion.Internal.TestUtil (ver, simpleResultBody, verPairs)++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ spec_aggregatePackageVersions+ spec_aggregateResults+ describe "Aggregators" $ do+ spec_or+ spec_pvp++vor :: V.VersionRange -> V.VersionRange -> V.VersionRange+vor = V.unionVersionRanges++vthis :: [Int] -> V.VersionRange+vthis = V.thisVersion . ver++spec_or :: Spec+spec_or = describe "aggOr" $ do+ specify "single version" $ do+ let input = ver [1,2,3] :| []+ expected = V.thisVersion $ ver [1,2,3]+ aggOr input `shouldBe` expected+ (showVersionRange $ aggOr input) `shouldBe` "==1.2.3"+ specify "three versions" $ do+ let input = ver [1,2] :| [ver [3,4], ver [5,6], ver [7,8]]+ expected = vor (vthis [1,2])+ $ vor (vthis [3,4])+ $ vor (vthis [5,6])+ $ (vthis [7,8])+ aggOr input `shouldBe` expected+ (showVersionRange $ aggOr input) `shouldBe` "==1.2 || ==3.4 || ==5.6 || ==7.8"+ it "should sort versions" $ do+ let input = ver [5,5,0] :| [ver [0,2], ver [5,5], ver [3,3,2,1], ver [0,3]]+ expected = vor (vthis [0,2])+ $ vor (vthis [0,3])+ $ vor (vthis [3,3,2,1])+ $ vor (vthis [5,5])+ $ (vthis [5,5,0])+ aggOr input `shouldBe` expected+ (showVersionRange $ aggOr input) `shouldBe` "==0.2 || ==0.3 || ==3.3.2.1 || ==5.5 || ==5.5.0"+ it "should eliminate duplicates" $ do+ let input = ver [1,0] :| [ver [0,4], ver [1,2], ver [0,4], ver [1,0]]+ expected = vor (vthis [0,4])+ $ vor (vthis [1,0])+ $ (vthis [1,2])+ aggOr input `shouldBe` expected++vors :: [[Int]] -> V.VersionRange+vors = vors' . map vthis++vors' :: [V.VersionRange] -> V.VersionRange+vors' [] = error "this should not happen"+vors' [v] = v+vors' (v:rest) = vor v $ vors' rest++-- | Version interval. vint x y = [x, y)+vint :: [Int] -> [Int] ->V.VersionRange+vint vl vu = fromJust $ fmap V.fromVersionIntervals $ V.mkVersionIntervals [interval] where+ interval = (V.LowerBound (ver vl) V.InclusiveBound, V.UpperBound (ver vu) V.ExclusiveBound)++spec_pvp :: Spec+spec_pvp = describe "aggPvp" $ before (return aggPvp) $ do+ testAgg [[1,2,0,7]] $ vint [1,2,0,7] [1,3]+ testAgg [[1,2,0]] $ vint [1,2,0] [1,3]+ testAgg [[1,2]] $ vint [1,2] [1,3]+ testAgg [[1]] $ vint [1] [1,0]+ testAgg [[1,2,0,0], [1,2,3,0]] $ vint [1,2,0,0] [1,3]+ testAgg [[1,2,0,0], [1,2,0,0]] $ vint [1,2,0,0] [1,3]+ testAgg [[1,2,0,0], [1,3]] $ vint [1,2,0,0] [1,4]+ testAgg [[1,2,0,0], [1,3,0]] $ vors' [ vint [1,2,0,0] [1,3],+ vint [1,3,0] [1,4]+ ]+ testAgg [[1,3,0], [1,2,0,0]] $ vors' [ vint [1,2,0,0] [1,3],+ vint [1,3,0] [1,4]+ ]+ testAgg [[1,2,0,0], [1,3,0,0]] $ vors' [ vint [1,2,0,0] [1,3],+ vint [1,3,0,0] [1,4]+ ]+ testAgg [[1,3,0,0], [1,2,0,0]] $ vors' [ vint [1,2,0,0] [1,3],+ vint [1,3,0,0] [1,4]+ ]+ testAgg [[1,2,0,0], [2]] $ vors' [ vint [1,2,0,0] [1,3],+ vint [2] [2,0]+ ]+ testAgg [[2,2,0], [2,0], [3,5,0,1], [2,2,0,5]] $ vors' [ vint [2,0] [2,1],+ vint [2,2,0] [2,3],+ vint [3,5,0,1] [3,6]+ ]++testAgg :: [[Int]] -> V.VersionRange -> SpecWith Aggregator+testAgg input expected = specify desc $ \agg -> agg input' `shouldBe` expected where+ input' = case input of+ [] -> error "input to Aggregator must be non-empty."+ (h : rest) -> fmap ver $ (h :| rest)+ desc = show input ++ " -> " ++ showVersionRange expected++spec_aggregateResults :: Spec+spec_aggregateResults = describe "aggregateResults" $ do+ it "should return empty for empty input" $ do+ let (agg_ret, _) = aggregateResults aggOr []+ agg_ret `shouldBe` []+ + it "should aggregate SimpleResultBody" $ do+ let input = [ simpleResult "lts-5.0" "hoge" [1,0],+ simpleResult "lts-6.0" "hoge" [2,0],+ simpleResult "lts-7.0" "hoge" [3,0]+ ]+ expected = AggregatedResult { aggResultIn = rsource "lts-5.0"+ :| [ rsource "lts-6.0",+ rsource "lts-7.0"+ ],+ aggResultFor = QueryName "hoge",+ aggResultBody = Right $ SimpleResultBody "hoge"+ $ Just $ vors [[1,0], [2,0], [3,0]]+ }+ aggregateResults aggOr input `shouldBe` ([expected], [])++ it "should group Results based on their resultFor field" $ do+ let input = [ simpleResult "lts-5.0" "hoge" [1,0],+ simpleResult "lts-6.0" "foo" [2,0],+ simpleResult "lts-7.0" "bar" [3,0]+ ]+ expected = map singletonResult input+ aggregateResults aggOr input `shouldBe` (expected, [])++ it "should warn about Left resultBody" $ do+ let input = [ simpleResult "lts-5.0" "hoge" [1,0],+ (simpleResult "lts-6.0" "hoge" []) { resultBody = Left "SOME ERROR"+ },+ simpleResult "lts-7.0" "hoge" [3,0]+ ]+ expected = AggregatedResult { aggResultIn = rsource "lts-5.0" :| [rsource "lts-7.0"],+ aggResultFor = QueryName "hoge",+ aggResultBody = Right $ SimpleResultBody "hoge"+ $ Just $ vors [[1,0], [3,0]]+ }+ (got, got_logs) = aggregateResults aggOr input+ got `shouldBe` [expected]+ (matchLogCount LogWarn "SOME ERROR" got_logs) `shouldBe` 1++ it "should produce AggregatedResult with Left body for groups in which all Results are Left" $ do+ let input = [ simpleResult "lts-5.0" "hoge" [1,0],+ (simpleResult "lts-5.0" "foo" []) { resultBody = Left "SOME ERROR"+ },+ simpleResult "lts-6.0" "hoge" [2,0],+ (simpleResult "lts-6.0" "foo" []) { resultBody = Left "SOME ANOTHER ERROR"+ }+ ]+ expected = [ AggregatedResult { aggResultIn = rsource "lts-5.0" :| [rsource "lts-6.0"],+ aggResultFor = QueryName "hoge",+ aggResultBody = Right $ SimpleResultBody "hoge"+ $ Just $ vors [[1,0], [2,0]]+ },+ AggregatedResult { aggResultIn = rsource "lts-5.0" :| [rsource "lts-6.0"],+ aggResultFor = QueryName "foo",+ aggResultBody = Left "SOME ERROR"+ }+ ]+ (got, got_logs) = aggregateResults aggOr input+ got `shouldBe` expected+ length got_logs `shouldBe` 2+ (matchLogCount LogWarn "SOME ERROR" got_logs) `shouldBe` 1+ (matchLogCount LogWarn "SOME ANOTHER ERROR" got_logs) `shouldBe` 1+ it "should return error if SimpleResultBody and CabalResultBody are mixed in the same resultFor." $ do+ let input = [ simpleResult "lts-5.0" "hoge" [1,0],+ (cabalResult "lts-5.0" "foo.cabal" TargetLibrary [("foo", [1,0])])+ { resultFor = QueryName "hoge"+ }+ ]+ (got, got_logs) = aggregateResults aggOr input+ got `shouldBe` []+ (matchesLogCount LogError ["different", "results", "mixed"] got_logs) `shouldBe` 1+ it "should group CabalResultBody based on Target" $ do+ let input = [ cabalResult "lts-5.0" "foo.cabal" TargetLibrary [("a", [1,0]), ("b", [0,0,1])],+ cabalResult "lts-5.0" "foo.cabal" (TargetExecutable "exe") [("c", [10,5,6]), ("d", [3,4])],+ cabalResult "lts-6.0" "foo.cabal" TargetLibrary [("a", [2,0]), ("b", [0,0,1])],+ cabalResult "lts-6.0" "foo.cabal" (TargetExecutable "exe") [("c", [8,0]), ("d", [3,3,9])]+ ]+ expected = [ AggregatedResult { aggResultIn = rsource "lts-5.0" :| [rsource "lts-6.0"],+ aggResultFor = QueryCabalFile "foo.cabal",+ aggResultBody = Right $ CabalResultBody "foo.cabal" TargetLibrary+ $ [("a", Just $ vors [[1,0], [2,0]]), ("b", Just $ vors [[0,0,1]])]+ },+ AggregatedResult { aggResultIn = rsource "lts-5.0" :| [rsource "lts-6.0"],+ aggResultFor = QueryCabalFile "foo.cabal",+ aggResultBody = Right $ CabalResultBody "foo.cabal" (TargetExecutable "exe")+ $ [("c", Just $ vors [[8,0], [10,5,6]]), ("d", Just $ vors [[3,3,9], [3,4]])]+ }+ ]+ (got, got_logs) = aggregateResults aggOr input+ got `shouldBe` expected+ got_logs `shouldBe` []+ it "should be ok if source set are inconsistent between different Target for CabalResultBody" $ do+ let input = [ cabalResult "lts-5.0" "foo.cabal" TargetLibrary [("a", [1,0]), ("b", [1,1,0])],+ cabalResult "lts-6.0" "foo.cabal" (TargetTestSuite "tst") [("a", [2,2,0]), ("c", [10,4,0,1])]+ ]+ expected = [ AggregatedResult { aggResultIn = rsource "lts-5.0" :| [],+ aggResultFor = QueryCabalFile "foo.cabal",+ aggResultBody = Right $ CabalResultBody "foo.cabal" TargetLibrary+ $ [("a", Just $ vors [[1,0]]), ("b", Just $ vors [[1,1,0]])]+ },+ AggregatedResult { aggResultIn = rsource "lts-6.0" :| [],+ aggResultFor = QueryCabalFile "foo.cabal",+ aggResultBody = Right $ CabalResultBody "foo.cabal" (TargetTestSuite "tst")+ $ [("a", Just $ vors [[2,2,0]]), ("c", Just $ vors [[10,4,0,1]])]+ }+ ]+ (got, got_logs) = aggregateResults aggOr input+ got `shouldBe` expected+ got_logs `shouldBe` []+ it "should nub aggregated ResultSources" $ do+ let input = [ simpleResult "lts-5.0" "hoge" [1,0,0],+ simpleResult "lts-5.0" "hoge" [1,0,0],+ simpleResult "lts-5.0" "hoge" [1,0,0]+ ]+ expected = [ AggregatedResult { aggResultIn = rsource "lts-5.0" :| [],+ aggResultFor = QueryName "hoge",+ aggResultBody = Right $ SimpleResultBody "hoge" $ Just $ vthis [1,0,0]+ }+ ]+ aggregateResults aggOr input `shouldBe` (expected, [])+ it "should warn about Nothing version in CabalResultBody with Target" $ do+ let input = [ cabalResult "lts-5.0" "foo.cabal" TargetLibrary [("hoge-pack", [1,0]), ("b", [1,1,0])],+ cabalResult "lts-4.0" "foo.cabal" TargetLibrary [("hoge-pack", []), ("b", [1,0,9])]+ ]+ expected = [ AggregatedResult { aggResultIn = rsource "lts-5.0" :| [rsource "lts-4.0"],+ aggResultFor = QueryCabalFile "foo.cabal",+ aggResultBody = Right $ CabalResultBody "foo.cabal" TargetLibrary+ $ [("hoge-pack", Just $ vthis [1,0]), ("b", Just $ vors [[1,0,9], [1,1,0]])]+ }+ ]+ (got, got_logs) = aggregateResults aggOr input+ got `shouldBe` expected+ length got_logs `shouldBe` 1+ (matchesLogCount LogWarn ["hoge-pack", "foo.cabal", "lts-4.0", "TargetLibrary"] got_logs) `shouldBe` 1++rsource :: Resolver -> ResultSource+rsource res = ResultSource { resultSourceQueried = psource,+ resultSourceReal = Just psource+ }+ where+ psource = SourceStackage res++simpleResult :: Resolver -> PackageName -> [Int] -> Result+simpleResult resolver pname version =+ Result { resultIn = rsource resolver,+ resultFor = QueryName pname,+ resultBody = Right $ simpleResultBody pname version+ }++cabalResult :: Resolver -> FilePath -> Target -> [(PackageName, [Int])] -> Result+cabalResult resolver cabal_file target pmap =+ Result { resultIn = rsource resolver,+ resultFor = QueryCabalFile cabal_file,+ resultBody = Right $ CabalResultBody cabal_file target $ verPairs pmap+ }++matchLog :: LogLevel -> String -> LogEntry -> Bool+matchLog exp_level exp_msg_part entry = (logLevel entry == exp_level)+ && (lc exp_msg_part `isInfixOf` (lc $ logMessage entry))+ where+ lc = map toLower++matchLogCount :: LogLevel -> String -> [LogEntry] -> Int+matchLogCount exp_level exp_msg_part = matchesLogCount exp_level [exp_msg_part]++matchesLogCount :: LogLevel -> [String] -> [LogEntry] -> Int+matchesLogCount exp_level exp_msg_parts = length . filter predicate where+ predicate entry = getAll $ mconcat $ map (\exp_msg_part -> All $ matchLog exp_level exp_msg_part entry) exp_msg_parts++seqLabels :: NonEmpty a -> NonEmpty (String, a)+seqLabels = NL.zip labels where+ labels = NL.fromList $ map (\n -> "ENTRY" ++ show n) ([0..] :: [Int])++spec_aggregatePackageVersions :: Spec+spec_aggregatePackageVersions = describe "aggregatePackageVersions" $ do+ it "should accept an empty map" $ do+ let got = aggregatePackageVersions aggOr $ seqLabels ([] :| [[], []])+ got `shouldBe` (Just [], [])+ it "should aggregate package version maps" $ do+ let input = [("foo", Just $ ver [1,0]),+ ("bar", Just $ ver [1,2,3]),+ ("buzz", Just $ ver [2,0,5])+ ]+ :| [ [ ("foo", Just $ ver [2,0]),+ ("bar", Just $ ver [1,0,0,2]),+ ("buzz", Just $ ver [2,1])+ ],+ [ ("foo", Just $ ver [3,0]),+ ("bar", Just $ ver [0,0,4]),+ ("buzz", Just $ ver [2,2,0,10])+ ]+ ]+ expected = [ ("foo", Just $ vors [[1,0], [2,0], [3,0]]),+ ("bar", Just $ vors [[0,0,4], [1,0,0,2], [1,2,3]]),+ ("buzz", Just $ vors [[2,0,5], [2,1], [2,2,0,10]])+ ]+ aggregatePackageVersions aggOr (seqLabels input) `shouldBe` (Just expected, [])+ it "should warn about Nothing version" $ do+ let input = [("foo", Nothing)]+ :| [ [("foo", Just $ ver [1,0])],+ [("foo", Just $ ver [2,0])]+ ]+ (got, got_logs) = aggregatePackageVersions aggOr $ seqLabels input+ got `shouldBe` Just ([("foo", Just $ vors [[1,0], [2,0]])])+ length got_logs `shouldBe` 1+ matchesLogCount LogWarn ["foo", "ENTRY0", "missing"] got_logs `shouldBe` 1+ it "should return Nothing VersionRange if all versions are Nothing" $ do+ let input = [("foo", Nothing)]+ :| [ [("foo", Nothing)],+ [("foo", Nothing)]+ ]+ (got, got_logs) = aggregatePackageVersions aggOr $ seqLabels input+ got `shouldBe` Just ([("foo", Nothing)])+ matchesLogCount LogWarn ["foo", "missing"] got_logs `shouldBe` 3+ it "should be an error if package lists are inconsistent" $ do+ let input = [("foo", Just $ ver [1,0])]+ :| [ [("foo", Just $ ver [2,0])],+ [("bar", Just $ ver [3,0])]+ ]+ (got, got_logs) = aggregatePackageVersions aggOr $ seqLabels input+ got `shouldBe` Nothing+ length got_logs `shouldBe` 1+ matchesLogCount LogError ["inconsistent", "package list"] got_logs `shouldBe` 1
test/Staversion/Internal/ExecSpec.hs view
@@ -1,6 +1,7 @@ module Staversion.Internal.ExecSpec (main,spec) where import Data.Version (Version(Version))+import Data.Either (isLeft) import Data.IORef (readIORef) import Data.List (isInfixOf) import System.FilePath ((</>))@@ -20,9 +21,10 @@ ) import Staversion.Internal.Result ( Result(..),- ResultBody(..)+ ResultBody, ResultBody'(..),+ ResultSource(..) )-import Staversion.Internal.Log (defaultLogger, _mockLogger, Logger(loggerThreshold), LogLevel(..))+import Staversion.Internal.Log (defaultLogger, _mockLogger, Logger(loggerThreshold), LogLevel(..), LogEntry(..)) import Staversion.Internal.Cabal (Target(..)) import Staversion.Internal.TestUtil (ver, simpleResultBody, verPairs)@@ -34,6 +36,7 @@ spec = do spec_processCommand_basic spec_processCommand_disambiguates+ spec_processCommand_error spec_processCommand_basic :: Spec spec_processCommand_basic = describe "processCommand" $ do@@ -52,16 +55,17 @@ commLogger = logger { loggerThreshold = Just LogInfo } } [got_ret] <- processCommand comm- resultIn got_ret `shouldBe` src+ (resultSourceQueried . resultIn) got_ret `shouldBe` src+ (resultSourceReal . resultIn) got_ret `shouldBe` Nothing resultFor got_ret `shouldBe` query case resultBody got_ret of Right _ -> expectationFailure "it should fail" Left _ -> return () got_logs <- readIORef logs- let match :: (LogLevel, String) -> Bool- match (level, msg) = (level >= LogWarn)- && ("unknown.yaml" `isInfixOf` msg)- && ("not found" `isInfixOf` msg)+ let match :: LogEntry -> Bool+ match (LogEntry level msg) = (level >= LogWarn)+ && ("unknown.yaml" `isInfixOf` msg)+ && ("not found" `isInfixOf` msg) (length $ filter match got_logs) `shouldBe` 1 specify "QueryName, SourceStackage, full-mesh" $ do let src2 = SourceStackage "lts-2.22_conpact"@@ -69,16 +73,16 @@ qc = QueryName "conduit" qa = QueryName "aeson" comm = baseCommand { commSources = [src2, src7], commQueries = [qc, qa] }- expected = [ Result { resultIn = src2, resultReallyIn = Nothing, resultFor = qc,+ expected = [ Result { resultIn = ResultSource src2 (Just src2), resultFor = qc, resultBody = Right $ simpleResultBody "conduit" [1,2,5] },- Result { resultIn = src2, resultReallyIn = Nothing, resultFor = qa,+ Result { resultIn = ResultSource src2 (Just src2), resultFor = qa, resultBody = Right $ simpleResultBody "aeson" [0,8,0,2] },- Result { resultIn = src7, resultReallyIn = Nothing, resultFor = qc,+ Result { resultIn = ResultSource src7 (Just src7), resultFor = qc, resultBody = Right $ simpleResultBody "conduit" [1,2,7] },- Result { resultIn = src7, resultReallyIn = Nothing, resultFor = qa,+ Result { resultIn = ResultSource src7 (Just src7), resultFor = qa, resultBody = Right $ simpleResultBody "aeson" [0,11,2,1] } ]@@ -88,7 +92,7 @@ cabal_file = ("test" </> "data" </> "foobar.cabal_test") query = QueryCabalFile cabal_file comm = baseCommand { commSources = [src], commQueries = [query] }- ret t vps = Result { resultIn = src, resultReallyIn = Nothing, resultFor = query,+ ret t vps = Result { resultIn = ResultSource src (Just src), resultFor = query, resultBody = Right $ CabalResultBody cabal_file t vps } expected = [ ret TargetLibrary $ verPairs [ ("base", [4,8,2,0]),@@ -114,8 +118,9 @@ singleCase' :: PackageSource -> Query -> (Either ErrorMsg ResultBody -> IO a) -> IO a singleCase' src query checker = do [got_ret] <- processCommand comm- resultIn got_ret `shouldBe` src- resultReallyIn got_ret `shouldBe` Nothing+ (resultSourceQueried . resultIn) got_ret `shouldBe` src+ let exp_source_real = either (const Nothing) (const $ Just $ src) $ resultBody got_ret+ (resultSourceReal . resultIn) got_ret `shouldBe` exp_source_real resultFor got_ret `shouldBe` query checker $ resultBody got_ret where@@ -128,7 +133,8 @@ commLogger = defaultLogger { loggerThreshold = Nothing }, commSources = [], commQueries = [],- commAllowNetwork = False+ commAllowNetwork = False,+ commAggregator = Nothing } spec_processCommand_disambiguates :: Spec@@ -141,7 +147,24 @@ _setLTSDisambiguator bp_man 4 2 return bp_man [got_ret] <- _processCommandWithCustomBuildPlanManager withMockDisam comm- resultIn got_ret `shouldBe` SourceStackage "lts"- resultReallyIn got_ret `shouldBe` (Just $ SourceStackage "lts-4.2")+ (resultSourceQueried . resultIn) got_ret `shouldBe` SourceStackage "lts"+ (resultSourceReal . resultIn) got_ret `shouldBe` (Just $ SourceStackage "lts-4.2") resultFor got_ret `shouldBe` QueryName "conduit" resultBody got_ret `shouldBe` Right (simpleResultBody "conduit" [1,2,6,1])++spec_processCommand_error :: Spec+spec_processCommand_error = describe "processCommand" $ do+ it "should continue processing after IO error in reading .cabal file" $ do+ let src = SourceStackage "lts-4.2"+ comm = baseCommand { commSources = [src],+ commQueries = [ QueryCabalFile "this_does_not_exist.cabal",+ QueryName "parsec"+ ]+ }+ [got_cabal, got_name] <- processCommand comm+ resultFor got_cabal `shouldBe` QueryCabalFile "this_does_not_exist.cabal"+ resultBody got_cabal `shouldSatisfy` isLeft+ got_name `shouldBe` Result { resultIn = ResultSource src (Just src),+ resultFor = QueryName "parsec",+ resultBody = Right $ simpleResultBody "parsec" [3,1,9]+ }
test/Staversion/Internal/FormatSpec.hs view
@@ -3,12 +3,16 @@ import Data.Monoid ((<>)) import Test.Hspec -import Staversion.Internal.Format (formatResultsCabal)+import Staversion.Internal.Aggregate (aggOr)+import Staversion.Internal.Format+ ( formatResultsCabal,+ formatResultsCabalAggregated+ ) import Staversion.Internal.Query ( PackageSource(..), Query(..), Resolver, PackageName )-import Staversion.Internal.Result (Result(..), ResultBody(..))+import Staversion.Internal.Result (Result(..), ResultBody, ResultBody'(..), ResultSource(..)) import Staversion.Internal.Cabal (Target(..)) import Staversion.Internal.TestUtil (ver, simpleResultBody, verPairs)@@ -19,11 +23,16 @@ main = hspec spec spec :: Spec-spec = describe "formatResultsCabal" $ do+spec = do+ spec_simple+ spec_aggregate++spec_simple :: Spec+spec_simple = describe "formatResultsCabal" $ do it "should return empty text for empty list" $ do formatResultsCabal [] `shouldBe` "" it "should format a Result in a Cabal way" $ do- let input = [ Result { resultIn = SourceStackage "lts-6.10", resultReallyIn = Nothing,+ let input = [ Result { resultIn = ResultSource (SourceStackage "lts-6.10") (Just $ SourceStackage "lts-6.10"), resultFor = QueryName "hoge", resultBody = Right $ simpleResultBody "hoge" [3,4,5] }@@ -99,8 +108,7 @@ ) formatResultsCabal input `shouldBe` expected it "should output resultReallyIn field" $ do- let input = [ Result { resultIn = SourceStackage "lts",- resultReallyIn = Just $ SourceStackage "lts-7.4",+ let input = [ Result { resultIn = ResultSource (SourceStackage "lts") (Just $ SourceStackage "lts-7.4"), resultFor = QueryName "foobar", resultBody = Right $ simpleResultBody "foobar" [3,4,5] } ]@@ -110,7 +118,7 @@ ) formatResultsCabal input `shouldBe` expected it "should show ERROR if resultBody is Left, resultFor is QueryName" $ do- let input = [ Result { resultIn = SourceStackage "lts-4.2", resultReallyIn = Nothing,+ let input = [ Result { resultIn = ResultSource (SourceStackage "lts-4.2") Nothing, resultFor = QueryName "hogehoge", resultBody = Left "some error" } ]@@ -120,11 +128,11 @@ ) formatResultsCabal input `shouldBe` expected it "should show ERROR if resultBody is Left, resultFor is QueryCabalFile" $ do- let input = [ Result { resultIn = SourceStackage "lts-5.3", resultReallyIn = Nothing,+ let input = [ Result { resultIn = ResultSource (SourceStackage "lts-5.3") (Just $ SourceStackage "lts-5.3"), resultFor = QueryCabalFile "foobar.cabal", resultBody = Left "some error" },- Result { resultIn = SourceStackage "lts-5.3", resultReallyIn = Nothing,+ Result { resultIn = ResultSource (SourceStackage "lts-5.3") (Just $ SourceStackage "lts-5.3"), resultFor = QueryName "hoge", resultBody = Right $ simpleResultBody "hoge" [5,5] }@@ -212,15 +220,47 @@ ) formatResultsCabal input `shouldBe` expected +spec_aggregate :: Spec+spec_aggregate = describe "formatResultsCabalAggregated" $ do+ it "should aggregate Results over multiple package sources" $ do+ let input = [ simpleResult "lts-4.2" "hoge" [1,2,3],+ simpleResult "lts-5.0" "hoge" [1,5]+ ]+ expected = ( "------ lts-4.2, lts-5.0\n"+ <> "hoge ==1.2.3 || ==1.5\n"+ <> "\n"+ )+ formatResultsCabalAggregated aggOr input `shouldBe` (expected, [])+ it "should show resultReallyIn in the header" $ do+ let input = [ setRealSource "lts-4.22" $ simpleResult "lts-4" "foobar" [2,3],+ hackageResult "foobar" [2,3,10],+ simpleResult "lts-5.3" "foobar" [2,3,4]+ ]+ expected = ( "------ lts-4 (lts-4.22), latest in hackage, lts-5.3\n"+ <> "foobar ==2.3 || ==2.3.4 || ==2.3.10\n"+ <> "\n"+ )+ formatResultsCabalAggregated aggOr input `shouldBe` (expected, [])+ simpleResult :: Resolver -> PackageName -> [Int] -> Result-simpleResult res name vs = Result { resultIn = SourceStackage res, resultReallyIn = Nothing,+simpleResult res name vs = Result { resultIn = ResultSource (SourceStackage res) (Just $ SourceStackage res), resultFor = QueryName name, resultBody = Right $ simpleResultBody name vs } +hackageResult :: PackageName -> [Int] -> Result+hackageResult name vs = Result { resultIn = ResultSource SourceHackage (Just SourceHackage),+ resultFor = QueryName name,+ resultBody = Right $ simpleResultBody name vs+ }+ cabalResult :: Resolver -> FilePath -> Target -> [(PackageName, [Int])] -> Result cabalResult res file target vps =- Result { resultIn = SourceStackage res, resultReallyIn = Nothing,+ Result { resultIn = ResultSource (SourceStackage res) (Just $ SourceStackage res), resultFor = QueryCabalFile file, resultBody = Right $ CabalResultBody file target $ verPairs vps }++setRealSource :: Resolver -> Result -> Result+setRealSource resolver ret = ret { resultIn = rin { resultSourceReal = Just $ SourceStackage resolver } } where+ rin = resultIn ret
test/Staversion/Internal/TestUtil.hs view
@@ -6,7 +6,7 @@ import Data.Version (Version(..)) import Staversion.Internal.Query ( PackageName )-import Staversion.Internal.Result (ResultBody(..))+import Staversion.Internal.Result (ResultBody, ResultBody'(..)) ver :: [Int] -> Version ver vs = Version vs []