-- 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 Char (toUpper, toLower, isSpace)
import List (find)
import 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."]