--  Compiler Toolkit: compiler state management
--
--  Author : Manuel M. T. Chakravarty
--  Created: 2 November 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 forms the interface to the state base of the compiler. It is
--  used by all modules that are not directly involved in implementing the
--  state base. It provides a state transformer that is capable of doing I/O
--  and provides facilities such as error handling and compiler switch
--  management.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  * The monad `PreCST' is reexported abstractly.
--
--  * Errors are dumped to `stdout' to facilitate communication with other
--    processes (see `Interact').
--
--- TODO ----------------------------------------------------------------------
--

module State (-- the PreCST monad
              --
              PreCST,                                      -- reexport ABSTRACT
              nop, yield, (+>=), (+>), fixCST,             -- reexport
              throwExc, fatal, catchExc, fatalsHandledBy,  -- reexport lifted
              readCST, writeCST, transCST, run, runCST,
              StateTrans.MVar,                             -- reexport
              newMV, readMV, assignMV,                     -- reexport lifted
              --
              -- reexport compiler I/O
              --
              module CIO,
              liftIO,
              --
              -- identification
              --
              getId,
              --
              -- error management
              --
              raise, raiseWarning, raiseError, raiseFatal, showErrors,
              errorsPresent,
              --
              -- extra state management
              --
              readExtra, updExtra,
              --
              -- name supplies
              --
              getNameSupply)
where

import Data.Ix
import Control.Monad       (when)
import Data.List        (sort)

import BaseVersion (version, copyright, disclaimer)
import Config      (errorLimit)
import Position    (Position)
import UNames      (NameSupply,
                    rootSupply, splitSupply)
import StateTrans  (STB,
                    readBase, transBase, runSTB)
import qualified
       StateTrans  (interleave, throwExc, fatal, catchExc, fatalsHandledBy,
                    MVar, newMV, readMV, assignMV)
import StateBase   (PreCST(..), ErrorState(..), BaseState(..),
                    nop, yield, (+>=), (+>), fixCST,
                    unpackCST, readCST, writeCST, transCST,
                    liftIO)
import CIO
import Errors      (ErrorLvl(..), Error, makeError, errorLvl, showError)


-- state used in the whole compiler
-- --------------------------------

-- initialization
--
--  * it gets the version information and the initial extra state as arguments
--
initialBaseState        :: (String, String, String) -> e -> BaseState e
initialBaseState :: (String, String, String) -> e -> BaseState e
initialBaseState (String, String, String)
vcd e
es  = BaseState :: forall e.
(String, String, String)
-> (String, String, String)
-> ErrorState
-> [NameSupply]
-> e
-> BaseState e
BaseState {
                             idTKBS :: (String, String, String)
idTKBS     = (String
version, String
copyright, String
disclaimer),
                             idBS :: (String, String, String)
idBS       = (String, String, String)
vcd,
                             errorsBS :: ErrorState
errorsBS   = ErrorState
initialErrorState,
                             suppliesBS :: [NameSupply]
suppliesBS = NameSupply -> [NameSupply]
splitSupply NameSupply
rootSupply,
                             extraBS :: e
extraBS    = e
es
                        }


-- executing state transformers
-- ----------------------------

-- initiate a complete run of the ToolKit represented by a PreCST with a void
-- generic component (type `()') (EXPORTED)
--
--  * fatals errors are explicitly caught and reported (instead of letting them
--   through to the runtime system)
--
run            :: (String, String, String) -> e -> PreCST e () a -> IO a
run :: (String, String, String) -> e -> PreCST e () a -> IO a
run (String, String, String)
vcd e
es PreCST e () a
cst  = STB (BaseState e) () a -> BaseState e -> () -> IO a
forall bs gs a. STB bs gs a -> bs -> gs -> IO a
runSTB STB (BaseState e) () a
m ((String, String, String) -> e -> BaseState e
forall e. (String, String, String) -> e -> BaseState e
initialBaseState (String, String, String)
vcd e
es) ()
  where
    m :: STB (BaseState e) () a
m = PreCST e () a -> STB (BaseState e) () a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST (
          PreCST e () a
cst
          PreCST e () a -> (IOError -> PreCST e () a) -> PreCST e () a
forall e s a.
PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
`fatalsHandledBy` \IOError
err ->
            String -> PreCST e () ()
forall e s. String -> PreCST e s ()
putStrCIO (String
"Uncaught fatal error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOError -> String
forall a. Show a => a -> String
show IOError
err)    PreCST e () () -> PreCST e () a -> PreCST e () a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
            ExitCode -> PreCST e () a
forall e s a. ExitCode -> PreCST e s a
exitWithCIO (Int -> ExitCode
ExitFailure Int
1)
        )

-- run a PreCST in the context of another PreCST (EXPORTED)
--
-- the generic state of the enclosing PreCST is preserved while the
-- computation of the PreCST passed as an argument is interleaved in the
-- execution of the enclosing one
--
runCST     :: PreCST e s a -> s -> PreCST e s' a
runCST :: PreCST e s a -> s -> PreCST e s' a
runCST PreCST e s a
m s
s  = STB (BaseState e) s' a -> PreCST e s' a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s' a -> PreCST e s' a)
-> STB (BaseState e) s' a -> PreCST e s' a
forall a b. (a -> b) -> a -> b
$ STB (BaseState e) s a -> s -> STB (BaseState e) s' a
forall bs gs' a gs. STB bs gs' a -> gs' -> STB bs gs a
StateTrans.interleave (PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST PreCST e s a
m) s
s


