Free Monoids vs. Foldable and Traversable Functors

FreeConstruction.hs

{-# LANGUAGE ConstraintKinds, DefaultSignatures, FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds, MultiParamTypeClasses                #-}
{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables       #-}
{-# LANGUAGE TypeApplications, UndecidableSuperClasses            #-}
{-# OPTIONS_GHC -Wall #-}
module FreeMonoid where
import           Data.Constraint
import           Data.Constraint.Forall
import           Data.Monoid
import           Data.Proxy
import qualified Data.Sequence          as Seq
import qualified Data.Vector            as V

-- class Monoid m => FreeMonoid m a where
--   iota    :: a -> m
--   liftMap :: Monoid n => (a -> n) -> m -> n
--   -- liftMap Must satisfy
--   --
--   -- prop> liftMap i (m <> n) = liftMap i m <> liftMap i n
--   -- prop> liftMap i mempty = mempty
--   -- prop> liftMap i . iota = i

--   fold :: (a -> b -> b) -> b -> m -> b
--   fold g b m = appEndo (liftMap (Endo . g) m) b

class (Foldable f, Functor f, ForallF cat f) => FreeConstruction cat f where
  iota :: proxy cat -> a -> f a
  liftMap :: cat n => proxy cat -> (a -> n) -> f a -> n

instance FreeConstruction Monoid [] where
  iota _ = return
  liftMap _ inj = foldMap inj

instance FreeConstruction Monoid V.Vector where
  iota _ = return
  liftMap _ = foldMap

instance FreeConstruction Monoid Seq.Seq where
  iota _ = return
  liftMap _ = foldMap

type FreeMonoid = FreeConstruction Monoid

fold :: FreeMonoid f => (a -> b -> b) -> b -> f a -> b
fold g n xs = appEndo (liftMap @Monoid Proxy (Endo . g) xs) n

fromList :: forall f a. FreeMonoid f => [a] -> f a
fromList = liftMap @Monoid Proxy (iota @Monoid Proxy) \\ (instF @Monoid @f @a)

foldMapF :: (FreeMonoid f, Monoid m) => (a -> m) -> f a -> m
foldMapF = liftMap @Monoid Proxy


toList :: FreeConstruction Monoid f => f a -> [a]
toList = liftMap @Monoid Proxy (:[])

-- Trivial, not so interesting...
-- traverseF :: (FreeMonoid t, Applicative f) => (a -> f b) -> t a -> f (t b)
-- traverseF f = fmap fromList . traverse f . toList

traverseF :: forall t f a b. (FreeMonoid t, Applicative f) => (a -> f b) -> t a -> f (t b)
traverseF f = fold (\a tb -> (<>) <$> (iota @Monoid Proxy <$> f a) <*> tb) (pure mempty)
           \\ instF @Monoid @t @b