    --  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 "Bool"   [PrimET pt :: CPrimType
    pt] | CPrimType -> Bool
    isIntegralCPrimType CPrimType
    pt =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
    -> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall a b. (a -> b) -> a -> b
    $ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (Ident
    cFromBoolIde, CHSArg
    CHSValArg)
    lookupDftMarshIn hsTy :: String
    hsTy     [PrimET pt :: CPrimType
    pt] | String -> Bool
    isIntegralHsType String
    hsTy
                                          Bool -> Bool -> Bool
    &&CPrimType -> Bool
    isIntegralCPrimType CPrimType
    pt =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
    -> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall a b. (a -> b) -> a -> b
    $ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (Ident
    cIntConvIde, CHSArg
    CHSValArg)
    lookupDftMarshIn hsTy :: String
    hsTy     [PrimET pt :: CPrimType
    pt] | String -> Bool
    isFloatHsType String
    hsTy
                                          Bool -> Bool -> Bool
    &&CPrimType -> Bool
    isFloatCPrimType CPrimType
    pt    =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
    -> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall a b. (a -> b) -> a -> b
    $ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (Ident
    cFloatConvIde, CHSArg
    CHSValArg)
    lookupDftMarshIn "String" [PtrET (PrimET CCharPT)]             =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
    -> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall a b. (a -> b) -> a -> b
    $ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (Ident
    withCStringIde, CHSArg
    CHSIOArg)
    lookupDftMarshIn "String" [PtrET (PrimET CCharPT), PrimET pt :: CPrimType
    pt]
      | CPrimType -> Bool
    isIntegralCPrimType CPrimType
    pt                                     =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
    -> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall a b. (a -> b) -> a -> b
    $ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (Ident
    withCStringLenIde, CHSArg
    CHSIOArg)
    lookupDftMarshIn hsTy :: String
    hsTy     [PtrET ty :: ExtType
    ty]  | ExtType -> String
    showExtType ExtType
    ty String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    hsTy =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
    -> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall a b. (a -> b) -> a -> b
    $ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (Ident
    withIde, CHSArg
    CHSIOArg)
    lookupDftMarshIn hsTy :: String
    hsTy     [PtrET (PrimET pt :: CPrimType
    pt)]
      | String -> Bool
    isIntegralHsType String
    hsTy Bool -> Bool -> Bool
    && CPrimType -> Bool
    isIntegralCPrimType CPrimType
    pt            =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
    -> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall a b. (a -> b) -> a -> b
    $ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (Ident
    withIntConvIde, CHSArg
    CHSIOArg)
    lookupDftMarshIn hsTy :: String
    hsTy     [PtrET (PrimET pt :: CPrimType
    pt)]
      | String -> Bool
    isFloatHsType String
    hsTy Bool -> Bool -> Bool
    && CPrimType -> Bool
    isFloatCPrimType CPrimType
    pt                  =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
    -> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall a b. (a -> b) -> a -> b
    $ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (Ident
    withFloatConvIde, CHSArg
    CHSIOArg)
    lookupDftMarshIn "Bool"   [PtrET (PrimET pt :: CPrimType
    pt)]
      | CPrimType -> Bool
    isIntegralCPrimType CPrimType
    pt                                     =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg)))
    -> Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall a b. (a -> b) -> a -> b
    $ (Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (Ident
    withFromBoolIde, CHSArg
    CHSIOArg)
    -- FIXME: handle array-list conversion
    lookupDftMarshIn _        _                                    =
      Maybe (Ident, CHSArg) -> GB (Maybe (Ident, CHSArg))
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Ident, CHSArg)
    forall a. Maybe a
    Nothing

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

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

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

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

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

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

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

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

    expandModule                   :: CHSModule -> GB (CHSModule, String, String)
    expandModule :: CHSModule -> CT GBState (CHSModule, String, String)
    expandModule (CHSModule frags :: [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 ("Errors during expansion of binding hooks:\n\n"   -- fatal error
                   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    errmsgs)
          else do
            CST (CState GBState) ()
    forall s. CST s ()
    traceInfoOK
            String
    warnmsgs <- GB String
    forall e s. PreCST e s String
    showErrors
            (CHSModule, String, String)
    -> CT GBState (CHSModule, String, String)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([CHSFrag] -> CHSModule
    CHSModule ([CHSFrag]
    frags' [CHSFrag] -> [CHSFrag] -> [CHSFrag]
    forall a. [a] -> [a] -> [a]
    ++ [CHSFrag]
    delayedFrags), String
    chi, String
    warnmsgs)
      where
        traceInfoExpand :: CST s ()
    traceInfoExpand = (Traces -> Bool) -> String -> CST s ()
    forall s. (Traces -> Bool) -> String -> CST s ()
    putTraceStr Traces -> Bool
    tracePhasesSW
                            ("...expanding binding hooks...\n")
        traceInfoErr :: CST s ()
    traceInfoErr    = (Traces -> Bool) -> String -> CST s ()
    forall s. (Traces -> Bool) -> String -> CST s ()
    putTraceStr Traces -> Bool
    tracePhasesSW
                            ("...error(s) detected.\n")
        traceInfoOK :: CST s ()
    traceInfoOK     = (Traces -> Bool) -> String -> CST s ()
    forall s. (Traces -> Bool) -> String -> CST s ()
    putTraceStr Traces -> Bool
    tracePhasesSW
                            ("...successfully completed.\n")

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

    expandFrag :: CHSFrag -> GB [CHSFrag]
    expandFrag :: CHSFrag -> GB [CHSFrag]
    expandFrag verb :: CHSFrag
    verb@(CHSVerb _ _     ) = [CHSFrag] -> GB [CHSFrag]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [CHSFrag
    verb]
    expandFrag line :: CHSFrag
    line@(CHSLine _       ) = [CHSFrag] -> GB [CHSFrag]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [CHSFrag
    line]
    expandFrag prag :: CHSFrag
    prag@(CHSLang _ _     ) = [CHSFrag] -> GB [CHSFrag]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [CHSFrag
    prag]
    expandFrag      (CHSHook h :: CHSHook
    h       ) =
      do
        String
    code <- CHSHook -> GB String
    expandHook CHSHook
    h
        [CHSFrag] -> GB [CHSFrag]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [String -> Position -> CHSFrag
    CHSVerb String
    code Position
    builtinPos]
      GB [CHSFrag] -> GB [CHSFrag] -> GB [CHSFrag]
    forall s a. CT s a -> CT s a -> CT s a
    `ifCTExc` [CHSFrag] -> GB [CHSFrag]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [String -> Position -> CHSFrag
    CHSVerb "** ERROR **" Position
    builtinPos]
    expandFrag      (CHSCPP  s :: String
    s _     ) =
      String -> GB [CHSFrag]
    forall a. String -> a
    interr (String -> GB [CHSFrag]) -> String -> GB [CHSFrag]
    forall a b. (a -> b) -> a -> b
    $ "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]
    ++ "\n---"
    expandFrag      (CHSC    s :: String
    s _     ) =
      String -> GB [CHSFrag]
    forall a. String -> a
    interr (String -> GB [CHSFrag]) -> String -> GB [CHSFrag]
    forall a b. (a -> b) -> a -> b
    $ "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]
    ++ "\n---"
    expandFrag      (CHSCond alts :: [(Ident, [CHSFrag])]
    alts dft :: 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 ((ide :: Ident
    ide, frags :: [CHSFrag]
    frags):alts :: [(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 "** CPP conditional:\n"
        traceInfoVal :: Ident -> Maybe a -> CST (CState GBState) ()
    traceInfoVal ide :: Ident
    ide oobj :: 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]
    ++ " is " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                  (if Maybe a -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe a
    oobj then "not " else "") String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                  "defined.\n"
        traceInfoDft :: Maybe a -> CST (CState GBState) ()
    traceInfoDft dft :: Maybe a
    dft      = if Maybe a -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe a
    dft
                                then
                                  () -> CST (CState GBState) ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                                else
                                  String -> CST (CState GBState) ()
    traceGenBind "Choosing else branch.\n"

    expandHook :: CHSHook -> GB String
    expandHook :: CHSHook -> GB String
    expandHook (CHSImport qual :: Bool
    qual ide :: Ident
    ide chi :: String
    chi _) =
      do
        String -> CST (CState GBState) ()
    mergeMaps String
    chi
        String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $
          "import " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (if Bool
    qual then "qualified " else "") String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Ident -> String
    identToLexeme Ident
    ide
    expandHook (CHSContext olib :: Maybe String
    olib oprefix :: Maybe String
    oprefix olock :: Maybe String
    olock _) =
      do
        Maybe String
    -> Maybe String -> Maybe String -> CST (CState GBState) ()
    setContext Maybe String
    olib Maybe String
    oprefix Maybe String
    olock              -- enter context information
        (String -> CST (CState GBState) ())
    -> Maybe String -> CST (CState GBState) ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
    mapMaybeM_ String -> CST (CState GBState) ()
    forall s. String -> CT s ()
    applyPrefixToNameSpaces Maybe String
    oprefix -- use the prefix on name spaces
        String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return ""
    expandHook (CHSType ide :: Ident
    ide pos :: Position
    pos) =
      do
        CST (CState GBState) ()
    traceInfoType
        CDecl
    decl <- Ident -> Bool -> Bool -> CT GBState CDecl
    forall s. Ident -> Bool -> Bool -> CT s CDecl
    findAndChaseDecl Ident
    ide Bool
    False Bool
    True     -- no indirection, but shadows
        ExtType
    ty <- Position -> CDecl -> GB ExtType
    extractSimpleType Position
    pos CDecl
    decl
        CDecl -> ExtType -> CST (CState GBState) ()
    forall a. Show a => a -> ExtType -> CST (CState GBState) ()
    traceInfoDump CDecl
    decl ExtType
    ty
        String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ExtType -> String
    showExtType ExtType
    ty String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
      where
        traceInfoType :: CST (CState GBState) ()
    traceInfoType         = String -> CST (CState GBState) ()
    traceGenBind "** Type hook:\n"
        traceInfoDump :: a -> ExtType -> CST (CState GBState) ()
    traceInfoDump decl :: a
    decl ty :: ExtType
    ty = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "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]
    ++ "\ntranslates to\n"
          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ExtType -> String
    showExtType ExtType
    ty String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n"
    expandHook (CHSSizeof ide :: Ident
    ide pos :: 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
        (size :: BitSize
    size, _) <- CDecl -> GB (BitSize, Int)
    sizeAlignOf CDecl
    decl
        CDecl -> BitSize -> CST (CState GBState) ()
    forall a. Show a => a -> BitSize -> CST (CState GBState) ()
    traceInfoDump CDecl
    decl BitSize
    size
        String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ Integer -> String
    forall a. Show a => a -> String
    show (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Integer) -> (BitSize -> Int) -> BitSize -> Integer
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BitSize -> Int
    padBits (BitSize -> Integer) -> BitSize -> Integer
    forall a b. (a -> b) -> a -> b
    $ BitSize
    size)
      where
        traceInfoSizeof :: CST (CState GBState) ()
    traceInfoSizeof         = String -> CST (CState GBState) ()
    traceGenBind "** Sizeof hook:\n"
        traceInfoDump :: a -> BitSize -> CST (CState GBState) ()
    traceInfoDump decl :: a
    decl size :: BitSize
    size = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "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]
    ++ "\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]
    ++ "\n"
    expandHook (CHSEnum cide :: Ident
    cide oalias :: Maybe Ident
    oalias chsTrans :: CHSTrans
    chsTrans oprefix :: Maybe String
    oprefix derive :: [Ident]
    derive _) =
      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 isPure :: Bool
    isPure isUns :: Bool
    isUns isNol :: Bool
    isNol ide :: Ident
    ide oalias :: Maybe Ident
    oalias pos :: 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
    cdecl, ide :: Ident
    ide) <- Ident -> Bool -> CT GBState (CObj, Ident)
    forall s. Ident -> Bool -> CT s (CObj, Ident)
    findFunObj Ident
    ide Bool
    True
        Maybe String
    mLock <- if Bool
    isNol then Maybe String -> PreCST SwitchBoard (CState GBState) (Maybe String)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe String
    forall a. Maybe a
    Nothing else PreCST SwitchBoard (CState GBState) (Maybe String)
    getLock
        let ideLexeme :: String
    ideLexeme = Ident -> String
    identToLexeme Ident
    ide  -- orignal name might have been a shadow
            hsLexeme :: String
    hsLexeme  = String
    ideLexeme String -> (Ident -> String) -> Maybe Ident -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    `maybe` Ident -> String
    identToLexeme (Maybe Ident -> String) -> Maybe Ident -> String
    forall a b. (a -> b) -> a -> b
    $ Maybe Ident
    oalias
            cdecl' :: CDecl
    cdecl'    = Ident
    ide Ident -> CDecl -> CDecl
    `simplifyDecl` CDecl
    cdecl
        CHSHook
    -> Bool
    -> Bool
    -> Maybe String
    -> String
    -> String
    -> CDecl
    -> Position
    -> GB String
    callImport CHSHook
    hook Bool
    isPure Bool
    isUns Maybe String
    mLock String
    ideLexeme String
    hsLexeme CDecl
    cdecl' Position
    pos
      where
        traceEnter :: CST (CState GBState) ()
    traceEnter = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "** Call hook for `" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Ident -> String
    identToLexeme Ident
    ide String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "':\n"
    expandHook hook :: CHSHook
    hook@(CHSFun isPure :: Bool
    isPure isUns :: Bool
    isUns isNol :: Bool
    isNol ide :: Ident
    ide oalias :: Maybe Ident
    oalias ctxt :: Maybe String
    ctxt parms :: [CHSParm]
    parms parm :: CHSParm
    parm pos :: 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
    cdecl, cide :: Ident
    cide) <- Ident -> Bool -> CT GBState (CObj, Ident)
    forall s. Ident -> Bool -> CT s (CObj, Ident)
    findFunObj Ident
    ide Bool
    True
        Maybe String
    mLock <- if Bool
    isNol then Maybe String -> PreCST SwitchBoard (CState GBState) (Maybe String)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe String
    forall a. Maybe a
    Nothing else PreCST SwitchBoard (CState GBState) (Maybe String)
    getLock
        let ideLexeme :: String
    ideLexeme = Ident -> String
    identToLexeme Ident
    ide  -- orignal name might have been a shadow
            hsLexeme :: String
    hsLexeme  = String
    ideLexeme String -> (Ident -> String) -> Maybe Ident -> String
    forall b a. b -> (a -> b) -> Maybe a -> b
    `maybe` Ident -> String
    identToLexeme (Maybe Ident -> String) -> Maybe Ident -> String
    forall a b. (a -> b) -> a -> b
    $ Maybe Ident
    oalias
            fiLexeme :: String
    fiLexeme  = String
    hsLexeme String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'_"   --  *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
    $
          "** Fun hook for `" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Ident -> String
    identToLexeme Ident
    ide String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "':\n"
    expandHook (CHSField access :: CHSAccess
    access path :: CHSAPath
    path pos :: Position
    pos) =
      do
        CST (CState GBState) ()
    traceInfoField
        (decl :: CDecl
    decl, offsets :: [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
                               CHSGet -> "Get"
                               CHSSet -> "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
    forall a. [a] -> [a] -> [a]
    ++ String
    accessString String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " hook:\n"
        traceDepth :: t a -> CST (CState GBState) ()
    traceDepth offsets :: t a
    offsets = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $ "Depth of access path: "
                                            String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show (t a -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length t a
    offsets) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n"
        traceValueType :: ExtType -> CST (CState GBState) ()
    traceValueType et :: ExtType
    et  = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "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]
    ++ "\n"
    expandHook (CHSPointer isStar :: Bool
    isStar cName :: Ident
    cName oalias :: Maybe Ident
    oalias ptrKind :: CHSPtrType
    ptrKind isNewtype :: Bool
    isNewtype oRefType :: Maybe Ident
    oRefType pos :: 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
    cdecl -> do                          -- found a typedef declaration
            Ident
    cNameFull <- case CDecl -> Maybe Ident
    declaredName CDecl
    cdecl of
                           Just ide :: Ident
    ide -> Ident -> PreCST SwitchBoard (CState GBState) Ident
    forall (m :: * -> *) a. Monad m => a -> m a
    return Ident
    ide
                           Nothing  -> String -> PreCST SwitchBoard (CState GBState) Ident
    forall a. String -> a
    interr
                                         "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 "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)
            (hsType :: String
    hsType, isFun :: Bool
    isFun) <-
              case Maybe Ident
    oRefType of
                Nothing     -> do
                                 CDecl
    cDecl <- Ident -> Bool -> CT GBState CDecl
    forall s. Ident -> Bool -> CT s CDecl
    chaseDecl Ident
    cNameFull (Bool -> Bool
    not Bool
    isStar)
                                 ExtType
    et    <- CDecl -> GB ExtType
    extractPtrType CDecl
    cDecl
                                 let et' :: ExtType
    et' = Bool -> ExtType -> ExtType
    adjustPtr Bool
    isStar ExtType
    et
                                 (String, Bool)
    -> PreCST SwitchBoard (CState GBState) (String, Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ExtType -> String
    showExtType ExtType
    et', ExtType -> Bool
    isFunExtType ExtType
    et')
                Just hsType :: Ident
    hsType -> (String, Bool)
    -> PreCST SwitchBoard (CState GBState) (String, Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Ident -> String
    identToLexeme Ident
    hsType, Bool
    False)
                -- FIXME: it is not possible to determine whether `hsType'
                --   is a function; we would need to extend the syntax to
                --   allow `... -> fun HSTYPE' to explicitly mark function
                --   types if this ever becomes important
            String -> String -> CST (CState GBState) ()
    traceInfoHsType String
    hsName String
    hsType
            Ident
    realCName <- (Maybe (CObj, Ident) -> Ident)
    -> PreCST SwitchBoard (CState GBState) (Maybe (CObj, Ident))
    -> PreCST SwitchBoard (CState GBState) Ident
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM (Ident -> ((CObj, Ident) -> Ident) -> Maybe (CObj, Ident) -> Ident
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Ident
    cName (CObj, Ident) -> Ident
    forall a b. (a, b) -> b
    snd) (PreCST SwitchBoard (CState GBState) (Maybe (CObj, Ident))
     -> PreCST SwitchBoard (CState GBState) Ident)
    -> PreCST SwitchBoard (CState GBState) (Maybe (CObj, Ident))
    -> PreCST SwitchBoard (CState GBState) Ident
    forall a b. (a -> b) -> a -> b
    $ Ident -> PreCST SwitchBoard (CState GBState) (Maybe (CObj, Ident))
    forall s. Ident -> CT s (Maybe (CObj, Ident))
    findObjShadow Ident
    cName
            Bool
    -> Ident
    -> String
    -> CHSPtrType
    -> Bool
    -> String
    -> Bool
    -> GB String
    pointerDef Bool
    isStar Ident
    realCName String
    hsName CHSPtrType
    ptrKind Bool
    isNewtype String
    hsType Bool
    isFun
          Right tag :: CTag
    tag -> do                           -- found a tag definition
            let cNameFull :: Ident
    cNameFull = CTag -> Ident
    tagName CTag
    tag
            String -> Ident -> CST (CState GBState) ()
    traceInfoCName "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
                           Nothing     -> "()"
                           Just hsType :: 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 True  et :: ExtType
    et         = ExtType
    et
        adjustPtr False (PtrET et :: ExtType
    et) = ExtType
    et
        adjustPtr _     _          = String -> ExtType
    forall a. String -> a
    interr "GenBind.adjustPtr: Where is the Ptr?"
        --
        traceInfoPointer :: CST (CState GBState) ()
    traceInfoPointer        = String -> CST (CState GBState) ()
    traceGenBind "** Pointer hook:\n"
        traceInfoCName :: String -> Ident -> CST (CState GBState) ()
    traceInfoCName kind :: String
    kind ide :: Ident
    ide = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "found C " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    kind String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " for `" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Ident -> String
    identToLexeme Ident
    ide String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'\n"
        traceInfoHsType :: String -> String -> CST (CState GBState) ()
    traceInfoHsType name :: String
    name ty :: String
    ty = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "associated with Haskell entity `" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'\nhaving type " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ty
          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n"
    expandHook (CHSClass oclassIde :: Maybe Ident
    oclassIde classIde :: Ident
    classIde typeIde :: Ident
    typeIde pos :: 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 ptrType :: CHSPtrType
    ptrType isNewtype :: 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 Nothing     = [(String, String, HsObject)] -> GB [(String, String, HsObject)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
        collectClasses (Just ide :: Ident
    ide)  =
          do
            Class oclassIde :: Maybe Ident
    oclassIde typeIde :: Ident
    typeIde <- Ident -> GB HsObject
    queryClass Ident
    ide
            HsObject
    ptr                     <- Ident -> GB HsObject
    queryPointer Ident
    typeIde
            [(String, String, HsObject)]
    classes                 <- Maybe Ident -> GB [(String, String, HsObject)]
    collectClasses Maybe Ident
    oclassIde
            [(String, String, HsObject)] -> GB [(String, String, HsObject)]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([(String, String, HsObject)] -> GB [(String, String, HsObject)])
    -> [(String, String, HsObject)] -> GB [(String, String, HsObject)]
    forall a b. (a -> b) -> a -> b
    $ (Ident -> String
    identToLexeme Ident
    ide, Ident -> String
    identToLexeme Ident
    typeIde, HsObject
    ptr) (String, String, HsObject)
    -> [(String, String, HsObject)] -> [(String, String, HsObject)]
    forall a. a -> [a] -> [a]
    : [(String, String, HsObject)]
    classes
        --
        traceInfoClass :: CST (CState GBState) ()
    traceInfoClass = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $ "** 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 _ list :: [(Ident, Maybe CExpr)]
    list _) hident :: String
    hident trans :: Ident -> String
    trans userDerive :: [String]
    userDerive =
      do
        (list' :: [(Ident, Maybe CExpr)]
    list', enumAuto :: 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) | (ide :: Ident
    ide, cexpr :: Maybe CExpr
    cexpr) <-  [(Ident, Maybe CExpr)]
    list']  -- translate
            defHead :: String
    defHead  = String -> String
    enumHead String
    hident
            defBody :: String
    defBody  = Int -> [(String, Maybe CExpr)] -> String
    enumBody (String -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    defHead Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - 2) [(String, Maybe CExpr)]
    enumVals
            inst :: String
    inst     = [String] -> String
    makeDerives
                       (if Bool
    enumAuto then "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 "\n" else "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> [(String, Maybe CExpr)] -> String
    enumInst String
    hident [(String, Maybe CExpr)]
    enumVals
        String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ String
    defHead String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    defBody String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    inst
      where
        cpos :: Position
    cpos = CEnum -> Position
    forall a. Pos a => a -> Position
    posOf CEnum
    cenum
        --
        evalTagVals :: [(a, Maybe CExpr)]
    -> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
    evalTagVals []                     = ([(a, Maybe CExpr)], Bool)
    -> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], Bool
    True)
        evalTagVals ((ide :: a
    ide, Nothing ):list :: [(a, Maybe CExpr)]
    list) =
          do
            (list' :: [(a, Maybe CExpr)]
    list', derived :: Bool
    derived) <- [(a, Maybe CExpr)]
    -> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
    evalTagVals [(a, Maybe CExpr)]
    list
            ([(a, Maybe CExpr)], Bool)
    -> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((a
    ide, Maybe CExpr
    forall a. Maybe a
    Nothing)(a, Maybe CExpr) -> [(a, Maybe CExpr)] -> [(a, Maybe CExpr)]
    forall a. a -> [a] -> [a]
    :[(a, Maybe CExpr)]
    list', Bool
    derived)
        evalTagVals ((ide :: a
    ide, Just exp :: CExpr
    exp):list :: [(a, Maybe CExpr)]
    list) =
          do
            (list' :: [(a, Maybe CExpr)]
    list', derived :: 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 val' :: Integer
    val' ->
                ([(a, Maybe CExpr)], Bool)
    -> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((a
    ide, CExpr -> Maybe CExpr
    forall a. a -> Maybe a
    Just (CExpr -> Maybe CExpr) -> CExpr -> Maybe CExpr
    forall a b. (a -> b) -> a -> b
    $ CConst -> Attrs -> CExpr
    CConst (Integer -> Attrs -> CConst
    CIntConst Integer
    val' Attrs
    at1) Attrs
    at2)(a, Maybe CExpr) -> [(a, Maybe CExpr)] -> [(a, Maybe CExpr)]
    forall a. a -> [a] -> [a]
    :[(a, Maybe CExpr)]
    list',
                        Bool
    False)
              FloatResult _ ->
                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) "a float result"
          where
            at1 :: Attrs
    at1 = Position -> Attrs
    newAttrsOnlyPos Position
    nopos
            at2 :: Attrs
    at2 = Position -> Attrs
    newAttrsOnlyPos Position
    nopos
        makeDerives :: [String] -> String
    makeDerives [] = ""
        makeDerives dList :: [String]
    dList = "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]
    dList) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++")"

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

    -- Haskell code for the body of an enumeration definition
    --
    enumBody                        :: Int -> [(String, Maybe CExpr)] -> String
    enumBody :: Int -> [(String, Maybe CExpr)] -> String
    enumBody indent :: Int
    indent []               = ""
    enumBody indent :: Int
    indent ((ide :: String
    ide, _):list :: [(String, Maybe CExpr)]
    list)  =
      String
    ide String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> Char -> String
    forall a. Int -> a -> [a]
    replicate Int
    indent ' '
      String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (if [(String, Maybe CExpr)] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(String, Maybe CExpr)]
    list then "" else "| " 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 ident :: String
    ident list :: [(String, Maybe CExpr)]
    list =
      "instance Enum " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ident String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " 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]
    ++ "\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]
    ++ "\n"
      String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [String] -> String
    succDef [String]
    names String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [String] -> String
    predDef [String]
    names String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\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 0

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

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

        succDef :: [String] -> String
    succDef [] = "  succ _ = undefined\n"
        succDef [x :: String
    x] = "  succ _ = undefined\n"
        succDef (x :: String
    x:x' :: String
    x':xs :: [String]
    xs) =
          "  succ " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    x String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    x' String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\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 [] = "  pred _ = undefined\n"
        predDef [x :: String
    x] = "  pred _ = undefined\n"
        predDef (x :: String
    x:x' :: String
    x':xs :: [String]
    xs) =
          "  pred " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    x' String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    x String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\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 [] = ""
        enumFromToDef names :: [String]
    names =
             "  enumFromTo x y | fromEnum x == fromEnum y = [ y ]\n"
          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "                 | otherwise = x : enumFromTo (succ x) y\n"
          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "  enumFrom x = enumFromTo x " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [String] -> String
    forall a. [a] -> a
    last [String]
    names String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n"
          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "  enumFromThen _ _ = "
          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "    error \"Enum "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    identString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++": enumFromThen not implemented\"\n"
          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "  enumFromThenTo _ _ _ = "
          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "    error \"Enum "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    identString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++": 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 hook :: CHSHook
    hook isPure :: Bool
    isPure isUns :: Bool
    isUns mLock :: Maybe String
    mLock ideLexeme :: String
    ideLexeme hsLexeme :: String
    hsLexeme cdecl :: CDecl
    cdecl pos :: Position
    pos =
      do
        -- compute the external type from the declaration, and delay the foreign
        -- export declaration
        --
        (mHsPtrRep :: [Maybe HsPtrRep]
    mHsPtrRep, extType :: ExtType
    extType) <- Position -> CDecl -> Bool -> GB ([Maybe HsPtrRep], ExtType)
    extractFunType Position
    pos CDecl
    cdecl Bool
    isPure
        String
    header  <- (SwitchBoard -> String) -> GB String
    forall a s. (SwitchBoard -> a) -> CST s a
    getSwitch SwitchBoard -> String
    headerSB
        CHSHook -> String -> CST (CState GBState) ()
    delayCode CHSHook
    hook (String -> String -> String -> Bool -> ExtType -> String
    foreignImport String
    header String
    ideLexeme String
    hsLexeme Bool
    isUns ExtType
    extType)
        ExtType -> CST (CState GBState) ()
    traceFunType ExtType
    extType
        -- if the type any special pointer aliases, generate a lambda expression
        -- which strips off the constructors
        if (Maybe HsPtrRep -> Bool) -> [Maybe HsPtrRep] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any Maybe HsPtrRep -> Bool
    forall a. Maybe a -> Bool
    isJust [Maybe HsPtrRep]
    mHsPtrRep
           then [Maybe HsPtrRep] -> GB String
    createLambdaExpr [Maybe HsPtrRep]
    mHsPtrRep
           else String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    funStr
      where
        createLambdaExpr :: [Maybe HsPtrRep] -> GB String
        createLambdaExpr :: [Maybe HsPtrRep] -> GB String
    createLambdaExpr foreignVec :: [Maybe HsPtrRep]
    foreignVec = String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $
          "(\\" String -> String -> String
    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 [1..])String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " -> "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 [1..])String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    funStrString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++" "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 [1..])String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++")"
        wrPattern :: Maybe (a, b, Maybe String, d) -> a -> String
    wrPattern (Just (_,_,Just con :: String
    con,_)) n :: a
    n = "("String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    conString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++" 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]
    ++")"
        wrPattern _                    n :: a
    n = "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 (_,CHSForeignPtr,_,_)) n :: a
    n
            = "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]
    ++" $ \\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]
    ++" ->"
        wrForPtr _                          n :: a
    n = ""
        wrArg :: Maybe (a, CHSPtrType, c, d) -> a -> String
    wrArg (Just (_,CHSForeignPtr,_,_)) n :: a
    n = "argPtr"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++a -> String
    forall a. Show a => a -> String
    show a
    n
        wrArg (Just (_,CHSStablePtr,_,_)) n :: a
    n =
            "(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]
    ++")"
        wrArg _ n :: a
    n = "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 Nothing -> String
    hsLexeme
                               Just lockFun :: String
    lockFun -> String
    lockFun String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " $ " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    hsLexeme
        traceFunType :: ExtType -> CST (CState GBState) ()
    traceFunType et :: ExtType
    et = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "Imported function type: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ExtType -> String
    showExtType ExtType
    et String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\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 header :: String
    header ident :: String
    ident hsIdent :: String
    hsIdent isUnsafe :: Bool
    isUnsafe ty :: ExtType
    ty  =
      "foreign import ccall " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    safety String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " 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]
    ++
      "\n  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    hsIdent String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " :: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ExtType -> String
    showExtType ExtType
    ty String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n"
      where
        safety :: String
    safety = if Bool
    isUnsafe then "unsafe" else "safe"
        entity :: String
    entity | String -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    header = String
    ident
               | Bool
    otherwise   = String
    header String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " String -> String -> String
    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 isPure :: Bool
    isPure hsLexeme :: String
    hsLexeme fiLexeme :: String
    fiLexeme cdecl :: CDecl
    cdecl octxt :: Maybe String
    octxt mLock :: Maybe String
    mLock parms :: [CHSParm]
    parms parm :: CHSParm
    parm pos :: Position
    pos =
      do
        (parms' :: [CHSParm]
    parms', parm' :: CHSParm
    parm', isImpure :: 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
    forall a. [a] -> [a] -> [a]
    ++ [CHSParm] -> CHSParm -> String
    funTy [CHSParm]
    parms' CHSParm
    parm' String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n"
          marshs :: [(String, String, String, String, String)]
    marshs    = [Integer -> CHSParm -> (String, String, String, String, String)
    forall a.
    Show a =>
    a -> CHSParm -> (String, String, String, String, String)
    marshArg Integer
    i CHSParm
    parm | (i :: Integer
    i, parm :: CHSParm
    parm) <- [Integer] -> [CHSParm] -> [(Integer, CHSParm)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [1..] [CHSParm]
    parms']
          funArgs :: [String]
    funArgs   = [String
    funArg   | (funArg :: String
    funArg, _, _, _, _)   <- [(String, String, String, String, String)]
    marshs, String
    funArg   String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ""]
          marshIns :: [String]
    marshIns  = [String
    marshIn  | (_, marshIn :: String
    marshIn, _, _, _)  <- [(String, String, String, String, String)]
    marshs]
          callArgs :: [String]
    callArgs  = [String
    callArg  | (_, _, callArg :: String
    callArg, _, _)  <- [(String, String, String, String, String)]
    marshs]
          marshOuts :: [String]
    marshOuts = [String
    marshOut | (_, _, _, marshOut :: String
    marshOut, _) <- [(String, String, String, String, String)]
    marshs, String
    marshOut String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ""]
          retArgs :: [String]
    retArgs   = [String
    retArg   | (_, _, _, _, retArg :: String
    retArg)   <- [(String, String, String, String, String)]
    marshs, String
    retArg   String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ""]
          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]
    ++ " =\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                      if Bool
    isPure Bool -> Bool -> Bool
    && Bool
    isImpure then "  unsafePerformIO $\n" else ""
          lock :: String
    lock      = case Maybe String
    mLock of Nothing -> ""
                                    Just lock :: String
    lock -> String
    lock String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " $"
          call :: String
    call      = if Bool
    isPure
                      then "  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]
    ++ "} in\n"
                      else "  " 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]
    ++ " >>= \\res ->\n"
          marshRes :: String
    marshRes  = case CHSParm
    parm' of
                        CHSParm _ _ twoCVal :: Bool
    twoCVal (Just (_    , CHSVoidArg)) _ -> ""
                        CHSParm _ _ twoCVal :: Bool
    twoCVal (Just (omIde :: Ident
    omIde, CHSIOArg  )) _ ->
                          "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Ident -> String
    identToLexeme Ident
    omIde String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " res >>= \\res' ->\n"
                        CHSParm _ _ twoCVal :: Bool
    twoCVal (Just (omIde :: Ident
    omIde, CHSValArg )) _ ->
                          "  let {res' = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Ident -> String
    identToLexeme Ident
    omIde String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " res} in\n"
                        CHSParm _ _ _       Nothing                    _ ->
                          String -> String
    forall a. String -> a
    interr "GenBind.funDef: marshRes: no default?"
          retArgs' :: [String]
    retArgs'  = case CHSParm
    parm' of
                        CHSParm _ _ _ (Just (_, CHSVoidArg)) _ ->        [String]
    retArgs
                        _                                      -> "res'"String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :[String]
    retArgs
          ret :: String
    ret       = "(" 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]
    retArgs') String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
          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
    forall a. [a] -> [a] -> [a]
    ++
                      (if Bool
    isImpure Bool -> Bool -> Bool
    || Bool -> Bool
    not Bool
    isPure then "return " else "") String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ret
        String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ String
    sig String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    funHead String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    funBody
      where
        join :: [String] -> String
    join      = (String -> String) -> [String] -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (' 'Char -> 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 (\s :: String
    s -> "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\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 parms :: [CHSParm]
    parms parm :: CHSParm
    parm =
          let
            ctxt :: String
    ctxt   = case Maybe String
    octxt of
                       Nothing      -> ""
                       Just ctxtStr :: String
    ctxtStr -> String
    ctxtStr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " => "
            argTys :: [String]
    argTys = [String
    ty | CHSParm im :: Maybe (Ident, CHSArg)
    im ty :: String
    ty _ _  _ <- [CHSParm]
    parms     , Maybe (Ident, CHSArg) -> Bool
    forall a. Maybe (a, CHSArg) -> Bool
    notVoid Maybe (Ident, CHSArg)
    im]
            resTys :: [String]
    resTys = [String
    ty | CHSParm _  ty :: String
    ty _ om :: Maybe (Ident, CHSArg)
    om _ <- 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
                       (lp :: String
    lp, rp :: String
    rp) = if Bool
    isPure Bool -> Bool -> Bool
    && [String] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [String]
    resTys Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 1
                                  then ("", "")
                                  else ("(", ")")
                       io :: String
    io       = if Bool
    isPure then "" else "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]
    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]
    argTys [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    resTup]))
          where
            notVoid :: Maybe (a, CHSArg) -> Bool
    notVoid Nothing          = String -> Bool
    forall a. String -> a
    interr "GenBind.funDef: \
                                              \No default marshaller?"
            notVoid (Just (_, kind :: CHSArg
    kind)) = CHSArg
    kind CHSArg -> CHSArg -> Bool
    forall a. Eq a => a -> a -> Bool
    /= CHSArg
    CHSVoidArg
        --
        -- for an argument marshaller, generate all "in" and "out" marshalling
        -- code fragments
        --
        marshArg :: a -> CHSParm -> (String, String, String, String, String)
    marshArg i :: a
    i (CHSParm (Just (imIde :: Ident
    imIde, imArgKind :: CHSArg
    imArgKind)) _ twoCVal :: Bool
    twoCVal
                            (Just (omIde :: Ident
    omIde, omArgKind :: CHSArg
    omArgKind)) _        ) =
          let
            a :: String
    a        = "a" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ a -> String
    forall a. Show a => a -> String
    show a
    i
            imStr :: String
    imStr    = Ident -> String
    identToLexeme Ident
    imIde
            imApp :: String
    imApp    = String
    imStr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " String -> String -> String
    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 "" else String
    a
            inBndr :: String
    inBndr   = if Bool
    twoCVal
                         then "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    a String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'1, " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    a String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'2)"
                         else String
    a String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'"
            marshIn :: String
    marshIn  = case CHSArg
    imArgKind of
                         CHSVoidArg -> String
    imStr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " $ \\" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    inBndr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " -> "
                         CHSIOArg   -> String
    imApp String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " $ \\" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    inBndr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " -> "
                         CHSValArg  -> "let {" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    inBndr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                       String
    imApp String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "} in "
            callArg :: String
    callArg  = if Bool
    twoCVal
                         then "" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    a String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'1 " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    a String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'2"
                         else String
    a String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "'"
            omApp :: String
    omApp    = Ident -> String
    identToLexeme Ident
    omIde String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    callArg
            outBndr :: String
    outBndr  = String
    a String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "''"
            marshOut :: String
    marshOut = case CHSArg
    omArgKind of
                         CHSVoidArg -> ""
                         CHSIOArg   -> String
    omApp String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ">>= \\" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    outBndr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " -> "
                         CHSValArg  -> "let {" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    outBndr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                                       String
    omApp String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "} in "
            retArg :: String
    retArg   = if CHSArg
    omArgKind CHSArg -> CHSArg -> Bool
    forall a. Eq a => a -> a -> Bool
    == CHSArg
    CHSVoidArg then "" else String
    outBndr
          in
          (String
    funArg, String
    marshIn, String
    callArg, String
    marshOut, String
    retArg)
        marshArg _ _ = String -> (String, String, String, String, String)
    forall a. String -> a
    interr "GenBind.funDef: Missing default?"
        --
        traceMarsh :: [CHSParm] -> CHSParm -> Bool -> CST (CState GBState) ()
    traceMarsh parms :: [CHSParm]
    parms parm :: CHSParm
    parm isImpure :: Bool
    isImpure = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "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
    forall a. [a] -> [a] -> [a]
    ++
          "  The marshalling is " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ if Bool
    isImpure then "impure.\n" else "pure.\n"
          where
            showParms :: [CHSParm] -> String -> String
    showParms []           = String -> String
    forall a. a -> a
    id
            showParms (parm :: CHSParm
    parm:parms :: [CHSParm]
    parms) =   String -> String -> String
    showString "  "
                                     (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 '\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 pos :: Position
    pos parms :: [CHSParm]
    parms parm :: CHSParm
    parm cdecl :: CDecl
    cdecl = do
      (_, fType :: ExtType
    fType) <- Position -> CDecl -> Bool -> GB ([Maybe HsPtrRep], ExtType)
    extractFunType Position
    pos CDecl
    cdecl Bool
    True
      let (resTy :: ExtType
    resTy, argTys :: [ExtType]
    argTys) = ExtType -> (ExtType, [ExtType])
    splitFunTy ExtType
    fType
      (parm' :: CHSParm
    parm' , isImpure1 :: Bool
    isImpure1) <- CHSParm -> ExtType -> GB (CHSParm, Bool)
    checkResMarsh CHSParm
    parm ExtType
    resTy
      (parms' :: [CHSParm]
    parms', isImpure2 :: Bool
    isImpure2) <- [CHSParm]
    -> [ExtType]
    -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
    addDft [CHSParm]
    parms [ExtType]
    argTys
      ([CHSParm], CHSParm, Bool) -> GB ([CHSParm], CHSParm, Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([CHSParm]
    parms', CHSParm
    parm', Bool
    isImpure1 Bool -> Bool -> Bool
    || Bool
    isImpure2)
      where
        -- the result marshalling may not use an "in" marshaller and can only have
        -- one C value
        --
        --  * a default marshaller maybe used for "out" marshalling
        --
        checkResMarsh :: CHSParm -> ExtType -> GB (CHSParm, Bool)
    checkResMarsh (CHSParm (Just _) _  _    _       pos :: Position
    pos) _   =
          Position -> GB (CHSParm, Bool)
    forall a. Position -> GB a
    resMarshIllegalInErr      Position
    pos
        checkResMarsh (CHSParm _        _  True _       pos :: Position
    pos) _   =
          Position -> GB (CHSParm, Bool)
    forall a. Position -> GB a
    resMarshIllegalTwoCValErr Position
    pos
        checkResMarsh (CHSParm _        ty :: String
    ty _    omMarsh :: Maybe (Ident, CHSArg)
    omMarsh pos :: Position
    pos) cTy :: ExtType
    cTy = do
          (imMarsh' :: Maybe (Ident, CHSArg)
    imMarsh', _       ) <- 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
          (omMarsh' :: Maybe (Ident, CHSArg)
    omMarsh', isImpure :: Bool
    isImpure) <- Position
    -> Maybe (Ident, CHSArg)
    -> String
    -> [ExtType]
    -> PreCST
         SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
    addDftOut Position
    pos Maybe (Ident, CHSArg)
    omMarsh String
    ty [ExtType
    cTy]
          (CHSParm, Bool) -> GB (CHSParm, Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg)
    -> String -> Bool -> Maybe (Ident, CHSArg) -> Position -> CHSParm
    CHSParm Maybe (Ident, CHSArg)
    imMarsh' String
    ty Bool
    False Maybe (Ident, CHSArg)
    omMarsh' Position
    pos, Bool
    isImpure)
        --
        splitFunTy :: ExtType -> (ExtType, [ExtType])
    splitFunTy (FunET UnitET ty :: ExtType
    ty ) = ExtType -> (ExtType, [ExtType])
    splitFunTy ExtType
    ty
        splitFunTy (FunET ty1 :: ExtType
    ty1    ty2 :: ExtType
    ty2) = let
                                          (resTy :: ExtType
    resTy, argTys :: [ExtType]
    argTys) = ExtType -> (ExtType, [ExtType])
    splitFunTy ExtType
    ty2
                                        in
                                        (ExtType
    resTy, ExtType
    ty1ExtType -> [ExtType] -> [ExtType]
    forall a. a -> [a] -> [a]
    :[ExtType]
    argTys)
        splitFunTy resTy :: ExtType
    resTy              = (ExtType
    resTy, [])
        --
        -- match Haskell with C arguments (and results)
        --
        addDft :: [CHSParm]
    -> [ExtType]
    -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
    addDft ((CHSParm imMarsh :: Maybe (Ident, CHSArg)
    imMarsh hsTy :: String
    hsTy False omMarsh :: Maybe (Ident, CHSArg)
    omMarsh p :: Position
    p):parms :: [CHSParm]
    parms) (cTy :: ExtType
    cTy      :cTys :: [ExtType]
    cTys) = do
          (imMarsh' :: Maybe (Ident, CHSArg)
    imMarsh', isImpureIn :: 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]
          (omMarsh' :: Maybe (Ident, CHSArg)
    omMarsh', isImpureOut :: 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
          (parms' :: [CHSParm]
    parms'  , isImpure :: Bool
    isImpure   ) <- [CHSParm]
    -> [ExtType]
    -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
    addDft [CHSParm]
    parms [ExtType]
    cTys
          ([CHSParm], Bool)
    -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg)
    -> String -> Bool -> Maybe (Ident, CHSArg) -> Position -> CHSParm
    CHSParm Maybe (Ident, CHSArg)
    imMarsh' String
    hsTy Bool
    False Maybe (Ident, CHSArg)
    omMarsh' Position
    p CHSParm -> [CHSParm] -> [CHSParm]
    forall a. a -> [a] -> [a]
    : [CHSParm]
    parms',
                  Bool
    isImpure Bool -> Bool -> Bool
    || Bool
    isImpureIn Bool -> Bool -> Bool
    || Bool
    isImpureOut)
        addDft ((CHSParm imMarsh :: Maybe (Ident, CHSArg)
    imMarsh hsTy :: String
    hsTy True  omMarsh :: Maybe (Ident, CHSArg)
    omMarsh p :: Position
    p):parms :: [CHSParm]
    parms) (cTy1 :: ExtType
    cTy1:cTy2 :: ExtType
    cTy2:cTys :: [ExtType]
    cTys) = do
          (imMarsh' :: Maybe (Ident, CHSArg)
    imMarsh', isImpureIn :: 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]
          (omMarsh' :: Maybe (Ident, CHSArg)
    omMarsh', isImpureOut :: 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
          (parms' :: [CHSParm]
    parms'  , isImpure :: Bool
    isImpure   ) <- [CHSParm]
    -> [ExtType]
    -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
    addDft [CHSParm]
    parms [ExtType]
    cTys
          ([CHSParm], Bool)
    -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg)
    -> String -> Bool -> Maybe (Ident, CHSArg) -> Position -> CHSParm
    CHSParm Maybe (Ident, CHSArg)
    imMarsh' String
    hsTy Bool
    True Maybe (Ident, CHSArg)
    omMarsh' Position
    p CHSParm -> [CHSParm] -> [CHSParm]
    forall a. a -> [a] -> [a]
    : [CHSParm]
    parms',
                  Bool
    isImpure Bool -> Bool -> Bool
    || Bool
    isImpureIn Bool -> Bool -> Bool
    || Bool
    isImpureOut)
        addDft []                                             []               =
          ([CHSParm], Bool)
    -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([], Bool
    False)
        addDft ((CHSParm _       _    _     _     pos :: Position
    pos):parms :: [CHSParm]
    parms) []               =
          Position
    -> String -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
    forall a. Position -> String -> GB a
    marshArgMismatchErr Position
    pos "This parameter is in excess of the C arguments."
        addDft []                                             (_:_)            =
          Position
    -> String -> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
    forall a. Position -> String -> GB a
    marshArgMismatchErr Position
    pos "Parameter marshallers are missing."
        --
        addDftIn :: Position
    -> Maybe (Ident, CHSArg)
    -> String
    -> [ExtType]
    -> PreCST
         SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
    addDftIn _   imMarsh :: Maybe (Ident, CHSArg)
    imMarsh@(Just (_, kind :: CHSArg
    kind)) _    _    = (Maybe (Ident, CHSArg), Bool)
    -> PreCST
         SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg)
    imMarsh,
                                                                  CHSArg
    kind CHSArg -> CHSArg -> Bool
    forall a. Eq a => a -> a -> Bool
    == CHSArg
    CHSIOArg)
        addDftIn pos :: Position
    pos imMarsh :: Maybe (Ident, CHSArg)
    imMarsh@Maybe (Ident, CHSArg)
    Nothing          hsTy :: String
    hsTy cTys :: [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 "\"in\"" String
    hsTy [ExtType]
    cTys
          (Maybe (Ident, CHSArg), Bool)
    -> PreCST
         SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg)
    marsh, case Maybe (Ident, CHSArg)
    marsh of {Just (_, kind :: 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 _   omMarsh :: Maybe (Ident, CHSArg)
    omMarsh@(Just (_, kind :: CHSArg
    kind)) _    _    = (Maybe (Ident, CHSArg), Bool)
    -> PreCST
         SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg)
    omMarsh,
                                                                  CHSArg
    kind CHSArg -> CHSArg -> Bool
    forall a. Eq a => a -> a -> Bool
    == CHSArg
    CHSIOArg)
        addDftOut pos :: Position
    pos omMarsh :: Maybe (Ident, CHSArg)
    omMarsh@Maybe (Ident, CHSArg)
    Nothing          hsTy :: String
    hsTy cTys :: [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 "\"out\"" String
    hsTy [ExtType]
    cTys
          (Maybe (Ident, CHSArg), Bool)
    -> PreCST
         SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg)
    marsh, case Maybe (Ident, CHSArg)
    marsh of {Just (_, kind :: 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 (_, kind :: CHSArg
    kind)) = (Maybe (Ident, CHSArg), Bool) -> m (Maybe (Ident, CHSArg), Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Ident, CHSArg)
    marsh, CHSArg
    kind CHSArg -> CHSArg -> Bool
    forall a. Eq a => a -> a -> Bool
    == CHSArg
    CHSIOArg)
        addDftVoid        Nothing         = do
          (Maybe (Ident, CHSArg), Bool) -> m (Maybe (Ident, CHSArg), Bool)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((Ident, CHSArg) -> Maybe (Ident, CHSArg)
    forall a. a -> Maybe a
    Just (String -> Ident
    noPosIdent "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 ide :: Ident
    ide) =                              -- t
      do
        CDecl
    decl <- Ident -> Bool -> Bool -> CT GBState CDecl
    forall s. Ident -> Bool -> Bool -> CT s CDecl
    findAndChaseDecl Ident
    ide Bool
    False Bool
    True
        (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Ident
    ide Ident -> CDecl -> CDecl
    `simplifyDecl` CDecl
    decl, [Int -> Int -> BitSize
    BitSize 0 0])
    accessPath (CHSDeref (CHSRoot ide :: Ident
    ide) _) =                 --  *t
      do
        CDecl
    decl <- Ident -> Bool -> Bool -> CT GBState CDecl
    forall s. Ident -> Bool -> Bool -> CT s CDecl
    findAndChaseDecl Ident
    ide Bool
    True Bool
    True
        (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Ident
    ide Ident -> CDecl -> CDecl
    `simplifyDecl` CDecl
    decl, [Int -> Int -> BitSize
    BitSize 0 0])
    accessPath (CHSRef root :: CHSAPath
    root@(CHSRoot ide1 :: Ident
    ide1) ide2 :: 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
        (offset :: BitSize
    offset, decl' :: CDecl
    decl') <- CStructUnion -> Ident -> GB (BitSize, CDecl)
    refStruct CStructUnion
    su Ident
    ide2
        CDecl
    adecl <- CDecl -> CT GBState CDecl
    replaceByAlias CDecl
    decl'
        (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CDecl
    adecl, [BitSize
    offset])
    accessPath (CHSRef (CHSDeref (CHSRoot ide1 :: Ident
    ide1) _) ide2 :: 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
        (offset :: BitSize
    offset, decl' :: CDecl
    decl') <- CStructUnion -> Ident -> GB (BitSize, CDecl)
    refStruct CStructUnion
    su Ident
    ide2
        CDecl
    adecl <- CDecl -> CT GBState CDecl
    replaceByAlias CDecl
    decl'
        (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CDecl
    adecl, [BitSize
    offset])
    accessPath (CHSRef path :: CHSAPath
    path ide :: Ident
    ide) =                          -- a.m
      do
        (decl :: CDecl
    decl, offset :: BitSize
    offset:offsets :: [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
        (addOffset :: BitSize
    addOffset, decl' :: CDecl
    decl') <- CStructUnion -> Ident -> GB (BitSize, CDecl)
    refStruct CStructUnion
    su Ident
    ide
        CDecl
    adecl <- CDecl -> CT GBState CDecl
    replaceByAlias CDecl
    decl'
        (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CDecl
    adecl, BitSize
    offset BitSize -> BitSize -> BitSize
    `addBitSize` BitSize
    addOffset BitSize -> [BitSize] -> [BitSize]
    forall a. a -> [a] -> [a]
    : [BitSize]
    offsets)
      where
        assertPrimDeclr :: Ident -> CDecl -> CST (CState GBState) ()
    assertPrimDeclr ide :: Ident
    ide (CDecl _ [declr :: (Maybe CDeclr, Maybe CInit, Maybe CExpr)
    declr] _) =
          case (Maybe CDeclr, Maybe CInit, Maybe CExpr)
    declr of
            (Just (CVarDeclr _ _), _, _) -> CST (CState GBState) ()
    forall e s. PreCST e s ()
    nop
            _                            -> Ident -> CST (CState GBState) ()
    forall a. Ident -> GB a
    structExpectedErr Ident
    ide
    accessPath (CHSDeref path :: CHSAPath
    path pos :: Position
    pos) =                        --  *a
      do
        (decl :: CDecl
    decl, offsets :: [BitSize]
    offsets) <- CHSAPath -> GB (CDecl, [BitSize])
    accessPath CHSAPath
    path
        CDecl
    decl' <- CDecl -> CT GBState CDecl
    derefOrErr CDecl
    decl
        CDecl
    adecl <- CDecl -> CT GBState CDecl
    replaceByAlias CDecl
    decl'
        (CDecl, [BitSize]) -> GB (CDecl, [BitSize])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CDecl
    adecl, Int -> Int -> BitSize
    BitSize 0 0 BitSize -> [BitSize] -> [BitSize]
    forall a. a -> [a] -> [a]
    : [BitSize]
    offsets)
      where
        derefOrErr :: CDecl -> CT GBState CDecl
    derefOrErr (CDecl specs :: [CDeclSpec]
    specs [declr :: (Maybe CDeclr, Maybe CInit, Maybe CExpr)
    declr] at :: Attrs
    at) =
          case (Maybe CDeclr, Maybe CInit, Maybe CExpr)
    declr of
            (Just (CPtrDeclr [_]       declr :: CDeclr
    declr at :: Attrs
    at), oinit :: Maybe CInit
    oinit, oexpr :: Maybe CExpr
    oexpr) ->
              CDecl -> CT GBState CDecl
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CDecl -> CT GBState CDecl) -> CDecl -> CT GBState CDecl
    forall a b. (a -> b) -> a -> b
    $ [CDeclSpec]
    -> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
    CDecl [CDeclSpec]
    specs [(CDeclr -> Maybe CDeclr
    forall a. a -> Maybe a
    Just CDeclr
    declr, Maybe CInit
    oinit, Maybe CExpr
    oexpr)] Attrs
    at
            (Just (CPtrDeclr (_:quals :: [CTypeQual]
    quals) declr :: CDeclr
    declr at :: Attrs
    at), oinit :: Maybe CInit
    oinit, oexpr :: Maybe CExpr
    oexpr) ->
              CDecl -> CT GBState CDecl
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CDecl -> CT GBState CDecl) -> CDecl -> CT GBState CDecl
    forall a b. (a -> b) -> a -> b
    $
                [CDeclSpec]
    -> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
    CDecl [CDeclSpec]
    specs [(CDeclr -> Maybe CDeclr
    forall a. a -> Maybe a
    Just ([CTypeQual] -> CDeclr -> Attrs -> CDeclr
    CPtrDeclr [CTypeQual]
    quals CDeclr
    declr Attrs
    at), Maybe CInit
    oinit, Maybe CExpr
    oexpr)] Attrs
    at
            _                                                   ->
              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 _ [(_, _, size :: Maybe CExpr
    size)] at :: 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
          Nothing                                  -> CDecl -> CT GBState CDecl
    forall (m :: * -> *) a. Monad m => a -> m a
    return CDecl
    cdecl
          Just (CDecl specs :: [CDeclSpec]
    specs [(declr :: Maybe CDeclr
    declr, init :: Maybe CInit
    init, _)] at :: Attrs
    at) ->   -- form of an alias
            CDecl -> CT GBState CDecl
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CDecl -> CT GBState CDecl) -> CDecl -> CT GBState CDecl
    forall a b. (a -> b) -> a -> b
    $ [CDeclSpec]
    -> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
    CDecl [CDeclSpec]
    specs [(Maybe CDeclr
    declr, Maybe CInit
    init, Maybe CExpr
    size)] Attrs
    at

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

    -- does the given declarator define the given name?
    --
    declNamed :: CDecl -> Ident -> Bool
    (CDecl _ [(Nothing   , _, _)] _) declNamed :: CDecl -> Ident -> Bool
    `declNamed` ide :: Ident
    ide = Bool
    False
    (CDecl _ [(Just declr :: CDeclr
    declr, _, _)] _) `declNamed` ide :: Ident
    ide = CDeclr
    declr CDeclr -> Ident -> Bool
    `declrNamed` Ident
    ide
    (CDecl _ []                   _) `declNamed` _   =
      String -> Bool
    forall a. String -> a
    interr "GenBind.declNamed: Abstract declarator in structure!"
    _                                `declNamed` _   =
      String -> Bool
    forall a. String -> a
    interr "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 pos :: Position
    pos access :: CHSAccess
    access offsets :: [BitSize]
    offsets ty :: ExtType
    ty =
      do
        let pre :: String
    pre = case CHSAccess
    access of
                    CHSSet -> "(\\ptr val -> do {"
                    CHSGet -> "(\\ptr -> do {"
        String
    body <- [BitSize] -> GB String
    setGetBody ([BitSize] -> [BitSize]
    forall a. [a] -> [a]
    reverse [BitSize]
    offsets)
        String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ String
    pre String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    body String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "})"
      where
        setGetBody :: [BitSize] -> GB String
    setGetBody [BitSize offset :: Int
    offset bitOffset :: Int
    bitOffset] =
          do
            let ty' :: ExtType
    ty' = case ExtType
    ty of
                              t :: ExtType
    t@(DefinedET _ _) -> ExtType -> ExtType
    PtrET ExtType
    t
                              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
              Nothing      -> String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ case CHSAccess
    access of       -- not a bitfield
                                CHSGet -> Int -> String -> String
    forall a. Show a => a -> String -> String
    peekOp Int
    offset String
    tyTag
                                CHSSet -> Int -> String -> String -> String
    forall a. Show a => a -> String -> String -> String
    pokeOp Int
    offset String
    tyTag "val"
    --FIXME: must take `bitfieldDirection' into account
              Just (_, bs :: Int
    bs) -> String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ case CHSAccess
    access of       -- a bitfield
                                CHSGet -> "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
                                CHSSet -> "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 "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 = "; return $ (val `shiftL` ("
                                    String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    bitsPerField String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " - "
                                    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]
    ++ ")) `shiftR` ("
                                    String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    bitsPerField String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " - " 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]
    ++ ")"
                  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
    * 8
                  --
                  insertBitfield :: String
    insertBitfield  = "; let {val' = (org .&. " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    middleMask
                                    String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ") .|. (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]
    ++ ")}; "
                  middleMask :: String
    middleMask      = "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]
    ++ ") `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]
    ++ ")"
        setGetBody (BitSize offset :: Int
    offset 0 : offsets :: [BitSize]
    offsets) =
          do
            String
    code <- [BitSize] -> GB String
    setGetBody [BitSize]
    offsets
            String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ "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
    forall a. [a] -> [a] -> [a]
    ++ String
    code
        setGetBody (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      _    )          = String -> GB (Maybe (Bool, Int))
    forall a. String -> a
    interr "GenBind.setGet: Illegal \
                                                      \type!"
        checkType (ExtType
    UnitET         )          = Position -> GB (Maybe (Bool, Int))
    forall a. Position -> GB a
    voidFieldErr Position
    pos
        checkType (PrimET    (CUFieldPT bs :: Int
    bs)) = Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Bool, Int) -> GB (Maybe (Bool, Int)))
    -> Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
    forall a b. (a -> b) -> a -> b
    $ (Bool, Int) -> Maybe (Bool, Int)
    forall a. a -> Maybe a
    Just (Bool
    False, Int
    bs)
        checkType (PrimET    (CSFieldPT bs :: Int
    bs)) = Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe (Bool, Int) -> GB (Maybe (Bool, Int)))
    -> Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
    forall a b. (a -> b) -> a -> b
    $ (Bool, Int) -> Maybe (Bool, Int)
    forall a. a -> Maybe a
    Just (Bool
    True , Int
    bs)
        checkType _                          = Maybe (Bool, Int) -> GB (Maybe (Bool, Int))
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Bool, Int)
    forall a. Maybe a
    Nothing
        --
        peekOp :: a -> String -> String
    peekOp off :: a
    off tyTag :: String
    tyTag     = "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]
    ++ " ::IO " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    tyTag
        pokeOp :: a -> String -> String -> String
    pokeOp off :: a
    off tyTag :: String
    tyTag var :: String
    var = "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
    forall a. [a] -> [a] -> [a]
    ++ String
    var
                               String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "::" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    tyTag String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"

    -- 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 isStar :: Bool
    isStar cNameFull :: Ident
    cNameFull hsName :: String
    hsName ptrKind :: CHSPtrType
    ptrKind isNewtype :: Bool
    isNewtype hsType :: String
    hsType isFun :: 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 "()"             -- legacy FFI interface
                      else if Bool
    isNewtype
                      then String
    hsName           -- abstract type
                      else String
    hsType           -- concrete type
            ptrCon :: String
    ptrCon  = case CHSPtrType
    ptrKind of
                        CHSPtr | Bool
    isFun -> "FunPtr"
                        _              -> 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
    forall a. [a] -> [a] -> [a]
    ++ String
    ptrArg String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
            thePtr :: (Bool, Ident)
    thePtr  = (Bool
    isStar, Ident
    cNameFull)

        (Bool, Ident)
    thePtr (Bool, Ident) -> HsPtrRep -> CST (CState GBState) ()
    `ptrMapsTo` (Bool
    isFun,
                            CHSPtrType
    ptrKind,
                            if Bool
    isNewtype then String -> Maybe String
    forall a. a -> Maybe a
    Just String
    hsName else Maybe String
    forall a. Maybe a
    Nothing,
                            String
    ptrArg)
        String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $
          if Bool
    isNewtype
          then "newtype " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    hsName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    hsName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ptrType String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
          else "type "    String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    hsName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " = "                   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 pos :: Position
    pos className :: String
    className typeName :: String
    typeName ptrType :: CHSPtrType
    ptrType isNewtype :: Bool
    isNewtype superClasses :: [(String, String, HsObject)]
    superClasses =
      do
        let
          toMethodName :: String
    toMethodName    = case String
    typeName of
                              ""   -> String -> String
    forall a. String -> a
    interr "GenBind.classDef: \
                                             \Illegal identifier!"
                              c :: Char
    c:cs :: String
    cs -> Char -> Char
    toLower Char
    c Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    cs
          fromMethodName :: String
    fromMethodName  = "from" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    typeName
          classDefContext :: String
    classDefContext = case [(String, String, HsObject)]
    superClasses of
                              []                  -> ""
                              (superName :: String
    superName, _, _):_ -> String
    superName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " p => "
          classDef :: String
    classDef        =
            "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]
    ++ " p where\n"
            String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    toMethodName   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " :: p -> " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    typeName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "\n"
            String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    fromMethodName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " :: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    typeName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " -> p\n"
          instDef :: String
    instDef         =
            "instance " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    className String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    typeName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " where\n"
            String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    toMethodName   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " = id\n"
            String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    fromMethodName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " = id\n"
        String
    instDefs <- [(String, String, HsObject)] -> GB String
    castInstDefs [(String, String, HsObject)]
    superClasses
        String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ String
    classDef String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    instDefs String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    instDef
      where
        castInstDefs :: [(String, String, HsObject)] -> GB String
    castInstDefs [] = String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return ""
        castInstDefs ((superName :: String
    superName, ptrName :: String
    ptrName, Pointer ptrType' :: CHSPtrType
    ptrType' isNewtype' :: Bool
    isNewtype'):classes :: [(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
    forall a. String -> a
    interr "GenBind.classDef: \
                                             \Illegal identifier - 2!"
                                    c:cs -> Char -> Char
    toLower Char
    c Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    cs
                fromMethodName :: String
    fromMethodName  = "from" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ptrName
                castFun :: String
    castFun         = "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]
    ++ " " else ""
                superConstr :: String
    superConstr     = if Bool
    isNewtype' then String
    ptrName  String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " else ""
                instDef :: String
    instDef         =
                  "instance " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    superName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    typeName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " where\n"
                  String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    toMethodName     String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    typeConstr  String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "p) = "
                    String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    superConstr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    castFun String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " p)\n"
                  String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    fromMethodName   String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    superConstr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "p) = "
                    String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    typeConstr  String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    castFun String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " p)\n"
            String
    instDefs <- [(String, String, HsObject)] -> GB String
    castInstDefs [(String, String, HsObject)]
    classes
            String -> GB String
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> GB String) -> String -> GB String
    forall a b. (a -> b) -> a -> b
    $ String
    instDef String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    instDefs

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

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

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

    instance Eq ExtType where
      (FunET     t1 :: ExtType
    t1 t2 :: ExtType
    t2 ) == :: ExtType -> ExtType -> Bool
    == (FunET     t1' :: ExtType
    t1' t2' :: 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      t :: ExtType
    t     ) == (IOET      t' :: ExtType
    t'      ) = ExtType
    t ExtType -> ExtType -> Bool
    forall a. Eq a => a -> a -> Bool
    == ExtType
    t'
      (PtrET     t :: ExtType
    t     ) == (PtrET     t' :: ExtType
    t'      ) = ExtType
    t ExtType -> ExtType -> Bool
    forall a. Eq a => a -> a -> Bool
    == ExtType
    t'
      (DefinedET _ rep :: HsPtrRep
    rep ) == (DefinedET _ rep' :: HsPtrRep
    rep'  ) = HsPtrRep
    rep HsPtrRep -> HsPtrRep -> Bool
    forall a. Eq a => a -> a -> Bool
    == HsPtrRep
    rep'
      (PrimET    t :: CPrimType
    t     ) == (PrimET    t' :: CPrimType
    t'      ) = CPrimType
    t CPrimType -> CPrimType -> Bool
    forall a. Eq a => a -> a -> Bool
    == CPrimType
    t'
      UnitET             == 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 _ _)  = Bool
    True
    isFunExtType (IOET  _  )  = Bool
    True
    isFunExtType (DefinedET _ (isFun :: Bool
    isFun,_,_,_)) = Bool
    isFun
    isFunExtType _            = 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 UnitET res :: ExtType
    res)      = ExtType -> String
    showExtType ExtType
    res
    showExtType (FunET arg :: ExtType
    arg res :: ExtType
    res)         = "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ExtType -> String
    showExtType ExtType
    arg String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " -> "
                                          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ExtType -> String
    showExtType ExtType
    res String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
    showExtType (IOET t :: ExtType
    t)                = "(IO " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ExtType -> String
    showExtType ExtType
    t String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
    showExtType (PtrET t :: ExtType
    t)               = let ptrCon :: String
    ptrCon = if ExtType -> Bool
    isFunExtType ExtType
    t
                                                       then "FunPtr" else "Ptr"
                                          in
                                          "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ptrCon String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ExtType -> String
    showExtType ExtType
    t
                                          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ")"
    showExtType (DefinedET _ (_,_,_,str :: String
    str)) = String
    str
    showExtType (PrimET CPtrPT)         = "(Ptr ())"
    showExtType (PrimET CFunPtrPT)      = "(FunPtr ())"
    showExtType (PrimET CCharPT)        = "CChar"
    showExtType (PrimET CUCharPT)       = "CUChar"
    showExtType (PrimET CSCharPT)       = "CSChar"
    showExtType (PrimET CIntPT)         = "CInt"
    showExtType (PrimET CShortPT)       = "CShort"
    showExtType (PrimET CLongPT)        = "CLong"
    showExtType (PrimET CLLongPT)       = "CLLong"
    showExtType (PrimET CUIntPT)        = "CUInt"
    showExtType (PrimET CUShortPT)      = "CUShort"
    showExtType (PrimET CULongPT)       = "CULong"
    showExtType (PrimET CULLongPT)      = "CULLong"
    showExtType (PrimET CFloatPT)       = "CFloat"
    showExtType (PrimET CDoublePT)      = "CDouble"
    showExtType (PrimET CLDoublePT)     = "CLDouble"
    showExtType (PrimET (CSFieldPT bs :: Int
    bs)) = "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]
    ++ "-}"
    showExtType (PrimET (CUFieldPT bs :: Int
    bs)) = "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]
    ++ "-}"
    showExtType UnitET                  = "()"

    -- 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 pos :: Position
    pos cdecl :: CDecl
    cdecl isPure :: 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 (args :: [CDecl]
    args, resultDecl :: CDecl
    resultDecl, variadic :: 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)
        --
        (foreignSyn :: [Maybe HsPtrRep]
    foreignSyn, argTypes :: [ExtType]
    argTypes) <- ([ExtType] -> ([Maybe HsPtrRep], [ExtType]))
    -> PreCST SwitchBoard (CState GBState) [ExtType]
    -> PreCST
         SwitchBoard (CState GBState) ([Maybe HsPtrRep], [ExtType])
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM ([(Maybe HsPtrRep, ExtType)] -> ([Maybe HsPtrRep], [ExtType])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Maybe HsPtrRep, ExtType)] -> ([Maybe HsPtrRep], [ExtType]))
    -> ([ExtType] -> [(Maybe HsPtrRep, ExtType)])
    -> [ExtType]
    -> ([Maybe HsPtrRep], [ExtType])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ExtType -> (Maybe HsPtrRep, ExtType))
    -> [ExtType] -> [(Maybe HsPtrRep, ExtType)]
    forall a b. (a -> b) -> [a] -> [b]
    map ExtType -> (Maybe HsPtrRep, ExtType)
    expandSpecialPtrs) (PreCST SwitchBoard (CState GBState) [ExtType]
     -> PreCST
          SwitchBoard (CState GBState) ([Maybe HsPtrRep], [ExtType]))
    -> PreCST SwitchBoard (CState GBState) [ExtType]
    -> PreCST
         SwitchBoard (CState GBState) ([Maybe HsPtrRep], [ExtType])
    forall a b. (a -> b) -> a -> b
    $
                                  (CDecl -> GB ExtType)
    -> [CDecl] -> PreCST SwitchBoard (CState GBState) [ExtType]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM (Position -> CDecl -> GB ExtType
    extractSimpleType Position
    pos) [CDecl]
    args

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

        -- provide info on Haskell wrappers around C pointers
        expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType)
          -- no special treatment for a simple type synonym
        expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType)
    expandSpecialPtrs all :: ExtType
    all@(DefinedET cdecl :: CDecl
    cdecl (_, CHSPtr, Nothing, _)) =
            (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
    cdecl hsPtrRep :: 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 all :: 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 pos :: Position
    pos cdecl :: CDecl
    cdecl  =
      do
        CST (CState GBState) ()
    traceEnter
        CompType
    ct <- CDecl -> GB CompType
    extractCompType CDecl
    cdecl
        case CompType
    ct of
          ExtType et :: ExtType
    et -> ExtType -> GB ExtType
    forall (m :: * -> *) a. Monad m => a -> m a
    return ExtType
    et
          SUType  _  -> 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
    $
          "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
    cdecl  = do
      CompType
    ct <- CDecl -> GB CompType
    extractCompType CDecl
    cdecl
      case CompType
    ct of
        ExtType et :: ExtType
    et -> ExtType -> GB ExtType
    forall (m :: * -> *) a. Monad m => a -> m a
    return ExtType
    et
        SUType  _  -> ExtType -> GB ExtType
    forall (m :: * -> *) a. Monad m => a -> m a
    return ExtType
    UnitET

    -- compute a Haskell type from the given C declaration, where C functions are
    -- represented by function pointers
    --
    --  * the declaration may have at most one declarator
    --
    --  * all C pointers (including functions) are represented as `Addr' if in
    --   compatibility mode (--old-ffi)
    --
    --  * typedef'ed types are chased
    --
    --  * takes the pointer map into account
    --
    --  * IMPORTANT NOTE: `sizeAlignOf' relies on `DefinedET' only being produced
    --                   for pointer types; if this ever changes, we need to
    --                   handle `DefinedET's differently.  The problem is that
    --                   entries in the pointer map currently prevent
    --                   `extractCompType' from looking further "into" the
    --                   definition of that pointer.
    --
    extractCompType :: CDecl -> GB CompType
    extractCompType :: CDecl -> GB CompType
    extractCompType cdecl :: CDecl
    cdecl@(CDecl specs :: [CDeclSpec]
    specs declrs :: [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
    declrs ats :: Attrs
    ats)  =
      if [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
    declrs Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > 1
      then String -> GB CompType
    forall a. String -> a
    interr "GenBind.extractCompType: Too many declarators!"
      else case [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
    declrs of
        [(Just declr :: CDeclr
    declr, _, size :: 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 declr :: 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
                       Nothing  -> Maybe HsPtrRep
    -> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe HsPtrRep
     -> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep))
    -> Maybe HsPtrRep
    -> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep)
    forall a b. (a -> b) -> a -> b
    $ Maybe HsPtrRep
    forall a. Maybe a
    Nothing
                       Just ide :: Ident
    ide -> (Bool, Ident)
    -> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep)
    queryPtr (Bool
    True, Ident
    ide)
          case Maybe HsPtrRep
    oHsRepr of
            Just repr :: HsPtrRep
    repr  -> HsPtrRep -> GB CompType
    forall s. HsPtrRep -> PreCST SwitchBoard s CompType
    ptrAlias HsPtrRep
    repr             -- got an alias
            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 et :: ExtType
    et -> ExtType -> ExtType
    PtrET ExtType
    et
                          SUType  _  -> 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
                    (_, et :: 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 size :: 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
            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 ide :: 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
                Nothing   -> do                -- skip current alias (only one)
                               CDecl
    cdecl' <- Ident -> CT GBState CDecl
    forall s. Ident -> CT s CDecl
    getDeclOf Ident
    ide
                               let CDecl specs :: [CDeclSpec]
    specs [(declr :: Maybe CDeclr
    declr, init :: Maybe CInit
    init, _)] at :: 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 repr :: 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 (isFun :: Bool
    isFun, ptrTy :: CHSPtrType
    ptrTy, wrapped :: Maybe String
    wrapped, tyArg :: 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 et :: ExtType
    et) = do
                                      Bool
    keepOld <- (SwitchBoard -> Bool) -> CST s Bool
    forall a s. (SwitchBoard -> a) -> CST s a
    getSwitch SwitchBoard -> Bool
    oldFFI
                                      if Bool
    keepOld
                                        then CompType -> PreCST SwitchBoard s CompType
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CompType -> PreCST SwitchBoard s CompType)
    -> CompType -> PreCST SwitchBoard s CompType
    forall a b. (a -> b) -> a -> b
    $ ExtType -> CompType
    ExtType (CPrimType -> ExtType
    PrimET CPrimType
    CPtrPT)
                                        else CompType -> PreCST SwitchBoard s CompType
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CompType -> PreCST SwitchBoard s CompType)
    -> CompType -> PreCST SwitchBoard s CompType
    forall a b. (a -> b) -> a -> b
    $ ExtType -> CompType
    ExtType ExtType
    retval
        returnX retval :: ExtType
    retval            = CompType -> PreCST SwitchBoard s CompType
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CompType -> PreCST SwitchBoard s CompType)
    -> CompType -> PreCST SwitchBoard s CompType
    forall a b. (a -> b) -> a -> b
    $ ExtType -> CompType
    ExtType ExtType
    retval
        --
        tracePtrType :: CST (CState GBState) ()
    tracePtrType = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $ "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
    $ "extractCompType: explicit function type\n"
        traceAliasOrSpecType :: Maybe a -> CST (CState GBState) ()
    traceAliasOrSpecType Nothing  = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "extractCompType: checking for alias\n"
        traceAliasOrSpecType (Just _) = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "extractCompType: checking for alias of bitfield\n"
        traceAlias :: Ident -> CST (CState GBState) ()
    traceAlias ide :: Ident
    ide = String -> CST (CState GBState) ()
    traceGenBind (String -> CST (CState GBState) ())
    -> String -> CST (CState GBState) ()
    forall a b. (a -> b) -> a -> b
    $
          "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]
    ++ "'\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 cpos :: Position
    cpos specs :: [CDeclSpec]
    specs osize :: Maybe CExpr
    osize =
      let tspecs :: [CTypeSpec]
    tspecs = [CTypeSpec
    ts | CTypeSpec ts :: 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 et :: ExtType
    et | ExtType -> Bool
    isUnsupportedType ExtType
    et -> Position -> GB CompType
    forall a. Position -> GB a
    unsupportedTypeSpecErr Position
    cpos
                | Maybe CExpr -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe CExpr
    osize      -> CompType -> GB CompType
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CompType -> GB CompType) -> CompType -> GB CompType
    forall a b. (a -> b) -> a -> b
    $ ExtType -> CompType
    ExtType ExtType
    et     -- not a bitfield
                | Bool
    otherwise            -> [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
    bitfieldSpec [CTypeSpec]
    tspecs ExtType
    et Maybe CExpr
    osize  -- bitfield
        Nothing                        ->
          case [CTypeSpec]
    tspecs of
            [CSUType   cu :: CStructUnion
    cu _] -> CompType -> GB CompType
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CompType -> GB CompType) -> CompType -> GB CompType
    forall a b. (a -> b) -> a -> b
    $ CStructUnion -> CompType
    SUType CStructUnion
    cu               -- struct or union
            [CEnumType _  _] -> CompType -> GB CompType
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CompType -> GB CompType) -> CompType -> GB CompType
    forall a b. (a -> b) -> a -> b
    $ ExtType -> CompType
    ExtType (CPrimType -> ExtType
    PrimET CPrimType
    CIntPT) -- enum
            [CTypeDef  _  _] -> String -> GB CompType
    forall a. String -> a
    interr "GenBind.specType: Illegal typedef alias!"
            _                -> 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 et :: CPrimType
    et) = CPrimType -> Int
    size CPrimType
    et Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 0  -- can't be a bitfield (yet)
        isUnsupportedType _           = 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` (_:_)  = Bool
    False
        (spec :: CTypeSpec
    spec:specs :: [CTypeSpec]
    specs) `matches` specs' :: [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   _) (CVoidType   _) = Bool
    True
        eqSpec (CCharType   _) (CCharType   _) = Bool
    True
        eqSpec (CShortType  _) (CShortType  _) = Bool
    True
        eqSpec (CIntType    _) (CIntType    _) = Bool
    True
        eqSpec (CLongType   _) (CLongType   _) = Bool
    True
        eqSpec (CFloatType  _) (CFloatType  _) = Bool
    True
        eqSpec (CDoubleType _) (CDoubleType _) = Bool
    True
        eqSpec (CSignedType _) (CSignedType _) = Bool
    True
        eqSpec (CUnsigType  _) (CUnsigType  _) = Bool
    True
        eqSpec (CSUType   _ _) (CSUType   _ _) = Bool
    True
        eqSpec (CEnumType _ _) (CEnumType _ _) = Bool
    True
        eqSpec (CTypeDef  _ _) (CTypeDef  _ _) = Bool
    True
        eqSpec _               _               = Bool
    False
        --
        bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
        bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
    bitfieldSpec tspecs :: [CTypeSpec]
    tspecs et :: ExtType
    et (Just sizeExpr :: 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 _     -> Position -> String -> GB CompType
    forall a. Position -> String -> GB a
    illegalConstExprErr Position
    pos "a float result"
              IntResult   size' :: Integer
    size' -> do
                let size :: Int
    size = Integer -> Int
    forall a. Num a => Integer -> a
    fromInteger Integer
    size'
                case ExtType
    et of
                  PrimET CUIntPT                      -> CPrimType -> GB CompType
    returnCT (CPrimType -> GB CompType) -> CPrimType -> GB CompType
    forall a b. (a -> b) -> a -> b
    $ Int -> CPrimType
    CUFieldPT Int
    size
                  PrimET 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
                  _                                   -> Position -> GB CompType
    forall a. Position -> GB a
    illegalFieldSizeErr Position
    pos
                where
                  returnCT :: CPrimType -> GB CompType
    returnCT = CompType -> GB CompType
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CompType -> GB CompType)
    -> (CPrimType -> CompType) -> CPrimType -> GB CompType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ExtType -> CompType
    ExtType (ExtType -> CompType)
    -> (CPrimType -> ExtType) -> CPrimType -> CompType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CPrimType -> ExtType
    PrimET
                  --
                  int :: CTypeSpec
    int    = Attrs -> CTypeSpec
    CIntType    Attrs
    forall a. HasCallStack => a
    undefined
                  signed :: CTypeSpec
    signed = Attrs -> CTypeSpec
    CSignedType Attrs
    forall a. HasCallStack => a
    undefined

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

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

    -- ordering relation compares in terms of required storage units
    --
    instance Ord BitSize where
      bs1 :: BitSize
    bs1@(BitSize o1 :: Int
    o1 b1 :: Int
    b1) < :: BitSize -> BitSize -> Bool
    <  bs2 :: BitSize
    bs2@(BitSize o2 :: Int
    o2 b2 :: 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)
      bs1 :: BitSize
    bs1                 <= :: BitSize -> BitSize -> Bool
    <= bs2 :: 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 o1 :: Int
    o1 b1 :: Int
    b1) (BitSize o2 :: Int
    o2 b2 :: 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
    * 8
        (overflow :: Int
    overflow, rest :: 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 o :: Int
    o 0)  = Int
    o
    padBits (BitSize o :: Int
    o _)  = 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 -> GB BitSize
    offsetInStruct []    _    _    = BitSize -> GB BitSize
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BitSize -> GB BitSize) -> BitSize -> GB BitSize
    forall a b. (a -> b) -> a -> b
    $ Int -> Int -> BitSize
    BitSize 0 0
    offsetInStruct decls :: [CDecl]
    decls decl :: CDecl
    decl tag :: CStructTag
    tag  =
      do
        (offset :: BitSize
    offset, _) <- [CDecl] -> CStructTag -> GB (BitSize, Int)
    sizeAlignOfStruct [CDecl]
    decls CStructTag
    tag
        (_, align :: Int
    align)  <- CDecl -> GB (BitSize, Int)
    sizeAlignOf CDecl
    decl
        BitSize -> GB BitSize
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BitSize -> GB BitSize) -> BitSize -> GB 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 []    _           = (BitSize, Int) -> GB (BitSize, Int)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int -> Int -> BitSize
    BitSize 0 0, 1)
    sizeAlignOfStruct decls :: [CDecl]
    decls CStructTag  =
      do
        (offset :: BitSize
    offset, preAlign :: Int
    preAlign) <- [CDecl] -> CStructTag -> GB (BitSize, Int)
    sizeAlignOfStruct ([CDecl] -> [CDecl]
    forall a. [a] -> [a]
    init [CDecl]
    decls) CStructTag
    CStructTag
        (size :: BitSize
    size, align :: Int
    align)      <- CDecl -> GB (BitSize, Int)
    sizeAlignOf       ([CDecl] -> CDecl
    forall a. [a] -> a
    last [CDecl]
    decls)
        let sizeOfStruct :: BitSize
    sizeOfStruct  = BitSize -> Int -> BitSize
    alignOffset BitSize
    offset Int
    align BitSize -> BitSize -> BitSize
    `addBitSize` BitSize
    size
            align' :: Int
    align'        = if Int
    align Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > 0 then Int
    align else Int
    bitfieldAlignment
            alignOfStruct :: Int
    alignOfStruct = Int
    preAlign Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    `max` Int
    align'
        (BitSize, Int) -> GB (BitSize, Int)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (BitSize
    sizeOfStruct, Int
    alignOfStruct)
    sizeAlignOfStruct decls :: [CDecl]
    decls CUnionTag   =
      do
        (sizes :: [BitSize]
    sizes, aligns :: [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
    > 0 then Int
    align else Int
    bitfieldAlignment
                      | Int
    align <- [Int]
    aligns]
        (BitSize, Int) -> GB (BitSize, Int)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([BitSize] -> BitSize
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum [BitSize]
    sizes, [Int] -> Int
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum [Int]
    aligns')

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

    -- compute the size and alignment constraint of a given C declaration
    --
    sizeAlignOf       :: CDecl -> GB (BitSize, Int)
    --
    --  * we make use of the assertion that `extractCompType' can only return a
    --   `DefinedET' when the declaration is a pointer declaration
    --
    sizeAlignOf :: CDecl -> GB (BitSize, Int)
    sizeAlignOf (CDecl specs :: [CDeclSpec]
    specs [(Just declr :: CDeclr
    declr, _, size :: Maybe CExpr
    size)] ats :: 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
    $ "sizeAlignOf: calculating size of constant array not supported."
    sizeAlignOf cdecl :: CDecl
    cdecl  =
      do
        CompType
    ct <- CDecl -> GB CompType
    extractCompType CDecl
    cdecl
        case CompType
    ct of
          ExtType (FunET _ _        ) -> (BitSize, Int) -> GB (BitSize, Int)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CPrimType -> BitSize
    bitSize CPrimType
    CFunPtrPT,
                                                 CPrimType -> Int
    alignment CPrimType
    CFunPtrPT)
          ExtType (IOET  _          ) -> String -> GB (BitSize, Int)
    forall a. String -> a
    interr "GenBind.sizeof: Illegal IO type!"
          ExtType (PtrET t :: ExtType
    t          )
            | ExtType -> Bool
    isFunExtType ExtType
    t          -> (BitSize, Int) -> GB (BitSize, Int)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CPrimType -> BitSize
    bitSize CPrimType
    CFunPtrPT,
                                                 CPrimType -> Int
    alignment CPrimType
    CFunPtrPT)
            | Bool
    otherwise               -> (BitSize, Int) -> GB (BitSize, Int)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CPrimType -> BitSize
    bitSize CPrimType
    CPtrPT, CPrimType -> Int
    alignment CPrimType
    CPtrPT)
          ExtType (DefinedET _ _    ) -> (BitSize, Int) -> GB (BitSize, Int)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CPrimType -> BitSize
    bitSize CPrimType
    CPtrPT, CPrimType -> Int
    alignment CPrimType
    CPtrPT)
            -- FIXME: The defined type could be a function pointer!!!
          ExtType (PrimET pt :: CPrimType
    pt        ) -> (BitSize, Int) -> GB (BitSize, Int)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CPrimType -> BitSize
    bitSize CPrimType
    pt, CPrimType -> Int
    alignment CPrimType
    pt)
          ExtType UnitET              -> Position -> GB (BitSize, Int)
    forall a. Position -> GB a
    voidFieldErr (CDecl -> Position
    forall a. Pos a => a -> Position
    posOf CDecl
    cdecl)
          SUType su :: CStructUnion
    su                   ->
            do
              let (fields :: [CDecl]
    fields, tag :: CStructTag
    tag) = CStructUnion -> ([CDecl], CStructTag)
    structMembers CStructUnion
    su
              [CDecl]
    fields' <- let ide :: Maybe Ident
    ide = CStructUnion -> Maybe Ident
    structName CStructUnion
    su
                         in
                         if (Bool -> Bool
    not (Bool -> Bool) -> ([CDecl] -> Bool) -> [CDecl] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [CDecl] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null ([CDecl] -> Bool) -> [CDecl] -> Bool
    forall a b. (a -> b) -> a -> b
    $ [CDecl]
    fields) Bool -> Bool -> Bool
    || Maybe Ident -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe Ident
    ide
                         then [CDecl] -> PreCST SwitchBoard (CState GBState) [CDecl]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [CDecl]
    fields
                         else do                              -- get the real...
                           Maybe CTag
    tag <- Ident -> CT GBState (Maybe CTag)
    forall s. Ident -> CT s (Maybe CTag)
    findTag (Maybe Ident -> Ident
    forall a. HasCallStack => Maybe a -> a
    fromJust Maybe Ident
    ide)      -- ...definition
                           case Maybe CTag
    tag of
                             Just (StructUnionCT su :: CStructUnion
    su) -> [CDecl] -> PreCST SwitchBoard (CState GBState) [CDecl]
    forall (m :: * -> *) a. Monad m => a -> m a
    return
                                                         (([CDecl], CStructTag) -> [CDecl]
    forall a b. (a, b) -> a
    fst (([CDecl], CStructTag) -> [CDecl])
    -> (CStructUnion -> ([CDecl], CStructTag))
    -> CStructUnion
    -> [CDecl]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CStructUnion -> ([CDecl], CStructTag)
    structMembers (CStructUnion -> [CDecl]) -> CStructUnion -> [CDecl]
    forall a b. (a -> b) -> a -> b
    $ CStructUnion
    su)
                             _                       -> [CDecl] -> PreCST SwitchBoard (CState GBState) [CDecl]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [CDecl]
    fields
              [CDecl] -> CStructTag -> GB (BitSize, Int)
    sizeAlignOfStructPad [CDecl]
    fields' CStructTag
    tag
      where
        bitSize :: CPrimType -> BitSize
    bitSize et :: CPrimType
    et | Int
    sz Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < 0    = Int -> Int -> BitSize
    BitSize 0  (-Int
    sz)   -- size is in bits
                   | Bool
    otherwise = Int -> Int -> BitSize
    BitSize Int
    sz 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 octetOffset :: Int
    octetOffset bitOffset :: Int
    bitOffset) align :: Int
    align
      | Int
    align Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > 0 Bool -> Bool -> Bool
    && Int
    bitOffset Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    /= 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
    + 7) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` 8) 0) Int
    align
      | Int
    align Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > 0 Bool -> Bool -> Bool
    && Int
    bitOffset Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 0 =               -- no bitfields involved
        Int -> Int -> BitSize
    BitSize (((Int
    octetOffset Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - 1) Int -> Int -> Int
    forall a. Integral a => a -> a -> a
    `div` Int
    align Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + 1) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    align) 0
      | Int
    bitOffset Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 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
    * 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 _ at :: Attrs
    at) =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr (Attrs -> Position
    forall a. Pos a => a -> Position
    posOf Attrs
    at) "a comma expression"
    evalConstCExpr (CAssign _ _ _ at :: Attrs
    at) =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr (Attrs -> Position
    forall a. Pos a => a -> Position
    posOf Attrs
    at) "an assignment"
    evalConstCExpr (CCond b :: CExpr
    b (Just t :: CExpr
    t) e :: CExpr
    e _) =
      do
        ConstResult
    bv <- CExpr -> GB ConstResult
    evalConstCExpr CExpr
    b
        case ConstResult
    bv of
          IntResult bvi :: Integer
    bvi  -> if Integer
    bvi Integer -> Integer -> Bool
    forall a. Eq a => a -> a -> Bool
    /= 0 then CExpr -> GB ConstResult
    evalConstCExpr CExpr
    t else CExpr -> GB ConstResult
    evalConstCExpr CExpr
    e
          FloatResult _ -> Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr (CExpr -> Position
    forall a. Pos a => a -> Position
    posOf CExpr
    b) "a float result"
    evalConstCExpr (CBinary op :: CBinaryOp
    op lhs :: CExpr
    lhs rhs :: CExpr
    rhs at :: Attrs
    at) =
      do
        ConstResult
    lhsVal <- CExpr -> GB ConstResult
    evalConstCExpr CExpr
    lhs
        ConstResult
    rhsVal <- CExpr -> GB ConstResult
    evalConstCExpr CExpr
    rhs
        let (lhsVal' :: ConstResult
    lhsVal', rhsVal' :: 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 _ _ _) =
      String -> GB ConstResult
    forall a. String -> a
    todo "GenBind.evalConstCExpr: Casts are not implemented yet."
    evalConstCExpr (CUnary op :: CUnaryOp
    op arg :: CExpr
    arg at :: 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 _ _) =
      String -> GB ConstResult
    forall a. String -> a
    todo "GenBind.evalConstCExpr: sizeof not implemented yet."
    evalConstCExpr (CSizeofType decl :: CDecl
    decl _) =
      do
        (size :: BitSize
    size, _) <- CDecl -> GB (BitSize, Int)
    sizeAlignOf CDecl
    decl
        ConstResult -> GB ConstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
    forall a b. (a -> b) -> a -> b
    $ Integer -> ConstResult
    IntResult (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Integer) -> (BitSize -> Int) -> BitSize -> Integer
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BitSize -> Int
    padBits (BitSize -> Integer) -> BitSize -> Integer
    forall a b. (a -> b) -> a -> b
    $ BitSize
    size)
    evalConstCExpr (CAlignofExpr _ _) =
      String -> GB ConstResult
    forall a. String -> a
    todo "GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet."
    evalConstCExpr (CAlignofType decl :: CDecl
    decl _) =
      do
        (_, align :: Int
    align) <- CDecl -> GB (BitSize, Int)
    sizeAlignOf CDecl
    decl
        ConstResult -> GB ConstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ConstResult -> GB ConstResult) -> ConstResult -> GB ConstResult
    forall a b. (a -> b) -> a -> b
    $ Integer -> ConstResult
    IntResult (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    align)
    evalConstCExpr (CIndex _ _ at :: Attrs
    at) =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr (Attrs -> Position
    forall a. Pos a => a -> Position
    posOf Attrs
    at) "array indexing"
    evalConstCExpr (CCall _ _ at :: Attrs
    at) =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr (Attrs -> Position
    forall a. Pos a => a -> Position
    posOf Attrs
    at) "function call"
    evalConstCExpr (CMember _ _ _ at :: Attrs
    at) =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr (Attrs -> Position
    forall a. Pos a => a -> Position
    posOf Attrs
    at) "a . or -> operator"
    evalConstCExpr (CVar ide :: Ident
    ide at :: Attrs
    at) =
      do
        (cobj :: CObj
    cobj, _) <- Ident -> Bool -> CT GBState (CObj, Ident)
    forall s. Ident -> Bool -> CT s (CObj, Ident)
    findValueObj Ident
    ide Bool
    False
        case CObj
    cobj of
          EnumCO ide :: Ident
    ide (CEnum _ enumrs :: [(Ident, Maybe CExpr)]
    enumrs _) -> (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 0
          _                             ->
            String -> GB ConstResult
    forall a. String -> a
    todo (String -> GB ConstResult) -> String -> GB ConstResult
    forall a b. (a -> b) -> a -> b
    $ "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 _   []                     _   =
          String -> PreCST SwitchBoard (CState GBState) Integer
    forall a. String -> a
    interr "GenBind.enumTagValue: enumerator not in declaration"
        enumTagValue ide :: t
    ide ((ide' :: t
    ide', oexpr :: Maybe CExpr
    oexpr):enumrs :: [(t, Maybe CExpr)]
    enumrs) val :: Integer
    val =
          do
            Integer
    val' <- case Maybe CExpr
    oexpr of
                      Nothing  -> Integer -> PreCST SwitchBoard (CState GBState) Integer
    forall (m :: * -> *) a. Monad m => a -> m a
    return Integer
    val
                      Just exp :: CExpr
    exp ->
                        do
                          ConstResult
    val' <- CExpr -> GB ConstResult
    evalConstCExpr CExpr
    exp
                          case ConstResult
    val' of
                            IntResult val' :: Integer
    val' -> Integer -> PreCST SwitchBoard (CState GBState) Integer
    forall (m :: * -> *) a. Monad m => a -> m a
    return Integer
    val'
                            FloatResult _  ->
                              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) "a float result"
            if t
    ide t -> t -> Bool
    forall a. Eq a => a -> a -> Bool
    == t
    ide'
              then                  -- found the right enumerator
                Integer -> PreCST SwitchBoard (CState GBState) Integer
    forall (m :: * -> *) a. Monad m => a -> m a
    return Integer
    val'
              else                  -- continue down the enumerator list
                t
    -> [(t, Maybe CExpr)]
    -> Integer
    -> PreCST SwitchBoard (CState GBState) Integer
    enumTagValue t
    ide [(t, Maybe CExpr)]
    enumrs (Integer
    val' Integer -> Integer -> Integer
    forall a. Num a => a -> a -> a
    + 1)
    evalConstCExpr (CConst c :: CConst
    c _) =
      CConst -> GB ConstResult
    evalCConst CConst
    c

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

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

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

    applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult
    applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult
    applyUnary cpos :: Position
    cpos CPreIncOp  _               =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr Position
    cpos "a ++ operator"
    applyUnary cpos :: Position
    cpos CPreDecOp  _               =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr Position
    cpos "a -- operator"
    applyUnary cpos :: Position
    cpos CPostIncOp _               =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr Position
    cpos "a ++ operator"
    applyUnary cpos :: Position
    cpos CPostDecOp _               =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr Position
    cpos "a -- operator"
    applyUnary cpos :: Position
    cpos CAdrOp     _               =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr Position
    cpos "a & operator"
    applyUnary cpos :: Position
    cpos CIndOp     _               =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr Position
    cpos "a * operator"
    applyUnary cpos :: Position
    cpos CPlusOp    arg :: ConstResult
    arg             = ConstResult -> GB ConstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return ConstResult
    arg
    applyUnary cpos :: Position
    cpos CMinOp     (IntResult   x :: Integer
    x) = ConstResult -> GB ConstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Integer -> ConstResult
    IntResult (-Integer
    x))
    applyUnary cpos :: Position
    cpos CMinOp     (FloatResult x :: Float
    x) = ConstResult -> GB ConstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Float -> ConstResult
    FloatResult (-Float
    x))
    applyUnary cpos :: Position
    cpos CCompOp    (IntResult   x :: Integer
    x) = ConstResult -> GB ConstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Integer -> ConstResult
    IntResult (Integer -> Integer
    forall a. Bits a => a -> a
    complement Integer
    x))
    applyUnary cpos :: Position
    cpos CNegOp     (IntResult   x :: 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
    == 0)
      in ConstResult -> GB ConstResult
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Integer -> ConstResult
    IntResult Integer
    r)
    applyUnary cpos :: Position
    cpos CNegOp     (FloatResult _) =
      Position -> String -> GB ConstResult
    forall a. Position -> String -> GB a
    illegalConstExprErr Position
    cpos "! applied to a float"

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

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

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

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

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

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

    unknownFieldErr          :: Position -> Ident -> GB a
    unknownFieldErr :: Position -> Ident -> GB a
    unknownFieldErr cpos :: Position
    cpos ide :: Ident
    ide  =
      Position -> [String] -> GB a
    forall s a. Position -> [String] -> CT s a
    raiseErrorCTExc (Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    ide)
        ["Unknown member name!",
         "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]
    ++ "'.  The structure is defined at",
         Position -> String
    forall a. Show a => a -> String
    show Position
    cpos String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "."]

    illegalStructUnionErr          :: Position -> Position -> GB a
    illegalStructUnionErr :: Position -> Position -> GB a
    illegalStructUnionErr cpos :: Position
    cpos pos :: Position
    pos  =
      Position -> [String] -> GB a
    forall s a. Position -> [String] -> CT s a
    raiseErrorCTExc Position
    pos
        ["Illegal structure or union type!",
         "There is not automatic support for marshaling of structures and",
         "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]
    ++ "."]

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

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

    variadicErr          :: Position -> Position -> GB a
    variadicErr :: Position -> Position -> GB a
    variadicErr pos :: Position
    pos cpos :: Position
    cpos  =
      Position -> [String] -> GB a
    forall s a. Position -> [String] -> CT s a
    raiseErrorCTExc Position
    pos
        ["Variadic function!",
         "Calling variadic functions is not supported by the FFI; the function",
         "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]
    ++ "."]

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

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

    structExpectedErr     :: Ident -> GB a
    structExpectedErr :: Ident -> GB a
    structExpectedErr ide :: Ident
    ide  =
      Position -> [String] -> GB a
    forall s a. Position -> [String] -> CT s a
    raiseErrorCTExc (Ident -> Position
    forall a. Pos a => a -> Position
    posOf Ident
    ide)
        ["Expected a structure or union!",
         "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]
    ++ "' in something not",
         "a structure or union."]

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

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

    pointerTypeMismatchErr :: Position -> String -> String -> GB a
    pointerTypeMismatchErr :: Position -> String -> String -> GB a
    pointerTypeMismatchErr pos :: Position
    pos className :: String
    className superName :: String
    superName =
      Position -> [String] -> GB a
    forall s a. Position -> [String] -> CT s a
    raiseErrorCTExc Position
    pos
        ["Pointer type mismatch!",
         "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]
    ++ "' is of a different kind",
         "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]
    ++ "'; this is illegal",
         "as the latter is defined to be an (indirect) superclass of the former."]

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

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

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

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

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

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