never executed always true always false
1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
4 module Distribution.Client.IndexUtils.ActiveRepos (
5 ActiveRepos (..),
6 defaultActiveRepos,
7 filterSkippedActiveRepos,
8 ActiveRepoEntry (..),
9 CombineStrategy (..),
10 organizeByRepos,
11 ) where
12
13 import Distribution.Client.Compat.Prelude
14 import Distribution.Client.Types.RepoName (RepoName (..))
15 import Prelude ()
16
17 import Distribution.Parsec (parsecLeadingCommaNonEmpty)
18
19 import qualified Distribution.Compat.CharParsing as P
20 import qualified Text.PrettyPrint as Disp
21
22 -- $setup
23 -- >>> import Distribution.Parsec
24
25 -------------------------------------------------------------------------------
26 -- Types
27 -------------------------------------------------------------------------------
28
29 -- | Ordered list of active repositories.
30 newtype ActiveRepos = ActiveRepos [ActiveRepoEntry]
31 deriving (Eq, Show, Generic)
32
33 defaultActiveRepos :: ActiveRepos
34 defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ]
35
36 -- | Note, this does nothing if 'ActiveRepoRest' is present.
37 filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos
38 filterSkippedActiveRepos repos@(ActiveRepos entries)
39 | any isActiveRepoRest entries = repos
40 | otherwise = ActiveRepos (filter notSkipped entries)
41 where
42 isActiveRepoRest (ActiveRepoRest _) = True
43 isActiveRepoRest _ = False
44
45 notSkipped (ActiveRepo _ CombineStrategySkip) = False
46 notSkipped _ = True
47
48 instance Binary ActiveRepos
49 instance Structured ActiveRepos
50 instance NFData ActiveRepos
51
52 instance Pretty ActiveRepos where
53 pretty (ActiveRepos [])
54 = Disp.text ":none"
55 pretty (ActiveRepos repos)
56 = Disp.hsep
57 $ Disp.punctuate Disp.comma
58 $ map pretty repos
59
60 -- | Note: empty string is not valid 'ActiveRepos'.
61 --
62 -- >>> simpleParsec "" :: Maybe ActiveRepos
63 -- Nothing
64 --
65 -- >>> simpleParsec ":none" :: Maybe ActiveRepos
66 -- Just (ActiveRepos [])
67 --
68 -- >>> simpleParsec ":rest" :: Maybe ActiveRepos
69 -- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge])
70 --
71 -- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos
72 -- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride])
73 --
74 instance Parsec ActiveRepos where
75 parsec = ActiveRepos [] <$ P.try (P.string ":none")
76 <|> do
77 repos <- parsecLeadingCommaNonEmpty parsec
78 return (ActiveRepos (toList repos))
79
80 data ActiveRepoEntry
81 = ActiveRepoRest CombineStrategy -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo'
82 | ActiveRepo RepoName CombineStrategy -- ^ explicit repository name
83 deriving (Eq, Show, Generic)
84
85 instance Binary ActiveRepoEntry
86 instance Structured ActiveRepoEntry
87 instance NFData ActiveRepoEntry
88
89 instance Pretty ActiveRepoEntry where
90 pretty (ActiveRepoRest s) =
91 Disp.text ":rest" <<>> Disp.colon <<>> pretty s
92 pretty (ActiveRepo r s) =
93 pretty r <<>> Disp.colon <<>> pretty s
94
95 instance Parsec ActiveRepoEntry where
96 parsec = leadColon <|> leadRepo where
97 leadColon = do
98 _ <- P.char ':'
99 token <- P.munch1 isAlpha
100 case token of
101 "rest" -> ActiveRepoRest <$> strategyP
102 "repo" -> P.char ':' *> leadRepo
103 _ -> P.unexpected $ "Unknown active repository entry type: " ++ token
104
105 leadRepo = do
106 r <- parsec
107 s <- strategyP
108 return (ActiveRepo r s)
109
110 strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec)
111
112 data CombineStrategy
113 = CombineStrategySkip -- ^ skip this repository
114 | CombineStrategyMerge -- ^ merge existing versions
115 | CombineStrategyOverride -- ^ if later repository specifies a package,
116 -- all package versions are replaced
117 deriving (Eq, Show, Enum, Bounded, Generic)
118
119 instance Binary CombineStrategy
120 instance Structured CombineStrategy
121 instance NFData CombineStrategy
122
123 instance Pretty CombineStrategy where
124 pretty CombineStrategySkip = Disp.text "skip"
125 pretty CombineStrategyMerge = Disp.text "merge"
126 pretty CombineStrategyOverride = Disp.text "override"
127
128 instance Parsec CombineStrategy where
129 parsec = P.choice
130 [ CombineStrategySkip <$ P.string "skip"
131 , CombineStrategyMerge <$ P.string "merge"
132 , CombineStrategyOverride <$ P.string "override"
133 ]
134
135 -------------------------------------------------------------------------------
136 -- Organisation
137 -------------------------------------------------------------------------------
138
139 -- | Sort values 'RepoName' according to 'ActiveRepos' list.
140 --
141 -- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"]
142 -- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos
143 -- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]
144 --
145 -- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos
146 -- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)]
147 --
148 -- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos
149 -- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)]
150 --
151 -- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos
152 -- Left "no repository provided d"
153 --
154 -- Note: currently if 'ActiveRepoRest' is provided more than once,
155 -- rest-repositories will be multiple times in the output.
156 --
157 organizeByRepos
158 :: forall a. ActiveRepos
159 -> (a -> RepoName)
160 -> [a]
161 -> Either String [(a, CombineStrategy)]
162 organizeByRepos (ActiveRepos xs0) sel ys0 =
163 -- here we use lazyness to do only one traversal
164 let (rest, result) = case go rest xs0 ys0 of
165 Right (rest', result') -> (rest', Right result')
166 Left err -> ([], Left err)
167 in result
168 where
169 go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)])
170 go _rest [] ys = Right (ys, [])
171 go rest (ActiveRepoRest s : xs) ys =
172 go rest xs ys <&> \(rest', result) ->
173 (rest', map (\x -> (x, s)) rest ++ result)
174 go rest (ActiveRepo r s : xs) ys = do
175 (z, zs) <- extract r ys
176 go rest xs zs <&> \(rest', result) ->
177 (rest', (z, s) : result)
178
179 extract :: RepoName -> [a] -> Either String (a, [a])
180 extract r = loop id where
181 loop _acc [] = Left $ "no repository provided " ++ prettyShow r
182 loop acc (x:xs)
183 | sel x == r = Right (x, acc xs)
184 | otherwise = loop (acc . (x :)) xs
185
186 (<&>)
187 :: Either err ([s], b)
188 -> (([s], b) -> ([s], c))
189 -> Either err ([s], c)
190 (<&>) = flip fmap