constraining "coerce" using type families

ConstrainingCoerce.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}

-- | Examples of how to constrain "coerce" using type families so that only the
-- types that we really want to change might change, and not some unexpected
-- newtype.
module Main where 

import Data.Coerce
import Data.Functor.Compose
import Control.Monad.Trans.Except
import GHC.TypeLits

type Phases = IO `Compose` IO `Compose` IO `Compose` IO

-- ugh! tedious to write
value :: Phases Int
value = Compose (pure (Compose (pure (Compose (pure (pure 5))))))

bareValue :: IO (IO (IO (IO Int)))
bareValue = pure $ pure $ pure $ pure 5

value2 :: Phases Int 
value2 = coerce bareValue

-- We don't want this newtype to be coerced, but we might do it by accident.
newtype DoNotUnwrap = DoNotUnwrap Int

dangerousBareValue :: IO (IO (IO (IO DoNotUnwrap)))
dangerousBareValue = pure $ pure $ pure $ pure (DoNotUnwrap 5)

-- bad!
value3 :: Phases Int 
value3 = coerce dangerousBareValue

type family Bare x where
  Bare (Compose outer inner x) = Bare (outer (Bare (inner x)))
  Bare other = other

fromBare :: Coercible x (Bare x) => Bare x -> x
fromBare = coerce

value4 :: Phases Int
value4 = fromBare bareValue

-- doesn't compile (good!)
-- value5 :: Phases Int
-- value5 = fromBare dangerousBareValue

--
--
-- Now an example with Servant-like handlers
type Handler = Int -> String -> ExceptT String IO Int

eitherHandler :: Int -> String -> IO (Either String Int)
eitherHandler = undefined

-- ugh! tedious to write
manuallyAdaptedHandler :: Handler
manuallyAdaptedHandler i s = ExceptT (eitherHandler i s)

handler2 :: Handler
handler2 = coerce eitherHandler

dangerousEitherHandler :: Int -> String -> IO (Either String DoNotUnwrap)
dangerousEitherHandler = undefined

-- bad!
handler3 :: Handler
handler3 = coerce dangerousEitherHandler

type family BareH x where
  BareH (ExceptT e IO r) = IO (Either e r)
  BareH (input -> output) = input -> BareH output
  BareH other = TypeError (Text "unexpedted value at the tip: " :<>: ShowType other)

fromBareH :: Coercible x (BareH x) => BareH x -> x
fromBareH = coerce

handler4 :: Handler 
handler4 = fromBareH eitherHandler

-- doesn't compile (good!)
-- handler5 :: Handler 
-- handler5 = fromBareH dangerousEitherHandler

main :: IO ()
main = pure ()