using DerivingVia with types which are not representationally-equal

DerivingViaSameShape.hs

-- DerivingVia is great when you want to delegate to a type which is
-- representationally-equal, in the sense that we can use coerce to convert
-- between the two types. But what if you want to delegate to a type which has
-- the same representation in the other sense of having the same shape? Here's a
-- trick!

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module DerivingViaSameShape where
import Test.DocTest

import GHC.Generics
import Generics.Eot

-- $setup
-- >>> :set -XScopedTypeVariables


-- |
-- A demo of what we're trying to achieve: deriving a bunch of instances for
-- 'MyMaybe' via a different type, 'Maybe', which cannot be coerced into
-- 'MyMaybe' but nevertheless has the same shape as 'MyMaybe'.
--
-- >>> MyNothing
-- MyNothing
-- >>> MyJust "foo" == MyJust "foo"
-- True
-- >>> MyNothing <> MyJust "foo"
-- MyJust "foo"
-- >>> mempty :: MyMaybe String
-- MyNothing
data MyMaybe a = MyNothing | MyJust a
  deriving stock (Show, Generic)
  deriving (Eq, Semigroup, Monoid)
    via (ViaEot (MyMaybe a) (Maybe a))


-- |
-- The first step is to define what "having the same shape" even means. I mean
-- that the two types have the same number of constructors, in the same order,
-- and that corresponding constructors have the same number or arguments and
-- corresponding arguments have the same type. I have derived 'Generic' above,
-- so you might guess that "having the same shape" means "having the same Rep",
-- but that's not quite right, because 'Rep' also includes a bunch of extra data
-- which I do not consider essential for two types to have the same shape, such
-- as the module they are defined in and the names of their constructors:
--
-- >>> :kind! forall a. Rep (Maybe a)
-- forall a. Rep (Maybe a) :: * -> *
-- = D1
--     ('MetaData "Maybe" "GHC.Maybe" "base" 'False)
--     (C1 ('MetaCons "Nothing" 'PrefixI 'False) U1
--      :+: C1
--            ('MetaCons "Just" 'PrefixI 'False)
--            (S1
--               ('MetaSel
--                  'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--               (Rec0 a)))
-- >>> :kind! forall a. Rep (MyMaybe a)
-- forall a. Rep (MyMaybe a) :: * -> *
-- = D1
--     ('MetaData "MyMaybe" "DerivingViaSameShape" "main" 'False)
--     (C1 ('MetaCons "MyNothing" 'PrefixI 'False) U1
--      :+: C1
--            ('MetaCons "MyJust" 'PrefixI 'False)
--            (S1
--               ('MetaSel
--                  'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)
--               (Rec0 a)))
--
-- Having this extra information in 'Rep' is often useful, e.g. to derive a
-- 'ToJSON' instance which encodes the name of the constructor as a string. But
-- for our purpose today, let's use generic-eot's much simpler generic
-- representation which intentionally does not include all that extra
-- information:
--
-- >>> :kind! forall a. Eot (Maybe a)
-- forall a. Eot (Maybe a) :: *
-- = Either () (Either (a, ()) Void)
-- >>> :kind! forall a. Eot (MyMaybe a)
-- forall a. Eot (MyMaybe a) :: *
-- = Either () (Either (a, ()) Void)
--
-- @Maybe a@ and @MyMaybe a@ have the same shape because their Eot representation
-- is the same: two constructors (@Either ... (Either ... Void)@), one of which
-- takes zero arguments (@()@), the other taking one argument of type 'a' (@(a, ())@).
--
-- We can make this more formal by defining a constraint synonym for @(Eot a ~ Eot b)@.
class    (HasEot a, HasEot b, Eot a ~ Eot b) => SameShape a b
instance (HasEot a, HasEot b, Eot a ~ Eot b) => SameShape a b

-- |
-- >>> convert (MyJust "foo") :: Maybe String
-- Just "foo"
convert :: SameShape a b
        => a -> b
convert = fromEot . toEot

-- |
-- >>> convertBack (Just "foo") :: MyMaybe String
-- MyJust "foo"
convertBack :: SameShape a b
            => b -> a
convertBack = fromEot . toEot


-- In order to make use of the DerivingVia mechanism, we have to define a
-- newtype and instances for that newtype such that when this newtype is wrapped
-- around 'MyMaybe', its instances behave like the existing instances for
-- 'Maybe'. Thus, let's define a newtype with two type parameters, one for the
-- type its is wrapping (in our case 'MyMaybe') and one for the type we want to
-- delegate to (in our case 'Maybe').
newtype ViaEot a b = ViaEot
  { unViaEot :: a }

-- Finally, we need to write instances for @ViaEot a b@ which delegate to the
-- existing instances for 'b' by converting the wrapped 'a' to a 'b', applying
-- the method, and converting the result back to an 'a' (if applicable).

instance (SameShape a b, Eq b) => Eq (ViaEot a b) where
  ViaEot a1 == ViaEot a2 = b1 == b2
    where
      b1, b2 :: b
      b1 = convert a1
      b2 = convert a2

instance (SameShape a b, Semigroup b) => Semigroup (ViaEot a b) where
  ViaEot a1 <> ViaEot a2 = ViaEot $ convertBack (b1 <> b2)
    where
      b1, b2 :: b
      b1 = convert a1
      b2 = convert a2

instance (SameShape a b, Monoid b) => Monoid (ViaEot a b) where
  mempty = ViaEot $ convertBack b
    where
      b :: b
      b = mempty



main :: IO ()
main = doctest ["src/Main.hs"]