-- exception handling
-- ------------------

-- throw an exception with the given tag and message (EXPORTED)
--
throwExc       :: String -> String -> PreCST e s a
throwExc :: String -> String -> PreCST e s a
throwExc String
s1 String
s2  = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> STB (BaseState e) s a -> PreCST e s a
forall a b. (a -> b) -> a -> b
$ String -> String -> STB (BaseState e) s a
forall bs gs a. String -> String -> STB bs gs a
StateTrans.throwExc String
s1 String
s2

-- raise a fatal user-defined error (EXPORTED)
--
--  * such an error my be caught and handled using `fatalsHandeledBy'
--
fatal :: String -> PreCST e s a
fatal :: String -> PreCST e s a
fatal  = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> (String -> STB (BaseState e) s a) -> String -> PreCST e s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> STB (BaseState e) s a
forall bs gs a. String -> STB bs gs a
StateTrans.fatal

-- 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 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     :: PreCST e s a
             -> (String, String -> PreCST e s a)
             -> PreCST e s a
catchExc :: PreCST e s a -> (String, String -> PreCST e s a) -> PreCST e s a
catchExc PreCST e s a
m (String
s, String -> PreCST e s a
h)  = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> STB (BaseState e) s a -> PreCST e s a
forall a b. (a -> b) -> a -> b
$ STB (BaseState e) s a
-> (String, String -> STB (BaseState e) s a)
-> STB (BaseState e) s a
forall bs gs a.
STB bs gs a -> (String, String -> STB bs gs a) -> STB bs gs a
StateTrans.catchExc (PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST PreCST e s a
m) (String
s, PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST (PreCST e s a -> STB (BaseState e) s a)
-> (String -> PreCST e s a) -> String -> STB (BaseState e) s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> PreCST e s a
h)

-- 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 :: PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
fatalsHandledBy :: PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a
fatalsHandledBy PreCST e s a
m IOError -> PreCST e s a
h  = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> STB (BaseState e) s a -> PreCST e s a
forall a b. (a -> b) -> a -> b
$ STB (BaseState e) s a
-> (IOError -> STB (BaseState e) s a) -> STB (BaseState e) s a
forall bs gs a.
STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a
StateTrans.fatalsHandledBy STB (BaseState e) s a
m' IOError -> STB (BaseState e) s a
h'
                       where
                         m' :: STB (BaseState e) s a
m' = PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST PreCST e s a
m
                         h' :: IOError -> STB (BaseState e) s a
h' = PreCST e s a -> STB (BaseState e) s a
forall e s a. PreCST e s a -> STB (BaseState e) s a
unpackCST (PreCST e s a -> STB (BaseState e) s a)
-> (IOError -> PreCST e s a) -> IOError -> STB (BaseState e) s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> PreCST e s a
h

-- mutable variables
-- -----------------

-- lifted mutable variable functions (EXPORTED)
--

newMV :: a -> PreCST e s (StateTrans.MVar a)
newMV :: a -> PreCST e s (MVar a)
newMV  = STB (BaseState e) s (MVar a) -> PreCST e s (MVar a)
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s (MVar a) -> PreCST e s (MVar a))
-> (a -> STB (BaseState e) s (MVar a)) -> a -> PreCST e s (MVar a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> STB (BaseState e) s (MVar a)
forall a bs gs. a -> STB bs gs (MVar a)
StateTrans.newMV

readMV :: StateTrans.MVar a -> PreCST e s a
readMV :: MVar a -> PreCST e s a
readMV  = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> (MVar a -> STB (BaseState e) s a) -> MVar a -> PreCST e s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar a -> STB (BaseState e) s a
forall a bs gs. MVar a -> STB bs gs a
StateTrans.readMV

assignMV     :: StateTrans.MVar a -> a -> PreCST e s ()
assignMV :: MVar a -> a -> PreCST e s ()
assignMV MVar a
m a
a  = STB (BaseState e) s () -> PreCST e s ()
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s () -> PreCST e s ())
-> STB (BaseState e) s () -> PreCST e s ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> STB (BaseState e) s ()
forall a bs gs. MVar a -> a -> STB bs gs ()
StateTrans.assignMV MVar a
m a
a

-- read identification
-- -------------------

-- read identification information (EXPORT)
--
getId :: PreCST e s (String, String, String)
getId :: PreCST e s (String, String, String)
getId  = STB (BaseState e) s (String, String, String)
-> PreCST e s (String, String, String)
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s (String, String, String)
 -> PreCST e s (String, String, String))
-> STB (BaseState e) s (String, String, String)
-> PreCST e s (String, String, String)
forall a b. (a -> b) -> a -> b
$
         (BaseState e -> (String, String, String))
-> STB (BaseState e) s (String, String, String)
forall bs a gs. (bs -> a) -> STB bs gs a
readBase (BaseState e -> (String, String, String)
forall e. BaseState e -> (String, String, String)
idBS)


-- manipulating the error state
-- ----------------------------

-- the lowest level of errors is `WarningErr', but it is meaningless as long as
-- the the list of errors is empty
--
initialErrorState :: ErrorState
initialErrorState :: ErrorState
initialErrorState  = ErrorLvl -> Int -> [Error] -> ErrorState
ErrorState ErrorLvl
WarningErr Int
0 []

