--  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 (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
showList :: [HsObject] -> String -> String
$cshowList :: [HsObject] -> String -> String
show :: HsObject -> String
$cshow :: HsObject -> String
showsPrec :: Int -> HsObject -> String -> String
$cshowsPrec :: Int -> 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
readListPrec :: ReadPrec [HsObject]
$creadListPrec :: ReadPrec [HsObject]
readPrec :: ReadPrec HsObject
$creadPrec :: ReadPrec HsObject
readList :: ReadS [HsObject]
$creadList :: ReadS [HsObject]
readsPrec :: Int -> ReadS HsObject
$creadsPrec :: Int -> ReadS 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 (t :: * -> *) a. Foldable t => t a -> Bool
null String
ideChars 
                             then []
                             else [(Position -> String -> Ident
onlyPosIdent Position
nopos String
ideChars, String -> String
forall a. [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 :: String
-> String
-> Maybe String
-> [(CHSHook, CHSFrag)]
-> PointerMap
-> HsObjectMap
-> GBState
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 :: String
lib    = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
lib,
                              prefix :: String
prefix = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
prefix,
                              mLock :: Maybe String
mLock  = case Maybe String
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 :: [(CHSHook, CHSFrag)]
frags = [(CHSHook, CHSFrag)]
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 (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 (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 :: PointerMap
ptrmap = (Bool, Ident) -> HsPtrRep -> PointerMap -> PointerMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Bool
isStar, Ident
cName) HsPtrRep
hsRepr (GBState -> PointerMap
ptrmap GBState
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 (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 :: HsObjectMap
objmap = Ident -> HsObject -> HsObjectMap -> HsObjectMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
hsName HsObject
obj (GBState -> HsObjectMap
objmap GBState
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 (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 (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 (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 entires 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 :: PointerMap
ptrmap = PointerMap -> PointerMap -> PointerMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (GBState -> PointerMap
ptrmap GBState
state) PointerMap
readPtrMap,
                        objmap :: HsObjectMap
objmap = HsObjectMap -> HsObjectMap -> HsObjectMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (GBState -> HsObjectMap
objmap GBState
state) HsObjectMap
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 (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 :: Position -> Position -> GB a
incompatibleCallHooksErr Position
here Position
there  =
  Position -> [String] -> GB 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 :: Ident -> GB a
classExpectedErr Ident
ide  =
  Position -> [String] -> GB 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 :: Ident -> GB a
pointerExpectedErr Ident
ide  =
  Position -> [String] -> GB 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 :: Ident -> GB a
hsObjExpectedErr Ident
ide  =
  Position -> [String] -> GB 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."]