Commit 90b14ae6 authored by Oleg Grenrus's avatar Oleg Grenrus

Add buildinfo-reference-generator

Note all Described instances are implemented. This is just a start.
parent c0dc3059
......@@ -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
-------------------------------------------------------------------------------
......@@ -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
......@@ -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
......@@ -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
......@@ -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
......@@ -614,6 +620,7 @@ 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
......@@ -621,6 +628,7 @@ test-suite unit-tests
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
......@@ -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,
......@@ -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
......@@ -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:
......
......@@ -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)
......@@ -48,6 +49,7 @@ module Distribution.Compat.Prelude (
Set,
Identity (..),
Proxy (..),
Void,
-- * Data.Maybe
catMaybes, mapMaybe,
......@@ -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,
......@@ -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
......
......@@ -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
......@@ -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
......@@ -48,7 +47,7 @@ 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
......@@ -56,7 +55,7 @@ class FieldGrammar g where
-- | 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
......@@ -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
......@@ -135,7 +134,7 @@ 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
......@@ -143,7 +142,7 @@ 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)
......@@ -151,7 +150,7 @@ 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
......@@ -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
......
{-# 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 ','
......@@ -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
......@@ -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 == '\''
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar".
module Distribution.Parsec.Newtypes (
-- * List
......@@ -38,8 +38,9 @@ import Distribution.Compat.Prelude
import Prelude ()
import Distribution.CabalSpecVersion
import Distribution.Compiler (CompilerFlavor)
import Distribution.License (License)
import Distribution.Compiler (CompilerFlavor)
import Distribution.FieldGrammar.Described
import Distribution.License (License)
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Version (LowerBound (..), Version, VersionRange, anyVersion, asVersionIntervals, mkVersion)
......@@ -69,29 +70,36 @@ class Sep sep where
parseSep :: CabalParsing m => Proxy sep -> m a -> m [a]
describeSep :: Proxy sep -> Regex a -> Regex a
instance Sep CommaVCat where
prettySep _ = vcat . punctuate comma
parseSep _ p = do
v <- askCabalSpecVersion
if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p
describeSep _ = reCommaList
instance Sep CommaFSep where
prettySep _ = fsep . punctuate comma
parseSep _ p = do
v <- askCabalSpecVersion
if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p
describeSep _ = reCommaList
instance Sep VCat where
prettySep _ = vcat
parseSep _ p = do
v <- askCabalSpecVersion
if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
describeSep _ = reCommaList
instance Sep FSep where
prettySep _ = fsep
parseSep _ p = do
v <- askCabalSpecVersion
if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
describeSep _ = reOptCommaList
instance Sep NoCommaFSep where
prettySep _ = fsep
parseSep _ p = many (p <* P.spaces)
describeSep _ = reSpacedList
-- | List separated with optional commas. Displayed with @sep@, arguments of
-- type @a@ are parsed and pretty-printed as @b@.
......@@ -121,6 +129,10 @@ instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where
instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where
pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack
instance (Newtype a b, Sep sep, Described b) => Described (List sep b a) where
describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b))
--
-- | Like 'List', but for 'Set'.
--
-- @since 3.2.0.0
......@@ -156,6 +168,9 @@ instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where
instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where
pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack
instance (Newtype a b, Ord a, Sep sep, Described b) => Described (Set' sep b a) where
describe _ = describeSep (Proxy :: Proxy sep) (describe (Proxy :: Proxy b))
-- | Haskell string or @[^ ,]+@
newtype Token = Token { getToken :: String }
......@@ -167,6 +182,9 @@ instance Parsec Token where
instance Pretty Token where
pretty = showToken . unpack
instance Described Token where
describe _ = REUnion [reHsString, reMunch1CS csNotSpaceOrComma]
-- | Haskell string or @[^ ]+@
newtype Token' = Token' { getToken' :: String }
......@@ -178,6 +196,9 @@ instance Parsec Token' where
instance Pretty Token' where
pretty = showToken . unpack
instance Described Token' where
describe _ = REUnion [reHsString, reMunch1CS csNotSpace]
-- | Either @"quoted"@ or @un-quoted@.
newtype MQuoted a = MQuoted { getMQuoted :: a }
......@@ -189,6 +210,10 @@ instance Parsec a => Parsec (MQuoted a) where
instance Pretty a => Pretty (MQuoted a) where
pretty = pretty . unpack
instance Described a => Described (MQuoted a) where
-- TODO: this is simplification
describe _ = describe ([] :: [a])
-- | Version range or just version, i.e. @cabal-version@ field.
--
-- There are few things to consider:
......@@ -215,6 +240,9 @@ instance Parsec SpecVersion where
instance Pretty SpecVersion where
pretty = either pretty pretty . unpack
instance Described SpecVersion where
describe _ = "3.0" -- :)
specVersionFromRange :: VersionRange -> Version
specVersionFromRange versionRange = case asVersionIntervals versionRange of
[] -> mkVersion [0]
......@@ -235,6 +263,9 @@ instance Parsec SpecLicense where
instance Pretty SpecLicense where
pretty = either pretty pretty . unpack
instance Described SpecLicense where
describe _ = RETodo
-- | Version range or just version
newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) }
......@@ -247,6 +278,9 @@ instance Pretty TestedWith where
pretty x = case unpack x of
(compiler, vr) -> pretty compiler <+> pretty vr
instance Described TestedWith where
describe _ = RETodo
-- | Filepath are parsed as 'Token'.
newtype FilePathNT = FilePathNT { getFilePathNT :: String }
......@@ -258,6 +292,9 @@ instance Parsec FilePathNT where
instance Pretty FilePathNT where
pretty = showFilePath . unpack
instance Described FilePathNT where
describe _ = describe ([] :: [Token])
-------------------------------------------------------------------------------
-- Internal
-------------------------------------------------------------------------------
......
......@@ -7,6 +7,7 @@ import Prelude ()
import Distribution.Parsec
import Distribution.Pretty
import Distribution.FieldGrammar.Described
import qualified Distribution.Compat.CharParsing as P
import qualified Distribution.Package as Package
......@@ -39,6 +40,12 @@ instance Parsec AbiDependency where
abi <- parsec
return (AbiDependency uid abi)
instance Described AbiDependency where
describe _ =
describe (Proxy :: Proxy Package.UnitId) <>
reChar '=' <>
describe (Proxy :: Proxy Package.AbiHash)
instance Binary AbiDependency
instance Structured AbiDependency
instance NFData AbiDependency where rnf = genericRnf
......@@ -13,6 +13,7 @@ import Distribution.Utils.ShortText
import qualified Distribution.Compat.CharParsing as P
import Distribution.Pretty
import Distribution.Parsec
import Distribution.FieldGrammar.Described
import Text.PrettyPrint (text)
......@@ -59,3 +60,6 @@ instance Pretty AbiHash where
instance Parsec AbiHash where
parsec = fmap mkAbiHash (P.munch isAlphaNum)
instance Described AbiHash where
describe _ = reMunchCS csAlphaNum
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Distribution.Types.BenchmarkType (
BenchmarkType(..),
......@@ -9,10 +10,11 @@ module Distribution.Types.BenchmarkType (
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.FieldGrammar.Described (Described (..))
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Version
import Text.PrettyPrint (char, text)
import Text.PrettyPrint (char, text)
-- | The \"benchmark-type\" field in the benchmark stanza.
--
......@@ -37,3 +39,6 @@ instance Parsec BenchmarkType where
parsec = parsecStandard $ \ver name -> case name of
"exitcode-stdio" -> BenchmarkTypeExe ver
_ -> BenchmarkTypeUnknown name ver
instance Described BenchmarkType where
describe _ = "exitcode-stdio-1.0"
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Distribution.Types.BuildType (
BuildType(..),
......@@ -12,6 +13,7 @@ import Distribution.Compat.Prelude