Commit 0e1c0604 authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Add Described FlagName and RepoName instances

Move few Arbitrary instances to more correct places,
add tests
parent 3642d2db
......@@ -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
-------------------------------------------------------------------------------
......
......@@ -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@
......
......@@ -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)
]
-------------------------------------------------------------------------------
......
......@@ -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
......
{-# 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
......
......@@ -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
{-# 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)
]
-------------------------------------------------------------------------------
......
......@@ -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')) ]
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment