--  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 :: forall a b. (a -> b) -> STB bs gs a -> STB bs gs b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative (STB bs gs) where
  pure :: forall a. a -> STB bs gs a
pure  = forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: forall a b. STB bs gs (a -> b) -> STB bs gs a -> STB bs gs b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (STB bs gs) where
  return :: forall a. a -> STB bs gs a
return = forall a bs gs. a -> STB bs gs a
yield
  >>= :: forall a b. STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
(>>=)  = forall bs gs a b. STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
(+>=)
  >> :: forall a b. STB bs gs a -> STB bs gs b -> STB bs gs b
(>>)   = forall bs gs a b. STB bs gs a -> STB bs gs b -> STB bs gs b
(+>)

-- the monad's unit
--
yield   :: a -> STB bs gs a
yield :: forall a bs gs. a -> STB bs gs a
yield a
a  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. b -> Either a b
Right a
a)

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

-- bind dropping the result of the first state transfomer
--
(+>)   :: STB bs gs a -> STB bs gs b -> STB bs gs b
STB bs gs a
k +> :: forall bs gs a b. STB bs gs a -> STB bs gs b -> STB bs gs b
+> STB bs gs b
m  = STB bs gs a
k forall bs gs a b. STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
+>= forall a b. a -> b -> a
const STB bs gs b
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 :: forall a bs gs. (a -> STB bs gs a) -> STB bs gs a
fixSTB a -> STB bs gs a
m  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs
                  -> forall a. (a -> IO a) -> IO a
fixIO (\(bs, gs, Either (String, String) a)
future -> let
                                         STB bs -> gs -> IO (bs, gs, Either (String, String) a)
m' = a -> STB bs gs a
m (forall {a} {b} {a} {b}. (a, b, Either a b) -> b
extractResult (bs, gs, Either (String, String) a)
future)
                                       in
                                       bs -> gs -> IO (bs, gs, Either (String, String) a)
m' bs
bs gs
gs)
            where
              extractResult :: (a, b, Either a b) -> b
extractResult (a
_, b
_, Right b
r) = b
r
              extractResult (a
_, b
_, Left a
_ ) = forall a. String -> a
interr String
"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 :: forall bs a gs. (bs -> a) -> STB bs gs a
readBase bs -> a
f  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. b -> Either a b
Right (bs -> a
f bs
bs))

-- given a new base state, inject it into an STB monad
--
writeBase     :: bs -> STB bs gs ()
writeBase :: forall bs gs. bs -> STB bs gs ()
writeBase bs
bs'  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
_ gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs, forall a b. b -> Either a b
Right ())

-- given a transformer function for the base state, wrap it into an STB monad
--
transBase   :: (bs -> (bs, a)) -> STB bs gs a
transBase :: forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase bs -> (bs, a)
f  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> let
                                 (bs
bs', a
a) = bs -> (bs, a)
f bs
bs
                               in
                                 forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs, forall a b. b -> Either a b
Right a
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 :: forall gs a bs. (gs -> a) -> STB bs gs a
readGeneric gs -> a
f  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. b -> Either a b
Right (gs -> a
f gs
gs))

-- given a new generic state, inject it into an STB monad
--
writeGeneric     :: gs -> STB bs gs ()
writeGeneric :: forall gs bs. gs -> STB bs gs ()
writeGeneric gs
gs'  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs', forall a b. b -> Either a b
Right ())

-- given a transformer function for the generic state, wrap it into an STB
-- monad
--
transGeneric   :: (gs -> (gs, a)) -> STB bs gs a
transGeneric :: forall gs a bs. (gs -> (gs, a)) -> STB bs gs a
transGeneric gs -> (gs, a)
f  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> let
                                    (gs
gs', a
a) = gs -> (gs, a)
f gs
gs
                                  in
                                  forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs', forall a b. b -> Either a b
Right a
a)


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

-- lifts an `IO' state transformer into `STB'
--
liftIO   :: IO a -> STB bs gs a
liftIO :: forall a bs gs. IO a -> STB bs gs a
liftIO IO a
m  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> IO a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. b -> Either a b
Right a
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 :: forall bs gs a. STB bs gs a -> bs -> gs -> IO a
runSTB STB bs gs a
m bs
bs gs
gs  = let
                    STB bs -> gs -> IO (bs, gs, Either (String, String) a)
m' = STB bs gs a
m
                  in
                  bs -> gs -> IO (bs, gs, Either (String, String) a)
m' bs
bs gs
gs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(bs
_, gs
_, Either (String, String) a
res) ->
                  case Either (String, String) a
