cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3
   4 -----------------------------------------------------------------------------
   5
   6 -- |
   7 -- Module      :  Distribution.Client.IndexUtils.IndexUtils
   8 -- Copyright   :  (c) 2016 Herbert Valerio Riedel
   9 -- License     :  BSD3
  10 --
  11 -- Package repositories index state.
  12 module Distribution.Client.IndexUtils.IndexState
  13   ( RepoIndexState (..)
  14   , TotalIndexState
  15   , headTotalIndexState
  16   , makeTotalIndexState
  17   , lookupIndexState
  18   , insertIndexState
  19   ) where
  20
  21 import Distribution.Client.Compat.Prelude
  22 import Distribution.Client.IndexUtils.Timestamp (Timestamp)
  23 import Distribution.Client.Types.RepoName (RepoName (..))
  24
  25 import Distribution.Parsec (parsecLeadingCommaNonEmpty)
  26
  27 import qualified Data.Map.Strict as Map
  28 import qualified Distribution.Compat.CharParsing as P
  29 import qualified Text.PrettyPrint as Disp
  30
  31 -- $setup
  32 -- >>> import Distribution.Parsec
  33
  34 -------------------------------------------------------------------------------
  35 -- Total index state
  36 -------------------------------------------------------------------------------
  37
  38 -- | Index state of multiple repositories
  39 data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState)
  40   deriving (Eq, Show, Generic)
  41
  42 instance Binary TotalIndexState
  43 instance Structured TotalIndexState
  44 instance NFData TotalIndexState
  45
  46 instance Pretty TotalIndexState where
  47   pretty (TIS IndexStateHead m)
  48     | not (Map.null m) =
  49         Disp.hsep $
  50           Disp.punctuate
  51             Disp.comma
  52             [ pretty rn Disp.<+> pretty idx
  53             | (rn, idx) <- Map.toList m
  54             ]
  55   pretty (TIS def m) = foldl' go (pretty def) (Map.toList m)
  56     where
  57       go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx
  58
  59 -- |
  60 --
  61 -- >>> simpleParsec "HEAD" :: Maybe TotalIndexState
  62 -- Just (TIS IndexStateHead (fromList []))
  63 --
  64 -- >>> simpleParsec "" :: Maybe TotalIndexState
  65 -- Nothing
  66 --
  67 -- >>> simpleParsec "hackage.haskell.org HEAD" :: Maybe TotalIndexState
  68 -- Just (TIS IndexStateHead (fromList []))
  69 --
  70 -- >>> simpleParsec "2020-02-04T12:34:56Z, hackage.haskell.org HEAD" :: Maybe TotalIndexState
  71 -- Just (TIS (IndexStateTime (TS 1580819696)) (fromList [(RepoName {unRepoName = "hackage.haskell.org"},IndexStateHead)]))
  72 --
  73 -- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState
  74 -- Just (TIS IndexStateHead (fromList [(RepoName {unRepoName = "hackage.haskell.org"},IndexStateTime (TS 1580819696))]))
  75 instance Parsec TotalIndexState where
  76   parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0
  77     where
  78       single0 = startsWithRepoName <|> TokTimestamp <$> parsec
  79       startsWithRepoName = do
  80         reponame <- parsec
  81         -- the "HEAD" is technically a valid reponame...
  82         if reponame == RepoName "HEAD"
  83           then return TokHead
  84           else do
  85             P.spaces
  86             TokRepo reponame <$> parsec
  87
  88       add :: TotalIndexState -> Tok -> TotalIndexState
  89       add _ TokHead = headTotalIndexState
  90       add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty
  91       add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m)
  92
  93 -- used in Parsec TotalIndexState implementation
  94 data Tok
  95   = TokRepo RepoName RepoIndexState
  96   | TokTimestamp Timestamp
  97   | TokHead
  98
  99 -- | Remove non-default values from 'TotalIndexState'.
 100 normalise :: TotalIndexState -> TotalIndexState
 101 normalise (TIS def m) = TIS def (Map.filter (/= def) m)
 102
 103 -- | 'TotalIndexState' where all repositories are at @HEAD@ index state.
 104 headTotalIndexState :: TotalIndexState
 105 headTotalIndexState = TIS IndexStateHead Map.empty
 106
 107 -- | Create 'TotalIndexState'.
 108 makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
 109 makeTotalIndexState def m = normalise (TIS def m)
 110
 111 -- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'.
 112 lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState
 113 lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m
 114
 115 -- | Insert a 'RepoIndexState' to 'TotalIndexState'.
 116 insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState
 117 insertIndexState rn idx (TIS def m)
 118   | idx == def = TIS def (Map.delete rn m)
 119   | otherwise = TIS def (Map.insert rn idx m)
 120
 121 -------------------------------------------------------------------------------
 122 -- Repository index state
 123 -------------------------------------------------------------------------------
 124
 125 -- | Specification of the state of a specific repo package index
 126 data RepoIndexState
 127   = -- | Use all available entries
 128     IndexStateHead
 129   | -- | Use all entries that existed at the specified time
 130     IndexStateTime !Timestamp
 131   deriving (Eq, Generic, Show)
 132
 133 instance Binary RepoIndexState
 134 instance Structured RepoIndexState
 135 instance NFData RepoIndexState
 136
 137 instance Pretty RepoIndexState where
 138   pretty IndexStateHead = Disp.text "HEAD"
 139   pretty (IndexStateTime ts) = pretty ts
 140
 141 instance Parsec RepoIndexState where
 142   parsec = parseHead <|> parseTime
 143     where
 144       parseHead = IndexStateHead <$ P.string "HEAD"
 145       parseTime = IndexStateTime <$> parsec