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