    --  C->Haskell Compiler: monad for the binding generator
    --
    --  Author : Manuel M T Chakravarty
    --  Derived: 18 February 2 (extracted from GenBind.hs)
    --
    --  Version $Revision: 1.1 $ from $Date: 2004/11/21 21:05:41 $
    --
    --  Copyright (c) [2002..2003] 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 modules defines the monad and related utility routines for the code
    --  that implements the expansion of the binding hooks.
    --
    --- DOCU ----------------------------------------------------------------------
    --
    --  language: Haskell 98
    --
    --  Translation table handling for enumerators:
    --  -------------------------------------------
    --
    --  First a translation table lookup on the original identifier of the
    --  enumerator is done.  If that doesn't match and the prefix can be removed
    --  from the identifier, a second lookup on the identifier without the prefix
    --  is performed.  If this also doesn't match, the identifier without prefix
    --  (possible after underscoreToCase translation is returned).  If there is a
    --  match, the translation (without any further stripping of prefix) is
    --  returned.
    --
    --  Pointer map
    --  -----------
    --
    --  Pointer hooks allow the use to customise the Haskell types to which C
    --  pointer types are mapped.  The globally maintained map essentially maps C
    --  pointer types to Haskell pointer types.  The representation of the Haskell
    --  types is defined by the `type' or `newtype' declaration emitted by the
    --  corresponding pointer hook.  However, the map stores a flag that tells
    --  whether the C type is itself the pointer type in question or whether it is
    --  pointers to this C type that should be mapped as specified.  The pointer
    --  map is dumped into and read from `.chi' files.
    --
    --  Haskell object map
    --  ------------------
    --
    --  Some features require information about Haskell objects defined by c2hs.
    --  Therefore, the Haskell object map maintains the necessary information
    --  about these Haskell objects.  The Haskell object map is dumped into and
    --  read from `.chi' files.
    --
    --- TODO ----------------------------------------------------------------------
    --
    --  * Look up in translation tables is naive - this probably doesn't affect
    --    costs much, but at some point a little profiling might be beneficial.
    --

    module GBMonad (
      TransFun, transTabToTransFun,

      HsObject(..), GB, HsPtrRep, initialGBState, setContext, getLibrary,
      getPrefix, getLock, delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,
      queryObj, queryClass, queryPointer, mergeMaps, dumpMaps
      ) where

    -- standard libraries
    import Data.Char          (toUpper, toLower, isSpace)
    import Data.List       (find)
    import Data.Maybe         (fromMaybe)

    -- Compiler Toolkit
    import Position   (Position, Pos(posOf), nopos, builtinPos)
    import Errors     (interr)
    import Idents     (Ident, identToLexeme, onlyPosIdent)
    import Map        (Map)
    import qualified  Map as Map (empty, insert, lookup, fromList, toList, union)

    -- C -> Haskell
    import C          (CT, readCT, transCT, raiseErrorCTExc)

    -- friends
    import CHS        (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),
                       CHSAccess(..), CHSAPath(..), CHSPtrType(..))

    -- translation tables
    -- ------------------

    -- takes an identifier to a lexeme including a potential mapping by a
    -- translation table
    --
    type TransFun = Ident -> String

    -- translation function for the `underscoreToCase' flag
    --
    underscoreToCase     :: TransFun
    underscoreToCase :: TransFun
    underscoreToCase Ident
    ide  = let lexeme :: String
    lexeme = TransFun
    identToLexeme Ident
    ide
                                ps :: [String]
    ps     = (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null) ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    parts (String -> [String]) -> String -> [String]
    forall a b. (a -> b) -> a -> b
    $ String
    lexeme
                            in
                            [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> String)
    -> ([String] -> [String]) -> [String] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String
    adjustCase ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ [String]
    ps
                            where
                              parts :: String -> [String]
    parts String
    s = let (String
    l, String
    s') = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_') String
    s
                                        in
                                        String
    l String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : case String
    s' of
                                              []      -> []
                                              (Char
    _:String
    s'') -> String -> [String]
    parts String
    s''

                              adjustCase :: String -> String
    adjustCase (Char
    c:String
    cs) = Char -> Char
    toUpper Char
    c Char -> String -> String
    forall a. a -> [a] -> [a]
    : (Char -> Char) -> String -> String
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower String
    cs

    -- takes an identifier association table to a translation function
    --
    --  * if first argument is `True', identifiers that are not found in the
    --   translation table are subjected to `underscoreToCase'
    --
    --  * the details of handling the prefix are given in the DOCU section at the
    --   beginning of this file
    --
    transTabToTransFun :: String -> CHSTrans -> TransFun
    transTabToTransFun :: String -> CHSTrans -> TransFun
    transTabToTransFun String
    prefix (CHSTrans Bool
    _2Case [(Ident, Ident)]
    table) =
      \Ident
    ide -> let
                lexeme :: String
    lexeme = TransFun
    identToLexeme Ident
    ide
                dft :: String
    dft    = if Bool
    _2Case                  -- default uses maybe the...
                         then TransFun
    underscoreToCase Ident
    ide  -- ..._2case transformed...
                         else String
    lexeme                -- ...lexeme
              in
              case Ident -> [(Ident, Ident)] -> Maybe Ident
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Ident
    ide [(Ident, Ident)]
    table of                  -- lookup original ident
                Just Ident
    ide' -> TransFun
    identToLexeme Ident
    ide'         -- original ident matches
                Maybe Ident
    Nothing   ->
                  case String -> String -> Maybe String
    eat String
    prefix String
    lexeme of
                    Maybe String
    Nothing          -> String
    dft             -- no match & no prefix
                    Just String
    eatenLexeme ->
                      let
                        eatenIde :: Ident
    eatenIde = Position -> String -> Ident
    onlyPosIdent (Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    ide) String
    eatenLexeme
                        eatenDft :: String
    eatenDft = if Bool
    _2Case
                                   then TransFun
    underscoreToCase Ident
    eatenIde
                                   else String
    eatenLexeme
                      in
                      case Ident -> [(Ident, Ident)] -> Maybe Ident
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Ident
    eatenIde [(Ident, Ident)]
    table of     -- lookup without prefix
                        Maybe Ident
    Nothing   -> String
    eatenDft           -- orig ide without prefix
                        Just Ident
    ide' -> TransFun
    identToLexeme Ident
    ide' -- without prefix matched
      where
        -- try to eat prefix and return `Just partialLexeme' if successful
        --
        eat :: String -> String -> Maybe String
    eat []         (Char
    '_':String
    cs)                        = String -> String -> Maybe String
    eat [] String
    cs
        eat []         String
    cs                              = String -> Maybe String
    forall a. a -> Maybe a
    Just String
    cs
        eat (Char
    p:String
    prefix) (Char
    c:String
    cs) | Char -> Char
    toUpper Char
    p Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char -> Char
    toUpper Char
    c = String -> String -> Maybe String
    eat String
    prefix String
    cs
                              | Bool
    otherwise              = Maybe String
    forall a. Maybe a
    Nothing
        eat String
    _          String
    _                               = Maybe String
    forall a. Maybe a
    Nothing

    -- the local monad
    -- ---------------

    -- map that for maps C pointer types to Haskell types for pointer that have
    -- been registered using a pointer hook
    --
    --  * the `Bool' indicates whether for a C type "ctype", we map "ctype" itself
    --   or "*ctype"
    --
    --  * the co-domain details how this pointer is represented in Haskell.
    --   See HsPtrRep.
    --
    type PointerMap = Map (Bool, Ident) HsPtrRep

    -- Define how pointers are represented in Haskell.
    --
    --  * The first element is true if the pointer points to a function.
    --   The second is the Haskell pointer type (plain
    --   Ptr, ForeignPtr or StablePtr). The third field is (Just wrap) if the
    --   pointer is wrapped in a newtype. Where "wrap"
    --   contains the name of the Haskell data type that was defined for this
    --   pointer. The forth element contains the type argument of the
    --   Ptr, ForeignPtr or StablePtr and is the same as "wrap"
    --   unless the user overrode it with the -> notation.
    type HsPtrRep = (Bool, CHSPtrType, Maybe String, String)

    -- map that maintains key information about some of the Haskell objects
    -- generated by c2hs
    --
    -- NB: using records here avoids to run into a bug with deriving `Read' in GHC
    --     5.04.1
    --
    data HsObject    = Pointer {
                         HsObject -> CHSPtrType
    ptrTypeHO    :: CHSPtrType,   -- kind of pointer
                         HsObject -> Bool
    isNewtypeHO  :: Bool          -- newtype?
                       }
                     | Class {
                         HsObject -> Maybe Ident
    superclassHO :: (Maybe Ident),-- superclass
                         HsObject -> Ident
    ptrHO        :: Ident         -- pointer
                       }
                     deriving (Int -> HsObject -> String -> String
    [HsObject] -> String -> String
    HsObject -> String
    (Int -> HsObject -> String -> String)
    -> (HsObject -> String)
    -> ([HsObject] -> String -> String)
    -> Show HsObject
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> HsObject -> String -> String
    showsPrec :: Int -> HsObject -> String -> String
    $cshow :: HsObject -> String
    show :: HsObject -> String
    $cshowList :: [HsObject] -> String -> String
    showList :: [HsObject] -> String -> String
    Show, ReadPrec [HsObject]
    ReadPrec HsObject
    Int -> ReadS HsObject
    ReadS [HsObject]
    (Int -> ReadS HsObject)
    -> ReadS [HsObject]
    -> ReadPrec HsObject
    -> ReadPrec [HsObject]
    -> Read HsObject
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS HsObject
    readsPrec :: Int -> ReadS HsObject
    $creadList :: ReadS [HsObject]
    readList :: ReadS [HsObject]
    $creadPrec :: ReadPrec HsObject
    readPrec :: ReadPrec HsObject
    $creadListPrec :: ReadPrec [HsObject]
    readListPrec :: ReadPrec [HsObject]
    Read)
    type HsObjectMap = Map Ident HsObject

    {- FIXME: What a mess...
    instance Show HsObject where
      show (Pointer ptrType isNewtype) =
        "Pointer " ++ show ptrType ++ show isNewtype
      show (Class   osuper  pointer  ) =
        "Class " ++ show ptrType ++ show isNewtype
    -}
    -- super kludgy (depends on Show instance of Ident)
    instance Read Ident where
      readsPrec :: Int -> ReadS Ident
    readsPrec Int
    _ (Char
    '`':String
    lexeme) = let (String
    ideChars, String
    rest) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    span (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\'') String
    lexeme
                                 in
                                 if String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    ideChars
                                 then []
                                 else [(Position -> String -> Ident
    onlyPosIdent Position
    nopos String
    ideChars, String -> String
    forall a. HasCallStack => [a] -> [a]
    tail String
    rest)]
      readsPrec Int
    p (Char
    c:String
    cs)
        | Char -> Bool
    isSpace Char
    c                                              = Int -> ReadS Ident
    forall a. Read a => Int -> ReadS a
    readsPrec Int
    p String
    cs
      readsPrec Int
    _ String
    _                                              = []

    -- the local state consists of
    --
    -- (1) the dynamic library specified by the context hook,
    -- (2) the prefix specified by the context hook,
    -- (3) an optional wrapper function that acquires a lock, this may also
    --     be specified on the command line
    -- (3) the set of delayed code fragaments, ie, pieces of Haskell code that,
    --     finally, have to be appended at the CHS module together with the hook
    --     that created them (the latter allows avoid duplication of foreign
    --     export declarations), and
    -- (4) a map associating C pointer types with their Haskell representation
    --
    -- access to the attributes of the C structure tree is via the `CT' monad of
    -- which we use an instance here
    --
    data GBState  = GBState {
                      GBState -> String
    lib     :: String,               -- dynamic library
                      GBState -> String
    prefix  :: String,               -- prefix
                      GBState -> Maybe String
    mLock   :: Maybe String,         -- a lock function
                      GBState -> [(CHSHook, CHSFrag)]
    frags   :: [(CHSHook, CHSFrag)], -- delayed code (with hooks)
                      GBState -> PointerMap
    ptrmap  :: PointerMap,           -- pointer representation
                      GBState -> HsObjectMap
    objmap  :: HsObjectMap           -- generated Haskell objects
                   }

    type GB a = CT GBState a

    initialGBState :: Maybe String -> GBState
    initialGBState :: Maybe String -> GBState
    initialGBState Maybe String
    mLock = GBState {
        lib :: String
    lib    = String
    "",
        prefix :: String
    prefix = String
    "",
        mLock :: Maybe String
    mLock = Maybe String
    mLock,
        frags :: [(CHSHook, CHSFrag)]
    frags  = [],
        ptrmap :: PointerMap
    ptrmap = PointerMap
    forall k a. Map k a
    Map.empty,
        objmap :: HsObjectMap
    objmap = HsObjectMap
    forall k a. Map k a
    Map.empty
      }

    -- set the dynamic library and library prefix
    --
    setContext            :: (Maybe String) -> (Maybe String) -> (Maybe String) ->
                             GB ()
    setContext :: Maybe String -> Maybe String -> Maybe String -> GB ()
    setContext Maybe String
    lib Maybe String
    prefix Maybe String
    newMLock =
      (GBState -> (GBState, ())) -> GB ()
    forall s a. (s -> (s, a)) -> CT s a
    transCT ((GBState -> (GBState, ())) -> GB ())
    -> (GBState -> (GBState, ())) -> GB ()
    forall a b. (a -> b) -> a -> b
    $ \GBState
    state -> (GBState
    state {lib    = fromMaybe "" lib,
                                  prefix = fromMaybe "" prefix,
                                  mLock  = case newMLock of
                                             Maybe String
    Nothing -> GBState -> Maybe String
    mLock GBState
    state
                                             Just String
    _ -> Maybe String
    newMLock },
                           ())

    -- get the dynamic library
    --
    getLibrary :: GB String
    getLibrary :: GB String
    getLibrary  = (GBState -> String) -> GB String
    forall s a. (s -> a) -> CT s a
    readCT GBState -> String
    lib

    -- get the prefix string
    --
    getPrefix :: GB String
    getPrefix :: GB String
    getPrefix  = (GBState -> String) -> GB String
    forall s a. (s -> a) -> CT s a
    readCT GBState -> String
    prefix

    -- get the lock function
    getLock :: GB (Maybe String)
    getLock :: GB (Maybe String)
    getLock = (GBState -> Maybe String) -> GB (Maybe String)
    forall s a. (s -> a) -> CT s a
    readCT GBState -> Maybe String
    mLock

    -- add code to the delayed fragments (the code is made to start at a new line)
    --
    --  * currently only code belonging to call hooks can be delayed
    --
    --  * if code for the same call hook (ie, same C function) is delayed
    --   repeatedly only the first entry is stored; it is checked that the hooks
    --   specify the same flags (ie, produce the same delayed code)
    --
    delayCode          :: CHSHook -> String -> GB ()
    delayCode :: CHSHook -> String -> GB ()
    delayCode CHSHook
    hook String
    str  =
      do
        [(CHSHook, CHSFrag)]
    frags <- (GBState -> [(CHSHook, CHSFrag)])
    -> CT GBState [(CHSHook, CHSFrag)]
    forall s a. (s -> a) -> CT s a
    readCT GBState -> [(CHSHook, CHSFrag)]
    frags
        [(CHSHook, CHSFrag)]
    frags' <- CHSHook -> [(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)]
    delay CHSHook
    hook [(CHSHook, CHSFrag)]
    frags
        (GBState -> (GBState, ())) -> GB ()
    forall s a. (s -> (s, a)) -> CT s a
    transCT (\GBState
    state -> (GBState
    state {frags = frags'}, ()))
        where
          newEntry :: (CHSHook, CHSFrag)
    newEntry = (CHSHook
    hook, (String -> Position -> CHSFrag
    CHSVerb (String
    "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str) (CHSHook -> Position
    forall a. Pos a => a -> Position
    posOf CHSHook
    hook)))
          --
          delay :: CHSHook -> [(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)]
    delay hook :: CHSHook
    hook@(CHSCall Bool
    isFun Bool
    isUns Bool
    _ Ident
    ide Maybe Ident
    oalias Position
    _) [(CHSHook, CHSFrag)]
    frags =
            case ((CHSHook, CHSFrag) -> Bool)
    -> [(CHSHook, CHSFrag)] -> Maybe (CHSHook, CHSFrag)
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    find (\(CHSHook
    hook', CHSFrag
    _) -> CHSHook
    hook' CHSHook -> CHSHook -> Bool
    forall a. Eq a => a -> a -> Bool
    == CHSHook
    hook) [(CHSHook, CHSFrag)]
    frags of
              Just (CHSCall Bool
    isFun' Bool
    isUns' Bool
    _ Ident
    ide' Maybe Ident
    _ Position
    _, CHSFrag
    _)
                |    Bool
    isFun Bool -> Bool -> Bool
    forall a. Eq a => a -> a -> Bool
    == Bool
    isFun'
                  Bool -> Bool -> Bool
    && Bool
    isUns Bool -> Bool -> Bool
    forall a. Eq a => a -> a -> Bool
    == Bool
    isUns'
                  Bool -> Bool -> Bool
    && Ident
    ide   Ident -> Ident -> Bool
    forall a. Eq a => a -> a -> Bool
    == Ident
    ide'   -> [(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)]
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [(CHSHook, CHSFrag)]
    frags
                | Bool
    otherwise          -> Position -> Position -> CT GBState [(CHSHook, CHSFrag)]
    forall {a}. Position -> Position -> GB a
    err (Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    ide) (Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    ide')
              Maybe (CHSHook, CHSFrag)
    Nothing                -> [(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)]
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)])
    -> [(CHSHook, CHSFrag)] -> CT GBState [(CHSHook, CHSFrag)]
    forall a b. (a -> b) -> a -> b
    $ [(CHSHook, CHSFrag)]
    frags [(CHSHook, CHSFrag)]
    -> [(CHSHook, CHSFrag)] -> [(CHSHook, CHSFrag)]
    forall a. [a] -> [a] -> [a]
    ++ [(CHSHook, CHSFrag)
    newEntry]
          delay CHSHook
    _ [(CHSHook, CHSFrag)]
    _                                  =
            String -> CT GBState [(CHSHook, CHSFrag)]
    forall a. String -> a
    interr String
    "GBMonad.delayCode: Illegal delay!"
          --
          err :: Position -> Position -> GB a
    err = Position -> Position -> GB a
    forall {a}. Position -> Position -> GB a
    incompatibleCallHooksErr

    -- get the complete list of delayed fragments
    --
    getDelayedCode :: GB [CHSFrag]
    getDelayedCode :: GB [CHSFrag]
    getDelayedCode  = (GBState -> [CHSFrag]) -> GB [CHSFrag]
    forall s a. (s -> a) -> CT s a
    readCT (((CHSHook, CHSFrag) -> CHSFrag)
    -> [(CHSHook, CHSFrag)] -> [CHSFrag]
    forall a b. (a -> b) -> [a] -> [b]
    map (CHSHook, CHSFrag) -> CHSFrag
    forall a b. (a, b) -> b
    snd ([(CHSHook, CHSFrag)] -> [CHSFrag])
    -> (GBState -> [(CHSHook, CHSFrag)]) -> GBState -> [CHSFrag]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . GBState -> [(CHSHook, CHSFrag)]
    frags)

    -- add an entry to the pointer map
    --
    ptrMapsTo :: (Bool, Ident) -> HsPtrRep -> GB ()
    (Bool
    isStar, Ident
    cName) ptrMapsTo :: (Bool, Ident) -> HsPtrRep -> GB ()
    `ptrMapsTo` HsPtrRep
    hsRepr =
      (GBState -> (GBState, ())) -> GB ()
    forall s a. (s -> (s, a)) -> CT s a
    transCT (\GBState
    state -> (GBState
    state {
                            ptrmap = Map.insert (isStar, cName) hsRepr (ptrmap state)
                          }, ()))

    -- query the pointer map
    --
    queryPtr        :: (Bool, Ident) -> GB (Maybe HsPtrRep)
    queryPtr :: (Bool, Ident) -> GB (Maybe HsPtrRep)
    queryPtr (Bool, Ident)
    pcName  = do
                         PointerMap
    fm <- (GBState -> PointerMap) -> CT GBState PointerMap
    forall s a. (s -> a) -> CT s a
    readCT GBState -> PointerMap
    ptrmap
                         Maybe HsPtrRep -> GB (Maybe HsPtrRep)
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe HsPtrRep -> GB (Maybe HsPtrRep))
    -> Maybe HsPtrRep -> GB (Maybe HsPtrRep)
    forall a b. (a -> b) -> a -> b
    $ (Bool, Ident) -> PointerMap -> Maybe HsPtrRep
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup (Bool, Ident)
    pcName PointerMap
    fm

    -- add an entry to the Haskell object map
    --
    objIs :: Ident -> HsObject -> GB ()
    Ident
    hsName objIs :: Ident -> HsObject -> GB ()
    `objIs` HsObject
    obj =
      (GBState -> (GBState, ())) -> GB ()
    forall s a. (s -> (s, a)) -> CT s a
    transCT (\GBState
    state -> (GBState
    state {
                            objmap = Map.insert hsName obj (objmap state)
                          }, ()))

    -- query the Haskell object map
    --
    queryObj        :: Ident -> GB (Maybe HsObject)
    queryObj :: Ident -> GB (Maybe HsObject)
    queryObj Ident
    hsName  = do
                         HsObjectMap
    fm <- (GBState -> HsObjectMap) -> CT GBState HsObjectMap
    forall s a. (s -> a) -> CT s a
    readCT GBState -> HsObjectMap
    objmap
                         Maybe HsObject -> GB (Maybe HsObject)
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe HsObject -> GB (Maybe HsObject))
    -> Maybe HsObject -> GB (Maybe HsObject)
    forall a b. (a -> b) -> a -> b
    $ Ident -> HsObjectMap -> Maybe HsObject
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Ident
    hsName HsObjectMap
    fm

    -- query the Haskell object map for a class
    --
    --  * raise an error if the class cannot be found
    --
    queryClass        :: Ident -> GB HsObject
    queryClass :: Ident -> GB HsObject
    queryClass Ident
    hsName  = do
                           let pos :: Position
    pos = Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    hsName
                           Maybe HsObject
    oobj <- Ident -> GB (Maybe HsObject)
    queryObj Ident
    hsName
                           case Maybe HsObject
    oobj of
                             Just obj :: HsObject
    obj@(Class Maybe Ident
    _ Ident
    _) -> HsObject -> GB HsObject
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return HsObject
    obj
                             Just HsObject
    _               -> Ident -> GB HsObject
    forall a. Ident -> GB a
    classExpectedErr Ident
    hsName
                             Maybe HsObject
    Nothing              -> Ident -> GB HsObject
    forall a. Ident -> GB a
    hsObjExpectedErr Ident
    hsName

    -- query the Haskell object map for a pointer
    --
    --  * raise an error if the pointer cannot be found
    --
    queryPointer        :: Ident -> GB HsObject
    queryPointer :: Ident -> GB HsObject
    queryPointer Ident
    hsName  = do
                           let pos :: Position
    pos = Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    hsName
                           Maybe HsObject
    oobj <- Ident -> GB (Maybe HsObject)
    queryObj Ident
    hsName
                           case Maybe HsObject
    oobj of
                             Just obj :: HsObject
    obj@(Pointer CHSPtrType
    _ Bool
    _) -> HsObject -> GB HsObject
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return HsObject
    obj
                             Just HsObject
    _                 -> Ident -> GB HsObject
    forall a. Ident -> GB a
    pointerExpectedErr Ident
    hsName
                             Maybe HsObject
    Nothing                -> Ident -> GB HsObject
    forall a. Ident -> GB a
    hsObjExpectedErr Ident
    hsName

    -- merge the pointer and Haskell object maps
    --
    --  * currently, the read map overrides any entries for shared keys in the map
    --   that is already in the monad; this is so that, if multiple import hooks
    --   add entries for shared keys, the textually latest prevails; any local
    --   entries are entered after all import hooks anyway
    --
    -- FIXME: This currently has several shortcomings:
    --        * It just dies in case of a corrupted .chi file
    --        * We should at least have the option to raise a warning if two
    --          entries collide in the `objmap'.  But it would be better to
    --          implement qualified names.
    --        * Do we want position information associated with the read idents?
    --
    mergeMaps     :: String -> GB ()
    mergeMaps :: String -> GB ()
    mergeMaps String
    str  =
      (GBState -> (GBState, ())) -> GB ()
    forall s a. (s -> (s, a)) -> CT s a
    transCT (\GBState
    state -> (GBState
    state {
                            ptrmap = Map.union (ptrmap state) readPtrMap,
                            objmap = Map.union (objmap state) readObjMap
                          }, ()))
      where
        ([((Bool, String), HsPtrRep)]
    ptrAssoc, [(String, HsObject)]
    objAssoc) = String -> ([((Bool, String), HsPtrRep)], [(String, HsObject)])
    forall a. Read a => String -> a
    read String
    str
        readPtrMap :: PointerMap
    readPtrMap           = [((Bool, Ident), HsPtrRep)] -> PointerMap
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList [((Bool
    isStar, Position -> String -> Ident
    onlyPosIdent Position
    nopos String
    ide), HsPtrRep
    repr)
                                        | ((Bool
    isStar, String
    ide), HsPtrRep
    repr) <- [((Bool, String), HsPtrRep)]
    ptrAssoc]
        readObjMap :: HsObjectMap
    readObjMap           = [(Ident, HsObject)] -> HsObjectMap
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList [(Position -> String -> Ident
    onlyPosIdent Position
    nopos String
    ide, HsObject
    obj)
                                        | (String
    ide, HsObject
    obj)            <- [(String, HsObject)]
    objAssoc]

    -- convert the whole pointer and Haskell object maps into printable form
    --
    dumpMaps :: GB String
    dumpMaps :: GB String
    dumpMaps  = do
                  PointerMap
    ptrFM <- (GBState -> PointerMap) -> CT GBState PointerMap
    forall s a. (s -> a) -> CT s a
    readCT GBState -> PointerMap
    ptrmap
                  HsObjectMap
    objFM <- (GBState -> HsObjectMap) -> CT GBState HsObjectMap
    forall s a. (s -> a) -> CT s a
    readCT GBState -> HsObjectMap
    objmap
                  let dumpable :: ([((Bool, String), HsPtrRep)], [(String, HsObject)])
    dumpable = ([((Bool
    isStar, TransFun
    identToLexeme Ident
    ide), HsPtrRep
    repr)
                                  | ((Bool
    isStar, Ident
    ide), HsPtrRep
    repr) <- PointerMap -> [((Bool, Ident), HsPtrRep)]
    forall k a. Map k a -> [(k, a)]
    Map.toList PointerMap
    ptrFM],
                                  [(TransFun
    identToLexeme Ident
    ide, HsObject
    obj)
                                  | (Ident
    ide, HsObject
    obj)            <- HsObjectMap -> [(Ident, HsObject)]
    forall k a. Map k a -> [(k, a)]
    Map.toList HsObjectMap
    objFM])
                  String -> GB String
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ ([((Bool, String), HsPtrRep)], [(String, HsObject)]) -> String
    forall a. Show a => a -> String
    show ([((Bool, String), HsPtrRep)], [(String, HsObject)])
    dumpable

    -- error messages
    -- --------------

    incompatibleCallHooksErr            :: Position -> Position -> GB a
    incompatibleCallHooksErr :: forall {a}. Position -> Position -> GB a
    incompatibleCallHooksErr Position
    here Position
    there  =
      Position -> [String] -> CT GBState a
    forall s a. Position -> [String] -> CT s a
    raiseErrorCTExc Position
    here
        [String
    "Incompatible call hooks!",
         String
    "There is a another call hook for the same C function at " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Position -> String
    forall a. Show a => a -> String
    show Position
    there,
         String
    "The flags and C function name of the two hooks should be identical,",
         String
    "but they are not."]

    classExpectedErr     :: Ident -> GB a
    classExpectedErr :: forall a. Ident -> GB a
    classExpectedErr Ident
    ide  =
      Position -> [String] -> CT GBState a
    forall s a. Position -> [String] -> CT s a
    raiseErrorCTExc (Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    ide)
        [String
    "Expected a class name!",
         String
    "Expected `" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ TransFun
    identToLexeme Ident
    ide String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "' to refer to a class introduced",
         String
    "by a class hook."]

    pointerExpectedErr     :: Ident -> GB a
    pointerExpectedErr :: forall a. Ident -> GB a
    pointerExpectedErr Ident
    ide  =
      Position -> [String] -> CT GBState a
    forall s a. Position -> [String] -> CT s a
    raiseErrorCTExc (Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    ide)
        [String
    "Expected a pointer name!",
         String
    "Expected `" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ TransFun
    identToLexeme Ident
    ide String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "' to be a type name introduced by",
         String
    "a pointer hook."]

    hsObjExpectedErr     :: Ident -> GB a
    hsObjExpectedErr :: forall a. Ident -> GB a
    hsObjExpectedErr Ident
    ide  =
      Position -> [String] -> CT GBState a
    forall s a. Position -> [String] -> CT s a
    raiseErrorCTExc (Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    ide)
        [String
    "Unknown name!",
         String
    "`" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ TransFun
    identToLexeme Ident
    ide String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "' is unknown; it has *not* been defined by",
         String
    "a previous hook."]