{-# LANGUAGE RankNTypes, TypeOperators, TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}

-- Advanced examples of Iteratee, including IterFile,
-- incremental file writing with assured file closing
-- Relating Iteratees and Monadic Regions.

-- For a tighter integration of Iteratees and Regions
-- and perhaps better implementation of IterFile,
-- see the file IterReg.hs in the present directory.

module IterAdv where

import IterateeM
import ComposeAdv (R, L(..), (:>=:)(..), (|||), compL)
import Data.Monoid
import Control.Monad.Trans
import Data.Typeable
import Control.Exception
import System.IO

-- A few standard enumerators in the L notation

fileL :: FilePath -> L Char IO IO
fileL fname = L (enum_file fname)

-- ------------------------------------------------------------------------
-- Implementing a very lightweight version of monadic regions
-- (with few guarantees on the non-escaping handles).
-- Essentially, we end up with something like withFile.
-- The full version of lightweight monadic regions can be implemented, too.
-- The present code is meant as an example; (over)simplicity is a virtue.
-- We then implement iterFile, incremental writing to a file.

-- Save all the contents into a given file, incrementally
-- iterFile is written in the *ordinary* monadic style
-- We don't worry about the closing file: the L that opened it
-- with close it.
iterFile :: MonadIO m => FilePath -> R Char m ()
iterFile fname = openReq fname >>= loop 
 where
 loop h = getChunk >>= check h
 check h (Chunk s) = liftIO (hPutStr h s) >> loop h
 check h e  = return ()

tIF0 = run =<< openFileL ||| iterFile "/tmp/x"
{-
Opening the request file: "/tmp/x"
Closing: {handle: /tmp/x}
-}

tIF1 = run =<< fileL "/etc/motd" ||| iterFile "/tmp/x"
{-opened file /etc/motd
  closed file /etc/motd
-- *** Exception: control message: OpenReq "/tmp/x"
-}

-- Indeed, we have forgotten the OpenReq handler -- the Region manager
-- We should add openFileL first
tIF2 = run =<< openFileL `mappend` fileL "/etc/motd" ||| iterFile "/tmp/x"
-- Notice the sequence of opening and closing and requesting
{-
Opening the request file: "/tmp/x"
opened file /etc/motd
checkK
closed file /etc/motd
checkK
Closing: {handle: /tmp/x}
-}
-- diff -u /etc/motd /tmp/x

tIF3 = run =<< 
        (openFileL `mappend` fileL "/etc/services") ||| (iterFile "/tmp/x")
{-
Opening the request file: "/tmp/x"
opened file /etc/services
checkK
checkK
...
checkK
checkK
closed file /etc/services
checkK
Closing: {handle: /tmp/x}
-}
-- diff -u /etc/services /tmp/x


-- Let us write a simple enumeratee: filter
-- We write it in the regular monadic style

-- There is a bit boiler-plate here, which should be factored out
-- properly. It is too late to do it today though...

filterL :: (e -> Bool) -> L e IO (R e IO)
filterL pred = L loop
 where
 -- inner iteratee wants data
 loop (IE_cont Nothing k) = getChunk >>= check k
 loop (IE_cont e k) = IE_cont e (checkK k)
 loop i = return i 

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

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

 checkK k s = feedI k s >>= ie_ret . loop


tIF4 = run =<< tL ||| iterFile "/tmp/x"
 where
 tL = (openFileL `mappend` fileL "/etc/motd") `compL` filterL (/= ',')
{-
Opening the request file: "/tmp/x"
opened file /etc/motd
checkK
filter: yield
closed file /etc/motd
checkK
Closing: {handle: /tmp/x}
-}

tIF5 = run =<< tL ||| iterFile "/tmp/x"
 where
 tL = (openFileL `mappend` fileL "/etc/services") `compL` filterL (/= ',')

{-
Opening the request file: "/tmp/x"
opened file /etc/services
checkK
filter: yield
...
checkK
filter: yield
checkK
filter: yield
checkK
filter: yield
closed file /etc/services
checkK
Closing: {handle: /tmp/x}
-}


-- A request to open a file is implemented as a restartable exception
-- Yes, it is lame and smacks of dynamic typing.
-- A better version _can_ and _has_ been written, see UpDown.hs or
-- UpDownCPS.hs
-- The present version has the advantage of using IterateeM.hs as it is.

newtype OpenReq = OpenReq FilePath
  deriving (Show,Typeable)
instance Exception OpenReq

newtype HandleReply = HandleReply Handle
  deriving (Show,Typeable)
instance Exception HandleReply

-- A primitive to make opening easier
openReq :: MonadIO m => FilePath -> R e m Handle
openReq fname = IE_cont (Just (toException (OpenReq fname))) k
 where 
 k (EOF (Just e)) | Just (HandleReply h) <- fromException e =
   ie_doneM h empty_stream
 k _ = ie_ret (throwErrStr "openReq: didn't gent the handle")

-- The point: an interpreter, the L, does not have to handle all
-- requests. It can handle some (for example, OpenReq) propagating
-- others. One should not therefore think of L as Sources since
-- they may be producing other effects.

-- We could do something smarter than just throwing all IO exceptions
-- up to the chain. Anyway, the point is to make sure that all handles 
-- are closed.
openFileL :: L e IO IO
openFileL = L (loop [])
 where
 loop :: [Handle] -> Iteratee e IO a -> IO (Iteratee e IO a)
 loop hs i@IE_done{} = cleanup hs >> return i
 loop hs (IE_cont (Just e) k) | Just (OpenReq fname) <- fromException e =
   putStrLn ("Opening the request file: " ++ show fname) >>
   try (openFile fname WriteMode) >>= check
   where
   check (Right h) = 
       conv_IO_errors (k (EOF (Just (toException (HandleReply h)))))
		      >>= loop (h:hs) . fst
   check (Left e) = err hs e

 -- get chunk request
 loop hs (IE_cont Nothing k) = return (IE_cont Nothing (checkK hs k))
 -- some kind of error: rethrow
 loop hs (IE_cont (Just e) k) = err hs e

 -- Install the post-continuation
 checkK hs k s = do
   putStrLn "checkK"
   (i,_) <- conv_IO_errors (k s) 
   i1 <- loop hs i
   ie_ret i1

 err :: [Handle] -> ErrMsg -> IO (Iteratee e IO a0)
 err hs e = cleanup hs >> return (throwErr e)

 cleanup :: [Handle] -> IO ()
 cleanup = mapM_ close
  where close h = putStrLn ("Closing: " ++ show h) >> hClose h


-- Convert all IO errors into Iteratee errors
conv_IO_errors :: IO (R e IO a, Stream e) -> IO (R e IO a, Stream e)
conv_IO_errors m = try m >>= check
 where
 check (Right x) = return x
 check (Left e)  = ie_ret (throwErr e)


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