Using GADTs with Free (with fewer typeclasses & extensions)

BeepBoop.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

module Main where

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

data Hide g r where
  Hide :: g a -> (a -> r) -> Hide g r

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

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

runWith :: (Monad m) => (forall b. g b -> m b) -> Free (Hide g) a -> m a
runWith interpreter = go
  where
    go (Pure x) = pure x
    go (Free m) = join $ interpreter' $ go <$> m
    interpreter' (Hide g k) = k <$> interpreter g

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

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

interpret :: BeepBooping a -> IO a
interpret (Beep count) = 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 = runWith interpret example