--  C->Haskell Compiler: binding generator
--
--  Author : Manuel M T Chakravarty
--  Created: 17 August 99
--
--  Version $Revision: 1.3 $ from $Date: 2005/10/17 20:41:30 $
--
--  Copyright (c) [1999..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 ---------------------------------------------------------------
--
--  Module implementing the expansion of the binding hooks.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  * If there is an error in one binding hook, it is skipped and the next one 
--    is processed (to collect as many errors as possible).  However, if at
--    least one error occured, the expansion of binding hooks ends in a fatal
--    exception.
--
--  * `CST' exceptions are used to back off a binding hook as soon as an error 
--    is encountered while it is processed.
--
--  Mapping of C types to Haskell FFI types:
--  ----------------------------------------
--
--  The following defines the mapping for basic types.  If the type specifer
--  is missing, it is taken to be `int'.  In the following, elements enclosed
--  in square brackets are optional.
--
--    void                      -> ()
--    char                      -> CChar
--    unsigned char             -> CUChar
--    signed char               -> CShort
--    signed                    -> CInt
--    [signed] int              -> CInt
--    [signed] short [int]      -> CSInt
--    [signed] long [int]       -> CLong
--    [signed] long long [int]  -> CLLong
--    unsigned [int]            -> CUInt
--    unsigned short [int]      -> CUShort
--    unsigned long [int]       -> CULong
--    unsigned long long [int]  -> CULLong
--    float                     -> CFloat
--    double                    -> CDouble
--    long double               -> CLDouble
--    enum ...                  -> CInt
--    struct ...                -> ** error **
--    union ...                 -> ** error **
--
--  Plain structures or unions (ie, if not the base type of a pointer type)
--  are not supported at the moment (the underlying FFI does not support them
--  directly).  Named types (ie, in C type names defined using `typedef') are
--  traced back to their original definitions.  Pointer types are mapped
--  to `Ptr a' or `FunPtr a' depending on whether they point to a functional.
--  Values obtained from bit fields are represented by `CInt' or `CUInt'
--  depending on whether they are signed.
--
--  We obtain the size and alignment constraints for all primitive types of C
--  from `CInfo', which obtains it from the Haskell 98 FFI.  In the alignment
--  computations involving bit fields, we assume that the alignment
--  constraints for bitfields (wrt to non-bitfield members) is always the same
--  as for `int' irrespective of the size of the bitfield.  This seems to be
--  implicitly guaranteed by K&R A8.3, but it is not entirely clear.
--
--  Identifier lookup:
--  ------------------
--
--  We allow to identify enumerations and structures by the names of `typedef' 
--  types aliased to them.
--
--  * enumerations: It is first checked whether there is a tag with the given
--      identifier; if such a tag does not exist, the definition of a typedef
--      with the same name is taken if it exists.
--  * structs/unions: like enumerations
--
--  We generally use `shadow' lookups.  When an identifier cannot be found,
--  we check whether - according to the prefix set by the context hook -
--  another identifier casts a shadow that matches.  If so, that identifier is
--  taken instead of the original one.
--
--- TODO ----------------------------------------------------------------------
--
--  * A function prototype that uses a defined type on its left hand side may
--    declare a function, while that is not obvious from the declaration
--    itself (without also considering the `typedef').  Calls to such
--    functions are currently rejected, which is a BUG.
--
--  * context hook must precede all but the import hooks
--
--  * The use of `++' in the recursive definition of the routines generating
--    `Enum' instances is not particularly efficient.
--
--  * Some operands are missing in `applyBin' - unfortunately, Haskell does
--    not have standard bit operations.   Some constructs are also missing
--    from `evalConstCExpr'.  Haskell 98 FFI standardises `Bits'; use that.
--

module GenBind (expandHooks) 
where 

-- standard libraries
import Data.Char          (toUpper, toLower, isSpace)
import Data.List          (deleteBy, intersperse, isPrefixOf, find, nubBy)
import Data.Maybe         (isNothing, isJust, fromJust, fromMaybe)
import Control.Monad      (when, unless, liftM, mapAndUnzipM)

import Data.Bits  ((.&.), (.|.), xor, complement)

-- Compiler Toolkit
import Position   (Position, Pos(posOf), nopos, builtinPos)
import Errors     (interr, todo)
import Idents     (Ident, identToLexeme, onlyPosIdent)
import Attributes (newAttrsOnlyPos)

-- C->Haskell
import C2HSConfig (dlsuffix)
import C2HSState  (CST, nop, errorsPresent, showErrors, fatal,
                   SwitchBoard(..), Traces(..), putTraceStr, getSwitch,
                   printCIO)
import C          (AttrC, CObj(..), CTag(..), lookupDefObjC, lookupDefTagC,
                   CHeader(..), CExtDecl, CDecl(..), CDeclSpec(..),
                   CStorageSpec(..), CTypeSpec(..), CTypeQual(..),
                   CStructUnion(..), CStructTag(..), CEnum(..), CDeclr(..),
                   CInit(..), CExpr(..), CAssignOp(..), CBinaryOp(..),
                   CUnaryOp(..), CConst (..),
                   CT, readCT, transCT, getCHeaderCT, runCT, ifCTExc,
                   raiseErrorCTExc, findValueObj, findFunObj, findTag,
                   findTypeObj, applyPrefixToNameSpaces, isTypedef,
                   simplifyDecl, declrFromDecl, declrNamed, structMembers,
                   structName, tagName, declaredName , structFromDecl,
                   funResultAndArgs, chaseDecl, findAndChaseDecl,
                   findObjShadow,
                   checkForAlias, checkForOneAliasName, lookupEnum,
                   lookupStructUnion, lookupDeclOrTag, isPtrDeclr,
                   isArrDeclr, dropPtrDeclr, isPtrDecl, getDeclOf, isFunDeclr,
                   refersToNewDef, CDef(..))

-- friends
import CHS        (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),
                   CHSParm(..), CHSArg(..), CHSAccess(..), CHSAPath(..),
                   CHSPtrType(..), showCHSParm) 
import CInfo      (CPrimType(..), size, alignment, bitfieldIntSigned,
                   bitfieldAlignment)
import GBMonad    (TransFun, transTabToTransFun, HsObject(..), GB, HsPtrRep,
                   initialGBState, setContext, getPrefix, getLock,
                   delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,
                   queryObj, queryClass, queryPointer, mergeMaps, dumpMaps)

-- default marshallers
-- -------------------

-- FIXME: 
-- - we might have a dynamically extended table in the monad if needed (we
--   could marshall enums this way and also save the `id' marshallers for
--   pointers defined via (newtype) pointer hooks)
-- - the checks for the Haskell types are quite kludgy

-- determine the default "in" marshaller for the given Haskell and C types
--
lookupDftMarshIn :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshIn :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshIn String
"Bool"   [PrimET CPrimType
pt] | CPrimType -> Bool
isIntegralCPrimType CPrimType
pt = 
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
cFromBoolIde, CHSArg
CHSValArg)
lookupDftMarshIn String
hsTy     [PrimET CPrimType
pt] | String -> Bool
isIntegralHsType String
hsTy 
                                      Bool -> Bool -> Bool
&&CPrimType -> Bool
isIntegralCPrimType CPrimType
pt = 
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
cIntConvIde, CHSArg
CHSValArg)
lookupDftMarshIn String
hsTy     [PrimET CPrimType
pt] | String -> Bool
isFloatHsType String
hsTy 
                                      Bool -> Bool -> Bool
&&CPrimType -> Bool
isFloatCPrimType CPrimType
pt    = 
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
cFloatConvIde, CHSArg
CHSValArg)
lookupDftMarshIn String
"String" [PtrET (PrimET CPrimType
CCharPT)]             =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
withCStringIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
"String" [PtrET (PrimET CPrimType
CCharPT), PrimET CPrimType
pt]  
  | CPrimType -> Bool
isIntegralCPrimType CPrimType
pt                                     =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
withCStringLenIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
hsTy     [PtrET ExtType
ty]  | ExtType -> String
showExtType ExtType
ty String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
hsTy =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
withIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
hsTy     [PtrET (PrimET CPrimType
pt)]  
  | String -> Bool
isIntegralHsType String
hsTy Bool -> Bool -> Bool
&& CPrimType -> Bool
isIntegralCPrimType CPrimType
pt            =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
withIntConvIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
hsTy     [PtrET (PrimET CPrimType
pt)]  
  | String -> Bool
isFloatHsType String
hsTy Bool -> Bool -> Bool
&& CPrimType -> Bool
isFloatCPrimType CPrimType
pt                  =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
withFloatConvIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
"Bool"   [PtrET (PrimET CPrimType
pt)]  
  | CPrimType -> Bool
isIntegralCPrimType CPrimType
pt                                     =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
withFromBoolIde, CHSArg
CHSIOArg)
-- FIXME: handle array-list conversion
lookupDftMarshIn String
_        [ExtType]
_                                    = 
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ident, CHSArg)
forall a. Maybe a
Nothing

-- determine the default "out" marshaller for the given Haskell and C types
--
lookupDftMarshOut :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshOut :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshOut String
"()"     [ExtType]
_                                    =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
voidIde, CHSArg
CHSVoidArg)
lookupDftMarshOut String
"Bool"   [PrimET CPrimType
pt] | CPrimType -> Bool
isIntegralCPrimType CPrimType
pt = 
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
cToBoolIde, CHSArg
CHSValArg)
lookupDftMarshOut String
hsTy     [PrimET CPrimType
pt] | String -> Bool
isIntegralHsType String
hsTy 
                                       Bool -> Bool -> Bool
&&CPrimType -> Bool
isIntegralCPrimType CPrimType
pt = 
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
cIntConvIde, CHSArg
CHSValArg)
lookupDftMarshOut String
hsTy     [PrimET CPrimType
pt] | String -> Bool
isFloatHsType String
hsTy 
                                       Bool -> Bool -> Bool
&&CPrimType -> Bool
isFloatCPrimType CPrimType
pt    = 
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
cFloatConvIde, CHSArg
CHSValArg)
lookupDftMarshOut String
"String" [PtrET (PrimET CPrimType
CCharPT)]             =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
peekCStringIde, CHSArg
CHSIOArg)
lookupDftMarshOut String
"String" [PtrET (PrimET CPrimType
CCharPT), PrimET CPrimType
pt]  
  | CPrimType -> Bool
isIntegralCPrimType CPrimType
pt                                      =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
peekCStringLenIde, CHSArg
CHSIOArg)
lookupDftMarshOut String
hsTy     [PtrET ExtType
ty]  | ExtType -> String
showExtType ExtType
ty String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
hsTy =
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
-> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall a b. (a -> b) -> a -> b
$ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (Ident
peekIde, CHSArg
CHSIOArg)
-- FIXME: add combination, such as "peek" plus "cIntConv" etc
-- FIXME: handle array-list conversion
lookupDftMarshOut String
_        [ExtType]
_                                    = 
  Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ident, CHSArg)
forall a. Maybe a
Nothing


-- check for integral Haskell types
--
isIntegralHsType :: String -> Bool
isIntegralHsType :: String -> Bool
isIntegralHsType String
"Int"    = Bool
True
isIntegralHsType String
"Int8"   = Bool
True
isIntegralHsType String
"Int16"  = Bool
True
isIntegralHsType String
"Int32"  = Bool
True
isIntegralHsType String
"Int64"  = Bool
True
isIntegralHsType String
"Word8"  = Bool
True
isIntegralHsType String
"Word16" = Bool
True
isIntegralHsType String
"Word32" = Bool
True
isIntegralHsType String
"Word64" = Bool
True
isIntegralHsType String
_        = Bool
False

-- check for floating Haskell types
--
isFloatHsType :: String -> Bool
isFloatHsType :: String -> Bool
isFloatHsType String
"Float"  = Bool
True
isFloatHsType String
"Double" = Bool
True
isFloatHsType String
_        = Bool
False

-- check for integral C types
--
--  * For marshalling purposes C char's are integral types (see also types
--   classes for which the FFI guarantees instances for `CChar', `CSChar', and
--   `CUChar')
--
isIntegralCPrimType :: CPrimType -> Bool
isIntegralCPrimType :: CPrimType -> Bool
isIntegralCPrimType  = (CPrimType -> [CPrimType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CPrimType
CCharPT, CPrimType
CSCharPT, CPrimType
CIntPT, CPrimType
CShortPT, CPrimType
CLongPT,
                                CPrimType
CLLongPT, CPrimType
CUIntPT, CPrimType
CUCharPT, CPrimType
CUShortPT,
                                CPrimType
CULongPT, CPrimType
CULLongPT]) 

-- check for floating C types
--
isFloatCPrimType :: CPrimType -> Bool
isFloatCPrimType :: CPrimType -> Bool
isFloatCPrimType  = (CPrimType -> [CPrimType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CPrimType
CFloatPT, CPrimType
CDoublePT, CPrimType
CLDoublePT])

-- standard conversions
--
voidIde :: Ident
voidIde           = String -> Ident
noPosIdent String
"void"         -- never appears in the output
cFromBoolIde :: Ident
cFromBoolIde      = String -> Ident
noPosIdent String
"cFromBool"
cToBoolIde :: Ident
cToBoolIde        = String -> Ident
noPosIdent String
"cToBool"
cIntConvIde :: Ident
cIntConvIde       = String -> Ident
noPosIdent String
"cIntConv"
cFloatConvIde :: Ident
cFloatConvIde     = String -> Ident
noPosIdent String
"cFloatConv"
withIde :: Ident
withIde           = String -> Ident
noPosIdent String
"with"
withCStringIde :: Ident
withCStringIde    = String -> Ident
noPosIdent String
"withCString"
withCStringLenIde :: Ident
withCStringLenIde = String -> Ident
noPosIdent String
"withCStringLenIntConv"
withIntConvIde :: Ident
withIntConvIde    = String -> Ident
noPosIdent String
"withIntConv"
withFloatConvIde :: Ident
withFloatConvIde  = String -> Ident
noPosIdent String
"withFloatConv"
withFromBoolIde :: Ident
withFromBoolIde   = String -> Ident
noPosIdent String
"withFromBoolConv"
peekIde :: Ident
peekIde           = String -> Ident
noPosIdent String
"peek"
peekCStringIde :: Ident
peekCStringIde    = String -> Ident
noPosIdent String
"peekCString"
peekCStringLenIde :: Ident
peekCStringLenIde = String -> Ident
noPosIdent String
"peekCStringLenIntConv"


-- expansion of binding hooks
-- --------------------------

-- given a C header file and a binding file, expand all hooks in the binding
-- file using the C header information (EXPORTED)
--
--  * together with the module, returns the contents of the .chi file
--
--  * if any error (not warnings) is encountered, a fatal error is raised.
--
--  * also returns all warning messages encountered (last component of result)
--
expandHooks        :: AttrC -> CHSModule -> CST s (CHSModule, String, String)
expandHooks :: AttrC -> CHSModule -> CST s (CHSModule, String, String)
expandHooks AttrC
ac CHSModule
mod  = do
  Maybe String
mLock <- (SwitchBoard -> Maybe String) -> CST s (Maybe String)
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Maybe String
lockFunSB
  (AttrC
_, (CHSModule, String, String)
res) <- CT GBState (CHSModule, String, String)
-> AttrC -> GBState -> CST s (AttrC, (CHSModule, String, String))
forall s a t. CT s a -> AttrC -> s -> CST t (AttrC, a)
runCT (CHSModule -> CT GBState (CHSModule, String, String)
expandModule CHSModule
mod) AttrC
ac (Maybe String -> GBState
initialGBState Maybe String
mLock)
  (CHSModule, String, String) -> CST s (CHSModule, String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSModule, String, String)
res

expandModule                   :: CHSModule -> GB (CHSModule, String, String)
expandModule :: CHSModule -> CT GBState (CHSModule, String, String)
expandModule (CHSModule [CHSFrag]
frags)  =
  do
    -- expand hooks
    --
    CST (CState GBState) ()
forall s. CST s ()
traceInfoExpand
    [CHSFrag]
frags'       <- [CHSFrag] -> GB [CHSFrag]
expandFrags [CHSFrag]
frags
    [CHSFrag]
delayedFrags <- GB [CHSFrag]
getDelayedCode

    -- get .chi dump
    --
    String
chi <- GB String
dumpMaps

    -- check for errors and finalise
    --
    Bool
errs <- PreCST SwitchBoard (CState GBState) Bool
forall e s. PreCST e s Bool
errorsPresent
    if Bool
errs
      then do
        CST (CState GBState) ()
forall s. CST s ()
traceInfoErr
        String
errmsgs <- GB String
forall e s. PreCST e s String
showErrors
        String -> CT GBState (CHSModule, String, String)
forall e s a. String -> PreCST e s a
fatal (String
"Errors during expansion of binding hooks:\n\n"   -- fatal error
               String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errmsgs)
      else do
        CST (CState GBState) ()
forall s. CST s ()
traceInfoOK
        String
warnmsgs <- GB String
forall e s. PreCST e s String
showErrors
        (CHSModule, String, String)
-> CT GBState (CHSModule, String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CHSModule
CHSModule ([CHSFrag]
frags' [CHSFrag] -> [CHSFrag] -> [CHSFrag]
forall a. [a] -> [a] -> [a]
++ [CHSFrag]
delayedFrags), String
chi, String
warnmsgs)
  where
    traceInfoExpand :: CST s ()
traceInfoExpand = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW 
                        (String
"...expanding binding hooks...\n")
    traceInfoErr :: CST s ()
traceInfoErr    = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW 
                        (String
"...error(s) detected.\n")
    traceInfoOK :: CST s ()
traceInfoOK     = (Traces -> Bool) -> String -> CST s ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW 
                        (String
"...successfully completed.\n")

expandFrags :: [CHSFrag] -> GB [CHSFrag]
expandFrags :: [CHSFrag] -> GB [CHSFrag]
expandFrags = ([[CHSFrag]] -> [CHSFrag])
-> PreCST SwitchBoard (CState GBState) [[CHSFrag]] -> GB [CHSFrag]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[CHSFrag]] -> [CHSFrag]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (PreCST SwitchBoard (CState GBState) [[CHSFrag]] -> GB [CHSFrag])
-> ([CHSFrag] -> PreCST SwitchBoard (CState GBState) [[CHSFrag]])
-> [CHSFrag]
-> GB [CHSFrag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CHSFrag -> GB [CHSFrag])
-> [CHSFrag] -> PreCST SwitchBoard (CState GBState) [[CHSFrag]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CHSFrag -> GB [CHSFrag]
expandFrag

expandFrag :: CHSFrag -> GB [CHSFrag]
expandFrag :: CHSFrag -> GB [CHSFrag]
expandFrag verb :: CHSFrag
verb@(CHSVerb String
_ Position
_     ) = [CHSFrag] -> GB [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return [CHSFrag
verb]
expandFrag line :: CHSFrag
line@(CHSLine Position
_       ) = [CHSFrag] -> GB [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return [CHSFrag
line]
expandFrag prag :: CHSFrag
prag@(CHSLang [String]
_ Position
_     ) = [CHSFrag] -> GB [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return [CHSFrag
prag]
expandFrag      (CHSHook CHSHook
h       ) = 
  do
    String
code <- CHSHook -> GB String
expandHook CHSHook
h
    [CHSFrag] -> GB [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Position -> CHSFrag
CHSVerb String
code Position
builtinPos]
  GB [CHSFrag] -> GB [CHSFrag] -> GB [CHSFrag]
forall s a. CT s a -> CT s a -> CT s a
`ifCTExc` [CHSFrag] -> GB [CHSFrag]
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Position -> CHSFrag
CHSVerb String
"** ERROR **" Position
builtinPos]
expandFrag      (CHSCPP  String
s Position
_     ) = 
  String -> GB [CHSFrag]
forall a. String -> a
interr (String -> GB [CHSFrag]) -> String -> GB [CHSFrag]
forall a b. (a -> b) -> a -> b
$ String
"GenBind.expandFrag: Left over CHSCPP!\n---\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n---"
expandFrag      (CHSC    String
s Position
_     ) = 
  String -> GB [CHSFrag]
forall a. String -> a
interr (String -> GB [CHSFrag]) -> String -> GB [CHSFrag]
forall a b. (a -> b) -> a -> b
$ String
"GenBind.expandFrag: Left over CHSC!\n---\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n---"
expandFrag      (CHSCond [(Ident, [CHSFrag])]
alts Maybe [CHSFrag]
dft) = 
  do
    CST (CState GBState) ()
traceInfoCond
    [(Ident, [CHSFrag])] -> GB [CHSFrag]
select [(Ident, [CHSFrag])]
alts
  where
    select :: [(Ident, [CHSFrag])] -> GB [CHSFrag]
select []                  = do
                                   Maybe [CHSFrag] -> CST (CState GBState) ()
forall a. Maybe a -> CST (CState GBState) ()
traceInfoDft Maybe [CHSFrag]
dft
                                   [CHSFrag] -> GB [CHSFrag]
expandFrags ([CHSFrag]
-> ([CHSFrag] -> [CHSFrag]) -> Maybe [CHSFrag] -> [CHSFrag]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [CHSFrag] -> [CHSFrag]
forall a. a -> a
id Maybe [CHSFrag]
dft)
    select ((Ident
ide, [CHSFrag]
frags):[(Ident, [CHSFrag])]
alts) = do
                                   Maybe CTag
oobj <- Ident -> CT GBState (Maybe CTag)
forall s. Ident -> CT s (Maybe CTag)
findTag Ident
ide
                                   Ident -> Maybe CTag -> CST (CState GBState) ()
forall a. Ident -> Maybe a -> CST (CState GBState) ()
traceInfoVal Ident
ide Maybe CTag
oobj
                                   if Maybe CTag -> Bool
forall a. Maybe a -> Bool
isNothing Maybe CTag
oobj
                                     then
                                       [(Ident, [CHSFrag])] -> GB [CHSFrag]
select [(Ident, [CHSFrag])]
alts
                                     else            -- found right alternative
                                       [CHSFrag] -> GB [CHSFrag]
expandFrags [CHSFrag]
frags
    --
    traceInfoCond :: CST (CState GBState) ()
traceInfoCond         = String -> CST (CState GBState) ()
traceGenBind String
"** CPP conditional:\n"
    traceInfoVal :: Ident -> Maybe a -> CST (CState GBState) ()
traceInfoVal Ident
ide Maybe a
oobj = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ Ident -> String
identToLexeme Ident
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                              (if Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
oobj then String
"not " else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++
                              String
"defined.\n"
    traceInfoDft :: Maybe a -> CST (CState GBState) ()
traceInfoDft Maybe a
dft      = if Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
dft 
                            then 
                              () -> CST (CState GBState) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () 
                            else 
                              String -> CST (CState GBState) ()
traceGenBind String
"Choosing else branch.\n"

expandHook :: CHSHook -> GB String
expandHook :: CHSHook -> GB String
expandHook (CHSImport Bool
qual Ident
ide String
chi Position
_) =
  do
    String -> CST (CState GBState) ()
mergeMaps String
chi
    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
$ 
      String
"import " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
qual then String
"qualified " else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide
expandHook (CHSContext Maybe String
olib Maybe String
oprefix Maybe String
olock Position
_) =
  do
    Maybe String
-> Maybe String -> Maybe String -> CST (CState GBState) ()
setContext Maybe String
olib Maybe String
oprefix Maybe String
olock              -- enter context information
    (String -> CST (CState GBState) ())
-> Maybe String -> CST (CState GBState) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ String -> CST (CState GBState) ()
forall s. String -> CT s ()
applyPrefixToNameSpaces Maybe String
oprefix -- use the prefix on name spaces
    String -> GB String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
expandHook (CHSType Ident
ide Position
pos) =
  do
    CST (CState GBState) ()
traceInfoType
    CDecl
decl <- Ident -> Bool -> Bool -> CT GBState CDecl
forall s. Ident -> Bool -> Bool -> CT s CDecl
findAndChaseDecl Ident
ide Bool
False Bool
True     -- no indirection, but shadows
    ExtType
ty <- Position -> CDecl -> GB ExtType
extractSimpleType Position
pos CDecl
decl
    CDecl -> ExtType -> CST (CState GBState) ()
forall a. Show a => a -> ExtType -> CST (CState GBState) ()
traceInfoDump CDecl
decl ExtType
ty
    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
$ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  where
    traceInfoType :: CST (CState GBState) ()
traceInfoType         = String -> CST (CState GBState) ()
traceGenBind String
"** Type hook:\n"
    traceInfoDump :: a -> ExtType -> CST (CState GBState) ()
traceInfoDump a
decl ExtType
ty = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$
      String
"Declaration\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
decl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\ntranslates to\n" 
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
expandHook (CHSSizeof Ident
ide Position
pos) =
  do
    CST (CState GBState) ()
traceInfoSizeof
    CDecl
decl <- Ident -> Bool -> Bool -> CT GBState CDecl
forall s. Ident -> Bool -> Bool -> CT s CDecl
findAndChaseDecl Ident
ide Bool
False Bool
True     -- no indirection, but shadows
    (BitSize
size, Int
_) <- CDecl -> GB (BitSize, Int)
sizeAlignOf CDecl
decl
    CDecl -> BitSize -> CST (CState GBState) ()
forall a. Show a => a -> BitSize -> CST (CState GBState) ()
traceInfoDump CDecl
decl BitSize
size
    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
$ Integer -> String
forall a. Show a => a -> String
show (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (BitSize -> Int) -> BitSize -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitSize -> Int
padBits (BitSize -> Integer) -> BitSize -> Integer
forall a b. (a -> b) -> a -> b
$ BitSize
size)
  where
    traceInfoSizeof :: CST (CState GBState) ()
traceInfoSizeof         = String -> CST (CState GBState) ()
traceGenBind String
"** Sizeof hook:\n"
    traceInfoDump :: a -> BitSize -> CST (CState GBState) ()
traceInfoDump a
decl BitSize
size = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$
      String
"Size of declaration\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
decl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nis " 
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (BitSize -> Int) -> BitSize -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitSize -> Int
padBits (BitSize -> Integer) -> BitSize -> Integer
forall a b. (a -> b) -> a -> b
$ BitSize
size) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
expandHook (CHSEnum Ident
cide Maybe Ident
oalias CHSTrans
chsTrans Maybe String
oprefix [Ident]
derive Position
_) =
  do
    -- get the corresponding C declaration
    --
    CEnum
enum <- Ident -> Bool -> CT GBState CEnum
forall s. Ident -> Bool -> CT s CEnum
lookupEnum Ident
cide Bool
True        -- smart lookup incl error handling
    --
    -- convert the translation table and generate data type definition code
    --
    String
gprefix <- GB String
getPrefix
    let prefix :: String
prefix = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
gprefix Maybe String
oprefix
        trans :: Ident -> String
trans  = String -> CHSTrans -> Ident -> String
transTabToTransFun String
prefix CHSTrans
chsTrans
        hide :: String
hide   = Ident -> String
identToLexeme (Ident -> String)
-> (Maybe Ident -> Ident) -> Maybe Ident -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Maybe Ident -> Ident
forall a. a -> Maybe a -> a
fromMaybe Ident
cide (Maybe Ident -> String) -> Maybe Ident -> String
forall a b. (a -> b) -> a -> b
$ Maybe Ident
oalias
    CEnum -> String -> (Ident -> String) -> [String] -> GB String
enumDef CEnum
enum String
hide Ident -> String
trans ((Ident -> String) -> [Ident] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
identToLexeme [Ident]
derive)
expandHook hook :: CHSHook
hook@(CHSCall Bool
isPure Bool
isUns Bool
isNol Ident
ide Maybe Ident
oalias Position
pos) =
  do
    CST (CState GBState) ()
traceEnter
    -- get the corresponding C declaration; raises error if not found or not a
    -- function; we use shadow identifiers, so the returned identifier is used 
    -- afterwards instead of the original one
    --
    (ObjCO CDecl
cdecl, Ident
ide) <- Ident -> Bool -> CT GBState (CObj, Ident)
forall s. Ident -> Bool -> CT s (CObj, Ident)
findFunObj Ident
ide Bool
True
    Maybe String
mLock <- if Bool
isNol then Maybe String -> PreCST SwitchBoard (CState GBState) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing else PreCST SwitchBoard (CState GBState) (Maybe String)
getLock
    let ideLexeme :: String
ideLexeme = Ident -> String
identToLexeme Ident
ide  -- orignal name might have been a shadow
        hsLexeme :: String
hsLexeme  = String
ideLexeme String -> (Ident -> String) -> Maybe Ident -> String
forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` Ident -> String
identToLexeme (Maybe Ident -> String) -> Maybe Ident -> String
forall a b. (a -> b) -> a -> b
$ Maybe Ident
oalias
        cdecl' :: CDecl
cdecl'    = Ident
ide Ident -> CDecl -> CDecl
`simplifyDecl` CDecl
cdecl
    CHSHook
-> Bool
-> Bool
-> Maybe String
-> String
-> String
-> CDecl
-> Position
-> GB String
callImport CHSHook
hook Bool
isPure Bool
isUns Maybe String
mLock String
ideLexeme String
hsLexeme CDecl
cdecl' Position
pos
  where
    traceEnter :: CST (CState GBState) ()
traceEnter = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"** Call hook for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"':\n"
expandHook hook :: CHSHook
hook@(CHSFun Bool
isPure Bool
isUns Bool
isNol Ident
ide Maybe Ident
oalias Maybe String
ctxt [CHSParm]
parms CHSParm
parm Position
pos) =
  do
    CST (CState GBState) ()
traceEnter
    -- get the corresponding C declaration; raises error if not found or not a
    -- function; we use shadow identifiers, so the returned identifier is used 
    -- afterwards instead of the original one
    --
    (ObjCO CDecl
cdecl, Ident
cide) <- Ident -> Bool -> CT GBState (CObj, Ident)
forall s. Ident -> Bool -> CT s (CObj, Ident)
findFunObj Ident
ide Bool
True
    Maybe String
mLock <- if Bool
isNol then Maybe String -> PreCST SwitchBoard (CState GBState) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing else PreCST SwitchBoard (CState GBState) (Maybe String)
getLock
    let ideLexeme :: String
ideLexeme = Ident -> String
identToLexeme Ident
ide  -- orignal name might have been a shadow
        hsLexeme :: String
hsLexeme  = String
ideLexeme String -> (Ident -> String) -> Maybe Ident -> String
forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` Ident -> String
identToLexeme (Maybe Ident -> String) -> Maybe Ident -> String
forall a b. (a -> b) -> a -> b
$ Maybe Ident
oalias
        fiLexeme :: String
fiLexeme  = String
hsLexeme String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'_"   --  *Urgh* - probably unique...
        fiIde :: Ident
fiIde     = Position -> String -> Ident
onlyPosIdent Position
nopos String
fiLexeme
        cdecl' :: CDecl
cdecl'    = Ident
cide Ident -> CDecl -> CDecl
`simplifyDecl` CDecl
cdecl
        callHook :: CHSHook
callHook  = Bool -> Bool -> Bool -> Ident -> Maybe Ident -> Position -> CHSHook
CHSCall Bool
isPure Bool
isUns Bool
isNol Ident
cide (Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
fiIde) Position
pos
    CHSHook
-> Bool
-> Bool
-> Maybe String
-> String
-> String
-> CDecl
-> Position
-> GB String
callImport CHSHook
callHook Bool
isPure Bool
isUns Maybe String
mLock (Ident -> String
identToLexeme Ident
cide) String
fiLexeme CDecl
cdecl' Position
pos
    Bool
-> String
-> String
-> CDecl
-> Maybe String
-> Maybe String
-> [CHSParm]
-> CHSParm
-> Position
-> GB String
funDef Bool
isPure String
hsLexeme String
fiLexeme CDecl
cdecl' Maybe String
ctxt Maybe String
mLock [CHSParm]
parms CHSParm
parm Position
pos
  where
    traceEnter :: CST (CState GBState) ()
traceEnter = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"** Fun hook for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"':\n"
expandHook (CHSField CHSAccess
access CHSAPath
path Position
pos) =
  do
    CST (CState GBState) ()
traceInfoField
    (CDecl
decl, [BitSize]
offsets) <- CHSAPath -> GB (CDecl, [BitSize])
accessPath CHSAPath
path
    [BitSize] -> CST (CState GBState) ()
forall (t :: * -> *) a.
Foldable t =>
t a -> CST (CState GBState) ()
traceDepth [BitSize]
offsets
    ExtType
ty <- Position -> CDecl -> GB ExtType
extractSimpleType Position
pos CDecl
decl
    ExtType -> CST (CState GBState) ()
traceValueType ExtType
ty
    Position -> CHSAccess -> [BitSize] -> ExtType -> GB String
setGet Position
pos CHSAccess
access [BitSize]
offsets ExtType
ty
  where
    accessString :: String
accessString       = case CHSAccess
access of
                           CHSAccess
CHSGet -> String
"Get"
                           CHSAccess
CHSSet -> String
"Set"
    traceInfoField :: CST (CState GBState) ()
traceInfoField     = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ String
"** " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
accessString String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" hook:\n"
    traceDepth :: t a -> CST (CState GBState) ()
traceDepth t a
offsets = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ String
"Depth of access path: " 
                                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
offsets) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
    traceValueType :: ExtType -> CST (CState GBState) ()
traceValueType ExtType
et  = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"Type of accessed value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
et String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
expandHook (CHSPointer Bool
isStar Ident
cName Maybe Ident
oalias CHSPtrType
ptrKind Bool
isNewtype Maybe Ident
oRefType Position
pos) =
  do
    CST (CState GBState) ()
traceInfoPointer
    let hsIde :: Ident
hsIde  = Ident -> Maybe Ident -> Ident
forall a. a -> Maybe a -> a
fromMaybe Ident
cName Maybe Ident
oalias
        hsName :: String
hsName = Ident -> String
identToLexeme Ident
hsIde
    Ident
hsIde Ident -> HsObject -> CST (CState GBState) ()
`objIs` CHSPtrType -> Bool -> HsObject
Pointer CHSPtrType
ptrKind Bool
isNewtype     -- register Haskell object
    --
    -- we check for a typedef declaration or tag (struct, union, or enum)
    --
    Either CDecl CTag
declOrTag <- Ident -> Bool -> CT GBState (Either CDecl CTag)
forall s. Ident -> Bool -> CT s (Either CDecl CTag)
lookupDeclOrTag Ident
cName Bool
True
    case Either CDecl CTag
declOrTag of
      Left CDecl
cdecl -> do                          -- found a typedef declaration
        Ident
cNameFull <- case CDecl -> Maybe Ident
declaredName CDecl
cdecl of
                       Just Ident
ide -> Ident -> PreCST SwitchBoard (CState GBState) Ident
forall (m :: * -> *) a. Monad m => a -> m a
return Ident
ide
                       Maybe Ident
Nothing  -> String -> PreCST SwitchBoard (CState GBState) Ident
forall a. String -> a
interr 
                                     String
"GenBind.expandHook: Where is the name?"
        Ident
cNameFull Ident -> CDef -> CST (CState GBState) ()
forall s. Ident -> CDef -> CT s ()
`refersToNewDef` CObj -> CDef
ObjCD (CDecl -> CObj
TypeCO CDecl
cdecl) 
                                   -- assoc needed for chasing
        String -> Ident -> CST (CState GBState) ()
traceInfoCName String
"declaration" Ident
cNameFull
        Bool -> CST (CState GBState) () -> CST (CState GBState) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isStar Bool -> Bool -> Bool
|| CDecl -> Bool
isPtrDecl CDecl
cdecl) (CST (CState GBState) () -> CST (CState GBState) ())
-> CST (CState GBState) () -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
          Position -> CST (CState GBState) ()
forall a. Position -> GB a
ptrExpectedErr (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
cName)
        (String
hsType, Bool
isFun) <- 
          case Maybe Ident
oRefType of
            Maybe Ident
Nothing     -> do
                             CDecl
cDecl <- Ident -> Bool -> CT GBState CDecl
forall s. Ident -> Bool -> CT s CDecl
chaseDecl Ident
cNameFull (Bool -> Bool
not Bool
isStar)
                             ExtType
et    <- CDecl -> GB ExtType
extractPtrType CDecl
cDecl
                             let et' :: ExtType
et' = Bool -> ExtType -> ExtType
adjustPtr Bool
isStar ExtType
et
                             (String, Bool)
-> PreCST SwitchBoard (CState GBState) (String, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtType -> String
showExtType ExtType
et', ExtType -> Bool
isFunExtType ExtType
et')
            Just Ident
hsType -> (String, Bool)
-> PreCST SwitchBoard (CState GBState) (String, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> String
identToLexeme Ident
hsType, Bool
False)
            -- FIXME: it is not possible to determine whether `hsType'
            --   is a function; we would need to extend the syntax to
            --   allow `... -> fun HSTYPE' to explicitly mark function
            --   types if this ever becomes important
        String -> String -> CST (CState GBState) ()
traceInfoHsType String
hsName String
hsType
        Ident
realCName <- (Maybe (CObj, Ident) -> Ident)
-> PreCST SwitchBoard (CState GBState) (Maybe (CObj, Ident))
-> PreCST SwitchBoard (CState GBState) Ident
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Ident -> ((CObj, Ident) -> Ident) -> Maybe (CObj, Ident) -> Ident
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Ident
cName (CObj, Ident) -> Ident
forall a b. (a, b) -> b
snd) (PreCST SwitchBoard (CState GBState) (Maybe (CObj, Ident))
 -> PreCST SwitchBoard (CState GBState) Ident)
-> PreCST SwitchBoard (CState GBState) (Maybe (CObj, Ident))
-> PreCST SwitchBoard (CState GBState) Ident
forall a b. (a -> b) -> a -> b
$ Ident -> PreCST SwitchBoard (CState GBState) (Maybe (CObj, Ident))
forall s. Ident -> CT s (Maybe (CObj, Ident))
findObjShadow Ident
cName
        Bool
-> Ident
-> String
-> CHSPtrType
-> Bool
-> String
-> Bool
-> GB String
pointerDef Bool
isStar Ident
realCName String
hsName CHSPtrType
ptrKind Bool
isNewtype String
hsType Bool
isFun
      Right CTag
tag -> do                           -- found a tag definition
        let cNameFull :: Ident
cNameFull = CTag -> Ident
tagName CTag
tag
        String -> Ident -> CST (CState GBState) ()
traceInfoCName String
"tag definition" Ident
cNameFull
        Bool -> CST (CState GBState) () -> CST (CState GBState) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isStar (CST (CState GBState) () -> CST (CState GBState) ())
-> CST (CState GBState) () -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$                         -- tags need an explicit `*'
          Position -> CST (CState GBState) ()
forall a. Position -> GB a
ptrExpectedErr (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
cName)
        let hsType :: String
hsType = case Maybe Ident
oRefType of
                       Maybe Ident
Nothing     -> String
"()"
                       Just Ident
hsType -> Ident -> String
identToLexeme Ident
hsType
        String -> String -> CST (CState GBState) ()
traceInfoHsType String
hsName String
hsType
        Bool
-> Ident
-> String
-> CHSPtrType
-> Bool
-> String
-> Bool
-> GB String
pointerDef Bool
isStar Ident
cNameFull String
hsName CHSPtrType
ptrKind Bool
isNewtype String
hsType Bool
False
  where
    -- remove a pointer level if the first argument is `False'
    --
    adjustPtr :: Bool -> ExtType -> ExtType
adjustPtr Bool
True  ExtType
et         = ExtType
et
    adjustPtr Bool
False (PtrET ExtType
et) = ExtType
et
    adjustPtr Bool
_     ExtType
_          = String -> ExtType
forall a. String -> a
interr String
"GenBind.adjustPtr: Where is the Ptr?"
    --
    traceInfoPointer :: CST (CState GBState) ()
traceInfoPointer        = String -> CST (CState GBState) ()
traceGenBind String
"** Pointer hook:\n"
    traceInfoCName :: String -> Ident -> CST (CState GBState) ()
traceInfoCName String
kind Ident
ide = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"found C " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
kind String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\n"
    traceInfoHsType :: String -> String -> CST (CState GBState) ()
traceInfoHsType String
name String
ty = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"associated with Haskell entity `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\nhaving type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ty 
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
expandHook (CHSClass Maybe Ident
oclassIde Ident
classIde Ident
typeIde Position
pos) =
  do
    CST (CState GBState) ()
traceInfoClass
    Ident
classIde Ident -> HsObject -> CST (CState GBState) ()
`objIs` Maybe Ident -> Ident -> HsObject
Class Maybe Ident
oclassIde Ident
typeIde    -- register Haskell object
    [(String, String, HsObject)]
superClasses <- Maybe Ident -> GB [(String, String, HsObject)]
collectClasses Maybe Ident
oclassIde
    Pointer CHSPtrType
ptrType Bool
isNewtype <- Ident -> GB HsObject
queryPointer Ident
typeIde
    Bool -> CST (CState GBState) () -> CST (CState GBState) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CHSPtrType
ptrType CHSPtrType -> CHSPtrType -> Bool
forall a. Eq a => a -> a -> Bool
== CHSPtrType
CHSStablePtr) (CST (CState GBState) () -> CST (CState GBState) ())
-> CST (CState GBState) () -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$
      Position -> CST (CState GBState) ()
forall a. Position -> GB a
illegalStablePtrErr Position
pos
    Position
-> String
-> String
-> CHSPtrType
-> Bool
-> [(String, String, HsObject)]
-> GB String
classDef Position
pos (Ident -> String
identToLexeme Ident
classIde) (Ident -> String
identToLexeme Ident
typeIde) 
             CHSPtrType
ptrType Bool
isNewtype [(String, String, HsObject)]
superClasses
  where
    -- compile a list of all super classes (the direct super class first)
    --
    collectClasses            :: Maybe Ident -> GB [(String, String, HsObject)]
    collectClasses :: Maybe Ident -> GB [(String, String, HsObject)]
collectClasses Maybe Ident
Nothing     = [(String, String, HsObject)] -> GB [(String, String, HsObject)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    collectClasses (Just Ident
ide)  = 
      do
        Class Maybe Ident
oclassIde Ident
typeIde <- Ident -> GB HsObject
queryClass Ident
ide
        HsObject
ptr                     <- Ident -> GB HsObject
queryPointer Ident
typeIde
        [(String, String, HsObject)]
classes                 <- Maybe Ident -> GB [(String, String, HsObject)]
collectClasses Maybe Ident
oclassIde
        [(String, String, HsObject)] -> GB [(String, String, HsObject)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String, HsObject)] -> GB [(String, String, HsObject)])
-> [(String, String, HsObject)] -> GB [(String, String, HsObject)]
forall a b. (a -> b) -> a -> b
$ (Ident -> String
identToLexeme Ident
ide, Ident -> String
identToLexeme Ident
typeIde, HsObject
ptr) (String, String, HsObject)
-> [(String, String, HsObject)] -> [(String, String, HsObject)]
forall a. a -> [a] -> [a]
: [(String, String, HsObject)]
classes
    --
    traceInfoClass :: CST (CState GBState) ()
traceInfoClass = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ String
"** Class hook:\n"

-- produce code for an enumeration
--
--  * an extra instance declaration is required when any of the enumeration
--   constants is explicitly assigned a value in its definition
--
--  * the translation function strips prefixes where possible (different
--   enumerators maye have different prefixes)
--
enumDef :: CEnum -> String -> TransFun -> [String] -> GB String
enumDef :: CEnum -> String -> (Ident -> String) -> [String] -> GB String
enumDef cenum :: CEnum
cenum@(CEnum Maybe Ident
_ [(Ident, Maybe CExpr)]
list Attrs
_) String
hident Ident -> String
trans [String]
userDerive =
  do
    ([(Ident, Maybe CExpr)]
list', Bool
enumAuto) <- [(Ident, Maybe CExpr)]
-> PreCST
     SwitchBoard (CState GBState) ([(Ident, Maybe CExpr)], Bool)
forall a.
[(a, Maybe CExpr)]
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
evalTagVals [(Ident, Maybe CExpr)]
list
    let enumVals :: [(String, Maybe CExpr)]
enumVals = [(Ident -> String
trans Ident
ide, Maybe CExpr
cexpr) | (Ident
ide, Maybe CExpr
cexpr) <-  [(Ident, Maybe CExpr)]
list']  -- translate
        defHead :: String
defHead  = String -> String
enumHead String
hident
        defBody :: String
defBody  = Int -> [(String, Maybe CExpr)] -> String
enumBody (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
defHead Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) [(String, Maybe CExpr)]
enumVals
        inst :: String
inst     = [String] -> String
makeDerives 
                   (if Bool
enumAuto then String
"Enum" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
userDerive else [String]
userDerive) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   if Bool
enumAuto then String
"\n" else String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [(String, Maybe CExpr)] -> String
enumInst String
hident [(String, Maybe CExpr)]
enumVals
    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
$ String
defHead String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
defBody String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inst
  where
    cpos :: Position
cpos = CEnum -> Position
forall a. Pos a => a -> Position
posOf CEnum
cenum
    --
    evalTagVals :: [(a, Maybe CExpr)]
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
evalTagVals []                     = ([(a, Maybe CExpr)], Bool)
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Bool
True)
    evalTagVals ((a
ide, Maybe CExpr
Nothing ):[(a, Maybe CExpr)]
list) = 
      do
        ([(a, Maybe CExpr)]
list', Bool
derived) <- [(a, Maybe CExpr)]
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
evalTagVals [(a, Maybe CExpr)]
list
        ([(a, Maybe CExpr)], Bool)
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
ide, Maybe CExpr
forall a. Maybe a
Nothing)(a, Maybe CExpr) -> [(a, Maybe CExpr)] -> [(a, Maybe CExpr)]
forall a. a -> [a] -> [a]
:[(a, Maybe CExpr)]
list', Bool
derived)
    evalTagVals ((a
ide, Just CExpr
exp):[(a, Maybe CExpr)]
list) = 
      do
        ([(a, Maybe CExpr)]
list', Bool
derived) <- [(a, Maybe CExpr)]
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
evalTagVals [(a, Maybe CExpr)]
list
        ConstResult
