"guarded instances" (GHC #5590) example

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
{-# LANGUAGE TypeFamilies, PolyKinds, DataKinds, MultiParamTypeClasses,                                                                                                                           
  FlexibleInstances, ScopedTypeVariables, UndecidableInstances, TypeOperators                                                                                                                     
 #-}

module GuardedInstancesExample where

data PROXY a = PROXY
class Contra f where
  contramap :: (a -> b) -> f b -> f a

newtype (:.:) f (g :: * -> *) a = Comp {unComp :: f (g a)}


data V = CoV | ContraV
type family Variance (a :: kD -> kR) :: V -- drop the kind pattern for GHC < 7.5                                                                                                                  
type instance Variance Maybe = CoV
type instance Variance [] = CoV
type instance Variance (->) = ContraV
type instance Variance ((->) a) = CoV

class Functor_V f (v :: V) where
  fmap_V :: PROXY v -> (a -> b) -> f a -> f b

instance (Functor f, Functor g) => Functor_V (f :.: g) CoV where
  fmap_V _ f = Comp . fmap (fmap f) . unComp

instance (Contra f, Contra g) => Functor_V (f :.: g) ContraV where
  fmap_V _ f = Comp . contramap (contramap f) . unComp


instance (v ~ Variance f, Functor_V (f :.: g) v) => Functor (f :.: g) where
  fmap = fmap_V (PROXY :: PROXY v)


newtype IntSink a = IntSink (a -> Int)
type instance Variance IntSink = ContraV
instance Contra IntSink where
  contramap f (IntSink x) = IntSink $ x . f


ex :: (IntSink :.: IntSink) String
ex = Comp $ IntSink $ \(IntSink sink) -> sink "payload"

test :: (IntSink :.: IntSink) Int
test = fmap length ex