FreeT MonadMask experimentation

mask-freet.hs

#! /usr/bin/env nix-shell
#! nix-shell -i runghc -p "haskellPackages.ghcWithPackages (pkgs: with pkgs; [ text free exceptions_0_10_0 ])"
#! nix-shell -I nixpkgs=https://github.com/NixOS/nixpkgs-channels/archive/nixpkgs-unstable.tar.gz
-- #! nix-shell -i runghc -p haskellPackages.text haskellPackages.free "haskellPackages.callHackage ''exceptions'' ''0.10.0'' {}"

{-# language DeriveFunctor, FlexibleInstances #-}

-- | Historical background reading for this experiment (in historical order):
--
-- * https://stackoverflow.com/questions/41966893/why-is-there-no-monadmask-instance-for-exceptt
-- * https://www.fpcomplete.com/blog/2017/02/monadmask-vs-monadbracket
-- * http://hackage.haskell.org/package/exceptions-0.10.0/docs/Control-Monad-Catch.html#t:MonadMask
--
-- Additional reading related to FreeT:
--
-- * https://stackoverflow.com/questions/17511841/monadtranscontrol-instance-for-proxyfast-proxycorrect/17515535#17515535
-- * https://stackoverflow.com/a/17515535/167485
-- * https://github.com/ekmett/free/pull/88/files#diff-32a6f4e068c0071020e712c18bb358be
--
-- It's a little tough wrapping your head around
--
-- * multiple exit points (ExcepT)
-- * rolling back state (StateT)
-- * continuation passing...
--
-- One reason why MonadMask would be helpful is for interactions with other threads via e.g. withMVar.
--
-- Lets find out what all this means for FreeT. Hence experimentation:

import Control.Monad.Trans.Free
import Control.Monad.Trans.State
import Control.Monad.Catch
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)

data Interaction cont
  = Print
  | Fail
  | Done
  deriving Functor

data ScriptError = ScriptError
data ScriptState = State1 | State2

type ScriptT m result = FreeT Interaction m result

type InteractiveIO = ExceptT ScriptError (StateT ScriptState IO)

-- 1. A general implementation is impossible (cannot fill the holes, there's no interpreter available)
--
-- instance (Functor f, MonadThrow m) => MonadMask (FreeT f m) where
--   generalBracket acquire release use = generalBracket (_ acquire) (_ release) (_ use)

-- 2. This is a bad idea because it forces us to pick a specific interpreter:
--
-- instance MonadMask (FreeT Interaction InteractiveIO) where
--   generalBracket acquire release use = lift $ generalBracket
--     (iterT interpret acquire)
--     (\resource exitCase -> case exitCase of
--       ExitCaseSuccess b -> iterT interpret (release resource (ExitCaseSuccess b))
--       ExitCaseException e -> iterT interpret (release resource (ExitCaseException e))
--       ExitCaseAbort -> iterT interpret (release resource ExitCaseAbort)
--     )
--     _

-- 3. Wrap a newtype for this particular (interactive IO) interpretation of the script?
newtype InteractiveScript result = InteractiveScript _