Add JSON roundtrip specs

This commit is contained in:
Julian Ospald 2020-09-13 20:46:34 +02:00
parent de09c950d5
commit 9d6a5313ab
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
8 changed files with 9529 additions and 14 deletions

View File

@ -81,6 +81,9 @@ common containers
common cryptohash-sha256 common cryptohash-sha256
build-depends: cryptohash-sha256 >= 0.11.101.0 build-depends: cryptohash-sha256 >= 0.11.101.0
common generic-arbitrary
build-depends: generic-arbitrary >=0.1.0
common generics-sop common generics-sop
build-depends: generics-sop >=0.5 build-depends: generics-sop >=0.5
@ -108,6 +111,12 @@ common hpath-posix
common http-io-streams common http-io-streams
build-depends: http-io-streams >=0.1.2.0 build-depends: http-io-streams >=0.1.2.0
common hspec
build-depends: hspec >=2.7.4
common hspec-golden-aeson
build-depends: hspec-golden-aeson >=0.7
common io-streams common io-streams
build-depends: io-streams >=1.5 build-depends: io-streams >=1.5
@ -195,6 +204,12 @@ common transformers
common os-release common os-release
build-depends: os-release >=1.0.0 build-depends: os-release >=1.0.0
common QuickCheck
build-depends: QuickCheck >=2.14.1
common quickcheck-arbitrary-adt
build-depends: quickcheck-arbitrary-adt >=0.3.1.0
common unix common unix
build-depends: unix >=2.7 build-depends: unix >=2.7
@ -240,8 +255,6 @@ common config
PackageImports PackageImports
RecordWildCards RecordWildCards
ScopedTypeVariables ScopedTypeVariables
Strict
StrictData
TupleSections TupleSections
library library
@ -321,6 +334,10 @@ library
GHCup.Utils.Version.QQ GHCup.Utils.Version.QQ
GHCup.Version GHCup.Version
default-extensions:
Strict
StrictData
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
hs-source-dirs: lib hs-source-dirs: lib
@ -377,6 +394,10 @@ executable ghcup
hs-source-dirs: app/ghcup hs-source-dirs: app/ghcup
default-language: Haskell2010 default-language: Haskell2010
default-extensions:
Strict
StrictData
if flag(internal-downloader) if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER cpp-options: -DINTERNAL_DOWNLOADER
@ -431,8 +452,25 @@ executable ghcup-gen
default-language: Haskell2010 default-language: Haskell2010
test-suite ghcup-test test-suite ghcup-test
default-language: Haskell2010 import:
config
, base
, bytestring
, containers
, QuickCheck
, generic-arbitrary
, hpath
, hspec
, hspec-golden-aeson
, quickcheck-arbitrary-adt
, text
, uri-bytestring
, versions
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
build-depends: ghcup
hs-source-dirs: test hs-source-dirs: test
main-is: MyLibTest.hs main-is: Main.hs
build-depends: base >=4.12.0.0 other-modules:
GHCup.ArbitraryTypes
GHCup.Types.JSONSpec
Spec

9257
golden/GHCupInfo.json Normal file

File diff suppressed because it is too large Load Diff

View File

@ -87,7 +87,7 @@ data VersionInfo = VersionInfo
, _viSourceDL :: Maybe DownloadInfo -- ^ source tarball , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch , _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
} }
deriving (Eq, Show) deriving (Eq, GHC.Generic, Show)
-- | A tag. These are currently attached to a version of a tool. -- | A tag. These are currently attached to a version of a tool.
@ -96,7 +96,7 @@ data Tag = Latest
| Prerelease | Prerelease
| Base PVP | Base PVP
| UnknownTag String -- ^ used for upwardscompat | UnknownTag String -- ^ used for upwardscompat
deriving (Ord, Eq, Show) -- FIXME: manual JSON instance deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
data Architecture = A_64 data Architecture = A_64
@ -168,7 +168,7 @@ data DownloadInfo = DownloadInfo
, _dlSubdir :: Maybe TarDir , _dlSubdir :: Maybe TarDir
, _dlHash :: Text , _dlHash :: Text
} }
deriving (Eq, Show) deriving (Eq, GHC.Generic, Show)
@ -181,14 +181,14 @@ data DownloadInfo = DownloadInfo
-- | How to descend into a tar archive. -- | How to descend into a tar archive.
data TarDir = RealDir (Path Rel) data TarDir = RealDir (Path Rel)
| RegexDir String -- ^ will be compiled to regex, the first match will "win" | RegexDir String -- ^ will be compiled to regex, the first match will "win"
deriving (Eq, Show) deriving (Eq, GHC.Generic, Show)
-- | Where to fetch GHCupDownloads from. -- | Where to fetch GHCupDownloads from.
data URLSource = GHCupURL data URLSource = GHCupURL
| OwnSource URI | OwnSource URI
| OwnSpec GHCupInfo | OwnSpec GHCupInfo
deriving Show deriving (GHC.Generic, Show)
data Settings = Settings data Settings = Settings

