MonadSubst.hs

{-# LANGUAGE DeriveFunctor, GADTs, UndecidableInstances #-}

module FreeExample where

import Control.Monad
import Data.Void -- Empty type

-- ghci> ppr example1
-- "Add 1 (Sub 2 3)"
example1 :: Expr Void
example1 = add (lit 1) (sub (lit 2) (lit 3))

-- Note that you get "substituteUsing" for free from the monad. The Free monad gives this to you completely auomatically,
-- given the definition of the ExprF type.

-- ghci> ppr example2
-- "Add 2 (Add 10 6)"
example2 :: Expr String
example2 = substituteUsing mySubstFn (add (lit 2) (Pure "abcdef"))
  where
    mySubstFn :: String -> Expr String
    mySubstFn varName = add (lit 10) (lit (length varName))




data ExprF a where
  Lit :: Int -> ExprF a

  Add :: a -> a -> ExprF a
  Sub :: a -> a -> ExprF a
  deriving (Show, Functor)

type Expr a = Free ExprF a

add :: Expr a -> Expr a -> Expr a
add x y = Joined (Add x y)

sub :: Expr a -> Expr a -> Expr a
sub x y = Joined (Sub x y)

lit :: Int -> Expr a
lit x = lift (Lit x)

instance Ppr a => Ppr (ExprF a) where
  ppr (Lit i) = show i
  ppr (Add x y) = "Add " ++ pprParens x ++ " " ++ pprParens y
  ppr (Sub x y) = "Sub " ++ pprParens x ++ " " ++ pprParens y

  pprParens (Lit i) = show i
  pprParens e = "(" ++ ppr e ++ ")"



---- Definition of free monad (which is reusable) ----

data Free f a = Pure a | Joined (f (Free f a))
  deriving (Functor)

substituteUsing :: Monad m => (a -> m b) -> m a -> m b
substituteUsing f x = x >>= f

lift :: Functor f => f a -> Free f a
lift x = Joined (fmap Pure x)

-- lift2 :: Functor f 

instance Functor f => Applicative (Free f) where
  pure = Pure
  (<*>) = ap

instance Functor f => Monad (Free f) where
  Pure x >>= f = f x
  Joined x >>= f = Joined (fmap (>>= f) x)

instance (Ppr a, Ppr (f (Free f a))) => Ppr (Free f a) where
  ppr (Pure x) = ppr x
  ppr (Joined x) = ppr x

  pprParens (Pure x) = pprParens x
  pprParens (Joined x) = pprParens x

---- Pretty printer ----

class Ppr a where
  ppr :: a -> String
  pprParens :: a -> String

instance Ppr () where ppr = show
instance Ppr String where ppr = show