{-# LANGUAGE QuantifiedConstraints, DerivingStrategies, GeneralizedNewtypeDeriving #-}
import Control.Concurrent
import Control.Monad
import Data.IORef

data Free f a = Pure a | Free (f (Free f a))
  deriving (Functor)
deriving instance (Show a, forall a. Show a => Show (f a)) => Show (Free f a)
instance Functor f => Applicative (Free f) where
  pure = Pure
  (<*>) = ap
instance Functor f => Monad (Free f) where
  Pure x >>= f = f x
  Free c >>= f = Free (fmap (>>= f) c)

-- Free IO Functor
data FIOF r
  = Put String r
  | Get (String -> r)
  | Sleep Int r
  | forall a. NewIORef (IORef a -> r)
  | forall a. ReadIORef (IORef a) (a -> r)
  | forall a. WriteIORef (IORef a) a r
  -- deriving (Show)
deriving instance (Functor FIOF)

-- Free FIO
newtype FIO a = FIO (Free FIOF a)
  -- deriving (Show)
  deriving newtype (Functor, Applicative, Monad)

put :: String -> FIO ()
put s = FIO (Free (Put s (Pure ())))

get :: FIO String
get = FIO (Free (Get Pure))

sleep :: Int -> FIO ()
sleep n = FIO (Free (Sleep n (Pure ())))

foo :: FIO Int
foo = do
  put "Input a number: "
  n <- read <$> get
  put "Computing...\n"
  sleep 1000000
  put $ "You entered: " ++ show n ++ "!\n"
  return n

fakeGetLine :: IO String
fakeGetLine = return "42\n"  -- can't get lines in playground, let's fake it

interpret :: FIO a -> IO a
interpret = \(FIO m) -> go m
  where
    go :: Free FIOF a -> IO a
    go _ = _

main :: IO ()
main = do
  x <- interpret foo
  putStrLn $ "Returned: " ++ show x