{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.IndexUtils.IndexUtils
-- Copyright   :  (c) 2016 Herbert Valerio Riedel
-- License     :  BSD3
--
-- Package repositories index state.
--
module Distribution.Client.IndexUtils.IndexState (
    RepoIndexState(..),
    TotalIndexState,
    headTotalIndexState,
    makeTotalIndexState,
    lookupIndexState,
    insertIndexState,
) where

import Distribution.Client.Compat.Prelude
import Distribution.Client.IndexUtils.Timestamp (Timestamp)
import Distribution.Client.Types.RepoName       (RepoName (..))

import Distribution.Parsec (parsecLeadingCommaNonEmpty)

import qualified Data.Map.Strict                 as Map
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint                as Disp

-- $setup
-- >>> import Distribution.Parsec

-------------------------------------------------------------------------------
-- Total index state
-------------------------------------------------------------------------------

-- | Index state of multiple repositories
data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState)
  deriving (TotalIndexState -> TotalIndexState -> Bool
(TotalIndexState -> TotalIndexState -> Bool)
-> (TotalIndexState -> TotalIndexState -> Bool)
-> Eq TotalIndexState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TotalIndexState -> TotalIndexState -> Bool
$c/= :: TotalIndexState -> TotalIndexState -> Bool
== :: TotalIndexState -> TotalIndexState -> Bool
$c== :: TotalIndexState -> TotalIndexState -> Bool
Eq, Int -> TotalIndexState -> ShowS
[TotalIndexState] -> ShowS
TotalIndexState -> String
(Int -> TotalIndexState -> ShowS)
-> (TotalIndexState -> String)
-> ([TotalIndexState] -> ShowS)
-> Show TotalIndexState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TotalIndexState] -> ShowS
$cshowList :: [TotalIndexState] -> ShowS
show :: TotalIndexState -> String
$cshow :: TotalIndexState -> String
showsPrec :: Int -> TotalIndexState -> ShowS
$cshowsPrec :: Int -> TotalIndexState -> ShowS
Show, (forall x. TotalIndexState -> Rep TotalIndexState x)
-> (forall x. Rep TotalIndexState x -> TotalIndexState)
-> Generic TotalIndexState
forall x. Rep TotalIndexState x -> TotalIndexState
forall x. TotalIndexState -> Rep TotalIndexState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TotalIndexState x -> TotalIndexState
$cfrom :: forall x. TotalIndexState -> Rep TotalIndexState x
Generic)

instance Binary TotalIndexState
instance Structured TotalIndexState
instance NFData TotalIndexState

instance Pretty TotalIndexState where
    pretty :: TotalIndexState -> Doc
pretty (TIS RepoIndexState
IndexStateHead Map RepoName RepoIndexState
m)
        | Bool -> Bool
not (Map RepoName RepoIndexState -> Bool
forall k a. Map k a -> Bool
Map.null Map RepoName RepoIndexState
m)
        = [Doc] -> Doc
Disp.hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
Disp.punctuate Doc
Disp.comma
            [ RepoName -> Doc
forall a. Pretty a => a -> Doc
pretty RepoName
rn Doc -> Doc -> Doc
Disp.<+> RepoIndexState -> Doc
forall a. Pretty a => a -> Doc
pretty RepoIndexState
idx
            | (RepoName
rn, RepoIndexState
idx) <- Map RepoName RepoIndexState -> [(RepoName, RepoIndexState)]
forall k a. Map k a -> [(k, a)]
Map.toList Map RepoName RepoIndexState
m
            ]
    pretty (TIS RepoIndexState
def Map RepoName RepoIndexState
m) = (Doc -> (RepoName, RepoIndexState) -> Doc)
-> Doc -> [(RepoName, RepoIndexState)] -> Doc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Doc -> (RepoName, RepoIndexState) -> Doc
forall a a. (Pretty a, Pretty a) => Doc -> (a, a) -> Doc
go (RepoIndexState -> Doc
forall a. Pretty a => a -> Doc
pretty RepoIndexState
def) (Map RepoName RepoIndexState -> [(RepoName, RepoIndexState)]
forall k a. Map k a -> [(k, a)]
Map.toList Map RepoName RepoIndexState
m) where
        go :: Doc -> (a, a) -> Doc
