FreeForget.hs

{-# language DeriveFunctor #-}
{-# language TypeFamilies #-}
{-# language MultiParamTypeClasses #-}
{-# language FlexibleInstances #-}

module FreeForget where

import Data.Distributive
import Data.Functor.Rep
import Data.Functor.Adjunction
import Data.Char

newtype Forget a = Forget { getForget :: a } deriving (Show, Eq, Functor)
data TaggedF t a = Tagged
  { getTag :: t
  , untag :: a
  } deriving (Show, Eq, Functor)
type Tagged = TaggedF (Maybe String)

instance Distributive Tagged where
  distribute fa = Tagged mempty (untag <$> fa)

instance Distributive Forget where
  distribute fa = Forget (getForget <$> fa)

instance Representable Tagged where
  type Rep Tagged = ()
  index (Tagged _ a) () = a
  tabulate describe = Tagged mempty (describe ())

instance Representable Forget where
  type Rep Forget = ()
  index (Forget a) () = a
  tabulate describe = Forget (describe ())

instance Adjunction Forget Tagged where
  unit a = Tagged Nothing (Forget a)
  counit (Forget (Tagged _ a)) = a
  -- leftAdjunct :: (Forget a -> b) -> a -> Tagged b
  -- rightAdjunct :: (a -> Tagged b) -> Forget a -> b

instance Adjunction Tagged Forget where
  unit a = Forget (Tagged Nothing a)
  counit (Tagged _ (Forget a)) = a
  -- leftAdjunct :: (Tagged a -> b) -> a -> Forget b
  -- rightAdjunct :: (a -> Forget b) -> Tagged a -> b

overUntagged :: (Tagged a -> b) -> a -> b
overUntagged f = getForget . leftAdjunct f 

overTagged :: (a -> b) -> Tagged a -> b
overTagged f = rightAdjunct (Forget <$> f)

applyTag :: Tagged String -> String
applyTag (Tagged Nothing s) = s
applyTag (Tagged (Just tag) s) = tag ++ ": " ++ s

-- We can now call applyTag over Either of Tagged or untagged strings:
resA, resB :: String
resA = overUntagged applyTag "Testing"
-- resA == "Testing"
resB = applyTag (Tagged (Just "MyTag") "Testing")
-- resB == "MyTag: Testing"

upperCase :: String -> String
upperCase = fmap toUpper

-- We can also lift regular string functions up to run on tags (but they forget the tags):
resC, resD :: String
resC = overTagged upperCase (Tagged (Just "MyTag") "Testing")
-- resC == "TESTING"
resD = upperCase "Testing"
-- resD == "TESTING"