HandleWriter.hs

{-# LANGUAGE BangPatterns #-}
module Control.Monad.HandleWriter
  ( HandleWriter
  , runHandleWriter
  ) where

import BasePrelude (seq)
import System.IO
import Control.Monad.Reader
import Control.Monad.Writer.Class

type HandleWriter :: Type -> Type -> Type
newtype HandleWriter w a = HandleWriter (ReaderT Handle IO a)
  deriving (Functor, Applicative, Monad, MonadFail, MonadIO)

runHandleWriter :: HandleWriter w a -> Handle -> IO a
runHandleWriter (HandleWriter x) = runReaderT x

instance MonadWriter String (HandleWriter String) where
  writer (x, w) = HandleWriter do
    h <- ask
    liftIO $ hPutStr h w
    return x
  listen (HandleWriter m) = HandleWriter do
    h <- ask
    i <- liftIO $ hTell h
    x <- m
    w <- liftIO do
      hSeek h AbsoluteSeek i
      w <- hGetContents h
      length w `seq` return w
    return (x, w)
  pass (HandleWriter m) = HandleWriter do
    h <- ask
    i <- liftIO $ hTell h
    (x, f) <- m
    liftIO do
      hSeek h AbsoluteSeek i
      w <- hGetContents h
      hSetFileSize h i
      hSeek h AbsoluteSeek i
      hPutStr h $ f w
    return x

--runHandleWriter :: HandleWriter -> IO a
--runHandleWriter =