|
|
@@ -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 |
|
|
|
|