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