AutoDerive.hs

{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE QuantifiedConstraints      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

module Data.Functor.Classes.AutoDerive
  ( DerivingShow1 (..)
  , DerivingShow2 (..)

  , ReprConstraint (..)
  , ReprDict (..)
  , DictReceiver (..)
  , innerDictReceiveCoerce

  , Bicontravariant (..)
  , Joker (..)
  ) where

import           Data.Bifunctor
import           Data.Coerce
import           Data.Constraint
import           Data.Functor.Classes
import           Data.Reflection
import           Unsafe.Coerce


class ReprConstraint c where
  data ReprDict c

  default fromReprDict :: (Given (ReprDict c) => c) => ReprDict c -> Dict c
  fromReprDict = reifyGift (Gift Dict)

  fromReprDict :: ReprDict c -> Dict c


newtype DictReceiver a = DictReceiver a

type ReceiveReprDict c a = ReprDict (c (DictReceiver a))

innerDictReceiveCoerce ::
  ( Bicontravariant f
  , Coercible (f (DictReceiver a) (DictReceiver b)) fdab, Coercible (f a b) fab
  ) => (fdab -> f (DictReceiver a) (DictReceiver b)) -> (f a b -> fab) -> fdab -> fab
innerDictReceiveCoerce = innerBicontramapCoerce
{-# INLINE innerDictReceiveCoerce #-}


instance ReprConstraint (Eq (DictReceiver a)) where
  newtype ReprDict (Eq (DictReceiver a)) = EqDict
    { eqDict_equal :: a -> a -> Bool
    }

instance Given (ReceiveReprDict Eq a) => Eq (DictReceiver a) where
  (==) = coerce $ eqDict_equal (given @(ReceiveReprDict Eq a))


instance ReprConstraint (Show (DictReceiver a)) where
  data ReprDict (Show (DictReceiver a)) = ShowDict
    { showDict_showsPrec :: Int -> a -> ShowS
    , showDict_showList :: [a] -> ShowS
    }

instance Given (ReceiveReprDict Show a) => Show (DictReceiver a) where
  showsPrec = coerce $ showDict_showsPrec (given @(ReceiveReprDict Show a))
  showList = coerce $ showDict_showList (given @(ReceiveReprDict Show a))


newtype BiliftedMethod_showsPrec f a b = BiliftedMethod_showsPrec
  { getBiliftedMethod_showsPrec :: Int -> f a b -> ShowS
  }

liftedMethod_showsPrec :: (Int -> f a -> ShowS) -> BiliftedMethod_showsPrec (Joker f) b a
liftedMethod_showsPrec = coerce

getLiftedMethod_showsPrec :: BiliftedMethod_showsPrec (Joker f) b a -> (Int -> f a -> ShowS)
getLiftedMethod_showsPrec = coerce

instance Bifunctor f => Bicontravariant (BiliftedMethod_showsPrec f) where
  bicontramap f g (BiliftedMethod_showsPrec m) = BiliftedMethod_showsPrec \p -> m p . bimap f g

newtype BiliftedMethod_showList f a b = BiliftedMethod_showList
  { getBiliftedMethod_showList :: [f a b] -> ShowS
  }

liftedMethod_showList :: ([f a] -> ShowS) -> BiliftedMethod_showList (Joker f) b a
liftedMethod_showList = coerce

getLiftedMethod_showList :: BiliftedMethod_showList (Joker f) b a -> ([f a] -> ShowS)
getLiftedMethod_showList = coerce

instance Bifunctor f => Bicontravariant (BiliftedMethod_showList f) where
  bicontramap f g (BiliftedMethod_showList m) = BiliftedMethod_showList $ m . fmap (bimap f g)


-- | An instance template of @Show1@ for @DerivingVia@
--
-- Example:
--
-- >>> :set -XDerivingVia -XDeriveFunctor -XStandaloneDeriving
-- >>> import Data.Functor.Classes
-- >>> data F a = F a deriving (Show, Functor)
-- >>> deriving via (DerivingShow1 F) instance Show1 F
-- >>> showsPrec1 0 (F (F True)) ""
-- "F (F True)"
-- >>> showsPrec 0 (F (F True)) ""
-- "F (F True)"
--
newtype DerivingShow1 f a = DerivingShow1 (f a)
  deriving Functor

instance Show (f a) => Show (DerivingShow1 f a) where
  showsPrec = coerce $ showsPrec @(f a)
  showList = coerce $ showList @(f a)
  show = coerce $ show @(f a)

instance (Functor f, forall x. Show x => Show (f x)) => Show1 (DerivingShow1 f) where
  liftShowsPrec _showsPrec _showList =
    case fromReprDict $ ShowDict _showsPrec _showList of
      Dict -> innerDictReceiveCoerce liftedMethod_showsPrec getLiftedMethod_showsPrec showsPrec
  liftShowList _showsPrec _showList =
    case fromReprDict $ ShowDict _showsPrec _showList of
      Dict -> innerDictReceiveCoerce liftedMethod_showList getLiftedMethod_showList showList


-- | An instance template of @Show2@ for @DerivingVia@
--
-- Example:
--
-- >>> :set -XDerivingVia -XDeriveFunctor -XStandaloneDeriving
-- >>> import Data.Functor.Classes
-- >>> import Data.Bifunctor
-- >>> data F a b = F a b deriving (Show, Functor)
-- >>> instance Bifunctor F where bimap f g (F x y) = F (f x) (g y)
-- >>> deriving via (DerivingShow2 F) instance Show2 F
-- >>> deriving via (DerivingShow2 F a) instance Show a => Show1 (F a)
-- >>> showsPrec2 0 (F (F True 'c') "str") ""
-- "F (F True 'c') \"str\""
-- >>> showsPrec1 0 (F (F True 'c') "str") ""
-- "F (F True 'c') \"str\""
-- >>> showsPrec 0 (F (F True 'c') "str") ""
-- "F (F True 'c') \"str\""
--
newtype DerivingShow2 f a b = DerivingShow2 (f a b)
  deriving (Functor, Bifunctor)

instance Show (f a b) => Show (DerivingShow2 f a b) where
  showsPrec = coerce $ showsPrec @(f a b)
  showList = coerce $ showList @(f a b)
  show = coerce $ show @(f a b)

instance (Bifunctor f, Show a, forall x y. (Show x, Show y) => Show (f x y)) => Show1 (DerivingShow2 f a) where
  liftShowsPrec = liftShowsPrec2 showsPrec showList
  liftShowList = liftShowList2 showsPrec showList

instance (Bifunctor f, forall x y. (Show x, Show y) => Show (f x y)) => Show2 (DerivingShow2 f) where
  liftShowsPrec2 _showsPrecX _showListX _showsPrecY _showListY =
    case (fromReprDict $ ShowDict _showsPrecX _showListX, fromReprDict $ ShowDict _showsPrecY _showListY) of
      (Dict, Dict) -> innerDictReceiveCoerce BiliftedMethod_showsPrec getBiliftedMethod_showsPrec showsPrec
  liftShowList2 _showsPrecX _showListX _showsPrecY _showListY =
    case (fromReprDict $ ShowDict _showsPrecX _showListX, fromReprDict $ ShowDict _showsPrecY _showListY) of
      (Dict, Dict) -> innerDictReceiveCoerce BiliftedMethod_showList getBiliftedMethod_showList showList


-- utilities

newtype Gift a r = Gift (Given a => r)

reifyGift :: Gift a r -> a -> r
reifyGift (Gift f) x = give x f
{-# INLINE reifyGift #-}

class Bicontravariant f where
  bicontramap :: (a -> b) -> (c -> d) -> f b d -> f a c

bicontramapCoerce :: (Bicontravariant f, Coercible a b, Coercible c d) => f b d -> f a c
bicontramapCoerce = unsafeCoerce
{-# INLINE bicontramapCoerce #-}

innerBicontramapCoerce :: forall f a b c d fac fbd.
  ( Bicontravariant f
  , Coercible (f a c) fac, Coercible (f b d) fbd
  , Coercible a b, Coercible c d
  ) => (fac -> f a c) -> (f b d -> fbd) -> fac -> fbd
innerBicontramapCoerce _ _ = coerce $ bicontramapCoerce @f @b @a @d @c
{-# INLINE innerBicontramapCoerce #-}

newtype Joker f a b = Joker (f b)

instance Functor f => Bifunctor (Joker f) where
  bimap _ lf = coerce $ fmap @f lf