{-# language AllowAmbiguousTypes #-}
{-# language ConstraintKinds #-}
{-# language TypeFamilies #-}
{-# options_ghc -Wno-missing-pattern-synonym-signatures #-}
module Nix.Value.Equal where
import Nix.Prelude hiding ( Comparison )
import Control.Comonad ( Comonad(extract))
import Control.Monad.Free ( Free(Pure,Free) )
import Control.Monad.Trans.Except ( throwE )
import Data.Semialign ( Align
, Semialign(align)
)
import qualified Data.HashMap.Lazy as HashMap.Lazy
import Data.These ( These(These) )
import Nix.Atoms
import Nix.Frames
import Nix.String
import Nix.Thunk
import Nix.Value
import Nix.Expr.Types ( AttrSet )
checkComparable
:: ( Framed e m
, MonadDataErrorContext t f m
)
=> NValue t f m
-> NValue t f m
-> m ()
checkComparable :: forall e (m :: * -> *) t (f :: * -> *).
(Framed e m, MonadDataErrorContext t f m) =>
NValue t f m -> NValue t f m -> m ()
checkComparable NValue t f m
x NValue t f m
y =
case (NValue t f m
x, NValue t f m
y) of
(NVConstant (NInt Integer
_), NVConstant (NInt Integer
_)) -> forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
(NVConstant (NInt Integer
_), NVConstant (NFloat Float
_)) -> forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
(NVConstant (NFloat Float
_), NVConstant (NInt Integer
_)) -> forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
(NVConstant (NFloat Float
_), NVConstant (NFloat Float
_)) -> forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
(NVStr NixString
_ , NVStr NixString
_ ) -> forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
(NVPath Path
_ , NVPath Path
_ ) -> forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
(NValue t f m, NValue t f m)
_ -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall t (f :: * -> *) (m :: * -> *).
NValue t f m -> NValue t f m -> ValueFrame t f m
Comparison NValue t f m
x NValue t f m
y
alignEqM
:: (Align f, Traversable f, Monad m)
=> (a -> b -> m Bool)
-> f a
-> f b
-> m Bool
alignEqM :: forall (f :: * -> *) (m :: * -> *) a b.
(Align f, Traversable f, Monad m) =>
(a -> b -> m Bool) -> f a -> f b -> m Bool
alignEqM a -> b -> m Bool
eq f a
fa f b
fb =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(forall a b. Either a b -> Bool
isRight @() @())
forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
(forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> m Bool
eq)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
(\case
These a
a b
b -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, b
b)
These a b
_ -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE forall a. Monoid a => a
mempty
)
(forall (f :: * -> *) a b.
Semialign f =>
f a -> f b -> f (These a b)
Data.Semialign.align f a
fa f b
fb)
alignEq :: (Align f, Traversable f) => (a -> b -> Bool) -> f a -> f b -> Bool
alignEq :: forall (f :: * -> *) a b.
(Align f, Traversable f) =>
(a -> b -> Bool) -> f a -> f b -> Bool
alignEq a -> b -> Bool
eq f a
fa f b
fb =
forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a b.
(Align f, Traversable f, Monad m) =>
(a -> b -> m Bool) -> f a -> f b -> m Bool
alignEqM ((forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b -> Bool
eq) f a
fa f b
fb
isDerivationM
:: Monad m
=> ( t
-> m (Maybe NixString)
)
-> AttrSet t
-> m Bool
isDerivationM :: forall (m :: * -> *) t.
Monad m =>
(t -> m (Maybe NixString)) -> AttrSet t -> m Bool
isDerivationM t -> m (Maybe NixString)
f AttrSet t
m =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
Bool
False
(forall a. Eq a => a -> a -> Bool
(==) Text
"derivation" forall b c a. (b -> c) -> (a -> b) -> a -> c
. NixString -> Text
ignoreContext)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse t -> m (Maybe NixString)
f (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.Lazy.lookup VarName
"type" AttrSet t
m)
isDerivation
:: Monad m
=> ( t
-> Maybe NixString
)
-> AttrSet t
-> Bool
isDerivation :: forall (m :: * -> *) t.
Monad m =>
(t -> Maybe NixString) -> AttrSet t -> Bool
isDerivation t -> Maybe NixString
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) t.
Monad m =>
(t -> m (Maybe NixString)) -> AttrSet t -> m Bool
isDerivationM (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe NixString
f)
valueFEqM
:: Monad n
=> ( AttrSet a
-> AttrSet a
-> n Bool
)
-> ( a
-> a
-> n Bool
)
-> NValueF p m a
-> NValueF p m a
-> n Bool
valueFEqM :: forall (n :: * -> *) a p (m :: * -> *).
Monad n =>
(AttrSet a -> AttrSet a -> n Bool)
-> (a -> a -> n Bool) -> NValueF p m a -> NValueF p m a -> n Bool
valueFEqM AttrSet a -> AttrSet a -> n Bool
attrsEq a -> a -> n Bool
eq =
forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a b. (a -> b) -> a -> b
$
\case
(NVConstantF (NFloat Float
x), NVConstantF (NInt Integer
y)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Float
x forall a. Eq a => a -> a -> Bool
== forall a. Num a => Integer -> a
fromInteger Integer
y
(NVConstantF (NInt Integer
x), NVConstantF (NFloat Float
y)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger Integer
x forall a. Eq a => a -> a -> Bool
== Float
y
(NVConstantF NAtom
lc , NVConstantF NAtom
rc ) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NAtom
lc forall a. Eq a => a -> a -> Bool
== NAtom
rc
(NVStrF NixString
ls , NVStrF NixString
rs ) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (\ NixString -> Text
i -> NixString -> Text
i NixString
ls forall a. Eq a => a -> a -> Bool
== NixString -> Text
i NixString
rs) NixString -> Text
ignoreContext
(NVListF [a]
ls , NVListF [a]
rs ) -> forall (f :: * -> *) (m :: * -> *) a b.
(Align f, Traversable f, Monad m) =>
(a -> b -> m Bool) -> f a -> f b -> m Bool
alignEqM a -> a -> n Bool
eq [a]
ls [a]
rs
(NVSetF PositionSet
_ AttrSet a
lm , NVSetF PositionSet
_ AttrSet a
rm ) -> AttrSet a -> AttrSet a -> n Bool
attrsEq AttrSet a
lm AttrSet a
rm
(NVPathF Path
lp , NVPathF Path
rp ) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path
lp forall a. Eq a => a -> a -> Bool
== Path
rp
(NValueF p m a, NValueF p m a)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
valueFEq
:: (AttrSet a -> AttrSet a -> Bool)
-> (a -> a -> Bool)
-> NValueF p m a
-> NValueF p m a
-> Bool
valueFEq :: forall a p (m :: * -> *).
(AttrSet a -> AttrSet a -> Bool)
-> (a -> a -> Bool) -> NValueF p m a -> NValueF p m a -> Bool
valueFEq AttrSet a -> AttrSet a -> Bool
attrsEq a -> a -> Bool
eq NValueF p m a
x NValueF p m a
y =
forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$
forall (n :: * -> *) a p (m :: * -> *).
Monad n =>
(AttrSet a -> AttrSet a -> n Bool)
-> (a -> a -> n Bool) -> NValueF p m a -> NValueF p m a -> n Bool
valueFEqM
((forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttrSet a -> AttrSet a -> Bool
attrsEq)
((forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Bool
eq)
NValueF p m a
x
NValueF p m a
y
compareAttrSetsM
:: Monad m
=> (t -> m (Maybe NixString))
-> (t -> t -> m Bool)
-> AttrSet t
-> AttrSet t
-> m Bool
compareAttrSetsM :: forall (m :: * -> *) t.
Monad m =>
(t -> m (Maybe NixString))
-> (t -> t -> m Bool) -> AttrSet t -> AttrSet t -> m Bool
compareAttrSetsM t -> m (Maybe NixString)
f t -> t -> m Bool
eq AttrSet t
lm AttrSet t
rm =
forall a. a -> a -> Bool -> a
bool
m Bool
compareAttrs
(forall a. a -> Maybe a -> a
fromMaybe m Bool
compareAttrs Maybe (m Bool)
equalOutPaths)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Bool
areDerivations
where
areDerivations :: m Bool
areDerivations = forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&)) (forall (m :: * -> *) t.
Monad m =>
(t -> m (Maybe NixString)) -> AttrSet t -> m Bool
isDerivationM t -> m (Maybe NixString)
f ) AttrSet t
lm AttrSet t
rm
equalOutPaths :: Maybe (m Bool)
equalOutPaths = forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 t -> t -> m Bool
eq) (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.Lazy.lookup VarName
"outPath") AttrSet t
lm AttrSet t
rm
compareAttrs :: m Bool
compareAttrs = forall (f :: * -> *) (m :: * -> *) a b.
(Align f, Traversable f, Monad m) =>
(a -> b -> m Bool) -> f a -> f b -> m Bool
alignEqM t -> t -> m Bool
eq AttrSet t
lm AttrSet t
rm
compareAttrSets
:: (t -> Maybe NixString)
-> (t -> t -> Bool)
-> AttrSet t
-> AttrSet t
-> Bool
compareAttrSets :: forall t.
(t -> Maybe NixString)
-> (t -> t -> Bool) -> AttrSet t -> AttrSet t -> Bool
compareAttrSets t -> Maybe NixString
f t -> t -> Bool
eq AttrSet t
lm AttrSet t
rm =
forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) t.
Monad m =>
(t -> m (Maybe NixString))
-> (t -> t -> m Bool) -> AttrSet t -> AttrSet t -> m Bool
compareAttrSetsM (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Maybe NixString
f) ((forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t -> Bool
eq) AttrSet t
lm AttrSet t
rm
valueEqM
:: forall t f m
. (MonadThunk t m (NValue t f m), NVConstraint f)
=> NValue t f m
-> NValue t f m
-> m Bool
valueEqM :: forall t (f :: * -> *) (m :: * -> *).
(MonadThunk t m (NValue t f m), NVConstraint f) =>
NValue t f m -> NValue t f m -> m Bool
valueEqM ( Pure t
x) ( Pure t
y) = forall t (m :: * -> *) (f :: * -> *).
(MonadThunk t m (NValue t f m), NVConstraint f) =>
t -> t -> m Bool
thunkEqM t
x t
y
valueEqM ( Pure t
x) y :: NValue t f m
y@(Free NValue' t f m (NValue t f m)
_) = forall t (m :: * -> *) (f :: * -> *).
(MonadThunk t m (NValue t f m), NVConstraint f) =>
t -> t -> m Bool
thunkEqM t
x forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall t (m :: * -> *) a. MonadThunk t m a => m a -> m t
thunk (forall (f :: * -> *) a. Applicative f => a -> f a
pure NValue t f m
y)
valueEqM x :: NValue t f m
x@(Free NValue' t f m (NValue t f m)
_) ( Pure t
y) = (forall t (m :: * -> *) (f :: * -> *).
(MonadThunk t m (NValue t f m), NVConstraint f) =>
t -> t -> m Bool
`thunkEqM` t
y) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall t (m :: * -> *) a. MonadThunk t m a => m a -> m t
thunk (forall (f :: * -> *) a. Applicative f => a -> f a
pure NValue t f m
x)
valueEqM (Free (NValue' (forall (w :: * -> *) a. Comonad w => w a -> a
extract -> NValueF (NValue t f m) m (NValue t f m)
x))) (Free (NValue' (forall (w :: * -> *) a. Comonad w => w a -> a
extract -> NValueF (NValue t f m) m (NValue t f m)
y))) =
forall (n :: * -> *) a p (m :: * -> *).
Monad n =>
(AttrSet a -> AttrSet a -> n Bool)
-> (a -> a -> n Bool) -> NValueF p m a -> NValueF p m a -> n Bool
valueFEqM
(forall (m :: * -> *) t.
Monad m =>
(t -> m (Maybe NixString))
-> (t -> t -> m Bool) -> AttrSet t -> AttrSet t -> m Bool
compareAttrSetsM NValue t f m -> m (Maybe NixString)
findNVStr forall t (f :: * -> *) (m :: * -> *).
(MonadThunk t m (NValue t f m), NVConstraint f) =>
NValue t f m -> NValue t f m -> m Bool
valueEqM)
forall t (f :: * -> *) (m :: * -> *).
(MonadThunk t m (NValue t f m), NVConstraint f) =>
NValue t f m -> NValue t f m -> m Bool
valueEqM
NValueF (NValue t f m) m (NValue t f m)
x
NValueF (NValue t f m) m (NValue t f m)
y
where
findNVStr :: NValue t f m -> m (Maybe NixString)
findNVStr :: NValue t f m -> m (Maybe NixString)
findNVStr =
forall a b (f :: * -> *).
(a -> b) -> (f (Free f a) -> b) -> Free f a -> b
free
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(\case
NVStr NixString
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NixString
s
NValue t f m
_ -> forall a. Monoid a => a
mempty
) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force
)
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
.
\case
NVStr' NixString
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NixString
s
NValue' t f m (NValue t f m)
_ -> forall a. Monoid a => a
mempty
)
thunkEqM :: (MonadThunk t m (NValue t f m), NVConstraint f) => t -> t -> m Bool
thunkEqM :: forall t (m :: * -> *) (f :: * -> *).
(MonadThunk t m (NValue t f m), NVConstraint f) =>
t -> t -> m Bool
thunkEqM t
lt t
rt =
do
NValue t f m
lv <- forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force t
lt
NValue t f m
rv <- forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force t
rt
let
unsafePtrEq :: m Bool
unsafePtrEq =
forall a. a -> a -> Bool -> a
bool
(forall t (f :: * -> *) (m :: * -> *).
(MonadThunk t m (NValue t f m), NVConstraint f) =>
NValue t f m -> NValue t f m -> m Bool
valueEqM NValue t f m
lv NValue t f m
rv)
(forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
forall a b. (a -> b) -> a -> b
$ forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) forall t (m :: * -> *) a. MonadThunk t m a => t -> ThunkId m
thunkId t
lt t
rt
case (NValue t f m
lv, NValue t f m
rv) of
(NVClosure Params ()
_ NValue t f m -> m (NValue t f m)
_, NVClosure Params ()
_ NValue t f m -> m (NValue t f m)
_) -> m Bool
unsafePtrEq
(NVList [NValue t f m]
_ , NVList [NValue t f m]
_ ) -> m Bool
unsafePtrEq
(NVSet PositionSet
_ AttrSet (NValue t f m)
_ , NVSet PositionSet
_ AttrSet (NValue t f m)
_ ) -> m Bool
unsafePtrEq
(NValue t f m, NValue t f m)
_ -> forall t (f :: * -> *) (m :: * -> *).
(MonadThunk t m (NValue t f m), NVConstraint f) =>
NValue t f m -> NValue t f m -> m Bool
valueEqM NValue t f m
lv NValue t f m
rv