Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

buildinfo-reference-generator #6258

Merged
merged 1 commit into from
Mar 9, 2020
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
22 changes: 22 additions & 0 deletions Cabal/Cabal-quickcheck/src/Test/QuickCheck/Instances/Cabal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,16 +3,30 @@
module Test.QuickCheck.Instances.Cabal () where

import Control.Applicative (liftA2)
import Data.Char (isAlphaNum, isDigit)
import Data.List (intercalate)
import Test.QuickCheck

import Distribution.SPDX
import Distribution.Version
import Distribution.Types.PackageName
import Distribution.Types.VersionRange.Internal

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (pure, (<$>), (<*>))
#endif

-------------------------------------------------------------------------------
-- PackageName
-------------------------------------------------------------------------------

instance Arbitrary PackageName where
arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent
where
nameComponent = shortListOf1 5 (elements packageChars)
`suchThat` (not . all isDigit)
packageChars = filter isAlphaNum ['\0'..'\127']

-------------------------------------------------------------------------------
-- Version
-------------------------------------------------------------------------------
Expand Down Expand Up @@ -150,3 +164,11 @@ instance Arbitrary LicenseExpression where
shrink (EOr a b) = a : b : map (uncurry EOr) (shrink (a, b))
shrink _ = []

-------------------------------------------------------------------------------
-- Helpers
-------------------------------------------------------------------------------

shortListOf1 :: Int -> Gen a -> Gen [a]
shortListOf1 bound gen = sized $ \n -> do
k <- choose (1, 1 `max` ((n `div` 2) `min` bound))
vectorOf k gen
19 changes: 18 additions & 1 deletion Cabal/Cabal.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -303,6 +303,9 @@ library
-- already depends on `fail` and `semigroups` transitively
build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.20

if !impl(ghc >= 7.10)
build-depends: void >= 0.7.3 && < 0.8

if !impl(ghc >= 7.8)
-- semigroups depends on tagged.
build-depends: tagged >=0.8.6 && <0.9
Expand Down Expand Up @@ -481,6 +484,8 @@ library
Distribution.Types.VersionInterval
Distribution.Types.GivenComponent
Distribution.Types.PackageVersionConstraint
Distribution.Utils.CharSet
Distribution.Utils.Regex
Distribution.Utils.Generic
Distribution.Utils.NubList
Distribution.Utils.ShortText
Expand All @@ -504,6 +509,7 @@ library
Distribution.Compat.CharParsing
Distribution.FieldGrammar
Distribution.FieldGrammar.Class
Distribution.FieldGrammar.Described
Distribution.FieldGrammar.FieldDescrs
Distribution.FieldGrammar.Parsec
Distribution.FieldGrammar.Pretty
Expand Down Expand Up @@ -614,13 +620,15 @@ test-suite unit-tests
UnitTests.Distribution.Compat.CreatePipe
UnitTests.Distribution.Compat.Graph
UnitTests.Distribution.Compat.Time
UnitTests.Distribution.Described
UnitTests.Distribution.Simple.Glob
UnitTests.Distribution.Simple.Program.GHC
UnitTests.Distribution.Simple.Program.Internal
UnitTests.Distribution.Simple.Utils
UnitTests.Distribution.SPDX
UnitTests.Distribution.System
UnitTests.Distribution.Types.GenericPackageDescription
UnitTests.Distribution.Utils.CharSet
UnitTests.Distribution.Utils.Generic
UnitTests.Distribution.Utils.NubList
UnitTests.Distribution.Utils.ShortText
Expand All @@ -644,6 +652,7 @@ test-suite unit-tests
directory,
filepath,
integer-logarithms >= 1.0.2 && <1.1,
rere >=0.1 && <0.2,
tasty >= 1.2.3 && < 1.3,
tasty-hunit,
tasty-quickcheck,
Expand All @@ -657,6 +666,14 @@ test-suite unit-tests
ghc-options: -Wall
default-language: Haskell2010

if !impl(ghc >= 7.10)
build-depends: void

-- Cabal-quickcheck
hs-source-dirs: Cabal-quickcheck/src
other-modules:
Test.QuickCheck.Instances.Cabal

test-suite parser-tests
type: exitcode-stdio-1.0
hs-source-dirs: tests
Expand All @@ -677,7 +694,7 @@ test-suite parser-tests
default-language: Haskell2010

if !impl(ghc >= 8.0)
build-depends: semigroups
build-depends: semigroups

if impl(ghc >= 7.8)
build-depends:
Expand Down
6 changes: 6 additions & 0 deletions Cabal/Distribution/Compat/Prelude.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Trustworthy #-}

