    --  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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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 :: forall s. 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 a. a -> PreCST SwitchBoard s a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [CHSFrag
    verb]
    expandFrag line :: CHSFrag
    line@(CHSLine Position
    _       ) = [CHSFrag] -> GB [CHSFrag]
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [CHSFrag
    line]
    expandFrag prag :: CHSFrag
    prag@(CHSLang [String]
    _ Position
    _     ) = [CHSFrag] -> GB [CHSFrag]
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 -> GB (Maybe String)
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe String
    forall a. Maybe a
    Nothing else GB (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 -> GB (Maybe String)
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe String
    forall a. Maybe a
    Nothing else GB (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 a. 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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. [a] -> 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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. [a] -> 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 Integer
    m Attrs
    _) Attrs
    _) -> Integer
    m
                  Just CExpr
    _ -> 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. HasCallStack => [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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. [a] -> 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 {p}.
    Show p =>
    p -> 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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. [a] -> 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 :: p -> CHSParm -> (String, String, String, String, String)
    marshArg p
    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]
    ++ p -> String
    forall a. Show a => a -> String
    show p
    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 p
    _ 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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> m a
    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 a. a -> m a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. [a] -> 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. HasCallStack => [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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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!"
                                    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
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (Position -> CDecl -> GB ExtType
    extractSimpleType Position
    pos) [CDecl]
    args

        ([Maybe HsPtrRep], ExtType) -> GB ([Maybe HsPtrRep], ExtType)
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Maybe HsPtrRep]
    foreignSyn, (ExtType -> ExtType -> ExtType) -> ExtType -> [ExtType] -> ExtType
    forall a b. (a -> b -> b) -> b -> [a] -> b
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ExtType
    et
        SUType  CStructUnion
    _  -> ExtType -> GB ExtType
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. [a] -> 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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard s a
    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 a. a -> PreCST SwitchBoard s a
    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 a. a -> PreCST SwitchBoard s a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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
    $c== :: BitSize -> BitSize -> Bool
    == :: BitSize -> BitSize -> Bool
    $c/= :: BitSize -> BitSize -> Bool
    /= :: 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
    $cshowsPrec :: Int -> BitSize -> String -> String
    showsPrec :: Int -> BitSize -> String -> String
    $cshow :: BitSize -> String
    show :: BitSize -> String
    $cshowList :: [BitSize] -> String -> String
    showList :: [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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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. HasCallStack => [a] -> [a]
    init [CDecl]
    decls) CStructTag
    CStructTag
        (BitSize
    size, Int
    align)      <- CDecl -> GB (BitSize, Int)
    sizeAlignOf       ([CDecl] -> CDecl
    forall a. HasCallStack => [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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([BitSize] -> BitSize
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum [BitSize]
    sizes, [Int] -> Int
    forall a. Ord a => [a] -> a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. [a] -> 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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ConstResult
    arg
    applyUnary Position
    cpos CUnaryOp
    CMinOp     (IntResult   Integer
    x) = ConstResult -> GB ConstResult
    forall a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 a. a -> PreCST SwitchBoard (CState GBState) a
    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 :: forall a b. (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
    lookupBy a -> a -> Bool
    eq a
    x  = ((a, b) -> b) -> Maybe (a, b) -> Maybe b
    forall a b. (a -> b) -> Maybe a -> 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_ :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
    mapMaybeM_ a -> m b
    m Maybe a
    Nothing   =        () -> m ()
    forall a. a -> m a
    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 a b. m a -> m b -> m b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> () -> m ()
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

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

    unknownFieldErr          :: Position -> Ident -> GB a
    unknownFieldErr :: forall a. Position -> Ident -> GB a
    unknownFieldErr Position
    cpos Ident
    ide  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> Position -> GB a
    illegalStructUnionErr Position
    cpos Position
    pos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> GB a
    illegalTypeSpecErr Position
    cpos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> GB a
    unsupportedTypeSpecErr Position
    cpos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> Position -> GB a
    variadicErr Position
    pos Position
    cpos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> String -> GB a
    illegalConstExprErr Position
    cpos String
    hint  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> GB a
    voidFieldErr Position
    cpos  =
      Position -> [String] -> CT GBState 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 :: forall a. Ident -> GB a
    structExpectedErr Ident
    ide  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> GB a
    ptrExpectedErr Position
    pos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> GB a
    illegalStablePtrErr Position
    pos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> String -> String -> GB a
    pointerTypeMismatchErr Position
    pos String
    className String
    superName =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> GB a
    illegalFieldSizeErr Position
    cpos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> GB a
    derefBitfieldErr Position
    pos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> GB a
    resMarshIllegalInErr Position
    pos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> GB a
    resMarshIllegalTwoCValErr Position
    pos  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> String -> GB a
    marshArgMismatchErr Position
    pos String
    reason  =
      Position -> [String] -> CT GBState 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 :: forall a. Position -> String -> String -> [ExtType] -> GB a
    noDftMarshErr Position
    pos String
    inOut String
    hsTy [ExtType]
    cTys  =
      Position -> [String] -> CT GBState 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))]