?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
gitlab CI generates x64-deb11 images
[cabal.git] / Cabal-described / src / Distribution / Described.hs
blobd095040a87ce08913be76a9a4bc9cf12449f3baf
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 module Distribution.Described (
4 Described (..),
5 describeDoc,
6 -- * Regular expressions
7 GrammarRegex (..),
8 reEps,
9 reChar,
10 reChars,
11 reMunchCS,
12 reMunch1CS,
13 -- * Variables
14 reVar0,
15 reVar1,
16 -- * Special expressions
17 reDot,
18 reComma,
19 reSpacedComma,
20 reHsString,
21 reUnqualComponent,
22 -- *
23 describeFlagAssignmentNonEmpty,
24 -- * Lists
25 reSpacedList,
26 reCommaList,
27 reCommaNonEmpty,
28 reOptCommaList,
29 -- * Character Sets
30 csChar,
31 csAlpha,
32 csAlphaNum,
33 csUpper,
34 csNotSpace,
35 csNotSpaceOrComma,
36 -- * tasty
37 testDescribed,
38 ) where
39
40 import Prelude
41 (Bool (..), Char, Either (..), Enum (..), Eq (..), Ord (..), Show (..), String, elem, fmap, foldr, id, map, maybe, otherwise, return, undefined, ($),
42 (.))
43
44 import Data.Functor.Identity (Identity (..))
45 import Data.Maybe (fromMaybe)
46 import Data.Proxy (Proxy (..))
47 import Data.String (IsString (..))
48 import Data.Typeable (Typeable, typeOf)
49 import Data.Void (Void, vacuous)
50 import Test.QuickCheck (Arbitrary (..), Property, counterexample)
51 import Test.Tasty (TestTree, testGroup)
52 import Test.Tasty.QuickCheck (testProperty)
53
54 import Distribution.Compat.Semigroup (Semigroup (..))
55 import Distribution.Parsec (Parsec, eitherParsec)
56 import Distribution.Pretty (Pretty, prettyShow)
57
58 import qualified Distribution.Utils.CharSet as CS
59 import qualified RERE as RE
60 import qualified RERE.CharSet as RE
61 import qualified Text.PrettyPrint as PP
62
63 import Distribution.Utils.GrammarRegex
64
65 -- Types
66 import Distribution.Compat.Newtype
67 import Distribution.Compiler (CompilerFlavor, CompilerId, knownCompilerFlavors)
68 import Distribution.FieldGrammar.Newtypes
69 import Distribution.ModuleName (ModuleName)
70 import Distribution.System (Arch, OS, knownArches, knownOSs)
71 import Distribution.Types.AbiDependency (AbiDependency)
72 import Distribution.Types.AbiHash (AbiHash)
73 import Distribution.Types.BenchmarkType (BenchmarkType)
74 import Distribution.Types.BuildType (BuildType)
75 import Distribution.Types.Dependency (Dependency)
76 import Distribution.Types.ExecutableScope (ExecutableScope)
77 import Distribution.Types.ExeDependency (ExeDependency)
78 import Distribution.Types.ExposedModule (ExposedModule)
79 import Distribution.Types.Flag (FlagAssignment, FlagName)
80 import Distribution.Types.ForeignLib (LibVersionInfo)
81 import Distribution.Types.ForeignLibOption (ForeignLibOption)
82 import Distribution.Types.ForeignLibType (ForeignLibType)
83 import Distribution.Types.IncludeRenaming (IncludeRenaming)
84 import Distribution.Types.LegacyExeDependency (LegacyExeDependency)
85 import Distribution.Types.LibraryVisibility (LibraryVisibility)
86 import Distribution.Types.Mixin (Mixin)
87 import Distribution.Types.ModuleReexport (ModuleReexport)
88 import Distribution.Types.ModuleRenaming (ModuleRenaming)
89 import Distribution.Types.MungedPackageName (MungedPackageName)
90 import Distribution.Types.PackageId (PackageIdentifier)
91 import Distribution.Types.PackageName (PackageName)
92 import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint)
93 import Distribution.Types.PkgconfigDependency (PkgconfigDependency)
94 import Distribution.Types.SourceRepo (RepoType)
95 import Distribution.Types.TestType (TestType)
96 import Distribution.Types.UnitId (UnitId)
97 import Distribution.Types.UnqualComponentName (UnqualComponentName)
98 import Distribution.Verbosity (Verbosity)
99 import Distribution.Version (Version, VersionRange)
100 import Language.Haskell.Extension (Extension, Language)
101
102 -- | Class describing the pretty/parsec format of a.
103 class (Pretty a, Parsec a) => Described a where
104 -- | A pretty document of "regex" describing the field format
105 describe :: proxy a -> GrammarRegex void
106
107 -- | Pretty-print description.
108 --
109 -- >>> describeDoc ([] :: [Bool])
110 -- \left\{ \mathop{\mathord{``}\mathtt{True}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{False}\mathord{"}} \right\}
111 --
112 describeDoc :: Described a => proxy a -> PP.Doc
113 describeDoc p = regexDoc (describe p)
114
115 instance Described Bool where
116 describe _ = REUnion ["True", "False"]
117
118 instance Described a => Described (Identity a) where
119 describe _ = describe ([] :: [a])
120
121 -------------------------------------------------------------------------------
122 -- Lists
123 ------------------------------------------------------------------------------
124
125 reSpacedList :: GrammarRegex a -> GrammarRegex a
126 reSpacedList = REMunch RESpaces1
127
128 reCommaList :: GrammarRegex a -> GrammarRegex a
129 reCommaList = RECommaList
130
131 reCommaNonEmpty :: GrammarRegex a -> GrammarRegex a
132 reCommaNonEmpty = RECommaNonEmpty
133
134 reOptCommaList :: GrammarRegex a -> GrammarRegex a
135 reOptCommaList = REOptCommaList
136
137 -------------------------------------------------------------------------------
138 -- Specific grammars
139 -------------------------------------------------------------------------------
140
141 reHsString :: GrammarRegex a
142 reHsString = RENamed "hs-string" impl where
143 impl = reChar '"' <> REMunch reEps (REUnion [strChar, escChar]) <> reChar '"'
144 strChar = RECharSet $ CS.difference CS.universe (CS.fromList "\"\\")
145
146 escChar = REUnion
147 [ "\\&"
148 , "\\\\"
149 , REUnion ["\\n", RENamed "escapes" "\\n"] -- TODO
150 , "\\" <> RECharSet "0123456789"
151 , "\\o" <> RECharSet "01234567"
152 , "\\x" <> RECharSet "0123456789abcdefABCDEF"
153 , REUnion ["\\^@", RENamed "control" "\\^@"] -- TODO
154 , REUnion ["\\NUL", RENamed "ascii" "\\NUL"] -- TODO
155 ]
156
157 reUnqualComponent :: GrammarRegex a
158 reUnqualComponent = RENamed "unqual-name" $
159 REMunch1 (reChar '-') component
160 where
161 component
162 = REMunch reEps (RECharSet csAlphaNum)
163 -- currently the parser accepts "csAlphaNum `difference` "0123456789"
164 -- which is larger set than CS.alpha
165 --
166 -- Hackage rejects non ANSI names, so it's not so relevant.
167 <> RECharSet CS.alpha
168 <> REMunch reEps (RECharSet csAlphaNum)
169
170 reDot :: GrammarRegex a
171 reDot = reChar '.'
172
173 reComma :: GrammarRegex a
174 reComma = reChar ','
175
176 reSpacedComma :: GrammarRegex a
177 reSpacedComma = RESpaces <> reComma <> RESpaces
178
179 -------------------------------------------------------------------------------
180 -- Character sets
181 -------------------------------------------------------------------------------
182
183 csChar :: Char -> CS.CharSet
184 csChar = CS.singleton
185
186 csAlpha :: CS.CharSet
187 csAlpha = CS.alpha
188
189 csAlphaNum :: CS.CharSet
190 csAlphaNum = CS.alphanum
191
192 csUpper :: CS.CharSet
193 csUpper = CS.upper
194
195 csNotSpace :: CS.CharSet
196 csNotSpace = CS.difference CS.universe $ CS.singleton ' '
197
198 csNotSpaceOrComma :: CS.CharSet
199 csNotSpaceOrComma = CS.difference csNotSpace $ CS.singleton ','
200
201 -------------------------------------------------------------------------------
202 -- Special
203 -------------------------------------------------------------------------------
204
205 describeFlagAssignmentNonEmpty :: GrammarRegex void
206 describeFlagAssignmentNonEmpty = REMunch1 RESpaces1 $
207 REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName)
208
209 -------------------------------------------------------------------------------
210 -- Conversion
211 -------------------------------------------------------------------------------
212
213 convert :: GrammarRegex Void -> RE.RE Void
214 convert = go id . vacuous where
215 go :: Ord b => (a -> b) -> GrammarRegex a -> RE.RE b
216 go f (REAppend rs) = foldr (\r acc -> go f r <> acc) RE.Eps rs
217 go f (REUnion rs) = foldr (\r acc -> go f r RE.\/ acc) RE.Null rs
218 go _ (RECharSet cs) = RE.Ch (convertCS cs)
219 go _ (REString str) = RE.string_ str
220
221 go f (REMunch sep r) = RE.Eps RE.\/ r' <> RE.star_ (sep' <> r') where
222 sep' = go f sep
223 r' = go f r
224 go f (REMunch1 sep r) = r' <> RE.star_ (sep' <> r') where
225 sep' = go f sep
226 r' = go f r
227 go f (REMunchR n sep r)
228 | n <= 0 = RE.Eps
229 | otherwise = RE.Eps RE.\/ r' <> go' (pred n)
230 where
231 sep' = go f sep
232 r' = go f r
233
234 go' m | m <= 0 = RE.Eps
235 | otherwise = RE.Eps RE.\/ sep' <> r' <> go' (pred m)
236
237 go f (REOpt r) = RE.Eps RE.\/ go f r
238
239 go f (REVar a) = RE.Var (f a)
240 go f (RENamed _ r) = go f r
241 go f (RERec n r) = RE.fix_ (fromString n)
242 (go (maybe RE.B (RE.F . f)) r)
243
244 go _ RESpaces = RE.Eps RE.\/ RE.ch_ ' ' RE.\/ " " RE.\/ "\n"
245 go _ RESpaces1 = RE.ch_ ' ' RE.\/ " " RE.\/ "\n"
246
247 go f (RECommaList r) = go f (expandedCommaList r)
248 go f (RECommaNonEmpty r)= go f (expandedCommaNonEmpty r)
249 go f (REOptCommaList r) = go f (expandedOptCommaList r)
250
251 go _ RETodo = RE.Null
252
253 expandedCommaList :: GrammarRegex a -> GrammarRegex a
254 expandedCommaList = REUnion . expandedCommaList'
255
256 expandedCommaNonEmpty :: GrammarRegex a -> GrammarRegex a
257 expandedCommaNonEmpty r = REUnion
258 [ REMunch1 reSpacedComma r
259 , reComma <> RESpaces <> REMunch1 reSpacedComma r
260 , REMunch1 reSpacedComma r <> RESpaces <> reComma
261 ]
262
263 expandedCommaList' :: GrammarRegex a -> [GrammarRegex a]
264 expandedCommaList' r =
265 [ REMunch reSpacedComma r
266 , reComma <> RESpaces <> REMunch1 reSpacedComma r
267 , REMunch1 reSpacedComma r <> RESpaces <> reComma
268 ]
269
270 expandedOptCommaList :: GrammarRegex a -> GrammarRegex a
271 expandedOptCommaList r = REUnion $ reSpacedList r : expandedCommaList' r
272
273 convertCS :: CS.CharSet -> RE.CharSet
274 convertCS = RE.fromIntervalList . CS.toIntervalList
275
276 -------------------------------------------------------------------------------
277 -- tasty
278 -------------------------------------------------------------------------------
279
280 testDescribed
281 :: forall a. (Arbitrary a, Described a, Typeable a, Eq a, Show a)
282 => Proxy a
283 -> TestTree
284 testDescribed _ = testGroup name
285 [ testProperty "parsec" propParsec
286 , testProperty "pretty" propPretty
287 , testProperty "roundtrip" propRoundtrip
288 ]
289 where
290 name = show (typeOf (undefined :: a))
291
292 propParsec :: Ex a -> Property
293 propParsec (Example str) = counterexample (show res) $ case res of
294 Right _ -> True
295 Left _ -> False
296 where
297 res :: Either String a
298 res = eitherParsec str
299
300 rr :: RE.RE Void
301 rr = convert $ describe (Proxy :: Proxy a)
302
303 propPretty :: a -> Property
304 propPretty x = counterexample str $ RE.matchR rr str
305 where
306 str = prettyShow x
307
308 propRoundtrip :: a -> Property
309 propRoundtrip x = counterexample (show (res, str)) $ case res of
310 Right y -> x == y
311 Left _ -> False
312 where
313 str = prettyShow x
314 res = eitherParsec str
315
316 newtype Ex a = Example String
317 deriving (Show)
318
319 instance Described a => Arbitrary (Ex a) where
320 arbitrary
321 = fmap Example
322 $ fromMaybe (return "")
323 $ RE.generate 10 5
324 $ convert $ describe (Proxy :: Proxy a)
325
326 shrink (Example s)
327 | '\n' `elem` s = [ Example $ map (\c -> if c == '\n' then ' ' else c) s ]
328 | otherwise = []
329
330 -------------------------------------------------------------------------------
331 -- Instances
332 -------------------------------------------------------------------------------
333
334 instance Described AbiDependency where
335 describe _ =
336 describe (Proxy :: Proxy UnitId) <>
337 reChar '=' <>
338 describe (Proxy :: Proxy AbiHash)
339
340 instance Described AbiHash where
341 describe _ = reMunchCS csAlphaNum
342
343 instance Described Arch where
344 describe _ = REUnion
345 [ fromString (prettyShow arch)
346 | arch <- knownArches
347 ]
348
349 instance Described BenchmarkType where
350 describe _ = "exitcode-stdio-1.0"
351
352 instance Described BuildType where
353 describe _ = REUnion ["Simple","Configure","Custom","Make","Default"]
354
355 instance Described CompilerFlavor where
356 describe _ = REUnion
357 [ fromString (prettyShow c)
358 | c <- knownCompilerFlavors
359 ]
360
361 instance Described CompilerId where
362 describe _ =
363 describe (Proxy :: Proxy CompilerFlavor)
364 <> fromString "-"
365 <> describe (Proxy :: Proxy Version)
366
367 instance Described Dependency where
368 describe _ = REAppend
369 [ RENamed "pkg-name" (describe (Proxy :: Proxy PackageName))
370 , REOpt $
371 reChar ':'
372 <> REUnion
373 [ reUnqualComponent
374 , REAppend
375 [ reChar '{'
376 , RESpaces
377 -- no leading or trailing comma
378 , REMunch1 reSpacedComma reUnqualComponent
379 , RESpaces
380 , reChar '}'
381 ]
382 ]
383
384 , REOpt $ RESpaces <> vr
385 ]
386 where
387 vr = RENamed "version-range" (describe (Proxy :: Proxy VersionRange))
388
389 instance Described ExecutableScope where
390 describe _ = REUnion ["public","private"]
391
392 instance Described ExeDependency where
393 describe _ = RETodo
394
395 instance Described ExposedModule where
396 describe _ = RETodo
397
398 instance Described Extension where
399 describe _ = RETodo
400
401 instance Described FlagAssignment where
402 describe _ = REMunch RESpaces1 $
403 REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName)
404
405 instance Described FlagName where
406 describe _ = lead <> rest where
407 lead = RECharSet $ csAlphaNum <> fromString "_"
408 rest = reMunchCS $ csAlphaNum <> fromString "_-"
409
410 instance Described ForeignLibOption where
411 describe _ = "standalone"
412
413 instance Described ForeignLibType where
414 describe _ = REUnion ["native-shared","native-static"]
415
416 instance Described IncludeRenaming where
417 describe _ = mr <> REOpt (RESpaces <> "requires" <> RESpaces1 <> mr)
418 where
419 mr = describe (Proxy :: Proxy ModuleRenaming)
420
421 instance Described Language where
422 describe _ = REUnion ["Haskell98", "Haskell2010"]
423
424 instance Described LegacyExeDependency where
425 describe _ = RETodo
426
427 instance Described LibraryVisibility where
428 describe _ = REUnion ["public","private"]
429
430 instance Described LibVersionInfo where
431 describe _ = reDigits <> REOpt (reChar ':' <> reDigits <> REOpt (reChar ':' <> reDigits)) where
432 reDigits = reChars ['0'..'9']
433
434 instance Described Mixin where
435 describe _ =
436 RENamed "package-name" (describe (Proxy :: Proxy PackageName)) <>
437 REOpt (reChar ':' <> RENamed "library-name" (describe (Proxy :: Proxy UnqualComponentName))) <>
438 REOpt (RESpaces1 <> describe (Proxy :: Proxy IncludeRenaming))
439
440 instance Described ModuleName where
441 describe _ = REMunch1 (reChar '.') component where
442 component = RECharSet csUpper <> REMunch reEps (REUnion [RECharSet csAlphaNum, RECharSet (fromString "_'")])
443
444 instance Described ModuleReexport where
445 describe _ = RETodo
446
447 instance Described ModuleRenaming where
448 describe _ = REUnion
449 [ reEps
450 , "hiding" <> RESpaces <> bp (REMunch reSpacedComma mn)
451 , bp (REMunch reSpacedComma entry)
452 ]
453 where
454 bp r = "(" <> RESpaces <> r <> RESpaces <> ")"
455 mn = RENamed "module-name" $ describe (Proxy :: Proxy ModuleName)
456
457 entry = mn <> REOpt (RESpaces1 <> "as" <> RESpaces1 <> mn)
458
459 instance Described MungedPackageName where
460 describe _ = RETodo
461
462 instance Described OS where
463 describe _ = REUnion
464 [ fromString (prettyShow os)
465 | os <- knownOSs
466 ]
467
468 instance Described PackageIdentifier where
469 describe _ = describe (Proxy :: Proxy PackageName) <> fromString "-" <> describe (Proxy :: Proxy Version)
470
471 instance Described PackageName where
472 describe _ = reUnqualComponent
473
474 instance Described PackageVersionConstraint where
475 describe _ = describe (Proxy :: Proxy PackageName) <> REUnion
476 [ fromString "-" <> describe (Proxy :: Proxy Version)
477 , RESpaces <> describe (Proxy :: Proxy VersionRange)
478 ]
479
480 instance Described PkgconfigDependency where
481 describe _ = RETodo
482
483 instance Described RepoType where
484 describe _ = reMunch1CS $ csAlphaNum <> csChar '_' <> csChar '-'
485
486 instance Described TestType where
487 describe _ = REUnion ["exitcode-stdio-1.0", "detailed-0.9"]
488
489 instance Described Verbosity where
490 describe _ = REUnion
491 [ REUnion ["0", "1", "2", "3"]
492 , REUnion ["silent", "normal", "verbose", "debug", "deafening"]
493 <> REMunch reEps (RESpaces <> "+" <>
494 -- markoutput is left out on purpose
495 REUnion ["callsite", "callstack", "nowrap", "timestamp", "stderr", "stdout" ])
496 ]
497
498 instance Described Version where
499 describe _ = REMunch1 reDot reDigits where
500 reDigits = REUnion
501 [ reChar '0'
502 , reChars ['1'..'9'] <> REMunchR 8 reEps (reChars ['0'..'9'])
503 ]
504
505 instance Described VersionRange where
506 describe _ = RERec "version-range" $ REUnion
507 [ "==" <> RESpaces <> ver
508 , ">" <> RESpaces <> ver
509 , "<" <> RESpaces <> ver
510 , "<=" <> RESpaces <> ver
511 , ">=" <> RESpaces <> ver
512 , "^>=" <> RESpaces <> ver
513
514 -- ==0.1.*
515 , "==" <> RESpaces <> wildVer
516
517 , reVar0 <> RESpaces <> "||" <> RESpaces <> reVar0
518 , reVar0 <> RESpaces <> "&&" <> RESpaces <> reVar0
519 , "(" <> RESpaces <> reVar0 <> RESpaces <> ")"
520
521 -- == { 0.1.2 }
522 -- silly haddock: ^>= { 0.1.2, 3.4.5 }
523 , "==" <> RESpaces <> verSet
524 , "^>=" <> RESpaces <> verSet
525 ]
526 where
527 ver' = describe (Proxy :: Proxy Version)
528 ver = RENamed "version" ver'
529 wildVer = ver' <> ".*"
530 verSet = "{" <> RESpaces <> REMunch1 reSpacedComma ver <> RESpaces <> "}"
531
532 instance Described UnitId where
533 describe _ = reMunch1CS $ csAlphaNum <> csChar '-' <> csChar '_' <> csChar '.' <> csChar '+'
534
535 instance Described UnqualComponentName where
536 describe _ = reUnqualComponent
537
538 -------------------------------------------------------------------------------
539 -- Instances: Newtypes
540 -------------------------------------------------------------------------------
541
542 class Sep sep => DescribeSep sep where
543 describeSep :: Proxy sep -> GrammarRegex a -> GrammarRegex a
544
545 instance DescribeSep CommaVCat where describeSep _ = reCommaList
546 instance DescribeSep CommaFSep where describeSep _ = reCommaList
547 instance DescribeSep VCat where describeSep _ = reCommaList
548 instance DescribeSep FSep where describeSep _ = reOptCommaList
549 instance DescribeSep NoCommaFSep where describeSep _ = reSpacedList
550
551 instance (Newtype a b, DescribeSep sep, Described b) => Described (List sep b a) where
552 describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b))
553
554 instance (Newtype a b, Ord a, DescribeSep sep, Described b) => Described (Set' sep b a) where
555 describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b))
556
557 instance Described Token where
558 describe _ = REUnion [reHsString, reMunch1CS csNotSpaceOrComma]
559
560 instance Described Token' where
561 describe _ = REUnion [reHsString, reMunch1CS csNotSpace]
562
563 instance Described a => Described (MQuoted a) where
564 -- TODO: this is simplification
565 describe _ = describe ([] :: [a])
566
567 instance Described SpecVersion where
568 describe _ = "3.4" -- :)
569
570 instance Described SpecLicense where
571 describe _ = RETodo
572
573 instance Described TestedWith where
574 describe _ = RETodo
575
576 instance Described FilePathNT where
577 describe _ = describe ([] :: [Token])
Common Architecture for Building Applications and Libraries