val <- CExpr -> GB ConstResult
evalConstCExpr CExpr
exp
        case ConstResult
val of
          IntResult Integer
val' -> 
            ([(a, Maybe CExpr)], Bool)
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
ide, CExpr -> Maybe CExpr
forall a. a -> Maybe a
Just (CExpr -> Maybe CExpr) -> CExpr -> Maybe CExpr
forall a b. (a -> b) -> a -> b
$ CConst -> Attrs -> CExpr
CConst (Integer -> Attrs -> CConst
CIntConst Integer
val' Attrs
at1) Attrs
at2)(a, Maybe CExpr) -> [(a, Maybe CExpr)] -> [(a, Maybe CExpr)]
forall a. a -> [a] -> [a]
:[(a, Maybe CExpr)]
list', 
                    Bool
False)
          FloatResult Float
_ ->
            Position
-> String
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
forall a. Position -> String -> GB a
illegalConstExprErr (CExpr -> Position
forall a. Pos a => a -> Position
posOf CExpr
exp) String
"a float result"
      where
        at1 :: Attrs
at1 = Position -> Attrs
newAttrsOnlyPos Position
nopos
        at2 :: Attrs
at2 = Position -> Attrs
newAttrsOnlyPos Position
nopos
    makeDerives :: [String] -> String
