mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-09-11 18:05:56 +03:00
remote: add/derive instances for StoreRequest
This commit is contained in:
parent
e0456e3bc9
commit
7f9c7fb2eb
@ -99,6 +99,7 @@ library
|
||||
base >=4.12 && <5
|
||||
, hnix-store-core >= 0.8 && <0.9
|
||||
, hnix-store-nar >= 0.1
|
||||
, hnix-store-tests >= 0.1
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, cereal
|
||||
@ -106,6 +107,7 @@ library
|
||||
, crypton
|
||||
, data-default-class
|
||||
, dependent-sum > 0.7 && < 1
|
||||
, dependent-sum-template > 0.1.1 && < 0.3
|
||||
, generic-arbitrary < 1.1
|
||||
, hashable
|
||||
, text
|
||||
|
@ -3,12 +3,21 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module System.Nix.Store.Remote.Arbitrary where
|
||||
|
||||
import Data.Some (Some(Some))
|
||||
import System.Nix.Arbitrary ()
|
||||
import System.Nix.Store.Remote.GADT
|
||||
import System.Nix.Store.Remote.Types
|
||||
|
||||
import Test.QuickCheck (Arbitrary(..))
|
||||
import Test.QuickCheck (Arbitrary(..), oneof)
|
||||
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
|
||||
import Test.QuickCheck.Instances ()
|
||||
|
||||
deriving via GenericArbitrary CheckMode
|
||||
instance Arbitrary CheckMode
|
||||
|
||||
deriving via GenericArbitrary SubstituteMode
|
||||
instance Arbitrary SubstituteMode
|
||||
|
||||
deriving via GenericArbitrary ProtoVersion
|
||||
instance Arbitrary ProtoVersion
|
||||
|
||||
@ -43,3 +52,30 @@ deriving via GenericArbitrary Logger
|
||||
|
||||
deriving via GenericArbitrary Verbosity
|
||||
instance Arbitrary Verbosity
|
||||
|
||||
instance Arbitrary (Some StoreRequest) where
|
||||
arbitrary = oneof
|
||||
[ Some <$> (AddToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)
|
||||
, Some <$> (AddTextToStore <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary)
|
||||
, Some <$> (AddSignatures <$> arbitrary <*> arbitrary)
|
||||
, Some . AddIndirectRoot <$> arbitrary
|
||||
, Some . AddTempRoot <$> arbitrary
|
||||
, Some <$> (BuildPaths <$> arbitrary <*> arbitrary)
|
||||
, Some <$> (BuildDerivation <$> arbitrary <*> arbitrary <*> arbitrary)
|
||||
, Some . EnsurePath <$> arbitrary
|
||||
, pure $ Some FindRoots
|
||||
, Some . IsValidPath <$> arbitrary
|
||||
, Some <$> (QueryValidPaths <$> arbitrary <*> arbitrary)
|
||||
, pure $ Some QueryAllValidPaths
|
||||
, Some . QuerySubstitutablePaths <$> arbitrary
|
||||
, Some . QueryPathInfo <$> arbitrary
|
||||
, Some . QueryReferrers <$> arbitrary
|
||||
, Some . QueryValidDerivers <$> arbitrary
|
||||
, Some . QueryDerivationOutputs <$> arbitrary
|
||||
, Some . QueryDerivationOutputNames <$> arbitrary
|
||||
, Some . QueryPathFromHashPart <$> arbitrary
|
||||
, Some . QueryMissing <$> arbitrary
|
||||
, pure $ Some OptimiseStore
|
||||
, pure $ Some SyncWithGC
|
||||
, Some <$> (VerifyStore <$> arbitrary <*> arbitrary)
|
||||
]
|
||||
|
@ -1,24 +1,25 @@
|
||||
{-# language GADTs #-}
|
||||
{-# language Rank2Types #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module System.Nix.Store.Remote.GADT
|
||||
( StoreRequest(..)
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.GADT.Compare.TH (deriveGEq, deriveGCompare)
|
||||
import Data.GADT.Show.TH (deriveGShow)
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.Kind (Type)
|
||||
import Data.Map (Map)
|
||||
import Data.Set (Set)
|
||||
import Data.Text (Text)
|
||||
import Data.Some (Some)
|
||||
import Data.Some (Some(Some))
|
||||
|
||||
import System.Nix.Build (BuildMode, BuildResult)
|
||||
import System.Nix.Derivation (Derivation)
|
||||
import System.Nix.DerivedPath (DerivedPath)
|
||||
import System.Nix.Hash (HashAlgo)
|
||||
import System.Nix.Nar (NarSource)
|
||||
import System.Nix.Store.Types (RepairMode)
|
||||
import System.Nix.StorePath (StorePath, StorePathName, StorePathHashPart)
|
||||
import System.Nix.StorePath.Metadata (Metadata)
|
||||
@ -30,8 +31,16 @@ data StoreRequest :: Type -> Type where
|
||||
AddToStore
|
||||
:: StorePathName -- ^ Name part of the newly created @StorePath@
|
||||
-> Bool -- ^ Add target directory recursively
|
||||
-> Some HashAlgo
|
||||
-> (forall m . MonadIO m => NarSource m) -- ^ provide nar stream
|
||||
-> Some HashAlgo -- ^ Nar hashing algorithm
|
||||
-- -> (forall m . MonadIO m => NarSource m) -- ^ provide nar stream
|
||||
-- Not part of StoreRequest
|
||||
-- as it would require StoreRequest (m :: Type -> Type) :: Type -> Type
|
||||
-- for which we cannot derive anything
|
||||
--
|
||||
-- Also the thing is the only special case
|
||||
-- and it is always sent *after* the other
|
||||
-- information so it can be handled
|
||||
-- separately after that. Hopefully.
|
||||
-> RepairMode -- ^ Only used by local store backend
|
||||
-> StoreRequest StorePath
|
||||
|
||||
@ -148,3 +157,37 @@ data StoreRequest :: Type -> Type where
|
||||
:: CheckMode
|
||||
-> RepairMode
|
||||
-> StoreRequest Bool
|
||||
|
||||
deriving instance Eq (StoreRequest a)
|
||||
deriving instance Show (StoreRequest a)
|
||||
|
||||
deriveGEq ''StoreRequest
|
||||
deriveGCompare ''StoreRequest
|
||||
deriveGShow ''StoreRequest
|
||||
|
||||
instance {-# OVERLAPPING #-} Eq (Some StoreRequest) where
|
||||
Some (AddToStore a b c d) == Some (AddToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d')
|
||||
Some (AddTextToStore a b c d) == Some (AddTextToStore a' b' c' d') = (a, b, c, d) == (a', b', c', d')
|
||||
Some (AddSignatures a b) == Some (AddSignatures a' b') = (a, b) == (a', b')
|
||||
Some (AddIndirectRoot a) == Some (AddIndirectRoot a') = a == a'
|
||||
Some (AddTempRoot a) == Some (AddTempRoot a') = a == a'
|
||||
Some (BuildPaths a b) == Some (BuildPaths a' b') = (a, b) == (a', b')
|
||||
Some (BuildDerivation a b c) == Some (BuildDerivation a' b' c') = (a, b, c) == (a', b', c')
|
||||
Some (EnsurePath a) == Some (EnsurePath a') = a == a'
|
||||
Some (FindRoots) == Some (FindRoots) = True
|
||||
Some (IsValidPath a) == Some (IsValidPath a') = a == a'
|
||||
Some (QueryValidPaths a b) == Some (QueryValidPaths a' b') = (a, b) == (a', b')
|
||||
Some QueryAllValidPaths == Some QueryAllValidPaths = True
|
||||
Some (QuerySubstitutablePaths a) == Some (QuerySubstitutablePaths a') = a == a'
|
||||
Some (QueryPathInfo a) == Some (QueryPathInfo a') = a == a'
|
||||
Some (QueryReferrers a) == Some (QueryReferrers a') = a == a'
|
||||
Some (QueryValidDerivers a) == Some (QueryValidDerivers a') = a == a'
|
||||
Some (QueryDerivationOutputs a) == Some (QueryDerivationOutputs a') = a == a'
|
||||
Some (QueryDerivationOutputNames a) == Some (QueryDerivationOutputNames a') = a == a'
|
||||
Some (QueryPathFromHashPart a) == Some (QueryPathFromHashPart a') = a == a'
|
||||
Some (QueryMissing a) == Some (QueryMissing a') = a == a'
|
||||
Some OptimiseStore == Some OptimiseStore = True
|
||||
Some SyncWithGC == Some SyncWithGC = True
|
||||
Some (VerifyStore a b) == Some (VerifyStore a' b') = (a, b) == (a', b')
|
||||
|
||||
_ == _ = False
|
||||
|
Loading…
Reference in New Issue
Block a user