Using GADTs with Free

BeepBoop.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Main where

import Control.Monad (forM_, join)
import Control.Monad.Free (Free(..), liftF)
import System.Random (randomRIO)

class (Functor f, Monad m) => Natural f m where
  natural :: f a -> m a

class (Monad m) => Interpretable g m where
  interpret :: g a -> m a

data Hide g r = forall a. Hide (g a) (a -> r)

instance Functor (Hide g) where
  fmap f (Hide g k) = Hide g (f . k)

instance (Interpretable g m) => Natural (Hide g) m where
  natural (Hide g k) = k <$> interpret g

hide :: g a -> Free (Hide g) a
hide action = liftF (Hide action id)

run :: (Natural f m) => Free f a -> m a
run (Pure x) = pure x
run (Free f) = join $ natural $ run <$> f

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

data BeepBooping f where
  Beep :: Int -> BeepBooping ()
  Boop :: BeepBooping Int

instance Interpretable BeepBooping IO where
  interpret (Beep count) = do
    forM_ [1..count] $ const $ putStrLn "beep"
  interpret Boop = randomRIO (1, 10)

type BeepBoop = Hide BeepBooping

beep :: Int -> Free BeepBoop ()
beep count = hide (Beep count)

boop :: Free BeepBoop Int
boop = hide Boop

example :: Free BeepBoop ()
example = do
  beep 1
  beep =<< boop
  beep 2

main :: IO ()
main = run example