makeDerives [] = String
""
    makeDerives [String]
dList = String
"deriving (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"," [String]
dList) String -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"

-- Haskell code for the head of an enumeration definition
--
enumHead       :: String -> String
enumHead :: String -> String
enumHead String
ident  = String
"data " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ident String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = "

-- Haskell code for the body of an enumeration definition
--
enumBody                        :: Int -> [(String, Maybe CExpr)] -> String
enumBody :: Int -> [(String, Maybe CExpr)] -> String
enumBody Int
indent []               = String
""
enumBody Int
indent ((String
ide, Maybe CExpr
_):[(String, Maybe CExpr)]
list)  =
  String
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
indent Char
' ' 
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if [(String, Maybe CExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Maybe CExpr)]
list then String
"" else String
"| " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> [(String, Maybe CExpr)] -> String
enumBody Int
indent [(String, Maybe CExpr)]
list)

-- Haskell code for an instance declaration for `Enum'
--
--  * the expression of all explicitly specified tag values already have to be
--   in normal form, ie, to be an int constant
--
--  * enumerations start at 0 and whenever an explicit value is specified,
--   following tags are assigned values continuing from the explicitly
--   specified one
--
enumInst :: String -> [(String, Maybe CExpr)] -> String
enumInst :: String -> [(String, Maybe CExpr)] -> String
enumInst String
ident [(String, Maybe CExpr)]
list =
  String
"instance Enum " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ident String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, Integer)] -> String
forall a. (Ord a, Num a, Show a) => [(String, a)] -> String
fromDef [(String, Integer)]
flatList String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, Integer)] -> String
forall a. (Ord a, Num a, Show a) => [(String, a)] -> String
toDef [(String, Integer)]
flatList String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
succDef [String]
names String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
predDef [String]
names String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
enumFromToDef [String]
names
  where
    names :: [String]
names = ((String, Maybe CExpr) -> String)
-> [(String, Maybe CExpr)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe CExpr) -> String
forall a b. (a, b) -> a
fst [(String, Maybe CExpr)]
list
    flatList :: [(String, Integer)]
flatList = [(String, Maybe CExpr)] -> Integer -> [(String, Integer)]
forall a. [(a, Maybe CExpr)] -> Integer -> [(a, Integer)]
flatten [(String, Maybe CExpr)]
list Integer
0

    flatten :: [(a, Maybe CExpr)] -> Integer -> [(a, Integer)]
flatten []                Integer
n = []
    flatten ((a
ide, Maybe CExpr
exp):[(a, Maybe CExpr)]
list) Integer
n = (a
ide, Integer
val) (a, Integer) -> [(a, Integer)] -> [(a, Integer)]
forall a. a -> [a] -> [a]
: [(a, Maybe CExpr)] -> Integer -> [(a, Integer)]
flatten [(a, Maybe CExpr)]
list (Integer
val Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
      where
        val :: Integer
val = case Maybe CExpr
exp of
              Maybe CExpr
Nothing                         -> Integer
n
              Just (CConst (CIntConst m _) _) -> Integer
m
              Just _ -> String -> Integer
forall a. String -> a
interr String
"GenBind.enumInst: Integer constant expected!"

    show' :: a -> String
show' a
x = if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" else a -> String
forall a. Show a => a -> String
show a
x
    fromDef :: [(String, a)] -> String
fromDef [(String, a)]
list = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"  fromEnum " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. (Ord a, Num a, Show a) => a -> String
show' a
val String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      | (String
ide, a
val) <- [(String, a)]
list
      ]
    toDef :: [(String, a)] -> String
toDef [(String, a)]
list = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"  toEnum " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. (Ord a, Num a, Show a) => a -> String
show' a
val String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      | (String
ide, a
val) <- ((String, a) -> (String, a) -> Bool)
-> [(String, a)] -> [(String, a)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(String, a)
x (String, a)
y -> (String, a) -> a
forall a b. (a, b) -> b
snd (String, a)
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (String, a) -> a
forall a b. (a, b) -> b
snd (String, a)
y) [(String, a)]
list
      ]
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  toEnum unmatched = error (\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ident
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".toEnum: Cannot match \" ++ show unmatched)\n"

    succDef :: [String] -> String
succDef [] = String
"  succ _ = undefined\n"
    succDef [String
x] = String
"  succ _ = undefined\n"
    succDef (String
x:String
x':[String]
xs) =
      String
"  succ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
succDef (String
x'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)
    predDef :: [String] -> String
predDef [] = String
"  pred _ = undefined\n"
    predDef [String
x] = String
"  pred _ = undefined\n"
    predDef (String
x:String
x':[String]
xs) =
      String
"  pred " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
predDef (String
x'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs)
    enumFromToDef :: [String] -> String
enumFromToDef [] = String
""
    enumFromToDef [String]
names =
         String
"  enumFromTo x y | fromEnum x == fromEnum y = [ y ]\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"                 | otherwise = x : enumFromTo (succ x) y\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  enumFrom x = enumFromTo x " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. [a] -> a
last [String]
names String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  enumFromThen _ _ = "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    error \"Enum "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
identString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": enumFromThen not implemented\"\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  enumFromThenTo _ _ _ = "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    error \"Enum "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
identString -> String -> String
forall a. [a] -> [a] -> [a]
++String
": enumFromThenTo not implemented\"\n"


-- generate a foreign import declaration that is put into the delayed code
--
--  * the C declaration is a simplified declaration of the function that we
--   want to import into Haskell land
--
callImport :: CHSHook -> Bool -> Bool -> Maybe String -> String -> String
           -> CDecl -> Position -> GB String
callImport :: CHSHook
-> Bool
-> Bool
-> Maybe String
-> String
-> String
-> CDecl
-> Position
-> GB String
callImport CHSHook
hook Bool
isPure Bool
isUns Maybe String
mLock String
ideLexeme String
hsLexeme CDecl
cdecl Position
pos =
  do
    -- compute the external type from the declaration, and delay the foreign
    -- export declaration
    --
    ([Maybe HsPtrRep]
mHsPtrRep, ExtType
extType) <- Position -> CDecl -> Bool -> GB ([Maybe HsPtrRep], ExtType)
extractFunType Position
pos CDecl
cdecl Bool
isPure
    String
header  <- (SwitchBoard -> String) -> GB String
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
headerSB
    CHSHook -> String -> CST (CState GBState) ()
delayCode CHSHook
hook (String -> String -> String -> Bool -> ExtType -> String
foreignImport String
header String
ideLexeme String
hsLexeme Bool
isUns ExtType
extType)
    ExtType -> CST (CState GBState) ()
traceFunType ExtType
extType
    -- if the type any special pointer aliases, generate a lambda expression
    -- which strips off the constructors
    if (Maybe HsPtrRep -> Bool) -> [Maybe HsPtrRep] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe HsPtrRep -> Bool
forall a. Maybe a -> Bool
isJust [Maybe HsPtrRep]
mHsPtrRep
       then [Maybe HsPtrRep] -> GB String
createLambdaExpr [Maybe HsPtrRep]
mHsPtrRep
       else String -> GB String
forall (m :: * -> *) a. Monad m => a -> m a
return String
funStr
  where
    createLambdaExpr :: [Maybe HsPtrRep] -> GB String
    createLambdaExpr :: [Maybe HsPtrRep] -> GB String
createLambdaExpr [Maybe HsPtrRep]
foreignVec = 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
$
      String
"(\\" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      [String] -> String
unwords ((Maybe HsPtrRep -> Integer -> String)
-> [Maybe HsPtrRep] -> [Integer] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe HsPtrRep -> Integer -> String
forall a a b d.
Show a =>
Maybe (a, b, Maybe String, d) -> a -> String
wrPattern [Maybe HsPtrRep]
foreignVec [Integer
1..])String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> "String -> String -> String
forall a. [a] -> [a] -> [a]
++
      [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Maybe HsPtrRep -> Integer -> String)
-> [Maybe HsPtrRep] -> [Integer] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe HsPtrRep -> Integer -> String
forall a a c d.
Show a =>
Maybe (a, CHSPtrType, c, d) -> a -> String
wrForPtr [Maybe HsPtrRep]
foreignVec [Integer
1..])String -> String -> String
forall a. [a] -> [a] -> [a]
++String
funStrString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" "String -> String -> String
forall a. [a] -> [a] -> [a]
++
      [String] -> String
unwords ((Maybe HsPtrRep -> Integer -> String)
-> [Maybe HsPtrRep] -> [Integer] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe HsPtrRep -> Integer -> String
forall a a c d.
Show a =>
Maybe (a, CHSPtrType, c, d) -> a -> String
wrArg [Maybe HsPtrRep]
foreignVec [Integer
1..])String -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"
    wrPattern :: Maybe (a, b, Maybe String, d) -> a -> String
wrPattern (Just (a
_,b
_,Just String
con,d
_)) a
n = String
"("String -> String -> String
forall a. [a] -> [a] -> [a]
++String
conString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" arg"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"
    wrPattern Maybe (a, b, Maybe String, d)
_                    a
n = String
"arg"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
n
    wrForPtr :: Maybe (a, CHSPtrType, c, d) -> a -> String
wrForPtr (Just (a
_,CHSPtrType
CHSForeignPtr,c
_,d
_)) a
n 
        = String
"withForeignPtr arg"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" $ \\argPtr"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" ->"
    wrForPtr Maybe (a, CHSPtrType, c, d)
_                          a
n = String
""
    wrArg :: Maybe (a, CHSPtrType, c, d) -> a -> String
wrArg (Just (a
_,CHSPtrType
CHSForeignPtr,c
_,d
_)) a
n = String
"argPtr"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
n
    wrArg (Just (a
_,CHSPtrType
CHSStablePtr,c
_,d
_)) a
n = 
        String
"(castStablePtrToPtr arg"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
nString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")"
    wrArg Maybe (a, CHSPtrType, c, d)
_ a
n = String
"arg"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
n

    funStr :: String
funStr = case Maybe String
mLock of Maybe String
Nothing -> String
hsLexeme
                           Just String
lockFun -> String
lockFun String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" $ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsLexeme
    traceFunType :: ExtType -> CST (CState GBState) ()
traceFunType ExtType
et = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"Imported function type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
et String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

-- Haskell code for the foreign import declaration needed by a call hook
--
-- On Windows, the paths for headers in "entity" may include backslashes, like
-- dist\build\System\Types\GIO.h
-- It seems GHC expects these to be escaped. Below, we make an educated guess
-- that it in fact expects a Haskell string, and use the "show" function to do
-- the escaping of this (and any other cases) for us.
foreignImport :: String -> String -> String -> Bool -> ExtType -> String
foreignImport :: String -> String -> String -> Bool -> ExtType -> String
foreignImport String
header String
ident String
hsIdent Bool
isUnsafe ExtType
ty  =
  String
"foreign import ccall " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
safety String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
entity String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsIdent String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  where
    safety :: String
safety = if Bool
isUnsafe then String
"unsafe" else String
"safe"
    entity :: String
entity | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
header = String
ident
           | Bool
otherwise   = String
header String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ident

-- produce a Haskell function definition for a fun hook
--
funDef :: Bool               -- pure function?
       -> String             -- name of the new Haskell function
       -> String             -- Haskell name of the foreign imported C function
       -> CDecl              -- simplified declaration of the C function
       -> Maybe String       -- type context of the new Haskell function
       -> Maybe String       -- lock function
       -> [CHSParm]          -- parameter marshalling description
       -> CHSParm            -- result marshalling description 
       -> Position           -- source location of the hook
       -> GB String          -- Haskell code in text form
funDef :: Bool
-> String
-> String
-> CDecl
-> Maybe String
-> Maybe String
-> [CHSParm]
-> CHSParm
-> Position
-> GB String
funDef Bool
isPure String
hsLexeme String
fiLexeme CDecl
cdecl Maybe String
octxt Maybe String
mLock [CHSParm]
parms CHSParm
parm Position
pos =
  do
    ([CHSParm]
parms', CHSParm
parm', Bool
isImpure) <- Position
-> [CHSParm] -> CHSParm -> CDecl -> GB ([CHSParm], CHSParm, Bool)
addDftMarshaller Position
pos [CHSParm]
parms CHSParm
parm CDecl
cdecl
    [CHSParm] -> CHSParm -> Bool -> CST (CState GBState) ()
traceMarsh [CHSParm]
parms' CHSParm
parm' Bool
isImpure
    let 
      sig :: String
sig       = String
hsLexeme String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [CHSParm] -> CHSParm -> String
funTy [CHSParm]
parms' CHSParm
parm' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      marshs :: [(String, String, String, String, String)]
marshs    = [Integer -> CHSParm -> (String, String, String, String, String)
forall a.
Show a =>
a -> CHSParm -> (String, String, String, String, String)
marshArg Integer
i CHSParm
parm | (Integer
i, CHSParm
parm) <- [Integer] -> [CHSParm] -> [(Integer, CHSParm)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [CHSParm]
parms']
      funArgs :: [String]
funArgs   = [String
funArg   | (String
funArg, String
_, String
_, String
_, String
_)   <- [(String, String, String, String, String)]
marshs, String
funArg   String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""]
      marshIns :: [String]
marshIns  = [String
marshIn  | (String
_, String
marshIn, String
_, String
_, String
_)  <- [(String, String, String, String, String)]
marshs]
      callArgs :: [String]
callArgs  = [String
callArg  | (String
_, String
_, String
callArg, String
_, String
_)  <- [(String, String, String, String, String)]
marshs]
      marshOuts :: [String]
marshOuts = [String
marshOut | (String
_, String
_, String
_, String
marshOut, String
_) <- [(String, String, String, String, String)]
marshs, String
marshOut String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""]
      retArgs :: [String]
retArgs   = [String
retArg   | (String
_, String
_, String
_, String
_, String
retArg)   <- [(String, String, String, String, String)]
marshs, String
retArg   String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""]
      funHead :: String
funHead   = String
hsLexeme String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
join [String]
funArgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  if Bool
isPure Bool -> Bool -> Bool
&& Bool
isImpure then String
"  unsafePerformIO $\n" else String
""
      lock :: String
lock      = case Maybe String
mLock of Maybe String
Nothing -> String
""
                                Just String
lock -> String
lock String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" $"
      call :: String
call      = if Bool
isPure 
                  then String
"  let {res = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fiLexeme String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
join [String]
callArgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"} in\n"
                  else String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lock String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fiLexeme String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
join [String]
callArgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >>= \\res ->\n"
      marshRes :: String
marshRes  = case CHSParm
parm' of
                    CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
twoCVal (Just (Ident
_    , CHSArg
CHSVoidArg)) Position
_ -> String
""
                    CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
twoCVal (Just (Ident
omIde, CHSArg
CHSIOArg  )) Position
_ -> 
                      String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
omIde String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" res >>= \\res' ->\n"
                    CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
twoCVal (Just (Ident
omIde, CHSArg
CHSValArg )) Position
_ -> 
                      String
"  let {res' = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
omIde String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" res} in\n"
                    CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
_       Maybe (Ident, CHSArg)
Nothing                    Position
_ ->
                      String -> String
forall a. String -> a
interr String
"GenBind.funDef: marshRes: no default?"
      retArgs' :: [String]
retArgs'  = case CHSParm
parm' of
                    CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
_ (Just (Ident
_, CHSArg
CHSVoidArg)) Position
_ ->        [String]
retArgs
                    CHSParm
_                                      -> String
"res'"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
retArgs
      ret :: String
ret       = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " [String]
retArgs') String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      funBody :: String
funBody   = [String] -> String
joinLines [String]
marshIns  String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                  String
call                String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  [String] -> String
joinLines [String]
marshOuts String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                  String
marshRes            String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                  String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                  (if Bool
isImpure Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
isPure then String
"return " else String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ret
    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
$ String
sig String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funHead String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funBody
  where
    join :: [String] -> String
join      = (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:)
    joinLines :: [String] -> String
joinLines = (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
s -> String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
    --
    -- construct the function type
    --
    --  * specified types appear in the argument and result only if their "in"
    --   and "out" marshaller, respectively, is not the `void' marshaller
    --
    funTy :: [CHSParm] -> CHSParm -> String
funTy [CHSParm]
parms CHSParm
parm =
      let
        ctxt :: String
ctxt   = case Maybe String
octxt of
                   Maybe String
Nothing      -> String
""
                   Just String
ctxtStr -> String
ctxtStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" => "
        argTys :: [String]
argTys = [String
ty | CHSParm Maybe (Ident, CHSArg)
im String
ty Bool
_ Maybe (Ident, CHSArg)
_  Position
_ <- [CHSParm]
parms     , Maybe (Ident, CHSArg) -> Bool
forall a. Maybe (a, CHSArg) -> Bool
notVoid Maybe (Ident, CHSArg)
im]
        resTys :: [String]
resTys = [String
ty | CHSParm Maybe (Ident, CHSArg)
_  String
ty Bool
_ Maybe (Ident, CHSArg)
om Position
_ <- CHSParm
parmCHSParm -> [CHSParm] -> [CHSParm]
forall a. a -> [a] -> [a]
:[CHSParm]
parms, Maybe (Ident, CHSArg) -> Bool
forall a. Maybe (a, CHSArg) -> Bool
notVoid Maybe (Ident, CHSArg)
om]
        resTup :: String
