hdirect-0.21.0: src/Rename.lhs
%
% (c) The Foo Project, University of Glasgow 1998-99
%
% @(#) $Docid: Dec. 27th 2001 00:14 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
Prior to converting (core) IDL declarations to Haskell, we
run a renaming pass over the IDL, performing the following
tasks:
- fields labels, method names and types are renamed so
as to be unique within the scope of a Haskell module.
- For imported types, adjust the module name to point to
the Haskell interface/module we're importing from.
To be more precise, IDL has three namespaces:
* struct/union/enum tags
* component names (fields, parameter names)
* other (typedef names, method names and enumeration constants)
which are mapped onto the following Haskell namespaces:
* tags => type constructors (unique per module.)
* field labels => varids (unique per module.)
* parameter names => varids (unique per function.)
* typedef nms. => type ids (unique per module.)
* method names => varids (unique per module.)
* module names => modids (unique per translation unit.)
* interface names => varids / modids (unique per translation unit.)
An added wrinkle when mapping from IDL into Haskell namespaces is that
we have to make sure we don't map IDL names onto Haskell keywords/reserved ids.
\begin{code}
module Rename ( renameDecls, IsoEnv, IfaceNukeEnv ) where
import RnMonad
import CoreIDL
import BasicTypes
import CoreUtils ( mkHaskellTyConName, isMethod, mkIfaceTypeName, getTypeAttributes,
localiseTypes )
import Attribute ( isConstantAttribute, hasAttributeWithName, hasAttributeWithNames,
sourceAttribute, filterAttributes, filterOutAttributes,
findAttribute, findStringAttributes
)
import Utils ( dropSuffix, mapMbM, splitLast )
import DsMonad ( TypeEnv, SourceEnv, TagEnv, IfaceEnv )
import Opts ( optOneModulePerInterface, optCoalesceIsomorphicMethods,
optPrefixIfaceName, optAppendIfaceName, optInlineTypes,
optCharPtrIsString, optUseStdDispatch
)
import Maybe ( isJust, fromMaybe )
import List ( isPrefixOf )
import Monad ( when, mplus )
import Char ( isUpper, toUpper )
import Literal
\end{code}
This module's shopfront is @renameDecls@, renaming a list of declarations.
Along with the renamed decls, @renameDecls@ returns an environment of
method names. The environment contains signatures of methods for which
there exist isomorphic definitions, .e.g.,
@
interface IA { void foo(); };
interface IB { void foo(); };
@
The @foo@ method in @IB@ is isomorphic to the one in @IA@, a fact that may
be exploited when generating code, creating just an overloaded version
of @foo@ (or one that is just not as strongly typed.)
\begin{code}
renameDecls :: TypeEnv
-> TagEnv
-> SourceEnv
-> IfaceEnv
-> [Decl]
-> ([Decl], IsoEnv, IfaceNukeEnv)
renameDecls tenv tgenv senv ienv ds =
runRnM tenv tgenv senv ienv $ mapM renameDecl (localiseTypes ds)
\end{code}
Renaming individual definitions:
\begin{code}
renameDecl :: Decl -> RnM Decl
renameDecl (Typedef i t orig_ty) = do
i' <- renameTypeId (normaliseIdName i)
t' <- renameType t
getModuleName $ \ x -> do
n_ty <- normaliseTy x [] t'
return (Typedef i' n_ty orig_ty)
renameDecl (Constant i t o_t e) = do
i' <- renameVarId (normaliseIdName i)
t' <- renameType t
o_t' <- relabelType False o_t
return (Constant i' t' o_t' e)
renameDecl (Interface i is_ref inh ds) = do
i' <- renameConId (normaliseIdName i)
i'' <- renameTypeId i'
is_source <- isSourceIface (idName i)
let
i'''
| is_source = i''{idAttributes=sourceAttribute:idAttributes i''}
| otherwise = i''
nm = mkHaskellTyConName (idName i''')
startOffset
| nm == "IUnknown" = Just 0
| otherwise = Just (sum (map snd inh))
rnDecl d
| isMethod d = do
d' <- renameDecl d
incMethOffset
return d'
| otherwise = renameDecl d
deps = map remove $
filterAttributes (idAttributes i) ["depender"]
where
remove (Attribute _ [ParamLit (LitLit s)]) = mkHaskellTyConName (snd (splitLast "." s))
remove _ = ""
ds' <-
setMethOffset startOffset $
setIfaceName nm (
if optOneModulePerInterface
then withDependers deps (setModuleName nm (withNewVarIdEnv (mapM rnDecl ds)))
else mapM rnDecl ds)
sane_inh <-
if optOneModulePerInterface then
normaliseInh nm deps inh
else
getModuleName $ \ mod_nm -> do
normaliseInh mod_nm [] inh
i_final <-
if optOneModulePerInterface then
return (i'''{idModule=Nothing})
else
normaliseModName i'''
let d = Interface i_final is_ref sane_inh ds'
when (not is_ref) (addIface (idName i_final) d)
return d
renameDecl (Module i ms) = do
i' <- renameModId (normaliseIdName i)
ms' <- setModuleName (idName i') (inNewModule (mapM renameDecl ms))
return (Module i' ms')
renameDecl (Library i ls) = do
i' <- renameModId (normaliseIdName i)
ls' <- setModuleName (idName i') (inNewModule (mapM renameDecl ls))
return (Library i' ls')
renameDecl (DispInterface i ii ps ms) = do
i' <- renameTypeId (normaliseIdName i) >>= \ x -> renameConId x >>= normaliseModName
is_source <- isSourceIface (idName i)
let
i''
| is_source = i'{idAttributes=sourceAttribute:idAttributes i'}
| otherwise = i'
nm = mkHaskellTyConName (idName i'')
is_wrapper = isJust ii && not optUseStdDispatch
reDecl
| is_wrapper = relabelDecl
| otherwise = renameDecl
(ps',ms') <-
setIfaceName nm (
withNew nm ( do
ps' <- mapM reDecl ps
ms' <- mapM reDecl ms
return (ps', ms')))
ii' <-
case ii of
Nothing -> return Nothing
Just d -> do
d' <- relabelDecl d
return (Just d')
let d = DispInterface i'' ii' ps' ms'
addIface (idName i'') d
return d
where
withNew nm
| optOneModulePerInterface = (setModuleName nm).withNewVarIdEnv
| otherwise = id
renameDecl (CoClass i ls) = do
i' <-
if optOneModulePerInterface then
renameConId (normaliseIdName i) >>= renameClassId
else
renameClassId (normaliseIdName i)
ls' <- mapM renameCoCDecl ls
case ls' of
[x] -> do
when optOneModulePerInterface (addNukeIface (idName (coClassId x)) i')
return (CoClass i' ls')
_ -> return (CoClass i' ls')
renameDecl (Method i cc res ps offs) =
getIfaceName $ \ if_name -> do
let
-- We pin on the prefixes of propgetters and putters
-- here, and rename that.
attrs = idAttributes i
i' = normaliseIdName i
real_i
| attrs `hasAttributeWithName` "propget"
= i'{idName=if_mangle ("get"++mkHaskellTyConName (idName i))}
| attrs `hasAttributeWithNames` ["propput", "propputref"]
= i'{idName=if_mangle ("set"++mkHaskellTyConName (idName i))}
| optPrefixIfaceName
= i'{idName=if_mangle (idName i)}
| otherwise = i'
h_if_name = mkIfaceTypeName if_name
if_mangle
| optPrefixIfaceName = \ x -> h_if_name ++ "_" ++ x
| optAppendIfaceName = \ x -> x ++ shorten_if h_if_name
| otherwise = id
mangled_i
| optAppendIfaceName && not optOneModulePerInterface
= real_i{idName=if_mangle (idName i')}
| otherwise = real_i
-- IFooBar => FB
-- FooBar => FB
-- IntFoo => IF
shorten_if ls =
case ls of
'I':x:xs | isUpper x -> shorten (x:xs)
xs -> shorten xs
shorten [] = []
shorten (x:xs) = toUpper x : filter (isUpper) xs
the_i <- renameVarId2 mangled_i real_i
-- fish out the attributes from the result type, so
-- that all of them are attached to the method Id.
-- (this is done chiefly to cope with the [ignore]
-- attribute, which causes type names to be shorted
-- during type renaming and relabelling.)
--
-- see relabelDecl.Method comment as to why [ignore]s
-- are filtered out here.
let ty_attrs = filterOutAttributes (getTypeAttributes (resultOrigType res))
["ignore"]
res' <- renameResult res
ps' <- withNewVarIdEnv $ do
ps' <- mapM renameParam ps
mapM renameParamAttr ps'
off <- getMethOffset
when optCoalesceIsomorphicMethods (checkIsomorphicMeth real_i off res' ps')
return (Method the_i{idAttributes=idAttributes the_i ++ ty_attrs} cc res' ps' offs)
renameDecl (Property i ty mb_off set_i get_i) = do
set_i' <- renameId (normaliseIdName set_i)
get_i' <- renameId (normaliseIdName get_i)
ty' <- renameType ty
return (Property i ty' mb_off set_i' get_i')
renameDecl d@(HsLiteral _) = return d
renameDecl d@(CInclude _) = return d
renameDecl d@(CLiteral _) = return d
\end{code}
\begin{code}
renameCoCDecl :: CoClassDecl -> RnM CoClassDecl
renameCoCDecl d = do
i' <- relabelTyConId i >>= normaliseModName
mb_d <- lookupIface (idName i')
return (d{coClassId=i',coClassDecl=mb_d `mplus` coClassDecl d})
where
i = normaliseIdName (coClassId d)
\end{code}
\begin{code}
relabelDecl :: Decl -> RnM Decl
relabelDecl (Interface i is_ref inh ds) = do
i' <- relabelTyConId (normaliseIdName i)
ds' <- mapM relabelDecl ds
i'' <- normaliseModName i'
getModuleName $ \ mod_nm -> do
inh' <- normaliseInh mod_nm [] inh
return (Interface i'' is_ref inh' ds')
relabelDecl (DispInterface i ii ps ms) = do
i' <- relabelTyConId i
i'' <- normaliseModName i'
ms' <- mapM relabelDecl ms
return (DispInterface i'' ii ps ms')
relabelDecl (Method i cc res ps offs) = do
i' <- relabelVarId i
ps' <- mapM relabelParam ps
-- [ignore] attributes attached to the result type are *not*
-- propagated to the method Id.
let ty_attrs = filterOutAttributes (getTypeAttributes (resultOrigType res))
["ignore"]
res' <- relabelResult res
return (Method i'{idAttributes=idAttributes i' ++ ty_attrs} cc res' ps' offs)
relabelDecl (Property i ty mb_off set_i get_i) = do
set_i' <- relabelVarId (normaliseIdName set_i)
get_i' <- relabelVarId (normaliseIdName get_i)
ty' <- relabelType False ty
return (Property i ty' mb_off set_i' get_i')
relabelDecl d = return d
\end{code}
\begin{code}
renameVarId :: Id -> RnM Id
renameVarId i =
lookupVarIdAndAddEnv (idName i) $ \ nm ->
return (i{idName=nm})
renameModId :: Id -> RnM Id
renameModId i =
lookupModIdAndAddEnv (idName i) $ \ nm ->
return (i{idName=nm})
normaliseModName :: Id -> RnM Id
normaliseModName i =
getModuleName $ \ mod_nm ->
case (idModule i) of
Just x | x == mod_nm -> return (i{idModule=Nothing})
| otherwise -> return (i{idModule=Just (mkHaskellTyConName (dropSuffix x))})
_ -> return (i{idModule=Nothing})
normaliseIdName :: Id -> Id
normaliseIdName i =
case findAttribute "hs_name" (idAttributes i) of
Just (Attribute _ [ParamLit (StringLit s)]) -> i{idName=s}
_ -> adjustHsNameId i
renameId :: Id -> RnM Id
renameId i =
lookupVarIdAndAddEnv (idName i) $ \ nm ->
return (i{idName=nm})
renameVarId2 :: Id -> Id -> RnM Id
renameVarId2 i2 i = do
flg <- varIdInScope (idName i)
-- if it's already there, try using i2 instead.
if flg then
renameVarId i2
else
renameVarId i
renameConId :: Id -> RnM Id
renameConId i =
lookupTyConAndAddEnv (idName i) $ \ nm ->
return (i{idName=nm})
renameClassId :: Id -> RnM Id
renameClassId i =
lookupClassIdAndAddEnv (idName i) $ \ nm ->
return (i{idName=nm})
renameTyConId :: Id -> RnM Id
renameTyConId i =
lookupTyConAndAddEnv (idName i) $ \ nm ->
return (i{idName=nm})
renameTypeId :: Id -> RnM Id
renameTypeId i =
lookupTypeIdAndAddEnv (idName i) $ \ nm ->
return (i{idName=nm})
\end{code}
Check to see if a method's result and parameters are
isomorphic (upto parameter names) of any others:
\begin{code}
checkIsomorphicMeth :: Id -> Maybe Int -> Result -> [Param] -> RnM ()
checkIsomorphicMeth i mem_off res params = do
r <- lookupMethod (idOrigName i) -- use original names here.
case r of
Nothing -> -- none yet, add an entry for the method and return.
addMethod (idOrigName i) (mem_off,res,params)
Just alts
| any checkOne alts -> -- name & params matched, store it.
addIsoMethod (idOrigName i) (res, params)
| otherwise ->
addMethod (idOrigName i) (mem_off, res,params)
where
checkOne (off,r,ps) =
off == mem_off &&
resultType r == resultType res &&
all (\ (p1,p2) -> paramMode p1 == paramMode p2 &&
paramType p1 == paramType p2) -- ToDo: check attributes too.
(zip ps params)
\end{code}
\begin{code}
renameType :: Type -> RnM Type
renameType ty =
case ty of
Struct i [] mbsz -> do
r <- lookupTag (idName i)
case r of
Just (mod,nm) -> do
mb_r <- lookupTypeId nm
let r' = fmap (snd) mb_r
return (Name nm nm mod Nothing r' Nothing)
Nothing -> do
--i' <- renameTagId i
return (Struct i [] mbsz)
Struct i fields mbsz -> do
i' <- renameTyConId i
{-
Need to rename all the fields ids first, since
field types may have attributes that refer to
another field (and these might be forward refs).
Sigh.
-}
fields' <- mapM renameFieldId fields
fields'' <- mapM renameField fields'
fields''' <- mapM relabelFieldAttr fields''
return (Struct i' fields''' mbsz)
Enum i flg vals -> do
i_r <- renameTyConId i
i' <- normaliseModName i_r
i'' <-
{- Make sure we've got the right module. -}
case idModule i' of
Nothing -> do
r <- lookupTag (idName i)
case r of
Just (Just mod, _) -> setModuleName mod (normaliseModName i')
-- drop the module qualifier if it's the same as the name of the
-- containing module [this prunage is only done in the one-mod-per-iface
-- setting at the moment.]
_ -> return i'
Just _ -> return i'
vals' <- mapM renameEnumTag vals
return (Enum i'' flg vals')
Union i t struct_tg un_tg switches -> do
i' <- renameTyConId i
struct_tg' <- renameTyConId struct_tg
un_tg' <- renameTyConId un_tg
switches' <- mapM renameSwitch switches
return (Union i' t struct_tg' un_tg' switches')
UnionNon i switches -> do
i' <- renameTyConId i
switches' <- mapM renameSwitch switches
return (UnionNon i' switches')
CUnion i fields mbsz -> do
i' <- renameTyConId i
fields' <- mapM renameFieldId fields
fields'' <- mapM renameField fields'
return (CUnion i' fields'' mbsz)
FunTy cc res ps -> do
res' <- renameResult res
ps' <- mapM renameParam ps
return (FunTy cc res' ps')
Pointer _ _ x@(Char _)
| optCharPtrIsString -> return (String x False Nothing)
Pointer pt isExp t -> do
t' <- renameType t
return (Pointer pt isExp t')
Array t es -> do
t' <- renameType t
return (Array t' es)
SafeArray t -> do
t' <- renameType t
return (SafeArray t')
Sequence t mb_sz mb_term -> do
t' <- renameType t
return (Sequence t' mb_sz mb_term)
{-
We adjust the module part of a name (if any) from the name of the IDL source file
to the Haskell module that contains it.
-}
Name nm orig_nm mod mb_attrs mb_ty mb_ti ->
getModuleName $ \ mod_nm ->
getDependers $ \ deps ->
lookupTypeIdEnv (adjustHsName (fromMaybe [] mb_attrs) nm) $ \ nm' -> do
mb_attrs' <- mapMbM renameAttrs mb_attrs
ren_ty <-
case mb_ty of
Nothing -> do
r <- lookupTypeId (adjustHsName (fromMaybe [] mb_attrs) nm)
case r of
Nothing -> return (Name nm' orig_nm mod mb_attrs' (fmap snd r) mb_ti)
-- avoid 'obvious' loops.
Just (_, t) -> do
t' <- relabelType True t
return (Name nm' orig_nm mod mb_attrs' (Just t') mb_ti)
Just ty1 -> do
ty' <- relabelType True ty1
-- optionally shortening out imported synonyms
-- can sometimes reduce external dependencies.
if (optInlineTypes && isJust mod && nm /= "HRESULT") ||
((getTypeAttributes ty1 ++ fromMaybe [] mb_attrs) `hasAttributeWithName`
"ignore") then
return ty'
else
return (Name nm' orig_nm mod mb_attrs' (Just ty') mb_ti)
normaliseTy mod_nm deps ren_ty
Iface{} ->
getModuleName $ \ if_name ->
getDependers $ \ deps -> do
normaliseTy if_name deps ty
_ -> return ty
-- drop the module qualifier if it's the same as the name of the
-- containing module.
normaliseTy :: String -> [String] -> Type -> RnM Type
normaliseTy mod_nm ls t =
case t of
Iface nm (Just mod) onm attrs is_idis inh
| mkHaskellTyConName mod == mod_nm -> do
inh1 <- getBestInheritInfo nm inh
inh' <- normaliseInh mod_nm ls inh1
return (Iface (mkHaskellTyConName nm) Nothing
onm attrs is_idis inh')
Iface nm mod onm attrs is_idis inh -> do
inh1 <- getBestInheritInfo nm inh
inh' <- normaliseInh mod_nm ls inh1
return (Iface (mkHaskellTyConName nm) mod'
onm attrs is_idis inh')
where
mod' =
case mod of
Nothing -> mod
Just x ->
let h_mod = mkHaskellTyConName x in
if (optOneModulePerInterface && h_mod `elem` ls) then
Just (h_mod ++ "Ty")
else
Just h_mod
Name nm orig_nm mb_mod mb_attrs mb_ty mb_ti -> do
mb_ty' <- mapMbM (normaliseTy mod_nm ls) mb_ty
let
mb_mod' =
case mb_mod of
Just x | mkHaskellTyConName x == mod_nm -> Nothing
| otherwise -> Just (mkHaskellTyConName (dropSuffix x))
_ -> Nothing
return (Name (mkHaskellTyConName nm) orig_nm mb_mod'
mb_attrs mb_ty' mb_ti)
Pointer x isExp ty -> do
ty' <- normaliseTy mod_nm ls ty
return (Pointer x isExp ty')
SafeArray ty -> do
ty' <- normaliseTy mod_nm ls ty
return (SafeArray ty')
Sequence ty mb_sz mb_term -> do
ty' <- normaliseTy mod_nm ls ty
return (Sequence ty' mb_sz mb_term)
Array ty e -> do
ty' <- normaliseTy mod_nm ls ty
return (Array ty e)
_ -> return t
normaliseInh :: String -> [String] -> InterfaceInherit -> RnM InterfaceInherit
normaliseInh mod_nm ls inh = do
inh' <- updateMethodCount inh
mapM tweakMod inh'
where
tweakMod (q,n) = do
m <- adjustName optOneModulePerInterface q (qModule q)
mbNm <- adjustName False q (Just (qName q))
let nm = fromMaybe (qName q) mbNm
case m of
Just x | x == mod_nm -> return (q{qModule=Nothing,qName=nm}, n)
_ -> return (q{qModule=m,qName=nm}, n)
adjustName isModule q nm =
case nm of
Nothing
| isModule && (qName q) `elem` ls
-> return (Just ((qName q) ++ "Ty"))
| otherwise -> return nm
Just h_mod ->
lookupTyConEnv h_mod $ \ _ ->
-- 11/00:
-- suspicious lack of use of the result, but i'm leaving it
-- as is, for fear of perturbing anything right now.
if (isModule && h_mod `elem` ls) then
return (Just (h_mod ++ "Ty"))
else
return (Just (mkHaskellTyConName h_mod))
{-
In the following setting:
interface IB;
interface IA : IB { ... };
interface IB { ... };
we need to know how many methods there are in IB when generating
the stubs for the IA methods. 'updateMethodCount' updates this info
for IA's inherited interfaces, using the type environment that was
gathered during desugaring.
[ -fsort-defns will in most cases sort this one out for us, but
this fwd. ref. situation may still occur in a strongly connected
group of ifaces.
]
-}
updateMethodCount :: InterfaceInherit -> RnM InterfaceInherit
updateMethodCount is = mapM updateMethod is
where
updateMethod (i,n)
| n /= 0 = return (i,n) -- non-zero method count means
-- that it is up-to-date.
| otherwise = do
res <- lookupIface (qName i)
case res of
Just DispInterface{} -> return (i, 7)
Just iface@Interface{declInherit=inhs,declDecls=ds} -> do
-- make sure the parent info is up-to-date.
is' <- updateMethodCount inhs
let inh_meths = sum (map snd is')
no_meths = length (filter isMethod ds)
-- update info in env for the benefit of others.
addIface (qName i) (iface{declInherit=is'})
-- ToDo: attribute Interface decls with vtbl sizes.
return (i, no_meths + inh_meths)
_ -> return (i,n)
{-
In case we were processing something like:
interface A;
interface B { ... f(...A* x...); }
interface A : X { ... };
The inheritance info 'X' for A isn't known when processing
interface B. Rectify that here.
-}
getBestInheritInfo :: Name -> InterfaceInherit -> RnM InterfaceInherit
getBestInheritInfo nm inh = do
res <- lookupTypeId nm
case res of
Just (_, Iface _ _ _ _ _ inh2) | not (null inh2) -> return inh2
_ -> return inh
\end{code}
\begin{code}
relabelType :: Bool -> Type -> RnM Type
relabelType derefTy ty =
case ty of
Struct i [] mbsz -> do
r <- lookupTag (idName i)
case r of
Just (mod,nm) -> do
r1 <- lookupTypeId nm
case r1 of
Just (_,t) -> return (Name nm nm mod Nothing (Just t) Nothing)
Nothing -> do
return (Name nm nm mod Nothing Nothing Nothing)
Nothing -> do
--i' <- relabelTyConId i
return (Struct i [] mbsz)
Struct i fields mbsz -> do
i' <- relabelTyConId i
fields' <- mapM relabelField fields
fields'' <- mapM relabelFieldAttr fields'
return (Struct i' fields' mbsz)
Enum i flg vals -> do
i' <- relabelTyConId i >>= normaliseModName
vals' <- mapM relabelEnumTag vals
return (Enum i' flg vals')
Union i t struct_tg un_tg switches -> do
i' <- relabelTyConId i
struct_tg' <- relabelTyConId struct_tg
un_tg' <- relabelTyConId un_tg
switches' <- mapM relabelSwitch switches
return (Union i' t struct_tg' un_tg' switches')
UnionNon i switches -> do
i' <- relabelTyConId i
switches' <- mapM relabelSwitch switches
return (UnionNon i' switches')
CUnion i fields mbsz -> do
i' <- relabelTyConId i
fields' <- mapM relabelField fields
return (CUnion i' fields' mbsz)
Pointer _ _ x@(Char _)
| optCharPtrIsString -> return (String x False Nothing)
Pointer pt isExp t -> do
t' <- relabelType derefTy t
return (Pointer pt isExp t')
Array t es -> do
t' <- relabelType derefTy t
return (Array t' es)
SafeArray t -> do
t' <- relabelType derefTy t
return (SafeArray t')
Sequence t mb_sz mb_term -> do
t' <- relabelType derefTy t
return (Sequence t' mb_sz mb_term)
FunTy cc res ps -> do
res' <- relabelResult res
ps' <- mapM relabelParam ps
return (FunTy cc res' ps')
{-
We adjust the module part of a name (if any) from the name of the IDL source file
to the Haskell module that contains it.
-}
Name nm orig_nm mod mb_attrs mb_ty mb_ti ->
getModuleName $ \ mod_nm ->
getDependers $ \ deps -> do
lookupTypeIdEnv (adjustHsName (fromMaybe [] mb_attrs) nm) $ \ nm' -> do
mb_attrs' <- mapMbM renameAttrs mb_attrs
ren_ty <-
case mb_ty of
Nothing -> do
r <- lookupTypeId (adjustHsName (fromMaybe [] mb_attrs) nm)
case r of
-- avoid chains of type names..
-- iff there's no TypeInfo attached to the outermost, since
-- it takes precedence later on as it completely describes the ty.
Just (_, t) | derefTy -> do
t' <- relabelType False t
return (Name nm' orig_nm mod mb_attrs' (Just t') mb_ti)
Just (_,(Name _ _ _ a o_t mb_ti2))
| isJust mb_ti -> return (Name nm' orig_nm mod a o_t mb_ti2)
_ -> return (Name nm' orig_nm mod mb_attrs' (fmap snd r) mb_ti)
Just ty1
| optInlineTypes && isJust mod && nm /= "HRESULT" -> return ty1
| (fromMaybe [] mb_attrs ++ getTypeAttributes ty1)
`hasAttributeWithName` "ignore" -> return ty1
| otherwise -> do
ty' <- if False && derefTy then
relabelType False ty1
else
return ty1
return (Name nm' orig_nm mod mb_attrs' (Just ty') mb_ti)
normaliseTy mod_nm deps ren_ty
Iface{} ->
getModuleName $ \ if_name ->
getDependers $ \ deps -> do
normaliseTy if_name deps ty
_ -> return ty
\end{code}
\begin{code}
renameParam :: Param -> RnM Param
renameParam (Param i m ty orig_ty has_dep) = do
i' <- renameVarId i
ty' <- renameType ty
orig_ty' <- relabelType True orig_ty
return (Param i' m ty' orig_ty' has_dep)
relabelParam :: Param -> RnM Param
relabelParam (Param i m ty orig_ty has_dep) = do
i' <- relabelVarId i
ty' <- relabelType False ty
orig_ty' <- relabelType False orig_ty
return (Param i' m ty' orig_ty' has_dep)
relabelField :: Field -> RnM Field
relabelField (Field i ty orig_ty mb_sz mb_off) = do
i' <- relabelVarId i
ty' <- relabelType False ty
orig_ty' <- relabelType False orig_ty
return (Field i' ty' orig_ty' mb_sz mb_off)
relabelResult :: Result -> RnM Result
relabelResult (Result ty orig_ty) = do
ty' <- relabelType False ty
orig_ty' <- relabelType False orig_ty
return (Result ty' orig_ty')
relabelSwitch :: Switch -> RnM Switch
relabelSwitch (Switch i labs ty orig_ty) = do
i' <- relabelVarId i
ty' <- relabelType False ty
orig_ty' <- relabelType False orig_ty
return (Switch i' labs ty' orig_ty')
relabelSwitch s = return s
renameFieldId :: Field -> RnM Field
renameFieldId f = do
i' <- renameVarId (fieldId f)
return (f{fieldId=i'})
renameField :: Field -> RnM Field
renameField f@Field{fieldType=ty,fieldOrigType=o_ty} = do
ty' <- renameType ty
o_ty' <- relabelType True o_ty
return f{fieldType=ty',fieldOrigType=o_ty'}
{- UNUSED
renameFieldAttr :: Field -> RnM Field
renameFieldAttr f@Field{fieldId=i} = do
attrs <- mapM renameAttribute (idAttributes i)
return (f{fieldId=i{idAttributes=attrs}})
-}
relabelFieldAttr :: Field -> RnM Field
relabelFieldAttr f@Field{fieldId=i} = do
attrs <- mapM relabelAttribute (idAttributes i)
return (f{fieldId=i{idAttributes=attrs}})
renameResult :: Result -> RnM Result
renameResult (Result ty orig_ty) = do
ty' <- renameType ty
orig_ty' <- relabelType True orig_ty
return (Result ty' orig_ty')
renameParamAttr :: Param -> RnM Param
renameParamAttr p = do
attrs <- mapM renameAttribute (idAttributes (paramId p))
return (p{paramId=(paramId p){idAttributes=attrs}})
renameAttrs :: [Attribute] -> RnM [Attribute]
renameAttrs = mapM renameAttribute
renameAttribute :: Attribute -> RnM Attribute
renameAttribute at
| isConstantAttribute at = return at -- NB: not just an optimisation,
-- atParams will fail when given a (moded) constant attributes!
| otherwise = do
params <- mapM renameAttrParam (atParams at)
return (at{atParams=params})
renameAttrParam :: AttributeParam -> RnM AttributeParam
renameAttrParam p =
case p of
ParamVar nm -> lookupVarIdEnv nm $ \ v -> return (ParamVar v)
ParamType t -> do
t' <- renameType t
return (ParamType t')
ParamLit _ -> return p
ParamVoid -> return p
ParamPtr ptr -> do
p' <- renameAttrParam ptr
return (ParamPtr p')
ParamExpr e -> do
e' <- renameExpr e
return (ParamExpr e')
relabelAttribute :: Attribute -> RnM Attribute
relabelAttribute at
| isConstantAttribute at = return at -- NB: not just an optimisation,
-- atParams will fail when given a (moded) constant attributes!
| otherwise = do
params <- mapM relabelAttrParam (atParams at)
return (at{atParams=params})
relabelAttrParam :: AttributeParam -> RnM AttributeParam
relabelAttrParam p =
case p of
ParamVar nm -> lookupVarIdEnv nm $ \ v -> return (ParamVar v)
ParamType t -> do
t' <- relabelType True t
return (ParamType t')
ParamLit _ -> return p
ParamVoid -> return p
ParamPtr ptr -> do
p' <- relabelAttrParam ptr
return (ParamPtr p')
ParamExpr e -> do
e' <- renameExpr e
return (ParamExpr e')
renameSwitch :: Switch -> RnM Switch
renameSwitch (Switch i labs ty orig_ty) = do
i' <- renameVarId i
ty' <- renameType ty
orig_ty' <- relabelType True orig_ty
return (Switch i' labs ty' orig_ty')
renameSwitch s = return s
renameEnumTag :: EnumValue -> RnM EnumValue
renameEnumTag (EnumValue nm (Left v)) = do
nm' <- renameTyConId (adjustHsNameId nm)
return (EnumValue nm' (Left v))
renameEnumTag (EnumValue nm (Right e)) = do
nm' <- renameTyConId (adjustHsNameId nm)
e' <- renameExpr e
return (EnumValue nm' (Right e'))
relabelEnumTag :: EnumValue -> RnM EnumValue
relabelEnumTag ev =
let i = enumName ev in
lookupTyConEnv (idName i) $ \ nm -> return (ev{enumName=i{idName=nm}})
relabelVarId :: Id -> RnM Id
relabelVarId i = lookupVarIdEnv (idName i) $ \ v -> return (i{idName=v})
relabelTyConId :: Id -> RnM Id
relabelTyConId i =
lookupTyConEnv (idName i) $ \ v -> return (i{idName=v})
\end{code}
\begin{code}
renameExpr :: Expr -> RnM Expr
renameExpr e =
case e of
Binary bop e1 e2 -> do
e1' <- renameExpr e1
e2' <- renameExpr e2
return (Binary bop e1' e2')
Cond e1 e2 e3 -> do
e1' <- renameExpr e1
e2' <- renameExpr e2
e3' <- renameExpr e3
return (Cond e1' e2' e3')
Unary op e1 -> do
e1' <- renameExpr e1
return (Unary op e1')
Var nm -> lookupVarIdEnv nm $ \ v -> return (Var v)
Lit _ -> return e
Cast t e1 -> do
e' <- renameExpr e1
return (Cast t e')
Sizeof t -> do
t' <- relabelType True t
return (Sizeof t')
\end{code}
\begin{code}
adjustHsNameId :: Id -> Id
adjustHsNameId i = i{idName=adjustHsName (idAttributes i) (idName i)}
adjustHsName :: [Attribute] -> Name -> Name
adjustHsName attr nm = rmPrefix prefixes
where
prefixes = findStringAttributes "hs_prefix" attr
rmPrefix [] = nm
rmPrefix (x:xs) | x `isPrefixOf` nm = drop (length x) nm
| otherwise = rmPrefix xs
\end{code}