Reference-ish equality in Haskell

unique-value.hs

#!/usr/bin/env stack
{- stack script
 --resolver=nightly-2019-12-08
 --package=base-unicode-symbols
 --package=hashable
 -}

-- Author: Viacheslav Lotsmanov <lotsmanov89@gmail.com>
-- Date: December 2019
-- License: BSD-3-Clause

-- Copyright 2019 Viacheslav Lotsmanov
--
-- Redistribution and use in source and binary forms, with or without modification, are permitted
-- provided that the following conditions are met:
--
-- 1. Redistributions of source code must retain the above copyright notice, this list of conditions
--    and the following disclaimer.
--
-- 2. Redistributions in binary form must reproduce the above copyright notice, this list of
--    conditions and the following disclaimer in the documentation and/or other materials provided
--    with the distribution.
--
-- 3. Neither the name of the copyright holder nor the names of its contributors may be used to
--    endorse or promote products derived from this software without specific prior written
--    permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
-- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-- WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
-- WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE UnicodeSyntax, KindSignatures, DataKinds, TypeApplications, ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, LambdaCase #-}
{-# LANGUAGE InstanceSigs #-}

module Main
     ( main

     -- Just showing what is supposed to be exposed

     , uniqueValue
     , UniqueValue -- ^ Constructor is hidden, only type is exposed
     , UniqueValueFullEq (..)
     , UniqueValueLazyEq (..)
     , UniqueValueEq (..) -- ^ Recommended way to \"lazily" or \"fully" comparison
     , ExtrudeUniqueValue (..)
     , WrapUniqueValue (..)
     , FromUniqueValue (..)
     , UpdateUniqueValue (..)
     ) where

import Prelude.Unicode
import Data.Unique (Unique, newUnique, hashUnique)
import Data.Hashable (Hashable (hash, hashWithSalt))
import Control.Exception (SomeException, assert, try, displayException, throwIO)
import System.IO.Unsafe (unsafePerformIO)


data UniqueValue α = UniqueValue {-# UNPACK #-} !Unique α

newtype UniqueValueFullEq α
      = UniqueValueFullEq
      { fromUniqueValueFullEq ∷ UniqueValue α
      } deriving Show

newtype UniqueValueLazyEq α
      = UniqueValueLazyEq
      { fromUniqueValueLazyEq ∷ UniqueValue α
      } deriving Show

instance Show α ⇒ Show (UniqueValue α) where
  show (UniqueValue τ α) =
    "UniqueValue (identity hash: " ◇ show (hashUnique τ) ◇ ") (" ◇ show α ◇ ")"

-- | @UniqueValueFullEq@ checks whether identities are equal,
--   if not then it tries to do real @Eq@ comparison,
--   so this is correct implementation and very fast in case both arguments are the same value
--   which hasn't changed (identity hasn't been updated).
instance Eq α ⇒ Eq (UniqueValueFullEq α) where
  UniqueValueFullEq (UniqueValue x xv) == UniqueValueFullEq (UniqueValue y yv) = x ≡ y ∨ xv ≡ yv

-- | @UniqueValueLazyEq@ checks whether identities are equal,
--   values may be equal but this comparison will return @False@ in case identities aren't equal.
instance Eq (UniqueValueLazyEq α) where
  UniqueValueLazyEq (UniqueValue x _) == UniqueValueLazyEq (UniqueValue y _) = x ≡ y
  UniqueValueLazyEq (UniqueValue x _) /= UniqueValueLazyEq (UniqueValue y _) = x ≠ y

-- | Full hash of whole data structure including identity.
instance Hashable α ⇒ Hashable (UniqueValueFullEq α) where
  hashWithSalt salt (UniqueValueFullEq (UniqueValue τ α)) =
    hashWithSalt salt (hashUnique τ) + hashWithSalt salt α

  hash (UniqueValueFullEq (UniqueValue τ α)) = hash (hashUnique τ) + hash α

-- | @UniqueValueLazyEq@ Gives you hash only of the identity.
instance Hashable (UniqueValueLazyEq α) where
  hashWithSalt salt (UniqueValueLazyEq (UniqueValue τ _)) = hashWithSalt salt (hashUnique τ)
  hash (UniqueValueLazyEq (UniqueValue τ _)) = hash (hashUnique τ)


-- | Gives you original @UniqueValue@ from a newtype-wrapper.
class ExtrudeUniqueValue (α ∷ * → *) where
  extrudeUniqueValue ∷ α β → UniqueValue β

instance ExtrudeUniqueValue UniqueValue where
  extrudeUniqueValue = id

instance ExtrudeUniqueValue UniqueValueFullEq where
  extrudeUniqueValue = fromUniqueValueFullEq

instance ExtrudeUniqueValue UniqueValueLazyEq where
  extrudeUniqueValue = fromUniqueValueLazyEq


class WrapUniqueValue (α ∷ * → *) (ω ∷ * → *) where
  wrapUniqueValue ∷ α γ → ω γ

instance ExtrudeUniqueValue α ⇒ WrapUniqueValue α UniqueValue where
  wrapUniqueValue = extrudeUniqueValue

instance ExtrudeUniqueValue α ⇒ WrapUniqueValue α UniqueValueLazyEq where
  wrapUniqueValue = UniqueValueLazyEq ∘ extrudeUniqueValue

instance ExtrudeUniqueValue α ⇒ WrapUniqueValue α UniqueValueFullEq where
  wrapUniqueValue = UniqueValueFullEq ∘ extrudeUniqueValue


class FromUniqueValue (α ∷ * → *) where
  fromUniqueValue ∷ α β → β

instance ExtrudeUniqueValue α ⇒ FromUniqueValue α where
  fromUniqueValue = (\(UniqueValue _ x) → x) ∘ extrudeUniqueValue


class UniqueValueEq (α ∷ * → *) (β ∷ * → *) where
  lazyUniqueValueEq    ∷        α γ → β γ → Bool
  lazyUniqueValueNotEq ∷        α γ → β γ → Bool
  fullUniqueValueEq    ∷ Eq γ ⇒ α γ → β γ → Bool
  fullUniqueValueNotEq ∷ Eq γ ⇒ α γ → β γ → Bool

instance (ExtrudeUniqueValue α, ExtrudeUniqueValue β) ⇒ UniqueValueEq α β where
  lazyUniqueValueEq α β =
    UniqueValueLazyEq (extrudeUniqueValue α) == UniqueValueLazyEq (extrudeUniqueValue β)

  lazyUniqueValueNotEq α β =
    UniqueValueLazyEq (extrudeUniqueValue α) /= UniqueValueLazyEq (extrudeUniqueValue β)

  fullUniqueValueEq α β =
    UniqueValueFullEq (extrudeUniqueValue α) == UniqueValueFullEq (extrudeUniqueValue β)

  fullUniqueValueNotEq α β =
    UniqueValueFullEq (extrudeUniqueValue α) /= UniqueValueFullEq (extrudeUniqueValue β)


class UpdateUniqueValue (α ∷ * → *) where
  updateUniqueValue ∷ (β → β) → α β → α β

  -- | Gives original value with original identity if value hasn't changed.
  updateUniqueValueWithImmutabilityCheck ∷ Eq β ⇒ (β → β) → α β → α β

instance (ExtrudeUniqueValue α, WrapUniqueValue UniqueValue α) ⇒ UpdateUniqueValue α where
  updateUniqueValue fn
    = wrapUniqueValue
    ∘ uniqueValue
    ∘ fn
    ∘ fromUniqueValue
    ∘ extrudeUniqueValue

  updateUniqueValueWithImmutabilityCheck fn = go where
    go = wrapUniqueValue ∘ update ∘ extrudeUniqueValue

    update prevUniqueX = nextUniqueValue where
      nextUniqueValue = if x == newX then prevUniqueX else uniqueValue newX
      x = fromUniqueValue prevUniqueX
      newX = fn x


-- | N.B. Avoid point-free style here since it memoizes unique identity
--   (it stays the same for every new value).
uniqueValue ∷ α → UniqueValue α
uniqueValue x = result where
  identity = unsafePerformIO newUnique
  result   = UniqueValue identity x


main ∷ IO ()
main = do
  do
    putStrLn "(Show)ing UniqueValue…"
    print $                     uniqueValue @Integer 10
    print $ UniqueValueFullEq $ uniqueValue @Integer 10
    print $ UniqueValueLazyEq $ uniqueValue @Integer 10

  do
    putStrLn "Proving that identity is lazy…"
    let x = uniqueValue @Integer 10
    let y = uniqueValue @Integer 15

    y `seq` x
      `seq` (hash (UniqueValueLazyEq y) < hash (UniqueValueLazyEq x))
      `assert` (print x >> print y)

  do
    putStrLn "Proving that lazy Eq doesn't compare actual value…"

    let (x, y) = let value = 10 in
                 case uniqueValue @Integer value of
                      UniqueValue τ _ →
                        ( UniqueValue τ (error "this value 'x' shouldn't be reached" `seq` value)
                        , UniqueValue τ (error "this value 'y' shouldn't be reached" `seq` value)
                        )

    (x `lazyUniqueValueEq` y) `assert` pure ()
    not (x `lazyUniqueValueEq` uniqueValue @Integer 10) `assert` pure ()

  do
    putStrLn "Proving that full Eq compares actual value (but only if identity is different)…"
    let refErrStr = "value 'x' is reached"

    let (x, y) = let value = 10 in
                 case uniqueValue @Integer value of
                      UniqueValue τ _ →
                        ( UniqueValue τ (error refErrStr `seq` value)
                        , UniqueValue τ (error "value 'y' is reached" `seq` value)
                        )

    let z = uniqueValue @Integer 10

    -- Identities are equal, it doesn't look inside in this case
    (x `fullUniqueValueEq` y) `assert` pure ()

    -- Reaches innards only when identities are not equal
    try ((x `fullUniqueValueEq` z) `seq` pure ()) >>= \case
      Right () → fail "It should fail but it did not"
      Left (e :: SomeException) →
        if take (length refErrStr) (displayException e) == refErrStr
           then pure ()
           else throwIO e

  do
    putStrLn "Lazy eq check gives 'not equal' for different identities even if values are equal…"
    let (x, y) = (uniqueValue @Integer 10, uniqueValue @Integer 10)
    not (x `lazyUniqueValueEq` y) `assert` pure ()

  do
    putStrLn "Full eq check gives 'equal' for different identities if values are equal…"
    let (x, y) = (uniqueValue @Integer 10, uniqueValue @Integer 10)
    (x `fullUniqueValueEq` y) `assert` pure ()

  do
    putStrLn "Full eq check gives 'not equal' for different identities if values are not equal…"
    let (x, y) = (uniqueValue @Integer 10, uniqueValue @Integer 15)
    not (x `fullUniqueValueEq` y) `assert` pure ()

  do
    putStrLn "Updating value gives new identity (even if a value hasn't changed)…"
    let x = uniqueValue @Integer 10
    let y = updateUniqueValue id x
    (x `fullUniqueValueEq` y) `assert` pure ()
    not (x `lazyUniqueValueEq` y) `assert` pure ()

  do
    putStrLn "Updating value keeps old identity if a value hasn't changed…"
    let x = uniqueValue @Integer 10
    let y = updateUniqueValueWithImmutabilityCheck id x
    (x `fullUniqueValueEq` y) `assert` pure ()
    (x `lazyUniqueValueEq` y) `assert` pure ()

  do
    putStrLn "Updating value gives new identity if a value has changed…"
    let x = uniqueValue @Integer 10
    let y = updateUniqueValueWithImmutabilityCheck succ x
    let z = updateUniqueValue succ x
    not (x `fullUniqueValueEq` y) `assert` pure ()
    not (x `lazyUniqueValueEq` y) `assert` pure ()
    not (x `fullUniqueValueEq` z) `assert` pure ()
    not (x `lazyUniqueValueEq` z) `assert` pure ()

  do
    putStrLn "Polymorphic UniqueValue wrappers…"
    do
      let x = UniqueValueFullEq $ uniqueValue @Integer 10
      let y = updateUniqueValueWithImmutabilityCheck id x
      let z = updateUniqueValue id x
      (x `fullUniqueValueEq` y) `assert` pure ()
      (x `lazyUniqueValueEq` y) `assert` pure ()
      (x `fullUniqueValueEq` z) `assert` pure ()
      not (x `lazyUniqueValueEq` z) `assert` pure ()
    do
      let x = UniqueValueLazyEq $ uniqueValue @Integer 10
      let y = updateUniqueValueWithImmutabilityCheck id x
      let z = updateUniqueValue id x
      (x `fullUniqueValueEq` y) `assert` pure ()
      (x `lazyUniqueValueEq` y) `assert` pure ()
      (x `fullUniqueValueEq` z) `assert` pure ()
      not (x `lazyUniqueValueEq` z) `assert` pure ()
    do
      let x = uniqueValue @Integer 10
      let y = UniqueValueFullEq $ updateUniqueValueWithImmutabilityCheck id x
      let z = UniqueValueFullEq $ updateUniqueValue id x
      (x `fullUniqueValueEq` y) `assert` pure ()
      (x `lazyUniqueValueEq` y) `assert` pure ()
      (x `fullUniqueValueEq` z) `assert` pure ()
      not (x `lazyUniqueValueEq` z) `assert` pure ()
    do
      let x = uniqueValue @Integer 10
      let y = UniqueValueLazyEq $ updateUniqueValueWithImmutabilityCheck id x
      let z = UniqueValueLazyEq $ updateUniqueValue id x
      (x `fullUniqueValueEq` y) `assert` pure ()
      (x `lazyUniqueValueEq` y) `assert` pure ()
      (x `fullUniqueValueEq` z) `assert` pure ()
      not (x `lazyUniqueValueEq` z) `assert` pure ()
    do
      let x = UniqueValueFullEq $ uniqueValue @Integer 10
      let y = UniqueValueLazyEq $ extrudeUniqueValue $ updateUniqueValueWithImmutabilityCheck id x
      let z = UniqueValueLazyEq $ extrudeUniqueValue $ updateUniqueValue id x
      (x `fullUniqueValueEq` y) `assert` pure ()
      (x `fullUniqueValueEq` y) `assert` pure ()
      (x `fullUniqueValueEq` z) `assert` pure ()
      not (x `lazyUniqueValueEq` z) `assert` pure ()
    do
      let x = UniqueValueLazyEq $ uniqueValue @Integer 10
      let y = UniqueValueFullEq $ extrudeUniqueValue $ updateUniqueValueWithImmutabilityCheck id x
      let z = UniqueValueFullEq $ extrudeUniqueValue $ updateUniqueValue id x
      (x `fullUniqueValueEq` y) `assert` pure ()
      (x `lazyUniqueValueEq` y) `assert` pure ()
      (x `fullUniqueValueEq` z) `assert` pure ()
      not (x `lazyUniqueValueEq` z) `assert` pure ()


(◇) ∷ Semigroup α ⇒ α → α → α; (◇) = (<>)
-- vim:et ts=2 sts=2 sw=2 tw=100 cc=+1: