1{-# LANGUAGE OverloadedStrings #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module UnitTests.Distribution.Client.DescribedInstances where
4
5import Distribution.Client.Compat.Prelude
6
7import Distribution.Described
8import Data.List ((\\))
9
10import Distribution.Types.Dependency   (Dependency)
11import Distribution.Types.PackageId    (PackageIdentifier)
12import Distribution.Types.PackageName  (PackageName)
13import Distribution.Types.VersionRange (VersionRange)
14
15import Distribution.Client.BuildReports.Types     (InstallOutcome, Outcome)
16import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry, ActiveRepos, CombineStrategy)
17import Distribution.Client.IndexUtils.IndexState  (RepoIndexState, TotalIndexState)
18import Distribution.Client.IndexUtils.Timestamp   (Timestamp)
19import Distribution.Client.Targets                (UserConstraint)
20import Distribution.Client.Types                  (RepoName)
21import Distribution.Client.Types.AllowNewer       (RelaxDepSubject, RelaxDeps, RelaxedDep)
22import Distribution.Client.World                  (WorldPkgInfo)
23import Distribution.Client.Glob                   (FilePathGlob)
24
25-------------------------------------------------------------------------------
26-- BuildReport
27-------------------------------------------------------------------------------
28
29instance Described InstallOutcome where
30    describe _ = REUnion
31        [ "PlanningFailed"
32        , "DependencyFailed" <> RESpaces1 <> describe (Proxy :: Proxy PackageIdentifier)
33        , "DownloadFailed"
34        , "UnpackFailed"
35        , "SetupFailed"
36        , "ConfigureFailed"
37        , "BuildFailed"
38        , "TestsFailed"
39        , "InstallFailed"
40        , "InstallOk"
41        ]
42instance Described Outcome where
43    describe _ = REUnion
44        [ fromString (prettyShow o)
45        | o <- [minBound .. maxBound :: Outcome]
46        ]
47
48-------------------------------------------------------------------------------
49-- Glob
50-------------------------------------------------------------------------------
51
52-- This instance is incorrect as it may generate C:\dir\{foo,bar}
53instance Described FilePathGlob where
54    describe _ = REUnion [ root, relative, homedir ] where
55        root = REUnion
56            [ fromString "/"
57            , reChars (['a'..'z'] ++ ['A' .. 'Z']) <> ":" <> reChars "/\\"
58            ] <> REOpt pieces
59        homedir = "~/" <> REOpt pieces
60        relative = pieces
61
62        pieces :: GrammarRegex void
63        pieces = REMunch1 sep piece <> REOpt "/"
64
65        piece :: GrammarRegex void
66        piece = RERec "glob" $ REMunch1 mempty $ REUnion
67            [ normal
68            , escape
69            , wildcard
70            , "{" <> REMunch1 "," (REVar Nothing) <> "}"
71            ]
72
73        sep :: GrammarRegex void
74        sep = reChars "/\\"
75
76        wildcard :: GrammarRegex void
77        wildcard = "*"
78
79        normal   = reChars $ ['\0'..'\128'] \\ "*{},/\\"
80        escape   = fromString "\\" <> reChars "*{},"
81
82-------------------------------------------------------------------------------
83-- WorldPkgInfo
84-------------------------------------------------------------------------------
85
86instance Described WorldPkgInfo where
87  describe _ =
88    describe (Proxy :: Proxy Dependency)
89    <> REOpt (RESpaces1 <> "--flags=\"" <> describeFlagAssignmentNonEmpty <> "\"")
90
91-------------------------------------------------------------------------------
92-- AllowNewer
93-------------------------------------------------------------------------------
94
95instance Described RelaxedDep where
96    describe _ =
97        REOpt (describeRelaxDepScope <> ":" <> REOpt ("^"))
98        <> describe (Proxy :: Proxy RelaxDepSubject)
99      where
100        describeRelaxDepScope = REUnion
101            [ "*"
102            , "all"
103            , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
104            , RENamed "package-id" (describe (Proxy :: Proxy PackageIdentifier))
105            ]
106
107instance Described RelaxDepSubject where
108    describe _ = REUnion
109        [ "*"
110        , "all"
111        , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
112        ]
113
114instance Described RelaxDeps where
115    describe _ = REUnion
116        [ "*"
117        , "all"
118        , "none"
119        , RECommaNonEmpty (describe (Proxy :: Proxy RelaxedDep))
120        ]
121
122-------------------------------------------------------------------------------
123-- ActiveRepos
124-------------------------------------------------------------------------------
125
126instance Described ActiveRepos where
127    describe _ = REUnion
128        [ ":none"
129        , RECommaNonEmpty (describe (Proxy :: Proxy ActiveRepoEntry))
130        ]
131
132instance Described ActiveRepoEntry where
133    describe _ = REUnion
134        [ ":rest" <> strategy
135        , REOpt ":repo:" <> describe (Proxy :: Proxy RepoName) <> strategy
136        ]
137      where
138        strategy = REOpt $ ":" <> describe (Proxy :: Proxy CombineStrategy)
139
140instance Described CombineStrategy where
141    describe _ = REUnion
142        [ "skip"
143        , "merge"
144        , "override"
145        ]
146
147-------------------------------------------------------------------------------
148-- UserConstraint
149-------------------------------------------------------------------------------
150
151instance Described UserConstraint where
152    describe _ = REAppend
153        [ describeConstraintScope
154        , describeConstraintProperty
155        ]
156      where
157        describeConstraintScope :: GrammarRegex void
158        describeConstraintScope = REUnion
159            [ "any." <> describePN
160            , "setup." <> describePN
161            , describePN
162            , describePN <> ":setup." <> describePN
163            ]
164
165        describeConstraintProperty :: GrammarRegex void
166        describeConstraintProperty = REUnion
167            [ RESpaces <> RENamed "version-range" (describe (Proxy :: Proxy VersionRange))
168            , RESpaces1 <> describeConstraintProperty'
169            ]
170
171        describeConstraintProperty' :: GrammarRegex void
172        describeConstraintProperty' = REUnion
173            [ "installed"
174            , "source"
175            , "test"
176            , "bench"
177            , describeFlagAssignmentNonEmpty
178            ]
179
180        describePN :: GrammarRegex void
181        describePN = RENamed "package-name" (describe (Proxy :: Proxy PackageName))
182
183-------------------------------------------------------------------------------
184-- IndexState
185-------------------------------------------------------------------------------
186
187instance Described TotalIndexState where
188    describe _ = reCommaNonEmpty $ REUnion
189        [ describe (Proxy :: Proxy RepoName) <> RESpaces1 <> ris
190        , ris
191        ]
192      where
193        ris = describe (Proxy :: Proxy RepoIndexState)
194
195instance Described RepoName where
196    describe _ = lead <> rest where
197        lead = RECharSet $ csAlpha    <> "_-."
198        rest = reMunchCS $ csAlphaNum <> "_-."
199
200instance Described RepoIndexState where
201    describe _ = REUnion
202        [ "HEAD"
203        , RENamed "timestamp" (describe (Proxy :: Proxy Timestamp))
204        ]
205
206instance Described Timestamp where
207    describe _ =  REUnion
208        [ posix
209        , utc
210        ]
211      where
212        posix = reChar '@' <> reMunch1CS "0123456789"
213        utc   = RENamed "date" date <> reChar 'T' <> RENamed "time" time <> reChar 'Z'
214
215        date = REOpt digit <> REUnion
216            [ leapYear   <> reChar '-' <> leapMD
217            , commonYear <> reChar '-' <> commonMD
218            ]
219
220        -- leap year: either
221        -- * divisible by 400
222        -- * not divisible by 100 and divisible by 4
223        leapYear = REUnion
224            [ div4           <> "00"
225            , digit <> digit <> div4not0
226            ]
227
228        -- common year: either
229        -- * not divisible by 400 but divisible by 100
230        -- * not divisible by 4
231        commonYear = REUnion
232            [ notDiv4        <> "00"
233            , digit <> digit <> notDiv4
234            ]
235
236        div4 = REUnion
237            [ "0" <> reChars "048"
238            , "1" <> reChars "26"
239            , "2" <> reChars "048"
240            , "3" <> reChars "26"
241            , "4" <> reChars "048"
242            , "5" <> reChars "26"
243            , "6" <> reChars "048"
244            , "7" <> reChars "26"
245            , "8" <> reChars "048"
246            , "9" <> reChars "26"
247            ]
248
249        div4not0 = REUnion
250            [ "0" <> reChars "48" -- no zero
251            , "1" <> reChars "26"
252            , "2" <> reChars "048"
253            , "3" <> reChars "26"
254            , "4" <> reChars "048"
255            , "5" <> reChars "26"
256            , "6" <> reChars "048"
257            , "7" <> reChars "26"
258            , "8" <> reChars "048"
259            , "9" <> reChars "26"
260            ]
261
262        notDiv4 = REUnion
263            [ "0" <> reChars "1235679"
264            , "1" <> reChars "01345789"
265            , "2" <> reChars "1235679"
266            , "3" <> reChars "01345789"
267            , "4" <> reChars "1235679"
268            , "5" <> reChars "01345789"
269            , "6" <> reChars "1235679"
270            , "7" <> reChars "01345789"
271            , "8" <> reChars "1235679"
272            , "9" <> reChars "01345789"
273            ]
274
275        leapMD = REUnion
276            [ jan, fe', mar, apr, may, jun, jul, aug, sep, oct, nov, dec ]
277
278        commonMD = REUnion
279            [ jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec ]
280
281        jan = "01-" <> d31
282        feb = "02-" <> d28
283        fe' = "02-" <> d29
284        mar = "03-" <> d31
285        apr = "04-" <> d30
286        may = "05-" <> d31
287        jun = "06-" <> d30
288        jul = "07-" <> d31
289        aug = "08-" <> d31
290        sep = "09-" <> d30
291        oct = "10-" <> d31
292        nov = "11-" <> d30
293        dec = "12-" <> d31
294
295        d28 = REUnion
296            [ "0" <> digit1, "1" <> digit, "2" <> reChars "012345678" ]
297        d29 = REUnion
298            [ "0" <> digit1, "1" <> digit, "2" <> digit ]
299        d30 = REUnion
300            [ "0" <> digit1, "1" <> digit, "2" <> digit, "30" ]
301        d31 = REUnion
302            [ "0" <> digit1, "1" <> digit, "2" <> digit, "30", "31" ]
303
304        time = ho <> reChar ':' <> minSec <> reChar ':' <> minSec
305
306        -- 0..23
307        ho = REUnion
308            [ "0" <> digit
309            , "1" <> digit
310            , "2" <> reChars "0123"
311            ]
312
313        -- 0..59
314        minSec = reChars "012345" <> digit
315
316        digit  = reChars "0123456789"
317        digit1 = reChars  "123456789"
318