Implement cursh by Traversable.

Crush.hs

{-# LANGUAGE DeriveFunctor #-}
module Crush(
  AST(..)
, crush
, crushMap
, crushMapM

  -- debugging
, buildAst
, printAst
) where

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

class UnitalMagma u where
  uneu :: u
  uoplus :: u -> u -> u

newtype Accy u a = Acc {acc :: u}
  deriving Functor

instance UnitalMagma u => Applicative (Accy u) where
  pure _ = Acc uneu
  Acc c1 <*> Acc c2 = Acc (c1 `uoplus` c2)

reduceMap :: (Traversable t, UnitalMagma u) => (a -> u) -> t a -> u
reduceMap f = acc . traverse (Acc . f)

reduce :: (Traversable t, UnitalMagma u) => t u -> u
reduce = crushMap id

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

-- This is trick part: (Pair, Nil) are not real Monoid!
instance UnitalMagma (AST a)  where
  uneu = Empty
  uoplus = Pair

buildAst :: Traversable t => t a -> AST a
buildAst = reduceMap 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 :: Traversable 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 :: Traversable 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
-- Sometimes ⊕ has no neutral element, e.g 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, then actually we can not use Maybe, nevertheless, we still use Maybet o deal with it.
-- Note that the ⊕ is not required to be associative as well, because there are some interesting application.
crushMapM :: Traversable 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/1276819182907056128