tcHomom.hs

-- stack resolver: lts-8.21

-- https://ghc.haskell.org/trac/ghc/ticket/3205

{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FlexibleInstances, LambdaCase, ViewPatterns, FlexibleContexts #-}

import Control.Monad
import Data.Semigroup hiding (Product)
import Data.Monoid hiding (Product, (<>))
import Data.Functor.Identity
import Data.Functor.Product
import Data.Foldable

data Iso a b = Iso
  { l_ :: (a -> b)
  , r_ :: (b -> a) }

data Iso1 f g = Iso1
  { l :: (forall a . f a -> g a)
  , r :: (forall a . g a -> f a) }

class Isom a b where
  iso :: Iso a b

class Isom1 f g where
  iso1 :: Iso1 f g
-- TODO add composition, dual etc
-- TODO polykinded version of IsoN?

-- TODO All of these derivable via safe coerce...
instance Isom Bool Any where
  iso = Iso Any getAny
instance Isom Bool All where
  iso = Iso All getAll
instance Isom a (Identity a) where
  iso = Iso Identity runIdentity
instance Isom a a where
  iso = Iso id id
instance Isom1 a a where
  iso1 = Iso1 id id

fmapI :: Functor f => Iso1 f g -> (a -> b) -> g a -> g b
fmapI i f x = l i $ f <$> (r i x)

pureI :: Applicative f => Iso1 f g -> a -> g a
pureI i = l i . pure

apI :: Applicative f => Iso1 f g -> g (a -> b) -> g a -> g b
apI i f x = l i $ (r i f) <*> (r i x)

bindI :: Monad f => Iso1 f g -> g a -> (a -> g b) -> g b
bindI i k f = l i $ (r i $ k) >>= (r i . f)

sappendI :: Semigroup a => Iso a b -> b -> b -> b
sappendI i x y = l_ i $ r_ i x <> r_ i y

sappendI1 :: Semigroup (f a) => Iso1 f g -> g a -> g a -> g a
sappendI1 i x y = l i $ r i x <> r i y

mappendI1 :: Monoid (f a) => Iso1 f g -> g a -> g a -> g a
mappendI1 i x y = l i $ r i x `mappend` r i y

memptyI1 :: Monoid (f a) => Iso1 f g -> g a
memptyI1 i = l i $ mempty

foldMapI :: (Foldable f, Monoid m) => Iso1 f g -> (a -> m) -> g a -> m
foldMapI i f x = foldMap f $ r i x

instance Monoid a => Foldable ((->) a) where
  foldMap f x = f (x mempty)




data P a = P (a, a) deriving Show

instance Isom Bool a => Isom1 ((->) a) P where
  iso1 = Iso1 (\f -> P (f $ l_ iso False, f $ l_ iso True)) (\(P (a, b)) -> \case { (r_ iso -> False) -> a ; (r_ iso -> True) -> b })

instance (Isom1 Identity f, Isom1 Identity g) => Isom1 (Product f g) P where
  iso1 = Iso1 (\(Pair (r iso1 -> Identity x) (r iso1 -> Identity y)) -> P (x, y)) (\(P (x, y)) -> Pair (l iso1 $ Identity x) (l iso1 $ Identity y))

-- deriving Functor P via (Product Identity Identity)
-- deriving Monad P via (Product Identity Identity)
-- deriving Monad P via (Product Identity Identity)
-- deriving Foldable P via ((->) Any)

instance Functor P where
  fmap = fmapI (iso1 :: Iso1 (Product Identity Identity) P)

instance Applicative P where
  pure = pureI (iso1 :: Iso1 (Product Identity Identity) P)
  (<*>) = apI (iso1 :: Iso1 (Product Identity Identity) P)

instance Monad P where
  (>>=)  = bindI (iso1 :: Iso1 (Product Identity Identity) P)

instance Foldable P where
  foldMap = foldMapI (iso1 :: Iso1 ((->) Any) P)