not-so-free-monad-default-options.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}

import Control.Monad (ap)
import System.IO (Handle, IOMode (ReadMode, WriteMode), hGetLine, hPutStrLn, stdin, stdout, withFile)

data MyIO a
  = Pure a
  | GetLine {handle :: Handle, next_getLine :: String -> MyIO a}
  | PutStrLn {handle :: Handle, str_putStrLn :: String, next_putStrLn :: MyIO a}
  deriving stock (Functor)

instance Applicative MyIO where
  pure = Pure
  (<*>) = ap

instance Monad MyIO where
  Pure x >>= f = f x
  GetLine h k >>= f = GetLine h \s -> k s >>= f
  PutStrLn h s k >>= f = PutStrLn h s (k >>= f)

myGetLine :: MyIO String
myGetLine = GetLine stdin Pure

myPutStrLn :: String -> MyIO ()
myPutStrLn str = PutStrLn stdout str (Pure ())

run :: MyIO a -> IO a
run = \case
  Pure x -> pure x
  GetLine h k -> hGetLine h >>= run . k
  PutStrLn h s k -> hPutStrLn h s >> run k

main :: IO ()
main = do
  withFile "package.yaml" ReadMode \h1 ->
    withFile "test" WriteMode \h2 -> run do
      x <- myGetLine
      y <- myGetLine {handle = h1}
      myPutStrLn y
      (myPutStrLn x) {handle = h2}