--  The HiPar Toolkit: state transformer routines
--
--  Author : Manuel M. T. Chakravarty
--  Created: 3 March 95
--
--  Version $Revision: 1.1.1.1 $ from $Date: 2004/11/13 16:42:45 $
--
--  Copyright (C) [1995..1999] Manuel M. T. Chakravarty
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This module provides basic support for the use of state transformers.
--  The state transformer is build around the `IO' monad to allow the
--  manipulation of external state. It encapsulated two separate states with
--  the intention to use the first one for the omnipresent compiler state
--  consisting of the accumulated error messages etc. and to use the second as
--  a generic component that can be used in different ways by the different
--  phases of the compiler.
--
--  The module also supports the use of exceptions and fatal errors.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  * We explicitly do not use any names for the monad types and functions
--    that are used by either Haskell's `IO' monad or GHC's `ST' monad.  Since
--    Haskell 1.4, `STB' is an instance of the `Monad' constructor class.
--
--  * To integrate the Haskell prelude `IO' monad into our `STB' monad we use
--    the technique from ``Composing monads'' by Mark P. Jones and Luc
--    Duponcheel (Report YALEU/DCS/RR-1004) from 1993, Section 8.
--
--  * The use of GHC's inplace-update goodies within monads of kind `STB' is
--    possible, because `IO' is based on `ST' in the GHC.
--
--  * In the following, we call the two kinds of state managed by the `STB' the
--    base state (the omnipresent state of the compiler) and generic state.
--
--  * `STB' is a newtype, which requires careful wrapping and unwrapping of its
--    values in the following definitions.
--
--- TODO ----------------------------------------------------------------------
--
--  * with constructor classes, the state transformer business can be made
--    more elegant (they weren't around when this module was initially written)
--
--  * it would be possible to maintain the already applied changes to the base
--    and generic state even in the case of a fatal error, when in `listIO'
--    every IO operation is encapsulated into a handler that transforms IO
--    errors into exceptions
--

module StateTrans (-- the monad and the generic operations
                   --
                   STB, fixSTB,
                   --
                   -- monad specific operations
                   --
                   readBase, writeBase, transBase, readGeneric, writeGeneric,
                   transGeneric, liftIO, runSTB, interleave,
                   --
                   -- exception handling and fatal errors
                   --
                   throwExc, fatal, catchExc, fatalsHandledBy,
                   --
                   -- mutable variables and arrays
                   --
                   MVar, newMV, readMV, assignMV)
where

import Prelude hiding     (catch)

import Control.Applicative (Applicative(..))
import Control.Monad      (liftM, ap)
import Control.Exception  (catch)
import System.IO  (fixIO)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)

import Errors (interr)

infixr 1 +>=, +>


-- BEWARE! You enter monad country. Read any of Wadler's or
-- Launchbury/Peyton-Jones' texts before entering. Otherwise,
-- your mental health my be in danger.  You have been warned!


-- state transformer base and its monad operations
-- -----------------------------------------------

-- the generic form of a state transformer using the external state represented
-- by `IO'; `STB' is a abbreviation for state transformer base
--
-- the first state component `bs' is provided for the omnipresent compiler
-- state and the, second, `gs' for the generic component
--
-- the third component of the result distinguishes between erroneous and
-- successful computations where
--
--   `Left (tag, msg)' -- stands for an exception identified by `tag' with
--                        error message `msg', and
--   `Right a'         -- is a successfully delivered result
--

newtype STB bs gs a = STB (bs -> gs -> IO (bs, gs, Either (String, String) a))

instance Functor (STB bs gs) where
  fmap = liftM

instance Applicative (STB bs gs) where
  pure  = yield
  (<*>) = ap
  (*>)  = (+>)

instance Monad (STB bs gs) where
  return = pure
  (>>=)  = (+>=)
  (>>)   = (*>)

-- the monad's unit
--
yield   :: a -> STB bs gs a
yield a  = STB $ \bs gs -> return (bs, gs, Right a)

-- the monad's bind
--
--  * exceptions are propagated
--
(+>=)   :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
m +>= k  = let
             STB m' = m
           in
           STB $ \bs gs -> m' bs gs >>= \(bs', gs', res) ->
                     case res of
                       Left  exc -> return (bs', gs', Left exc)  -- prop exc
                       Right a   -> let
                                      STB k' = k a
                                    in
                                    k' bs' gs'                   -- cont

-- bind dropping the result of the first state transformer
--
(+>)   :: STB bs gs a -> STB bs gs b -> STB bs gs b
k +> m  = k +>= const m

-- fixpoint combinator in the monad
--
fixSTB   :: (a -> STB bs gs a) -> STB bs gs a
--
-- builds on the fixpoint combinator embedded within the IO monad; the
-- future overall result wrapped into a closure with the function extracting
-- the user-level result component is used to build the cycle
--
fixSTB m  = STB $ \bs gs
                  -> fixIO (\future -> let
                                         STB m' = m (extractResult future)
                                       in
                                       m' bs gs)
            where
              extractResult (_, _, Right r) = r
              extractResult (_, _, Left _ ) = interr "StateTrans: fixSTB: \
                                                     \Tried to access result \
                                                     \of unsuccessful \
                                                     \recursive computation!"


-- generic state manipulation
-- --------------------------

-- base state:
--

-- given a reader function for the base state, wrap it into an STB monad
--
readBase   :: (bs -> a) -> STB bs gs a
readBase f  = STB $ \bs gs -> return (bs, gs, Right (f bs))

-- given a new base state, inject it into an STB monad
--
writeBase     :: bs -> STB bs gs ()
writeBase bs'  = STB $ \_ gs -> return (bs', gs, Right ())

-- given a transformer function for the base state, wrap it into an STB monad
--
transBase   :: (bs -> (bs, a)) -> STB bs gs a
transBase f  = STB $ \bs gs -> let
                                 (bs', a) = f bs
                               in
                                 return (bs', gs, Right a)

-- generic state:
--

-- given a reader function for the generic state, wrap it into an STB monad
--
readGeneric   :: (gs -> a) -> STB bs gs a
readGeneric f  = STB $ \bs gs -> return (bs, gs, Right (f gs))

-- given a new generic state, inject it into an STB monad
--
writeGeneric     :: gs -> STB bs gs ()
writeGeneric gs'  = STB $ \bs _ -> return (bs, gs', Right ())

-- given a transformer function for the generic state, wrap it into an STB
-- monad
--
transGeneric   :: (gs -> (gs, a)) -> STB bs gs a
transGeneric f  = STB $ \bs gs -> let
                                    (gs', a) = f gs
                                  in
                                  return (bs, gs', Right a)


-- interaction with the encapsulated `IO' monad
-- --------------------------------------------

-- lifts an `IO' state transformer into `STB'
--
liftIO   :: IO a -> STB bs gs a
liftIO m  = STB $ \bs gs -> m >>= \r -> return (bs, gs, Right r)

-- given an initial state, executes the `STB' state transformer yielding an
-- `IO' state transformer that must be placed into the context of the external
-- IO
--
--  * uncaught exceptions become fatal errors
--
runSTB         :: STB bs gs a -> bs -> gs -> IO a
runSTB m bs gs  = let
                    STB m' = m
                  in
                  m' bs gs >>= \(_, _, res) ->
                  case res of
                    Left  (tag, msg) -> let
                                          err = userError ("Exception `"
                                                           ++ tag ++ "': "
                                                           ++ msg)
                                        in
                                        ioError err
                    Right a          -> return a

-- interleave the (complete) execution of an `STB' with another generic state
-- component into an `STB'
--
interleave :: STB bs gs' a -> gs' -> STB bs gs a
interleave m gs' = STB $ let
                           STB m' = m
                         in
                         \bs gs
                         -> (m' bs gs' >>= \(bs', _, a) -> return (bs', gs, a))


-- error and exception handling
-- ----------------------------

--  * we exploit the `UserError' component of `IOError' for fatal errors
--
--  * we distinguish exceptions and user-defined fatal errors
--
--   - exceptions are meant to be caught in order to recover the currently
--     executed operation; they turn into fatal errors if they are not caught;
--     exceptions are tagged, which allows to deal with multiple kinds of
--     exceptions at the same time and to handle them differently
--   - user-defined fatal errors abort the currently executed operation, but
--     they may be caught at the top-level in order to terminate gracefully or
--     to invoke another operation; there is no special support for different
--     handling of different kinds of fatal-errors
--
--  * the costs for fatal error handling are already incurred by the `IO' monad;
--   the costs for exceptions mainly is the case distinction in the definition
--   of `+>='
--

-- throw an exception with the given tag and message (EXPORTED)
--
throwExc         :: String -> String -> STB bs gs a
throwExc tag msg  = STB $ \bs gs -> return (bs, gs, Left (tag, msg))

-- raise a fatal user-defined error (EXPORTED)
--
--  * such an error my be caught and handled using `fatalsHandeledBy'
--
fatal   :: String -> STB bs gs a
fatal s  = liftIO (ioError (userError s))

-- the given state transformer is executed and exceptions with the given tag
-- are caught using the provided handler, which expects to get the exception
-- message (EXPORTED)
--
--  * the base and generic state observed by the exception handler is *modified*
--   by the failed state transformer upto the point where the exception was
--   thrown (this semantics is the only reasonable when it should be possible
--   to use updating for maintaining the state)
--
catchExc                  :: STB bs gs a
                          -> (String, String -> STB bs gs a)
                          -> STB bs gs a
catchExc m (tag, handler)  =
  STB $ \bs gs
        -> let
             STB m' = m
           in
           m' bs gs >>= \state@(bs', gs', res) ->
           case res of
             Left (tag', msg) -> if (tag == tag')       -- exception with...
                                 then
                                   let
                                     STB handler' = handler msg
                                   in
                                   handler' bs' gs'     -- correct tag, catch
                                 else
                                   return state         -- wrong tag, rethrow
             Right _          -> return state           -- no exception

-- given a state transformer that may raise fatal errors and an error handler
-- for fatal errors, execute the state transformer and apply the error handler
-- when a fatal error occurs (EXPORTED)
--
--  * fatal errors are IO monad errors and errors raised by `fatal' as well as
--   uncaught exceptions
--
--  * the base and generic state observed by the error handler is *in contrast
--   to `catch'* the state *before* the state transformer is applied
--
fatalsHandledBy :: STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a
fatalsHandledBy m handler  =
  STB $ \bs gs
        -> (let
              STB m' = m
            in
            m' bs gs >>= \state@(gs', bs', res) ->
            case res of
              Left  (tag, msg) -> let
                                    err = userError ("Exception `" ++ tag
                                                     ++ "': " ++ msg)
                                  in
                                  ioError err
              Right a          -> return state
            )
            `catch` (\err -> let
                               STB handler' = handler err
                             in
                             handler' bs gs)


-- list mutable variables and arrays stuff into `STB'; all (EXPORTED)
-- ------------------------------------------------------------------

type MVar a   = IORef a

newMV   :: a -> STB bs gs (MVar a)
newMV x  = liftIO (newIORef x)

readMV    :: MVar a -> STB bs gs a
readMV mv  = liftIO (readIORef mv)

assignMV      :: MVar a -> a -> STB bs gs ()
assignMV mv x  = liftIO (writeIORef mv x)