resTup = let
                   (String
lp, String
rp) = if Bool
isPure Bool -> Bool -> Bool
&& [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
resTys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 
                              then (String
"", String
"") 
                              else (String
"(", String
")") 
                   io :: String
io       = if Bool
isPure then String
"" else String
"IO "
                 in
                 String
io String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lp String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " [String]
resTys) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rp
                 
      in
      String
ctxt String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
" -> " ([String]
argTys [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
resTup]))
      where
        notVoid :: Maybe (a, CHSArg) -> Bool
notVoid Maybe (a, CHSArg)
Nothing          = String -> Bool
forall a. String -> a
interr String
"GenBind.funDef: \
                                          \No default marshaller?"
        notVoid (Just (a
_, CHSArg
kind)) = CHSArg
kind CHSArg -> CHSArg -> Bool
forall a. Eq a => a -> a -> Bool
/= CHSArg
CHSVoidArg
    --
    -- for an argument marshaller, generate all "in" and "out" marshalling
    -- code fragments
    --
    marshArg :: a -> CHSParm -> (String, String, String, String, String)
marshArg a
i (CHSParm (Just (Ident
imIde, CHSArg
imArgKind)) String
_ Bool
twoCVal 
                        (Just (Ident
omIde, CHSArg
omArgKind)) Position
_        ) =
      let
        a :: String
a        = String
"a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i
        imStr :: String
imStr    = Ident -> String
identToLexeme Ident
imIde
        imApp :: String
imApp    = String
imStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a
        funArg :: String
funArg   = if CHSArg
imArgKind CHSArg -> CHSArg -> Bool
forall a. Eq a => a -> a -> Bool
== CHSArg
CHSVoidArg then String
"" else String
a
        inBndr :: String
inBndr   = if Bool
twoCVal 
                     then String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'1, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'2)"
                     else String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
        marshIn :: String
marshIn  = case CHSArg
imArgKind of
                     CHSArg
CHSVoidArg -> String
imStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" $ \\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inBndr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> "
                     CHSArg
CHSIOArg   -> String
imApp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" $ \\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inBndr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> "
                     CHSArg
CHSValArg  -> String
"let {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inBndr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                                   String
imApp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"} in "
        callArg :: String
callArg  = if Bool
twoCVal 
                     then String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'1 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'2"
                     else String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
        omApp :: String
omApp    = Ident -> String
identToLexeme Ident
omIde String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
callArg
        outBndr :: String
outBndr  = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"''"
        marshOut :: String
marshOut = case CHSArg
omArgKind of
                     CHSArg
CHSVoidArg -> String
""
                     CHSArg
CHSIOArg   -> String
omApp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">>= \\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
outBndr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> "
                     CHSArg
CHSValArg  -> String
"let {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
outBndr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                                   String
omApp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"} in "
        retArg :: String
retArg   = if CHSArg
omArgKind CHSArg -> CHSArg -> Bool
forall a. Eq a => a -> a -> Bool
== CHSArg
CHSVoidArg then String
"" else String
outBndr
      in
      (String
funArg, String
marshIn, String
callArg, String
marshOut, String
retArg)
    marshArg a
_ CHSParm
_ = String -> (String, String, String, String, String)
forall a. String -> a
interr String
"GenBind.funDef: Missing default?"
    --
    traceMarsh :: [CHSParm] -> CHSParm -> Bool -> CST (CState GBState) ()
traceMarsh [CHSParm]
parms CHSParm
parm Bool
isImpure = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"Marshalling specification including defaults: \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      [CHSParm] -> String -> String
showParms ([CHSParm]
parms [CHSParm] -> [CHSParm] -> [CHSParm]
forall a. [a] -> [a] -> [a]
++ [CHSParm
parm]) String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
"  The marshalling is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
isImpure then String
"impure.\n" else String
"pure.\n"
      where
        showParms :: [CHSParm] -> String -> String
showParms []           = String -> String
forall a. a -> a
id
        showParms (CHSParm
parm:[CHSParm]
parms) =   String -> String -> String
showString String
"  "
                                 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSParm -> String -> String
showCHSParm CHSParm
parm 
                                 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
'\n' 
                                 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CHSParm] -> String -> String
showParms [CHSParm]
parms

-- add default marshallers for "in" and "out" marshalling
--
addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> CDecl 
                 -> GB ([CHSParm], CHSParm, Bool)
addDftMarshaller :: Position
-> [CHSParm] -> CHSParm -> CDecl -> GB ([CHSParm], CHSParm, Bool)
addDftMarshaller Position
pos [CHSParm]
parms CHSParm
parm CDecl
cdecl = do
  ([Maybe HsPtrRep]
_, ExtType
fType) <- Position -> CDecl -> Bool -> GB ([Maybe HsPtrRep], ExtType)
extractFunType Position
pos CDecl
cdecl Bool
True
  let (ExtType
resTy, [ExtType]
argTys) = ExtType -> (ExtType, [ExtType])
splitFunTy ExtType
fType
  (CHSParm
parm' , Bool
isImpure1) <- CHSParm -> ExtType -> GB (CHSParm, Bool)
checkResMarsh CHSParm
parm ExtType
resTy
  ([CHSParm]
parms', Bool
isImpure2) <- [CHSParm]
-> [ExtType]
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
addDft [CHSParm]
parms [ExtType]
argTys
  ([CHSParm], CHSParm, Bool) -> GB ([CHSParm], CHSParm, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSParm]
parms', CHSParm
parm', Bool
isImpure1 Bool -> Bool -> Bool
|| Bool
isImpure2)
  where
    -- the result marshalling may not use an "in" marshaller and can only have
    -- one C value
    --
    --  * a default marshaller maybe used for "out" marshalling
    --
    checkResMarsh :: CHSParm -> ExtType -> GB (CHSParm, Bool)
checkResMarsh (CHSParm (Just (Ident, CHSArg)
_) String
_  Bool
_    Maybe (Ident, CHSArg)
_       Position
pos) ExtType
_   = 
      Position -> GB (CHSParm, Bool)
forall a. Position -> GB a
resMarshIllegalInErr      Position
pos
    checkResMarsh (CHSParm Maybe (Ident, CHSArg)
_        String
_  Bool
True Maybe (Ident, CHSArg)
_       Position
pos) ExtType
_   = 
      Position -> GB (CHSParm, Bool)
forall a. Position -> GB a
resMarshIllegalTwoCValErr Position
pos
    checkResMarsh (CHSParm Maybe (Ident, CHSArg)
_        String
ty Bool
_    Maybe (Ident, CHSArg)
omMarsh Position
pos) ExtType
cTy = do
      (Maybe (Ident, CHSArg)
imMarsh', Bool
_       ) <- Maybe (Ident, CHSArg)
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
forall (m :: * -> *).
Monad m =>
Maybe (Ident, CHSArg) -> m (Maybe (Ident, CHSArg), Bool)
addDftVoid Maybe (Ident, CHSArg)
forall a. Maybe a
Nothing
      (Maybe (Ident, CHSArg)
omMarsh', Bool
isImpure) <- Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftOut Position
pos Maybe (Ident, CHSArg)
omMarsh String
ty [ExtType
cTy]
      (CHSParm, Bool) -> GB (CHSParm, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
-> String -> Bool -> Maybe (Ident, CHSArg) -> Position -> CHSParm
CHSParm Maybe (Ident, CHSArg)
imMarsh' String
ty Bool
False Maybe (Ident, CHSArg)
omMarsh' Position
pos, Bool
isImpure)
    --
    splitFunTy :: ExtType -> (ExtType, [ExtType])
splitFunTy (FunET ExtType
UnitET ExtType
ty ) = ExtType -> (ExtType, [ExtType])
splitFunTy ExtType
ty
    splitFunTy (FunET ExtType
ty1    ExtType
ty2) = let 
                                      (ExtType
resTy, [ExtType]
argTys) = ExtType -> (ExtType, [ExtType])
splitFunTy ExtType
ty2
                                    in
                                    (ExtType
resTy, ExtType
ty1ExtType -> [ExtType] -> [ExtType]
forall a. a -> [a] -> [a]
:[ExtType]
argTys)
    splitFunTy ExtType
resTy              = (ExtType
resTy, [])
    --
    -- match Haskell with C arguments (and results)
    --
    addDft :: [CHSParm]
-> [ExtType]
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
addDft ((CHSParm Maybe (Ident, CHSArg)
imMarsh String
hsTy Bool
False Maybe (Ident, CHSArg)
omMarsh Position
p):[CHSParm]
parms) (ExtType
cTy      :[ExtType]
cTys) = do
      (Maybe (Ident, CHSArg)
imMarsh', Bool
isImpureIn ) <- Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftIn   Position
p Maybe (Ident, CHSArg)
imMarsh String
hsTy [ExtType
cTy]
      (Maybe (Ident, CHSArg)
omMarsh', Bool
isImpureOut) <- Maybe (Ident, CHSArg)
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
forall (m :: * -> *).
Monad m =>
Maybe (Ident, CHSArg) -> m (Maybe (Ident, CHSArg), Bool)
addDftVoid    Maybe (Ident, CHSArg)
omMarsh
      ([CHSParm]
parms'  , Bool
isImpure   ) <- [CHSParm]
-> [ExtType]
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
addDft [CHSParm]
parms [ExtType]
cTys
      ([CHSParm], Bool)
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
-> String -> Bool -> Maybe (Ident, CHSArg) -> Position -> CHSParm
CHSParm Maybe (Ident, CHSArg)
imMarsh' String
hsTy Bool
False Maybe (Ident, CHSArg)
omMarsh' Position
p CHSParm -> [CHSParm] -> [CHSParm]
forall a. a -> [a] -> [a]
: [CHSParm]
parms',
              Bool
isImpure Bool -> Bool -> Bool
|| Bool
isImpureIn Bool -> Bool -> Bool
|| Bool
isImpureOut)
    addDft ((CHSParm Maybe (Ident, CHSArg)
imMarsh String
hsTy Bool
True  Maybe (Ident, CHSArg)
omMarsh Position
p):[CHSParm]
parms) (ExtType
cTy1:ExtType
cTy2:[ExtType]
cTys) = do
      (Maybe (Ident, CHSArg)
imMarsh', Bool
isImpureIn ) <- Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftIn   Position
p Maybe (Ident, CHSArg)
imMarsh String
hsTy [ExtType
cTy1, ExtType
cTy2]
      (Maybe (Ident, CHSArg)
omMarsh', Bool
isImpureOut) <- Maybe (Ident, CHSArg)
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
forall (m :: * -> *).
Monad m =>
Maybe (Ident, CHSArg) -> m (Maybe (Ident, CHSArg), Bool)
addDftVoid   Maybe (Ident, CHSArg)
omMarsh
      ([CHSParm]
parms'  , Bool
isImpure   ) <- [CHSParm]
-> [ExtType]
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
addDft [CHSParm]
parms [ExtType]
cTys
      ([CHSParm], Bool)
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
-> String -> Bool -> Maybe (Ident, CHSArg) -> Position -> CHSParm
CHSParm Maybe (Ident, CHSArg)
imMarsh' String
hsTy Bool
True Maybe (Ident, CHSArg)
omMarsh' Position
p CHSParm -> [CHSParm] -> [CHSParm]
forall a. a -> [a] -> [a]
: [CHSParm]
parms',
              Bool
isImpure Bool -> Bool -> Bool
|| Bool
isImpureIn Bool -> Bool -> Bool
|| Bool
isImpureOut)
    addDft []                                             []               = 
      ([CHSParm], Bool)
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Bool
False)
    addDft ((CHSParm Maybe (Ident, CHSArg)
_       String
_    Bool
_     Maybe (Ident, CHSArg)
_     Position
pos):[CHSParm]
parms) []               = 
      Position
-> String -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
forall a. Position -> String -> GB a
marshArgMismatchErr Position
pos String
"This parameter is in excess of the C arguments."
    addDft []                                             (ExtType
_:[ExtType]
_)            = 
      Position
-> String -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
forall a. Position -> String -> GB a
marshArgMismatchErr Position
pos String
"Parameter marshallers are missing."
    --
    addDftIn :: Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftIn Position
_   imMarsh :: Maybe (Ident, CHSArg)
imMarsh@(Just (Ident
_, CHSArg
kind)) String
_    [ExtType]
_    = (Maybe (Ident, CHSArg), Bool)
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
imMarsh,
                                                              CHSArg
kind CHSArg -> CHSArg -> Bool
forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg)
    addDftIn Position
pos imMarsh :: Maybe (Ident, CHSArg)
imMarsh@Maybe (Ident, CHSArg)
Nothing          String
hsTy [ExtType]
cTys = do
      Maybe (Ident, CHSArg)
marsh <- String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshIn String
hsTy [ExtType]
cTys
      Bool -> CST (CState GBState) () -> CST (CState GBState) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Ident, CHSArg) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Ident, CHSArg)
marsh) (CST (CState GBState) () -> CST (CState GBState) ())
-> CST (CState GBState) () -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$
        Position
-> String -> String -> [ExtType] -> CST (CState GBState) ()
forall a. Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr Position
pos String
"\"in\"" String
hsTy [ExtType]
cTys
      (Maybe (Ident, CHSArg), Bool)
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
marsh, case Maybe (Ident, CHSArg)
marsh of {Just (Ident
_, CHSArg
kind) -> CHSArg
kind CHSArg -> CHSArg -> Bool
forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg})
    --
    addDftOut :: Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftOut Position
_   omMarsh :: Maybe (Ident, CHSArg)
omMarsh@(Just (Ident
_, CHSArg
kind)) String
_    [ExtType]
_    = (Maybe (Ident, CHSArg), Bool)
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
omMarsh,
                                                              CHSArg
kind CHSArg -> CHSArg -> Bool
forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg)
    addDftOut Position
pos omMarsh :: Maybe (Ident, CHSArg)
omMarsh@Maybe (Ident, CHSArg)
Nothing          String
hsTy [ExtType]
cTys = do
      Maybe (Ident, CHSArg)
marsh <- String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshOut String
hsTy [ExtType]
cTys
      Bool -> CST (CState GBState) () -> CST (CState GBState) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Ident, CHSArg) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Ident, CHSArg)
marsh) (CST (CState GBState) () -> CST (CState GBState) ())
-> CST (CState GBState) () -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$
        Position
-> String -> String -> [ExtType] -> CST (CState GBState) ()
forall a. Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr Position
pos String
"\"out\"" String
hsTy [ExtType]
cTys
      (Maybe (Ident, CHSArg), Bool)
-> PreCST
     SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
marsh, case Maybe (Ident, CHSArg)
marsh of {Just (Ident
_, CHSArg
kind) -> CHSArg
kind CHSArg -> CHSArg -> Bool
forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg})
    --
    -- add void marshaller if no explict one is given
    --
    addDftVoid :: Maybe (Ident, CHSArg) -> m (Maybe (Ident, CHSArg), Bool)
addDftVoid marsh :: Maybe (Ident, CHSArg)
marsh@(Just (Ident
_, CHSArg
kind)) = (Maybe (Ident, CHSArg), Bool) -> m (Maybe (Ident, CHSArg), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
marsh, CHSArg
kind CHSArg -> CHSArg -> Bool
forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg)
    addDftVoid        Maybe (Ident, CHSArg)
Nothing         = do
      (Maybe (Ident, CHSArg), Bool) -> m (Maybe (Ident, CHSArg), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ident, CHSArg) -> Maybe (Ident, CHSArg)
forall a. a -> Maybe a
Just (String -> Ident
noPosIdent String
"void", CHSArg
CHSVoidArg), Bool
False)

-- compute from an access path, the declarator finally accessed and the index
-- path required for the access
--
--  * each element in the index path specifies dereferencing an address and the 
--   offset to be added to the address before dereferencing
--
--  * the returned declaration is already normalised (ie, alias have been
--   expanded) 
--
--  * it may appear as if `t.m' and `t->m' should have different access paths,
--   as the latter specifies one more dereferencing; this is certainly true in
--   C, but it doesn't apply here, as `t.m' is merely provided for the
--   convenience of the interface writer - it is strictly speaking an
--   impossible access paths, as in Haskell we always have a pointer to a
--   structure, we can never have the structure as a value itself
--
accessPath :: CHSAPath -> GB (CDecl, [BitSize])
accessPath :: CHSAPath -> GB (CDecl, [BitSize])
accessPath (CHSRoot Ident
ide) =                              -- t
  do
    CDecl
decl <- Ident -> Bool -> Bool -> CT GBState CDecl
forall s. Ident -> Bool -> Bool -> CT s CDecl
findAndChaseDecl Ident
ide Bool
False Bool
True
    (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ide Ident -> CDecl -> CDecl
`simplifyDecl` CDecl
decl, [Int -> Int -> BitSize
BitSize Int
0 Int
0])
accessPath (CHSDeref (CHSRoot Ident
ide) Position
_) =                 --  *t
  do
    CDecl
decl <- Ident -> Bool -> Bool -> CT GBState CDecl
forall s. Ident -> Bool -> Bool -> CT s CDecl
findAndChaseDecl Ident
ide Bool
True Bool
True
    (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ide Ident -> CDecl -> CDecl
`simplifyDecl` CDecl
decl, [Int -> Int -> BitSize
BitSize Int
0 Int
0])
accessPath (CHSRef root :: CHSAPath
root@(CHSRoot Ident
ide1) Ident
ide2) =          -- t.m
  do
    CStructUnion
su <- Ident -> Bool -> Bool -> CT GBState CStructUnion
forall s. Ident -> Bool -> Bool -> CT s CStructUnion
lookupStructUnion Ident
ide1 Bool
False Bool
True
    (BitSize
offset, CDecl
decl') <- CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct CStructUnion
su Ident
ide2
    CDecl
adecl <- CDecl -> CT GBState CDecl
replaceByAlias CDecl
decl'
    (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
adecl, [BitSize
offset])
accessPath (CHSRef (CHSDeref (CHSRoot Ident
ide1) Position
_) Ident
ide2) =  -- t->m
  do
    CStructUnion
su <- Ident -> Bool -> Bool -> CT GBState CStructUnion
forall s. Ident -> Bool -> Bool -> CT s CStructUnion
lookupStructUnion Ident
ide1 Bool
True Bool
True
    (BitSize
offset, CDecl
decl') <- CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct CStructUnion
su Ident
ide2
    CDecl
adecl <- CDecl -> CT GBState CDecl
replaceByAlias CDecl
decl'
    (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
adecl, [BitSize
offset])
accessPath (CHSRef CHSAPath
path Ident
ide) =                          -- a.m
  do
    (CDecl
decl, BitSize
offset:[BitSize]
offsets) <- CHSAPath -> GB (CDecl, [BitSize])
accessPath CHSAPath
path
    Ident -> CDecl -> CST (CState GBState) ()
assertPrimDeclr Ident
ide CDecl
decl
    CStructUnion
su <- Position -> CDecl -> CT GBState CStructUnion
forall s. Position -> CDecl -> CT s CStructUnion
structFromDecl (Ident -> Position
forall a. Pos a => a -> Position
posOf Ident
ide) CDecl
decl
    (BitSize
addOffset, CDecl
decl') <- CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct CStructUnion
su Ident
ide
    CDecl
adecl <- CDecl -> CT GBState CDecl
replaceByAlias CDecl
decl'
    (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
adecl, BitSize
offset BitSize -> BitSize -> BitSize
`addBitSize` BitSize
addOffset BitSize -> [BitSize] -> [BitSize]
forall a. a -> [a] -> [a]
: [BitSize]
offsets)
  where
    assertPrimDeclr :: Ident -> CDecl -> CST (CState GBState) ()
assertPrimDeclr Ident
ide (CDecl [CDeclSpec]
_ [(Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr] Attrs
_) =
      case (Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr of
        (Just (CVarDeclr Maybe Ident
_ Attrs
_), Maybe CInit
_, Maybe CExpr
_) -> CST (CState GBState) ()
forall e s. PreCST e s ()
nop
        (Maybe CDeclr, Maybe CInit, Maybe CExpr)
_                            -> Ident -> CST (CState GBState) ()
forall a. Ident -> GB a
structExpectedErr Ident
ide
accessPath (CHSDeref CHSAPath
path Position
pos) =                        --  *a
  do
    (CDecl
decl, [BitSize]
offsets) <- CHSAPath -> GB (CDecl, [BitSize])
accessPath CHSAPath
path
    CDecl
decl' <- CDecl -> CT GBState CDecl
derefOrErr CDecl
decl
    CDecl
adecl <- CDecl -> CT GBState CDecl
replaceByAlias CDecl
decl'
    (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
adecl, Int -> Int -> BitSize
BitSize Int
0 Int
0 BitSize -> [BitSize] -> [BitSize]
forall a. a -> [a] -> [a]
: [BitSize]
offsets)
  where
    derefOrErr :: CDecl -> CT GBState CDecl
derefOrErr (CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr] Attrs
at) =
      case (Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr of
        (Just (CPtrDeclr [CTypeQual
_]       CDeclr
declr Attrs
at), Maybe CInit
oinit, Maybe CExpr
oexpr) -> 
          CDecl -> CT GBState CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl -> CT GBState CDecl) -> CDecl -> CT GBState CDecl
forall a b. (a -> b) -> a -> b
$ [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(CDeclr -> Maybe CDeclr
forall a. a -> Maybe a
Just CDeclr
declr, Maybe CInit
oinit, Maybe CExpr
oexpr)] Attrs
at
        (Just (CPtrDeclr (CTypeQual
_:[CTypeQual]
quals) CDeclr
declr Attrs
at), Maybe CInit
oinit, Maybe CExpr
oexpr) -> 
          CDecl -> CT GBState CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl -> CT GBState CDecl) -> CDecl -> CT GBState CDecl
forall a b. (a -> b) -> a -> b
$ 
            [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(CDeclr -> Maybe CDeclr
forall a. a -> Maybe a
Just ([CTypeQual] -> CDeclr -> Attrs -> CDeclr
CPtrDeclr [CTypeQual]
quals CDeclr
declr Attrs
at), Maybe CInit
oinit, Maybe CExpr
oexpr)] Attrs
at
        (Maybe CDeclr, Maybe CInit, Maybe CExpr)
_                                                   -> 
          Position -> CT GBState CDecl
forall a. Position -> GB a
ptrExpectedErr Position
pos

-- replaces a decleration by its alias if any
--
--  * the alias inherits any field size specification that the original
--   declaration may have
--
--  * declaration must have exactly one declarator
--
replaceByAlias                                :: CDecl -> GB CDecl
replaceByAlias :: CDecl -> CT GBState CDecl
replaceByAlias cdecl :: CDecl
cdecl@(CDecl [CDeclSpec]
_ [(Maybe CDeclr
_, Maybe CInit
_, Maybe CExpr
size)] Attrs
at)  =
  do
    Maybe CDecl
ocdecl <- CDecl -> CT GBState (Maybe CDecl)
forall s. CDecl -> CT s (Maybe CDecl)
checkForAlias CDecl
cdecl
    case Maybe CDecl
ocdecl of
      Maybe CDecl
Nothing                                  -> CDecl -> CT GBState CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return CDecl
cdecl
      Just (CDecl [CDeclSpec]
specs [(Maybe CDeclr
declr, Maybe CInit
init, Maybe CExpr
_)] Attrs
at) ->   -- form of an alias
        CDecl -> CT GBState CDecl
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl -> CT GBState CDecl) -> CDecl -> CT GBState CDecl
forall a b. (a -> b) -> a -> b
$ [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(Maybe CDeclr
declr, Maybe CInit
init, Maybe CExpr
size)] Attrs
at

-- given a structure declaration and member name, compute the offset of the
-- member in the structure and the declaration of the referenced member
--
refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct CStructUnion
su Ident
ide =
  do
    -- get the list of fields and check for our selector
    --
    let ([CDecl]
fields, CStructTag
tag) = CStructUnion -> ([CDecl], CStructTag)
structMembers CStructUnion
su
        ([CDecl]
pre, [CDecl]
post)   = (CDecl -> Bool) -> [CDecl] -> ([CDecl], [CDecl])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (CDecl -> Bool) -> CDecl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CDecl -> Ident -> Bool) -> Ident -> CDecl -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip CDecl -> Ident -> Bool
declNamed Ident
ide) [CDecl]
fields
    Bool -> CST (CState GBState) () -> CST (CState GBState) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([CDecl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CDecl]
post) (CST (CState GBState) () -> CST (CState GBState) ())
-> CST (CState GBState) () -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$
      Position -> Ident -> CST (CState GBState) ()
