Combining folds using semigroups - Haskell

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}

module Semi where

import Control.Arrow
import Data.Fix

data ExprF a
  = ConstantF Int
  | AddF a a
  deriving Functor

type Expr = Fix ExprF

constant :: Int -> Expr
constant x = Fix (ConstantF x)

add :: Expr -> Expr -> Expr
add left right = Fix (AddF left right)

expr :: Expr
expr = constant 1 `add` constant 2 `add` constant 3

function1, function2 :: ExprF (IO ()) -> IO ()
function1 = function "function1:"
function2 = function "function2:"

function :: String -> ExprF (IO ()) -> IO ()
function prefix = \case
  ConstantF x ->
    putStrLn $ unwords [prefix, "Constant", show x]
  AddF action1 action2 -> do
    action1
    putStrLn $ unwords [prefix, "Add"]
    action2

compose :: (Applicative f, Semigroup b) => (a -> f b) -> (a -> f b) -> a -> f b
compose f g a = (<>) <$> f a <*> g a

example1 :: IO ()
example1 = do
  putStrLn "Running function1:"
  foldFix function1 expr
  putStrLn "Running function2:"
  foldFix function2 expr

alg :: ExprF (IO (), IO ()) -> (IO (), IO ())
alg = (function1 . fmap fst) &&& (function2 . fmap snd)

example2 :: IO ()
example2 = do
  let (action1, action2) = foldFix alg expr
  action1
  putStrLn "action1 finished, now action2:"
  action2

example3 :: IO ()
example3 = foldFix alg expr
  where
  alg :: ExprF (IO ()) -> IO ()
  alg = function1 <> function2