diff --git a/package.yaml b/package.yaml index b5af0f2..1951301 100644 --- a/package.yaml +++ b/package.yaml @@ -39,7 +39,6 @@ dependencies: - persistent-template - resourcet - rio -- semialign - shakespeare - tar-conduit - template-haskell diff --git a/src/Stackage/Database/Query.hs b/src/Stackage/Database/Query.hs index 5fbccb9..bc3693f 100644 --- a/src/Stackage/Database/Query.hs +++ b/src/Stackage/Database/Query.hs @@ -27,6 +27,7 @@ module Stackage.Database.Query , getAllPackages , getPackagesForSnapshot + , getPackagesForSnapshotDiff , getPackageVersionForSnapshot , getLatests @@ -375,6 +376,22 @@ getPackagesForSnapshot snapshotId = toPackageListingInfo (Value pliName, Value pliVersion, Value pliSynopsis, Value pliOrigin) = PackageListingInfo {pliName, pliVersion, pliSynopsis, pliOrigin} +getPackagesForSnapshotDiff :: GetStackageDatabase env m => SnapshotId -> m [(PackageNameP, VersionP)] +getPackagesForSnapshotDiff snapshotId = + run (map toPackageListingInfo <$> + select + (from $ \(sp `InnerJoin` pn `InnerJoin` v) -> do + on (sp ^. SnapshotPackageVersion ==. v ^. VersionId) + on (sp ^. SnapshotPackagePackageName ==. pn ^. PackageNameId) + where_ (sp ^. SnapshotPackageSnapshot ==. val snapshotId) + orderBy [asc (pn ^. PackageNameName)] + pure + ( pn ^. PackageNameName + , v ^. VersionVersion + ))) + where + toPackageListingInfo (Value name, Value version) = (name, version) + getPackageVersionForSnapshot :: GetStackageDatabase env m diff --git a/src/Stackage/Snapshot/Diff.hs b/src/Stackage/Snapshot/Diff.hs index 2b8f7bb..8256a78 100644 --- a/src/Stackage/Snapshot/Diff.hs +++ b/src/Stackage/Snapshot/Diff.hs @@ -15,14 +15,11 @@ module Stackage.Snapshot.Diff import ClassyPrelude (sortOn, toCaseFold) import Data.Aeson -import Data.Align -import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as T (commonPrefixes) import Data.These import RIO import Stackage.Database (GetStackageDatabase, SnapshotId, - getPackagesForSnapshot) -import Stackage.Database.Types (PackageListingInfo(..)) + getPackagesForSnapshotDiff) import Types import Web.PathPieces @@ -30,18 +27,15 @@ data WithSnapshotNames a = WithSnapshotNames SnapName SnapName a newtype SnapshotDiff - = SnapshotDiff { unSnapshotDiff :: HashMap PackageNameP VersionChange } + = SnapshotDiff { toDiffList :: [(PackageNameP, VersionChange)] } deriving (Show, Eq, Generic, Typeable) instance ToJSON (WithSnapshotNames SnapshotDiff) where toJSON (WithSnapshotNames nameA nameB (SnapshotDiff diff)) = object [ "comparing" .= [toPathPiece nameA, toPathPiece nameB] - , "diff" .= toJSON (WithSnapshotNames nameA nameB <$> diff) + , "diff" .= toJSON (map (second (WithSnapshotNames nameA nameB)) diff) ] -toDiffList :: SnapshotDiff -> [(PackageNameP, VersionChange)] -toDiffList = sortOn (toCaseFold . textDisplay . fst) . HashMap.toList . unSnapshotDiff - versionPrefix :: VersionChange -> Maybe (Text, Text, Text) versionPrefix vc = case unVersionChange vc of These va vb -> T.commonPrefixes (textDisplay va) (textDisplay vb) @@ -73,15 +67,24 @@ instance ToJSON (WithSnapshotNames VersionChange) where VersionChange (That b) -> object [ bKey .= b ] VersionChange (These a b) -> object [ aKey .= a, bKey .= b ] -changed :: VersionChange -> Bool -changed = these (const True) (const True) (/=) . unVersionChange - getSnapshotDiff :: GetStackageDatabase env m => SnapshotId -> SnapshotId -> m SnapshotDiff -getSnapshotDiff a b = snapshotDiff <$> getPackagesForSnapshot a <*> getPackagesForSnapshot b +getSnapshotDiff a b = snapshotDiff <$> getPackagesForSnapshotDiff a <*> getPackagesForSnapshotDiff b -snapshotDiff :: [PackageListingInfo] -> [PackageListingInfo] -> SnapshotDiff -snapshotDiff as bs = - SnapshotDiff $ HashMap.filter changed - $ alignWith VersionChange (toMap as) (toMap bs) +snapshotDiff + :: [(PackageNameP, VersionP)] + -> [(PackageNameP, VersionP)] + -> SnapshotDiff +snapshotDiff as0 bs0 = + SnapshotDiff $ map (second VersionChange) $ go (sortEm as0) (sortEm bs0) where - toMap = HashMap.fromList . map (pliName &&& pliVersion) + sortEm = sortOn (toCaseFold . textDisplay . fst) + + go as [] = map (second This) as + go [] bs = map (second That) bs + go (a:as) (b:bs) = + case compare (fst a) (fst b) of + EQ + | snd a == snd b -> go as bs + | otherwise -> (fst a, These (snd a) (snd b)) : go as bs + LT -> (fst a, This $ snd a) : go as (b:bs) + GT -> (fst b, That $ snd b) : go (a:as) bs