hnix/src/Nix/Value/Equal.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-}

module Nix.Value.Equal where

import           Control.Comonad
import           Control.Monad
import           Control.Monad.Free
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Data.Align
import           Data.Eq.Deriving
import           Data.Fix
import           Data.Functor.Classes
import           Data.Functor.Identity
import qualified Data.HashMap.Lazy             as M
import           Data.These
import           Nix.Atoms
import           Nix.Frames
import           Nix.String
import           Nix.Thunk
import           Nix.Utils
import           Nix.Value

checkComparable
  :: (Framed e m, MonadDataErrorContext t f m)
  => NValue t f m
  -> NValue t f m
  -> m ()
checkComparable x y = case (x, y) of
  (NVConstant (NFloat _), NVConstant (NInt _)) -> pure ()
  (NVConstant (NInt _), NVConstant (NFloat _)) -> pure ()
  (NVConstant (NInt _), NVConstant (NInt _)) -> pure ()
  (NVConstant (NFloat _), NVConstant (NFloat _)) -> pure ()
  (NVStr _, NVStr _) -> pure ()
  (NVPath _, NVPath _) -> pure ()
  _ -> throwError $ Comparison x y

thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool
thunkEqM lt rt = force lt $ \lv -> force rt $ \rv ->
  let unsafePtrEq = case (lt, rt) of
        (thunkId -> lid, thunkId -> rid) | lid == rid -> return True
        _ -> valueEqM lv rv
  in  case (lv, rv) of
        (NVClosure _ _, NVClosure _ _) -> unsafePtrEq
        (NVList _     , NVList _     ) -> unsafePtrEq
        (NVSet _ _    , NVSet _ _    ) -> unsafePtrEq
        _                              -> valueEqM lv rv

-- | Checks whether two containers are equal, using the given item equality
--   predicate. If there are any item slots that don't match between the two
--   containers, the result will be False.
alignEqM
  :: (Align f, Traversable f, Monad m)
  => (a -> b -> m Bool)
  -> f a
  -> f b
  -> m Bool
alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
  pairs <- forM (Data.Align.align fa fb) $ \case
    These a b -> return (a, b)
    _         -> throwE ()
  forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)

alignEq :: (Align f, Traversable f) => (a -> b -> Bool) -> f a -> f b -> Bool
alignEq eq fa fb = runIdentity $ alignEqM (\x y -> Identity (eq x y)) fa fb

isDerivationM :: Monad m => (t -> m (Maybe NixString)) -> AttrSet t -> m Bool
isDerivationM f m = case M.lookup "type" m of
  Nothing -> pure False
  Just t  -> do
    mres <- f t
    case mres of
        -- We should probably really make sure the context is empty here
        -- but the C++ implementation ignores it.
      Just s  -> pure $ principledStringIgnoreContext s == "derivation"
      Nothing -> pure False

isDerivation :: Monad m => (t -> Maybe NixString) -> AttrSet t -> Bool
isDerivation f = runIdentity . isDerivationM (\x -> Identity (f x))

valueFEqM
  :: Monad n
  => (AttrSet a -> AttrSet a -> n Bool)
  -> (a -> a -> n Bool)
  -> NValueF p m a
  -> NValueF p m a
  -> n Bool
valueFEqM attrsEq eq = curry $ \case
  (NVConstantF (NFloat x), NVConstantF (NInt y)  ) -> pure $ x == fromInteger y
  (NVConstantF (NInt   x), NVConstantF (NFloat y)) -> pure $ fromInteger x == y
  (NVConstantF lc        , NVConstantF rc        ) -> pure $ lc == rc
  (NVStrF ls, NVStrF rs) ->
    pure $ principledStringIgnoreContext ls == principledStringIgnoreContext rs
  (NVListF ls , NVListF rs ) -> alignEqM eq ls rs
  (NVSetF lm _, NVSetF rm _) -> attrsEq lm rm
  (NVPathF lp , NVPathF rp ) -> pure $ lp == rp
  _                          -> pure False

valueFEq
  :: (AttrSet a -> AttrSet a -> Bool)
  -> (a -> a -> Bool)
  -> NValueF p m a
  -> NValueF p m a
  -> Bool
valueFEq attrsEq eq x y = runIdentity $ valueFEqM
  (\x' y' -> Identity (attrsEq x' y'))
  (\x' y' -> Identity (eq x' y'))
  x
  y

compareAttrSetsM
  :: Monad m
  => (t -> m (Maybe NixString))
  -> (t -> t -> m Bool)
  -> AttrSet t
  -> AttrSet t
  -> m Bool
compareAttrSetsM f eq lm rm = do
  isDerivationM f lm >>= \case
    True -> isDerivationM f rm >>= \case
      True
        | Just lp <- M.lookup "outPath" lm, Just rp <- M.lookup "outPath" rm -> eq
          lp
          rp
      _ -> compareAttrs
    _ -> compareAttrs
  where compareAttrs = alignEqM eq lm rm

compareAttrSets
  :: (t -> Maybe NixString)
  -> (t -> t -> Bool)
  -> AttrSet t
  -> AttrSet t
  -> Bool
compareAttrSets f eq lm rm = runIdentity
  $ compareAttrSetsM (\t -> Identity (f t)) (\x y -> Identity (eq x y)) lm rm

valueEqM
  :: forall t f m. (MonadThunk t m (NValue t f m), Comonad f)
  => NValue t f m
  -> NValue t f m
  -> m Bool
valueEqM (Pure x) (Pure y) = thunkEqM x y
valueEqM (Pure _) _ = pure False
valueEqM _ (Pure _) = pure False
valueEqM (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
  valueFEqM (compareAttrSetsM f valueEqM) valueEqM x y
  where
  f (Pure t) = force t $ \case
    NVStr s -> pure $ Just s
    _       -> pure Nothing
  f (Free v) = case v of
    NVStr' s -> pure $ Just s
    _        -> pure Nothing

valueNFEq :: Comonad f => NValueNF t f m -> NValueNF t f m -> Bool
valueNFEq (Fix (NValue (extract -> x))) (Fix (NValue (extract -> y))) =
  valueFEq (compareAttrSets f valueNFEq) valueNFEq x y
 where
  f = \case
    NVStrNF s -> Just s
    _         -> Nothing

instance Eq1 (NValueF p m) where
  liftEq _  (NVConstantF x) (NVConstantF y) = x == y
  liftEq _  (NVStrF      x) (NVStrF      y) = x == y
  liftEq eq (NVListF     x) (NVListF     y) = liftEq eq x y
  liftEq eq (NVSetF x _   ) (NVSetF y _   ) = liftEq eq x y
  liftEq _  (NVPathF x    ) (NVPathF y    ) = x == y
  liftEq _  _               _               = False

$(deriveEq1 ''NValue')