-- raise an error (EXPORTED)
--
--  * a fatal error is reported immediately; see `raiseFatal'
--
raise     :: Error -> PreCST e s ()
raise :: Error -> PreCST e s ()
raise Error
err  = case Error -> ErrorLvl
errorLvl Error
err of
               ErrorLvl
WarningErr  -> Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 Error
err
               ErrorLvl
ErrorErr    -> Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 Error
err
               ErrorLvl
FatalErr    -> String -> Error -> PreCST e s ()
forall e s a. String -> Error -> PreCST e s a
raiseFatal0 String
"Generic fatal error." Error
err

-- raise a warning (see `raiseErr') (EXPORTED)
--
raiseWarning         :: Position -> [String] -> PreCST e s ()
raiseWarning :: Position -> [String] -> PreCST e s ()
raiseWarning Position
pos [String]
msg  = Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 (ErrorLvl -> Position -> [String] -> Error
makeError ErrorLvl
WarningErr Position
pos [String]
msg)

-- raise an error (see `raiseErr') (EXPORTED)
--
raiseError         :: Position -> [String] -> PreCST e s ()
raiseError :: Position -> [String] -> PreCST e s ()
raiseError Position
pos [String]
msg  = Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 (ErrorLvl -> Position -> [String] -> Error
makeError ErrorLvl
ErrorErr Position
pos [String]
msg)

-- raise a fatal compilation error (EXPORTED)
--
--  * the error is together with the up-to-now accumulated errors are reported
--   as part of the error message of the fatal error exception
--
--  * the current thread of control is discarded and control is passed to the
--   innermost handler for fatal errors
--
--  * the first argument must contain a short description of the error, while
--   the second and third argument are like the two arguments to `raise'
--
raiseFatal                :: String -> Position -> [String] -> PreCST e s a
raiseFatal :: String -> Position -> [String] -> PreCST e s a
raiseFatal String
short Position
pos [String]
long  = String -> Error -> PreCST e s a
forall e s a. String -> Error -> PreCST e s a
raiseFatal0 String
short (ErrorLvl -> Position -> [String] -> Error
makeError ErrorLvl
FatalErr Position
pos [String]
long)

-- raise a fatal error; internal version that gets an abstract error
--
raiseFatal0           :: String -> Error -> PreCST e s a
raiseFatal0 :: String -> Error -> PreCST e s a
raiseFatal0 String
short Error
err  = do
                           Error -> PreCST e s ()
forall e s. Error -> PreCST e s ()
raise0 Error
err
                           String
errmsgs <- PreCST e s String
forall e s. PreCST e s String
showErrors
                           String -> PreCST e s a
forall e s a. String -> PreCST e s a
fatal (String
short String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errmsgs)

-- raise an error; internal version, doesn't check whether the error is fatal
--
--  * the error is entered into the compiler state and a fatal error is
--   triggered if the `errorLimit' is reached
--
raise0     :: Error -> PreCST e s ()
raise0 :: Error -> PreCST e s ()
raise0 Error
err  = do
                Int
noOfErrs <- STB (BaseState e) s Int -> PreCST e s Int
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s Int -> PreCST e s Int)
-> STB (BaseState e) s Int -> PreCST e s Int
forall a b. (a -> b) -> a -> b
$ (BaseState e -> (BaseState e, Int)) -> STB (BaseState e) s Int
forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase BaseState e -> (BaseState e, Int)
forall e. BaseState e -> (BaseState e, Int)
doRaise
                Bool -> PreCST e s () -> PreCST e s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
noOfErrs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
errorLimit) (PreCST e s () -> PreCST e s ()) -> PreCST e s () -> PreCST e s ()
forall a b. (a -> b) -> a -> b
$ do
                  String
errmsgs <- PreCST e s String
forall e s. PreCST e s String
showErrors
                  String -> PreCST e s ()
forall e s a. String -> PreCST e s a
fatal (String
"Error limit of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
errorLimit
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" errors has been reached.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errmsgs)
  where
    doRaise    :: BaseState e -> (BaseState e, Int)
    doRaise :: BaseState e -> (BaseState e, Int)
doRaise BaseState e
bs  = let
                    lvl :: ErrorLvl
lvl                        = Error -> ErrorLvl
errorLvl Error
err
                    ErrorState ErrorLvl
wlvl Int
no [Error]
errs    = BaseState e -> ErrorState
forall e. BaseState e -> ErrorState
errorsBS BaseState e
bs
                    wlvl' :: ErrorLvl
wlvl'                      = ErrorLvl -> ErrorLvl -> ErrorLvl
forall a. Ord a => a -> a -> a
max ErrorLvl
wlvl ErrorLvl
lvl
                    no' :: Int
no'                        = Int
no Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if ErrorLvl
lvl ErrorLvl -> ErrorLvl -> Bool
forall a. Ord a => a -> a -> Bool
> ErrorLvl
WarningErr
                                                      then Int
1 else Int
0
                    errs' :: [Error]
errs'                      = Error
err Error -> [Error] -> [Error]
forall a. a -> [a] -> [a]
: [Error]
errs
                  in
                    (BaseState e
bs {errorsBS :: ErrorState
errorsBS = (ErrorLvl -> Int -> [Error] -> ErrorState
ErrorState ErrorLvl
wlvl' Int
no' [Error]
errs')}, Int
no')

-- yield a string containing the collected error messages (EXPORTED)
--
--  * the error state is reset in this process
--
showErrors :: PreCST e s String
showErrors :: PreCST e s String
showErrors  = STB (BaseState e) s String -> PreCST e s String
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s String -> PreCST e s String)
-> STB (BaseState e) s String -> PreCST e s String
forall a b. (a -> b) -> a -> b
$ do
                ErrorState ErrorLvl
wlvl Int
no [Error]
errs <- (BaseState e -> (BaseState e, ErrorState))
-> STB (BaseState e) s ErrorState
forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase BaseState e -> (BaseState e, ErrorState)
forall e. BaseState e -> (BaseState e, ErrorState)
extractErrs
                String -> STB (BaseState e) s String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> STB (BaseState e) s String)
-> String -> STB (BaseState e) s String
forall a b. (a -> b) -> a -> b
$ ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) String -> String
forall a. a -> a
id ((String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
showString ([Error] -> [String]
errsToStrs [Error]
errs)) String
""
              where
                extractErrs    :: BaseState e -> (BaseState e, ErrorState)
                extractErrs :: BaseState e -> (BaseState e, ErrorState)
extractErrs BaseState e
bs  = (BaseState e
bs {errorsBS :: ErrorState
errorsBS = ErrorState
initialErrorState},
                                   BaseState e -> ErrorState
forall e. BaseState e -> ErrorState
errorsBS BaseState e
bs)

                errsToStrs      :: [Error] -> [String]
                errsToStrs :: [Error] -> [String]
errsToStrs [Error]
errs  = ((Error -> String) -> [Error] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Error -> String
showError ([Error] -> [String])
-> ([Error] -> [Error]) -> [Error] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Error] -> [Error]
forall a. Ord a => [a] -> [a]
sort) [Error]
errs

-- inquire if there was already an error of at least level `ErrorErr' raised
-- (EXPORTED)
--
errorsPresent :: PreCST e s Bool
errorsPresent :: PreCST e s Bool
errorsPresent  = STB (BaseState e) s Bool -> PreCST e s Bool
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s Bool -> PreCST e s Bool)
-> STB (BaseState e) s Bool -> PreCST e s Bool
forall a b. (a -> b) -> a -> b
$ do
                   ErrorState ErrorLvl
