{-# LANGUAGE CPP #-}
module Foreign.Hoppy.Generator.Hook (
Hooks (..),
defaultHooks,
EnumEvaluator,
EnumEvaluatorArgs (..),
EnumEvaluatorEntry (..),
EnumEvaluatorResult (..),
evaluateEnumsWithCompiler,
evaluateEnumsWithDefaultCompiler,
makeCppSourceToEvaluateEnums,
interpretOutputToEvaluateEnums,
internalEvaluateEnumsForInterface,
) where
import Control.Arrow ((&&&))
import Control.Monad (forM, forM_, unless, when)
import Control.Monad.Except (ExceptT (ExceptT), MonadError, runExceptT, throwError)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (MonadState, execStateT, modify')
import Control.Monad.Writer (execWriter, tell)
import Data.ByteString.Lazy (ByteString, hPut)
import Data.ByteString.Builder (stringUtf8, toLazyByteString)
#if !MIN_VERSION_base(4,12,0)
import Data.List (splitAt)
#endif
import qualified Data.Map as M
import Data.Maybe (isJust, listToMaybe, mapMaybe)
import qualified Data.Set as S
import Foreign.C (CInt, CLong, CLLong, CUInt, CULong, CULLong)
import Foreign.Hoppy.Generator.Common (doubleQuote, for, fromMaybeM, pluralize)
import Foreign.Hoppy.Generator.Common.Consume (MonadConsume, evalConsume, next)
import Foreign.Hoppy.Generator.Compiler (Compiler, SomeCompiler (SomeCompiler), compileProgram)
import Foreign.Hoppy.Generator.Language.Cpp (renderIdentifier)
import Foreign.Hoppy.Generator.Spec.Base
import Foreign.Hoppy.Generator.Types (intT, llongT, longT, uintT, ullongT, ulongT)
import Foreign.Hoppy.Generator.Util (withTempFile)
import Foreign.Hoppy.Generator.Version (CppVersion (Cpp2011), activeCppVersion)
import Foreign.Storable (Storable, sizeOf)
import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitFailure)
import System.IO (hClose, hPutStrLn, stderr)
import System.Process (readProcessWithExitCode)
data Hooks = Hooks
{ hookEvaluateEnums :: EnumEvaluator
}
defaultHooks :: Hooks
defaultHooks =
Hooks
{ hookEvaluateEnums = evaluateEnumsWithDefaultCompiler
}
type EnumEvaluator = EnumEvaluatorArgs -> IO (Maybe EnumEvaluatorResult)
data EnumEvaluatorArgs = EnumEvaluatorArgs
{ enumEvaluatorArgsInterface :: Interface
, enumEvaluatorArgsReqs :: Reqs
, enumEvaluatorArgsSizeofIdentifiers :: [Identifier]
, enumEvaluatorArgsEntries :: [EnumEvaluatorEntry]
, enumEvaluatorArgsKeepOutputsOnFailure :: Bool
}
data EnumEvaluatorEntry = EnumEvaluatorEntry
{ enumEvaluatorEntryScoped :: Scoped
, enumEvaluatorEntryIdentifier :: Identifier
}
deriving (Eq)
instance Ord EnumEvaluatorEntry where
compare (EnumEvaluatorEntry _ i1) (EnumEvaluatorEntry _ i2) =
compare (OrdIdentifier i1) (OrdIdentifier i2)
data EnumEvaluatorResult = EnumEvaluatorResult
{ enumEvaluatorResultSizes :: ![Int]
, enumEvaluatorResultValues :: ![Integer]
} deriving (Show)
emptyEnumEvaluatorResult :: EnumEvaluatorResult
emptyEnumEvaluatorResult = EnumEvaluatorResult
{ enumEvaluatorResultSizes = []
, enumEvaluatorResultValues = []
}
evaluateEnumsWithDefaultCompiler :: EnumEvaluator
evaluateEnumsWithDefaultCompiler args = do
let iface = enumEvaluatorArgsInterface args
case interfaceCompiler iface of
Just (SomeCompiler compiler) -> evaluateEnumsWithCompiler compiler args
Nothing -> do
hPutStrLn stderr $
"evaluateEnumsWithDefaultCompiler: Don't have a compiler to evaluate enums with in " ++
show iface ++ "."
return Nothing
evaluateEnumsWithCompiler :: Compiler a => a -> EnumEvaluator
evaluateEnumsWithCompiler compiler args =
withTempFile "hoppy-enum.cpp" removeBuildFailures $ \cppPath cppHandle ->
withTempFile "hoppy-enum" removeBuildFailures $ \binPath binHandle -> do
hPut cppHandle program
hClose cppHandle
hClose binHandle
success <- compileProgram compiler cppPath binPath
result <- case success of
False -> do
hPutStrLn stderr $
"evaluateEnumsWithCompiler: Failed to build program " ++ show cppPath ++
" to evaluate enums with " ++ show compiler ++ "." ++ removeBuildFailuresNote
return Nothing
True -> runAndGetOutput binPath
let remove = isJust result || removeBuildFailures
return (remove, (remove, result))
where removeBuildFailures = not $ enumEvaluatorArgsKeepOutputsOnFailure args
removeBuildFailuresNote =
if removeBuildFailures
then " Pass --keep-temp-outputs-on-failure to keep build outputs around for debugging."
else " --keep-temp-outputs-on-failure was given, leaving files on disk."
program = makeCppSourceToEvaluateEnums args
runAndGetOutput :: FilePath -> IO (Maybe EnumEvaluatorResult)
runAndGetOutput binPath = do
result <- runExceptT $ do
(exitCode, out, err) <- liftIO $ readProcessWithExitCode binPath [] ""
case exitCode of
ExitFailure code ->
throwError $
"evaluateEnumsWithCompiler: Failed to run binary " ++ show binPath ++
", code = " ++ show code ++ ", stdout = <<<" ++ out ++ ">>>, stderr = <<<" ++
err ++ ">>>." ++ removeBuildFailuresNote
ExitSuccess ->
ExceptT $ return $ interpretOutputToEvaluateEnums args out
case result of
Right value -> return $ Just value
Left err -> do
hPutStrLn stderr err
return Nothing
makeCppSourceToEvaluateEnums :: EnumEvaluatorArgs -> ByteString
makeCppSourceToEvaluateEnums args =
toLazyByteString $ stringUtf8 $ unlines $
[ "#include <iostream>"
] ++
(if any isEntryScoped $ enumEvaluatorArgsEntries args
then [ "#include <type_traits>" ]
else []) ++
[ ""
] ++ [concatMap includeToString $
S.elems $ reqsIncludes $ enumEvaluatorArgsReqs args] ++
[ ""
, "int main() {"
, " std::cout << \"#sizes\\n\";"
] ++ for (enumEvaluatorArgsSizeofIdentifiers args)
(\identifier ->
let rendered = renderIdentifier identifier
in " std::cout << sizeof(" ++ rendered ++ ") << ' ' << " ++
doubleQuote rendered ++ " << '\\n';") ++
[ " std::cout << \"#values\\n\";"
] ++ for (enumEvaluatorArgsEntries args)
(\(EnumEvaluatorEntry scoped identifier) ->
let rendered = renderIdentifier identifier
numericExpr = case scoped of
Unscoped -> rendered
Scoped ->
"static_cast<std::underlying_type<decltype(" ++ rendered ++ ")>::type>(" ++
rendered ++ ")"
in " std::cout << (" ++ numericExpr ++ ") << ' ' << " ++
doubleQuote rendered ++ " << '\\n';") ++
[ ""
, " return 0;"
, "}"
]
interpretOutputToEvaluateEnums ::
EnumEvaluatorArgs
-> String
-> Either String EnumEvaluatorResult
interpretOutputToEvaluateEnums args out =
evalConsume (lines out) $ runExceptT $ flip execStateT emptyEnumEvaluatorResult $ do
expectLine "#sizes"
readSizes $ enumEvaluatorArgsSizeofIdentifiers args
expectLine "#values"
readValues $ map (\(EnumEvaluatorEntry _ i) -> i) $ enumEvaluatorArgsEntries args
expectEof
modify' $ \EnumEvaluatorResult
{ enumEvaluatorResultSizes = sizes
, enumEvaluatorResultValues = values
} ->
EnumEvaluatorResult
{ enumEvaluatorResultSizes = reverse sizes
, enumEvaluatorResultValues = reverse values
}
where expectEof :: (MonadConsume String m, MonadError String m) => m ()
expectEof = next >>= \case
Nothing -> return ()
Just line -> throwError $ "Expected EOF, got " ++ show line ++ "."
expectLine :: (MonadConsume String m, MonadError String m) => String -> m ()
expectLine expected = do
line <- next
when (line /= Just expected) $
throwError $ "Expected " ++ show expected ++ ", got " ++ show line ++ "."
expectIdentifier :: (MonadError String m, Read a) => Identifier -> String -> m a
expectIdentifier identifier line = case reads line of
[(value, ' ':identStr)] -> do
let expectedStr = renderIdentifier identifier
unless (identStr == expectedStr) $
throwError $ "Expected identifier " ++ show expectedStr ++ ", but saw identifier " ++
show identStr ++ "."
return value
_ ->
throwError $ "Expected a line for " ++ show identifier ++ ", but got line " ++
show line ++ "."
readSizes :: (MonadConsume String m, MonadError String m, MonadState EnumEvaluatorResult m)
=> [Identifier]
-> m ()
readSizes expectedIdentifiers = case expectedIdentifiers of
[] -> return ()
expectedIdentifier:restIdentifiers -> next >>= \case
Just line -> do
size <- expectIdentifier expectedIdentifier line
modify' $ \r@EnumEvaluatorResult { enumEvaluatorResultSizes = sizes } ->
r { enumEvaluatorResultSizes = size:sizes }
readSizes restIdentifiers
Nothing -> throwError "Unexpected end of input while reading enum sizes."
readValues :: (MonadConsume String m, MonadError String m, MonadState EnumEvaluatorResult m)
=> [Identifier]
-> m ()
readValues expectedIdentifiers = case expectedIdentifiers of
[] -> return ()
expectedIdentifier:restIdentifiers -> next >>= \case
Just line -> do
value <- expectIdentifier expectedIdentifier line
modify' $ \r@EnumEvaluatorResult { enumEvaluatorResultValues = values } ->
r { enumEvaluatorResultValues = value:values }
readValues restIdentifiers
Nothing -> throwError "Unexpected end of input while reading enum sizes."
internalEvaluateEnumsForInterface :: Interface -> Bool -> IO Interface
internalEvaluateEnumsForInterface iface keepBuildFailures =
case interfaceEvaluatedEnumData iface of
Just _ -> return iface
Nothing -> internalEvaluateEnumsForInterface' iface keepBuildFailures
internalEvaluateEnumsForInterface' :: Interface -> Bool -> IO Interface
internalEvaluateEnumsForInterface' iface keepBuildFailures = do
let validateEnumTypes = interfaceValidateEnumTypes iface
allExports :: M.Map ExtName Export
allExports = M.unions $ map moduleExports $ M.elems $ interfaceModules iface
enumExports :: [(ExtName, Maybe Type, Scoped, Maybe Identifier, Reqs, EnumValueMap)]
enumExports = flip mapMaybe (M.elems allExports) $ \export ->
flip fmap (getExportEnumInfo export) $ \(info :: EnumInfo) ->
(enumInfoExtName info,
enumInfoNumericType info,
enumInfoScoped info,
case (enumInfoNumericType info, validateEnumTypes) of
(Just _, False) -> Nothing
_ -> Just $ enumInfoIdentifier info,
enumInfoReqs info,
enumInfoValues info)
sumReqs :: Reqs
sizeofIdentifiersToEvaluate :: [OrdIdentifier]
entriesToEvaluate :: [EnumEvaluatorEntry]
(sumReqs, sizeofIdentifiersToEvaluate, entriesToEvaluate) =
(\(a, b, c) -> (a, b, S.toList $ S.fromList c)) $
execWriter $ forM_ enumExports $ \(_, _, scoped, maybeIdent, reqs, entries) -> do
tell (reqs,
maybe [] (\i -> [OrdIdentifier i]) maybeIdent,
[])
forM_ (M.toList $ enumValueMapValues entries) $ \(_, value) -> case value of
EnumValueManual _ -> return ()
EnumValueAuto identifier -> tell (mempty, [], [EnumEvaluatorEntry scoped identifier])
when (activeCppVersion < Cpp2011) $ do
let scopedEnumsWithAutoEntries :: [ExtName] = flip mapMaybe enumExports $
\(extName, _, _, _, _, entries) ->
if any isAuto $ M.elems $ enumValueMapValues entries
then Just extName
else Nothing
(namesToShow, namesToSkip) = splitAt 10 scopedEnumsWithAutoEntries
unless (null scopedEnumsWithAutoEntries) $ do
hPutStrLn stderr $
"internalEvaluateEnumsForInterface': Automatic evaluation of enum values is not " ++
"requires at least " ++ show Cpp2011 ++ ", but we are compiling for " ++
show activeCppVersion ++ ", aborting. Enums requesting evaluation are " ++
show namesToShow ++
(if not $ null namesToSkip then " (and more)" else "") ++ "."
exitFailure
evaluatorResult :: EnumEvaluatorResult <-
case (sizeofIdentifiersToEvaluate, entriesToEvaluate) of
([], []) -> return emptyEnumEvaluatorResult
_ -> do
let hooks = interfaceHooks iface
args = EnumEvaluatorArgs
{ enumEvaluatorArgsInterface = iface
, enumEvaluatorArgsReqs = sumReqs
, enumEvaluatorArgsSizeofIdentifiers =
map ordIdentifier sizeofIdentifiersToEvaluate
, enumEvaluatorArgsEntries = entriesToEvaluate
, enumEvaluatorArgsKeepOutputsOnFailure = keepBuildFailures
}
hookEvaluateEnums hooks args >>=
fromMaybeM
(do hPutStrLn stderr $
"internalEvaluateEnumsForInterface': Failed to build and run program. Aborting."
exitFailure)
let entryIdentifiersToEvaluate :: [OrdIdentifier]
entryIdentifiersToEvaluate =
map (OrdIdentifier . enumEvaluatorEntryIdentifier) entriesToEvaluate
evaluatedIdentifierSizes :: M.Map OrdIdentifier Int
evaluatedIdentifierSizes =
M.fromList $ zip sizeofIdentifiersToEvaluate $ enumEvaluatorResultSizes evaluatorResult
evaluatedIdentifierValues :: M.Map OrdIdentifier Integer
evaluatedIdentifierValues =
M.fromList $ zip entryIdentifiersToEvaluate $ enumEvaluatorResultValues evaluatorResult
getIdentifierSize :: Identifier -> IO Int
getIdentifierSize identifier =
fromMaybeM
(do hPutStrLn stderr $
"internalEvaluateEnumsForInterface': Internal error, " ++
"failed to find evaluated size for " ++ show identifier ++ "."
exitFailure) $
M.lookup (OrdIdentifier identifier) evaluatedIdentifierSizes
getIdentifierValue :: Identifier -> IO Integer
getIdentifierValue identifier =
fromMaybeM
(do hPutStrLn stderr $
"internalEvaluateEnumsForInterface': Internal error, " ++
"failed to find evaluated value for " ++ show identifier ++ "."
exitFailure) $
M.lookup (OrdIdentifier identifier) evaluatedIdentifierValues
getNumericTypeInfo :: ExtName -> Type -> IO NumericTypeInfo
getNumericTypeInfo extName t =
fromMaybeM
(do hPutStrLn stderr $
"internalEvaluateEnumsForInterface': Explicit type " ++ show t ++
" for enum " ++ show extName ++ " is not a usable numeric type."
exitFailure) $
findNumericTypeInfo t
evaluatedDataMap :: M.Map ExtName EvaluatedEnumData <-
fmap M.fromList $ forM enumExports $
\(extName, maybeNumericType, _, maybeIdent, _, values) -> do
numMap :: M.Map [String] Integer <-
fmap M.fromList $ forM (M.toList $ enumValueMapValues values) $ \(label, value) -> do
num <- case value of
EnumValueManual n -> return n
EnumValueAuto entryIdent -> getIdentifierValue entryIdent
return (label, num)
bytes <- case (maybeNumericType, maybeIdent) of
(Just numericType, Just identifier) -> do
providedBytes <- numBytes <$> getNumericTypeInfo extName numericType
evaluatedBytes <- getIdentifierSize identifier
when (providedBytes /= evaluatedBytes) $ do
hPutStrLn stderr $
"internalEvaluateEnumsForInterface': The explicit type " ++ show numericType ++
" for enum " ++ show extName ++ " takes " ++ pluralize providedBytes "byte" "bytes" ++
", but sizeof(" ++ renderIdentifier identifier ++ ") evaluates to " ++
pluralize evaluatedBytes "byte" "bytes" ++ "."
exitFailure
return providedBytes
(Just numericType, Nothing) -> numBytes <$> getNumericTypeInfo extName numericType
(Nothing, Just identifier) -> getIdentifierSize identifier
(Nothing, Nothing) ->
error $ "internalEvaluateEnumsForInterface': Internal error, don't have a size for " ++
"enum " ++ show extName ++ ", shouldn't happen."
let (low, high) = minimum &&& maximum $ M.elems numMap
numericType <-
fromMaybeM
(do hPutStrLn stderr $
"internalEvaluateEnumsForInterface': Couldn't find a numeric type " ++
"to use to represent the C++ enumeration " ++ show extName ++ "."
exitFailure) $
pickNumericType bytes low high
let result = EvaluatedEnumData
{ evaluatedEnumType = numericType
, evaluatedEnumValueMap = numMap
}
return (extName, result)
return iface { interfaceEvaluatedEnumData = Just evaluatedDataMap }
newtype OrdIdentifier = OrdIdentifier { ordIdentifier :: Identifier }
deriving (Eq, Show)
instance Ord OrdIdentifier where
compare (OrdIdentifier i1) (OrdIdentifier i2) =
compare (renderIdentifier i1) (renderIdentifier i2)
data NumericTypeInfo = NumericTypeInfo
{ numType :: Type
, numBytes :: Int
, numMinBound :: Integer
, numMaxBound :: Integer
}
numericTypeInfo :: [NumericTypeInfo]
numericTypeInfo =
[ mk intT (undefined :: CInt)
, mk uintT (undefined :: CUInt)
, mk longT (undefined :: CLong)
, mk ulongT (undefined :: CULong)
, mk llongT (undefined :: CLLong)
, mk ullongT (undefined :: CULLong)
]
where mk :: forall a. (Bounded a, Integral a, Storable a) => Type -> a -> NumericTypeInfo
mk t _ = NumericTypeInfo
{ numType = t
, numBytes = sizeOf (undefined :: a)
, numMinBound = toInteger (minBound :: a)
, numMaxBound = toInteger (maxBound :: a)
}
findNumericTypeInfo :: Type -> Maybe NumericTypeInfo
findNumericTypeInfo t = listToMaybe $ filter (\i -> numType i == t) numericTypeInfo
pickNumericType :: Int -> Integer -> Integer -> Maybe Type
pickNumericType bytes low high =
fmap numType $ listToMaybe $ flip filter numericTypeInfo $ \info ->
numBytes info == bytes &&
numMinBound info <= low &&
numMaxBound info >= high
isAuto :: EnumValue -> Bool
isAuto (EnumValueAuto _) = True
isAuto (EnumValueManual _) = False
isEntryScoped :: EnumEvaluatorEntry -> Bool
isEntryScoped (EnumEvaluatorEntry scoped _) = isScoped scoped