Code accompanying https://welltypedwit.ch/posts/value-restriction.html

value-restriction.hs

{-# LANGUAGE ImpredicativeTypes, MagicHash, UnboxedTuples, BlockArguments, LambdaCase, NoMonoLocalBinds, TypeApplications #-}
module Main where

import GHC.IO (IO(..))

import GHC.Exts (State#)

import Data.IORef (IORef, newIORef, readIORef, writeIORef)

class (Monad m) => MonadGen m where
    generalize :: forall f. (forall a. m (f a)) -> m (forall a. f a)

data BoxedState s = BoxedState {state :: State# s}

liftState :: (# State# s, b #) -> (BoxedState s, b)
liftState (# s, b #) = (BoxedState s, b)

instance MonadGen IO where
    generalize m = do
        let (IO f) = m
        IO \s -> do
            let (boxedState, result) = liftState (f s)
            let (BoxedState{state}) = boxedState
            (# state, result #)

newtype MaybeRef a = MaybeRef (IORef (Maybe a))

unsafeCoerceIO :: forall a b. a -> IO b
unsafeCoerceIO x = do
    maybeRef <- generalize (MaybeRef <$> newIORef Nothing)
    let MaybeRef ref = maybeRef
    writeIORef ref (Just x)
    readIORef ref >>= \case
        Just y -> pure y
        Nothing -> error "unreachable"
    
main :: IO ()
main = do
    string <- unsafeCoerceIO @_ @String id
    print string