wlvl Int
no [Error]
_ <- (BaseState e -> ErrorState) -> STB (BaseState e) s ErrorState
forall bs a gs. (bs -> a) -> STB bs gs a
readBase BaseState e -> ErrorState
forall e. BaseState e -> ErrorState
errorsBS
                   Bool -> STB (BaseState e) s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STB (BaseState e) s Bool)
-> Bool -> STB (BaseState e) s Bool
forall a b. (a -> b) -> a -> b
$ ErrorLvl
wlvl ErrorLvl -> ErrorLvl -> Bool
forall a. Ord a => a -> a -> Bool
>= ErrorLvl
ErrorErr


-- manipulating the extra state
-- ----------------------------

-- apply a reader function to the extra state and yield the reader's result
-- (EXPORTED)
--
readExtra    :: (e -> a) -> PreCST e s a
readExtra :: (e -> a) -> PreCST e s a
readExtra e -> a
rf  = STB (BaseState e) s a -> PreCST e s a
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s a -> PreCST e s a)
-> STB (BaseState e) s a -> PreCST e s a
forall a b. (a -> b) -> a -> b
$ (BaseState e -> a) -> STB (BaseState e) s a
forall bs a gs. (bs -> a) -> STB bs gs a
readBase (\BaseState e
bs ->
                        (e -> a
rf (e -> a) -> (BaseState e -> e) -> BaseState e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseState e -> e
forall e. BaseState e -> e
extraBS) BaseState e
bs
                      )

