Override data types in instance

overload.hs

-- This is an approach to refine ability to selectively override
-- instances when deriving using deriving via method. Idea was first
-- presented here:
--
-- http://caryrobbins.com/dev/overriding-type-class-instances/
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
import Data.Coerce
import Data.Proxy
import Data.Type.Equality
import           Data.Text   (Text)
import qualified Data.Text as T
import GHC.Generics

----------------------------------------------------------------
-- Simple type class
----------------------------------------------------------------

class Encode a where
  encode :: a -> Text

----------------------------------------------------------------
-- Deriving strategies
----------------------------------------------------------------

-- Encode using Show instance of type
newtype ShowEncode a = ShowEncode a

instance Show a => Encode (ShowEncode a) where
  encode (ShowEncode a) = T.pack (show a)

deriving via ShowEncode Int   instance Encode Int
deriving via ShowEncode Float instance Encode Float
deriving via ShowEncode Text  instance Encode Text


-- Encode using ALLCAPS
newtype Uptext a = Uptext a

instance Encode a where
  encode (Uptext a) = T.toUpper $ encode a


-- Affirms that value is number but doesn't care whether it's number or not.
newtype ReallyNumber a = ReallyNumber a

instance Encode a => Encode (ReallyNumber a) where
  encode (ReallyNumber t) = "NUMBER:" <> encode t

  
----------------------------------------------------------------
-- Generic encoder
----------------------------------------------------------------

-- We follow customary practice of defining separate type class for
-- working with generics. It's quite convenient since here we work
-- with * -> * kinded values
--
-- `xs' type parameter is for passing list of overrides.
class GEncode (xs :: [*]) f where
  gencode :: Proxy xs -> f p -> Text

instance (GEncode xs f) => GEncode xs (M1 D x f) where
  gencode p (M1 x) = gencode p x

instance (GEncode xs f) => GEncode xs (M1 C x f) where
  gencode p (M1 x) = gencode p x

instance (GEncode xs f, Selector s) => GEncode xs (M1 S s f) where
  gencode p m@(M1 x) = T.pack (selName m) <> " = " <> gencode p x

instance (GEncode xs f, GEncode xs g) => GEncode xs (f :*: g) where
  gencode p (f :*: g) = gencode p f <> ", " <> gencode p g

-- Other instances are mostly plumbing but this one is where we select
-- instance for type.
--
-- `b ~ Using a xs' is data type which will be used for selecting
-- instance. If there's no override it defaults to a
instance ( b ~ Using a xs
         , Encode b
         , Coercible a b
         ) => GEncode xs (K1 R a) where
  gencode _ (K1 x) = encode (coerce x :: b)


-- Select data type which should be used for defining instance for x.
type family Using x xs where
  Using x '[] = x
  Using x (As a b ': xs) = IF (x == a) b (Using x xs)

-- Type level IF
type family IF f a b where
  IF 'True  a b = a
  IF 'False a b = b

-- Use b to provide instance for data type a
data As a b


-- Use plain generic deriving for data type
newtype GenericEncode a = GenericEncode a

instance (Generic a, GEncode '[] (Rep a)) => Encode (GenericEncode a) where
  encode (GenericEncode a) = gencode (Proxy @ '[]) (from a)


-- Use generics + list of overrides for deriving instance
newtype GenericEncodeWith (xs :: [*]) a = GenericEncodeWith a

instance (Generic a, GEncode xs (Rep a)) => Encode (GenericEncodeWith xs a) where
  encode (GenericEncodeWith a) = gencode (Proxy @xs) (from a)



----------------------------------------------------------------
--
----------------------------------------------------------------


  
data Rec = Rec
  { foo :: Int
  , bar :: Text
  , baz :: Text
  }
  deriving stock (Show, Eq, Generic)
  deriving Encode via (GenericEncodeWith '[ Text `As` Uptext
                                          , Int  `As` ReallyNumber Int
                                          ] Rec)

go = putStrLn $ T.unpack $ encode $ Rec 1 "asd" "dfg"