Add Pointed instances to types from kan-extensions

pointed.cabal

@@ -70,7 +70,8 @@ flag unordered-containers
 
 library
   build-depends: base >= 4.5 && < 5,
-                 data-default-class >= 0.0.1 && < 0.2
+                 data-default-class >= 0.0.1 && < 0.2,
+                 contravariant == 1.*
 
   if impl(ghc >= 7.0 && < 7.2)
     build-depends: generic-deriving >= 1.11 && < 1.13

src/Data/Copointed.hs

@@ -15,6 +15,7 @@ import Data.Default.Class
 import Control.Comonad.Trans.Env
 import Control.Comonad.Trans.Store
 import Control.Comonad.Trans.Traced
+import Control.Comonad
 
 #if !(MIN_VERSION_comonad(4,3,0))
 import Data.Functor.Coproduct
@@ -29,6 +30,13 @@ import Data.Tree
 import Data.Functor.Bind
 #endif
 
+#ifdef MIN_VERSION_kan_extensions
+import Control.Comonad.Density
+import Data.Functor.Coyoneda
+import Data.Functor.Day
+import Data.Functor.Yoneda
+import qualified Data.Functor.Invariant.Day as ID
+#endif
 
 #if defined(MIN_VERSION_semigroups) || (MIN_VERSION_base(4,9,0))
 import Data.Semigroup as Semigroup
@@ -128,6 +136,23 @@ instance (Copointed f, Copointed g) => Copointed (F.Sum f g) where
   copoint (F.InR m) = copoint m
 #endif
 
+#ifdef MIN_VERSION_kan_extensions
+instance Copointed (Density f) where
+  copoint = extract
+
+instance Copointed f => Copointed (Coyoneda f) where
+  copoint (Coyoneda f x) = f (copoint x)
+
+instance (Copointed f, Copointed g) => Copointed (Day f g) where
+  copoint (Day x y f) = f (copoint x) (copoint y)
+
+instance (Copointed f, Copointed g) => Copointed (ID.Day f g) where
+  copoint (ID.Day x y f _) = f (copoint x) (copoint y)
+
+instance Copointed f => Copointed (Yoneda f) where
+  copoint = copoint . ($ id) . runYoneda
+#endif
+
 #ifdef MIN_VERSION_transformers
 instance Copointed f => Copointed (Backwards f) where
   copoint = copoint . forwards

src/Data/Pointed.hs

@@ -13,6 +13,7 @@ import Control.Arrow
 import Control.Applicative
 import qualified Data.Monoid as Monoid
 import Data.Default.Class
+import Data.Functor.Contravariant
 
 #ifdef MIN_VERSION_comonad
 import Control.Comonad
@@ -29,7 +30,17 @@ import Data.Tree (Tree(..))
 #endif
 
 #ifdef MIN_VERSION_kan_extensions
+import Control.Comonad.Density
+import Control.Monad.Codensity
+import Data.Functor.Coyoneda
+import Data.Functor.Day
 import Data.Functor.Day.Curried
+import Data.Functor.Kan.Lan
+import Data.Functor.Yoneda
+import qualified Data.Functor.Contravariant.Coyoneda as Contra
+import qualified Data.Functor.Contravariant.Day as Contra
+import qualified Data.Functor.Contravariant.Yoneda as Contra
+import qualified Data.Functor.Invariant.Day as ID
 #endif
 
 #if defined(MIN_VERSION_semigroups) || (MIN_VERSION_base(4,9,0))
@@ -180,6 +191,46 @@ instance Pointed Set where
 instance (Functor g, g ~ h) => Pointed (Curried g h) where
   point a = Curried (fmap ($a))
   {-# INLINE point #-}
+
+instance (Pointed f, Pointed g) => Pointed (Day f g) where
+  point a = Day (point ()) (point ()) (\_ _ -> a)
+  {-# INLINE point #-}
+
+instance (Pointed f, Pointed g) => Pointed (Contra.Day f g) where
+  point a = Contra.Day (point a) (point a) (\x -> (x, x))
+  {-# INLINE point #-}
+
+instance Pointed f => Pointed (Coyoneda f) where
+  point a = Coyoneda (const a) (point ())
+  {-# INLINE point #-}
+
+instance Pointed f => Pointed (Contra.Coyoneda f) where
+  point a = Contra.Coyoneda id (point a)
+  {-# INLINE point #-}
+
+instance (Pointed f, Functor f) => Pointed (Yoneda f) where
+  point a = Yoneda $ \f -> f <$> point a
+  {-# INLINE point #-}
+
+instance (Pointed f, Contravariant f) => Pointed (Contra.Yoneda f) where
+  point a = Contra.Yoneda $ \f -> contramap f (point a)
+  {-# INLINE point #-}
+
+instance Pointed f => Pointed (Density f) where
+  point a = Density (const a) (point ())
+  {-# INLINE point #-}
+
+instance Pointed (Codensity f) where
+  point = pure
+  {-# INLINE point #-}
+
+instance (Pointed f, Pointed g) => Pointed (ID.Day f g) where
+  point a = ID.Day (point ()) (point ()) (\_ _ -> a) (const ((),()))
+  {-# INLINE point #-}
+
+instance (Functor g, Pointed h) => Pointed (Lan g h) where
+  point a = Lan (const a) (point ())
+  {-# INLINE point #-}
 #endif
 
 #ifdef MIN_VERSION_semigroupoids