addPoint product-profunctors

addPoint.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

import Control.Applicative
import Data.Profunctor
import Data.Profunctor.Product
import Data.Profunctor.Product.Default
import Data.Profunctor.Product.Examples
import Data.Profunctor.Product.TH

data Point a = Point
  { x :: a,
    y :: a
  }
  deriving (Functor)

$(makeAdaptorAndInstanceInferrable' ''Point)

newtype App p q a b = App {runAppExplicit :: (p -> p -> q) -> a -> a -> b}
  deriving (Functor)

newtype Stop a = Stop {unStop :: a}

instance Default (App p q) (Stop p) (Stop q) where
  def = App (\f (Stop a1) (Stop a2) -> Stop (f a1 a2))

runApp :: (Default (App p q) a b) => (p -> p -> q) -> a -> a -> b
runApp = runAppExplicit def

-- boilerplate (this should also be derived by Generic!)
instance Profunctor (App p q) where
  lmap f (App g) = App (\t a1 a2 -> g t (f a1) (f a2))
  rmap = fmap

-- boilerplate (this should also be derived by Generic!)
instance Applicative (App p q a) where
  pure = App . pure . pure . pure
  App f <*> App x = App (\t a1 a2 -> f t a1 a2 (x t a1 a2))

-- boilerplate (this should also be derived by Generic!)
instance ProductProfunctor (App p q) where
  purePP = pure
  (****) = (<*>)

zipFields :: Point a -> Point a -> (a -> a -> b) -> Point b
zipFields a b f = fmap unStop $ runApp f (fmap Stop a) (fmap Stop b)

addPoint :: (Num a) => Point a -> Point a -> Point a
addPoint a b = zipFields a b (+)