go Doc
doc (a
rn, a
idx) = Doc
doc Doc -> Doc -> Doc
<<>> Doc
Disp.comma Doc -> Doc -> Doc
Disp.<+> a -> Doc
forall a. Pretty a => a -> Doc
pretty a
rn Doc -> Doc -> Doc
Disp.<+> a -> Doc
forall a. Pretty a => a -> Doc
pretty a
idx

-- |
--
-- >>> simpleParsec "HEAD" :: Maybe TotalIndexState
-- Just (TIS IndexStateHead (fromList []))
--
-- >>> simpleParsec "" :: Maybe TotalIndexState
-- Nothing
--
-- >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState
-- Just (TIS IndexStateHead (fromList []))
--
-- >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState
-- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName "hackage.haskell.org",IndexStateHead)]))
--
-- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState
-- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))]))
--
instance Parsec TotalIndexState where
    parsec :: m TotalIndexState
parsec = TotalIndexState -> TotalIndexState
normalise (TotalIndexState -> TotalIndexState)
-> (NonEmpty Tok -> TotalIndexState)
-> NonEmpty Tok
-> TotalIndexState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TotalIndexState -> Tok -> TotalIndexState)
-> TotalIndexState -> NonEmpty Tok -> TotalIndexState
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' TotalIndexState -> Tok -> TotalIndexState
add TotalIndexState
headTotalIndexState (NonEmpty Tok -> TotalIndexState)
-> m (NonEmpty Tok) -> m TotalIndexState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Tok -> m (NonEmpty Tok)
forall (m :: * -> *) a. CabalParsing m => m a -> m (NonEmpty a)
parsecLeadingCommaNonEmpty m Tok
single0 where
        single0 :: m Tok
single0 = m Tok
startsWithRepoName m Tok -> m Tok -> m Tok
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Timestamp -> Tok
TokTimestamp (Timestamp -> Tok) -> m Timestamp -> m Tok
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Timestamp
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        startsWithRepoName :: m Tok
startsWithRepoName = do
            RepoName
reponame <- m RepoName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
            -- the "HEAD" is technically a valid reponame...
            if RepoName
reponame RepoName -> RepoName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> RepoName
RepoName String
"HEAD"
            then Tok -> m Tok
forall (m :: * -> *) a. Monad m => a -> m a
return Tok
TokHead
            else do
                m ()
forall (m :: * -> *). CharParsing m => m ()
P.spaces
                RepoName -> RepoIndexState -> Tok
TokRepo RepoName
reponame (RepoIndexState -> Tok) -> m RepoIndexState -> m Tok
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m RepoIndexState
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec

        add :: TotalIndexState -> Tok -> TotalIndexState
        add :: TotalIndexState -> Tok -> TotalIndexState
add TotalIndexState
_           Tok
TokHead           = TotalIndexState
headTotalIndexState
        add TotalIndexState
_           (TokTimestamp Timestamp
ts) = RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
TIS (Timestamp -> RepoIndexState
IndexStateTime Timestamp
ts) Map RepoName RepoIndexState
forall k a. Map k a
Map.empty
        add (TIS RepoIndexState
def Map RepoName RepoIndexState
m) (TokRepo RepoName
rn RepoIndexState
idx)  = RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
TIS RepoIndexState
def (RepoName
-> RepoIndexState
-> Map RepoName RepoIndexState
-> Map RepoName RepoIndexState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RepoName
rn RepoIndexState
idx Map RepoName RepoIndexState
m)

-- used in Parsec TotalIndexState implementation
data Tok
    = TokRepo RepoName RepoIndexState
    | TokTimestamp Timestamp
    | TokHead

-- | Remove non-default values from 'TotalIndexState'.
normalise :: TotalIndexState -> TotalIndexState
normalise :: TotalIndexState -> TotalIndexState
normalise (TIS RepoIndexState
def Map RepoName RepoIndexState
m) = RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
TIS RepoIndexState
def ((RepoIndexState -> Bool)
-> Map RepoName RepoIndexState -> Map RepoName RepoIndexState
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (RepoIndexState -> RepoIndexState -> Bool
forall a. Eq a => a -> a -> Bool
/= RepoIndexState
def) Map RepoName RepoIndexState
m)

-- | 'TotalIndexState' where all repositories are at @HEAD@ index state.
headTotalIndexState :: TotalIndexState
headTotalIndexState :: TotalIndexState
headTotalIndexState = RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
TIS RepoIndexState
IndexStateHead Map RepoName RepoIndexState
forall k a. Map k a
Map.empty

