Implement cursh by Foldable.

Crush.hs

module Crush(
  AST(..)
, crush
, crushMap
, crushMapM

  -- debugging
, buildAst
, printAst
) where

import qualified Data.Tree as DTree
import Data.Tree.Pretty

data AST a = Pair (AST a) (AST a) | Singleton a | Empty

-- This is trick part: (Pair, Empty) are not real Monoid!
instance Semigroup (AST a)  where
  (<>) = Pair

instance Monoid (AST a)  where
  mempty = Empty

buildAst :: Foldable t => t a -> AST a
buildAst = foldMap Singleton

-- <<⊕, v⊕>> = ⊕/, where the ⊕ is binary operator with some neutral element v⊕.
-- Note that the ⊕ can be a monoid, but it is not required to be a monoid
-- If t is non-empty strucuture, then v will not be used.
crush :: Foldable t => (a -> a -> a) -> a -> t a -> a
crush oplus v = crushMap oplus v id

-- <<⊕, v⊕, f>> = ⊕/ . f*, where the ⊕ is binary operator with some neutral element v⊕.
-- Note that the ⊕ can be a monoid, but it is not required to be a monoid
-- If t is non-empty strucuture, then v will not be used.
crushMap :: Foldable t => (b -> b -> b) -> b -> (a -> b) -> t a -> b
crushMap oplus v f = crushAST . buildAst
  where crushAST (Pair x y) = crushAST x `oplus` crushAST y
        crushAST (Singleton x) = f x
        crushAST Empty = v

-- <<⊕, f>> = ⊕/ . f*, where the ⊕ is binary operator but without neutral element, e.g. min/max operator on Int.
-- In this case:
-- If t is emptiable strucuture, then it will be dealt with in classic BMF by introducing so-called “fictitious values”, extend b's domain by Maybe b
-- If t is non-empty strucuture, we still use Maybe to deal with it.
-- Note that the ⊕ is not required to be associative as well, because there are some interesting application.
crushMapM :: Foldable t => (b -> b -> b) -> (a -> b) -> t a -> Maybe b
crushMapM oplus f = crushMap (oplusM oplus) Nothing (Just . f)

oplusM :: (b -> b -> b) -> (Maybe b -> Maybe b -> Maybe b)
oplusM oplus (Just u) (Just v) = Just (u `oplus` v)
oplusM oplus (Just u) Nothing = Just (u)
oplusM oplus Nothing (Just v)  = Just (v)
oplusM oplus Nothing Nothing  = Nothing

-- For debugging AST
data Label a = LPair | LSingleton a | LEmpty

instance Show a => Show (Label a) where
  show LPair = "Pair"
  show (LSingleton a) = show a
  show LEmpty = "Empty"

astToDTree :: AST a -> DTree.Tree (Label a)
astToDTree = DTree.unfoldTree f
  where f (Pair Empty Empty) = (LPair, [Empty, Empty])
        f (Pair Empty r) = (LPair, [Empty, r])
        f (Pair l Empty) = (LPair, [l, Empty])
        f (Pair l r) = (LPair, [l,r])
        f (Singleton x) = (LSingleton x, [])
        f Empty = (LEmpty, [])

safeAstToDTree :: AST a -> Maybe (DTree.Tree (Label a))
safeAstToDTree Empty = Nothing
safeAstToDTree x = Just (astToDTree x)

drawAst :: Show a => AST a -> String
drawAst ast = case safeAstToDTree ast of
  Nothing -> "empty"
  Just x -> drawVerticalTree $ fmap show x

printAst :: Show a => AST a -> IO ()
printAst = putStrLn . drawAst

Related tweets
https://twitter.com/chansey97/status/1265307084855230465