-- 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 ide = let lexeme = identToLexeme ide ps = filter (not . null) . parts $ lexeme in concat . map adjustCase $ ps where parts s = let (l, s') = break (== '_') s in l : case s' of [] -> [] (_:s'') -> parts s'' adjustCase (c:cs) = toUpper c : map toLower 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 prefix (CHSTrans _2Case table) = \ide -> let lexeme = identToLexeme ide dft = if _2Case -- default uses maybe the... then underscoreToCase ide -- ..._2case transformed... else lexeme -- ...lexeme in case lookup ide table of -- lookup original ident Just ide' -> identToLexeme ide' -- original ident matches Nothing -> case eat prefix lexeme of Nothing -> dft -- no match & no prefix Just eatenLexeme -> let eatenIde = onlyPosIdent (posOf ide) eatenLexeme eatenDft = if _2Case then underscoreToCase eatenIde else eatenLexeme in case lookup eatenIde table of -- lookup without prefix Nothing -> eatenDft -- orig ide without prefix Just ide' -> identToLexeme ide' -- without prefix matched where -- try to eat prefix and return `Just partialLexeme' if successful -- eat [] ('_':cs) = eat [] cs eat [] cs = Just cs eat (p:prefix) (c:cs) | toUpper p == toUpper c = eat prefix cs | otherwise = Nothing eat _ _ = 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 { ptrTypeHO :: CHSPtrType, -- kind of pointer isNewtypeHO :: Bool -- newtype? } | Class { superclassHO :: (Maybe Ident),-- superclass ptrHO :: Ident -- pointer } deriving (Show, 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 _ ('`':lexeme) = let (ideChars, rest) = span (/= '\'') lexeme in if null ideChars then [] else [(onlyPosIdent nopos ideChars, tail rest)] readsPrec p (c:cs) | isSpace c = readsPrec p cs readsPrec _ _ = [] -- 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 { lib :: String, -- dynamic library prefix :: String, -- prefix mLock :: Maybe String, -- a lock function frags :: [(CHSHook, CHSFrag)], -- delayed code (with hooks) ptrmap :: PointerMap, -- pointer representation objmap :: HsObjectMap -- generated Haskell objects } type GB a = CT GBState a initialGBState :: Maybe String -> GBState initialGBState mLock = GBState { lib = "", prefix = "", mLock = mLock, frags = [], ptrmap = Map.empty, objmap = Map.empty } -- set the dynamic library and library prefix -- setContext :: (Maybe String) -> (Maybe String) -> (Maybe String) -> GB () setContext lib prefix newMLock = transCT $ \state -> (state {lib = fromMaybe "" lib, prefix = fromMaybe "" prefix, mLock = case newMLock of Nothing -> mLock state Just _ -> newMLock }, ()) -- get the dynamic library -- getLibrary :: GB String getLibrary = readCT lib -- get the prefix string -- getPrefix :: GB String getPrefix = readCT prefix -- get the lock function getLock :: GB (Maybe String) getLock = readCT 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 hook str = do frags <- readCT frags frags' <- delay hook frags transCT (\state -> (state {frags = frags'}, ())) where newEntry = (hook, (CHSVerb ("\n" ++ str) (posOf hook))) -- delay hook@(CHSCall isFun isUns _ ide oalias _) frags = case find (\(hook', _) -> hook' == hook) frags of Just (CHSCall isFun' isUns' _ ide' _ _, _) | isFun == isFun' && isUns == isUns' && ide == ide' -> return frags | otherwise -> err (posOf ide) (posOf ide') Nothing -> return $ frags ++ [newEntry] delay _ _ = interr "GBMonad.delayCode: Illegal delay!" -- err = incompatibleCallHooksErr -- get the complete list of delayed fragments -- getDelayedCode :: GB [CHSFrag] getDelayedCode = readCT (map snd . frags) -- add an entry to the pointer map -- ptrMapsTo :: (Bool, Ident) -> HsPtrRep -> GB () (isStar, cName) `ptrMapsTo` hsRepr = transCT (\state -> (state { ptrmap = Map.insert (isStar, cName) hsRepr (ptrmap state) }, ())) -- query the pointer map -- queryPtr :: (Bool, Ident) -> GB (Maybe HsPtrRep) queryPtr pcName = do fm <- readCT ptrmap return $ Map.lookup pcName fm -- add an entry to the Haskell object map -- objIs :: Ident -> HsObject -> GB () hsName `objIs` obj = transCT (\state -> (state { objmap = Map.insert hsName obj (objmap state) }, ())) -- query the Haskell object map -- queryObj :: Ident -> GB (Maybe HsObject) queryObj hsName = do fm <- readCT objmap return $ Map.lookup hsName fm -- query the Haskell object map for a class -- -- * raise an error if the class cannot be found -- queryClass :: Ident -> GB HsObject queryClass hsName = do let pos = posOf hsName oobj <- queryObj hsName case oobj of Just obj@(Class _ _) -> return obj Just _ -> classExpectedErr hsName Nothing -> hsObjExpectedErr hsName -- query the Haskell object map for a pointer -- -- * raise an error if the pointer cannot be found -- queryPointer :: Ident -> GB HsObject queryPointer hsName = do let pos = posOf hsName oobj <- queryObj hsName case oobj of Just obj@(Pointer _ _) -> return obj Just _ -> pointerExpectedErr hsName Nothing -> hsObjExpectedErr 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 str = transCT (\state -> (state { ptrmap = Map.union (ptrmap state) readPtrMap, objmap = Map.union (objmap state) readObjMap }, ())) where (ptrAssoc, objAssoc) = read str readPtrMap = Map.fromList [((isStar, onlyPosIdent nopos ide), repr) | ((isStar, ide), repr) <- ptrAssoc] readObjMap = Map.fromList [(onlyPosIdent nopos ide, obj) | (ide, obj) <- objAssoc] -- convert the whole pointer and Haskell object maps into printable form -- dumpMaps :: GB String dumpMaps = do ptrFM <- readCT ptrmap objFM <- readCT objmap let dumpable = ([((isStar, identToLexeme ide), repr) | ((isStar, ide), repr) <- Map.toList ptrFM], [(identToLexeme ide, obj) | (ide, obj) <- Map.toList objFM]) return $ show dumpable -- error messages -- -------------- incompatibleCallHooksErr :: Position -> Position -> GB a incompatibleCallHooksErr here there = raiseErrorCTExc here ["Incompatible call hooks!", "There is a another call hook for the same C function at " ++ show there, "The flags and C function name of the two hooks should be identical,", "but they are not."] classExpectedErr :: Ident -> GB a classExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected a class name!", "Expected `" ++ identToLexeme ide ++ "' to refer to a class introduced", "by a class hook."] pointerExpectedErr :: Ident -> GB a pointerExpectedErr ide = raiseErrorCTExc (posOf ide) ["Expected a pointer name!", "Expected `" ++ identToLexeme ide ++ "' to be a type name introduced by", "a pointer hook."] hsObjExpectedErr :: Ident -> GB a hsObjExpectedErr ide = raiseErrorCTExc (posOf ide) ["Unknown name!", "`" ++ identToLexeme ide ++ "' is unknown; it has *not* been defined by", "a previous hook."]