-- apply an update function to the extra state (EXPORTED)
--
updExtra    :: (e -> e) -> PreCST e s ()
updExtra :: (e -> e) -> PreCST e s ()
updExtra e -> e
uf  = STB (BaseState e) s () -> PreCST e s ()
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s () -> PreCST e s ())
-> STB (BaseState e) s () -> PreCST e s ()
forall a b. (a -> b) -> a -> b
$ (BaseState e -> (BaseState e, ())) -> STB (BaseState e) s ()
forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase (\BaseState e
bs ->
                       let
                         es :: e
es = BaseState e -> e
forall e. BaseState e -> e
extraBS BaseState e
bs
                       in
                       (BaseState e
bs {extraBS :: e
extraBS = e -> e
uf e
es}, ())
                     )


-- name supplies
-- -------------

-- Get a name supply out of the base state (EXPORTED)
--
getNameSupply :: PreCST e s NameSupply
getNameSupply :: PreCST e s NameSupply
getNameSupply  = STB (BaseState e) s NameSupply -> PreCST e s NameSupply
forall e s a. STB (BaseState e) s a -> PreCST e s a
CST (STB (BaseState e) s NameSupply -> PreCST e s NameSupply)
-> STB (BaseState e) s NameSupply -> PreCST e s NameSupply
forall a b. (a -> b) -> a -> b
$ (BaseState e -> (BaseState e, NameSupply))
-> STB (BaseState e) s NameSupply
forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase (\BaseState e
bs ->
                         let
                           NameSupply
supply : [NameSupply]
supplies = BaseState e -> [NameSupply]
forall e. BaseState e -> [NameSupply]
suppliesBS BaseState e
bs
                         in
                         (BaseState e
bs {suppliesBS :: [NameSupply]
suppliesBS = [NameSupply]
supplies}, NameSupply
supply)
                       )