View File

@ -0,0 +1,193 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.ArbitraryTypes where
import GHCup.Types
import Data.ByteString ( ByteString )
import Data.Versions
import Data.List.NonEmpty
import HPath
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT ( ToADTArbitrary )
import Test.QuickCheck.Arbitrary.Generic
import URI.ByteString
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Lazy as T
( toStrict )
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
-----------------
--[ utilities ]--
-----------------
intToText :: Integral a => a -> T.Text
intToText = T.toStrict . B.toLazyText . B.decimal
genVer :: Gen (Int, Int, Int)
genVer =
(\x y z -> (getPositive x, getPositive y, getPositive z))
<$> arbitrary
<*> arbitrary
<*> arbitrary
instance ToADTArbitrary GHCupInfo
----------------------
--[ base arbitrary ]--
----------------------
instance Arbitrary T.Text where
arbitrary = fmap T.pack $ listOf $ elements ['a' .. 'z']
shrink xs = T.pack <$> shrink (T.unpack xs)
instance Arbitrary (NonEmpty Word) where
arbitrary = fmap fromList $ listOf1 $ arbitrary
-- utf8 encoded bytestring
instance Arbitrary ByteString where
arbitrary = fmap (E.encodeUtf8 . T.pack) $ listOf $ elements ['a' .. 'z']
---------------------
--[ uri arbitrary ]--
---------------------
instance Arbitrary Scheme where
arbitrary = oneof [ Scheme <$> pure "http", Scheme <$> pure "https" ]
instance Arbitrary Host where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Port where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (URIRef Absolute) where
arbitrary =
URI <$> arbitrary <*> pure Nothing <*> arbitrary <*> (Query <$> pure []) <*> pure Nothing
-------------------------
--[ version arbitrary ]--
-------------------------
instance Arbitrary Mess where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ mess
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Version where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ version
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary SemVer where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ semver
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary PVP where
arbitrary = do
(x, y, z) <- genVer
pure
$ either (error . show) id
$ pvp
$ (intToText x <> "." <> intToText y <> "." <> intToText z)
instance Arbitrary Versioning where
arbitrary = Ideal <$> arbitrary
-----------------------
--[ ghcup arbitrary ]--
-----------------------
instance Arbitrary Requirements where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary DownloadInfo where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary LinuxDistro where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Platform where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Tag where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Architecture where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary VersionInfo where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary (Path Rel) where
arbitrary =
(either (error . show) id . parseRel . E.encodeUtf8 . T.pack)
<$> (listOf1 $ elements ['a' .. 'z'])
instance Arbitrary TarDir where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary Tool where
arbitrary = genericArbitrary
shrink = genericShrink
instance Arbitrary GHCupInfo where
arbitrary = genericArbitrary
shrink = genericShrink
-- our maps are nested... the default size easily blows up most ppls ram
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map Tool v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Version) v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map Platform v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary
instance {-# OVERLAPS #-} Arbitrary v => Arbitrary (M.Map (Maybe Versioning) v) where
arbitrary = resize 8 $ M.fromList <$> arbitrary

View File

@ -0,0 +1,17 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.Types.JSONSpec where
import GHCup.ArbitraryTypes ()
import GHCup.Types
import GHCup.Types.JSON ()
import Test.Aeson.GenericSpecs
import Test.Hspec
spec :: Spec
spec = do
roundtripAndGoldenSpecs (Proxy @GHCupInfo)

12
test/Main.hs Normal file
View File

@ -0,0 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
import Test.Hspec.Runner
import Test.Hspec.Formatters
import qualified Spec
main :: IO ()
main =
hspecWith
defaultConfig { configFormatter = Just progress }
$ Spec.spec

View File

@ -1,4 +0,0 @@
module Main (main) where
main :: IO ()
main = putStrLn "Test suite not yet implemented."

2
test/Spec.hs Normal file
View File

@ -0,0 +1,2 @@
-- file test/Spec.hs
{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}