thing.hs

{-# Language DeriveFunctor, FlexibleInstances #-}

module Lib where

newtype Mu f = Mu (f (Mu f))

data ArithF f =
  ALit Int |
  AAdd f f |
  ASub f f deriving Functor

lit :: Int -> Arith
lit i = Mu $ ALit i

add :: Arith -> Arith -> Arith
add x y = Mu $ AAdd x y

sub :: Arith -> Arith -> Arith
sub x y = Mu $ ASub x y

cata :: Functor f => (f a -> a) -> Mu f -> a
cata f (Mu g) = f (fmap (cata f) g)

type Arith = Mu ArithF
type Alg f a = f a -> a

-- This is why we need FlexibleInstances
instance Show (Mu ArithF) where
  show = cata printer

printer :: Alg ArithF String
printer (ALit i) = show i
printer (AAdd l r) = "(" ++ l ++ " + " ++ r ++ ")"
printer (ASub l r) = "(" ++ l ++ " - " ++ r ++ ")"


interpreter :: Alg ArithF Int
interpreter (ALit i) = i
interpreter (AAdd l r) = l + r
interpreter (ASub l r) = l - r

keep :: Alg ArithF Arith
keep = Mu 

(<+>) :: Functor f => Alg f a -> Alg f b -> Alg f (a,b)
c1 <+> c2 = \f -> (c1 $ fmap fst f,
                   c2 $ fmap snd f)

eval :: Arith -> (Int, String)
eval = cata (interpreter <+> printer)

annotated :: Arith -> (Int, Arith)
annotated = cata (interpreter <+> keep)

full :: Arith -> (Int, (String, Arith))
full = cata (interpreter <+> (printer <+> keep))