forall a. Position -> Ident -> GB a
unknownFieldErr (CStructUnion -> Position
forall a. Pos a => a -> Position
posOf CStructUnion
su) Ident
ide
    --
    -- get sizes of preceding fields and the result type (`pre' are all
    -- declarators preceding `ide' and the first declarator in `post' defines 
    -- `ide')
    --
    let decl :: CDecl
decl = [CDecl] -> CDecl
forall a. [a] -> a
head [CDecl]
post
    BitSize
offset <- case CStructTag
tag of
                CStructTag
CStructTag -> [CDecl]
-> CDecl
-> CStructTag
-> PreCST SwitchBoard (CState GBState) BitSize
offsetInStruct [CDecl]
pre CDecl
decl CStructTag
tag
                CStructTag
CUnionTag  -> BitSize -> PreCST SwitchBoard (CState GBState) BitSize
forall (m :: * -> *) a. Monad m => a -> m a
return (BitSize -> PreCST SwitchBoard (CState GBState) BitSize)
-> BitSize -> PreCST SwitchBoard (CState GBState) BitSize
forall a b. (a -> b) -> a -> b
$ Int -> Int -> BitSize
BitSize Int
0 Int
0
    (BitSize, CDecl) -> GB (BitSize, CDecl)
forall (m :: * -> *) a. Monad m => a -> m a
return (BitSize
offset, CDecl
decl)

-- does the given declarator define the given name?
--
declNamed :: CDecl -> Ident -> Bool
(CDecl [CDeclSpec]
_ [(Maybe CDeclr
Nothing   , Maybe CInit
_, Maybe CExpr
_)] Attrs
_) declNamed :: CDecl -> Ident -> Bool
`declNamed` Ident
ide = Bool
False
(CDecl [CDeclSpec]
_ [(Just CDeclr
declr, Maybe CInit
_, Maybe CExpr
_)] Attrs
_) `declNamed` Ident
ide = CDeclr
declr CDeclr -> Ident -> Bool
`declrNamed` Ident
ide
(CDecl [CDeclSpec]
_ []                   Attrs
_) `declNamed` Ident
_   =
  String -> Bool
forall a. String -> a
interr String
"GenBind.declNamed: Abstract declarator in structure!"
CDecl
_                                `declNamed` Ident
_   =
  String -> Bool
forall a. String -> a
interr String
"GenBind.declNamed: More than one declarator!"

-- Haskell code for writing to or reading from a struct
--
setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String
setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String
setGet Position
pos CHSAccess
access [BitSize]
offsets ExtType
ty =
  do
    let pre :: String
pre = case CHSAccess
access of 
                CHSAccess
CHSSet -> String
"(\\ptr val -> do {"
                CHSAccess
CHSGet -> String
"(\\ptr -> do {"
    String
body <- [BitSize] -> GB String
setGetBody ([BitSize] -> [BitSize]
forall a. [a] -> [a]
reverse [BitSize]
offsets)
    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
$ String
pre String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
body String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"})"
  where
    setGetBody :: [BitSize] -> GB String
setGetBody [BitSize Int
offset Int
bitOffset] =
      do
        let ty' :: ExtType
ty' = case ExtType
ty of
                          t :: ExtType
t@(DefinedET CDecl
_ HsPtrRep
_) -> ExtType -> ExtType
PtrET ExtType
t
                          ExtType
t                 -> ExtType
t
        let tyTag :: String
tyTag = ExtType -> String
showExtType ExtType
ty'
        Maybe (Bool, Int)
bf <- ExtType -> GB (Maybe (Bool, Int))
checkType ExtType
ty'
        case Maybe (Bool, Int)
bf of
          Maybe (Bool, Int)
Nothing      -> 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
$ case CHSAccess
access of       -- not a bitfield
                            CHSAccess
CHSGet -> Int -> String -> String
forall a. Show a => a -> String -> String
peekOp Int
offset String
tyTag
                            CHSAccess
CHSSet -> Int -> String -> String -> String
forall a. Show a => a -> String -> String -> String
pokeOp Int
offset String
tyTag String
"val"
--FIXME: must take `bitfieldDirection' into account
          Just (Bool
_, Int
bs) -> 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
$ case CHSAccess
access of       -- a bitfield
                            CHSAccess
CHSGet -> String
"val <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Show a => a -> String -> String
peekOp Int
offset String
tyTag
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
extractBitfield
                            CHSAccess
CHSSet -> String
"org <- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Show a => a -> String -> String
peekOp Int
offset String
tyTag
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
insertBitfield 
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String -> String
forall a. Show a => a -> String -> String -> String
pokeOp Int
offset String
tyTag String
"val'"
            where
              -- we have to be careful here to ensure proper sign extension;
              -- in particular, shifting right followed by anding a mask is
              --  *not* sufficient; instead, we exploit in the following that
              -- `shiftR' performs sign extension
              --
              extractBitfield :: String
extractBitfield = String
"; return $ (val `shiftL` (" 
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bitsPerField String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - " 
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
bs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bitOffset) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")) `shiftR` ("
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bitsPerField String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bs
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
              bitsPerField :: String
bitsPerField    = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ CPrimType -> Int
size CPrimType
CIntPT Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
              --
              insertBitfield :: String
insertBitfield  = String
"; let {val' = (org .&. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
middleMask
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") .|. (val `shiftL` " 
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bitOffset String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")}; "
              middleMask :: String
middleMask      = String
"fromIntegral (((maxBound::CUInt) `shiftL` "
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") `rotateL` " 
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bitOffset String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    setGetBody (BitSize Int
offset Int
0 : [BitSize]
offsets) =
      do
        String
code <- [BitSize] -> GB String
setGetBody [BitSize]
offsets
        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
$ String
"ptr <- peekByteOff ptr " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
offset String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
code
    setGetBody (BitSize Int
_      Int
_ : [BitSize]
_      ) =
      Position -> GB String
forall a. Position -> GB a
derefBitfieldErr Position
pos
    --
    -- check that the type can be marshalled and compute extra operations for
    -- bitfields
    --
    checkType :: ExtType -> GB (Maybe (Bool, Int))
checkType (IOET      ExtType
_    )          = String -> GB (Maybe (Bool, Int))
forall a. String -> a
interr String
"GenBind.setGet: Illegal \
                                                  \type!"
    checkType (ExtType
UnitET         )          = Position -> GB (Maybe (Bool, Int))
forall a. Position -> GB a
voidFieldErr Position
pos
    checkType (PrimET    (CUFieldPT Int
bs)) = Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Bool, Int) -> GB (Maybe (Bool, Int)))
-> Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
forall a b. (a -> b) -> a -> b
$ (Bool, Int) -> Maybe (Bool, Int)
forall a. a -> Maybe a
Just (Bool
False, Int
bs)
    checkType (PrimET    (CSFieldPT Int
bs)) = Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Bool, Int) -> GB (Maybe (Bool, Int)))
-> Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
forall a b. (a -> b) -> a -> b
$ (Bool, Int) -> Maybe (Bool, Int)
forall a. a -> Maybe a
Just (Bool
True , Int
bs)
    checkType ExtType
_                          = Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Bool, Int)
forall a. Maybe a
Nothing
    --
    peekOp :: a -> String -> String
peekOp a
off String
tyTag     = String
"peekByteOff ptr " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
off String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ::IO " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tyTag
    pokeOp :: a -> String -> String -> String
pokeOp a
off String
tyTag String
var = String
"pokeByteOff ptr " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
off String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
var
                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"::" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tyTag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- generate the type definition for a pointer hook and enter the required type
-- mapping into the `ptrmap'
--
pointerDef :: Bool              -- explicit `*' in pointer hook
           -> Ident             -- full C name
           -> String            -- Haskell name
           -> CHSPtrType        -- kind of the pointer
           -> Bool              -- explicit newtype tag
           -> String            -- Haskell type expression of pointer argument
           -> Bool              -- do we have a pointer to a function?
           -> GB String
pointerDef :: Bool
-> Ident
-> String
-> CHSPtrType
-> Bool
-> String
-> Bool
-> GB String
pointerDef Bool
isStar Ident
cNameFull String
hsName CHSPtrType
ptrKind Bool
isNewtype String
hsType Bool
isFun =
  do
    Bool
keepOld <- (SwitchBoard -> Bool) -> PreCST SwitchBoard (CState GBState) Bool
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
oldFFI
    let ptrArg :: String
ptrArg  = if Bool
keepOld 
                  then String
"()"             -- legacy FFI interface
                  else if Bool
isNewtype 
                  then String
hsName           -- abstract type
                  else String
hsType           -- concrete type
        ptrCon :: String
ptrCon  = case CHSPtrType
ptrKind of
                    CHSPtrType
CHSPtr | Bool
isFun -> String
"FunPtr"
                    CHSPtrType
_              -> CHSPtrType -> String
forall a. Show a => a -> String
show CHSPtrType
ptrKind
        ptrType :: String
ptrType = String
ptrCon String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ptrArg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
        thePtr :: (Bool, Ident)
thePtr  = (Bool
isStar, Ident
cNameFull)

    (Bool, Ident)
thePtr (Bool, Ident) -> HsPtrRep -> CST (CState GBState) ()
`ptrMapsTo` (Bool
isFun,
                        CHSPtrType
ptrKind,
                        if Bool
isNewtype then String -> Maybe String
forall a. a -> Maybe a
Just String
hsName else Maybe String
forall a. Maybe a
Nothing,
                        String
ptrArg)
    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
$
      if Bool
isNewtype 
      then String
"newtype " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ptrType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      else String
"type "    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = "                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ptrType

-- generate the class and instance definitions for a class hook
--
--  * the pointer type must not be a stable pointer
--
--  * the first super class (if present) must be the direct superclass
--
--  * all Haskell objects in the superclass list must be pointer objects
--
classDef :: Position                     -- for error messages
         -> String                       -- class name
         -> String                       -- pointer type name
         -> CHSPtrType                   -- type of the pointer
         -> Bool                         -- is a newtype?
         -> [(String, String, HsObject)] -- superclasses
         -> GB String
classDef :: Position
-> String
-> String
-> CHSPtrType
-> Bool
-> [(String, String, HsObject)]
-> GB String
classDef Position
pos String
className String
typeName CHSPtrType
ptrType Bool
isNewtype [(String, String, HsObject)]
superClasses =
  do
    let
      toMethodName :: String
toMethodName    = case String
typeName of
                          String
""   -> String -> String
forall a. String -> a
interr String
"GenBind.classDef: \
                                         \Illegal identifier!"
                          Char
c:String
cs -> Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
      fromMethodName :: String
fromMethodName  = String
"from" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName
      classDefContext :: String
classDefContext = case [(String, String, HsObject)]
superClasses of
                          []                  -> String
"" 
                          (String
superName, String
_, HsObject
_):[(String, String, HsObject)]
_ -> String
superName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p => "
      classDef :: String
classDef        = 
        String
"class " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
classDefContext String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
className String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p where\n" 
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
toMethodName   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: p -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fromMethodName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> p\n"
      instDef :: String
instDef         = 
        String
"instance " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
className String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
toMethodName   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = id\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fromMethodName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = id\n"
    String
instDefs <- [(String, String, HsObject)] -> GB String
castInstDefs [(String, String, HsObject)]
superClasses
    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
$ String
classDef String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
instDefs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
instDef
  where 
    castInstDefs :: [(String, String, HsObject)] -> GB String
castInstDefs [] = String -> GB String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
    castInstDefs ((String
superName, String
ptrName, Pointer CHSPtrType
ptrType' Bool
isNewtype'):[(String, String, HsObject)]
classes) =
      do
        Bool -> CST (CState GBState) () -> CST (CState GBState) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CHSPtrType
ptrType CHSPtrType -> CHSPtrType -> Bool
forall a. Eq a => a -> a -> Bool
== CHSPtrType
ptrType') (CST (CState GBState) () -> CST (CState GBState) ())
-> CST (CState GBState) () -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$
          Position -> String -> String -> CST (CState GBState) ()
forall a. Position -> String -> String -> GB a
pointerTypeMismatchErr Position
pos String
className String
superName
        let toMethodName :: String
toMethodName    = case String
ptrName of
                                String
""   -> String -> String
forall a. String -> a
interr String
"GenBind.classDef: \
                                         \Illegal identifier - 2!"
                                c:cs -> Char -> Char
toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs
            fromMethodName :: String
fromMethodName  = String
"from" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ptrName
            castFun :: String
castFun         = String
"cast" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CHSPtrType -> String
forall a. Show a => a -> String
show CHSPtrType
ptrType
            typeConstr :: String
typeConstr      = if Bool
isNewtype  then String
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " else String
""
            superConstr :: String
superConstr     = if Bool
isNewtype' then String
ptrName  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " else String
""
            instDef :: String
instDef         =
              String
"instance " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
superName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where\n"
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
toMethodName     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeConstr  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"p) = " 
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
superConstr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
castFun String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p)\n"
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fromMethodName   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
superConstr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"p) = " 
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeConstr  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
castFun String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" p)\n"
        String
instDefs <- [(String, String, HsObject)] -> GB String
castInstDefs [(String, String, HsObject)]
classes
        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
$ String
instDef String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
instDefs


-- C code computations
-- -------------------

-- the result of a constant expression
--
data ConstResult = IntResult   Integer
                 | FloatResult Float

-- types that may occur in foreign declarations, ie, Haskell land types
--
--  * we reprsent C functions with no arguments (ie, the ANSI C `void'
--   argument) by `FunET UnitET res' rather than just `res' internally,
--   although the latter representation is finally emitted into the binding
--   file; this is because we need to know which types are functions (in
--   particular, to distinguish between `Ptr a' and `FunPtr a')
--
--  * aliased types (`DefinedET') are represented by a string plus their C
--   declaration; the latter is for functions interpreting the following
--   structure; an aliased type is always a pointer type that is contained in
--   the pointer map (and got there either from a .chi or from a pointer hook
--   in the same module)
--
--  * the representation for pointers does not distinguish between normal,
--   function, foreign, and stable pointers; function pointers are identified
--   by their argument and foreign and stable pointers are only used
--   indirectly, by referring to type names introduced by a `pointer' hook
--
data ExtType = FunET     ExtType ExtType        -- function
             | IOET      ExtType                -- operation with side effect
             | PtrET     ExtType                -- typed pointer
             | DefinedET CDecl HsPtrRep         -- aliased type
             | PrimET    CPrimType              -- basic C type
             | UnitET                           -- void

instance Eq ExtType where
  (FunET     ExtType
t1 ExtType
t2 ) == :: ExtType -> ExtType -> Bool
== (FunET     ExtType
t1' ExtType
t2' ) = ExtType
t1 ExtType -> ExtType -> Bool
forall a. Eq a => a -> a -> Bool
== ExtType
t1' Bool -> Bool -> Bool
&& ExtType
t2 ExtType -> ExtType -> Bool
forall a. Eq a => a -> a -> Bool
== ExtType
t2'
  (IOET      ExtType
t     ) == (IOET      ExtType
t'      ) = ExtType
t ExtType -> ExtType -> Bool
forall a. Eq a => a -> a -> Bool
== ExtType
t'
  (PtrET     ExtType
t     ) == (PtrET     ExtType
t'      ) = ExtType
t ExtType -> ExtType -> Bool
forall a. Eq a => a -> a -> Bool
== ExtType
t'
  (DefinedET CDecl
_ HsPtrRep
rep ) == (DefinedET CDecl
_ HsPtrRep
rep'  ) = HsPtrRep
rep HsPtrRep -> HsPtrRep -> Bool
forall a. Eq a => a -> a -> Bool
== HsPtrRep
rep'
  (PrimET    CPrimType
t     ) == (PrimET    CPrimType
t'      ) = CPrimType
t CPrimType -> CPrimType -> Bool
forall a. Eq a => a -> a -> Bool
== CPrimType
t'
  ExtType
UnitET             == ExtType
UnitET               = Bool
True

-- composite C type
--
data CompType = ExtType  ExtType                -- external type
              | SUType   CStructUnion           -- structure or union

-- check whether an external type denotes a function type
--
isFunExtType             :: ExtType -> Bool
isFunExtType :: ExtType -> Bool
isFunExtType (FunET ExtType
_ ExtType
_)  = Bool
True
isFunExtType (IOET  ExtType
_  )  = Bool
True
isFunExtType (DefinedET CDecl
_ (Bool
isFun,CHSPtrType
_,Maybe String
_,String
_)) = Bool
isFun
isFunExtType ExtType
_            = Bool
False

-- pretty print an external type
--
--  * a previous version of this function attempted to not print unnecessary
--   brackets; this however doesn't work consistently due to `DefinedET'; so,
--   we give up on the idea (preferring simplicity)
--
showExtType                        :: ExtType -> String
showExtType :: ExtType -> String
showExtType (FunET ExtType
UnitET ExtType
res)      = ExtType -> String
showExtType ExtType
res
showExtType (FunET ExtType
arg ExtType
res)         = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
arg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " 
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
res String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showExtType (IOET ExtType
t)                = String
"(IO " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showExtType (PtrET ExtType
t)               = let ptrCon :: String
ptrCon = if ExtType -> Bool
isFunExtType ExtType
t 
                                                   then String
"FunPtr" else String
"Ptr"
                                      in
                                      String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ptrCon String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
t 
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
showExtType (DefinedET CDecl
_ (Bool
_,CHSPtrType
_,Maybe String
_,String
str)) = String
str
showExtType (PrimET CPrimType
CPtrPT)         = String
"(Ptr ())"
showExtType (PrimET CPrimType
CFunPtrPT)      = String
"(FunPtr ())"
showExtType (PrimET CPrimType
CCharPT)        = String
"CChar"
showExtType (PrimET CPrimType
CUCharPT)       = String
"CUChar"
showExtType (PrimET CPrimType
CSCharPT)       = String
"CSChar"
showExtType (PrimET CPrimType
CIntPT)         = String
"CInt"
showExtType (PrimET CPrimType
CShortPT)       = String
"CShort"
showExtType (PrimET CPrimType
CLongPT)        = String
"CLong"
showExtType (PrimET CPrimType
CLLongPT)       = String
"CLLong"
showExtType (PrimET CPrimType
CUIntPT)        = String
"CUInt"
showExtType (PrimET CPrimType
CUShortPT)      = String
"CUShort"
showExtType (PrimET CPrimType
CULongPT)       = String
"CULong"
showExtType (PrimET CPrimType
CULLongPT)      = String
"CULLong"
showExtType (PrimET CPrimType
CFloatPT)       = String
"CFloat"
showExtType (PrimET CPrimType
CDoublePT)      = String
"CDouble"
showExtType (PrimET CPrimType
CLDoublePT)     = String
"CLDouble"
showExtType (PrimET (CSFieldPT Int
bs)) = String
"CInt{-:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-}"
showExtType (PrimET (CUFieldPT Int
bs)) = String
"CUInt{-:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-}"
showExtType ExtType
UnitET                  = String
"()"

-- compute the type of the C function declared by the given C object
--
--  * the identifier specifies in which of the declarators we are interested
--
--  * if the third argument is `True', the function result should not be
--   wrapped into an `IO' type
--
--  * the caller has to guarantee that the object does indeed refer to a
--   function 
--
extractFunType                  :: Position -> CDecl -> Bool ->
                                   GB ([Maybe HsPtrRep], ExtType)
extractFunType :: Position -> CDecl -> Bool -> GB ([Maybe HsPtrRep], ExtType)
extractFunType Position
pos CDecl
cdecl Bool
isPure  = 
  do
    -- remove all declarators except that of the function we are processing;
    -- then, extract the functions arguments and result type (also check that
    -- the function is not variadic); finally, compute the external type for
    -- the result
    --
    let ([CDecl]
args, CDecl
resultDecl, Bool
variadic) = CDecl -> ([CDecl], CDecl, Bool)
funResultAndArgs CDecl
cdecl
    Bool -> CST (CState GBState) () -> CST (CState GBState) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
variadic (CST (CState GBState) () -> CST (CState GBState) ())
-> CST (CState GBState) () -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$
      Position -> Position -> CST (CState GBState) ()
forall a. Position -> Position -> GB a
variadicErr Position
pos Position
cpos
    ExtType
preResultType <- (ExtType -> ExtType) -> GB ExtType -> GB ExtType
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Maybe HsPtrRep, ExtType) -> ExtType
forall a b. (a, b) -> b
snd ((Maybe HsPtrRep, ExtType) -> ExtType)
-> (ExtType -> (Maybe HsPtrRep, ExtType)) -> ExtType -> ExtType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtType -> (Maybe HsPtrRep, ExtType)
expandSpecialPtrs) (GB ExtType -> GB ExtType) -> GB ExtType -> GB ExtType
forall a b. (a -> b) -> a -> b
$ 
                     Position -> CDecl -> GB ExtType
extractSimpleType Position
pos CDecl
resultDecl
    --
    -- we can now add the `IO' monad if this is no pure function 
    --
    let resultType :: ExtType
resultType = if Bool
isPure 
                     then      ExtType
preResultType 
                     else ExtType -> ExtType
IOET ExtType
preResultType
    --
    -- compute function arguments and create a function type (a function
    -- prototype with `void' as its single argument declares a nullary
    -- function) 
    --
    ([Maybe HsPtrRep]
foreignSyn, [ExtType]
argTypes) <- ([ExtType] -> ([Maybe HsPtrRep], [ExtType]))
-> PreCST SwitchBoard (CState GBState) [ExtType]
-> PreCST
     SwitchBoard (CState GBState) ([Maybe HsPtrRep], [ExtType])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([(Maybe HsPtrRep, ExtType)] -> ([Maybe HsPtrRep], [ExtType])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe HsPtrRep, ExtType)] -> ([Maybe HsPtrRep], [ExtType]))
-> ([ExtType] -> [(Maybe HsPtrRep, ExtType)])
-> [ExtType]
-> ([Maybe HsPtrRep], [ExtType])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtType -> (Maybe HsPtrRep, ExtType))
-> [ExtType] -> [(Maybe HsPtrRep, ExtType)]
forall a b. (a -> b) -> [a] -> [b]
map ExtType -> (Maybe HsPtrRep, ExtType)
expandSpecialPtrs) (PreCST SwitchBoard (CState GBState) [ExtType]
 -> PreCST
      SwitchBoard (CState GBState) ([Maybe HsPtrRep], [ExtType]))