res of
                    Left  (String
tag, String
msg) -> let
                                          err :: IOError
err = String -> IOError
userError (String
"Exception `"
                                                           forall a. [a] -> [a] -> [a]
++ String
tag forall a. [a] -> [a] -> [a]
++ String
"': "
                                                           forall a. [a] -> [a] -> [a]
++ String
msg)
                                        in
                                        forall a. IOError -> IO a
ioError IOError
err
                    Right a
a          -> forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: forall bs gs' a gs. STB bs gs' a -> gs' -> STB bs gs a
interleave STB bs gs' a
m gs'
gs' = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ let
                           STB bs -> gs' -> IO (bs, gs', Either (String, String) a)
m' = STB bs gs' a
m
                         in
                         \bs
bs gs
gs
                         -> (bs -> gs' -> IO (bs, gs', Either (String, String) a)
m' bs
bs gs'
gs' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(bs
bs', gs'
_, Either (String, String) a
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs, Either (String, String) a
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 :: forall bs gs a. String -> String -> STB bs gs a
throwExc String
tag String
msg  = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. a -> Either a b
Left (String
tag, String
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 :: forall bs gs a. String -> STB bs gs a
fatal String
s  = forall a bs gs. IO a -> STB bs gs a
liftIO (forall a. IOError -> IO a
ioError (String -> IOError
userError String
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 :: forall bs gs a.
STB bs gs a -> (String, String -> STB bs gs a) -> STB bs gs a
catchExc STB bs gs a
m (String
tag, String -> STB bs gs a
handler)  =
  forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs
        -> let
             STB bs -> gs -> IO (bs, gs, Either (String, String) a)
m' = STB bs gs a
m
           in
           bs -> gs -> IO (bs, gs, Either (String, String) a)
m' bs
bs gs
gs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \state :: (bs, gs, Either (String, String) a)
state@(bs
bs', gs
gs', Either (String, String) a
res) ->
           case Either (String, String) a
res of
             Left (String
tag', String
msg) -> if (String
tag forall a. Eq a => a -> a -> Bool
== String
tag')       -- exception with...
                                 then
                                   let
                                     STB bs -> gs -> IO (bs, gs, Either (String, String) a)
handler' = String -> STB bs gs a
handler String
msg
                                   in
                                   bs -> gs -> IO (bs, gs, Either (String, String) a)
handler' bs
bs' gs
gs'     -- correct tag, catch
                                 else
                                   forall (m :: * -> *) a. Monad m => a -> m a
return (bs, gs, Either (String, String) a)
state         -- wrong tag, rethrow
             Right a
_          -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs, gs, Either (String, String) a)
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 :: forall bs gs a.
STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a
fatalsHandledBy STB bs gs a
m IOError -> STB bs gs a
handler  =
  forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs
        -> (let
              STB bs -> gs -> IO (bs, gs, Either (String, String) a)
m' = STB bs gs a
m
            in
            bs -> gs -> IO (bs, gs, Either (String, String) a)
m' bs
bs gs
gs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \state :: (bs, gs, Either (String, String) a)
state@(bs
gs', gs
bs', Either (String, String) a
res) ->
            case Either (String, String) a
res of
              Left  (String
tag, String
msg) -> let
                                    err :: IOError
err = String -> IOError
userError (String
"Exception `" forall a. [a] -> [a] -> [a]
++ String
tag
                                                     forall a. [a] -> [a] -> [a]
++ String
"': " forall a. [a] -> [a] -> [a]
++ String
msg)
                                  in
                                  forall a. IOError -> IO a
ioError IOError
err
              Right a
a          -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs, gs, Either (String, String) a)
state
            )
            forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\IOError
err -> let
                               STB bs -> gs -> IO (bs, gs, Either (String, String) a)
handler' = IOError -> STB bs gs a
handler IOError
err
                             in
                             bs -> gs -> IO (bs, gs, Either (String, String) a)
handler' bs
bs gs
gs)


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

type MVar a   = IORef a

newMV   :: a -> STB bs gs (MVar a)
newMV :: forall a bs gs. a -> STB bs gs (MVar a)
newMV a
x  = forall a bs gs. IO a -> STB bs gs a
liftIO (forall a. a -> IO (IORef a)
newIORef a
x)

readMV    :: MVar a -> STB bs gs a
readMV :: forall a bs gs. MVar a -> STB bs gs a
readMV MVar a
mv  = forall a bs gs. IO a -> STB bs gs a
liftIO (forall a. IORef a -> IO a
readIORef MVar a
mv)

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