Deriving `From` instances using `Generically`. https://github.com/tfausak/witch/issues/107

Witch.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Witch where

import qualified Data.Tuple as T
import qualified Data.Void as V
import qualified GHC.Generics as G

-- basic interface

class From source target where
  from :: source -> target

instance From a a where
  from = id

instance From Int Integer where
  from = toInteger

-- no constructors

data Empty deriving (G.Generic)

deriving via G.Generically V.Void instance From Empty V.Void

deriving via G.Generically Empty instance From V.Void Empty

-- one constructor

data Unit = MkUnit deriving (Eq, G.Generic, Show)

deriving via G.Generically () instance From Unit ()

deriving via G.Generically Unit instance From () Unit

-- two constructors

data Toggle = Off | On deriving (Eq, G.Generic, Show)

deriving via G.Generically Bool instance From Toggle Bool

deriving via G.Generically Toggle instance From Bool Toggle

-- one argument

newtype Only a = MkOnly a deriving (Eq, G.Generic, Show)

deriving via G.Generically (T.Solo b) instance (From a b) => From (Only a) (T.Solo b)

deriving via G.Generically (Only b) instance (From a b) => From (T.Solo a) (Only b)

-- two arguments

data Pair a b = MkPair a b deriving (Eq, G.Generic, Show)

deriving via G.Generically (c, d) instance (From a c, From b d) => From (Pair a b) (c, d)

deriving via G.Generically (Pair c d) instance (From a c, From b d) => From (a, b) (Pair c d)

-- two constructors with arguments

data Result e o = Err e | Ok o deriving (Eq, G.Generic, Show)

deriving via G.Generically (Either l r) instance (From e l, From o r) => From (Result e o) (Either l r)

deriving via G.Generically (Result e o) instance (From l e, From r o) => From (Either l r) (Result e o)

-- instance for Generically

instance
  ( G.Generic s,
    G.Generic t,
    GFrom (G.Rep s) (G.Rep t)
  ) =>
  From s (G.Generically t)
  where
  from = G.Generically . G.to . gFrom . G.from

-- GFrom class

class GFrom s t where
  gFrom :: s x -> t x

instance GFrom G.V1 G.V1 where
  gFrom = id

instance GFrom G.U1 G.U1 where
  gFrom = id

instance (From s t) => GFrom (G.K1 i s) (G.K1 j t) where
  gFrom = G.K1 . from . G.unK1

instance (GFrom s t) => GFrom (G.M1 i c s) (G.M1 j d t) where
  gFrom = G.M1 . gFrom . G.unM1

instance (GFrom sl tl, GFrom sr tr) => GFrom (sl G.:+: sr) (tl G.:+: tr) where
  gFrom x = case x of
    G.L1 l -> G.L1 $ gFrom l
    G.R1 r -> G.R1 $ gFrom r

instance (GFrom sl tl, GFrom sr tr) => GFrom (sl G.:*: sr) (tl G.:*: tr) where
  gFrom (l G.:*: r) = gFrom l G.:*: gFrom r