{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoMonoLocalBinds, NoMonomorphismRestriction #-}

-- Combining Iteratees and Regions
-- for incremental reading and writing with assured finalization

-- It turns out Iteratees (mostly as they are) combine well with
-- lightweight monadic regions (mostly as they are).
-- We use Regions to write enumFile and iterFile.
-- The former incrementally reads data from a file and feeds them
-- to an iteratee.
-- The latter takes the fed data increment and writes it into a file.
-- All opened files are *always* closed, regardless of any
-- (asynchronous) exceptions that may arise during opening, reading,
-- writing or transforming. See the many examples below.

module IterReg where

-- The iteratee library, used as it is
import IterateeM

-- Code from the Haskell08 paper `Lightweight monadic regions'
-- (refreshed for GHC 7.x and with primitives for reading and writing
-- ByteString from and to SafeHandles)
-- http://okmij.org/ftp/Computation/resource-aware-prog/
import SafeHandles			-- import the security kernel

import Control.Exception (SomeException)
import Control.Monad
import Control.Monad.Trans
import Data.ByteString as B
import Data.Monoid

-- ------------------------------------------------------------------------
-- We start with examples. See their implementation below

tIF0 = runSIO $ run (iterFile "/tmp/x")
{-
Opening the request file: "/tmp/x"
Closing: {handle: /tmp/x}
-}

-- Simple copying "/etc/motd" to "/tmp/x", incrementally
tIF1 = runSIO $ 
       run =<< unL (enumFile "/etc/motd") (iterFile "/tmp/x")
-- NB! The files are closed not in the LIFO order!
-- That is important as we get to copying of several files, see tIF3
{-
opened file /etc/motd
iterFile: opening /tmp/x
Closing {handle: /etc/motd}
Closing {handle: /tmp/x}
-}

-- Illustrating an iteratee error
tIF2 = runSIO $ 
       run =<< unL (enumFile "/etc/motd") (iterFile "/unopenable")

{-
opened file /etc/motd
iterFile: opening /unopenable
Closing {handle: /etc/motd}
*** Exception: /unopenable: openFile: permission denied (Permission denied)
-}

-- Copying two files into "/tmp/x", incrementally
tIF3 = runSIO $ 
       run =<< unL (enumFile "/etc/motd" `mappend`
		    enumFile "/usr/share/dict/words")
	     (iterFile "/tmp/x")
{-
opened file /etc/motd
iterFile: opening /tmp/x
Closing {handle: /etc/motd}
opened file /usr/share/dict/words
Closing {handle: /usr/share/dict/words}
Closing {handle: /tmp/x}
-}
-- diff -u /usr/share/dict/words /tmp/x

-- Illustrating an enumerator error: error opening a file
tIF4 = runSIO $ 
       run =<< unL (enumFile "/etc/motd" `mappend`
		    enumFile "/nonexistent")
	     (iterFile "/tmp/x")

{-
opened file /etc/motd
iterFile: opening /tmp/x
Closing {handle: /etc/motd}
opened file /nonexistent
Closing {handle: /tmp/x}
*** Exception: /nonexistent: openFile: does not exist (No such file or directory)
-}

-- Example of catching exceptions and handling them
tIF4' = runSIO $ 
       run =<< unL (enumFile "/etc/motd" `mappend`
		    recover (enumFile "/nonexistent"))
	     (iterFile "/tmp/x")
 where
 recover (L en) = 
   L (\iter -> shCatch (en iter) (\e -> report e >> return iter))
 report e = shReport $ "exception: " ++ show (e::SomeException)
{-
opened file /etc/motd
iterFile: opening /tmp/x
Closing {handle: /etc/motd}
opened file /nonexistent
exception: /nonexistent: openFile: does not exist (No such file or directory)
Closing {handle: /tmp/x}
-}			      


-- A more subtle enumerator error: Michael Snoyman's example
-- of asynchronous exceptions in an enumerator
tIF5 = do
    runSIO $ unL (enumFile "/etc/motd" `mappend` enum False) 
	       (iterFile "/tmp/f1") >>= run
    runSIO $ unL (enumFile "/etc/motd" `mappend` enum True)  
	       (iterFile "/tmp/f2") >>= run
 where
 enum :: SMonadIO m => Bool -> L ByteString m m
 enum toFail = L (sendChunk toFail)

 sendChunk :: SMonadIO m => Bool -> R ByteString m a -> m (R ByteString m a)
 sendChunk _ i@(IE_done _) = return i
 sendChunk toFail (IE_cont Nothing k) = 
    lifts (k (Chunk [a_chunk])) >>= die toFail
 sendChunk _ (IE_cont (Just e) k) = error $ show e

 a_chunk = B.pack (Prelude.map (toEnum.fromEnum) "This is successful\n")

 die :: SMonadIO m => Bool -> (i, Stream ByteString) -> m i
 die toFail = if toFail then error "die" else return . fst

{-
opened file /etc/motd
iterFile: opening /tmp/f1
Closing {handle: /etc/motd}
Closing {handle: /tmp/f1}
opened file /etc/motd
iterFile: opening /tmp/f2
Closing {handle: /etc/motd}
Closing {handle: /tmp/f2}
*** Exception: die
-}


-- Copying the files while removing commas
-- Illustrating the composition of an enumerator enumFile
-- with an enumeratee filterL, which produces an enumerator
tIF6 = runSIO $ 
       run =<< unL tL (iterFile "/tmp/x")
 where
 tL = enumFile "/etc/services" `compL` filterL pred
 pred = Prelude.map (B.filter (/= (toEnum.fromEnum) ','))

{-
opened file /etc/services
filter: yield
iterFile: opening /tmp/x
filter: yield
...
filter: yield
Closing {handle: /etc/services}
Closing {handle: /tmp/x}
-}

-- diff -u /etc/services /tmp/x

-- Faulty enumeratee
tIF6' = runSIO $ 
       run =<< unL tL (iterFile "/tmp/x")
 where
 tL = enumFile "/etc/services" `compL` filterL pred
 pred = Prelude.map (\b -> if B.any (== (toEnum.fromEnum) ',') b then
		              error "bad" else b)

{-
opened file /etc/services
filter: yield
iterFile: opening /tmp/x
Closing {handle: /etc/services}
Closing {handle: /tmp/x}
*** Exception: bad
-}


-- ------------------------------------------------------------------------
-- A few preliminaries and terminology
-- Once we step a bit beyond Haskell98, the story can be told simpler

-- An alias, shorter to type and less objectionable, for some people
type R e m = Iteratee e m

-- A better type for enumerator, which really does not depend on
-- the value yielded by an iteratee
newtype ENM e m = ENM{unENM:: forall a. R e m a -> m (R e m a)}

-- Now, it is a Monoid
instance Monad m => Monoid (ENM e m) where
    mempty = ENM return
    mappend (ENM e1) (ENM e2) = ENM $ \i -> e1 i >>= e2

-- It is now intuitive that composing (or, mappending) enumerators
-- concatenates their sources.
-- We no longer need to think up the name for the operation of
-- composing enumerators; we use the standard mappend.

-- We generalize
newtype L e mi mo = L{unL :: forall a. R e mi a -> mo (R e mi a)}

-- Both mi and mo parameters are meant to be monads. Furthermore,
-- mo should be the same or bigger than mi:
-- the producer should do all the effects that its consumer
-- wants, and perhaps a few more.

-- The type class MonadRaise (from lightweight monadic regions)
-- establishes the partial order among monads
-- (what it means to be `bigger')

-- When m1 = m2, L e m m is isomorphic to the enumerator, ENM
-- L e m1 m2 is still a monoid, even if m1 /= m2

instance (Monad mi, Monad mo) => Monoid (L e mi mo) where
    mempty = L return
    mappend (L e1) (L e2) = L $ \i -> e1 i >>= e2

-- The particular case L e m (R e' m) is enumeratee!
-- So, L e mi mo unify the notions of the enumerators and enumeratees
-- (and it is even more general)

-- For example, here is how we can `compose' L

-- The code says, in particular, that composing an enumerator with 
-- an enumeratee gives an enumerator, and composing two enumeratees
-- gives an enumeratee.
-- The code also gives all the intermediate cases.
compL :: (MonadRaise m mo) => L e m mo -> L e' m (R e m)  -> L e' m mo
compL (L e12) (L e23) = L (\ie' -> e12 (e23 ie') >>= lifts . run)

-- ------------------------------------------------------------------------
-- Implementing iterFile and enumFile using Regions

-- iterFile saves all received data into a given file, incrementally.
-- The code is written in the *ordinary* monadic style.
-- We don't worry about the closing file, it will be closed 
-- when the region (iterFile's top region) is exited.
iterFile :: (SMonad1IO m, m ~ (IORT s' m')) 
	    => FilePath -> R ByteString m ()
iterFile fname = do
  lift . shReport $ "iterFile: opening " ++ fname
  h <- lift $ newSHandle fname WriteMode
  loop h
 where
 loop h = getChunk >>= check h
 check h (Chunk s) = lift (mapM (shPut h) s) >> loop h
 check h e  = return ()

-- enumFile reads data from a file and feeds to an iteratee.
-- We use regions so to make sure the opened file will be closed
-- no matter what happens.
-- Generally speaking, enumFile can be implemented simpler since
-- it never gives the file handle to an iteratee and so there is
-- no danger the handle leaks. OTH, the code below is most
-- straightforward.
enumFile :: (SMonadIO m) => FilePath -> L ByteString m m
enumFile filepath = L $ \iterv -> do
  shReport $ "opened file " ++ filepath
  newRgn $ do
        h <- newSHandle filepath ReadMode
        unL (enumHandle h) iterv

-- An enumerator, so to speak, which reads data from a handle and
-- passes them to an iteratee.
-- We don't worry at all about exceptions: they will be caught
-- in due course by a newRgn somewhere up the stack.
-- enumHandle is an example of L where m' /= m and 
-- which is not an enumeratee.

enumHandle :: (SMonadIO m', MonadRaise m m') => 
	       SHandle m' -> L ByteString m m' 
enumHandle h = L (enumHandle' h)
enumHandle' h (IE_cont Nothing k) = shSetBuffering h NoBuffering >> loop k
 where
  buffer_size = 4096
  loop k = do
   b <- shGetSome h buffer_size
   -- putStrLn $ "Read buffer, size " ++ either (const "IO err") show n
   if B.null b then return (ie_cont k)
      else lifts (feedI k (Chunk [b])) >>= check
  check (IE_cont Nothing k) = loop k
  check i                   = return i
enumHandle' _ i = return i			-- i doesn't want any input



-- ------------------------------------------------------------------------
-- Auxiliaries

-- An incremental transformer that works on whole chunks
filterL :: SMonadIO m => ([e] -> [e]) -> L e m (R e m)
filterL pred = L loop
 where
 -- inner iteratee wants data
 loop (IE_cont Nothing k) = getChunk >>= check k
 loop (IE_cont (Just e) k) = throwErr e
 loop i = return i 

 check k (Chunk s) = case pred s of
		      [] -> getChunk     >>= check k
		      s  -> yield_to k s >>= loop
 check k s = return (ie_cont k)

 yield_to k v = lift (shReport "filter: yield" >> feedI k (Chunk v))


class Monad m => ITER m where
    type ITERStream m :: * 
    getChunk :: m (ITERStream m)
    -- putbackChunck :: ITERStream m -> m ()

instance Monad m => ITER (R e m) where
    type ITERStream (R e m) = Stream e
    getChunk = ie_cont step
     where
     step (Chunk []) = ie_contM step
     step s          = ie_doneM s empty_stream


{-
Alternative design: extensible free monads instead of monad transformers.
We have to support snag/catch protocol. One way to support it is to
supply finalizers with each request. If a request cannot be fulfilled,
a finalizer must be called. The server is responsible for that; perhaps
we should ensure that in types. Or should we register a finalizers
with a particular `region server', which only listens to 
registration requests?
-}