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

{-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 a
  = Put String (FIOF a) 
  | Get (String -> FIOF a)
  | Sleep Int (FIOF a)
  | Pure a
  -- deriving (Show)
  deriving (Functor)
  
instance Applicative FIOF where
  pure = Pure
  (<*>) = ap

instance Monad FIOF where
  (Pure a) >>= f = f a
  (Get cont) >>= f = Get (\u -> (cont u) >>= f)
  (Sleep int cont) >>= f = Sleep int (cont >>= f)
  (Put str cont) >>= f = Put str (cont >>= f)

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

put :: String -> FIOF ()
put s = Put s (Pure ())

get :: FIOF String
get = Get Pure

sleep :: Int -> FIOF ()
sleep n = Sleep n (Pure ())

foo :: FIOF 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 :: FIOF a -> IO a
interpret = \m -> go m
  where
    go :: FIOF a -> IO a
    go (Pure a) = pure a
    go (Put str cont) = putStrLn str >> go cont
    go ( (Get cont)) = fakeGetLine >>= \a -> go (cont a)
    go ( (Sleep time cont)) = threadDelay (time `div` 1000) >> go cont 

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