{-# LANGUAGE CPP #-}
module Foreign.Hoppy.Generator.Main (
Action (..),
defaultMain,
defaultMain',
run,
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Arrow ((&&&))
import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar, readMVar)
import Control.Monad ((<=<), forM, unless, when)
import Data.Foldable (forM_)
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Foreign.Hoppy.Generator.Common (fromMaybeM, writeFileIfDifferent)
import Foreign.Hoppy.Generator.Hook (internalEvaluateEnumsForInterface)
import qualified Foreign.Hoppy.Generator.Language.Cpp as Cpp
import qualified Foreign.Hoppy.Generator.Language.Cpp.Internal as Cpp
import qualified Foreign.Hoppy.Generator.Language.Haskell.Internal as Haskell
import Foreign.Hoppy.Generator.Spec
import System.Directory (createDirectoryIfMissing, doesDirectoryExist)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.FilePath ((</>), takeDirectory)
import System.IO (hPutStrLn, stderr)
data Action =
SelectInterface String
| ListInterfaces
| ListCppFiles
| ListHsFiles
| GenCpp FilePath
| GenHaskell FilePath
| KeepTempOutputsOnFailure
| DumpExtNames
| DumpEnums
data AppState = AppState
{ appInterfaces :: Map String Interface
, appCurrentInterfaceName :: String
, appCaches :: Caches
, appKeepTempOutputsOnFailure :: Bool
}
appCurrentInterface :: AppState -> Interface
appCurrentInterface state =
let name = appCurrentInterfaceName state
in case M.lookup name $ appInterfaces state of
Just iface -> iface
Nothing ->
error $
"Main.appCurrentInterface: Internal error, couldn't find current interface " ++
show name ++ "."
initialAppState :: [Interface] -> AppState
initialAppState ifaces = AppState
{ appInterfaces = M.fromList $ map (interfaceName &&& id) ifaces
, appCurrentInterfaceName = interfaceName $ head ifaces
, appCaches = M.empty
, appKeepTempOutputsOnFailure = False
}
type Caches = Map String InterfaceCache
data InterfaceCache = InterfaceCache
{ generatedCpp :: Maybe Cpp.Generation
, generatedHaskell :: Maybe Haskell.Generation
}
emptyCache :: InterfaceCache
emptyCache = InterfaceCache Nothing Nothing
getGeneratedCpp ::
AppState
-> Interface
-> InterfaceCache
-> IO (Interface, InterfaceCache, Either String Cpp.Generation)
getGeneratedCpp state iface cache = case generatedCpp cache of
Just gen -> return (iface, cache, Right gen)
_ -> do
iface' <- evaluateEnums state iface
case Cpp.generate iface' of
l@(Left _) -> return (iface', cache, l)
r@(Right gen) -> return (iface', cache { generatedCpp = Just gen }, r)
getGeneratedHaskell ::
AppState
-> Interface
-> InterfaceCache
-> IO (Interface, InterfaceCache, Either String Haskell.Generation)
getGeneratedHaskell state iface cache = case generatedHaskell cache of
Just gen -> return (iface, cache, Right gen)
_ -> do
iface' <- evaluateEnums state iface
case Haskell.generate iface' of
l@(Left _) -> return (iface', cache, l)
r@(Right gen) -> return (iface', cache { generatedHaskell = Just gen }, r)
evaluateEnums :: AppState -> Interface -> IO Interface
evaluateEnums state iface =
internalEvaluateEnumsForInterface iface $
appKeepTempOutputsOnFailure state
defaultMain :: Either String Interface -> IO ()
defaultMain interfaceResult = defaultMain' [interfaceResult]
defaultMain' :: [Either String Interface] -> IO ()
defaultMain' interfaceResults = do
interfaces <- forM interfaceResults $ \case
Left errorMsg -> do
hPutStrLn stderr $ "Error initializing interface: " ++ errorMsg
exitFailure
Right iface -> return iface
args <- getArgs
_ <- run interfaces args
return ()
run :: [Interface] -> [String] -> IO [Action]
run interfaces args = do
stateVar <- newMVar $ initialAppState interfaces
when (null args) $ do
putStrLn "This is a Hoppy interface generator. Use --help for options."
putStrLn ""
putStrLn $ "Interfaces: " ++ unwords (map interfaceName interfaces)
exitSuccess
when ("--help" `elem` args) $ usage stateVar >> exitSuccess
processArgs stateVar args
usage :: MVar AppState -> IO ()
usage stateVar = do
interfaceNames <- map interfaceName <$> getInterfaces stateVar
mapM_ putStrLn
[ "Hoppy binding generator"
, ""
, "Interfaces: " ++ intercalate ", " interfaceNames
, ""
, "Supported options:"
, " --help Displays this menu."
, " --interface <iface> Sets the interface used for subsequent options."
, " --list-interfaces Lists the interfaces compiled into this binary."
, " --list-cpp-files Lists generated file paths in C++ bindings."
, " --list-hs-files Lists generated file paths in Haskell bindings."
, " --gen-cpp <outdir> Generate C++ bindings in a directory."
, " --gen-hs <outdir> Generate Haskell bindings under the given"
, " top-level source directory."
, " --keep-temp-outputs-on-failure"
, " Keeps on disk any temporary programs that fail"
, " to build. Pass this before --gen-* commands."
, " --dump-ext-names Lists the current interface's external names."
, " --dump-enums Lists the current interface's enum data."
, ""
, "Arguments are processed in the order seen."
]
processArgs :: MVar AppState -> [String] -> IO [Action]
processArgs stateVar args =
case args of
[] -> return []
"--interface":name:rest -> do
modifyMVar_ stateVar $ \state ->
case M.lookup name $ appInterfaces state of
Nothing -> do
hPutStrLn stderr $
"--interface: Interface '" ++ name ++ "' doesn't exist in this generator."
_ <- exitFailure
return state
Just _ -> return state { appCurrentInterfaceName = name }
(SelectInterface name:) <$> processArgs stateVar rest
"--list-interfaces":rest -> do
listInterfaces stateVar
(ListInterfaces:) <$> processArgs stateVar rest
"--list-cpp-files":rest -> do
genResult <- withCurrentCache stateVar getGeneratedCpp
case genResult of
Left errorMsg -> do
hPutStrLn stderr $ "--list-cpp-files: Failed to generate: " ++ errorMsg
exitFailure
Right gen -> do
mapM_ putStrLn $ M.keys $ Cpp.generatedFiles gen
(ListCppFiles:) <$> processArgs stateVar rest
"--list-hs-files":rest -> do
genResult <- withCurrentCache stateVar getGeneratedHaskell
case genResult of
Left errorMsg -> do
hPutStrLn stderr $ "--list-hs-files: Failed to generate: " ++ errorMsg
exitFailure
Right gen -> do
mapM_ putStrLn $ M.keys $ Haskell.generatedFiles gen
(ListHsFiles:) <$> processArgs stateVar rest
"--gen-cpp":baseDir:rest -> do
baseDirExists <- doesDirectoryExist baseDir
unless baseDirExists $ do
hPutStrLn stderr $
"--gen-cpp: Please create this directory so that I can generate files in it: " ++
baseDir
exitFailure
genResult <- withCurrentCache stateVar getGeneratedCpp
case genResult of
Left errorMsg -> do
hPutStrLn stderr $ "--gen-cpp: Failed to generate: " ++ errorMsg
exitFailure
Right gen -> do
forM_ (M.toList $ Cpp.generatedFiles gen) $
uncurry $ writeGeneratedFile baseDir
(GenCpp baseDir:) <$> processArgs stateVar rest
"--gen-hs":baseDir:rest -> do
baseDirExists <- doesDirectoryExist baseDir
unless baseDirExists $ do
hPutStrLn stderr $
"--gen-hs: Please create this directory so that I can generate files in it: " ++
baseDir
exitFailure
genResult <- withCurrentCache stateVar getGeneratedHaskell
case genResult of
Left errorMsg -> do
hPutStrLn stderr $ "--gen-hs: Failed to generate: " ++ errorMsg
exitFailure
Right gen -> do
forM_ (M.toList $ Haskell.generatedFiles gen) $
uncurry $ writeGeneratedFile baseDir
(GenHaskell baseDir:) <$> processArgs stateVar rest
"--dump-ext-names":rest -> do
withCurrentCache stateVar $ \_ iface cache -> do
forM_ (interfaceModules iface) $ \m ->
forM_ (moduleExports m) $ \export ->
forM_ (getAllExtNames export) $ \extName ->
putStrLn $ "extname module=" ++ moduleName m ++ " name=" ++ fromExtName extName
return (iface, cache, ())
(DumpExtNames:) <$> processArgs stateVar rest
"--dump-enums":rest -> do
withCurrentCache stateVar $ \state iface cache -> do
iface' <- evaluateEnums state iface
allEvaluatedData <- flip fromMaybeM (interfaceEvaluatedEnumData iface') $ do
hPutStrLn stderr $ "--dump-enums expected to have evaluated enum data, but doesn't."
exitFailure
forM_ (M.toList allEvaluatedData) $ \(extName, evaluatedData) -> do
m <- flip fromMaybeM (M.lookup extName $ interfaceNamesToModules iface) $ do
hPutStrLn stderr $
"--dump-enums couldn't find module for enum " ++ show extName ++ "."
exitFailure
let typeStr =
Cpp.chunkContents $ Cpp.execChunkWriter $
Cpp.sayType Nothing $ evaluatedEnumType evaluatedData
putStrLn $ "enum name=" ++ fromExtName extName ++ " module=" ++ moduleName m ++
" type=" ++ typeStr
forM_ (M.toList $ evaluatedEnumValueMap evaluatedData) $ \(words', number) ->
putStrLn $ "entry value=" ++ show number ++ " name=" ++ show words'
return (iface', cache, ())
(DumpEnums:) <$> processArgs stateVar rest
"--keep-temp-outputs-on-failure":rest -> do
modifyMVar_ stateVar $ \state -> return $ state { appKeepTempOutputsOnFailure = True }
(KeepTempOutputsOnFailure:) <$> processArgs stateVar rest
arg:_ -> do
hPutStrLn stderr $ "Invalid option or missing argument for '" ++ arg ++ "'."
exitFailure
writeGeneratedFile :: FilePath -> FilePath -> String -> IO ()
writeGeneratedFile baseDir subpath contents = do
let path = baseDir </> subpath
createDirectoryIfMissing True $ takeDirectory path
writeFileIfDifferent path contents
withCurrentCache ::
MVar AppState
-> (AppState -> Interface -> InterfaceCache -> IO (Interface, InterfaceCache, a))
-> IO a
withCurrentCache stateVar fn = modifyMVar stateVar $ \state -> do
let iface = appCurrentInterface state
name = interfaceName iface
let cache = fromMaybe emptyCache $ M.lookup name $ appCaches state
(iface', cache', result) <- fn state iface cache
return ( state { appInterfaces = M.insert name iface' $ appInterfaces state
, appCaches = M.insert name cache' $ appCaches state
}
, result
)
listInterfaces :: MVar AppState -> IO ()
listInterfaces = mapM_ (putStrLn . interfaceName) <=< getInterfaces
getInterfaces :: MVar AppState -> IO [Interface]
getInterfaces = fmap (M.elems . appInterfaces) . readMVar