Pred.hs

{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Avoid restricted function" #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# OPTIONS_GHC -Wno-missing-fields #-}

module Pred where

import Control.Exception
import GHC.Exts.Heap
import GHC.Generics
import System.IO.Unsafe
import Unsafe.Coerce

data PredicateBox a = PredicateBox { unPredicateBox :: a -> Bool }

p :: (a -> Bool) -> a
p = unsafeCoerce . PredicateBox

unP :: a -> IO (Maybe (Either (a -> Bool) a))
unP a = do
  ma <- try (evaluate a)
  case ma of
    Left (_ :: SomeException) -> pure Nothing
    Right a' -> do
      cl <- getClosureData a'
      pure $ Just $ case cl of
        ConstrClosure{name = "PredicateBox"} ->
          Left (unPredicateBox (unsafeCoerce a'))
        _ -> Right a'

defaultEqOrPred :: Eq a => a -> a -> IO Bool
defaultEqOrPred x y = do
  y' <- unP y
  pure $ case y' of
    Nothing -> True
    Just (Left f) -> f x
    Just (Right y'') -> x == y''

class EqOrPred a where
  eqOrPred :: a -> a -> IO Bool

  default eqOrPred :: (Generic a, GEqOrPred (Rep a)) => a -> a -> IO Bool
  eqOrPred x y = geqOrPred (from x) (from y)

class GEqOrPred f where
  geqOrPred :: f a -> f a -> IO Bool

instance GEqOrPred f => GEqOrPred (M1 i c f) where
  geqOrPred (M1 f1) (M1 f2) = geqOrPred f1 f2

instance EqOrPred a => GEqOrPred (K1 i a) where
  geqOrPred (K1 f1) (K1 f2) = eqOrPred f1 f2

instance (GEqOrPred f, GEqOrPred g) => GEqOrPred (f :*: g) where
  geqOrPred (f1 :*: g1) (f2 :*: g2) = (&&) <$> geqOrPred f1 f2 <*> geqOrPred g1 g2

instance EqOrPred Int where eqOrPred = defaultEqOrPred
instance EqOrPred Double where eqOrPred = defaultEqOrPred
instance EqOrPred String where eqOrPred = defaultEqOrPred

(===) :: EqOrPred a => a -> a -> Bool
x === y = unsafePerformIO $ eqOrPred x y

----

data MyRecord = MyRecord { fld1 :: Int, fld2 :: String, fld3 :: Double }
  deriving (Generic, EqOrPred)

main :: IO ()
main = print $
  MyRecord {fld1 = 3, fld2 = "foo", fld3 = pi} === MyRecord {fld1 = p odd, fld2 = "foo"}