providing a local instance

LocalInstance.hs

-- in response to https://twitter.com/mstk/status/1137162185266696192
{-# LANGUAGE FlexibleContexts, FlexibleInstances, RankNTypes, ScopedTypeVariables #-}
module Main where
import Test.DocTest

import Data.Proxy
import Unsafe.Coerce


-- The goal is to implement a function
--
-- > withInst :: forall r. (C X => r) -> r
--
-- using dirty unsafe tricks. I will use newtypes and 'unsafeCoerce'.


-- First, let's define some concrete X and C.

data X = X1 | X2
  deriving (Eq, Show)

class C a where
  myEq  :: a -> a -> Bool
  myNot :: a -> a


-- Our goal is to call this function. Currently, we can't, because X does
-- not have a C instance.

-- |
-- >>> useCX
-- ...
-- ... No instance for (C X) ...
-- ...
useCX :: C X => (Bool, Bool, X, X)
useCX = (myEq X1 X1, myEq X1 X2, myNot X1, myNot X2)


-- 'withInst' needs to provide a C X instance without exposing that
-- instance globally. My trick is to define a newtype around X and to
-- define the instance for that newtype instead.

newtype SecretInstance = SecretInstance X

instance C SecretInstance where
  myEq (SecretInstance x) (SecretInstance y) = x == y
  myNot (SecretInstance X1) = SecretInstance X2
  myNot (SecretInstance X2) = SecretInstance X1


-- This second newtype is critical to make the 'unsafeCoerce' call below
-- work correctly! The newtype-less alternative
--
-- > withInst :: forall r. (C X => r) -> r
-- > withInst body = reallyUnsafeCoerce body
-- >   where
-- >     reallyUnsafeCoerce :: (C X => r)
-- >                        -> (C SecretInstance => r)
-- >     reallyUnsafeCoerce = unsafeCoerce unsafeCoerce
--
-- compiles but crashes at runtime. I think GHC might be discharging the
-- C SecretInstance constraint too early instead of waiting until after
-- the 'reallyUnsafeCoerce' call.
newtype AssumingC a b = AssumingC { givenC :: C a => b }


-- Finally, we can write 'withInst'. The methods
--
-- > myEq :: X -> X -> Bool
-- > myNot :: X -> X
--
-- are unsafeCoerced from their original types 
--
-- > myEq :: SecretInstance -> SecretInstance -> Bool
-- > myNot :: SecretInstance -> SecretInstance
--
-- but they will work fine since 'SecretInstance' has the same
-- representation as 'X'.

-- |
-- >>> withInst useCX
-- (True,False,X2,X1)
withInst :: forall r. (C X => r) -> r
withInst body = givenC $ barelyUnsafeCoerce $ AssumingC body
  where
    barelyUnsafeCoerce :: AssumingC X r
                       -> AssumingC SecretInstance r
    barelyUnsafeCoerce = unsafeCoerce


main :: IO ()
main = doctest ["LocalInstance.hs"]