Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
0e1c0604
Commit
0e1c0604
authored
Mar 19, 2020
by
Oleg Grenrus
Browse files
Add Described FlagName and RepoName instances
Move few Arbitrary instances to more correct places, add tests
parent
3642d2db
Changes
8
Hide whitespace changes
Inline
Side-by-side
Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs
View file @
0e1c0604
...
...
@@ -2,21 +2,24 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module
Test.QuickCheck.Instances.Cabal
()
where
import
Control.Applicative
(
liftA2
)
import
Data.Char
(
isAlphaNum
,
isDigit
)
import
Data.List
(
intercalate
)
import
Control.Applicative
(
liftA2
)
import
Data.Char
(
isAlphaNum
,
isDigit
)
import
Data.List
(
intercalate
)
import
Distribution.Utils.Generic
(
lowercase
)
import
Test.QuickCheck
import
Distribution.Simple.Flag
(
Flag
(
..
))
import
Distribution.SPDX
import
Distribution.
Version
import
Distribution.
System
import
Distribution.Types.Dependency
import
Distribution.Types.UnqualComponentName
import
Distribution.Simple.Flag
(
Flag
(
..
))
import
Distribution.Types.Flag
(
FlagAssignment
,
FlagName
,
mkFlagName
,
mkFlagAssignment
)
import
Distribution.Types.LibraryName
import
Distribution.Types.PackageName
import
Distribution.Types.SourceRepo
import
Distribution.Types.UnqualComponentName
import
Distribution.Types.VersionRange.Internal
import
Distribution.System
import
Distribution.Verbosity
import
Distribution.Version
#
if
!
MIN_VERSION_base
(
4
,
8
,
0
)
import
Control.Applicative
(
pure
,
(
<$>
),
(
<*>
))
...
...
@@ -167,10 +170,14 @@ instance Arbitrary LibraryName where
[
LSubLibName
<$>
arbitrary
,
pure
LMainLibName
]
shrink
(
LSubLibName
_
)
=
[
LMainLibName
]
shrink
_
=
[]
-------------------------------------------------------------------------------
-- option flags
-------------------------------------------------------------------------------
instance
Arbitrary
a
=>
Arbitrary
(
Flag
a
)
where
arbitrary
=
arbitrary1
...
...
@@ -184,6 +191,20 @@ instance Arbitrary1 Flag where
else
frequency
[
(
1
,
pure
NoFlag
)
,
(
3
,
Flag
<$>
genA
)
]
-------------------------------------------------------------------------------
-- GPD flags
-------------------------------------------------------------------------------
instance
Arbitrary
FlagName
where
arbitrary
=
mkFlagName
<$>
flagident
where
flagident
=
lowercase
<$>
shortListOf1
5
(
elements
flagChars
)
`
suchThat
`
((
"-"
/=
)
.
take
1
)
flagChars
=
"-_"
++
[
'a'
..
'z'
]
instance
Arbitrary
FlagAssignment
where
arbitrary
=
mkFlagAssignment
<$>
arbitrary
-------------------------------------------------------------------------------
-- Verbosity
-------------------------------------------------------------------------------
...
...
@@ -191,6 +212,16 @@ instance Arbitrary1 Flag where
instance
Arbitrary
Verbosity
where
arbitrary
=
elements
[
minBound
..
maxBound
]
-------------------------------------------------------------------------------
-- SourceRepo
-------------------------------------------------------------------------------
instance
Arbitrary
RepoType
where
arbitrary
=
elements
knownRepoTypes
instance
Arbitrary
RepoKind
where
arbitrary
=
elements
[
RepoHead
,
RepoThis
]
-------------------------------------------------------------------------------
-- SPDX
-------------------------------------------------------------------------------
...
...
Cabal/Distribution/Types/Flag.hs
View file @
0e1c0604
...
...
@@ -27,6 +27,7 @@ import Distribution.Utils.Generic (lowercase)
import
Distribution.Parsec
import
Distribution.Pretty
import
Distribution.FieldGrammar.Described
import
qualified
Data.Map
as
Map
import
qualified
Text.PrettyPrint
as
Disp
...
...
@@ -107,6 +108,12 @@ instance Parsec FlagName where
lead
=
P
.
satisfy
(
\
c
->
isAlphaNum
c
||
c
==
'_'
)
rest
=
P
.
munch
(
\
c
->
isAlphaNum
c
||
c
==
'_'
||
c
==
'-'
)
instance
Described
FlagName
where
describe
_
=
lead
<>
rest
where
lead
=
RECharSet
$
csAlphaNum
<>
fromString
"_"
rest
=
reMunchCS
$
csAlphaNum
<>
fromString
"_-"
-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
-- 'Bool' flag values. It represents the flags chosen by the user or
-- discovered during configuration. For example @--flags=foo --flags=-bar@
...
...
Cabal/tests/UnitTests/Distribution/Described.hs
View file @
0e1c0604
...
...
@@ -18,6 +18,7 @@ import Distribution.Pretty (prettyShow)
import
qualified
Distribution.Utils.CharSet
as
CS
import
Distribution.Types.Dependency
(
Dependency
)
import
Distribution.Types.Flag
(
FlagName
)
import
Distribution.Types.PackageName
(
PackageName
)
import
Distribution.Types.Version
(
Version
)
import
Distribution.Types.VersionRange
(
VersionRange
)
...
...
@@ -34,6 +35,7 @@ tests = testGroup "Described"
,
testDescribed
(
Proxy
::
Proxy
PackageName
)
,
testDescribed
(
Proxy
::
Proxy
Version
)
,
testDescribed
(
Proxy
::
Proxy
VersionRange
)
,
testDescribed
(
Proxy
::
Proxy
FlagName
)
]
-------------------------------------------------------------------------------
...
...
cabal-install/Distribution/Client/BuildReports/Types.hs
View file @
0e1c0604
...
...
@@ -29,9 +29,8 @@ import GHC.Generics (Generic)
import
Distribution.Compat.Binary
(
Binary
)
import
Distribution.Utils.Structured
(
Structured
)
data
ReportLevel
=
NoReports
|
AnonymousReports
|
DetailedReports
deriving
(
Eq
,
Ord
,
Enum
,
Show
,
Generic
)
deriving
(
Eq
,
Ord
,
Enum
,
Bounded
,
Show
,
Generic
)
instance
Binary
ReportLevel
instance
Structured
ReportLevel
...
...
cabal-install/Distribution/Client/Types.hs
View file @
0e1c0604
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
...
...
@@ -77,6 +77,7 @@ import qualified Data.ByteString.Lazy.Char8 as LBS
import
Distribution.Pretty
(
Pretty
(
..
))
import
Distribution.Parsec
(
Parsec
(
..
))
import
Distribution.FieldGrammar.Described
(
Described
(
..
),
reMunch1CS
,
csAlphaNum
)
newtype
Username
=
Username
{
unUsername
::
String
}
...
...
@@ -292,6 +293,9 @@ instance Parsec RepoName where
parsec
=
RepoName
<$>
P
.
munch1
(
\
c
->
isAlphaNum
c
||
c
==
'_'
||
c
==
'-'
||
c
==
'.'
)
instance
Described
RepoName
where
describe
_
=
reMunch1CS
$
csAlphaNum
<>
"_-."
type
UnresolvedPkgLoc
=
PackageLocation
(
Maybe
FilePath
)
type
ResolvedPkgLoc
=
PackageLocation
FilePath
...
...
@@ -363,7 +367,7 @@ instance Parsec RemoteRepo where
parsec
=
do
name
<-
parsec
_
<-
P
.
char
':'
uriStr
<-
P
.
munch1
(
\
c
->
isAlphaNum
c
||
c
`
elem
`
"+-=._/*()@'$:;&!?~"
)
uriStr
<-
P
.
munch1
(
\
c
->
isAlphaNum
c
||
c
`
elem
`
(
"+-=._/*()@'$:;&!?~"
::
String
)
)
uri
<-
maybe
(
fail
$
"Cannot parse URI:"
++
uriStr
)
return
(
parseAbsoluteURI
uriStr
)
return
RemoteRepo
{
remoteRepoName
=
name
...
...
cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
View file @
0e1c0604
...
...
@@ -16,17 +16,55 @@ import Prelude ()
import
Distribution.Types.PackageVersionConstraint
import
Distribution.Simple.Setup
import
Distribution.Simple.InstallDirs
import
Distribution.Simple.Setup
import
Distribution.Utils.NubList
import
Distribution.Client.Types
import
Distribution.Client.IndexUtils.Timestamp
import
Distribution.Client.BuildReports.Types
(
ReportLevel
(
..
))
import
Distribution.Client.CmdInstall.ClientInstallFlags
(
InstallMethod
)
import
Distribution.Client.IndexUtils.Timestamp
(
IndexState
(
..
),
Timestamp
,
epochTimeToTimestamp
)
import
Distribution.Client.InstallSymlink
(
OverwritePolicy
)
import
Distribution.Client.Types
(
RepoName
(
..
),
WriteGhcEnvironmentFilesPolicy
)
import
Test.QuickCheck
import
Test.QuickCheck.Instances.Cabal
()
import
Network.URI
(
URI
(
..
),
URIAuth
(
..
),
isUnreserved
)
-- note: there are plenty of instances defined in ProjectConfig test file.
-- they should be moved here or into Cabal-quickcheck
-------------------------------------------------------------------------------
-- Non-Cabal instances
-------------------------------------------------------------------------------
instance
Arbitrary
URI
where
arbitrary
=
URI
<$>
elements
[
"file:"
,
"http:"
,
"https:"
]
<*>
(
Just
<$>
arbitrary
)
<*>
((
'/'
:
)
<$>
arbitraryURIToken
)
<*>
((
'?'
:
)
<$>
arbitraryURIToken
)
<*>
pure
""
instance
Arbitrary
URIAuth
where
arbitrary
=
URIAuth
<$>
pure
""
-- no password as this does not roundtrip
<*>
arbitraryURIToken
<*>
arbitraryURIPort
arbitraryURIToken
::
Gen
String
arbitraryURIToken
=
shortListOf1
6
(
elements
(
filter
isUnreserved
[
'
\0
'
..
'
\255
'
]))
arbitraryURIPort
::
Gen
String
arbitraryURIPort
=
oneof
[
pure
""
,
(
':'
:
)
<$>
shortListOf1
4
(
choose
(
'0'
,
'9'
))
]
-------------------------------------------------------------------------------
-- cabal-install (and Cabal) types
-------------------------------------------------------------------------------
adjustSize
::
(
Int
->
Int
)
->
Gen
a
->
Gen
a
adjustSize
adjust
gen
=
sized
(
\
n
->
resize
(
adjust
n
)
gen
)
...
...
@@ -108,3 +146,16 @@ instance Arbitrary WriteGhcEnvironmentFilesPolicy where
arbitraryFlag
::
Gen
a
->
Gen
(
Flag
a
)
arbitraryFlag
=
liftArbitrary
instance
Arbitrary
RepoName
where
arbitrary
=
RepoName
<$>
listOf1
(
elements
[
c
|
c
<-
[
'
\NUL
'
..
'
\255
'
],
isAlphaNum
c
||
c
`
elem
`
"_-."
])
instance
Arbitrary
ReportLevel
where
arbitrary
=
arbitraryBoundedEnum
instance
Arbitrary
OverwritePolicy
where
arbitrary
=
arbitraryBoundedEnum
instance
Arbitrary
InstallMethod
where
arbitrary
=
arbitraryBoundedEnum
cabal-install/tests/UnitTests/Distribution/Client/Described.hs
View file @
0e1c0604
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module
UnitTests.Distribution.Client.Described
where
import
Distribution.Client.Compat.Prelude
...
...
@@ -19,6 +18,7 @@ import Distribution.Pretty (prettyShow)
import
qualified
Distribution.Utils.CharSet
as
CS
import
Distribution.Client.IndexUtils.Timestamp
(
IndexState
,
Timestamp
)
import
Distribution.Client.Types
(
RepoName
)
import
qualified
RERE
as
RE
import
qualified
RERE.CharSet
as
RE
...
...
@@ -30,6 +30,7 @@ tests :: TestTree
tests
=
testGroup
"Described"
[
testDescribed
(
Proxy
::
Proxy
Timestamp
)
,
testDescribed
(
Proxy
::
Proxy
IndexState
)
,
testDescribed
(
Proxy
::
Proxy
RepoName
)
]
-------------------------------------------------------------------------------
...
...
cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
View file @
0e1c0604
...
...
@@ -11,7 +11,7 @@ import Control.Applicative
import
Data.Map
(
Map
)
import
qualified
Data.Map
as
Map
import
Data.List
import
Data.Char
(
isAlphaNum
)
import
Network.URI
(
URI
)
import
Distribution.Deprecated.ParseUtils
import
Distribution.Deprecated.Text
as
Text
...
...
@@ -24,20 +24,16 @@ import Distribution.Version
import
Distribution.Simple.Compiler
import
Distribution.Simple.Setup
import
Distribution.Simple.InstallDirs
import
Distribution.Simple.Utils
import
Distribution.Simple.Program.Types
import
Distribution.Simple.Program.Db
import
Distribution.Types.PackageVersionConstraint
import
Distribution.Client.Types
import
Distribution.Client.CmdInstall.ClientInstallFlags
import
Distribution.Client.InstallSymlink
import
Distribution.Client.Dependency.Types
import
Distribution.Client.BuildReports.Types
import
Distribution.Client.Targets
import
Distribution.Client.SourceRepo
import
Distribution.Utils.NubList
import
Network.URI
import
Distribution.Solver.Types.PackageConstraint
import
Distribution.Solver.Types.ConstraintSource
...
...
@@ -357,12 +353,6 @@ arbitraryGlobLikeStr = outerTerm
braces
s
=
"{"
++
s
++
"}"
instance
Arbitrary
OverwritePolicy
where
arbitrary
=
arbitraryBoundedEnum
instance
Arbitrary
InstallMethod
where
arbitrary
=
arbitraryBoundedEnum
instance
Arbitrary
ClientInstallFlags
where
arbitrary
=
ClientInstallFlags
...
...
@@ -563,9 +553,6 @@ projectConfigConstraintSource =
instance
Arbitrary
ProjectConfigProvenance
where
arbitrary
=
elements
[
Implicit
,
Explicit
"cabal.project"
]
instance
Arbitrary
FlagAssignment
where
arbitrary
=
mkFlagAssignment
<$>
arbitrary
instance
Arbitrary
PackageConfig
where
arbitrary
=
PackageConfig
...
...
@@ -794,12 +781,6 @@ instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where
(
x1
,
ShortToken
x2
,
fmap
ShortToken
x3
,
fmap
ShortToken
x4
,
fmap
ShortToken
x5
)
]
instance
Arbitrary
RepoType
where
arbitrary
=
elements
knownRepoTypes
instance
Arbitrary
ReportLevel
where
arbitrary
=
elements
[
NoReports
..
DetailedReports
]
instance
Arbitrary
CompilerFlavor
where
arbitrary
=
elements
knownCompilerFlavors
...
...
@@ -837,10 +818,6 @@ instance Arbitrary LocalRepo where
<*>
elements
[
"/tmp/foo"
,
"/tmp/bar"
]
-- TODO: generate valid absolute paths
<*>
arbitrary
instance
Arbitrary
RepoName
where
arbitrary
=
RepoName
<$>
shortListOf1
10
(
elements
repochars
)
where
repochars
=
[
c
|
c
<-
[
'
\NUL
'
..
'
\255
'
],
isAlphaNum
c
||
c
`
elem
`
".-_"
]
instance
Arbitrary
UserConstraintScope
where
arbitrary
=
oneof
[
UserQualified
<$>
arbitrary
<*>
arbitrary
,
UserAnySetupQualifier
<$>
arbitrary
...
...
@@ -869,13 +846,6 @@ instance Arbitrary PackageProperty where
instance
Arbitrary
OptionalStanza
where
arbitrary
=
elements
[
minBound
..
maxBound
]
instance
Arbitrary
FlagName
where
arbitrary
=
mkFlagName
<$>
flagident
where
flagident
=
lowercase
<$>
shortListOf1
5
(
elements
flagChars
)
`
suchThat
`
((
"-"
/=
)
.
take
1
)
flagChars
=
"-_"
++
[
'a'
..
'z'
]
instance
Arbitrary
PreSolver
where
arbitrary
=
elements
[
minBound
..
maxBound
]
...
...
@@ -942,25 +912,3 @@ instance Arbitrary OptimisationLevel where
instance
Arbitrary
DebugInfoLevel
where
arbitrary
=
elements
[
minBound
..
maxBound
]
instance
Arbitrary
URI
where
arbitrary
=
URI
<$>
elements
[
"file:"
,
"http:"
,
"https:"
]
<*>
(
Just
<$>
arbitrary
)
<*>
((
'/'
:
)
<$>
arbitraryURIToken
)
<*>
((
'?'
:
)
<$>
arbitraryURIToken
)
<*>
pure
""
instance
Arbitrary
URIAuth
where
arbitrary
=
URIAuth
<$>
pure
""
-- no password as this does not roundtrip
<*>
arbitraryURIToken
<*>
arbitraryURIPort
arbitraryURIToken
::
Gen
String
arbitraryURIToken
=
shortListOf1
6
(
elements
(
filter
isUnreserved
[
'
\0
'
..
'
\255
'
]))
arbitraryURIPort
::
Gen
String
arbitraryURIPort
=
oneof
[
pure
""
,
(
':'
:
)
<$>
shortListOf1
4
(
choose
(
'0'
,
'9'
))
]
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment