Monoid operations on the free monoid

monop.hs

import Data.Monoid (Monoid(..))

{-

Summary

If we have a type, 'a', and some monoid defined for 'a', then 'Operation' is an AST representing
computations that could be done by the monoid. 'Operation' can represent something like
  [ 1, 2, 3 ] ++ ( [4, 5, 6] ++ [] )
or
  1 + 5 + (5 + 8 + (2 + 4) + 3 + (zero) + (zero))
The operations consist of:
  - 'Zero', which invokes the identity / zero value of whatever monoid structure is being used,
  - 'Literal', which creates some literal value (like the integers and lists above),
  - `Plus`, which invokes the append / plus operation of the monoid

To evaluate the result of the 'Operation', we go via 2 routes:
  1. Evaluate the AST directly, using the monoid defined for the type ('exec'), or
  2. Convert the AST into a list of instructions without data, evaluate the AST using the
     free monoid, and then "retrospectively apply" the intrinsic monoid to the free monoid
     ('execPure').
In general, the result of 'execPure' should be equal to the result of 'exec'.

-}

--------------------------------------------------------------------------------

-- operations supported by a monoid (containing values)
data Operation a = Zero
                 | Literal a
                 | Plus (Operation a) (Operation a)
                 deriving (Eq, Show)

-- operations supported by a monoid (without values)
data PureOperation = PureZero
                   | PureLiteral
                   | PurePlus PureOperation PureOperation
                   deriving (Eq, Show)
 
-- example operations ('exec opN' should equal 'execPure opN')
op1 :: Operation Int
op1 = Plus (Plus (Literal 2) (Literal 3)) (Plus (Literal 5) Zero)
op2 :: Operation [Int]
op2 = Plus (Literal [1,2,3]) (Plus (Literal [4,5,6]) Zero)
op3 :: Operation [Int]
op3 = Plus (Plus (Literal [1,2,3]) (Literal [4,5,6])) (Plus Zero (Literal [7,8,9]))
      
-- addition monoid for Int
instance Monoid Int where
  mempty      = 0
  mappend x y = x + y

--------------------------------------------------------------------------------
  
-- executes a tree of operations using a monoid type
execf :: Monoid b => (a -> b) -> Operation a -> b
execf _ Zero        = mempty
execf f (Literal x) = f x
execf f (Plus x y)  = mappend (execf f x) (execf f y)

-- executes operations using an intrinsic monoid
exec :: Monoid a => Operation a -> a
exec = execf id

-- executes operations using the list (free) monoid
execFree :: Operation a -> [a]
execFree = execf (:[])

--------------------------------------------------------------------------------

-- executes operations using intrinsic monoid, first converting to a free monoid
execPure :: Monoid a => Operation a -> a
execPure = execPureF id

-- executes a tree of operations using a monoid type, by first converting to a free monoid
execPureF :: Monoid b => (a -> b) -> Operation a -> b
execPureF f op = fst $ execPureOpsWithFreeF f (opToPure op) (execFree op)

-- converts a tree of operations to a tree without any values
opToPure :: Operation a -> PureOperation
opToPure Zero           = PureZero
opToPure (Literal _)    = PureLiteral
opToPure (Plus opx opy) = PurePlus (opToPure opx) (opToPure opy)

-- executes a tree of operations using the result from a free monoid
execPureOpsWithFreeF :: Monoid b => (a -> b) -> PureOperation -> [a] -> (b, [a])
execPureOpsWithFreeF f PureZero               xs = (mempty, xs)
execPureOpsWithFreeF f PureLiteral        (x:xs) = (f x, xs)
execPureOpsWithFreeF f (PurePlus opx opy)     xs = (mappend x y, yrem)
  where
    (x, xrem) = execPureOpsWithFreeF f opx xs
    (y, yrem) = execPureOpsWithFreeF f opy xrem