    --  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, bacause `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  = return
      (<*>) = ap

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

    -- 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 transfomer
    --
    (+>)   :: 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;
    --     execeptions are tagged, which allows to deal with multiple kinds of
    --     execeptions 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)