Functor over type functions

Singletons.hs

{-# Language StandaloneDeriving, PatternSynonyms, GADTs, UndecidableInstances, ScopedTypeVariables, TemplateHaskell, TypeInType, TypeOperators, TypeFamilies, AllowAmbiguousTypes, InstanceSigs, TypeApplications #-}

import Data.Singletons
import Data.Singletons.Prelude.Base
import Data.Singletons.TH
import Data.Kind
import Control.Arrow ((***))

data Dup :: Type ~> Type

type instance Dup `Apply` a = (a, a)

-- A functor class that subsumes Prelude.Functor
class Functor' (f::Type ~> Type) where  
  fmap' :: (a -> a') -> (f@@a -> f@@a')

instance Functor' IdSym0 where  
  fmap' :: (a -> a') -> (a -> a')
  fmap' = id

instance Functor' Dup where
  fmap' :: (a -> a') -> ((a, a) -> (a', a'))
  fmap' f = f *** f

instance (Functor' f, Functor' g) => Functor' (f :.$$$ g) where
  fmap' :: (a -> a') -> (f@@(g@@a) -> f@@(g@@a'))
  fmap' = fmap' @f . fmap' @g

newtype Applied f a = Applied (f @@ a)

deriving instance Show (f@@a) => Show (Applied f a)

instance Functor' f => Functor (Applied f) where
  fmap :: (a -> a') -> (Applied f a -> Applied f a')
  fmap f (Applied fa) = Applied (fmap' @f f fa)
  
instance Functor f => Functor' (TyCon1 f) where
  fmap :: (a -> a') -> (f a -> f a')
  fmap = fmap'

type Duped       = Applied Dup
type Identity    = Applied IdSym0
type Compose f g = Applied (TyCon1 f :.$$$ TyCon1 g)

----------------------------------------------------------------------
-- The ‘Data.Functor.*’ wrappers are special cases of these.
pattern Dup :: a -> a -> Duped a
pattern Dup a b = Applied (a, b)

pattern Identity :: a -> Identity a 
pattern Identity a = Applied a

pattern Compose :: f (g a) -> Compose f g a
pattern Compose a = Applied a

-- >>> succ <$> Identity 'a'
-- Applied 'b'

-- >>> succ <$> Dup 'a' 'b'
-- Applid ('b', 'c')