Supporting multiple implementations of type class instances for the same type

Main.purs

module Main where

import Prelude

import Control.Monad.Reader (ReaderT(..), runReader, runReaderT)
import Data.Identity (Identity(..))
import Data.Newtype (class Newtype, unwrap)
import Data.Symbol (class IsSymbol)
import Data.Tuple (Tuple(..))
import Effect (Effect)
import Effect.Console (log)
import Prim.Row as Row
import Record as Record
import Safe.Coerce (coerce)
import Type.Proxy (Proxy(..))
import TryPureScript as TPS

-- This file demonstrates how to enable multiple type class instance
-- implementations for the same type, `a`, by providing an external
-- implementation via a record value, `b`, that uses the least
-- amount of boilerplate.

-- | 1. Given a type class...
class Delegate b a where
  delegate :: ReaderT b Identity a

-- | 2. `Tuple` delegates to its inner parts and then wraps them as expected...
instance (Delegate externRec a, Delegate externRec b) => Delegate externRec (Tuple a b) where
  delegate = Tuple <$> delegate <*> delegate

-- | 3. `String` has a default implementation
instance Delegate externRec String where
  delegate = pure "default String implementation"

-- | 4. A special newtype that enables replacing a type's default instance
-- | with an external implementation. It takes 3 type paramters:
-- |   1. a record that has been wrapped in a newtype because it is recursive in nature
-- |   2. the label within that record that stores the new implementation
-- |   3. the type whose instance we are replacing
newtype ExternalRef :: Type -> Symbol -> Type -> Type
newtype ExternalRef newtypedRecordType sym a = ExternalRef a

-- | 5. `ExternalRef`'s implementation always uses the one corresponding
-- | to the label associated with that type in the externally-provided record type.
instance
  ( Newtype newtypedRecord { | rows }
  , Row.Cons sym (ReaderT newtypedRecord Identity a) tail rows
  , IsSymbol sym
  ) =>
  Delegate newtypedRecord (ExternalRef newtypedRecord sym a) where
  delegate :: ReaderT newtypedRecord Identity (ExternalRef newtypedRecord sym a)
  delegate = ReaderT \externRec -> do
    let
      theRecord :: { | rows }
      theRecord = unwrap externRec

      externalImplementation :: ReaderT newtypedRecord Identity a
      externalImplementation = Record.get (Proxy :: Proxy sym) theRecord

      wrapInExternalRef
        :: ReaderT newtypedRecord Identity a
        -> ReaderT newtypedRecord Identity (ExternalRef newtypedRecord sym a)
      wrapInExternalRef = coerce

    runReaderT (wrapInExternalRef externalImplementation) externRec

-- 6. Since each label in our external record must reference the record itself
-- (in case one local override should also use another local override),
-- we need to solve the problem of the recursive type by wrapping
-- the record in a newtype. Now, the record's labels can refer to itself.
newtype ExternImpls = ExternImpls
  { str1 :: ReaderT ExternImpls Identity String
  , str2 :: ReaderT ExternImpls Identity String
  }

derive instance Newtype ExternImpls _

-- | 7. Finally, if we don't need this 'local override' feature,
-- | we opt-out by using this newtype.
newtype NoLocalOverrides = NoLocalOverrides {}

runDelegate' :: forall a. ReaderT NoLocalOverrides Identity a -> a
runDelegate' (ReaderT f) = unwrap $ f $ NoLocalOverrides {}

-- | 8. Now we prove that this code compiles and runs without errors
main :: Effect Unit
main = TPS.render =<< TPS.withConsole do
  let
    -- 9. This demonstrates the smallest amount of code needed to provide local overrides
    --    1. Passing in a newtyped record informs the compiler what the possible labels are for the local overrides.
    --    2. `dropExternalRefs` informs the compiler what the `a` in `delegate` will be
    example :: Tuple String (Tuple String String)
    example = dropExternalRefs $ flip runReader (ExternImpls { str1: pure "one", str2: pure "two" }) delegate
      where
      dropExternalRefs
        :: Tuple String (Tuple (ExternalRef ExternImpls "str1" String) (ExternalRef ExternImpls "str2" String))
        -> Tuple String (Tuple String String)
      dropExternalRefs = coerce

  log $ show $ example

  let
    -- 10. If we generalize this idea so that the local overrides are passed in as an argument,
    -- then we can customize the local overrides on each run.
    buildExample :: ExternImpls -> Tuple String (Tuple String String)
    buildExample localOverrides = dropExternalRefs $ flip runReader localOverrides delegate
      where
      dropExternalRefs
        :: Tuple String (Tuple (ExternalRef ExternImpls "str1" String) (ExternalRef ExternImpls "str2" String))
        -> Tuple String (Tuple String String)
      dropExternalRefs = coerce

  log $ show $ buildExample $ ExternImpls { str1: pure "a", str2: pure "three" }
  log $ show $ buildExample $ ExternImpls { str1: pure "a", str2: pure "four" }

  -- 11. And if we don't need the local overrides, we just use the NoLocalOverrides newtype
  log $ show $ (runDelegate' delegate :: Tuple String (Tuple String String))