-- | Create 'TotalIndexState'.
makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
makeTotalIndexState RepoIndexState
def Map RepoName RepoIndexState
m = TotalIndexState -> TotalIndexState
normalise (RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
TIS RepoIndexState
def Map RepoName RepoIndexState
m)

-- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'.
lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState
lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState
lookupIndexState RepoName
rn (TIS RepoIndexState
def Map RepoName RepoIndexState
m) = RepoIndexState
-> RepoName -> Map RepoName RepoIndexState -> RepoIndexState
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault RepoIndexState
def RepoName
rn Map RepoName RepoIndexState
m

-- | Insert a 'RepoIndexState' to 'TotalIndexState'.
insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState
insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState
insertIndexState RepoName
rn RepoIndexState
idx (TIS RepoIndexState
def Map RepoName RepoIndexState
m)
    | RepoIndexState
idx RepoIndexState -> RepoIndexState -> Bool
forall a. Eq a => a -> a -> Bool
== RepoIndexState
def = RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
TIS RepoIndexState
def (RepoName
-> Map RepoName RepoIndexState -> Map RepoName RepoIndexState
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete RepoName
rn Map RepoName RepoIndexState
m)
    | Bool
otherwise  = RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
TIS RepoIndexState
def (RepoName
-> RepoIndexState
-> Map RepoName RepoIndexState
-> Map RepoName RepoIndexState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RepoName
rn RepoIndexState
idx Map RepoName RepoIndexState
m)

-------------------------------------------------------------------------------
-- Repository index state
-------------------------------------------------------------------------------

-- | Specification of the state of a specific repo package index
data RepoIndexState
    = IndexStateHead -- ^ Use all available entries
    | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time
    deriving (RepoIndexState -> RepoIndexState -> Bool
(RepoIndexState -> RepoIndexState -> Bool)
-> (RepoIndexState -> RepoIndexState -> Bool) -> Eq RepoIndexState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RepoIndexState -> RepoIndexState -> Bool
$c/= :: RepoIndexState -> RepoIndexState -> Bool
== :: RepoIndexState -> RepoIndexState -> Bool
$c== :: RepoIndexState -> RepoIndexState -> Bool
Eq,(forall x. RepoIndexState -> Rep RepoIndexState x)
-> (forall x. Rep RepoIndexState x -> RepoIndexState)
-> Generic RepoIndexState
forall x. Rep RepoIndexState x -> RepoIndexState
forall x. RepoIndexState -> Rep RepoIndexState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RepoIndexState x -> RepoIndexState
$cfrom :: forall x. RepoIndexState -> Rep RepoIndexState x
Generic,Int -> RepoIndexState -> ShowS
[RepoIndexState] -> ShowS
RepoIndexState -> String
(Int -> RepoIndexState -> ShowS)
-> (RepoIndexState -> String)
-> ([RepoIndexState] -> ShowS)
-> Show RepoIndexState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RepoIndexState] -> ShowS
$cshowList :: [RepoIndexState] -> ShowS
show :: RepoIndexState -> String
$cshow :: RepoIndexState -> String
showsPrec :: Int -> RepoIndexState -> ShowS
$cshowsPrec :: Int -> RepoIndexState -> ShowS
Show)

instance Binary RepoIndexState
instance Structured RepoIndexState
instance NFData RepoIndexState

instance Pretty RepoIndexState where
    pretty :: RepoIndexState -> Doc
pretty RepoIndexState
IndexStateHead = String -> Doc
Disp.text String
"HEAD"
    pretty (IndexStateTime Timestamp
ts) = Timestamp -> Doc
forall a. Pretty a => a -> Doc
pretty Timestamp
ts

instance Parsec RepoIndexState where
    parsec :: m RepoIndexState
parsec = m RepoIndexState
parseHead m RepoIndexState -> m RepoIndexState -> m RepoIndexState
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m RepoIndexState
parseTime where
        parseHead :: m RepoIndexState
parseHead = RepoIndexState
IndexStateHead RepoIndexState -> m String -> m RepoIndexState
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"HEAD"
        parseTime :: m RepoIndexState
parseTime = Timestamp -> RepoIndexState
IndexStateTime (Timestamp -> RepoIndexState) -> m Timestamp -> m RepoIndexState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Timestamp
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec