mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-12 04:08:29 +01:00
91 lines
3.3 KiB
Haskell
91 lines
3.3 KiB
Haskell
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
module Stackage.Snapshot.Diff
|
|
( getSnapshotDiff
|
|
, snapshotDiff
|
|
, SnapshotDiff()
|
|
, toDiffList
|
|
, toVersionedDiffList
|
|
, VersionChange(..)
|
|
, WithSnapshotNames(..)
|
|
) where
|
|
|
|
import ClassyPrelude (sortOn, toCaseFold)
|
|
import Data.Aeson
|
|
import qualified Data.Text as T (commonPrefixes)
|
|
import Data.These
|
|
import RIO
|
|
import Stackage.Database (GetStackageDatabase, SnapshotId,
|
|
getPackagesForSnapshotDiff)
|
|
import Types
|
|
import Web.PathPieces
|
|
|
|
data WithSnapshotNames a
|
|
= WithSnapshotNames SnapName SnapName a
|
|
|
|
newtype SnapshotDiff
|
|
= 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 (map (second (WithSnapshotNames nameA nameB)) diff)
|
|
]
|
|
|
|
versionPrefix :: VersionChange -> Maybe (Text, Text, Text)
|
|
versionPrefix vc = case unVersionChange vc of
|
|
These va vb -> T.commonPrefixes (textDisplay va) (textDisplay vb)
|
|
_ -> Nothing
|
|
|
|
versionedDiffList ::
|
|
[(PackageNameP, VersionChange)] -> [(PackageNameP, VersionChange, Maybe (Text, Text, Text))]
|
|
versionedDiffList = map withPrefixedVersion
|
|
where
|
|
withPrefixedVersion (packageName, versionChange) =
|
|
(packageName, versionChange, versionPrefix versionChange)
|
|
|
|
|
|
toVersionedDiffList :: SnapshotDiff -> [(PackageNameP, VersionChange, Maybe (Text, Text, Text))]
|
|
toVersionedDiffList = versionedDiffList . toDiffList
|
|
|
|
-- | Versions of a package as it occurs in the listings provided to `snapshotDiff`.
|
|
--
|
|
-- Would be represented with `These v1 v2` if the package is present in both listings,
|
|
-- otherwise it would be `This v1` if the package is present only in the first listing,
|
|
-- or `That v2` if only in the second.
|
|
newtype VersionChange = VersionChange { unVersionChange :: These VersionP VersionP }
|
|
deriving (Show, Eq, Generic, Typeable)
|
|
|
|
instance ToJSON (WithSnapshotNames VersionChange) where
|
|
toJSON (WithSnapshotNames (toPathPiece -> aKey) (toPathPiece -> bKey) change) =
|
|
case change of
|
|
VersionChange (This a) -> object [ aKey .= a ]
|
|
VersionChange (That b) -> object [ bKey .= b ]
|
|
VersionChange (These a b) -> object [ aKey .= a, bKey .= b ]
|
|
|
|
getSnapshotDiff :: GetStackageDatabase env m => SnapshotId -> SnapshotId -> m SnapshotDiff
|
|
getSnapshotDiff a b = snapshotDiff <$> getPackagesForSnapshotDiff a <*> getPackagesForSnapshotDiff b
|
|
|
|
snapshotDiff
|
|
:: [(PackageNameP, VersionP)]
|
|
-> [(PackageNameP, VersionP)]
|
|
-> SnapshotDiff
|
|
snapshotDiff as0 bs0 =
|
|
SnapshotDiff $ map (second VersionChange) $ go (sortEm as0) (sortEm bs0)
|
|
where
|
|
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
|