module GenBind (expandHooks)
where
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)
import Position (Position, Pos(posOf), nopos, builtinPos)
import Errors (interr, todo)
import Idents (Ident, identToLexeme, onlyPosIdent)
import Attributes (newAttrsOnlyPos)
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(..))
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)
lookupDftMarshIn :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshIn :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshIn String
"Bool" [PrimET CPrimType
pt] | CPrimType -> Bool
isIntegralCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
cFromBoolIde, CHSArg
CHSValArg)
lookupDftMarshIn String
hsTy [PrimET CPrimType
pt] | String -> Bool
isIntegralHsType String
hsTy
Bool -> Bool -> Bool
&&CPrimType -> Bool
isIntegralCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
cIntConvIde, CHSArg
CHSValArg)
lookupDftMarshIn String
hsTy [PrimET CPrimType
pt] | String -> Bool
isFloatHsType String
hsTy
Bool -> Bool -> Bool
&&CPrimType -> Bool
isFloatCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
cFloatConvIde, CHSArg
CHSValArg)
lookupDftMarshIn String
"String" [PtrET (PrimET CPrimType
CCharPT)] =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
withCStringIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
"String" [PtrET (PrimET CPrimType
CCharPT), PrimET CPrimType
pt]
| CPrimType -> Bool
isIntegralCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
withCStringLenIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
hsTy [PtrET ExtType
ty] | ExtType -> String
showExtType ExtType
ty forall a. Eq a => a -> a -> Bool
== String
hsTy =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
withIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
hsTy [PtrET (PrimET CPrimType
pt)]
| String -> Bool
isIntegralHsType String
hsTy Bool -> Bool -> Bool
&& CPrimType -> Bool
isIntegralCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
withIntConvIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
hsTy [PtrET (PrimET CPrimType
pt)]
| String -> Bool
isFloatHsType String
hsTy Bool -> Bool -> Bool
&& CPrimType -> Bool
isFloatCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
withFloatConvIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
"Bool" [PtrET (PrimET CPrimType
pt)]
| CPrimType -> Bool
isIntegralCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
withFromBoolIde, CHSArg
CHSIOArg)
lookupDftMarshIn String
_ [ExtType]
_ =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
lookupDftMarshOut :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshOut :: String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshOut String
"()" [ExtType]
_ =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
voidIde, CHSArg
CHSVoidArg)
lookupDftMarshOut String
"Bool" [PrimET CPrimType
pt] | CPrimType -> Bool
isIntegralCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
cToBoolIde, CHSArg
CHSValArg)
lookupDftMarshOut String
hsTy [PrimET CPrimType
pt] | String -> Bool
isIntegralHsType String
hsTy
Bool -> Bool -> Bool
&&CPrimType -> Bool
isIntegralCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
cIntConvIde, CHSArg
CHSValArg)
lookupDftMarshOut String
hsTy [PrimET CPrimType
pt] | String -> Bool
isFloatHsType String
hsTy
Bool -> Bool -> Bool
&&CPrimType -> Bool
isFloatCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
cFloatConvIde, CHSArg
CHSValArg)
lookupDftMarshOut String
"String" [PtrET (PrimET CPrimType
CCharPT)] =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
peekCStringIde, CHSArg
CHSIOArg)
lookupDftMarshOut String
"String" [PtrET (PrimET CPrimType
CCharPT), PrimET CPrimType
pt]
| CPrimType -> Bool
isIntegralCPrimType CPrimType
pt =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
peekCStringLenIde, CHSArg
CHSIOArg)
lookupDftMarshOut String
hsTy [PtrET ExtType
ty] | ExtType -> String
showExtType ExtType
ty forall a. Eq a => a -> a -> Bool
== String
hsTy =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Ident
peekIde, CHSArg
CHSIOArg)
lookupDftMarshOut String
_ [ExtType]
_ =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
isIntegralHsType :: String -> Bool
isIntegralHsType :: String -> Bool
isIntegralHsType String
"Int" = Bool
True
isIntegralHsType String
"Int8" = Bool
True
isIntegralHsType String
"Int16" = Bool
True
isIntegralHsType String
"Int32" = Bool
True
isIntegralHsType String
"Int64" = Bool
True
isIntegralHsType String
"Word8" = Bool
True
isIntegralHsType String
"Word16" = Bool
True
isIntegralHsType String
"Word32" = Bool
True
isIntegralHsType String
"Word64" = Bool
True
isIntegralHsType String
_ = Bool
False
isFloatHsType :: String -> Bool
isFloatHsType :: String -> Bool
isFloatHsType String
"Float" = Bool
True
isFloatHsType String
"Double" = Bool
True
isFloatHsType String
_ = Bool
False
isIntegralCPrimType :: CPrimType -> Bool
isIntegralCPrimType :: CPrimType -> Bool
isIntegralCPrimType = (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])
isFloatCPrimType :: CPrimType -> Bool
isFloatCPrimType :: CPrimType -> Bool
isFloatCPrimType = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CPrimType
CFloatPT, CPrimType
CDoublePT, CPrimType
CLDoublePT])
voidIde :: Ident
voidIde = String -> Ident
noPosIdent String
"void"
cFromBoolIde :: Ident
cFromBoolIde = String -> Ident
noPosIdent String
"cFromBool"
cToBoolIde :: Ident
cToBoolIde = String -> Ident
noPosIdent String
"cToBool"
cIntConvIde :: Ident
cIntConvIde = String -> Ident
noPosIdent String
"cIntConv"
cFloatConvIde :: Ident
cFloatConvIde = String -> Ident
noPosIdent String
"cFloatConv"
withIde :: Ident
withIde = String -> Ident
noPosIdent String
"with"
withCStringIde :: Ident
withCStringIde = String -> Ident
noPosIdent String
"withCString"
withCStringLenIde :: Ident
withCStringLenIde = String -> Ident
noPosIdent String
"withCStringLenIntConv"
withIntConvIde :: Ident
withIntConvIde = String -> Ident
noPosIdent String
"withIntConv"
withFloatConvIde :: Ident
withFloatConvIde = String -> Ident
noPosIdent String
"withFloatConv"
withFromBoolIde :: Ident
withFromBoolIde = String -> Ident
noPosIdent String
"withFromBoolConv"
peekIde :: Ident
peekIde = String -> Ident
noPosIdent String
"peek"
peekCStringIde :: Ident
peekCStringIde = String -> Ident
noPosIdent String
"peekCString"
peekCStringLenIde :: Ident
peekCStringLenIde = String -> Ident
noPosIdent String
"peekCStringLenIntConv"
expandHooks :: AttrC -> CHSModule -> CST s (CHSModule, String, String)
expandHooks :: forall s. AttrC -> CHSModule -> CST s (CHSModule, String, String)
expandHooks AttrC
ac CHSModule
mod = do
Maybe String
mLock <- forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Maybe String
lockFunSB
(AttrC
_, (CHSModule, String, String)
res) <- forall s a t. CT s a -> AttrC -> s -> CST t (AttrC, a)
runCT (CHSModule -> GB (CHSModule, String, String)
expandModule CHSModule
mod) AttrC
ac (Maybe String -> GBState
initialGBState Maybe String
mLock)
forall (m :: * -> *) a. Monad m => a -> m a
return (CHSModule, String, String)
res
expandModule :: CHSModule -> GB (CHSModule, String, String)
expandModule :: CHSModule -> GB (CHSModule, String, String)
expandModule (CHSModule [CHSFrag]
frags) =
do
forall {s}. CST s ()
traceInfoExpand
[CHSFrag]
frags' <- [CHSFrag] -> GB [CHSFrag]
expandFrags [CHSFrag]
frags
[CHSFrag]
delayedFrags <- GB [CHSFrag]
getDelayedCode
String
chi <- GB String
dumpMaps
Bool
errs <- forall e s. PreCST e s Bool
errorsPresent
if Bool
errs
then do
forall {s}. CST s ()
traceInfoErr
String
errmsgs <- forall e s. PreCST e s String
showErrors
forall e s a. String -> PreCST e s a
fatal (String
"Errors during expansion of binding hooks:\n\n"
forall a. [a] -> [a] -> [a]
++ String
errmsgs)
else do
forall {s}. CST s ()
traceInfoOK
String
warnmsgs <- forall e s. PreCST e s String
showErrors
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSFrag] -> CHSModule
CHSModule ([CHSFrag]
frags' forall a. [a] -> [a] -> [a]
++ [CHSFrag]
delayedFrags), String
chi, String
warnmsgs)
where
traceInfoExpand :: CST s ()
traceInfoExpand = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"...expanding binding hooks...\n")
traceInfoErr :: CST s ()
traceInfoErr = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"...error(s) detected.\n")
traceInfoOK :: CST s ()
traceInfoOK = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
tracePhasesSW
(String
"...successfully completed.\n")
expandFrags :: [CHSFrag] -> GB [CHSFrag]
expandFrags :: [CHSFrag] -> GB [CHSFrag]
expandFrags = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CHSFrag -> GB [CHSFrag]
expandFrag
expandFrag :: CHSFrag -> GB [CHSFrag]
expandFrag :: CHSFrag -> GB [CHSFrag]
expandFrag verb :: CHSFrag
verb@(CHSVerb String
_ Position
_ ) = forall (m :: * -> *) a. Monad m => a -> m a
return [CHSFrag
verb]
expandFrag line :: CHSFrag
line@(CHSLine Position
_ ) = forall (m :: * -> *) a. Monad m => a -> m a
return [CHSFrag
line]
expandFrag prag :: CHSFrag
prag@(CHSLang [String]
_ Position
_ ) = forall (m :: * -> *) a. Monad m => a -> m a
return [CHSFrag
prag]
expandFrag (CHSHook CHSHook
h ) =
do
String
code <- CHSHook -> GB String
expandHook CHSHook
h
forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Position -> CHSFrag
CHSVerb String
code Position
builtinPos]
forall s a. CT s a -> CT s a -> CT s a
`ifCTExc` forall (m :: * -> *) a. Monad m => a -> m a
return [String -> Position -> CHSFrag
CHSVerb String
"** ERROR **" Position
builtinPos]
expandFrag (CHSCPP String
s Position
_ ) =
forall a. String -> a
interr forall a b. (a -> b) -> a -> b
$ String
"GenBind.expandFrag: Left over CHSCPP!\n---\n" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"\n---"
expandFrag (CHSC String
s Position
_ ) =
forall a. String -> a
interr forall a b. (a -> b) -> a -> b
$ String
"GenBind.expandFrag: Left over CHSC!\n---\n" forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"\n---"
expandFrag (CHSCond [(Ident, [CHSFrag])]
alts Maybe [CHSFrag]
dft) =
do
GB ()
traceInfoCond
[(Ident, [CHSFrag])] -> GB [CHSFrag]
select [(Ident, [CHSFrag])]
alts
where
select :: [(Ident, [CHSFrag])] -> GB [CHSFrag]
select [] = do
forall {a}. Maybe a -> GB ()
traceInfoDft Maybe [CHSFrag]
dft
[CHSFrag] -> GB [CHSFrag]
expandFrags (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. a -> a
id Maybe [CHSFrag]
dft)
select ((Ident
ide, [CHSFrag]
frags):[(Ident, [CHSFrag])]
alts) = do
Maybe CTag
oobj <- forall s. Ident -> CT s (Maybe CTag)
findTag Ident
ide
forall {a}. Ident -> Maybe a -> GB ()
traceInfoVal Ident
ide Maybe CTag
oobj
if forall a. Maybe a -> Bool
isNothing Maybe CTag
oobj
then
[(Ident, [CHSFrag])] -> GB [CHSFrag]
select [(Ident, [CHSFrag])]
alts
else
[CHSFrag] -> GB [CHSFrag]
expandFrags [CHSFrag]
frags
traceInfoCond :: GB ()
traceInfoCond = String -> GB ()
traceGenBind String
"** CPP conditional:\n"
traceInfoVal :: Ident -> Maybe a -> GB ()
traceInfoVal Ident
ide Maybe a
oobj = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$ Ident -> String
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
" is " forall a. [a] -> [a] -> [a]
++
(if forall a. Maybe a -> Bool
isNothing Maybe a
oobj then String
"not " else String
"") forall a. [a] -> [a] -> [a]
++
String
"defined.\n"
traceInfoDft :: Maybe a -> GB ()
traceInfoDft Maybe a
dft = if forall a. Maybe a -> Bool
isNothing Maybe a
dft
then
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else
String -> GB ()
traceGenBind String
"Choosing else branch.\n"
expandHook :: CHSHook -> GB String
expandHook :: CHSHook -> GB String
expandHook (CHSImport Bool
qual Ident
ide String
chi Position
_) =
do
String -> GB ()
mergeMaps String
chi
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
String
"import " forall a. [a] -> [a] -> [a]
++ (if Bool
qual then String
"qualified " else String
"") forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide
expandHook (CHSContext Maybe String
olib Maybe String
oprefix Maybe String
olock Position
_) =
do
Maybe String -> Maybe String -> Maybe String -> GB ()
setContext Maybe String
olib Maybe String
oprefix Maybe String
olock
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ forall s. String -> CT s ()
applyPrefixToNameSpaces Maybe String
oprefix
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
expandHook (CHSType Ident
ide Position
pos) =
do
GB ()
traceInfoType
CDecl
decl <- forall s. Ident -> Bool -> Bool -> CT s CDecl
findAndChaseDecl Ident
ide Bool
False Bool
True
ExtType
ty <- Position -> CDecl -> GB ExtType
extractSimpleType Position
pos CDecl
decl
forall {a}. Show a => a -> ExtType -> GB ()
traceInfoDump CDecl
decl ExtType
ty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"(" forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
ty forall a. [a] -> [a] -> [a]
++ String
")"
where
traceInfoType :: GB ()
traceInfoType = String -> GB ()
traceGenBind String
"** Type hook:\n"
traceInfoDump :: a -> ExtType -> GB ()
traceInfoDump a
decl ExtType
ty = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"Declaration\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
decl forall a. [a] -> [a] -> [a]
++ String
"\ntranslates to\n"
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
ty forall a. [a] -> [a] -> [a]
++ String
"\n"
expandHook (CHSSizeof Ident
ide Position
pos) =
do
GB ()
traceInfoSizeof
CDecl
decl <- forall s. Ident -> Bool -> Bool -> CT s CDecl
findAndChaseDecl Ident
ide Bool
False Bool
True
(BitSize
size, Int
_) <- CDecl -> GB (BitSize, Int)
sizeAlignOf CDecl
decl
forall {a}. Show a => a -> BitSize -> GB ()
traceInfoDump CDecl
decl BitSize
size
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitSize -> Int
padBits forall a b. (a -> b) -> a -> b
$ BitSize
size)
where
traceInfoSizeof :: GB ()
traceInfoSizeof = String -> GB ()
traceGenBind String
"** Sizeof hook:\n"
traceInfoDump :: a -> BitSize -> GB ()
traceInfoDump a
decl BitSize
size = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"Size of declaration\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
decl forall a. [a] -> [a] -> [a]
++ String
"\nis "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitSize -> Int
padBits forall a b. (a -> b) -> a -> b
$ BitSize
size) forall a. [a] -> [a] -> [a]
++ String
"\n"
expandHook (CHSEnum Ident
cide Maybe Ident
oalias CHSTrans
chsTrans Maybe String
oprefix [Ident]
derive Position
_) =
do
CEnum
enum <- forall s. Ident -> Bool -> CT s CEnum
lookupEnum Ident
cide Bool
True
String
gprefix <- GB String
getPrefix
let prefix :: String
prefix = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe Ident
cide 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 (forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
identToLexeme [Ident]
derive)
expandHook hook :: CHSHook
hook@(CHSCall Bool
isPure Bool
isUns Bool
isNol Ident
ide Maybe Ident
oalias Position
pos) =
do
GB ()
traceEnter
(ObjCO CDecl
cdecl, Ident
ide) <- forall s. Ident -> Bool -> CT s (CObj, Ident)
findFunObj Ident
ide Bool
True
Maybe String
mLock <- if Bool
isNol then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing else GB (Maybe String)
getLock
let ideLexeme :: String
ideLexeme = Ident -> String
identToLexeme Ident
ide
hsLexeme :: String
hsLexeme = String
ideLexeme forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` Ident -> String
identToLexeme 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 :: GB ()
traceEnter = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"** Call hook for `" forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
"':\n"
expandHook hook :: CHSHook
hook@(CHSFun Bool
isPure Bool
isUns Bool
isNol Ident
ide Maybe Ident
oalias Maybe String
ctxt [CHSParm]
parms CHSParm
parm Position
pos) =
do
GB ()
traceEnter
(ObjCO CDecl
cdecl, Ident
cide) <- forall s. Ident -> Bool -> CT s (CObj, Ident)
findFunObj Ident
ide Bool
True
Maybe String
mLock <- if Bool
isNol then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing else GB (Maybe String)
getLock
let ideLexeme :: String
ideLexeme = Ident -> String
identToLexeme Ident
ide
hsLexeme :: String
hsLexeme = String
ideLexeme forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` Ident -> String
identToLexeme forall a b. (a -> b) -> a -> b
$ Maybe Ident
oalias
fiLexeme :: String
fiLexeme = String
hsLexeme forall a. [a] -> [a] -> [a]
++ String
"'_"
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 (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 :: GB ()
traceEnter = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"** Fun hook for `" forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
"':\n"
expandHook (CHSField CHSAccess
access CHSAPath
path Position
pos) =
do
GB ()
traceInfoField
(CDecl
decl, [BitSize]
offsets) <- CHSAPath -> GB (CDecl, [BitSize])
accessPath CHSAPath
path
forall {t :: * -> *} {a}. Foldable t => t a -> GB ()
traceDepth [BitSize]
offsets
ExtType
ty <- Position -> CDecl -> GB ExtType
extractSimpleType Position
pos CDecl
decl
ExtType -> GB ()
traceValueType ExtType
ty
Position -> CHSAccess -> [BitSize] -> ExtType -> GB String
setGet Position
pos CHSAccess
access [BitSize]
offsets ExtType
ty
where
accessString :: String
accessString = case CHSAccess
access of
CHSAccess
CHSGet -> String
"Get"
CHSAccess
CHSSet -> String
"Set"
traceInfoField :: GB ()
traceInfoField = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$ String
"** " forall a. [a] -> [a] -> [a]
++ String
accessString forall a. [a] -> [a] -> [a]
++ String
" hook:\n"
traceDepth :: t a -> GB ()
traceDepth t a
offsets = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$ String
"Depth of access path: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
offsets) forall a. [a] -> [a] -> [a]
++ String
"\n"
traceValueType :: ExtType -> GB ()
traceValueType ExtType
et = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"Type of accessed value: " forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
et forall a. [a] -> [a] -> [a]
++ String
"\n"
expandHook (CHSPointer Bool
isStar Ident
cName Maybe Ident
oalias CHSPtrType
ptrKind Bool
isNewtype Maybe Ident
oRefType Position
pos) =
do
GB ()
traceInfoPointer
let hsIde :: Ident
hsIde = forall a. a -> Maybe a -> a
fromMaybe Ident
cName Maybe Ident
oalias
hsName :: String
hsName = Ident -> String
identToLexeme Ident
hsIde
Ident
hsIde Ident -> HsObject -> GB ()
`objIs` CHSPtrType -> Bool -> HsObject
Pointer CHSPtrType
ptrKind Bool
isNewtype
Either CDecl CTag
declOrTag <- forall s. Ident -> Bool -> CT s (Either CDecl CTag)
lookupDeclOrTag Ident
cName Bool
True
case Either CDecl CTag
declOrTag of
Left CDecl
cdecl -> do
Ident
cNameFull <- case CDecl -> Maybe Ident
declaredName CDecl
cdecl of
Just Ident
ide -> forall (m :: * -> *) a. Monad m => a -> m a
return Ident
ide
Maybe Ident
Nothing -> forall a. String -> a
interr
String
"GenBind.expandHook: Where is the name?"
Ident
cNameFull forall s. Ident -> CDef -> CT s ()
`refersToNewDef` CObj -> CDef
ObjCD (CDecl -> CObj
TypeCO CDecl
cdecl)
String -> Ident -> GB ()
traceInfoCName String
"declaration" Ident
cNameFull
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isStar Bool -> Bool -> Bool
|| CDecl -> Bool
isPtrDecl CDecl
cdecl) forall a b. (a -> b) -> a -> b
$
forall a. Position -> GB a
ptrExpectedErr (forall a. Pos a => a -> Position
posOf Ident
cName)
(String
hsType, Bool
isFun) <-
case Maybe Ident
oRefType of
Maybe Ident
Nothing -> do
CDecl
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
forall (m :: * -> *) a. Monad m => a -> m a
return (ExtType -> String
showExtType ExtType
et', ExtType -> Bool
isFunExtType ExtType
et')
Just Ident
hsType -> forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> String
identToLexeme Ident
hsType, Bool
False)
String -> String -> GB ()
traceInfoHsType String
hsName String
hsType
Ident
realCName <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Ident
cName forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall s. Ident -> CT s (Maybe (CObj, Ident))
findObjShadow Ident
cName
Bool
-> Ident
-> String
-> CHSPtrType
-> Bool
-> String
-> Bool
-> GB String
pointerDef Bool
isStar Ident
realCName String
hsName CHSPtrType
ptrKind Bool
isNewtype String
hsType Bool
isFun
Right CTag
tag -> do
let cNameFull :: Ident
cNameFull = CTag -> Ident
tagName CTag
tag
String -> Ident -> GB ()
traceInfoCName String
"tag definition" Ident
cNameFull
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isStar forall a b. (a -> b) -> a -> b
$
forall a. Position -> GB a
ptrExpectedErr (forall a. Pos a => a -> Position
posOf Ident
cName)
let hsType :: String
hsType = case Maybe Ident
oRefType of
Maybe Ident
Nothing -> String
"()"
Just Ident
hsType -> Ident -> String
identToLexeme Ident
hsType
String -> String -> GB ()
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
adjustPtr :: Bool -> ExtType -> ExtType
adjustPtr Bool
True ExtType
et = ExtType
et
adjustPtr Bool
False (PtrET ExtType
et) = ExtType
et
adjustPtr Bool
_ ExtType
_ = forall a. String -> a
interr String
"GenBind.adjustPtr: Where is the Ptr?"
traceInfoPointer :: GB ()
traceInfoPointer = String -> GB ()
traceGenBind String
"** Pointer hook:\n"
traceInfoCName :: String -> Ident -> GB ()
traceInfoCName String
kind Ident
ide = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"found C " forall a. [a] -> [a] -> [a]
++ String
kind forall a. [a] -> [a] -> [a]
++ String
" for `" forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
"'\n"
traceInfoHsType :: String -> String -> GB ()
traceInfoHsType String
name String
ty = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"associated with Haskell entity `" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"'\nhaving type " forall a. [a] -> [a] -> [a]
++ String
ty
forall a. [a] -> [a] -> [a]
++ String
"\n"
expandHook (CHSClass Maybe Ident
oclassIde Ident
classIde Ident
typeIde Position
pos) =
do
GB ()
traceInfoClass
Ident
classIde Ident -> HsObject -> GB ()
`objIs` Maybe Ident -> Ident -> HsObject
Class Maybe Ident
oclassIde Ident
typeIde
[(String, String, HsObject)]
superClasses <- Maybe Ident -> GB [(String, String, HsObject)]
collectClasses Maybe Ident
oclassIde
Pointer CHSPtrType
ptrType Bool
isNewtype <- Ident -> GB HsObject
queryPointer Ident
typeIde
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CHSPtrType
ptrType forall a. Eq a => a -> a -> Bool
== CHSPtrType
CHSStablePtr) forall a b. (a -> b) -> a -> b
$
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
collectClasses :: Maybe Ident -> GB [(String, String, HsObject)]
collectClasses :: Maybe Ident -> GB [(String, String, HsObject)]
collectClasses Maybe Ident
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return []
collectClasses (Just Ident
ide) =
do
Class Maybe Ident
oclassIde Ident
typeIde <- Ident -> GB HsObject
queryClass Ident
ide
HsObject
ptr <- Ident -> GB HsObject
queryPointer Ident
typeIde
[(String, String, HsObject)]
classes <- Maybe Ident -> GB [(String, String, HsObject)]
collectClasses Maybe Ident
oclassIde
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Ident -> String
identToLexeme Ident
ide, Ident -> String
identToLexeme Ident
typeIde, HsObject
ptr) forall a. a -> [a] -> [a]
: [(String, String, HsObject)]
classes
traceInfoClass :: GB ()
traceInfoClass = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$ String
"** Class hook:\n"
enumDef :: CEnum -> String -> TransFun -> [String] -> GB String
enumDef :: CEnum -> String -> (Ident -> String) -> [String] -> GB String
enumDef cenum :: CEnum
cenum@(CEnum Maybe Ident
_ [(Ident, Maybe CExpr)]
list Attrs
_) String
hident Ident -> String
trans [String]
userDerive =
do
([(Ident, Maybe CExpr)]
list', Bool
enumAuto) <- forall {a}.
[(a, Maybe CExpr)]
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
evalTagVals [(Ident, Maybe CExpr)]
list
let enumVals :: [(String, Maybe CExpr)]
enumVals = [(Ident -> String
trans Ident
ide, Maybe CExpr
cexpr) | (Ident
ide, Maybe CExpr
cexpr) <- [(Ident, Maybe CExpr)]
list']
defHead :: String
defHead = String -> String
enumHead String
hident
defBody :: String
defBody = Int -> [(String, Maybe CExpr)] -> String
enumBody (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
defHead forall a. Num a => a -> a -> a
- Int
2) [(String, Maybe CExpr)]
enumVals
inst :: String
inst = [String] -> String
makeDerives
(if Bool
enumAuto then String
"Enum" forall a. a -> [a] -> [a]
: [String]
userDerive else [String]
userDerive) forall a. [a] -> [a] -> [a]
++
if Bool
enumAuto then String
"\n" else String
"\n" forall a. [a] -> [a] -> [a]
++ String -> [(String, Maybe CExpr)] -> String
enumInst String
hident [(String, Maybe CExpr)]
enumVals
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
defHead forall a. [a] -> [a] -> [a]
++ String
defBody forall a. [a] -> [a] -> [a]
++ String
inst
where
cpos :: Position
cpos = forall a. Pos a => a -> Position
posOf CEnum
cenum
evalTagVals :: [(a, Maybe CExpr)]
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
evalTagVals [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], Bool
True)
evalTagVals ((a
ide, Maybe CExpr
Nothing ):[(a, Maybe CExpr)]
list) =
do
([(a, Maybe CExpr)]
list', Bool
derived) <- [(a, Maybe CExpr)]
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
evalTagVals [(a, Maybe CExpr)]
list
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
ide, forall a. Maybe a
Nothing)forall a. a -> [a] -> [a]
:[(a, Maybe CExpr)]
list', Bool
derived)
evalTagVals ((a
ide, Just CExpr
exp):[(a, Maybe CExpr)]
list) =
do
([(a, Maybe CExpr)]
list', Bool
derived) <- [(a, Maybe CExpr)]
-> PreCST SwitchBoard (CState GBState) ([(a, Maybe CExpr)], Bool)
evalTagVals [(a, Maybe CExpr)]
list
ConstResult
val <- CExpr -> GB ConstResult
evalConstCExpr CExpr
exp
case ConstResult
val of
IntResult Integer
val' ->
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
ide, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CConst -> Attrs -> CExpr
CConst (Integer -> Attrs -> CConst
CIntConst Integer
val' Attrs
at1) Attrs
at2)forall a. a -> [a] -> [a]
:[(a, Maybe CExpr)]
list',
Bool
False)
FloatResult Float
_ ->
forall a. Position -> String -> GB a
illegalConstExprErr (forall a. Pos a => a -> Position
posOf CExpr
exp) String
"a float result"
where
at1 :: Attrs
at1 = Position -> Attrs
newAttrsOnlyPos Position
nopos
at2 :: Attrs
at2 = Position -> Attrs
newAttrsOnlyPos Position
nopos
makeDerives :: [String] -> String
makeDerives [] = String
""
makeDerives [String]
dList = String
"deriving (" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
"," [String]
dList) forall a. [a] -> [a] -> [a]
++String
")"
enumHead :: String -> String
enumHead :: String -> String
enumHead String
ident = String
"data " forall a. [a] -> [a] -> [a]
++ String
ident forall a. [a] -> [a] -> [a]
++ String
" = "
enumBody :: Int -> [(String, Maybe CExpr)] -> String
enumBody :: Int -> [(String, Maybe CExpr)] -> String
enumBody Int
indent [] = String
""
enumBody Int
indent ((String
ide, Maybe CExpr
_):[(String, Maybe CExpr)]
list) =
String
ide forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate Int
indent Char
' '
forall a. [a] -> [a] -> [a]
++ (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Maybe CExpr)]
list then String
"" else String
"| " forall a. [a] -> [a] -> [a]
++ Int -> [(String, Maybe CExpr)] -> String
enumBody Int
indent [(String, Maybe CExpr)]
list)
enumInst :: String -> [(String, Maybe CExpr)] -> String
enumInst :: String -> [(String, Maybe CExpr)] -> String
enumInst String
ident [(String, Maybe CExpr)]
list =
String
"instance Enum " forall a. [a] -> [a] -> [a]
++ String
ident forall a. [a] -> [a] -> [a]
++ String
" where\n"
forall a. [a] -> [a] -> [a]
++ forall {a}. (Ord a, Num a, Show a) => [(String, a)] -> String
fromDef [(String, Integer)]
flatList forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall {a}. (Ord a, Num a, Show a) => [(String, a)] -> String
toDef [(String, Integer)]
flatList forall a. [a] -> [a] -> [a]
++ String
"\n"
forall a. [a] -> [a] -> [a]
++ [String] -> String
succDef [String]
names forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
predDef [String]
names forall a. [a] -> [a] -> [a]
++ String
"\n"
forall a. [a] -> [a] -> [a]
++ [String] -> String
enumFromToDef [String]
names
where
names :: [String]
names = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(String, Maybe CExpr)]
list
flatList :: [(String, Integer)]
flatList = forall {a}. [(a, Maybe CExpr)] -> Integer -> [(a, Integer)]
flatten [(String, Maybe CExpr)]
list Integer
0
flatten :: [(a, Maybe CExpr)] -> Integer -> [(a, Integer)]
flatten [] Integer
n = []
flatten ((a
ide, Maybe CExpr
exp):[(a, Maybe CExpr)]
list) Integer
n = (a
ide, Integer
val) forall a. a -> [a] -> [a]
: [(a, Maybe CExpr)] -> Integer -> [(a, Integer)]
flatten [(a, Maybe CExpr)]
list (Integer
val forall a. Num a => a -> a -> a
+ Integer
1)
where
val :: Integer
val = case Maybe CExpr
exp of
Maybe CExpr
Nothing -> Integer
n
Just (CConst (CIntConst Integer
m Attrs
_) Attrs
_) -> Integer
m
Just CExpr
_ -> forall a. String -> a
interr String
"GenBind.enumInst: Integer constant expected!"
show' :: a -> String
show' a
x = if a
x forall a. Ord a => a -> a -> Bool
< a
0 then String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x forall a. [a] -> [a] -> [a]
++ String
")" else forall a. Show a => a -> String
show a
x
fromDef :: [(String, a)] -> String
fromDef [(String, a)]
list = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
" fromEnum " forall a. [a] -> [a] -> [a]
++ String
ide forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ forall {a}. (Ord a, Num a, Show a) => a -> String
show' a
val forall a. [a] -> [a] -> [a]
++ String
"\n"
| (String
ide, a
val) <- [(String, a)]
list
]
toDef :: [(String, a)] -> String
toDef [(String, a)]
list = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
" toEnum " forall a. [a] -> [a] -> [a]
++ forall {a}. (Ord a, Num a, Show a) => a -> String
show' a
val forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ String
ide forall a. [a] -> [a] -> [a]
++ String
"\n"
| (String
ide, a
val) <- forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(String, a)
x (String, a)
y -> forall a b. (a, b) -> b
snd (String, a)
x forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> b
snd (String, a)
y) [(String, a)]
list
]
forall a. [a] -> [a] -> [a]
++ String
" toEnum unmatched = error (\"" forall a. [a] -> [a] -> [a]
++ String
ident
forall a. [a] -> [a] -> [a]
++ String
".toEnum: Cannot match \" ++ show unmatched)\n"
succDef :: [String] -> String
succDef [] = String
" succ _ = undefined\n"
succDef [String
x] = String
" succ _ = undefined\n"
succDef (String
x:String
x':[String]
xs) =
String
" succ " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ String
x' forall a. [a] -> [a] -> [a]
++ String
"\n"
forall a. [a] -> [a] -> [a]
++ [String] -> String
succDef (String
x'forall a. a -> [a] -> [a]
:[String]
xs)
predDef :: [String] -> String
predDef [] = String
" pred _ = undefined\n"
predDef [String
x] = String
" pred _ = undefined\n"
predDef (String
x:String
x':[String]
xs) =
String
" pred " forall a. [a] -> [a] -> [a]
++ String
x' forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ String
x forall a. [a] -> [a] -> [a]
++ String
"\n"
forall a. [a] -> [a] -> [a]
++ [String] -> String
predDef (String
x'forall a. a -> [a] -> [a]
:[String]
xs)
enumFromToDef :: [String] -> String
enumFromToDef [] = String
""
enumFromToDef [String]
names =
String
" enumFromTo x y | fromEnum x == fromEnum y = [ y ]\n"
forall a. [a] -> [a] -> [a]
++ String
" | otherwise = x : enumFromTo (succ x) y\n"
forall a. [a] -> [a] -> [a]
++ String
" enumFrom x = enumFromTo x " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> a
last [String]
names forall a. [a] -> [a] -> [a]
++ String
"\n"
forall a. [a] -> [a] -> [a]
++ String
" enumFromThen _ _ = "
forall a. [a] -> [a] -> [a]
++ String
" error \"Enum "forall a. [a] -> [a] -> [a]
++String
identforall a. [a] -> [a] -> [a]
++String
": enumFromThen not implemented\"\n"
forall a. [a] -> [a] -> [a]
++ String
" enumFromThenTo _ _ _ = "
forall a. [a] -> [a] -> [a]
++ String
" error \"Enum "forall a. [a] -> [a] -> [a]
++String
identforall a. [a] -> [a] -> [a]
++String
": enumFromThenTo not implemented\"\n"
callImport :: CHSHook -> Bool -> Bool -> Maybe String -> String -> String
-> CDecl -> Position -> GB String
callImport :: CHSHook
-> Bool
-> Bool
-> Maybe String
-> String
-> String
-> CDecl
-> Position
-> GB String
callImport CHSHook
hook Bool
isPure Bool
isUns Maybe String
mLock String
ideLexeme String
hsLexeme CDecl
cdecl Position
pos =
do
([Maybe HsPtrRep]
mHsPtrRep, ExtType
extType) <- Position -> CDecl -> Bool -> GB ([Maybe HsPtrRep], ExtType)
extractFunType Position
pos CDecl
cdecl Bool
isPure
String
header <- forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> String
headerSB
CHSHook -> String -> GB ()
delayCode CHSHook
hook (String -> String -> String -> Bool -> ExtType -> String
foreignImport String
header String
ideLexeme String
hsLexeme Bool
isUns ExtType
extType)
ExtType -> GB ()
traceFunType ExtType
extType
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isJust [Maybe HsPtrRep]
mHsPtrRep
then [Maybe HsPtrRep] -> GB String
createLambdaExpr [Maybe HsPtrRep]
mHsPtrRep
else forall (m :: * -> *) a. Monad m => a -> m a
return String
funStr
where
createLambdaExpr :: [Maybe HsPtrRep] -> GB String
createLambdaExpr :: [Maybe HsPtrRep] -> GB String
createLambdaExpr [Maybe HsPtrRep]
foreignVec = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
String
"(\\" forall a. [a] -> [a] -> [a]
++
[String] -> String
unwords (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {a} {b} {d}.
Show a =>
Maybe (a, b, Maybe String, d) -> a -> String
wrPattern [Maybe HsPtrRep]
foreignVec [Integer
1..])forall a. [a] -> [a] -> [a]
++ String
" -> "forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {a} {c} {d}.
Show a =>
Maybe (a, CHSPtrType, c, d) -> a -> String
wrForPtr [Maybe HsPtrRep]
foreignVec [Integer
1..])forall a. [a] -> [a] -> [a]
++String
funStrforall a. [a] -> [a] -> [a]
++String
" "forall a. [a] -> [a] -> [a]
++
[String] -> String
unwords (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {a} {c} {d}.
Show a =>
Maybe (a, CHSPtrType, c, d) -> a -> String
wrArg [Maybe HsPtrRep]
foreignVec [Integer
1..])forall a. [a] -> [a] -> [a]
++String
")"
wrPattern :: Maybe (a, b, Maybe String, d) -> a -> String
wrPattern (Just (a
_,b
_,Just String
con,d
_)) a
n = String
"("forall a. [a] -> [a] -> [a]
++String
conforall a. [a] -> [a] -> [a]
++String
" arg"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show a
nforall a. [a] -> [a] -> [a]
++String
")"
wrPattern Maybe (a, b, Maybe String, d)
_ a
n = String
"arg"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show a
n
wrForPtr :: Maybe (a, CHSPtrType, c, d) -> a -> String
wrForPtr (Just (a
_,CHSPtrType
CHSForeignPtr,c
_,d
_)) a
n
= String
"withForeignPtr arg"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show a
nforall a. [a] -> [a] -> [a]
++String
" $ \\argPtr"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show a
nforall a. [a] -> [a] -> [a]
++String
" ->"
wrForPtr Maybe (a, CHSPtrType, c, d)
_ a
n = String
""
wrArg :: Maybe (a, CHSPtrType, c, d) -> a -> String
wrArg (Just (a
_,CHSPtrType
CHSForeignPtr,c
_,d
_)) a
n = String
"argPtr"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show a
n
wrArg (Just (a
_,CHSPtrType
CHSStablePtr,c
_,d
_)) a
n =
String
"(castStablePtrToPtr arg"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show a
nforall a. [a] -> [a] -> [a]
++String
")"
wrArg Maybe (a, CHSPtrType, c, d)
_ a
n = String
"arg"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show a
n
funStr :: String
funStr = case Maybe String
mLock of Maybe String
Nothing -> String
hsLexeme
Just String
lockFun -> String
lockFun forall a. [a] -> [a] -> [a]
++ String
" $ " forall a. [a] -> [a] -> [a]
++ String
hsLexeme
traceFunType :: ExtType -> GB ()
traceFunType ExtType
et = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"Imported function type: " forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
et forall a. [a] -> [a] -> [a]
++ String
"\n"
foreignImport :: String -> String -> String -> Bool -> ExtType -> String
foreignImport :: String -> String -> String -> Bool -> ExtType -> String
foreignImport String
header String
ident String
hsIdent Bool
isUnsafe ExtType
ty =
String
"foreign import ccall " forall a. [a] -> [a] -> [a]
++ String
safety forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
entity forall a. [a] -> [a] -> [a]
++
String
"\n " forall a. [a] -> [a] -> [a]
++ String
hsIdent forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
ty forall a. [a] -> [a] -> [a]
++ String
"\n"
where
safety :: String
safety = if Bool
isUnsafe then String
"unsafe" else String
"safe"
entity :: String
entity | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
header = String
ident
| Bool
otherwise = String
header forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
ident
funDef :: Bool
-> String
-> String
-> CDecl
-> Maybe String
-> Maybe String
-> [CHSParm]
-> CHSParm
-> Position
-> GB String
funDef :: Bool
-> String
-> String
-> CDecl
-> Maybe String
-> Maybe String
-> [CHSParm]
-> CHSParm
-> Position
-> GB String
funDef Bool
isPure String
hsLexeme String
fiLexeme CDecl
cdecl Maybe String
octxt Maybe String
mLock [CHSParm]
parms CHSParm
parm Position
pos =
do
([CHSParm]
parms', CHSParm
parm', Bool
isImpure) <- Position
-> [CHSParm] -> CHSParm -> CDecl -> GB ([CHSParm], CHSParm, Bool)
addDftMarshaller Position
pos [CHSParm]
parms CHSParm
parm CDecl
cdecl
[CHSParm] -> CHSParm -> Bool -> GB ()
traceMarsh [CHSParm]
parms' CHSParm
parm' Bool
isImpure
let
sig :: String
sig = String
hsLexeme forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ [CHSParm] -> CHSParm -> String
funTy [CHSParm]
parms' CHSParm
parm' forall a. [a] -> [a] -> [a]
++ String
"\n"
marshs :: [(String, String, String, String, String)]
marshs = [forall {p}.
Show p =>
p -> CHSParm -> (String, String, String, String, String)
marshArg Integer
i CHSParm
parm | (Integer
i, CHSParm
parm) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [CHSParm]
parms']
funArgs :: [String]
funArgs = [String
funArg | (String
funArg, String
_, String
_, String
_, String
_) <- [(String, String, String, String, String)]
marshs, String
funArg forall a. Eq a => a -> a -> Bool
/= String
""]
marshIns :: [String]
marshIns = [String
marshIn | (String
_, String
marshIn, String
_, String
_, String
_) <- [(String, String, String, String, String)]
marshs]
callArgs :: [String]
callArgs = [String
callArg | (String
_, String
_, String
callArg, String
_, String
_) <- [(String, String, String, String, String)]
marshs]
marshOuts :: [String]
marshOuts = [String
marshOut | (String
_, String
_, String
_, String
marshOut, String
_) <- [(String, String, String, String, String)]
marshs, String
marshOut forall a. Eq a => a -> a -> Bool
/= String
""]
retArgs :: [String]
retArgs = [String
retArg | (String
_, String
_, String
_, String
_, String
retArg) <- [(String, String, String, String, String)]
marshs, String
retArg forall a. Eq a => a -> a -> Bool
/= String
""]
funHead :: String
funHead = String
hsLexeme forall a. [a] -> [a] -> [a]
++ [String] -> String
join [String]
funArgs forall a. [a] -> [a] -> [a]
++ String
" =\n" forall a. [a] -> [a] -> [a]
++
if Bool
isPure Bool -> Bool -> Bool
&& Bool
isImpure then String
" unsafePerformIO $\n" else String
""
lock :: String
lock = case Maybe String
mLock of Maybe String
Nothing -> String
""
Just String
lock -> String
lock forall a. [a] -> [a] -> [a]
++ String
" $"
call :: String
call = if Bool
isPure
then String
" let {res = " forall a. [a] -> [a] -> [a]
++ String
fiLexeme forall a. [a] -> [a] -> [a]
++ [String] -> String
join [String]
callArgs forall a. [a] -> [a] -> [a]
++ String
"} in\n"
else String
" " forall a. [a] -> [a] -> [a]
++ String
lock forall a. [a] -> [a] -> [a]
++ String
fiLexeme forall a. [a] -> [a] -> [a]
++ [String] -> String
join [String]
callArgs forall a. [a] -> [a] -> [a]
++ String
" >>= \\res ->\n"
marshRes :: String
marshRes = case CHSParm
parm' of
CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
twoCVal (Just (Ident
_ , CHSArg
CHSVoidArg)) Position
_ -> String
""
CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
twoCVal (Just (Ident
omIde, CHSArg
CHSIOArg )) Position
_ ->
String
" " forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
omIde forall a. [a] -> [a] -> [a]
++ String
" res >>= \\res' ->\n"
CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
twoCVal (Just (Ident
omIde, CHSArg
CHSValArg )) Position
_ ->
String
" let {res' = " forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
omIde forall a. [a] -> [a] -> [a]
++ String
" res} in\n"
CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
_ Maybe (Ident, CHSArg)
Nothing Position
_ ->
forall a. String -> a
interr String
"GenBind.funDef: marshRes: no default?"
retArgs' :: [String]
retArgs' = case CHSParm
parm' of
CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
_ (Just (Ident
_, CHSArg
CHSVoidArg)) Position
_ -> [String]
retArgs
CHSParm
_ -> String
"res'"forall a. a -> [a] -> [a]
:[String]
retArgs
ret :: String
ret = String
"(" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
", " [String]
retArgs') forall a. [a] -> [a] -> [a]
++ String
")"
funBody :: String
funBody = [String] -> String
joinLines [String]
marshIns forall a. [a] -> [a] -> [a]
++
String
call forall a. [a] -> [a] -> [a]
++
[String] -> String
joinLines [String]
marshOuts forall a. [a] -> [a] -> [a]
++
String
marshRes forall a. [a] -> [a] -> [a]
++
String
" " forall a. [a] -> [a] -> [a]
++
(if Bool
isImpure Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
isPure then String
"return " else String
"") forall a. [a] -> [a] -> [a]
++ String
ret
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
sig forall a. [a] -> [a] -> [a]
++ String
funHead forall a. [a] -> [a] -> [a]
++ String
funBody
where
join :: [String] -> String
join = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Char
' 'forall a. a -> [a] -> [a]
:)
joinLines :: [String] -> String
joinLines = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
s -> String
" " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
"\n")
funTy :: [CHSParm] -> CHSParm -> String
funTy [CHSParm]
parms CHSParm
parm =
let
ctxt :: String
ctxt = case Maybe String
octxt of
Maybe String
Nothing -> String
""
Just String
ctxtStr -> String
ctxtStr forall a. [a] -> [a] -> [a]
++ String
" => "
argTys :: [String]
argTys = [String
ty | CHSParm Maybe (Ident, CHSArg)
im String
ty Bool
_ Maybe (Ident, CHSArg)
_ Position
_ <- [CHSParm]
parms , forall {a}. Maybe (a, CHSArg) -> Bool
notVoid Maybe (Ident, CHSArg)
im]
resTys :: [String]
resTys = [String
ty | CHSParm Maybe (Ident, CHSArg)
_ String
ty Bool
_ Maybe (Ident, CHSArg)
om Position
_ <- CHSParm
parmforall a. a -> [a] -> [a]
:[CHSParm]
parms, forall {a}. Maybe (a, CHSArg) -> Bool
notVoid Maybe (Ident, CHSArg)
om]
resTup :: String
resTup = let
(String
lp, String
rp) = if Bool
isPure Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
resTys forall a. Eq a => a -> a -> Bool
== Int
1
then (String
"", String
"")
else (String
"(", String
")")
io :: String
io = if Bool
isPure then String
"" else String
"IO "
in
String
io forall a. [a] -> [a] -> [a]
++ String
lp forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
", " [String]
resTys) forall a. [a] -> [a] -> [a]
++ String
rp
in
String
ctxt forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
" -> " ([String]
argTys forall a. [a] -> [a] -> [a]
++ [String
resTup]))
where
notVoid :: Maybe (a, CHSArg) -> Bool
notVoid Maybe (a, CHSArg)
Nothing = forall a. String -> a
interr String
"GenBind.funDef: \
\No default marshaller?"
notVoid (Just (a
_, CHSArg
kind)) = CHSArg
kind forall a. Eq a => a -> a -> Bool
/= CHSArg
CHSVoidArg
marshArg :: p -> CHSParm -> (String, String, String, String, String)
marshArg p
i (CHSParm (Just (Ident
imIde, CHSArg
imArgKind)) String
_ Bool
twoCVal
(Just (Ident
omIde, CHSArg
omArgKind)) Position
_ ) =
let
a :: String
a = String
"a" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show p
i
imStr :: String
imStr = Ident -> String
identToLexeme Ident
imIde
imApp :: String
imApp = String
imStr forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
a
funArg :: String
funArg = if CHSArg
imArgKind forall a. Eq a => a -> a -> Bool
== CHSArg
CHSVoidArg then String
"" else String
a
inBndr :: String
inBndr = if Bool
twoCVal
then String
"(" forall a. [a] -> [a] -> [a]
++ String
a forall a. [a] -> [a] -> [a]
++ String
"'1, " forall a. [a] -> [a] -> [a]
++ String
a forall a. [a] -> [a] -> [a]
++ String
"'2)"
else String
a forall a. [a] -> [a] -> [a]
++ String
"'"
marshIn :: String
marshIn = case CHSArg
imArgKind of
CHSArg
CHSVoidArg -> String
imStr forall a. [a] -> [a] -> [a]
++ String
" $ \\" forall a. [a] -> [a] -> [a]
++ String
inBndr forall a. [a] -> [a] -> [a]
++ String
" -> "
CHSArg
CHSIOArg -> String
imApp forall a. [a] -> [a] -> [a]
++ String
" $ \\" forall a. [a] -> [a] -> [a]
++ String
inBndr forall a. [a] -> [a] -> [a]
++ String
" -> "
CHSArg
CHSValArg -> String
"let {" forall a. [a] -> [a] -> [a]
++ String
inBndr forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++
String
imApp forall a. [a] -> [a] -> [a]
++ String
"} in "
callArg :: String
callArg = if Bool
twoCVal
then String
"" forall a. [a] -> [a] -> [a]
++ String
a forall a. [a] -> [a] -> [a]
++ String
"'1 " forall a. [a] -> [a] -> [a]
++ String
a forall a. [a] -> [a] -> [a]
++ String
"'2"
else String
a forall a. [a] -> [a] -> [a]
++ String
"'"
omApp :: String
omApp = Ident -> String
identToLexeme Ident
omIde forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
callArg
outBndr :: String
outBndr = String
a forall a. [a] -> [a] -> [a]
++ String
"''"
marshOut :: String
marshOut = case CHSArg
omArgKind of
CHSArg
CHSVoidArg -> String
""
CHSArg
CHSIOArg -> String
omApp forall a. [a] -> [a] -> [a]
++ String
">>= \\" forall a. [a] -> [a] -> [a]
++ String
outBndr forall a. [a] -> [a] -> [a]
++ String
" -> "
CHSArg
CHSValArg -> String
"let {" forall a. [a] -> [a] -> [a]
++ String
outBndr forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++
String
omApp forall a. [a] -> [a] -> [a]
++ String
"} in "
retArg :: String
retArg = if CHSArg
omArgKind forall a. Eq a => a -> a -> Bool
== CHSArg
CHSVoidArg then String
"" else String
outBndr
in
(String
funArg, String
marshIn, String
callArg, String
marshOut, String
retArg)
marshArg p
_ CHSParm
_ = forall a. String -> a
interr String
"GenBind.funDef: Missing default?"
traceMarsh :: [CHSParm] -> CHSParm -> Bool -> GB ()
traceMarsh [CHSParm]
parms CHSParm
parm Bool
isImpure = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"Marshalling specification including defaults: \n" forall a. [a] -> [a] -> [a]
++
[CHSParm] -> String -> String
showParms ([CHSParm]
parms forall a. [a] -> [a] -> [a]
++ [CHSParm
parm]) String
"" forall a. [a] -> [a] -> [a]
++
String
" The marshalling is " forall a. [a] -> [a] -> [a]
++ if Bool
isImpure then String
"impure.\n" else String
"pure.\n"
where
showParms :: [CHSParm] -> String -> String
showParms [] = forall a. a -> a
id
showParms (CHSParm
parm:[CHSParm]
parms) = String -> String -> String
showString String
" "
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CHSParm -> String -> String
showCHSParm CHSParm
parm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
'\n'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CHSParm] -> String -> String
showParms [CHSParm]
parms
addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> CDecl
-> GB ([CHSParm], CHSParm, Bool)
addDftMarshaller :: Position
-> [CHSParm] -> CHSParm -> CDecl -> GB ([CHSParm], CHSParm, Bool)
addDftMarshaller Position
pos [CHSParm]
parms CHSParm
parm CDecl
cdecl = do
([Maybe HsPtrRep]
_, ExtType
fType) <- Position -> CDecl -> Bool -> GB ([Maybe HsPtrRep], ExtType)
extractFunType Position
pos CDecl
cdecl Bool
True
let (ExtType
resTy, [ExtType]
argTys) = ExtType -> (ExtType, [ExtType])
splitFunTy ExtType
fType
(CHSParm
parm' , Bool
isImpure1) <- CHSParm -> ExtType -> GB (CHSParm, Bool)
checkResMarsh CHSParm
parm ExtType
resTy
([CHSParm]
parms', Bool
isImpure2) <- [CHSParm]
-> [ExtType]
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
addDft [CHSParm]
parms [ExtType]
argTys
forall (m :: * -> *) a. Monad m => a -> m a
return ([CHSParm]
parms', CHSParm
parm', Bool
isImpure1 Bool -> Bool -> Bool
|| Bool
isImpure2)
where
checkResMarsh :: CHSParm -> ExtType -> GB (CHSParm, Bool)
checkResMarsh (CHSParm (Just (Ident, CHSArg)
_) String
_ Bool
_ Maybe (Ident, CHSArg)
_ Position
pos) ExtType
_ =
forall a. Position -> GB a
resMarshIllegalInErr Position
pos
checkResMarsh (CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
True Maybe (Ident, CHSArg)
_ Position
pos) ExtType
_ =
forall a. Position -> GB a
resMarshIllegalTwoCValErr Position
pos
checkResMarsh (CHSParm Maybe (Ident, CHSArg)
_ String
ty Bool
_ Maybe (Ident, CHSArg)
omMarsh Position
pos) ExtType
cTy = do
(Maybe (Ident, CHSArg)
imMarsh', Bool
_ ) <- forall {m :: * -> *}.
Monad m =>
Maybe (Ident, CHSArg) -> m (Maybe (Ident, CHSArg), Bool)
addDftVoid forall a. Maybe a
Nothing
(Maybe (Ident, CHSArg)
omMarsh', Bool
isImpure) <- Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftOut Position
pos Maybe (Ident, CHSArg)
omMarsh String
ty [ExtType
cTy]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
-> String -> Bool -> Maybe (Ident, CHSArg) -> Position -> CHSParm
CHSParm Maybe (Ident, CHSArg)
imMarsh' String
ty Bool
False Maybe (Ident, CHSArg)
omMarsh' Position
pos, Bool
isImpure)
splitFunTy :: ExtType -> (ExtType, [ExtType])
splitFunTy (FunET ExtType
UnitET ExtType
ty ) = ExtType -> (ExtType, [ExtType])
splitFunTy ExtType
ty
splitFunTy (FunET ExtType
ty1 ExtType
ty2) = let
(ExtType
resTy, [ExtType]
argTys) = ExtType -> (ExtType, [ExtType])
splitFunTy ExtType
ty2
in
(ExtType
resTy, ExtType
ty1forall a. a -> [a] -> [a]
:[ExtType]
argTys)
splitFunTy ExtType
resTy = (ExtType
resTy, [])
addDft :: [CHSParm]
-> [ExtType]
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
addDft ((CHSParm Maybe (Ident, CHSArg)
imMarsh String
hsTy Bool
False Maybe (Ident, CHSArg)
omMarsh Position
p):[CHSParm]
parms) (ExtType
cTy :[ExtType]
cTys) = do
(Maybe (Ident, CHSArg)
imMarsh', Bool
isImpureIn ) <- Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftIn Position
p Maybe (Ident, CHSArg)
imMarsh String
hsTy [ExtType
cTy]
(Maybe (Ident, CHSArg)
omMarsh', Bool
isImpureOut) <- forall {m :: * -> *}.
Monad m =>
Maybe (Ident, CHSArg) -> m (Maybe (Ident, CHSArg), Bool)
addDftVoid Maybe (Ident, CHSArg)
omMarsh
([CHSParm]
parms' , Bool
isImpure ) <- [CHSParm]
-> [ExtType]
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
addDft [CHSParm]
parms [ExtType]
cTys
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 forall a. a -> [a] -> [a]
: [CHSParm]
parms',
Bool
isImpure Bool -> Bool -> Bool
|| Bool
isImpureIn Bool -> Bool -> Bool
|| Bool
isImpureOut)
addDft ((CHSParm Maybe (Ident, CHSArg)
imMarsh String
hsTy Bool
True Maybe (Ident, CHSArg)
omMarsh Position
p):[CHSParm]
parms) (ExtType
cTy1:ExtType
cTy2:[ExtType]
cTys) = do
(Maybe (Ident, CHSArg)
imMarsh', Bool
isImpureIn ) <- Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftIn Position
p Maybe (Ident, CHSArg)
imMarsh String
hsTy [ExtType
cTy1, ExtType
cTy2]
(Maybe (Ident, CHSArg)
omMarsh', Bool
isImpureOut) <- forall {m :: * -> *}.
Monad m =>
Maybe (Ident, CHSArg) -> m (Maybe (Ident, CHSArg), Bool)
addDftVoid Maybe (Ident, CHSArg)
omMarsh
([CHSParm]
parms' , Bool
isImpure ) <- [CHSParm]
-> [ExtType]
-> PreCST SwitchBoard (CState GBState) ([CHSParm], Bool)
addDft [CHSParm]
parms [ExtType]
cTys
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 forall a. a -> [a] -> [a]
: [CHSParm]
parms',
Bool
isImpure Bool -> Bool -> Bool
|| Bool
isImpureIn Bool -> Bool -> Bool
|| Bool
isImpureOut)
addDft [] [] =
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Bool
False)
addDft ((CHSParm Maybe (Ident, CHSArg)
_ String
_ Bool
_ Maybe (Ident, CHSArg)
_ Position
pos):[CHSParm]
parms) [] =
forall a. Position -> String -> GB a
marshArgMismatchErr Position
pos String
"This parameter is in excess of the C arguments."
addDft [] (ExtType
_:[ExtType]
_) =
forall a. Position -> String -> GB a
marshArgMismatchErr Position
pos String
"Parameter marshallers are missing."
addDftIn :: Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftIn Position
_ imMarsh :: Maybe (Ident, CHSArg)
imMarsh@(Just (Ident
_, CHSArg
kind)) String
_ [ExtType]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
imMarsh,
CHSArg
kind forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg)
addDftIn Position
pos imMarsh :: Maybe (Ident, CHSArg)
imMarsh@Maybe (Ident, CHSArg)
Nothing String
hsTy [ExtType]
cTys = do
Maybe (Ident, CHSArg)
marsh <- String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshIn String
hsTy [ExtType]
cTys
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe (Ident, CHSArg)
marsh) forall a b. (a -> b) -> a -> b
$
forall a. Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr Position
pos String
"\"in\"" String
hsTy [ExtType]
cTys
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
marsh, case Maybe (Ident, CHSArg)
marsh of {Just (Ident
_, CHSArg
kind) -> CHSArg
kind forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg})
addDftOut :: Position
-> Maybe (Ident, CHSArg)
-> String
-> [ExtType]
-> PreCST
SwitchBoard (CState GBState) (Maybe (Ident, CHSArg), Bool)
addDftOut Position
_ omMarsh :: Maybe (Ident, CHSArg)
omMarsh@(Just (Ident
_, CHSArg
kind)) String
_ [ExtType]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
omMarsh,
CHSArg
kind forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg)
addDftOut Position
pos omMarsh :: Maybe (Ident, CHSArg)
omMarsh@Maybe (Ident, CHSArg)
Nothing String
hsTy [ExtType]
cTys = do
Maybe (Ident, CHSArg)
marsh <- String -> [ExtType] -> GB (Maybe (Ident, CHSArg))
lookupDftMarshOut String
hsTy [ExtType]
cTys
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe (Ident, CHSArg)
marsh) forall a b. (a -> b) -> a -> b
$
forall a. Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr Position
pos String
"\"out\"" String
hsTy [ExtType]
cTys
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
marsh, case Maybe (Ident, CHSArg)
marsh of {Just (Ident
_, CHSArg
kind) -> CHSArg
kind forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg})
addDftVoid :: Maybe (Ident, CHSArg) -> m (Maybe (Ident, CHSArg), Bool)
addDftVoid marsh :: Maybe (Ident, CHSArg)
marsh@(Just (Ident
_, CHSArg
kind)) = forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Ident, CHSArg)
marsh, CHSArg
kind forall a. Eq a => a -> a -> Bool
== CHSArg
CHSIOArg)
addDftVoid Maybe (Ident, CHSArg)
Nothing = do
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (String -> Ident
noPosIdent String
"void", CHSArg
CHSVoidArg), Bool
False)
accessPath :: CHSAPath -> GB (CDecl, [BitSize])
accessPath :: CHSAPath -> GB (CDecl, [BitSize])
accessPath (CHSRoot Ident
ide) =
do
CDecl
decl <- forall s. Ident -> Bool -> Bool -> CT s CDecl
findAndChaseDecl Ident
ide Bool
False Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ide Ident -> CDecl -> CDecl
`simplifyDecl` CDecl
decl, [Int -> Int -> BitSize
BitSize Int
0 Int
0])
accessPath (CHSDeref (CHSRoot Ident
ide) Position
_) =
do
CDecl
decl <- forall s. Ident -> Bool -> Bool -> CT s CDecl
findAndChaseDecl Ident
ide Bool
True Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
ide Ident -> CDecl -> CDecl
`simplifyDecl` CDecl
decl, [Int -> Int -> BitSize
BitSize Int
0 Int
0])
accessPath (CHSRef root :: CHSAPath
root@(CHSRoot Ident
ide1) Ident
ide2) =
do
CStructUnion
su <- forall s. Ident -> Bool -> Bool -> CT s CStructUnion
lookupStructUnion Ident
ide1 Bool
False Bool
True
(BitSize
offset, CDecl
decl') <- CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct CStructUnion
su Ident
ide2
CDecl
adecl <- CDecl -> GB CDecl
replaceByAlias CDecl
decl'
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
adecl, [BitSize
offset])
accessPath (CHSRef (CHSDeref (CHSRoot Ident
ide1) Position
_) Ident
ide2) =
do
CStructUnion
su <- forall s. Ident -> Bool -> Bool -> CT s CStructUnion
lookupStructUnion Ident
ide1 Bool
True Bool
True
(BitSize
offset, CDecl
decl') <- CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct CStructUnion
su Ident
ide2
CDecl
adecl <- CDecl -> GB CDecl
replaceByAlias CDecl
decl'
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
adecl, [BitSize
offset])
accessPath (CHSRef CHSAPath
path Ident
ide) =
do
(CDecl
decl, BitSize
offset:[BitSize]
offsets) <- CHSAPath -> GB (CDecl, [BitSize])
accessPath CHSAPath
path
Ident -> CDecl -> GB ()
assertPrimDeclr Ident
ide CDecl
decl
CStructUnion
su <- forall s. Position -> CDecl -> CT s CStructUnion
structFromDecl (forall a. Pos a => a -> Position
posOf Ident
ide) CDecl
decl
(BitSize
addOffset, CDecl
decl') <- CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct CStructUnion
su Ident
ide
CDecl
adecl <- CDecl -> GB CDecl
replaceByAlias CDecl
decl'
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
adecl, BitSize
offset BitSize -> BitSize -> BitSize
`addBitSize` BitSize
addOffset forall a. a -> [a] -> [a]
: [BitSize]
offsets)
where
assertPrimDeclr :: Ident -> CDecl -> GB ()
assertPrimDeclr Ident
ide (CDecl [CDeclSpec]
_ [(Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr] Attrs
_) =
case (Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr of
(Just (CVarDeclr Maybe Ident
_ Attrs
_), Maybe CInit
_, Maybe CExpr
_) -> forall e s. PreCST e s ()
nop
(Maybe CDeclr, Maybe CInit, Maybe CExpr)
_ -> forall a. Ident -> GB a
structExpectedErr Ident
ide
accessPath (CHSDeref CHSAPath
path Position
pos) =
do
(CDecl
decl, [BitSize]
offsets) <- CHSAPath -> GB (CDecl, [BitSize])
accessPath CHSAPath
path
CDecl
decl' <- CDecl -> GB CDecl
derefOrErr CDecl
decl
CDecl
adecl <- CDecl -> GB CDecl
replaceByAlias CDecl
decl'
forall (m :: * -> *) a. Monad m => a -> m a
return (CDecl
adecl, Int -> Int -> BitSize
BitSize Int
0 Int
0 forall a. a -> [a] -> [a]
: [BitSize]
offsets)
where
derefOrErr :: CDecl -> GB CDecl
derefOrErr (CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr] Attrs
at) =
case (Maybe CDeclr, Maybe CInit, Maybe CExpr)
declr of
(Just (CPtrDeclr [CTypeQual
_] CDeclr
declr Attrs
at), Maybe CInit
oinit, Maybe CExpr
oexpr) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(forall a. a -> Maybe a
Just CDeclr
declr, Maybe CInit
oinit, Maybe CExpr
oexpr)] Attrs
at
(Just (CPtrDeclr (CTypeQual
_:[CTypeQual]
quals) CDeclr
declr Attrs
at), Maybe CInit
oinit, Maybe CExpr
oexpr) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
[CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(forall a. a -> Maybe a
Just ([CTypeQual] -> CDeclr -> Attrs -> CDeclr
CPtrDeclr [CTypeQual]
quals CDeclr
declr Attrs
at), Maybe CInit
oinit, Maybe CExpr
oexpr)] Attrs
at
(Maybe CDeclr, Maybe CInit, Maybe CExpr)
_ ->
forall a. Position -> GB a
ptrExpectedErr Position
pos
replaceByAlias :: CDecl -> GB CDecl
replaceByAlias :: CDecl -> GB CDecl
replaceByAlias cdecl :: CDecl
cdecl@(CDecl [CDeclSpec]
_ [(Maybe CDeclr
_, Maybe CInit
_, Maybe CExpr
size)] Attrs
at) =
do
Maybe CDecl
ocdecl <- forall s. CDecl -> CT s (Maybe CDecl)
checkForAlias CDecl
cdecl
case Maybe CDecl
ocdecl of
Maybe CDecl
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return CDecl
cdecl
Just (CDecl [CDeclSpec]
specs [(Maybe CDeclr
declr, Maybe CInit
init, Maybe CExpr
_)] Attrs
at) ->
forall (m :: * -> *) a. Monad m => a -> m a
return 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
refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl)
refStruct CStructUnion
su Ident
ide =
do
let ([CDecl]
fields, CStructTag
tag) = CStructUnion -> ([CDecl], CStructTag)
structMembers CStructUnion
su
([CDecl]
pre, [CDecl]
post) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip CDecl -> Ident -> Bool
declNamed Ident
ide) [CDecl]
fields
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CDecl]
post) forall a b. (a -> b) -> a -> b
$
forall a. Position -> Ident -> GB a
unknownFieldErr (forall a. Pos a => a -> Position
posOf CStructUnion
su) Ident
ide
let decl :: CDecl
decl = forall a. [a] -> a
head [CDecl]
post
BitSize
offset <- case CStructTag
tag of
CStructTag
CStructTag -> [CDecl]
-> CDecl
-> CStructTag
-> PreCST SwitchBoard (CState GBState) BitSize
offsetInStruct [CDecl]
pre CDecl
decl CStructTag
tag
CStructTag
CUnionTag -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> BitSize
BitSize Int
0 Int
0
forall (m :: * -> *) a. Monad m => a -> m a
return (BitSize
offset, CDecl
decl)
declNamed :: CDecl -> Ident -> Bool
(CDecl [CDeclSpec]
_ [(Maybe CDeclr
Nothing , Maybe CInit
_, Maybe CExpr
_)] Attrs
_) declNamed :: CDecl -> Ident -> Bool
`declNamed` Ident
ide = Bool
False
(CDecl [CDeclSpec]
_ [(Just CDeclr
declr, Maybe CInit
_, Maybe CExpr
_)] Attrs
_) `declNamed` Ident
ide = CDeclr
declr CDeclr -> Ident -> Bool
`declrNamed` Ident
ide
(CDecl [CDeclSpec]
_ [] Attrs
_) `declNamed` Ident
_ =
forall a. String -> a
interr String
"GenBind.declNamed: Abstract declarator in structure!"
CDecl
_ `declNamed` Ident
_ =
forall a. String -> a
interr String
"GenBind.declNamed: More than one declarator!"
setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String
setGet :: Position -> CHSAccess -> [BitSize] -> ExtType -> GB String
setGet Position
pos CHSAccess
access [BitSize]
offsets ExtType
ty =
do
let pre :: String
pre = case CHSAccess
access of
CHSAccess
CHSSet -> String
"(\\ptr val -> do {"
CHSAccess
CHSGet -> String
"(\\ptr -> do {"
String
body <- [BitSize] -> GB String
setGetBody (forall a. [a] -> [a]
reverse [BitSize]
offsets)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
pre forall a. [a] -> [a] -> [a]
++ String
body forall a. [a] -> [a] -> [a]
++ String
"})"
where
setGetBody :: [BitSize] -> GB String
setGetBody [BitSize Int
offset Int
bitOffset] =
do
let ty' :: ExtType
ty' = case ExtType
ty of
t :: ExtType
t@(DefinedET CDecl
_ HsPtrRep
_) -> ExtType -> ExtType
PtrET ExtType
t
ExtType
t -> ExtType
t
let tyTag :: String
tyTag = ExtType -> String
showExtType ExtType
ty'
Maybe (Bool, Int)
bf <- ExtType -> GB (Maybe (Bool, Int))
checkType ExtType
ty'
case Maybe (Bool, Int)
bf of
Maybe (Bool, Int)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case CHSAccess
access of
CHSAccess
CHSGet -> forall {a}. Show a => a -> String -> String
peekOp Int
offset String
tyTag
CHSAccess
CHSSet -> forall {a}. Show a => a -> String -> String -> String
pokeOp Int
offset String
tyTag String
"val"
Just (Bool
_, Int
bs) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case CHSAccess
access of
CHSAccess
CHSGet -> String
"val <- " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String -> String
peekOp Int
offset String
tyTag
forall a. [a] -> [a] -> [a]
++ String
extractBitfield
CHSAccess
CHSSet -> String
"org <- " forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String -> String
peekOp Int
offset String
tyTag
forall a. [a] -> [a] -> [a]
++ String
insertBitfield
forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> String -> String -> String
pokeOp Int
offset String
tyTag String
"val'"
where
extractBitfield :: String
extractBitfield = String
"; return $ (val `shiftL` ("
forall a. [a] -> [a] -> [a]
++ String
bitsPerField forall a. [a] -> [a] -> [a]
++ String
" - "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
bs forall a. Num a => a -> a -> a
+ Int
bitOffset) forall a. [a] -> [a] -> [a]
++ String
")) `shiftR` ("
forall a. [a] -> [a] -> [a]
++ String
bitsPerField forall a. [a] -> [a] -> [a]
++ String
" - " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
bs
forall a. [a] -> [a] -> [a]
++ String
")"
bitsPerField :: String
bitsPerField = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ CPrimType -> Int
size CPrimType
CIntPT forall a. Num a => a -> a -> a
* Int
8
insertBitfield :: String
insertBitfield = String
"; let {val' = (org .&. " forall a. [a] -> [a] -> [a]
++ String
middleMask
forall a. [a] -> [a] -> [a]
++ String
") .|. (val `shiftL` "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
bitOffset forall a. [a] -> [a] -> [a]
++ String
")}; "
middleMask :: String
middleMask = String
"fromIntegral (((maxBound::CUInt) `shiftL` "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
bs forall a. [a] -> [a] -> [a]
++ String
") `rotateL` "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
bitOffset forall a. [a] -> [a] -> [a]
++ String
")"
setGetBody (BitSize Int
offset Int
0 : [BitSize]
offsets) =
do
String
code <- [BitSize] -> GB String
setGetBody [BitSize]
offsets
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"ptr <- peekByteOff ptr " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
offset forall a. [a] -> [a] -> [a]
++ String
"; " forall a. [a] -> [a] -> [a]
++ String
code
setGetBody (BitSize Int
_ Int
_ : [BitSize]
_ ) =
forall a. Position -> GB a
derefBitfieldErr Position
pos
checkType :: ExtType -> GB (Maybe (Bool, Int))
checkType (IOET ExtType
_ ) = forall a. String -> a
interr String
"GenBind.setGet: Illegal \
\type!"
checkType (ExtType
UnitET ) = forall a. Position -> GB a
voidFieldErr Position
pos
checkType (PrimET (CUFieldPT Int
bs)) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Bool
False, Int
bs)
checkType (PrimET (CSFieldPT Int
bs)) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Bool
True , Int
bs)
checkType ExtType
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
peekOp :: a -> String -> String
peekOp a
off String
tyTag = String
"peekByteOff ptr " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
off forall a. [a] -> [a] -> [a]
++ String
" ::IO " forall a. [a] -> [a] -> [a]
++ String
tyTag
pokeOp :: a -> String -> String -> String
pokeOp a
off String
tyTag String
var = String
"pokeByteOff ptr " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
off forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
var
forall a. [a] -> [a] -> [a]
++ String
"::" forall a. [a] -> [a] -> [a]
++ String
tyTag forall a. [a] -> [a] -> [a]
++ String
")"
pointerDef :: Bool
-> Ident
-> String
-> CHSPtrType
-> Bool
-> String
-> Bool
-> GB String
pointerDef :: Bool
-> Ident
-> String
-> CHSPtrType
-> Bool
-> String
-> Bool
-> GB String
pointerDef Bool
isStar Ident
cNameFull String
hsName CHSPtrType
ptrKind Bool
isNewtype String
hsType Bool
isFun =
do
Bool
keepOld <- forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
oldFFI
let ptrArg :: String
ptrArg = if Bool
keepOld
then String
"()"
else if Bool
isNewtype
then String
hsName
else String
hsType
ptrCon :: String
ptrCon = case CHSPtrType
ptrKind of
CHSPtrType
CHSPtr | Bool
isFun -> String
"FunPtr"
CHSPtrType
_ -> forall a. Show a => a -> String
show CHSPtrType
ptrKind
ptrType :: String
ptrType = String
ptrCon forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
ptrArg forall a. [a] -> [a] -> [a]
++ String
")"
thePtr :: (Bool, Ident)
thePtr = (Bool
isStar, Ident
cNameFull)
(Bool, Ident)
thePtr (Bool, Ident) -> HsPtrRep -> GB ()
`ptrMapsTo` (Bool
isFun,
CHSPtrType
ptrKind,
if Bool
isNewtype then forall a. a -> Maybe a
Just String
hsName else forall a. Maybe a
Nothing,
String
ptrArg)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if Bool
isNewtype
then String
"newtype " forall a. [a] -> [a] -> [a]
++ String
hsName forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ String
hsName forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
ptrType forall a. [a] -> [a] -> [a]
++ String
")"
else String
"type " forall a. [a] -> [a] -> [a]
++ String
hsName forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ String
ptrType
classDef :: Position
-> String
-> String
-> CHSPtrType
-> Bool
-> [(String, String, HsObject)]
-> GB String
classDef :: Position
-> String
-> String
-> CHSPtrType
-> Bool
-> [(String, String, HsObject)]
-> GB String
classDef Position
pos String
className String
typeName CHSPtrType
ptrType Bool
isNewtype [(String, String, HsObject)]
superClasses =
do
let
toMethodName :: String
toMethodName = case String
typeName of
String
"" -> forall a. String -> a
interr String
"GenBind.classDef: \
\Illegal identifier!"
Char
c:String
cs -> Char -> Char
toLower Char
c forall a. a -> [a] -> [a]
: String
cs
fromMethodName :: String
fromMethodName = String
"from" forall a. [a] -> [a] -> [a]
++ String
typeName
classDefContext :: String
classDefContext = case [(String, String, HsObject)]
superClasses of
[] -> String
""
(String
superName, String
_, HsObject
_):[(String, String, HsObject)]
_ -> String
superName forall a. [a] -> [a] -> [a]
++ String
" p => "
classDef :: String
classDef =
String
"class " forall a. [a] -> [a] -> [a]
++ String
classDefContext forall a. [a] -> [a] -> [a]
++ String
className forall a. [a] -> [a] -> [a]
++ String
" p where\n"
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
toMethodName forall a. [a] -> [a] -> [a]
++ String
" :: p -> " forall a. [a] -> [a] -> [a]
++ String
typeName forall a. [a] -> [a] -> [a]
++ String
"\n"
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
fromMethodName forall a. [a] -> [a] -> [a]
++ String
" :: " forall a. [a] -> [a] -> [a]
++ String
typeName forall a. [a] -> [a] -> [a]
++ String
" -> p\n"
instDef :: String
instDef =
String
"instance " forall a. [a] -> [a] -> [a]
++ String
className forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
typeName forall a. [a] -> [a] -> [a]
++ String
" where\n"
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
toMethodName forall a. [a] -> [a] -> [a]
++ String
" = id\n"
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
fromMethodName forall a. [a] -> [a] -> [a]
++ String
" = id\n"
String
instDefs <- [(String, String, HsObject)] -> GB String
castInstDefs [(String, String, HsObject)]
superClasses
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
classDef forall a. [a] -> [a] -> [a]
++ String
instDefs forall a. [a] -> [a] -> [a]
++ String
instDef
where
castInstDefs :: [(String, String, HsObject)] -> GB String
castInstDefs [] = forall (m :: * -> *) a. Monad m => a -> m a
return String
""
castInstDefs ((String
superName, String
ptrName, Pointer CHSPtrType
ptrType' Bool
isNewtype'):[(String, String, HsObject)]
classes) =
do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CHSPtrType
ptrType forall a. Eq a => a -> a -> Bool
== CHSPtrType
ptrType') forall a b. (a -> b) -> a -> b
$
forall a. Position -> String -> String -> GB a
pointerTypeMismatchErr Position
pos String
className String
superName
let toMethodName :: String
toMethodName = case String
ptrName of
String
"" -> forall a. String -> a
interr String
"GenBind.classDef: \
\Illegal identifier - 2!"
Char
c:String
cs -> Char -> Char
toLower Char
c forall a. a -> [a] -> [a]
: String
cs
fromMethodName :: String
fromMethodName = String
"from" forall a. [a] -> [a] -> [a]
++ String
ptrName
castFun :: String
castFun = String
"cast" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CHSPtrType
ptrType
typeConstr :: String
typeConstr = if Bool
isNewtype then String
typeName forall a. [a] -> [a] -> [a]
++ String
" " else String
""
superConstr :: String
superConstr = if Bool
isNewtype' then String
ptrName forall a. [a] -> [a] -> [a]
++ String
" " else String
""
instDef :: String
instDef =
String
"instance " forall a. [a] -> [a] -> [a]
++ String
superName forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
typeName forall a. [a] -> [a] -> [a]
++ String
" where\n"
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
toMethodName forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
typeConstr forall a. [a] -> [a] -> [a]
++ String
"p) = "
forall a. [a] -> [a] -> [a]
++ String
superConstr forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
castFun forall a. [a] -> [a] -> [a]
++ String
" p)\n"
forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
fromMethodName forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ String
superConstr forall a. [a] -> [a] -> [a]
++ String
"p) = "
forall a. [a] -> [a] -> [a]
++ String
typeConstr forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ String
castFun forall a. [a] -> [a] -> [a]
++ String
" p)\n"
String
instDefs <- [(String, String, HsObject)] -> GB String
castInstDefs [(String, String, HsObject)]
classes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
instDef forall a. [a] -> [a] -> [a]
++ String
instDefs
data ConstResult = IntResult Integer
| FloatResult Float
data ExtType = FunET ExtType ExtType
| IOET ExtType
| PtrET ExtType
| DefinedET CDecl HsPtrRep
| PrimET CPrimType
| UnitET
instance Eq ExtType where
(FunET ExtType
t1 ExtType
t2 ) == :: ExtType -> ExtType -> Bool
== (FunET ExtType
t1' ExtType
t2' ) = ExtType
t1 forall a. Eq a => a -> a -> Bool
== ExtType
t1' Bool -> Bool -> Bool
&& ExtType
t2 forall a. Eq a => a -> a -> Bool
== ExtType
t2'
(IOET ExtType
t ) == (IOET ExtType
t' ) = ExtType
t forall a. Eq a => a -> a -> Bool
== ExtType
t'
(PtrET ExtType
t ) == (PtrET ExtType
t' ) = ExtType
t forall a. Eq a => a -> a -> Bool
== ExtType
t'
(DefinedET CDecl
_ HsPtrRep
rep ) == (DefinedET CDecl
_ HsPtrRep
rep' ) = HsPtrRep
rep forall a. Eq a => a -> a -> Bool
== HsPtrRep
rep'
(PrimET CPrimType
t ) == (PrimET CPrimType
t' ) = CPrimType
t forall a. Eq a => a -> a -> Bool
== CPrimType
t'
ExtType
UnitET == ExtType
UnitET = Bool
True
data CompType = ExtType ExtType
| SUType CStructUnion
isFunExtType :: ExtType -> Bool
isFunExtType :: ExtType -> Bool
isFunExtType (FunET ExtType
_ ExtType
_) = Bool
True
isFunExtType (IOET ExtType
_ ) = Bool
True
isFunExtType (DefinedET CDecl
_ (Bool
isFun,CHSPtrType
_,Maybe String
_,String
_)) = Bool
isFun
isFunExtType ExtType
_ = Bool
False
showExtType :: ExtType -> String
showExtType :: ExtType -> String
showExtType (FunET ExtType
UnitET ExtType
res) = ExtType -> String
showExtType ExtType
res
showExtType (FunET ExtType
arg ExtType
res) = String
"(" forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
arg forall a. [a] -> [a] -> [a]
++ String
" -> "
forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
res forall a. [a] -> [a] -> [a]
++ String
")"
showExtType (IOET ExtType
t) = String
"(IO " forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
t forall a. [a] -> [a] -> [a]
++ String
")"
showExtType (PtrET ExtType
t) = let ptrCon :: String
ptrCon = if ExtType -> Bool
isFunExtType ExtType
t
then String
"FunPtr" else String
"Ptr"
in
String
"(" forall a. [a] -> [a] -> [a]
++ String
ptrCon forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ ExtType -> String
showExtType ExtType
t
forall a. [a] -> [a] -> [a]
++ String
")"
showExtType (DefinedET CDecl
_ (Bool
_,CHSPtrType
_,Maybe String
_,String
str)) = String
str
showExtType (PrimET CPrimType
CPtrPT) = String
"(Ptr ())"
showExtType (PrimET CPrimType
CFunPtrPT) = String
"(FunPtr ())"
showExtType (PrimET CPrimType
CCharPT) = String
"CChar"
showExtType (PrimET CPrimType
CUCharPT) = String
"CUChar"
showExtType (PrimET CPrimType
CSCharPT) = String
"CSChar"
showExtType (PrimET CPrimType
CIntPT) = String
"CInt"
showExtType (PrimET CPrimType
CShortPT) = String
"CShort"
showExtType (PrimET CPrimType
CLongPT) = String
"CLong"
showExtType (PrimET CPrimType
CLLongPT) = String
"CLLong"
showExtType (PrimET CPrimType
CUIntPT) = String
"CUInt"
showExtType (PrimET CPrimType
CUShortPT) = String
"CUShort"
showExtType (PrimET CPrimType
CULongPT) = String
"CULong"
showExtType (PrimET CPrimType
CULLongPT) = String
"CULLong"
showExtType (PrimET CPrimType
CFloatPT) = String
"CFloat"
showExtType (PrimET CPrimType
CDoublePT) = String
"CDouble"
showExtType (PrimET CPrimType
CLDoublePT) = String
"CLDouble"
showExtType (PrimET (CSFieldPT Int
bs)) = String
"CInt{-:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
bs forall a. [a] -> [a] -> [a]
++ String
"-}"
showExtType (PrimET (CUFieldPT Int
bs)) = String
"CUInt{-:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
bs forall a. [a] -> [a] -> [a]
++ String
"-}"
showExtType ExtType
UnitET = String
"()"
extractFunType :: Position -> CDecl -> Bool ->
GB ([Maybe HsPtrRep], ExtType)
Position
pos CDecl
cdecl Bool
isPure =
do
let ([CDecl]
args, CDecl
resultDecl, Bool
variadic) = CDecl -> ([CDecl], CDecl, Bool)
funResultAndArgs CDecl
cdecl
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
variadic forall a b. (a -> b) -> a -> b
$
forall a. Position -> Position -> GB a
variadicErr Position
pos Position
cpos
ExtType
preResultType <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtType -> (Maybe HsPtrRep, ExtType)
expandSpecialPtrs) forall a b. (a -> b) -> a -> b
$
Position -> CDecl -> GB ExtType
extractSimpleType Position
pos CDecl
resultDecl
let resultType :: ExtType
resultType = if Bool
isPure
then ExtType
preResultType
else ExtType -> ExtType
IOET ExtType
preResultType
([Maybe HsPtrRep]
foreignSyn, [ExtType]
argTypes) <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ExtType -> (Maybe HsPtrRep, ExtType)
expandSpecialPtrs) forall a b. (a -> b) -> a -> b
$
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
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe HsPtrRep]
foreignSyn, 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 = forall a. Pos a => a -> Position
posOf CDecl
cdecl
expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType)
expandSpecialPtrs :: ExtType -> (Maybe HsPtrRep, ExtType)
expandSpecialPtrs all :: ExtType
all@(DefinedET CDecl
cdecl (Bool
_, CHSPtrType
CHSPtr, Maybe String
Nothing, String
_)) =
(forall a. Maybe a
Nothing, ExtType -> ExtType
PtrET ExtType
all)
expandSpecialPtrs all :: ExtType
all@(DefinedET CDecl
cdecl HsPtrRep
hsPtrRep) =
(forall a. a -> Maybe a
Just HsPtrRep
hsPtrRep, ExtType -> ExtType
PtrET ExtType
all)
expandSpecialPtrs ExtType
all = (forall a. Maybe a
Nothing, ExtType
all)
extractSimpleType :: Position -> CDecl -> GB ExtType
Position
pos CDecl
cdecl =
do
GB ()
traceEnter
CompType
ct <- CDecl -> GB CompType
extractCompType CDecl
cdecl
case CompType
ct of
ExtType ExtType
et -> forall (m :: * -> *) a. Monad m => a -> m a
return ExtType
et
SUType CStructUnion
_ -> forall a. Position -> Position -> GB a
illegalStructUnionErr (forall a. Pos a => a -> Position
posOf CDecl
cdecl) Position
pos
where
traceEnter :: GB ()
traceEnter = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"Entering `extractSimpleType'...\n"
extractPtrType :: CDecl -> GB ExtType
CDecl
cdecl = do
CompType
ct <- CDecl -> GB CompType
extractCompType CDecl
cdecl
case CompType
ct of
ExtType ExtType
et -> forall (m :: * -> *) a. Monad m => a -> m a
return ExtType
et
SUType CStructUnion
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ExtType
UnitET
extractCompType :: CDecl -> GB CompType
cdecl :: CDecl
cdecl@(CDecl [CDeclSpec]
specs [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs Attrs
ats) =
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs forall a. Ord a => a -> a -> Bool
> Int
1
then forall a. String -> a
interr String
"GenBind.extractCompType: Too many declarators!"
else case [(Maybe CDeclr, Maybe CInit, Maybe CExpr)]
declrs of
[(Just CDeclr
declr, Maybe CInit
_, Maybe CExpr
size)] | CDeclr -> Bool
isPtrDeclr CDeclr
declr -> CDeclr -> GB CompType
ptrType CDeclr
declr
| CDeclr -> Bool
isFunDeclr CDeclr
declr -> GB CompType
funType
| Bool
otherwise -> Maybe CExpr -> GB CompType
aliasOrSpecType Maybe CExpr
size
[] -> Maybe CExpr -> GB CompType
aliasOrSpecType forall a. Maybe a
Nothing
where
ptrType :: CDeclr -> GB CompType
ptrType CDeclr
declr = do
GB ()
tracePtrType
let declrs' :: CDeclr
declrs' = CDeclr -> CDeclr
dropPtrDeclr CDeclr
declr
cdecl' :: CDecl
cdecl' = [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(forall a. a -> Maybe a
Just CDeclr
declrs', forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)] Attrs
ats
oalias :: Maybe Ident
oalias = CDecl -> Maybe Ident
checkForOneAliasName CDecl
cdecl'
Maybe HsPtrRep
oHsRepr <- case Maybe Ident
oalias of
Maybe Ident
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing
Just Ident
ide -> (Bool, Ident)
-> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep)
queryPtr (Bool
True, Ident
ide)
case Maybe HsPtrRep
oHsRepr of
Just HsPtrRep
repr -> forall {s}. HsPtrRep -> PreCST SwitchBoard s CompType
ptrAlias HsPtrRep
repr
Maybe HsPtrRep
Nothing -> do
CompType
ct <- CDecl -> GB CompType
extractCompType CDecl
cdecl'
forall {s}. ExtType -> PreCST SwitchBoard s CompType
returnX forall a b. (a -> b) -> a -> b
$ case CompType
ct of
ExtType ExtType
et -> ExtType -> ExtType
PtrET ExtType
et
SUType CStructUnion
_ -> ExtType -> ExtType
PtrET ExtType
UnitET
funType :: GB CompType
funType = do
GB ()
traceFunType
([Maybe HsPtrRep]
_, ExtType
et) <- Position -> CDecl -> Bool -> GB ([Maybe HsPtrRep], ExtType)
extractFunType (forall a. Pos a => a -> Position
posOf CDecl
cdecl) CDecl
cdecl Bool
False
forall {s}. ExtType -> PreCST SwitchBoard s CompType
returnX ExtType
et
aliasOrSpecType :: Maybe CExpr -> GB CompType
aliasOrSpecType :: Maybe CExpr -> GB CompType
aliasOrSpecType Maybe CExpr
size = do
forall {a}. Maybe a -> GB ()
traceAliasOrSpecType Maybe CExpr
size
case CDecl -> Maybe Ident
checkForOneAliasName CDecl
cdecl of
Maybe Ident
Nothing -> Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType
specType (forall a. Pos a => a -> Position
posOf CDecl
cdecl) [CDeclSpec]
specs Maybe CExpr
size
Just Ident
ide -> do
Ident -> GB ()
traceAlias Ident
ide
Maybe HsPtrRep
oHsRepr <- (Bool, Ident)
-> PreCST SwitchBoard (CState GBState) (Maybe HsPtrRep)
queryPtr (Bool
False, Ident
ide)
case Maybe HsPtrRep
oHsRepr of
Maybe HsPtrRep
Nothing -> do
CDecl
cdecl' <- forall s. Ident -> CT s CDecl
getDeclOf Ident
ide
let CDecl [CDeclSpec]
specs [(Maybe CDeclr
declr, Maybe CInit
init, Maybe CExpr
_)] Attrs
at =
Ident
ide Ident -> CDecl -> CDecl
`simplifyDecl` CDecl
cdecl'
sdecl :: CDecl
sdecl = [CDeclSpec]
-> [(Maybe CDeclr, Maybe CInit, Maybe CExpr)] -> Attrs -> CDecl
CDecl [CDeclSpec]
specs [(Maybe CDeclr
declr, Maybe CInit
init, Maybe CExpr
size)] Attrs
at
CDecl -> GB CompType
extractCompType CDecl
sdecl
Just HsPtrRep
repr -> forall {s}. HsPtrRep -> PreCST SwitchBoard s CompType
ptrAlias HsPtrRep
repr
ptrAlias :: HsPtrRep -> PreCST SwitchBoard s CompType
ptrAlias (Bool
isFun, CHSPtrType
ptrTy, Maybe String
wrapped, String
tyArg) =
forall {s}. ExtType -> PreCST SwitchBoard s CompType
returnX forall a b. (a -> b) -> a -> b
$ CDecl -> HsPtrRep -> ExtType
DefinedET CDecl
cdecl (Bool
isFun, CHSPtrType
ptrTy, Maybe String
wrapped, String
tyArg)
returnX :: ExtType -> PreCST SwitchBoard s CompType
returnX retval :: ExtType
retval@(PtrET ExtType
et) = do
Bool
keepOld <- forall a s. (SwitchBoard -> a) -> CST s a
getSwitch SwitchBoard -> Bool
oldFFI
if Bool
keepOld
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType (CPrimType -> ExtType
PrimET CPrimType
CPtrPT)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType ExtType
retval
returnX ExtType
retval = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType ExtType
retval
tracePtrType :: GB ()
tracePtrType = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$ String
"extractCompType: explicit pointer type\n"
traceFunType :: GB ()
traceFunType = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$ String
"extractCompType: explicit function type\n"
traceAliasOrSpecType :: Maybe a -> GB ()
traceAliasOrSpecType Maybe a
Nothing = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"extractCompType: checking for alias\n"
traceAliasOrSpecType (Just a
_) = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"extractCompType: checking for alias of bitfield\n"
traceAlias :: Ident -> GB ()
traceAlias Ident
ide = String -> GB ()
traceGenBind forall a b. (a -> b) -> a -> b
$
String
"extractCompType: found an alias called `" forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
"'\n"
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 forall a. HasCallStack => a
undefined
char :: CTypeSpec
char = Attrs -> CTypeSpec
CCharType forall a. HasCallStack => a
undefined
short :: CTypeSpec
short = Attrs -> CTypeSpec
CShortType forall a. HasCallStack => a
undefined
int :: CTypeSpec
int = Attrs -> CTypeSpec
CIntType forall a. HasCallStack => a
undefined
long :: CTypeSpec
long = Attrs -> CTypeSpec
CLongType forall a. HasCallStack => a
undefined
float :: CTypeSpec
float = Attrs -> CTypeSpec
CFloatType forall a. HasCallStack => a
undefined
double :: CTypeSpec
double = Attrs -> CTypeSpec
CDoubleType forall a. HasCallStack => a
undefined
signed :: CTypeSpec
signed = Attrs -> CTypeSpec
CSignedType forall a. HasCallStack => a
undefined
unsigned :: CTypeSpec
unsigned = Attrs -> CTypeSpec
CUnsigType forall a. HasCallStack => a
undefined
enum :: CTypeSpec
enum = CEnum -> Attrs -> CTypeSpec
CEnumType forall a. HasCallStack => a
undefined forall a. HasCallStack => a
undefined
specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType
specType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB CompType
specType Position
cpos [CDeclSpec]
specs Maybe CExpr
osize =
let tspecs :: [CTypeSpec]
tspecs = [CTypeSpec
ts | CTypeSpec CTypeSpec
ts <- [CDeclSpec]
specs]
in case forall {b}. [CTypeSpec] -> [([CTypeSpec], b)] -> Maybe b
lookupTSpec [CTypeSpec]
tspecs [([CTypeSpec], ExtType)]
typeMap of
Just ExtType
et | ExtType -> Bool
isUnsupportedType ExtType
et -> forall a. Position -> GB a
unsupportedTypeSpecErr Position
cpos
| forall a. Maybe a -> Bool
isNothing Maybe CExpr
osize -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType ExtType
et
| Bool
otherwise -> [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
bitfieldSpec [CTypeSpec]
tspecs ExtType
et Maybe CExpr
osize
Maybe ExtType
Nothing ->
case [CTypeSpec]
tspecs of
[CSUType CStructUnion
cu Attrs
_] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CStructUnion -> CompType
SUType CStructUnion
cu
[CEnumType CEnum
_ Attrs
_] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ExtType -> CompType
ExtType (CPrimType -> ExtType
PrimET CPrimType
CIntPT)
[CTypeDef Ident
_ Attrs
_] -> forall a. String -> a
interr String
"GenBind.specType: Illegal typedef alias!"
[CTypeSpec]
_ -> forall a. Position -> GB a
illegalTypeSpecErr Position
cpos
where
lookupTSpec :: [CTypeSpec] -> [([CTypeSpec], b)] -> Maybe b
lookupTSpec = forall a b. (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
lookupBy [CTypeSpec] -> [CTypeSpec] -> Bool
matches
isUnsupportedType :: ExtType -> Bool
isUnsupportedType (PrimET CPrimType
et) = CPrimType -> Int
size CPrimType
et forall a. Eq a => a -> a -> Bool
== Int
0
isUnsupportedType ExtType
_ = Bool
False
matches :: [CTypeSpec] -> [CTypeSpec] -> Bool
[] matches :: [CTypeSpec] -> [CTypeSpec] -> Bool
`matches` [] = Bool
True
[] `matches` (CTypeSpec
_:[CTypeSpec]
_) = Bool
False
(CTypeSpec
spec:[CTypeSpec]
specs) `matches` [CTypeSpec]
specs'
| 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` forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy CTypeSpec -> CTypeSpec -> Bool
eqSpec CTypeSpec
spec [CTypeSpec]
specs'
| Bool
otherwise = Bool
False
eqSpec :: CTypeSpec -> CTypeSpec -> Bool
eqSpec (CVoidType Attrs
_) (CVoidType Attrs
_) = Bool
True
eqSpec (CCharType Attrs
_) (CCharType Attrs
_) = Bool
True
eqSpec (CShortType Attrs
_) (CShortType Attrs
_) = Bool
True
eqSpec (CIntType Attrs
_) (CIntType Attrs
_) = Bool
True
eqSpec (CLongType Attrs
_) (CLongType Attrs
_) = Bool
True
eqSpec (CFloatType Attrs
_) (CFloatType Attrs
_) = Bool
True
eqSpec (CDoubleType Attrs
_) (CDoubleType Attrs
_) = Bool
True
eqSpec (CSignedType Attrs
_) (CSignedType Attrs
_) = Bool
True
eqSpec (CUnsigType Attrs
_) (CUnsigType Attrs
_) = Bool
True
eqSpec (CSUType CStructUnion
_ Attrs
_) (CSUType CStructUnion
_ Attrs
_) = Bool
True
eqSpec (CEnumType CEnum
_ Attrs
_) (CEnumType CEnum
_ Attrs
_) = Bool
True
eqSpec (CTypeDef Ident
_ Attrs
_) (CTypeDef Ident
_ Attrs
_) = Bool
True
eqSpec CTypeSpec
_ CTypeSpec
_ = Bool
False
bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB CompType
bitfieldSpec [CTypeSpec]
tspecs ExtType
et (Just CExpr
sizeExpr) =
do
let pos :: Position
pos = forall a. Pos a => a -> Position
posOf CExpr
sizeExpr
ConstResult
sizeResult <- CExpr -> GB ConstResult
evalConstCExpr CExpr
sizeExpr
case ConstResult
sizeResult of
FloatResult Float
_ -> forall a. Position -> String -> GB a
illegalConstExprErr Position
pos String
"a float result"
IntResult Integer
size' -> do
let size :: Int
size = forall a. Num a => Integer -> a
fromInteger Integer
size'
case ExtType
et of
PrimET CPrimType
CUIntPT -> CPrimType -> GB CompType
returnCT forall a b. (a -> b) -> a -> b
$ Int -> CPrimType
CUFieldPT Int
size
PrimET CPrimType
CIntPT
| [CTypeSpec
signed] [CTypeSpec] -> [CTypeSpec] -> Bool
`matches` [CTypeSpec]
tspecs
Bool -> Bool -> Bool
|| [CTypeSpec
signed, CTypeSpec
int] [CTypeSpec] -> [CTypeSpec] -> Bool
`matches` [CTypeSpec]
tspecs -> CPrimType -> GB CompType
returnCT forall a b. (a -> b) -> a -> b
$ Int -> CPrimType
CSFieldPT Int
size
| [CTypeSpec
int] [CTypeSpec] -> [CTypeSpec] -> Bool
`matches` [CTypeSpec]
tspecs ->
CPrimType -> GB CompType
returnCT forall a b. (a -> b) -> a -> b
$ if Bool
bitfieldIntSigned then Int -> CPrimType
CSFieldPT Int
size
else Int -> CPrimType
CUFieldPT Int
size
ExtType
_ -> forall a. Position -> GB a
illegalFieldSizeErr Position
pos
where
returnCT :: CPrimType -> GB CompType
returnCT = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtType -> CompType
ExtType forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPrimType -> ExtType
PrimET
int :: CTypeSpec
int = Attrs -> CTypeSpec
CIntType forall a. HasCallStack => a
undefined
signed :: CTypeSpec
signed = Attrs -> CTypeSpec
CSignedType forall a. HasCallStack => a
undefined
data BitSize = BitSize Int Int
deriving (BitSize -> BitSize -> Bool
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
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)
instance Ord BitSize where
bs1 :: BitSize
bs1@(BitSize Int
o1 Int
b1) < :: BitSize -> BitSize -> Bool
< bs2 :: BitSize
bs2@(BitSize Int
o2 Int
b2) =
BitSize -> Int
padBits BitSize
bs1 forall a. Ord a => a -> a -> Bool
< BitSize -> Int
padBits BitSize
bs2 Bool -> Bool -> Bool
|| (Int
o1 forall a. Eq a => a -> a -> Bool
== Int
o2 Bool -> Bool -> Bool
&& Int
b1 forall a. Ord a => a -> a -> Bool
< Int
b2)
BitSize
bs1 <= :: BitSize -> BitSize -> Bool
<= BitSize
bs2 = BitSize
bs1 forall a. Ord a => a -> a -> Bool
< BitSize
bs2 Bool -> Bool -> Bool
|| BitSize
bs1 forall a. Eq a => a -> a -> Bool
== BitSize
bs2
addBitSize :: BitSize -> BitSize -> BitSize
addBitSize :: BitSize -> BitSize -> BitSize
addBitSize (BitSize Int
o1 Int
b1) (BitSize Int
o2 Int
b2) = Int -> Int -> BitSize
BitSize (Int
o1 forall a. Num a => a -> a -> a
+ Int
o2 forall a. Num a => a -> a -> a
+ Int
overflow) Int
rest
where
bitsPerBitfield :: Int
bitsPerBitfield = CPrimType -> Int
size CPrimType
CIntPT forall a. Num a => a -> a -> a
* Int
8
(Int
overflow, Int
rest) = (Int
b1 forall a. Num a => a -> a -> a
+ Int
b2) forall a. Integral a => a -> a -> (a, a)
`divMod` Int
bitsPerBitfield
padBits :: BitSize -> Int
padBits :: BitSize -> Int
padBits (BitSize Int
o Int
0) = Int
o
padBits (BitSize Int
o Int
_) = Int
o forall a. Num a => a -> a -> a
+ CPrimType -> Int
size CPrimType
CIntPT
offsetInStruct :: [CDecl] -> CDecl -> CStructTag -> GB BitSize
offsetInStruct :: [CDecl]
-> CDecl
-> CStructTag
-> PreCST SwitchBoard (CState GBState) BitSize
offsetInStruct [] CDecl
_ CStructTag
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> BitSize
BitSize Int
0 Int
0
offsetInStruct [CDecl]
decls CDecl
decl CStructTag
tag =
do
(BitSize
offset, Int
_) <- [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct [CDecl]
decls CStructTag
tag
(BitSize
_, Int
align) <- CDecl -> GB (BitSize, Int)
sizeAlignOf CDecl
decl
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BitSize -> Int -> BitSize
alignOffset BitSize
offset Int
align
sizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct [] CStructTag
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> BitSize
BitSize Int
0 Int
0, Int
1)
sizeAlignOfStruct [CDecl]
decls CStructTag
CStructTag =
do
(BitSize
offset, Int
preAlign) <- [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct (forall a. [a] -> [a]
init [CDecl]
decls) CStructTag
CStructTag
(BitSize
size, Int
align) <- CDecl -> GB (BitSize, Int)
sizeAlignOf (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 forall a. Ord a => a -> a -> Bool
> Int
0 then Int
align else Int
bitfieldAlignment
alignOfStruct :: Int
alignOfStruct = Int
preAlign forall a. Ord a => a -> a -> a
`max` Int
align'
forall (m :: * -> *) a. Monad m => a -> m a
return (BitSize
sizeOfStruct, Int
alignOfStruct)
sizeAlignOfStruct [CDecl]
decls CStructTag
CUnionTag =
do
([BitSize]
sizes, [Int]
aligns) <- 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 forall a. Ord a => a -> a -> Bool
> Int
0 then Int
align else Int
bitfieldAlignment
| Int
align <- [Int]
aligns]
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [BitSize]
sizes, forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
aligns')
sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStructPad [CDecl]
decls CStructTag
tag =
do
(BitSize
size, Int
align) <- [CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStruct [CDecl]
decls CStructTag
tag
forall (m :: * -> *) a. Monad m => a -> m a
return (BitSize -> Int -> BitSize
alignOffset BitSize
size Int
align, Int
align)
sizeAlignOf :: CDecl -> GB (BitSize, Int)
sizeAlignOf :: CDecl -> GB (BitSize, Int)
sizeAlignOf (CDecl [CDeclSpec]
specs [(Just CDeclr
declr, Maybe CInit
_, Maybe CExpr
size)] Attrs
ats) | CDeclr -> Bool
isArrDeclr CDeclr
declr =
forall a. String -> a
interr forall a b. (a -> b) -> a -> b
$ String
"sizeAlignOf: calculating size of constant array not supported."
sizeAlignOf CDecl
cdecl =
do
CompType
ct <- CDecl -> GB CompType
extractCompType CDecl
cdecl
case CompType
ct of
ExtType (FunET ExtType
_ ExtType
_ ) -> forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
CFunPtrPT,
CPrimType -> Int
alignment CPrimType
CFunPtrPT)
ExtType (IOET ExtType
_ ) -> forall a. String -> a
interr String
"GenBind.sizeof: Illegal IO type!"
ExtType (PtrET ExtType
t )
| ExtType -> Bool
isFunExtType ExtType
t -> forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
CFunPtrPT,
CPrimType -> Int
alignment CPrimType
CFunPtrPT)
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
CPtrPT, CPrimType -> Int
alignment CPrimType
CPtrPT)
ExtType (DefinedET CDecl
_ HsPtrRep
_ ) -> forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
CPtrPT, CPrimType -> Int
alignment CPrimType
CPtrPT)
ExtType (PrimET CPrimType
pt ) -> forall (m :: * -> *) a. Monad m => a -> m a
return (CPrimType -> BitSize
bitSize CPrimType
pt, CPrimType -> Int
alignment CPrimType
pt)
ExtType ExtType
UnitET -> forall a. Position -> GB a
voidFieldErr (forall a. Pos a => a -> Position
posOf CDecl
cdecl)
SUType CStructUnion
su ->
do
let ([CDecl]
fields, CStructTag
tag) = CStructUnion -> ([CDecl], CStructTag)
structMembers CStructUnion
su
[CDecl]
fields' <- let ide :: Maybe Ident
ide = CStructUnion -> Maybe Ident
structName CStructUnion
su
in
if (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [CDecl]
fields) Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isNothing Maybe Ident
ide
then forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl]
fields
else do
Maybe CTag
tag <- forall s. Ident -> CT s (Maybe CTag)
findTag (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Ident
ide)
case Maybe CTag
tag of
Just (StructUnionCT CStructUnion
su) -> forall (m :: * -> *) a. Monad m => a -> m a
return
(forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStructUnion -> ([CDecl], CStructTag)
structMembers forall a b. (a -> b) -> a -> b
$ CStructUnion
su)
Maybe CTag
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [CDecl]
fields
[CDecl] -> CStructTag -> GB (BitSize, Int)
sizeAlignOfStructPad [CDecl]
fields' CStructTag
tag
where
bitSize :: CPrimType -> BitSize
bitSize CPrimType
et | Int
sz forall a. Ord a => a -> a -> Bool
< Int
0 = Int -> Int -> BitSize
BitSize Int
0 (-Int
sz)
| Bool
otherwise = Int -> Int -> BitSize
BitSize Int
sz Int
0
where
sz :: Int
sz = CPrimType -> Int
size CPrimType
et
alignOffset :: BitSize -> Int -> BitSize
alignOffset :: BitSize -> Int -> BitSize
alignOffset offset :: BitSize
offset@(BitSize Int
octetOffset Int
bitOffset) Int
align
| Int
align forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
bitOffset forall a. Eq a => a -> a -> Bool
/= Int
0 =
BitSize -> Int -> BitSize
alignOffset (Int -> Int -> BitSize
BitSize (Int
octetOffset forall a. Num a => a -> a -> a
+ (Int
bitOffset forall a. Num a => a -> a -> a
+ Int
7) forall a. Integral a => a -> a -> a
`div` Int
8) Int
0) Int
align
| Int
align forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
bitOffset forall a. Eq a => a -> a -> Bool
== Int
0 =
Int -> Int -> BitSize
BitSize (((Int
octetOffset forall a. Num a => a -> a -> a
- Int
1) forall a. Integral a => a -> a -> a
`div` Int
align forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
* Int
align) Int
0
| Int
bitOffset forall a. Eq a => a -> a -> Bool
== Int
0
Bool -> Bool -> Bool
|| Bool
overflowingBitfield =
BitSize -> Int -> BitSize
alignOffset BitSize
offset Int
bitfieldAlignment
| Bool
otherwise =
BitSize
offset
where
bitsPerBitfield :: Int
bitsPerBitfield = CPrimType -> Int
size CPrimType
CIntPT forall a. Num a => a -> a -> a
* Int
8
overflowingBitfield :: Bool
overflowingBitfield = Int
bitOffset forall a. Num a => a -> a -> a
- Int
align forall a. Ord a => a -> a -> Bool
>= Int
bitsPerBitfield
evalConstCExpr :: CExpr -> GB ConstResult
evalConstCExpr :: CExpr -> GB ConstResult
evalConstCExpr (CComma [CExpr]
_ Attrs
at) =
forall a. Position -> String -> GB a
illegalConstExprErr (forall a. Pos a => a -> Position
posOf Attrs
at) String
"a comma expression"
evalConstCExpr (CAssign CAssignOp
_ CExpr
_ CExpr
_ Attrs
at) =
forall a. Position -> String -> GB a
illegalConstExprErr (forall a. Pos a => a -> Position
posOf Attrs
at) String
"an assignment"
evalConstCExpr (CCond CExpr
b (Just CExpr
t) CExpr
e Attrs
_) =
do
ConstResult
bv <- CExpr -> GB ConstResult
evalConstCExpr CExpr
b
case ConstResult
bv of
IntResult Integer
bvi -> if Integer
bvi forall a. Eq a => a -> a -> Bool
/= Integer
0 then CExpr -> GB ConstResult
evalConstCExpr CExpr
t else CExpr -> GB ConstResult
evalConstCExpr CExpr
e
FloatResult Float
_ -> forall a. Position -> String -> GB a
illegalConstExprErr (forall a. Pos a => a -> Position
posOf CExpr
b) String
"a float result"
evalConstCExpr (CBinary CBinaryOp
op CExpr
lhs CExpr
rhs Attrs
at) =
do
ConstResult
lhsVal <- CExpr -> GB ConstResult
evalConstCExpr CExpr
lhs
ConstResult
rhsVal <- CExpr -> GB ConstResult
evalConstCExpr CExpr
rhs
let (ConstResult
lhsVal', ConstResult
rhsVal') = ConstResult -> ConstResult -> (ConstResult, ConstResult)
usualArithConv ConstResult
lhsVal ConstResult
rhsVal
Position
-> CBinaryOp -> ConstResult -> ConstResult -> GB ConstResult
applyBin (forall a. Pos a => a -> Position
posOf Attrs
at) CBinaryOp
op ConstResult
lhsVal' ConstResult
rhsVal'
evalConstCExpr (CCast CDecl
_ CExpr
_ Attrs
_) =
forall a. String -> a
todo String
"GenBind.evalConstCExpr: Casts are not implemented yet."
evalConstCExpr (CUnary CUnaryOp
op CExpr
arg Attrs
at) =
do
ConstResult
argVal <- CExpr -> GB ConstResult
evalConstCExpr CExpr
arg
Position -> CUnaryOp -> ConstResult -> GB ConstResult
applyUnary (forall a. Pos a => a -> Position
posOf Attrs
at) CUnaryOp
op ConstResult
argVal
evalConstCExpr (CSizeofExpr CExpr
_ Attrs
_) =
forall a. String -> a
todo String
"GenBind.evalConstCExpr: sizeof not implemented yet."
evalConstCExpr (CSizeofType CDecl
decl Attrs
_) =
do
(BitSize
size, Int
_) <- CDecl -> GB (BitSize, Int)
sizeAlignOf CDecl
decl
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitSize -> Int
padBits forall a b. (a -> b) -> a -> b
$ BitSize
size)
evalConstCExpr (CAlignofExpr CExpr
_ Attrs
_) =
forall a. String -> a
todo String
"GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet."
evalConstCExpr (CAlignofType CDecl
decl Attrs
_) =
do
(BitSize
_, Int
align) <- CDecl -> GB (BitSize, Int)
sizeAlignOf CDecl
decl
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
align)
evalConstCExpr (CIndex CExpr
_ CExpr
_ Attrs
at) =
forall a. Position -> String -> GB a
illegalConstExprErr (forall a. Pos a => a -> Position
posOf Attrs
at) String
"array indexing"
evalConstCExpr (CCall CExpr
_ [CExpr]
_ Attrs
at) =
forall a. Position -> String -> GB a
illegalConstExprErr (forall a. Pos a => a -> Position
posOf Attrs
at) String
"function call"
evalConstCExpr (CMember CExpr
_ Ident
_ Bool
_ Attrs
at) =
forall a. Position -> String -> GB a
illegalConstExprErr (forall a. Pos a => a -> Position
posOf Attrs
at) String
"a . or -> operator"
evalConstCExpr (CVar Ident
ide Attrs
at) =
do
(CObj
cobj, Ident
_) <- forall s. Ident -> Bool -> CT s (CObj, Ident)
findValueObj Ident
ide Bool
False
case CObj
cobj of
EnumCO Ident
ide (CEnum Maybe Ident
_ [(Ident, Maybe CExpr)]
enumrs Attrs
_) -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Integer -> ConstResult
IntResult forall a b. (a -> b) -> a -> b
$
forall {t}.
Eq t =>
t
-> [(t, Maybe CExpr)]
-> Integer
-> PreCST SwitchBoard (CState GBState) Integer
enumTagValue Ident
ide [(Ident, Maybe CExpr)]
enumrs Integer
0
CObj
_ ->
forall a. String -> a
todo forall a b. (a -> b) -> a -> b
$ String
"GenBind.evalConstCExpr: variable names not implemented yet " forall a. [a] -> [a] -> [a]
++
forall a. Show a => a -> String
show (forall a. Pos a => a -> Position
posOf Attrs
at)
where
enumTagValue :: t
-> [(t, Maybe CExpr)]
-> Integer
-> PreCST SwitchBoard (CState GBState) Integer
enumTagValue t
_ [] Integer
_ =
forall a. String -> a
interr String
"GenBind.enumTagValue: enumerator not in declaration"
enumTagValue t
ide ((t
ide', Maybe CExpr
oexpr):[(t, Maybe CExpr)]
enumrs) Integer
val =
do
Integer
val' <- case Maybe CExpr
oexpr of
Maybe CExpr
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Integer
val
Just CExpr
exp ->
do
ConstResult
val' <- CExpr -> GB ConstResult
evalConstCExpr CExpr
exp
case ConstResult
val' of
IntResult Integer
val' -> forall (m :: * -> *) a. Monad m => a -> m a
return Integer
val'
FloatResult Float
_ ->
forall a. Position -> String -> GB a
illegalConstExprErr (forall a. Pos a => a -> Position
posOf CExpr
exp) String
"a float result"
if t
ide forall a. Eq a => a -> a -> Bool
== t
ide'
then
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
val'
else
t
-> [(t, Maybe CExpr)]
-> Integer
-> PreCST SwitchBoard (CState GBState) Integer
enumTagValue t
ide [(t, Maybe CExpr)]
enumrs (Integer
val' forall a. Num a => a -> a -> a
+ Integer
1)
evalConstCExpr (CConst CConst
c Attrs
_) =
CConst -> GB ConstResult
evalCConst CConst
c
evalCConst :: CConst -> GB ConstResult
evalCConst :: CConst -> GB ConstResult
evalCConst (CIntConst Integer
i Attrs
_ ) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult Integer
i
evalCConst (CCharConst Char
c Attrs
_ ) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (forall a. Integral a => a -> Integer
toInteger (forall a. Enum a => a -> Int
fromEnum Char
c))
evalCConst (CFloatConst String
s Attrs
_ ) =
forall a. String -> a
todo String
"GenBind.evalCConst: Float conversion from literal misses."
evalCConst (CStrConst String
s Attrs
at) =
forall a. Position -> String -> GB a
illegalConstExprErr (forall a. Pos a => a -> Position
posOf Attrs
at) String
"a string constant"
usualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult)
usualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult)
usualArithConv lhs :: ConstResult
lhs@(FloatResult Float
_) ConstResult
rhs = (ConstResult
lhs, ConstResult -> ConstResult
toFloat ConstResult
rhs)
usualArithConv ConstResult
lhs rhs :: ConstResult
rhs@(FloatResult Float
_) = (ConstResult -> ConstResult
toFloat ConstResult
lhs, ConstResult
rhs)
usualArithConv ConstResult
lhs ConstResult
rhs = (ConstResult
lhs, ConstResult
rhs)
toFloat :: ConstResult -> ConstResult
toFloat :: ConstResult -> ConstResult
toFloat x :: ConstResult
x@(FloatResult Float
_) = ConstResult
x
toFloat (IntResult Integer
i) = Float -> ConstResult
FloatResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Integer
i
applyBin :: Position
-> CBinaryOp
-> ConstResult
-> ConstResult
-> GB ConstResult
applyBin :: Position
-> CBinaryOp -> ConstResult -> ConstResult -> GB ConstResult
applyBin Position
cpos CBinaryOp
CMulOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Num a => a -> a -> a
* Integer
y)
applyBin Position
cpos CBinaryOp
CMulOp (FloatResult Float
x)
(FloatResult Float
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Float -> ConstResult
FloatResult (Float
x forall a. Num a => a -> a -> a
* Float
y)
applyBin Position
cpos CBinaryOp
CDivOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Integral a => a -> a -> a
`div` Integer
y)
applyBin Position
cpos CBinaryOp
CDivOp (FloatResult Float
x)
(FloatResult Float
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Float -> ConstResult
FloatResult (Float
x forall a. Fractional a => a -> a -> a
/ Float
y)
applyBin Position
cpos CBinaryOp
CRmdOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
returnforall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Integral a => a -> a -> a
`mod` Integer
y)
applyBin Position
cpos CBinaryOp
CRmdOp (FloatResult Float
x)
(FloatResult Float
y) =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a % operator applied to a float"
applyBin Position
cpos CBinaryOp
CAddOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Num a => a -> a -> a
+ Integer
y)
applyBin Position
cpos CBinaryOp
CAddOp (FloatResult Float
x)
(FloatResult Float
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Float -> ConstResult
FloatResult (Float
x forall a. Num a => a -> a -> a
+ Float
y)
applyBin Position
cpos CBinaryOp
CSubOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Num a => a -> a -> a
- Integer
y)
applyBin Position
cpos CBinaryOp
CSubOp (FloatResult Float
x)
(FloatResult Float
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Float -> ConstResult
FloatResult (Float
x forall a. Num a => a -> a -> a
- Float
y)
applyBin Position
cpos CBinaryOp
CShlOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Num a => a -> a -> a
* Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
y)
applyBin Position
cpos CBinaryOp
CShlOp (FloatResult Float
x)
(FloatResult Float
y) =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a << operator applied to a float"
applyBin Position
cpos CBinaryOp
CShrOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Integral a => a -> a -> a
`div` Integer
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
y)
applyBin Position
cpos CBinaryOp
CShrOp (FloatResult Float
x)
(FloatResult Float
y) =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a >> operator applied to a float"
applyBin Position
cpos CBinaryOp
CAndOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Bits a => a -> a -> a
.&. Integer
y)
applyBin Position
cpos CBinaryOp
COrOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Bits a => a -> a -> a
.|. Integer
y)
applyBin Position
cpos CBinaryOp
CXorOp (IntResult Integer
x)
(IntResult Integer
y) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> ConstResult
IntResult (Integer
x forall a. Bits a => a -> a -> a
`xor` Integer
y)
applyBin Position
cpos CBinaryOp
_ (IntResult Integer
x)
(IntResult Integer
y) =
forall a. String -> a
todo String
"GenBind.applyBin: Not yet implemented operator in constant expression."
applyBin Position
cpos CBinaryOp
_ (FloatResult Float
x)
(FloatResult Float
y) =
forall a. String -> a
todo String
"GenBind.applyBin: Not yet implemented operator in constant expression."
applyBin Position
_ CBinaryOp
_ ConstResult
_ ConstResult
_ =
forall a. String -> a
interr String
"GenBind.applyBinOp: Illegal combination!"
applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult
applyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult
applyUnary Position
cpos CUnaryOp
CPreIncOp ConstResult
_ =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a ++ operator"
applyUnary Position
cpos CUnaryOp
CPreDecOp ConstResult
_ =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a -- operator"
applyUnary Position
cpos CUnaryOp
CPostIncOp ConstResult
_ =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a ++ operator"
applyUnary Position
cpos CUnaryOp
CPostDecOp ConstResult
_ =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a -- operator"
applyUnary Position
cpos CUnaryOp
CAdrOp ConstResult
_ =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a & operator"
applyUnary Position
cpos CUnaryOp
CIndOp ConstResult
_ =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"a * operator"
applyUnary Position
cpos CUnaryOp
CPlusOp ConstResult
arg = forall (m :: * -> *) a. Monad m => a -> m a
return ConstResult
arg
applyUnary Position
cpos CUnaryOp
CMinOp (IntResult Integer
x) = forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> ConstResult
IntResult (-Integer
x))
applyUnary Position
cpos CUnaryOp
CMinOp (FloatResult Float
x) = forall (m :: * -> *) a. Monad m => a -> m a
return (Float -> ConstResult
FloatResult (-Float
x))
applyUnary Position
cpos CUnaryOp
CCompOp (IntResult Integer
x) = forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> ConstResult
IntResult (forall a. Bits a => a -> a
complement Integer
x))
applyUnary Position
cpos CUnaryOp
CNegOp (IntResult Integer
x) =
let r :: Integer
r = forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ (Integer
x forall a. Eq a => a -> a -> Bool
== Integer
0)
in forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> ConstResult
IntResult Integer
r)
applyUnary Position
cpos CUnaryOp
CNegOp (FloatResult Float
_) =
forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
"! applied to a float"
noPosIdent :: String -> Ident
noPosIdent :: String -> Ident
noPosIdent = Position -> String -> Ident
onlyPosIdent Position
nopos
traceGenBind :: String -> GB ()
traceGenBind :: String -> GB ()
traceGenBind = forall s. (Traces -> Bool) -> String -> CST s ()
putTraceStr Traces -> Bool
traceGenBindSW
lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
lookupBy :: forall a b. (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b
lookupBy a -> a -> Bool
eq a
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (a -> a -> Bool
eq a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
mapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ :: forall (m :: * -> *) a b. Monad m => (a -> m b) -> Maybe a -> m ()
mapMaybeM_ a -> m b
m Maybe a
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return ()
mapMaybeM_ a -> m b
m (Just a
a) = a -> m b
m a
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
unknownFieldErr :: Position -> Ident -> GB a
unknownFieldErr :: forall a. Position -> Ident -> GB a
unknownFieldErr Position
cpos Ident
ide =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc (forall a. Pos a => a -> Position
posOf Ident
ide)
[String
"Unknown member name!",
String
"The structure has no member called `" forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide
forall a. [a] -> [a] -> [a]
++ String
"'. The structure is defined at",
forall a. Show a => a -> String
show Position
cpos forall a. [a] -> [a] -> [a]
++ String
"."]
illegalStructUnionErr :: Position -> Position -> GB a
illegalStructUnionErr :: forall a. Position -> Position -> GB a
illegalStructUnionErr Position
cpos Position
pos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Illegal structure or union type!",
String
"There is not automatic support for marshaling of structures and",
String
"unions; the offending type is declared at "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
cpos forall a. [a] -> [a] -> [a]
++ String
"."]
illegalTypeSpecErr :: Position -> GB a
illegalTypeSpecErr :: forall a. Position -> GB a
illegalTypeSpecErr Position
cpos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos
[String
"Illegal type!",
String
"The type specifiers of this declaration do not form a legal ANSI C(89) \
\type."
]
unsupportedTypeSpecErr :: Position -> GB a
unsupportedTypeSpecErr :: forall a. Position -> GB a
unsupportedTypeSpecErr Position
cpos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos
[String
"Unsupported type!",
String
"The type specifier of this declaration is not supported by your C \
\compiler."
]
variadicErr :: Position -> Position -> GB a
variadicErr :: forall a. Position -> Position -> GB a
variadicErr Position
pos Position
cpos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Variadic function!",
String
"Calling variadic functions is not supported by the FFI; the function",
String
"is defined at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Position
cpos forall a. [a] -> [a] -> [a]
++ String
"."]
illegalConstExprErr :: Position -> String -> GB a
illegalConstExprErr :: forall a. Position -> String -> GB a
illegalConstExprErr Position
cpos String
hint =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos [String
"Illegal constant expression!",
String
"Encountered " forall a. [a] -> [a] -> [a]
++ String
hint forall a. [a] -> [a] -> [a]
++ String
" in a constant expression,",
String
"which ANSI C89 does not permit."]
voidFieldErr :: Position -> GB a
voidFieldErr :: forall a. Position -> GB a
voidFieldErr Position
cpos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos [String
"Void field in struct!",
String
"Attempt to access a structure field of type void."]
structExpectedErr :: Ident -> GB a
structExpectedErr :: forall a. Ident -> GB a
structExpectedErr Ident
ide =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc (forall a. Pos a => a -> Position
posOf Ident
ide)
[String
"Expected a structure or union!",
String
"Attempt to access member `" forall a. [a] -> [a] -> [a]
++ Ident -> String
identToLexeme Ident
ide forall a. [a] -> [a] -> [a]
++ String
"' in something not",
String
"a structure or union."]
ptrExpectedErr :: Position -> GB a
ptrExpectedErr :: forall a. Position -> GB a
ptrExpectedErr Position
pos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Expected a pointer object!",
String
"Attempt to dereference a non-pointer object or to use it in a `pointer' \
\hook."]
illegalStablePtrErr :: Position -> GB a
illegalStablePtrErr :: forall a. Position -> GB a
illegalStablePtrErr Position
pos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Illegal use of a stable pointer!",
String
"Class hooks cannot be used for stable pointers."]
pointerTypeMismatchErr :: Position -> String -> String -> GB a
pointerTypeMismatchErr :: forall a. Position -> String -> String -> GB a
pointerTypeMismatchErr Position
pos String
className String
superName =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Pointer type mismatch!",
String
"The pointer of the class hook for `" forall a. [a] -> [a] -> [a]
++ String
className
forall a. [a] -> [a] -> [a]
++ String
"' is of a different kind",
String
"than that of the class hook for `" forall a. [a] -> [a] -> [a]
++ String
superName forall a. [a] -> [a] -> [a]
++ String
"'; this is illegal",
String
"as the latter is defined to be an (indirect) superclass of the former."]
illegalFieldSizeErr :: Position -> GB a
illegalFieldSizeErr :: forall a. Position -> GB a
illegalFieldSizeErr Position
cpos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
cpos
[String
"Illegal field size!",
String
"Only signed and unsigned `int' types may have a size annotation."]
derefBitfieldErr :: Position -> GB a
derefBitfieldErr :: forall a. Position -> GB a
derefBitfieldErr Position
pos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Illegal dereferencing of a bit field!",
String
"Bit fields cannot be dereferenced."]
resMarshIllegalInErr :: Position -> GB a
resMarshIllegalInErr :: forall a. Position -> GB a
resMarshIllegalInErr Position
pos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Malformed result marshalling!",
String
"There may not be an \"in\" marshaller for the result."]
resMarshIllegalTwoCValErr :: Position -> GB a
resMarshIllegalTwoCValErr :: forall a. Position -> GB a
resMarshIllegalTwoCValErr Position
pos =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Malformed result marshalling!",
String
"Two C values (i.e., the `&' symbol) are not allowed for the result."]
marshArgMismatchErr :: Position -> String -> GB a
marshArgMismatchErr :: forall a. Position -> String -> GB a
marshArgMismatchErr Position
pos String
reason =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Function arity mismatch!",
String
reason]
noDftMarshErr :: Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr :: forall a. Position -> String -> String -> [ExtType] -> GB a
noDftMarshErr Position
pos String
inOut String
hsTy [ExtType]
cTys =
forall s a. Position -> [String] -> CT s a
raiseErrorCTExc Position
pos
[String
"Missing " forall a. [a] -> [a] -> [a]
++ String
inOut forall a. [a] -> [a] -> [a]
++ String
" marshaller!",
String
"There is no default marshaller for this combination of Haskell and \
\C type:",
String
"Haskell type: " forall a. [a] -> [a] -> [a]
++ String
hsTy,
String
"C type : " forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
" " (forall a b. (a -> b) -> [a] -> [b]
map ExtType -> String
showExtType [ExtType]
cTys))]