-> PreCST SwitchBoard (CState GBState) [ExtType]
-> PreCST
     SwitchBoard (CState GBState) ([Maybe HsPtrRep], [ExtType])
forall a b. (a -> b) -> a -> b
$
                              (CDecl -> GB ExtType)
-> [CDecl] -> PreCST SwitchBoard (CState GBState) [ExtType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Position -> CDecl -> GB ExtType
extractSimpleType Position
pos) [CDecl]
args

    ([Maybe HsPtrRep], ExtType) -> GB ([Maybe HsPtrRep], ExtType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe HsPtrRep]
foreignSyn, (ExtType -> ExtType -> ExtType) -> ExtType -> [ExtType] -> ExtType
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ExtType -> ExtType -> ExtType
FunET ExtType
resultType [ExtType]
argTypes)
  where
    cpos :: Position
cpos = CDecl -> Position
forall a. Pos a => a -> Position
posOf CDecl
cdecl

    -- provide info on Haskell wrappers around C pointers
    expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType)
      -- no special treatment for a simple type synonym
    expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType)
expandSpecialPtrs all :: ExtType
all@(DefinedET CDecl
cdecl (Bool
_, CHSPtrType
CHSPtr, Maybe String
Nothing, String
_)) = 
        (Maybe HsPtrRep
forall a. Maybe a
Nothing, ExtType -> ExtType
PtrET ExtType
all)
      -- all other Haskell pointer wrappings require
      -- special calling conventions
    expandSpecialPtrs all :: ExtType
all@(DefinedET CDecl
cdecl HsPtrRep
hsPtrRep) = 
        (HsPtrRep -> Maybe HsPtrRep
forall a. a -> Maybe a
Just HsPtrRep
hsPtrRep, ExtType -> ExtType
PtrET ExtType
all)
      -- non-pointer arguments are passed normal
    expandSpecialPtrs ExtType
all = (Maybe HsPtrRep
forall a. Maybe a
Nothing, ExtType
all)

-- compute a non-struct/union type from the given declaration 
--
--  * the declaration may have at most one declarator
--
--  * C functions are represented as `Ptr (FunEt ...)' or `Addr' if in
--   compatibility mode (ie, `--old-ffi=yes')
--
extractSimpleType            :: Position -> CDecl -> GB ExtType
extractSimpleType :: Position -> CDecl -> GB ExtType
extractSimpleType Position
pos CDecl
cdecl  =
  do
    CST (CState GBState) ()
traceEnter
    CompType
ct <- CDecl -> GB CompType
extractCompType CDecl
cdecl
    case CompType
ct of
      ExtType ExtType
et -> ExtType -> GB ExtType
forall (m :: * -> *) a. Monad m => a -> m a
return ExtType
et
      SUType  CStructUnion
_  -> Position -> Position -> GB ExtType
forall a. Position -> Position -> GB a
illegalStructUnionErr (CDecl -> Position
forall a. Pos a => a -> Position
posOf CDecl
cdecl) Position
pos
  where
    traceEnter :: CST (CState GBState) ()
traceEnter = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"Entering `extractSimpleType'...\n"

-- compute a Haskell type for a type referenced in a C pointer type
--
--  * the declaration may have at most one declarator
--
--  * struct/union types are mapped to `()'
--
--  * NB: this is by definition not a result type
--
extractPtrType       :: CDecl -> GB ExtType
extractPtrType :: CDecl -> GB ExtType
extractPtrType CDecl
cdecl  = do
  CompType
ct <- CDecl -> GB CompType
extractCompType CDecl
cdecl
  case CompType
ct of
    ExtType ExtType
et -> ExtType -> GB ExtType
forall (m :: * -> *) a. Monad m => a -> m a
return ExtType
et
    SUType  CStructUnion
_  -> ExtType -> GB ExtType
forall (m :: * -> *) a. Monad m => a -> m a
return ExtType
UnitET

-- compute a Haskell type from the given C declaration, where C functions are
-- represented by function pointers
--
--  * the declaration may have at most one declarator
--
--  * all C pointers (including functions) are represented as `Addr' if in
--   compatibility mode (--old-ffi)
--
--  * typedef'ed types are chased
--
--  * takes the pointer map into account
--
--  * IMPORTANT NOTE: `sizeAlignOf' relies on `DefinedET' only being produced
--                   for pointer types; if this ever changes, we need to
--                   handle `DefinedET's differently.  The problem is that
--                   entries in the pointer map currently prevent
--                   `extractCompType' from looking further "into" the
--                   definition of that pointer.
--
extractCompType :: CDecl -> GB CompType
extractCompType :: CDecl -> GB CompType
extractCompType cdecl :: CDecl
cdecl@(CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs Attrs
ats)  =
  if [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 
  then String -> GB CompType
forall a. String -> a
interr String
"GenBind.extractCompType: Too many declarators!"
  else case [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs of
    [(Just CDeclr
declr, Maybe CInit
_, Maybe CExpr
size)] | CDeclr -> Bool
isPtrDeclr CDeclr
declr -> CDeclr -> GB CompType
ptrType CDeclr
declr
                            | CDeclr -> Bool
isFunDeclr CDeclr
declr -> GB CompType
funType
                            | Bool
otherwise        -> Maybe CExpr -> GB CompType
aliasOrSpecType Maybe CExpr
size
    []                                         -> Maybe CExpr -> GB CompType
aliasOrSpecType Maybe CExpr
forall a. Maybe a
Nothing
  where
    -- handle explicit pointer types
    --
    ptrType :: CDeclr -> GB CompType
ptrType CDeclr
declr = do
      CST (CState GBState) ()
tracePtrType
      let declrs' :: CDeclr
declrs' = CDeclr -> CDeclr
dropPtrDeclr CDeclr
declr          -- remove indirection
          cdecl' :: CDecl
cdecl'  = [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(CDeclr -> Maybe CDeclr
forall a. a -> Maybe a
Just CDeclr
declrs', Maybe CInit
forall a. Maybe a
Nothing, Maybe CExpr
forall a. Maybe a
Nothing)] Attrs
ats
          oalias :: Maybe Ident
oalias  = CDecl -> Maybe Ident
checkForOneAliasName CDecl
cdecl' -- is only an alias remaining?
      Maybe HsPtrRep
oHsRepr <- case Maybe Ident
oalias of
                   Maybe Ident
Nothing  -> Maybe HsPtrRep
-> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe HsPtrRep
 -> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep))
-> Maybe HsPtrRep
-> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep)
forall a b. (a -> b) -> a -> b
$ Maybe HsPtrRep
forall a. Maybe a
Nothing
                   Just Ident
ide -> (Bool, Ident)
-> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep)
queryPtr (Bool
True, Ident
ide)
      case Maybe HsPtrRep
oHsRepr of
        Just HsPtrRep
repr  -> HsPtrRep -> GB CompType
forall s. HsPtrRep -> PreCST SwitchBoard s CompType
ptrAlias HsPtrRep
repr             -- got an alias
        Maybe HsPtrRep
Nothing    -> do                        -- no alias => recurs
          CompType
ct <- CDecl -> GB CompType
extractCompType CDecl
cdecl'
          ExtType -> GB CompType
forall s. ExtType -> PreCST SwitchBoard s CompType
returnX (ExtType -> GB CompType) -> ExtType -> GB CompType
forall a b. (a -> b) -> a -> b
$ case CompType
ct of
                      ExtType ExtType
et -> ExtType -> ExtType
PtrET ExtType
et
                      SUType  CStructUnion
_  -> ExtType -> ExtType
PtrET ExtType
UnitET
    --
    -- handle explicit function types
    --
    -- FIXME: we currently regard any functions as being impure (ie, being IO
    --        functions); is this ever going to be a problem?
    --
    funType :: GB CompType
funType = do
                CST (CState GBState) ()
traceFunType
                ([Maybe HsPtrRep]
_, ExtType
et) <- Position -> CDecl -> Bool -> GB ([Maybe HsPtrRep], ExtType)
extractFunType (CDecl -> Position
forall a. Pos a => a -> Position
posOf CDecl
cdecl) CDecl
cdecl Bool
False
                ExtType -> GB CompType
forall s. ExtType -> PreCST SwitchBoard s CompType
returnX ExtType
et
    --
    -- handle all types, which are not obviously pointers or functions 
    --
    aliasOrSpecType :: Maybe CExpr -> GB CompType
    aliasOrSpecType :: Maybe CExpr -> GB CompType
aliasOrSpecType Maybe CExpr
size = do
      Maybe CExpr -> CST (CState GBState) ()
forall a. Maybe a -> CST (CState GBState) ()
traceAliasOrSpecType Maybe CExpr
size
      case CDecl -> Maybe Ident
checkForOneAliasName CDecl
cdecl of
        Maybe Ident
Nothing   -> Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType
specType (CDecl -> Position
forall a. Pos a => a -> Position
posOf CDecl
cdecl) [CDeclSpec]
specs Maybe CExpr
size
        Just Ident
ide  -> do                    -- this is a typedef alias
          Ident -> CST (CState GBState) ()
traceAlias Ident
ide
          Maybe HsPtrRep
oHsRepr <- (Bool, Ident)
-> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep)
queryPtr (Bool
False, Ident
ide) -- check for pointer hook alias     
          case Maybe HsPtrRep
oHsRepr of
            Maybe HsPtrRep
Nothing   -> do                -- skip current alias (only one)
                           CDecl
cdecl' <- Ident -> CT GBState CDecl
forall s. Ident -> CT s CDecl
getDeclOf Ident
ide
                           let CDecl [CDeclSpec]
specs [(Maybe CDeclr
declr, Maybe CInit
init, Maybe CExpr
_)] Attrs
at =
                                 Ident
ide Ident -> CDecl -> CDecl
`simplifyDecl` CDecl
cdecl'
                               sdecl :: CDecl
sdecl = [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(Maybe CDeclr
declr, Maybe CInit
init, Maybe CExpr
size)] Attrs
at
                               -- propagate `size' down (slightly kludgy)
                           CDecl -> GB CompType
extractCompType CDecl
sdecl
            Just HsPtrRep
repr -> HsPtrRep -> GB CompType
forall s. HsPtrRep -> PreCST SwitchBoard s CompType
ptrAlias HsPtrRep
repr     -- found a pointer hook alias
    --
    -- compute the result for a pointer alias
    --
    ptrAlias :: HsPtrRep -> PreCST SwitchBoard s CompType
ptrAlias (Bool
isFun, CHSPtrType
ptrTy, Maybe String
wrapped, String
tyArg) = 
      ExtType -> PreCST SwitchBoard s CompType
forall s. ExtType -> PreCST SwitchBoard s CompType
returnX (ExtType -> PreCST SwitchBoard s CompType)
-> ExtType -> PreCST SwitchBoard s CompType
forall a b. (a -> b) -> a -> b
$ CDecl -> HsPtrRep -> ExtType
DefinedET CDecl
cdecl (Bool
isFun, CHSPtrType
ptrTy, Maybe String
wrapped, String
tyArg)
    --
    -- wrap an `ExtType' into a `CompType' and convert parametrised pointers
    -- to `Addr' if needed
    --
    returnX :: ExtType -> PreCST SwitchBoard s CompType
returnX retval :: ExtType
retval@(PtrET ExtType
et) = do
                                  Bool
keepOld <- (SwitchBoard -> Bool) -> CST s Bool
forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
oldFFI
                                  if Bool
keepOld 
                                    then CompType -> PreCST SwitchBoard s CompType
forall (m :: * -> *) a. Monad m => a -> m a
return (CompType -> PreCST SwitchBoard s CompType)
-> CompType -> PreCST SwitchBoard s CompType
forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType (CPrimType -> ExtType
PrimET CPrimType
CPtrPT)
                                    else CompType -> PreCST SwitchBoard s CompType
forall (m :: * -> *) a. Monad m => a -> m a
return (CompType -> PreCST SwitchBoard s CompType)
-> CompType -> PreCST SwitchBoard s CompType
forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType ExtType
retval
    returnX ExtType
retval            = CompType -> PreCST SwitchBoard s CompType
forall (m :: * -> *) a. Monad m => a -> m a
return (CompType -> PreCST SwitchBoard s CompType)
-> CompType -> PreCST SwitchBoard s CompType
forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType ExtType
retval
    --
    tracePtrType :: CST (CState GBState) ()
tracePtrType = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ String
"extractCompType: explicit pointer type\n"
    traceFunType :: CST (CState GBState) ()
traceFunType = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ String
"extractCompType: explicit function type\n"
    traceAliasOrSpecType :: Maybe a -> CST (CState GBState) ()
traceAliasOrSpecType Maybe a
Nothing  = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"extractCompType: checking for alias\n"
    traceAliasOrSpecType (Just a
_) = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"extractCompType: checking for alias of bitfield\n"
    traceAlias :: Ident -> CST (CState GBState) ()
traceAlias Ident
ide = String -> CST (CState GBState) ()
traceGenBind (String -> CST (CState GBState) ())
-> String -> CST (CState GBState) ()
forall a b. (a -> b) -> a -> b
$ 
      String
"extractCompType: found an alias called `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\n"

-- C to Haskell type mapping described in the DOCU section
--
typeMap :: [([CTypeSpec], ExtType)]
typeMap :: [([CTypeSpec], ExtType)]
typeMap  = [([CTypeSpec
void]                      , ExtType
UnitET           ),
            ([CTypeSpec
char]                      , CPrimType -> ExtType
PrimET CPrimType
CCharPT   ),
            ([CTypeSpec
unsigned, CTypeSpec
char]            , CPrimType -> ExtType
PrimET CPrimType
CUCharPT  ),
            ([CTypeSpec
signed, CTypeSpec
char]              , CPrimType -> ExtType
PrimET CPrimType
CSCharPT  ),
            ([CTypeSpec
signed]                    , CPrimType -> ExtType
PrimET CPrimType
CIntPT    ),
            ([CTypeSpec
int]                       , CPrimType -> ExtType
PrimET CPrimType
CIntPT    ),
            ([CTypeSpec
signed, CTypeSpec
int]               , CPrimType -> ExtType
PrimET CPrimType
CIntPT    ),
            ([CTypeSpec
short]                     , CPrimType -> ExtType
PrimET CPrimType
CShortPT  ),
            ([CTypeSpec
short, CTypeSpec
int]                , CPrimType -> ExtType
PrimET CPrimType
CShortPT  ),
            ([CTypeSpec
signed, CTypeSpec
short]             , CPrimType -> ExtType
PrimET CPrimType
CShortPT  ),
            ([CTypeSpec
signed, CTypeSpec
short, CTypeSpec
int]        , CPrimType -> ExtType
PrimET CPrimType
CShortPT  ),
            ([CTypeSpec
long]                      , CPrimType -> ExtType
PrimET CPrimType
CLongPT   ),
            ([CTypeSpec
long, CTypeSpec
int]                 , CPrimType -> ExtType
PrimET CPrimType
CLongPT   ),
            ([CTypeSpec
signed, CTypeSpec
long]              , CPrimType -> ExtType
PrimET CPrimType
CLongPT   ),
            ([CTypeSpec
signed, CTypeSpec
long, CTypeSpec
int]         , CPrimType -> ExtType
PrimET CPrimType
CLongPT   ),
            ([CTypeSpec
long, CTypeSpec
long]                , CPrimType -> ExtType
PrimET CPrimType
CLLongPT  ),
            ([CTypeSpec
long, CTypeSpec
long, CTypeSpec
int]           , CPrimType -> ExtType
PrimET CPrimType
CLLongPT  ),
            ([CTypeSpec
signed, CTypeSpec
long, CTypeSpec
long]        , CPrimType -> ExtType
PrimET CPrimType
CLLongPT  ),
            ([CTypeSpec
signed, CTypeSpec
long, CTypeSpec
long, CTypeSpec
int]   , CPrimType -> ExtType
PrimET CPrimType
CLLongPT  ),
            ([CTypeSpec
unsigned]                  , CPrimType -> ExtType
PrimET CPrimType
CUIntPT   ),
            ([CTypeSpec
unsigned, CTypeSpec
int]             , CPrimType -> ExtType
PrimET CPrimType
CUIntPT   ),
            ([CTypeSpec
unsigned, CTypeSpec
short]           , CPrimType -> ExtType
PrimET CPrimType
CUShortPT ),
            ([CTypeSpec
unsigned, CTypeSpec
short, CTypeSpec
int]      , CPrimType -> ExtType
PrimET CPrimType
CUShortPT ),
            ([CTypeSpec
unsigned, CTypeSpec
long]            , CPrimType -> ExtType
PrimET CPrimType
CULongPT  ),
            ([CTypeSpec
unsigned, CTypeSpec
long, CTypeSpec
int]       , CPrimType -> ExtType
PrimET CPrimType
CULongPT  ),
            ([CTypeSpec
unsigned, CTypeSpec
long, CTypeSpec
long]      , CPrimType -> ExtType
PrimET CPrimType
CULLongPT ),
            ([CTypeSpec
unsigned, CTypeSpec
long, CTypeSpec
long, CTypeSpec
int] , CPrimType -> ExtType
PrimET CPrimType
CULLongPT ),
            ([CTypeSpec
float]                     , CPrimType -> ExtType
PrimET CPrimType
CFloatPT  ),
            ([CTypeSpec
double]                    , CPrimType -> ExtType
PrimET CPrimType
CDoublePT ),
            ([CTypeSpec
long, CTypeSpec
double]              , CPrimType -> ExtType
PrimET CPrimType
CLDoublePT),
            ([CTypeSpec
enum]                      , CPrimType -> ExtType
PrimET CPrimType
CIntPT    )]
           where
             void :: CTypeSpec
