    --  Compiler Toolkit: compiler state management basics
    --
    --  Author : Manuel M. T. Chakravarty
    --  Created: 7 November 97
    --
    --  Version $Revision: 1.1.1.1 $
    --
    --  Copyright (C) [1997..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 types and services used to realize the state
    --  management of the compiler.
    --
    --- DOCU ----------------------------------------------------------------------
    --
    --  language: Haskell 98
    --
    --  * The monad `PreCST' is an instance of `STB' where the base state is fixed.
    --    However, the base state itself is parametrized by an extra state
    --    component that can be instantiated by the compiler that uses the toolkit
    --    (to store information like compiler switches) -- this is the reason for
    --    adding the prefix `Pre'.
    --
    --  * The module exports the details of the `BaseState' etc as they have to be
    --    know by `State'.  The latter ensures the necessary abstraction for
    --    modules that do not belong to the state management.
    --
    --  * Due to this module, the state management modules can share internal
    --    information about the data types hidden to the rest of the system.
    --
    --  * The following state components are maintained:
    --
    --    + idBS (triple of strings)        -- version, copyright, and disclaimer
    --    + errorsBS (type `ErrorState')    -- keeps track of raised errors
    --    + namesBS (type `NameSupply')     -- provides unique names
    --    + extraBS (generic type)          -- extra compiler-dependent state
    --                                         information, e.g., for compiler
    --                                         switches
    --
    --- TODO ----------------------------------------------------------------------
    --

    module StateBase (PreCST(..), ErrorState(..), BaseState(..),
                      nop, yield, (+>=), (+>), fixCST,
                      unpackCST, readCST, writeCST, transCST, liftIO)
    where

    import Control.Applicative (Applicative(..))
    import Control.Monad (liftM, ap)
    import Control.Monad.Fail (MonadFail (..))

    import Position   (Position)
    import UNames     (NameSupply)
    import StateTrans (STB,
                       fixSTB, readGeneric, writeGeneric, transGeneric, readBase,
                       transBase)
    import qualified
           StateTrans (liftIO)
    import Errors     (ErrorLvl(..), Error)

    infixr 1 +>=, +>

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

    -- form of the error state
    --
    --  * when no error was raised yet, the error level is the lowest possible one
    --
    data ErrorState = ErrorState ErrorLvl    -- worst error level that was raised
                                 Int         -- number of errors (excl warnings)
                                 [Error]     -- already raised errors

    -- base state (EXPORTED)
    --
    data BaseState e = BaseState {
                         forall e. BaseState e -> (String, String, String)
    idTKBS     :: (String, String, String),  -- toolkit id
                         forall e. BaseState e -> (String, String, String)
    idBS       :: (String, String, String),  -- compiler id
                         forall e. BaseState e -> ErrorState
    errorsBS   :: ErrorState,
                         forall e. BaseState e -> [NameSupply]
    suppliesBS :: [NameSupply],
                         forall e. BaseState e -> e
    extraBS    :: e                          -- extra state
                     }

    -- the compiler state transformer (EXPORTED)
    --

    newtype PreCST e s a = CST (STB (BaseState e) s a)

    instance Functor (PreCST e s) where
      fmap :: forall a b. (a -> b) -> PreCST e s a -> PreCST e s b
    fmap = (a -> b) -> PreCST e s a -> PreCST e s b
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM

    instance Applicative (PreCST e s) where
      pure :: forall a. a -> PreCST e s a
    pure  = a -> PreCST e s a
    forall a. a -> PreCST e s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
      <*> :: forall a b. PreCST e s (a -> b) -> PreCST e s a -> PreCST e s b
    (<*>) = PreCST e s (a -> b) -> PreCST e s a -> PreCST e s b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Monad (PreCST e s) where
      return :: forall a. a -> PreCST e s a
    return = a -> PreCST e s a
    forall a e s. a -> PreCST e s a
    yield
      >>= :: forall a b. PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b
    (>>=)  = PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b
    forall e s a b. PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b
    (+>=)
      >> :: forall a b. PreCST e s a -> PreCST e s b -> PreCST e s b
    (>>)   = PreCST e s a -> PreCST e s b -> PreCST e s b
    forall e s a b. PreCST e s a -> PreCST e s b -> PreCST e s b
    (+>)

    instance MonadFail (PreCST e s) where
      fail :: forall a. String -> PreCST e s a
    fail = String -> PreCST e s a
    forall a. HasCallStack => String -> a
    error

    -- unwrapper coercion function (EXPORTED)
    --
    unpackCST   :: PreCST e s a -> STB (BaseState e) s a
    unpackCST :: forall e s a. PreCST e s a -> STB (BaseState e) s a
    unpackCST PreCST e s a
    m  = let CST STB (BaseState e) s a
    m' = PreCST e s a
    m in STB (BaseState e) s a
    m'

    -- monad operations
    -- ----------------

    -- the monad's unit
    --
    yield   :: a -> PreCST e s a
    yield :: forall a e s. a -> PreCST e s a
    yield a
    a  = 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
    $ a -> STB (BaseState e) s a
    forall a. a -> STB (BaseState e) s a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    a

    -- the monad's bind
    --
    (+>=)   :: PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b
    PreCST e s a
    m +>= :: forall e s a b. PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b
    +>= a -> PreCST e s b
    k  = STB (BaseState e) s b -> PreCST e s b
    forall e s a. STB (BaseState e) s a -> PreCST e s a
    CST (STB (BaseState e) s b -> PreCST e s b)
    -> STB (BaseState e) s b -> PreCST e s b
    forall a b. (a -> b) -> a -> b
    $ 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 STB (BaseState e) s a
    -> (a -> STB (BaseState e) s b) -> STB (BaseState e) s b
    forall a b.
    STB (BaseState e) s a
    -> (a -> STB (BaseState e) s b) -> STB (BaseState e) s b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (\a
    a -> PreCST e s b -> STB (BaseState e) s b
    forall e s a. PreCST e s a -> STB (BaseState e) s a
    unpackCST (a -> PreCST e s b
    k a
    a))

    -- bind dropping the result of the first state transformer
    --
    (+>)   :: PreCST e s a -> PreCST e s b -> PreCST e s b
    PreCST e s a
    k +> :: forall e s a b. PreCST e s a -> PreCST e s b -> PreCST e s b
    +> PreCST e s b
    m  = PreCST e s a
    k PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b
    forall e s a b. PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b
    +>= PreCST e s b -> a -> PreCST e s b
    forall a b. a -> b -> a
    const PreCST e s b
    m

    -- unit with no result
    --
    nop :: PreCST e s ()
    nop :: forall e s. PreCST e s ()
    nop  = () -> PreCST e s ()
    forall a e s. a -> PreCST e s a
    yield ()

    -- fixpoint combinator in the monad (EXPORTED)
    --
    fixCST   :: (a -> PreCST e s a) -> PreCST e s a
    fixCST :: forall a e s. (a -> PreCST e s a) -> PreCST e s a
    fixCST a -> PreCST e s a
    m  = 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
    $ (a -> STB (BaseState e) s a) -> STB (BaseState e) s a
    forall a bs gs. (a -> STB bs gs a) -> STB bs gs a
    fixSTB (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)
    -> (a -> PreCST e s a) -> a -> STB (BaseState e) s a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> PreCST e s a
    m)

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

    -- given a reader function for the state, wrap it into an CST monad (EXPORTED)
    --
    readCST   :: (s -> a) -> PreCST e s a
    readCST :: forall s a e. (s -> a) -> PreCST e s a
    readCST s -> a
    f  = 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
    $ (s -> a) -> STB (BaseState e) s a
    forall gs a bs. (gs -> a) -> STB bs gs a
    readGeneric s -> a
    f

    -- given a new state, inject it into an CST monad (EXPORTED)
    --
    writeCST    :: s -> PreCST e s ()
    writeCST :: forall s e. s -> PreCST e s ()
    writeCST s
    s'  = 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
    $ s -> STB (BaseState e) s ()
    forall gs bs. gs -> STB bs gs ()
    writeGeneric s
    s'

    -- given a transformer function for the state, wrap it into an CST monad
    -- (EXPORTED)
    --
    transCST   :: (s -> (s, a)) -> PreCST e s a
    transCST :: forall s a e. (s -> (s, a)) -> PreCST e s a
    transCST s -> (s, a)
    f  = 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
    $ (s -> (s, a)) -> STB (BaseState e) s a
    forall gs a bs. (gs -> (gs, a)) -> STB bs gs a
    transGeneric s -> (s, a)
    f

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

    -- lifts an `IO' state transformer into `CST'
    --
    liftIO   :: IO a -> PreCST e s a
    liftIO :: forall a e s. IO a -> PreCST e s a
    liftIO IO a
    m  = 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
    $ (IO a -> STB (BaseState e) s a
    forall a bs gs. IO a -> STB bs gs a
    StateTrans.liftIO IO a
    m)