#ifdef MIN_VERSION_base
#define MINVER_base_411 MIN_VERSION_base(4,11,0)
Expand Down Expand Up @@ -48,6 +49,7 @@ module Distribution.Compat.Prelude (
Set,
Identity (..),
Proxy (..),
Void,

-- * Data.Maybe
catMaybes, mapMaybe,
Expand Down Expand Up @@ -92,6 +94,9 @@ module Distribution.Compat.Prelude (
chr, ord,
toLower, toUpper,

-- * Data.Void
absurd, vacuous,

-- * Data.Word & Data.Int
Word,
Word8, Word16, Word32, Word64,
Expand Down Expand Up @@ -160,6 +165,7 @@ import Data.Maybe
import Data.String (IsString (..))
import Data.Int
import Data.Word
import Data.Void (Void, absurd, vacuous)
import Text.Read (readMaybe)

import qualified Text.PrettyPrint as Disp
Expand Down
23 changes: 11 additions & 12 deletions Cabal/Distribution/FieldGrammar/Class.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,11 +11,10 @@ import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()

import Distribution.CabalSpecVersion (CabalSpecVersion)
import Distribution.Compat.Newtype (Newtype)
import Distribution.CabalSpecVersion (CabalSpecVersion)
import Distribution.Compat.Newtype (Newtype)
import Distribution.FieldGrammar.Described (Described)
import Distribution.Fields.Field
import Distribution.Parsec (Parsec)
import Distribution.Pretty (Pretty)
import Distribution.Utils.ShortText

-- | 'FieldGrammar' is parametrised by
Expand All @@ -33,7 +32,7 @@ class FieldGrammar g where

-- | Field which should be defined, exactly once.
uniqueFieldAla
:: (Parsec b, Pretty b, Newtype a b)
:: (Described b, Newtype a b)
=> FieldName -- ^ field name
-> (a -> b) -- ^ 'Newtype' pack
-> ALens' s a -- ^ lens into the field
Expand All @@ -48,15 +47,15 @@ class FieldGrammar g where

-- | Optional field.
optionalFieldAla
:: (Parsec b, Pretty b, Newtype a b)
:: (Described b, Newtype a b)
=> FieldName -- ^ field name
-> (a -> b) -- ^ 'pack'
-> ALens' s (Maybe a) -- ^ lens into the field
-> g s (Maybe a)

-- | Optional field with default value.
optionalFieldDefAla
:: (Parsec b, Pretty b, Newtype a b, Eq a)
:: (Described b, Newtype a b, Eq a)
=> FieldName -- ^ field name
-> (a -> b) -- ^ 'Newtype' pack
-> ALens' s a -- ^ @'Lens'' s a@: lens into the field
Expand Down Expand Up @@ -94,7 +93,7 @@ class FieldGrammar g where
-- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid.
--
monoidalFieldAla
:: (Parsec b, Pretty b, Monoid a, Newtype a b)
:: (Described b, Monoid a, Newtype a b)
=> FieldName -- ^ field name
-> (a -> b) -- ^ 'pack'
-> ALens' s a -- ^ lens into the field
Expand Down Expand Up @@ -135,23 +134,23 @@ class FieldGrammar g where

-- | Field which can be defined at most once.
uniqueField
:: (FieldGrammar g, Parsec a, Pretty a)
:: (FieldGrammar g, Described a)
=> FieldName -- ^ field name
-> ALens' s a -- ^ lens into the field
-> g s a
uniqueField fn = uniqueFieldAla fn Identity

-- | Field which can be defined at most once.
optionalField
:: (FieldGrammar g, Parsec a, Pretty a)
:: (FieldGrammar g, Described a)
=> FieldName -- ^ field name
-> ALens' s (Maybe a) -- ^ lens into the field
-> g s (Maybe a)
optionalField fn = optionalFieldAla fn Identity

-- | Optional field with default value.
optionalFieldDef
:: (FieldGrammar g, Functor (g s), Parsec a, Pretty a, Eq a)
:: (FieldGrammar g, Functor (g s), Described a, Eq a)
=> FieldName -- ^ field name
-> ALens' s a -- ^ @'Lens'' s a@: lens into the field
-> a -- ^ default value
Expand All @@ -160,7 +159,7 @@ optionalFieldDef fn = optionalFieldDefAla fn Identity

-- | Field which can be define multiple times, and the results are @mappend@ed.
monoidalField
:: (FieldGrammar g, Parsec a, Pretty a, Monoid a)
:: (FieldGrammar g, Described a, Monoid a)
=> FieldName -- ^ field name
-> ALens' s a -- ^ lens into the field
-> g s a
Expand Down
135 changes: 135 additions & 0 deletions Cabal/Distribution/FieldGrammar/Described.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,135 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.FieldGrammar.Described (
Described (..),
describeDoc,
-- * Regular expressions
Regex (..),
reEps,
reChar,
reChars,
reMunchCS,
reMunch1CS,
-- * Variables
reVar0,
reVar1,
-- * Special expressions
reDot,
reComma,
reSpacedComma,
reHsString,
reUnqualComponent,
-- * Lists
reSpacedList,
reCommaList,
reOptCommaList,
-- * Character Sets
csChar,
csAlphaNum,
csNotSpace,
csNotSpaceOrComma,
) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Parsec (Parsec)
import Distribution.Pretty (Pretty)

import Distribution.Utils.Regex

import qualified Distribution.Utils.CharSet as CS
import qualified Text.PrettyPrint as PP

-- | Class describing the pretty/parsec format of a.
class (Pretty a, Parsec a) => Described a where
-- | A pretty document of "regex" describing the field format
describe :: proxy a -> Regex void

-- | Pretty-print description.
--
-- >>> describeDoc ([] :: [Bool])
-- \left\{ \mathop{\mathord{``}\mathtt{True}\mathord{"}}\mid\mathop{\mathord{``}\mathtt{False}\mathord{"}} \right\}
--
describeDoc :: Described a => proxy a -> PP.Doc
describeDoc p = regexDoc (describe p)

instance Described Bool where
describe _ = REUnion ["True", "False"]

instance Described a => Described (Identity a) where
describe _ = describe ([] :: [a])

-------------------------------------------------------------------------------
-- Lists
------------------------------------------------------------------------------

reSpacedList :: Regex a -> Regex a
reSpacedList = REMunch RESpaces1

reCommaList :: Regex a -> Regex a
reCommaList = RECommaList

reOptCommaList :: Regex a -> Regex a
reOptCommaList = REOptCommaList

-------------------------------------------------------------------------------
-- Specific grammars
-------------------------------------------------------------------------------

reHsString :: Regex a
reHsString = RENamed "hs-string" impl where
impl = reChar '"' <> REMunch reEps (REUnion [strChar, escChar]) <> reChar '"'
strChar = RECharSet $ CS.difference CS.universe (CS.fromList "\"\\")

escChar = REUnion
[ "\\&"
, "\\\\"
, REUnion ["\\n", RENamed "escapes" "\\n"] -- TODO
, "\\" <> RECharSet "0123456789"
, "\\o" <> RECharSet "01234567"
, "\\x" <> RECharSet "0123456789abcdefABCDEF"
, REUnion ["\\^@", RENamed "control" "\\^@"] -- TODO
, REUnion ["\\NUL", RENamed "ascii" "\\NUL"] -- TODO
]

reUnqualComponent :: Regex a
reUnqualComponent = RENamed "unqual-name" $
REMunch1 (reChar '-') component
where
component
= REMunch reEps (RECharSet csAlphaNum)
-- currently the parser accepts "csAlphaNum `difference` "0123456789"
-- which is larger set than CS.alpha
--
-- Hackage rejects non ANSI names, so it's not so relevant.
<> RECharSet CS.alpha
<> REMunch reEps (RECharSet csAlphaNum)

reDot :: Regex a
reDot = reChar '.'

reComma :: Regex a
reComma = reChar ','

reSpacedComma :: Regex a
reSpacedComma = RESpaces <> reComma <> RESpaces

-------------------------------------------------------------------------------
-- Character sets
-------------------------------------------------------------------------------

csChar :: Char -> CS.CharSet
csChar = CS.singleton

csAlphaNum :: CS.CharSet
csAlphaNum = CS.alphanum

csNotSpace :: CS.CharSet
csNotSpace = CS.difference CS.universe $ CS.singleton ' '

csNotSpaceOrComma :: CS.CharSet
csNotSpaceOrComma = CS.difference csNotSpace $ CS.singleton ','
8 changes: 6 additions & 2 deletions Cabal/Distribution/ModuleName.hs
Original file line number Diff line number Diff line change
Expand Up @@ -26,10 +26,11 @@ module Distribution.ModuleName (
import Distribution.Compat.Prelude
import Prelude ()

import Distribution.FieldGrammar.Described
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText)
import System.FilePath (pathSeparator)
import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText)
import System.FilePath (pathSeparator)

import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
Expand Down Expand Up @@ -57,6 +58,9 @@ instance Parsec ModuleName where
cs <- P.munch validModuleChar
return (c:cs)

instance Described ModuleName where
describe _ = RETodo

validModuleChar :: Char -> Bool
validModuleChar c = isAlphaNum c || c == '_' || c == '\''

Expand Down
Loading