void     = Attrs -> CTypeSpec
CVoidType   Attrs
forall a. HasCallStack => a
undefined
             char :: CTypeSpec
char     = Attrs -> CTypeSpec
CCharType   Attrs
forall a. HasCallStack => a
undefined
             short :: CTypeSpec
short    = Attrs -> CTypeSpec
CShortType  Attrs
forall a. HasCallStack => a
undefined
             int :: CTypeSpec
int      = Attrs -> CTypeSpec
CIntType    Attrs
forall a. HasCallStack => a
undefined
             long :: CTypeSpec
long     = Attrs -> CTypeSpec
CLongType   Attrs
forall a. HasCallStack => a
undefined
             float :: CTypeSpec
float    = Attrs -> CTypeSpec
CFloatType  Attrs
forall a. HasCallStack => a
undefined
             double :: CTypeSpec
double   = Attrs -> CTypeSpec
CDoubleType Attrs
forall a. HasCallStack => a
undefined
             signed :: CTypeSpec
signed   = Attrs -> CTypeSpec
CSignedType Attrs
forall a. HasCallStack => a
undefined
             unsigned :: CTypeSpec
unsigned = Attrs -> CTypeSpec
CUnsigType  Attrs
forall a. HasCallStack => a
undefined
             enum :: CTypeSpec
enum     = CEnum -> Attrs -> CTypeSpec
CEnumType   CEnum
forall a. HasCallStack => a
undefined Attrs
forall a. HasCallStack => a
undefined

-- compute the complex (external) type determined by a list of type specifiers
--
--  * may not be called for a specifier that defines a typedef alias
--
specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType
specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType
specType Position
cpos [CDeclSpec]
specs Maybe CExpr
osize = 
  let tspecs :: [CTypeSpec]
tspecs = [CTypeSpec
ts | CTypeSpec CTypeSpec
ts <- [CDeclSpec]
specs]
  in case [CTypeSpec] -> [([CTypeSpec], ExtType)] -> Maybe ExtType
forall b. [CTypeSpec] -> [([CTypeSpec], b)] -> Maybe b
lookupTSpec [CTypeSpec]
tspecs [([CTypeSpec], ExtType)]
typeMap of
    Just ExtType
et | ExtType -> Bool
isUnsupportedType ExtType
et -> Position -> GB CompType
forall a. Position -> GB a
unsupportedTypeSpecErr Position
cpos
            | Maybe CExpr -> Bool
forall a. Maybe a -> Bool
isNothing Maybe CExpr
osize      -> CompType -> GB CompType
forall (m :: * -> *) a. Monad m => a -> m a
return (CompType -> GB CompType) -> CompType -> GB CompType
forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType ExtType
et     -- not a bitfield
            | Bool
otherwise            -> [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
bitfieldSpec [CTypeSpec]
tspecs ExtType
et Maybe CExpr
osize  -- bitfield
    Maybe ExtType
Nothing                        -> 
      case [CTypeSpec]
tspecs of
        [CSUType   CStructUnion
cu Attrs
_] -> CompType -> GB CompType
forall (m :: * -> *) a. Monad m => a -> m a
return (CompType -> GB CompType) -> CompType -> GB CompType
forall a b. (a -> b) -> a -> b
$ CStructUnion -> CompType
SUType CStructUnion
cu               -- struct or union
        [CEnumType CEnum
_  Attrs
_] -> CompType -> GB CompType
forall (m :: * -> *) a. Monad m => a -> m a
return (CompType -> GB CompType) -> CompType -> GB CompType
forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType (CPrimType -> ExtType
PrimET CPrimType
CIntPT) -- enum
        [CTypeDef  Ident
_  Attrs
_] -> String -> GB CompType
forall a. String -> a
interr String
"GenBind.specType: Illegal typedef alias!"
        [CTypeSpec]
_                -> Position -> GB CompType
forall a. Position -> GB a
illegalTypeSpecErr Position
cpos
  where
    lookupTSpec :: [CTypeSpec] -> [([CTypeSpec], b)] -> Maybe b
lookupTSpec = ([CTypeSpec] -> [CTypeSpec] -> Bool)
-> [CTypeSpec] -> [([CTypeSpec], b)] -> Maybe b
forall a b. (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
lookupBy [CTypeSpec] -> [CTypeSpec] -> Bool
matches
    --
    isUnsupportedType :: ExtType -> Bool
isUnsupportedType (PrimET CPrimType
et) = CPrimType -> Int
size CPrimType
et Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0  -- can't be a bitfield (yet)
    isUnsupportedType ExtType
_           = Bool
False
    --
    -- check whether two type specifier lists denote the same type; handles
    -- types like `long long' correctly, as `deleteBy' removes only the first
    -- occurrence of the given element
    --
    matches :: [CTypeSpec] -> [CTypeSpec] -> Bool
    []           matches :: [CTypeSpec] -> [CTypeSpec] -> Bool
`matches` []     = Bool
True
    []           `matches` (CTypeSpec
_:[CTypeSpec]
_)  = Bool
False
    (CTypeSpec
spec:[CTypeSpec]
specs) `matches` [CTypeSpec]
specs' 
      | (CTypeSpec -> Bool) -> [CTypeSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CTypeSpec -> CTypeSpec -> Bool
eqSpec CTypeSpec
spec) [CTypeSpec]
specs'  = [CTypeSpec]
specs [CTypeSpec] -> [CTypeSpec] -> Bool
`matches` (CTypeSpec -> CTypeSpec -> Bool)
-> CTypeSpec -> [CTypeSpec] -> [CTypeSpec]
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy CTypeSpec -> CTypeSpec -> Bool
eqSpec CTypeSpec
spec [CTypeSpec]
specs'
      | Bool
otherwise                 = Bool
False
    --
    eqSpec :: CTypeSpec -> CTypeSpec -> Bool
eqSpec (CVoidType   Attrs
_) (CVoidType   Attrs
_) = Bool
True
    eqSpec (CCharType   Attrs
_) (CCharType   Attrs
_) = Bool
True
    eqSpec (CShortType  Attrs
_) (CShortType  Attrs
_) = Bool
True
    eqSpec (CIntType    Attrs
_) (CIntType    Attrs
_) = Bool
True
    eqSpec (CLongType   Attrs
_) (CLongType   Attrs
_) = Bool
True
    eqSpec (CFloatType  Attrs
_) (CFloatType  Attrs
_) = Bool
True
    eqSpec (CDoubleType Attrs
_) (CDoubleType Attrs
_) = Bool
True
    eqSpec (CSignedType Attrs
_) (CSignedType Attrs
_) = Bool
True
    eqSpec (CUnsigType  Attrs
_) (CUnsigType  Attrs
_) = Bool
True
    eqSpec (CSUType   CStructUnion
_ Attrs
_) (CSUType   CStructUnion
_ Attrs
_) = Bool
True
    eqSpec (CEnumType CEnum
_ Attrs
_) (CEnumType CEnum
_ Attrs
_) = Bool
True
    eqSpec (CTypeDef  Ident
_ Attrs
_) (CTypeDef  Ident
_ Attrs
_) = Bool
True
    eqSpec CTypeSpec
_               CTypeSpec
_               = Bool
False
    --
    bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
    bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
bitfieldSpec [CTypeSpec]
tspecs ExtType
et (Just CExpr
sizeExpr) =  -- never called with `Nothing'
      do
        let pos :: Position
pos = CExpr -> Position
forall a. Pos a => a -> Position
posOf CExpr
sizeExpr
        ConstResult
sizeResult <- CExpr -> GB ConstResult
evalConstCExpr CExpr
sizeExpr
        case ConstResult
sizeResult of
          FloatResult Float
_     -> Position -> String -> GB CompType
forall a. Position -> String -> GB a
illegalConstExprErr Position
pos String
"a float result"
          IntResult   Integer
size' -> do
            let size :: Int
size = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
size'
            case ExtType
et of
              PrimET CPrimType
CUIntPT                      -> CPrimType -> GB CompType
returnCT (CPrimType -> GB CompType) -> CPrimType -> GB CompType
forall a b. (a -> b) -> a -> b
$ Int -> CPrimType
CUFieldPT Int
size
              PrimET CPrimType
CIntPT 
                |  [CTypeSpec
signed]      [CTypeSpec] -> [CTypeSpec] -> Bool
`matches` [CTypeSpec]
tspecs 
                Bool -> Bool -> Bool
|| [CTypeSpec
signed, CTypeSpec
int] [CTypeSpec] -> [CTypeSpec] -> Bool
`matches` [CTypeSpec]
tspecs -> CPrimType -> GB CompType
returnCT (CPrimType -> GB CompType) -> CPrimType -> GB CompType
forall a b. (a -> b) -> a -> b
$ Int -> CPrimType
CSFieldPT Int
size
                |  [CTypeSpec
int]         [CTypeSpec] -> [CTypeSpec] -> Bool
`matches` [CTypeSpec]
tspecs -> 
                  CPrimType -> GB CompType
returnCT (CPrimType -> GB CompType) -> CPrimType -> GB CompType
forall a b. (a -> b) -> a -> b
$ if Bool
bitfieldIntSigned then Int -> CPrimType
CSFieldPT Int
size 
                                                  else Int -> CPrimType
CUFieldPT Int
size
              ExtType
_                                   -> Position -> GB CompType
forall a. Position -> GB a
illegalFieldSizeErr Position
pos
            where
              returnCT :: CPrimType -> GB CompType
returnCT = CompType -> GB CompType
forall (m :: * -> *) a. Monad m => a -> m a
return (CompType -> GB CompType)
-> (CPrimType -> CompType) -> CPrimType -> GB CompType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtType -> CompType
ExtType (ExtType -> CompType)
-> (CPrimType -> ExtType) -> CPrimType -> CompType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPrimType -> ExtType
PrimET
              --
              int :: CTypeSpec
int    = Attrs -> CTypeSpec
CIntType    Attrs
forall a. HasCallStack => a
undefined
              signed :: CTypeSpec
signed = Attrs -> CTypeSpec
CSignedType Attrs
forall a. HasCallStack => a
undefined


-- offset and size computations
-- ----------------------------

-- precise size representation
--
--  * this is a pair of a number of octets and a number of bits
--
--  * if the number of bits is nonzero, the octet component is aligned by the
--   alignment constraint for `CIntPT' (important for accessing bitfields with
--   more than 8 bits)
--
data BitSize = BitSize Int Int
             deriving (BitSize -> BitSize -> Bool
(BitSize -> BitSize -> Bool)
-> (BitSize -> BitSize -> Bool) -> Eq BitSize
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BitSize -> BitSize -> Bool
$c/= :: BitSize -> BitSize -> Bool
== :: BitSize -> BitSize -> Bool
$c== :: BitSize -> BitSize -> Bool
Eq, Int -> BitSize -> String -> String
[BitSize] -> String -> String
BitSize -> String
(Int -> BitSize -> String -> String)
-> (BitSize -> String)
-> ([BitSize] -> String -> String)
-> Show BitSize
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [BitSize] -> String -> String
$cshowList :: [BitSize] -> String -> String
show :: BitSize -> String
$cshow :: BitSize -> String
showsPrec :: Int -> BitSize -> String -> String
$cshowsPrec :: Int -> BitSize -> String -> String
Show)

-- ordering relation compares in terms of required storage units
--
instance Ord BitSize where
  bs1 :: BitSize
bs1@(BitSize Int
o1 Int
b1) < :: BitSize -> BitSize -> Bool
<  bs2 :: BitSize
bs2@(BitSize Int
o2 Int
b2) = 
    BitSize -> Int
padBits BitSize
bs1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< BitSize -> Int
padBits BitSize
bs2 Bool -> Bool -> Bool
|| (Int
o1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
o2 Bool -> Bool -> Bool
&& Int
b1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
b2)
  BitSize
bs1                 <= :: BitSize -> BitSize -> Bool
<= BitSize
bs2                 = BitSize
bs1 BitSize -> BitSize -> Bool
forall a. Ord a => a -> a -> Bool
< BitSize
bs2 Bool -> Bool -> Bool
|| BitSize
bs1 BitSize -> BitSize -> Bool
forall a. Eq a => a -> a -> Bool
== BitSize
bs2
    -- the <= instance is needed for Ord's compare functions, which is used in
    -- the defaults for all other members

-- add two bit size values
--
addBitSize                                 :: BitSize -> BitSize -> BitSize
addBitSize :: BitSize -> BitSize -> BitSize
addBitSize (BitSize Int
o1 Int
b1) (BitSize Int
o2 Int
b2)  = Int -> Int -> BitSize
BitSize (Int
o1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
o2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
overflow) Int
rest
  where
    bitsPerBitfield :: Int
bitsPerBitfield  = CPrimType -> Int
size CPrimType
CIntPT Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
    (Int
overflow, Int
rest) = (Int
b1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b2) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
bitsPerBitfield

-- pad any storage unit that is partially used by a bitfield
--
padBits               :: BitSize -> Int
padBits :: BitSize -> Int
padBits (BitSize Int
o Int
0)  = Int
o
padBits (BitSize Int
o Int
_)  = Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CPrimType -> Int
size CPrimType
CIntPT

-- compute the offset of the declarator in the second argument when it is
-- preceded by the declarators in the first argument
--
offsetInStruct                :: [CDecl] -> CDecl -> CStructTag -> GB BitSize
offsetInStruct :: [CDecl]
-> CDecl
-> CStructTag
-> PreCST SwitchBoard (CState GBState) BitSize
offsetInStruct []    CDecl
_    CStructTag
_    = BitSize -> PreCST SwitchBoard (CState GBState) BitSize
forall (m :: * -> *) a. Monad m => a -> m a
return (BitSize -> PreCST SwitchBoard (CState GBState) BitSize)
-> BitSize -> PreCST SwitchBoard (CState GBState) BitSize
forall a b. (a -> b) -> a -> b
$ Int -> Int -> BitSize
BitSize Int
0 Int
0
offsetInStruct [CDecl]
decls CDecl
decl CStructTag
tag  = 
  do
    (BitSize
offset, Int
_) <- [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct [CDecl]
decls CStructTag
tag
    (BitSize
_, Int
align)  <- CDecl -> GB (BitSize, Int)
sizeAlignOf CDecl
decl
    BitSize -> PreCST SwitchBoard (CState GBState) BitSize
forall (m :: * -> *) a. Monad m => a -> m a
return (BitSize -> PreCST SwitchBoard (CState GBState) BitSize)
-> BitSize -> PreCST SwitchBoard (CState GBState) BitSize
forall a b. (a -> b) -> a -> b
$ BitSize -> Int -> BitSize
alignOffset BitSize
offset Int
align

-- compute the size and alignment (no padding at the end) of a set of
-- declarators from a struct
--
sizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct []    CStructTag
_           = (BitSize, Int) -> GB (BitSize, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> BitSize
BitSize Int
0 Int
0, Int
1)
sizeAlignOfStruct [CDecl]
decls CStructTag
CStructTag  = 
  do
    (BitSize
offset, Int
preAlign) <- [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct ([CDecl] -> [CDecl]
forall a. [a] -> [a]
init [CDecl]
decls) CStructTag
CStructTag
    (BitSize
size, Int
align)      <- CDecl -> GB (BitSize, Int)
sizeAlignOf       ([CDecl] -> CDecl
forall a. [a] -> a
last [CDecl]
decls)
    let sizeOfStruct :: BitSize
sizeOfStruct  = BitSize -> Int -> BitSize
alignOffset BitSize
offset Int
align BitSize -> BitSize -> BitSize
`addBitSize` BitSize
size
        align' :: Int
align'        = if Int
align Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int
align else Int
bitfieldAlignment
        alignOfStruct :: Int
alignOfStruct = Int
preAlign Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
align'
    (BitSize, Int) -> GB (BitSize, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (BitSize
sizeOfStruct, Int
alignOfStruct)
sizeAlignOfStruct [CDecl]
decls CStructTag
CUnionTag   =
  do
    ([BitSize]
sizes, [Int]
aligns) <- (CDecl -> GB (BitSize, Int))
-> [CDecl]
-> PreCST SwitchBoard (CState GBState) ([BitSize], [Int])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CDecl -> GB (BitSize, Int)
sizeAlignOf [CDecl]
decls
    let aligns' :: [Int]
aligns' = [if Int
align Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int
align else Int
bitfieldAlignment
                  | Int
align <- [Int]
aligns]
    (BitSize, Int) -> GB (BitSize, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ([BitSize] -> BitSize
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [BitSize]
sizes, [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
aligns')

-- compute the size and alignment of the declarators forming a struct
-- including any end-of-struct padding that is needed to make the struct ``tile
-- in an array'' (K&R A7.4.8)
--
sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStructPad [CDecl]
decls CStructTag
tag =
  do
    (BitSize
size, Int
align) <- [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct [CDecl]
decls CStructTag
tag
    (BitSize, Int) -> GB (BitSize, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (BitSize -> Int -> BitSize
alignOffset BitSize
size Int
align, Int
align)

-- compute the size and alignment constraint of a given C declaration
--
sizeAlignOf       :: CDecl -> GB (BitSize, Int)
--
--  * we make use of the assertion that `extractCompType' can only return a
--   `DefinedET' when the declaration is a pointer declaration
--
sizeAlignOf :: CDecl -> GB (BitSize, Int)
sizeAlignOf (CDecl [CDeclSpec]
specs [(Just CDeclr
declr, Maybe CInit
_, Maybe CExpr
size)] Attrs
ats) | CDeclr -> Bool
isArrDeclr CDeclr
declr =
  String -> GB (BitSize, Int)
forall a. String -> a
interr (String -> GB (BitSize, Int)) -> String -> GB (BitSize, Int)
forall a b. (a -> b) -> a -> b
$ String
"sizeAlignOf: calculating size of constant array not supported."
sizeAlignOf CDecl
cdecl  = 
  do
    CompType
ct <- CDecl -> GB CompType
extractCompType CDecl
cdecl
    case CompType
ct of
      ExtType (FunET ExtType
_ ExtType
_        ) -> (BitSize, Int) -> GB (BitSize, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
CFunPtrPT, 
                                             CPrimType -> Int
alignment CPrimType
CFunPtrPT)
      ExtType (IOET  ExtType
_          ) -> String -> GB (BitSize, Int)
forall a. String -> a
interr String
"GenBind.sizeof: Illegal IO type!"
      ExtType (PtrET ExtType
t          ) 
        | ExtType -> Bool
isFunExtType ExtType
t          -> (BitSize, Int) -> GB (BitSize, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
CFunPtrPT, 
                                             CPrimType -> Int
alignment CPrimType
CFunPtrPT)
        | Bool
otherwise               -> (BitSize, Int) -> GB (BitSize, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
CPtrPT, CPrimType -> Int
alignment CPrimType
CPtrPT)
      ExtType (DefinedET CDecl
_ HsPtrRep
_    ) -> (BitSize, Int) -> GB (BitSize, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
CPtrPT, CPrimType -> Int
alignment CPrimType
CPtrPT)
        -- FIXME: The defined type could be a function pointer!!!
      ExtType (PrimET CPrimType
pt        ) -> (BitSize, Int) -> GB (BitSize, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
pt, CPrimType -> Int
alignment CPrimType
pt)
      ExtType ExtType
UnitET              -> Position -> GB (BitSize, Int)
forall a. Position -> GB a
voidFieldErr (CDecl -> Position
forall a. Pos a => a -> Position
posOf CDecl
cdecl)
      SUType CStructUnion
su                   -> 
        do
          let ([CDecl]
fields, CStructTag
tag) = CStructUnion -> ([CDecl], CStructTag)
structMembers CStructUnion
su
          [CDecl]
fields' <- let ide :: Maybe Ident
ide = CStructUnion -> Maybe Ident
structName CStructUnion
su 
                     in
                     if (Bool -> Bool
not (Bool -> Bool) -> ([CDecl] -> Bool) -> [CDecl] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CDecl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CDecl] -> Bool) -> [CDecl] -> Bool
forall a b. (a -> b) -> a -> b
$ [CDecl]
fields) Bool -> Bool -> Bool
|| Maybe Ident -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Ident
ide
                     then [CDecl] -> PreCST SwitchBoard (CState GBState) [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl]
fields
                     else do                              -- get the real...
                       Maybe CTag
tag <- Ident -> CT GBState (Maybe CTag)
forall s. Ident -> CT s (Maybe CTag)
findTag (Maybe Ident -> Ident
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Ident
ide)      -- ...definition
                       case Maybe CTag
tag of
                         Just (StructUnionCT CStructUnion
su) -> [CDecl] -> PreCST SwitchBoard (CState GBState) [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return
                                                     (([CDecl], CStructTag) -> [CDecl]
forall a b. (a, b) -> a
fst (([CDecl], CStructTag) -> [CDecl])
-> (CStructUnion -> ([CDecl], CStructTag))
-> CStructUnion
-> [CDecl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStructUnion -> ([CDecl], CStructTag)
structMembers (CStructUnion -> [CDecl]) -> CStructUnion -> [CDecl]
forall a b. (a -> b) -> a -> b
$ CStructUnion
su)
                         Maybe CTag
_                       -> [CDecl] -> PreCST SwitchBoard (CState GBState) [CDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl]
fields
          [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStructPad [CDecl]
fields' CStructTag
tag
  where
    bitSize :: CPrimType -> BitSize
bitSize CPrimType
et | Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0    = Int -> Int -> BitSize
BitSize Int
0  (-Int
sz)   -- size is in bits
               | Bool
otherwise = Int -> Int -> BitSize
BitSize Int
sz Int
0
               where
                 sz :: Int
sz = CPrimType -> Int
size CPrimType
et

-- apply the given alignment constraint at the given offset
--
--  * if the alignment constraint is negative or zero, it is the alignment
--   constraint for a bitfield
--
alignOffset :: BitSize -> Int -> BitSize
alignOffset :: BitSize -> Int -> BitSize
alignOffset offset :: BitSize
offset@(BitSize Int
octetOffset Int
bitOffset) Int
align 
  | Int
align Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
bitOffset Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 =               -- close bitfield first
    BitSize -> Int -> BitSize
alignOffset (Int -> Int -> BitSize
BitSize (Int
octetOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
bitOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8) Int
0) Int
align
  | Int
align Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
bitOffset Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =               -- no bitfields involved
    Int -> Int -> BitSize
BitSize (((Int
octetOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
align Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
align) Int
0
  | Int
bitOffset Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0                              -- start a bitfield
    Bool -> Bool -> Bool
|| Bool
overflowingBitfield      =               -- .. or overflowing bitfield
    BitSize -> Int -> BitSize
alignOffset BitSize
offset Int
bitfieldAlignment
  | Bool
otherwise                   =               -- stays in current bitfield
    BitSize
offset
  where
    bitsPerBitfield :: Int
bitsPerBitfield     = CPrimType -> Int
size CPrimType
CIntPT Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
    overflowingBitfield :: Bool
overflowingBitfield = Int
bitOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
align Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bitsPerBitfield
                                    -- note, `align' is negative


-- constant folding
-- ----------------

-- evaluate a constant expression
--
-- FIXME: this is a bit too simplistic, as the range of expression allowed as
--        constant expression varies depending on the context in which the
--        constant expression occurs
--
evalConstCExpr :: CExpr -> GB ConstResult
evalConstCExpr :: CExpr -> GB ConstResult
evalConstCExpr (CComma [CExpr]
_ Attrs
at) =
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at) String
"a comma expression"
evalConstCExpr (CAssign CAssignOp
_ CExpr
_ CExpr
_ Attrs
at) =
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at) String
"an assignment"
evalConstCExpr (CCond CExpr
b (Just CExpr
t) CExpr
e Attrs
_) =
  do
    ConstResult
bv <- CExpr -> GB ConstResult
evalConstCExpr CExpr
b
    case ConstResult
bv of
      IntResult Integer
bvi  -> if Integer
bvi Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0 then CExpr -> GB ConstResult
evalConstCExpr CExpr
t else CExpr -> GB ConstResult
evalConstCExpr CExpr
e
      FloatResult Float
_ -> Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr (CExpr -> Position
forall a. Pos a => a -> Position
posOf CExpr
b) String
"a float result"
evalConstCExpr (CBinary CBinaryOp
op CExpr
lhs CExpr
rhs Attrs
at) =
  do
    ConstResult
lhsVal <- CExpr -> GB ConstResult
evalConstCExpr CExpr
lhs
    ConstResult
rhsVal <- CExpr -> GB ConstResult
evalConstCExpr CExpr
rhs
    let (ConstResult
lhsVal', ConstResult
rhsVal') = ConstResult -> ConstResult -> (ConstResult, ConstResult)
usualArithConv ConstResult
lhsVal ConstResult
rhsVal
    Position
-> CBinaryOp -> ConstResult -> ConstResult -> GB ConstResult
applyBin (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at) CBinaryOp
op ConstResult
lhsVal' ConstResult
rhsVal'
evalConstCExpr (CCast CDecl
_ CExpr
_ Attrs
_) =
  String -> GB ConstResult
forall a. String -> a
todo String
"GenBind.evalConstCExpr: Casts are not implemented yet."
evalConstCExpr (CUnary CUnaryOp
op CExpr
arg Attrs
at) =
  do
    ConstResult
argVal <- CExpr -> GB ConstResult
evalConstCExpr CExpr
arg
    Position -> CUnaryOp -> ConstResult -> GB ConstResult
applyUnary (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at) CUnaryOp
op ConstResult
argVal
evalConstCExpr (CSizeofExpr CExpr
_ Attrs
_) =
  String -> GB ConstResult
forall a. String -> a
todo String
"GenBind.evalConstCExpr: sizeof not implemented yet."
evalConstCExpr (CSizeofType CDecl
decl Attrs
_) =
  do
    (BitSize
size, Int
_) <- CDecl -> GB (BitSize, Int)
sizeAlignOf CDecl
decl
    ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> (BitSize -> Int) -> BitSize -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitSize -> Int
padBits (BitSize -> Integer) -> BitSize -> Integer
forall a b. (a -> b) -> a -> b
$ BitSize
size)
evalConstCExpr (CAlignofExpr CExpr
_ Attrs
_) =
  String -> GB ConstResult
forall a. String -> a
todo String
"GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet."
evalConstCExpr (CAlignofType CDecl
decl Attrs
_) =
  do
    (BitSize
_, Int
align) <- CDecl -> GB (BitSize, Int)
sizeAlignOf CDecl
decl
    ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
align)
evalConstCExpr (CIndex CExpr
_ CExpr
_ Attrs
at) =
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at) String
"array indexing"
evalConstCExpr (CCall CExpr
_ [CExpr]
_ Attrs
at) =
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at) String
"function call"
evalConstCExpr (CMember CExpr
_ Ident
_ Bool
_ Attrs
at) =
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at) String
"a . or -> operator"
evalConstCExpr (CVar Ident
ide Attrs
at) =
  do
    (CObj
cobj, Ident
_) <- Ident -> Bool -> CT GBState (CObj, Ident)
forall s. Ident -> Bool -> CT s (CObj, Ident)
findValueObj Ident
ide Bool
False
    case CObj
cobj of
      EnumCO Ident
ide (CEnum Maybe Ident
_ [(Ident, Maybe CExpr)]
enumrs Attrs
_) -> (Integer -> ConstResult)
-> PreCST SwitchBoard (CState GBState) Integer -> GB ConstResult
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Integer -> ConstResult
IntResult (PreCST SwitchBoard (CState GBState) Integer -> GB ConstResult)
-> PreCST SwitchBoard (CState GBState) Integer -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ 
                                         Ident
-> [(Ident, Maybe CExpr)]
-> Integer
-> PreCST SwitchBoard (CState GBState) Integer
forall t.
Eq t =>
t
-> [(t, Maybe CExpr)]
-> Integer
-> PreCST SwitchBoard (CState GBState) Integer
enumTagValue Ident
ide [(Ident, Maybe CExpr)]
enumrs Integer
0
      CObj
_                             -> 
        String -> GB ConstResult
forall a. String -> a
todo (String -> GB ConstResult) -> String -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ String
"GenBind.evalConstCExpr: variable names not implemented yet " String -> String -> String
forall a. [a] -> [a] -> [a]
++
               Position -> String
forall a. Show a => a -> String
show (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at)
  where
    -- FIXME: this is not very nice; instead, CTrav should have some support
    --        for determining enum tag values (but then, constant folding needs
    --        to be moved to CTrav, too)
    --
    -- Compute the tag value for `ide' defined in the given enumerator list
    --
    enumTagValue :: t
-> [(t, Maybe CExpr)]
-> Integer
-> PreCST SwitchBoard (CState GBState) Integer
enumTagValue t
_   []                     Integer
_   = 
      String -> PreCST SwitchBoard (CState GBState) Integer
forall a. String -> a
interr String
"GenBind.enumTagValue: enumerator not in declaration"
    enumTagValue t
ide ((t
ide', Maybe CExpr
oexpr):[(t, Maybe CExpr)]
enumrs) Integer
val =
      do
        Integer
val' <- case Maybe CExpr
oexpr of
                  Maybe CExpr
Nothing  -> Integer -> PreCST SwitchBoard (CState GBState) Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
val
                  Just CExpr
exp -> 
                    do
                      ConstResult
val' <- CExpr -> GB ConstResult
evalConstCExpr CExpr
exp
                      case ConstResult
val' of
                        IntResult Integer
val' -> Integer -> PreCST SwitchBoard (CState GBState) Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
val'
                        FloatResult Float
_  ->
                          Position -> String -> PreCST SwitchBoard (CState GBState) Integer
forall a. Position -> String -> GB a
illegalConstExprErr (CExpr -> Position
forall a. Pos a => a -> Position
posOf CExpr
exp) String
"a float result"
        if t
ide t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
ide'
          then                  -- found the right enumerator
            Integer -> PreCST SwitchBoard (CState GBState) Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
val'
          else                  -- continue down the enumerator list
            t
-> [(t, Maybe CExpr)]
-> Integer
-> PreCST SwitchBoard (CState GBState) Integer
enumTagValue t
ide [(t, Maybe CExpr)]
enumrs (Integer
val' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
evalConstCExpr (CConst CConst
c Attrs
_) =
  CConst -> GB ConstResult
evalCConst CConst
c

evalCConst :: CConst -> GB ConstResult
evalCConst :: CConst -> GB ConstResult
evalCConst (CIntConst   Integer
i Attrs
_ ) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult Integer
i
evalCConst (CCharConst  Char
c Attrs
_ ) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c))
evalCConst (CFloatConst String
s Attrs
_ ) = 
  String -> GB ConstResult
forall a. String -> a
todo String
"GenBind.evalCConst: Float conversion from literal misses."
evalCConst (CStrConst   String
s Attrs
at) = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr (Attrs -> Position
forall a. Pos a => a -> Position
posOf Attrs
at) String
"a string constant"

usualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult)
usualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult)
usualArithConv lhs :: ConstResult
lhs@(FloatResult Float
_) ConstResult
rhs                 = (ConstResult
lhs, ConstResult -> ConstResult
toFloat ConstResult
rhs)
usualArithConv ConstResult
lhs                 rhs :: ConstResult
rhs@(FloatResult Float
_) = (ConstResult -> ConstResult
toFloat ConstResult
lhs, ConstResult
rhs)
usualArithConv ConstResult
lhs                 ConstResult
rhs                 = (ConstResult
lhs, ConstResult
rhs)

toFloat :: ConstResult -> ConstResult
toFloat :: ConstResult -> ConstResult
toFloat x :: ConstResult
x@(FloatResult Float
_) = ConstResult
x
toFloat   (IntResult   Integer
i) = Float -> ConstResult
FloatResult (Float -> ConstResult)
-> (Integer -> Float) -> Integer -> ConstResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> ConstResult) -> Integer -> ConstResult
forall a b. (a -> b) -> a -> b
$ Integer
i

applyBin :: Position 
         -> CBinaryOp 
         -> ConstResult 
         -> ConstResult 
         -> GB ConstResult
applyBin :: Position
-> CBinaryOp -> ConstResult -> ConstResult -> GB ConstResult
applyBin Position
cpos CBinaryOp
CMulOp (IntResult   Integer
x) 
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
y)
applyBin Position
cpos CBinaryOp
CMulOp (FloatResult Float
x) 
                     (FloatResult Float
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Float -> ConstResult
FloatResult (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
y)
applyBin Position
cpos CBinaryOp
CDivOp (IntResult   Integer
x) 
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
y)
applyBin Position
cpos CBinaryOp
CDivOp (FloatResult Float
x) 
                     (FloatResult Float
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Float -> ConstResult
FloatResult (Float
x Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
y)
applyBin Position
cpos CBinaryOp
CRmdOp (IntResult   Integer
x) 
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return(ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
y)
applyBin Position
cpos CBinaryOp
CRmdOp (FloatResult Float
x) 
                     (FloatResult Float
y) = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a % operator applied to a float"
applyBin Position
cpos CBinaryOp
CAddOp (IntResult   Integer
x) 
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y)
applyBin Position
cpos CBinaryOp
CAddOp (FloatResult Float
x) 
                     (FloatResult Float
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Float -> ConstResult
FloatResult (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
y)
applyBin Position
cpos CBinaryOp
CSubOp (IntResult   Integer
x) 
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y)
applyBin Position
cpos CBinaryOp
CSubOp (FloatResult Float
x) 
                     (FloatResult Float
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Float -> ConstResult
FloatResult (Float
x Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
y)
applyBin Position
cpos CBinaryOp
CShlOp (IntResult   Integer
x) 
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
y)
applyBin Position
cpos CBinaryOp
CShlOp (FloatResult Float
x) 
                     (FloatResult Float
y) = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a << operator applied to a float"
applyBin Position
cpos CBinaryOp
CShrOp (IntResult   Integer
x) 
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
y)
applyBin Position
cpos CBinaryOp
CShrOp (FloatResult Float
x) 
                     (FloatResult Float
y) = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a >> operator applied to a float"
applyBin Position
cpos CBinaryOp
CAndOp (IntResult   Integer
x)
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
y)
applyBin Position
cpos CBinaryOp
COrOp  (IntResult   Integer
x)
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
y)
applyBin Position
cpos CBinaryOp
CXorOp (IntResult   Integer
x)
                     (IntResult   Integer
y) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
y)
applyBin Position
cpos CBinaryOp
_      (IntResult   Integer
x) 
                     (IntResult   Integer
y) = 
  String -> GB ConstResult
forall a. String -> a
todo String
"GenBind.applyBin: Not yet implemented operator in constant expression."
applyBin Position
cpos CBinaryOp
_      (FloatResult Float
x) 
                     (FloatResult Float
y) = 
  String -> GB ConstResult
forall a. String -> a
todo String
"GenBind.applyBin: Not yet implemented operator in constant expression."
applyBin Position
_    CBinaryOp
_      ConstResult
_ ConstResult
_             = 
  String -> GB ConstResult
forall a. String -> a
interr String
"GenBind.applyBinOp: Illegal combination!"

applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult
applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult
applyUnary Position
cpos CUnaryOp
CPreIncOp  ConstResult
_               = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a ++ operator"
applyUnary Position
cpos CUnaryOp
CPreDecOp  ConstResult
_               = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a -- operator"
applyUnary Position
cpos CUnaryOp
CPostIncOp ConstResult
_               = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a ++ operator"
applyUnary Position
cpos CUnaryOp
CPostDecOp ConstResult
_               = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a -- operator"
applyUnary Position
cpos CUnaryOp
CAdrOp     ConstResult
_               = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a & operator"
applyUnary Position
cpos CUnaryOp
CIndOp     ConstResult
_               = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a * operator"
applyUnary Position
cpos CUnaryOp
CPlusOp    ConstResult
arg             = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return ConstResult
arg
applyUnary Position
cpos CUnaryOp
CMinOp     (IntResult   Integer
x) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> ConstResult
IntResult (-Integer
x))
applyUnary Position
cpos CUnaryOp
CMinOp     (FloatResult Float
x) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> ConstResult
FloatResult (-Float
x))
applyUnary Position
cpos CUnaryOp
CCompOp    (IntResult   Integer
x) = ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> ConstResult
IntResult (Integer -> Integer
forall a. Bits a => a -> a
complement Integer
x))
applyUnary Position
cpos CUnaryOp
CNegOp     (IntResult   Integer
x) = 
  let r :: Integer
r = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (Bool -> Int) -> Bool -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Bool -> Integer) -> Bool -> Integer
forall a b. (a -> b) -> a -> b
$ (Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0)
  in ConstResult -> GB ConstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> ConstResult
IntResult Integer
r)
applyUnary Position
cpos CUnaryOp
CNegOp     (FloatResult Float
_) = 
  Position -> String -> GB ConstResult
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"! applied to a float"


-- auxilliary functions
-- --------------------

-- create an identifier without position information
--
noPosIdent :: String -> Ident
noPosIdent :: String -> Ident
noPosIdent  = Position -> String -> Ident
onlyPosIdent Position
nopos

-- print trace message
--
traceGenBind :: String -> GB ()
traceGenBind :: String -> CST (CState GBState) ()
traceGenBind  = (Traces -> Bool) -> String -> CST (CState GBState) ()
forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
traceGenBindSW

-- generic lookup
--
lookupBy      :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
lookupBy a -> a -> Bool
eq a
x  = ((a, b) -> b) -> Maybe (a, b) -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> b
forall a b. (a, b) -> b
snd (Maybe (a, b) -> Maybe b)
-> ([(a, b)] -> Maybe (a, b)) -> [(a, b)] -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> Bool) -> [(a, b)] -> Maybe (a, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (a -> a -> Bool
eq a
x (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst)

-- maps some monad operation into a `Maybe', discarding the result
--
mapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ :: (a -> m b) -> Maybe a -> m ()
mapMaybeM_ a -> m b
m Maybe a
Nothing   =        () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mapMaybeM_ a -> m b
m (Just a
a)  = a -> m b
m a
a m b -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


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

unknownFieldErr          :: Position -> Ident -> GB a
unknownFieldErr :: Position -> Ident -> GB a
unknownFieldErr Position
cpos 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 member name!",
     String
"The structure has no member called `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide 
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'.  The structure is defined at",
     Position -> String
forall a. Show a => a -> String
show Position
cpos String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."]

illegalStructUnionErr          :: Position -> Position -> GB a
illegalStructUnionErr :: Position -> Position -> GB a
illegalStructUnionErr Position
cpos Position
pos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos 
    [String
"Illegal structure or union type!",
     String
"There is not automatic support for marshaling of structures and",
     String
"unions; the offending type is declared at "
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show Position
cpos String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."]

illegalTypeSpecErr      :: Position -> GB a
illegalTypeSpecErr :: Position -> GB a
illegalTypeSpecErr Position
cpos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos 
    [String
"Illegal type!",
     String
"The type specifiers of this declaration do not form a legal ANSI C(89) \
     \type."
    ]

unsupportedTypeSpecErr      :: Position -> GB a
unsupportedTypeSpecErr :: Position -> GB a
unsupportedTypeSpecErr Position
cpos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos 
    [String
"Unsupported type!",
     String
"The type specifier of this declaration is not supported by your C \
     \compiler."
    ]

variadicErr          :: Position -> Position -> GB a
variadicErr :: Position -> Position -> GB a
variadicErr Position
pos Position
cpos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos 
    [String
"Variadic function!",
     String
"Calling variadic functions is not supported by the FFI; the function",
     String
"is defined at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Position -> String
forall a. Show a => a -> String
show Position
cpos String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."]

illegalConstExprErr           :: Position -> String -> GB a
illegalConstExprErr :: Position -> String -> GB a
illegalConstExprErr Position
cpos String
hint  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos [String
"Illegal constant expression!",
                        String
"Encountered " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hint String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in a constant expression,",
                        String
"which ANSI C89 does not permit."]

voidFieldErr      :: Position -> GB a
voidFieldErr :: Position -> GB a
voidFieldErr Position
cpos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos [String
"Void field in struct!",
                        String
"Attempt to access a structure field of type void."]

structExpectedErr     :: Ident -> GB a
structExpectedErr :: Ident -> GB a
structExpectedErr 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 structure or union!",
     String
"Attempt to access member `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' in something not",
     String
"a structure or union."]

ptrExpectedErr     :: Position -> GB a
ptrExpectedErr :: Position -> GB a
ptrExpectedErr Position
pos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
    [String
"Expected a pointer object!",
     String
"Attempt to dereference a non-pointer object or to use it in a `pointer' \
     \hook."]

illegalStablePtrErr     :: Position -> GB a
illegalStablePtrErr :: Position -> GB a
illegalStablePtrErr Position
pos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
    [String
"Illegal use of a stable pointer!",
     String
"Class hooks cannot be used for stable pointers."]

pointerTypeMismatchErr :: Position -> String -> String -> GB a
pointerTypeMismatchErr :: Position -> String -> String -> GB a
pointerTypeMismatchErr Position
pos String
className String
superName =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
    [String
"Pointer type mismatch!",
     String
"The pointer of the class hook for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
className 
     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is of a different kind",
     String
"than that of the class hook for `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
superName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'; this is illegal",
     String
"as the latter is defined to be an (indirect) superclass of the former."]

illegalFieldSizeErr      :: Position -> GB a
illegalFieldSizeErr :: Position -> GB a
illegalFieldSizeErr Position
cpos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos 
    [String
"Illegal field size!",
     String
"Only signed and unsigned `int' types may have a size annotation."]

derefBitfieldErr      :: Position -> GB a
derefBitfieldErr :: Position -> GB a
derefBitfieldErr Position
pos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos 
    [String
"Illegal dereferencing of a bit field!",
     String
"Bit fields cannot be dereferenced."]

resMarshIllegalInErr     :: Position -> GB a
resMarshIllegalInErr :: Position -> GB a
resMarshIllegalInErr Position
pos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos 
    [String
"Malformed result marshalling!",
     String
"There may not be an \"in\" marshaller for the result."]

resMarshIllegalTwoCValErr     :: Position -> GB a
resMarshIllegalTwoCValErr :: Position -> GB a
resMarshIllegalTwoCValErr Position
pos  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos 
    [String
"Malformed result marshalling!",
     String
"Two C values (i.e., the `&' symbol) are not allowed for the result."]

marshArgMismatchErr            :: Position -> String -> GB a
marshArgMismatchErr :: Position -> String -> GB a
marshArgMismatchErr Position
pos String
reason  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
    [String
"Function arity mismatch!",
     String
reason]

noDftMarshErr :: Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr :: Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr Position
pos String
inOut String
hsTy [ExtType]
cTys  =
  Position -> [String] -> GB a
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
    [String
"Missing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inOut String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" marshaller!",
     String
"There is no default marshaller for this combination of Haskell and \
     \C type:",
     String
"Haskell type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hsTy,
     String
"C type      : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
" " ((ExtType -> String) -> [ExtType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ExtType -> String
showExtType [ExtType]
cTys))]