-- The illustration of the Boehm-Berarducci encoding
-- This file is the baseline: using ordinary algebraic
-- data type and operations of constructions, deconstructions
-- and transformation.
-- We use the running example of the Exp data type from
-- tagless-final lectures
module BB_ADT where
-- Sample data type of expressions
data Exp = Lit Int
| Neg Exp
| Add Exp Exp
-- Constructing a sample expression
ti1 = Add (Lit 8) (Neg (Add (Lit 1) (Lit 2)))
-- A sample consumer
-- It is structurally recursive
view:: Exp -> String
view (Lit n) = show n
view (Neg e) = "(-" ++ view e ++ ")"
view (Add e1 e2) = "(" ++ view e1 ++ " + " ++ view e2 ++ ")"
ti1_view = view ti1
-- "(8 + (-(1 + 2)))"
-- In the general form, structural recursion over Exp is expressed by the fold:
fold_Exp :: (Int -> a) -> (a -> a) -> (a -> a -> a) -> Exp -> a
fold_Exp onlit onneg onadd (Lit n) = onlit n
fold_Exp onlit onneg onadd (Neg e) = onneg (fold_Exp onlit onneg onadd e)
fold_Exp onlit onneg onadd (Add e1 e2) =
onadd (fold_Exp onlit onneg onadd e1) (fold_Exp onlit onneg onadd e2)
-- It make sense to group the parameters of fold_Exp in a record, to
-- make fold_Exp more convenient to use and write
data ExpOps a = ExpOps{ olit :: Int -> a,
oneg :: a -> a,
oadd :: a -> a -> a }
fold_Exp' :: ExpOps a -> Exp -> a
fold_Exp' ops = fold_Exp (olit ops) (oneg ops) (oadd ops)
-- Then view is a particular case of fold_Exp
view_ops :: ExpOps String
view_ops = ExpOps {
olit=show,
oneg = \e -> "(-" ++ e ++ ")",
oadd = \e1 e2 -> "(" ++ e1 ++ " + " ++ e2 ++ ")"}
view' = fold_Exp' view_ops
ti1'_view = view' ti1
-- "(8 + (-(1 + 2)))"
-- Transformer
-- * Pushing the negation down
-- Previously, expressions were constructed according to this grammar:
-- * General grammar of expressions
-- * e ::= int | neg e | add e e
-- *
-- * Restricted grammar:
-- * e ::= factor | add e e
-- * factor ::= int | neg int
-- Now, only integer literals can be negated, and only once.
-- This function is NOT structurally recursive
push_neg :: Exp -> Exp
push_neg e@Lit{} = e
push_neg e@(Neg (Lit _)) = e
push_neg (Neg (Neg e)) = push_neg e
push_neg (Neg (Add e1 e2)) = Add (push_neg (Neg e1)) (push_neg (Neg e2))
push_neg (Add e1 e2) = Add (push_neg e1) (push_neg e2)
-- A few sample transformations and their results
ti1_norm = push_neg ti1
ti1_norm_view = view ti1_norm
-- "(8 + ((-1) + (-2)))"
-- Add an extra negation
ti1n_norm_view = view (push_neg (Neg ti1))
-- "((-8) + (1 + 2))"