-- This file is part of Hoppy.
--
-- Copyright 2015-2021 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE CPP #-}

-- | A driver for a command-line interface to a generator.
--
-- A simple @Main.hs@ for a generator can simply be:
--
-- @
-- import "Foreign.Hoppy.Generator.Main" ('defaultMain')
-- import "Foreign.Hoppy.Generator.Spec" ('ErrorMsg', 'Interface', 'interface')
--
-- interfaceResult :: Either 'ErrorMsg' 'Interface'
-- interfaceResult = 'interface' ...
--
-- main :: IO ()
-- main = 'defaultMain' interfaceResult
-- @
module Foreign.Hoppy.Generator.Main (
  Action (..),
  EnumEvalCacheMode (..),
  defaultMain,
  defaultMain',
  ensureInterfaces,
  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, doesFileExist, removeFile)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.FilePath ((</>), takeDirectory)
import System.IO (hPutStrLn, stderr)

-- | Actions that can be requested of the program.
data Action =
    SelectInterface String
    -- ^ Sets the interface that will be used for subsequent actions.
  | ListInterfaces
    -- ^ Lists the interfaces compiled into the generator.
  | ListCppFiles
    -- ^ Lists the generated files in C++ bindings.
  | ListHsFiles
    -- ^ Lists the generated files in Haskell bindings.
  | GenCpp FilePath
    -- ^ Generates C++ wrappers for an interface in the given location.
  | GenHaskell FilePath
    -- ^ Generates Haskell bindings for an interface in the given location.
  | CleanCpp FilePath
    -- ^ Removes the generated files in C++ bindings.
  | CleanHs FilePath
    -- ^ Removes the generated files in Haskell bindings.
  | KeepTempOutputsOnFailure
    -- ^ Instructs the generator to keep on disk any temporary programs or files
    -- created, in case of failure.
  | DumpExtNames
    -- ^ Dumps to stdout information about all external names in the current
    -- interface.
  | DumpEnums
    -- ^ Dumps to stdout information about all enums in the current interface.
  | EnumEvalCachePath (Maybe FilePath)
    -- ^ Specifies the path to a enum evaluation cache file to use.
  | EnumEvalCacheMode EnumEvalCacheMode
    -- ^ Specifies the behaviour with respect to how the enum evaluation cache
    -- cache file is used.

data AppState = AppState
  { AppState -> Map String Interface
appInterfaces :: Map String Interface
  , AppState -> String
appCurrentInterfaceName :: String
  , AppState -> Caches
appCaches :: Caches
  , AppState -> Bool
appKeepTempOutputsOnFailure :: Bool
  , AppState -> Maybe String
appEnumEvalCachePath :: Maybe FilePath
  , AppState -> EnumEvalCacheMode
appEnumEvalCacheMode :: EnumEvalCacheMode
  }

-- | Controls the behaviour of a generatior with respect to the enum cache file,
-- when a file path provided (@--enum-eval-cache-path@).
--
-- If enum evaluation is required, based on the presence of the cache file and
-- which of these modes is selected, then the compiler will be called and the
-- results will be written to the cache file
--
-- If an enum cache file path is not provided, then this mode is ignored, and
-- enum evaluation is attempted if a generator requires it.
--
-- Change detection is not currently supported.  There is no ability to detect
-- whether the cache file is up to date and contains all of the enum entries for
-- the current state of the enums defined in an interface.  The cache file is
-- meant to be refreshed with 'RefreshEnumCache' when building the C++ binding
-- package, and installed with them so that the Haskell binding package can use
-- 'EnumCacheMustExist'.
data EnumEvalCacheMode =
    RefreshEnumCache
    -- ^ The default.  Ignore the presence of an existing cache file, and
    -- evaluate enums freshly, updating the cache file with new contents.
  | EnumCacheMustExist
    -- ^ Require the cache file to exist.  If it does not, enum evaluation will
    -- not be attempted; the generator will exit unsuccessfully instead.

appCurrentInterface :: AppState -> Interface
appCurrentInterface :: AppState -> Interface
appCurrentInterface AppState
state =
  let name :: String
name = AppState -> String
appCurrentInterfaceName AppState
state
  in case String -> Map String Interface -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (Map String Interface -> Maybe Interface)
-> Map String Interface -> Maybe Interface
forall a b. (a -> b) -> a -> b
$ AppState -> Map String Interface
appInterfaces AppState
state of
       Just Interface
iface -> Interface
iface
       Maybe Interface
Nothing ->
         String -> Interface
forall a. HasCallStack => String -> a
error (String -> Interface) -> String -> Interface
forall a b. (a -> b) -> a -> b
$
         String
"Main.appCurrentInterface: Internal error, couldn't find current interface " String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String -> String
forall a. Show a => a -> String
show String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

initialAppState :: [Interface] -> AppState
initialAppState :: [Interface] -> AppState
initialAppState [Interface]
ifaces = AppState :: Map String Interface
-> String
-> Caches
-> Bool
-> Maybe String
-> EnumEvalCacheMode
-> AppState
AppState
  { appInterfaces :: Map String Interface
appInterfaces = [(String, Interface)] -> Map String Interface
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, Interface)] -> Map String Interface)
-> [(String, Interface)] -> Map String Interface
forall a b. (a -> b) -> a -> b
$ (Interface -> (String, Interface))
-> [Interface] -> [(String, Interface)]
forall a b. (a -> b) -> [a] -> [b]
map (Interface -> String
interfaceName (Interface -> String)
-> (Interface -> Interface) -> Interface -> (String, Interface)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Interface -> Interface
forall a. a -> a
id) [Interface]
ifaces
  , appCurrentInterfaceName :: String
appCurrentInterfaceName = Interface -> String
interfaceName (Interface -> String) -> Interface -> String
forall a b. (a -> b) -> a -> b
$ [Interface] -> Interface
forall a. [a] -> a
head [Interface]
ifaces
  , appCaches :: Caches
appCaches = Caches
forall k a. Map k a
M.empty
  , appKeepTempOutputsOnFailure :: Bool
appKeepTempOutputsOnFailure = Bool
False
  , appEnumEvalCachePath :: Maybe String
appEnumEvalCachePath = Maybe String
forall a. Maybe a
Nothing
  , appEnumEvalCacheMode :: EnumEvalCacheMode
appEnumEvalCacheMode = EnumEvalCacheMode
RefreshEnumCache
  }

type Caches = Map String InterfaceCache

data InterfaceCache = InterfaceCache
  { InterfaceCache -> Maybe Generation
cacheGeneratedCpp :: Maybe Cpp.Generation
  , InterfaceCache -> Maybe Generation
cacheGeneratedHaskell :: Maybe Haskell.Generation
  , InterfaceCache -> Maybe ComputedInterfaceData
cacheComputedData :: Maybe ComputedInterfaceData
  }

emptyCache :: InterfaceCache
emptyCache :: InterfaceCache
emptyCache = Maybe Generation
-> Maybe Generation
-> Maybe ComputedInterfaceData
-> InterfaceCache
InterfaceCache Maybe Generation
forall a. Maybe a
Nothing Maybe Generation
forall a. Maybe a
Nothing Maybe ComputedInterfaceData
forall a. Maybe a
Nothing

getGeneratedCpp ::
     Maybe FilePath
  -> AppState
  -> Interface
  -> InterfaceCache
  -> IO (InterfaceCache, Either String Cpp.Generation)
getGeneratedCpp :: Maybe String
-> AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
getGeneratedCpp Maybe String
maybeCppDir AppState
state Interface
iface InterfaceCache
cache = case InterfaceCache -> Maybe Generation
cacheGeneratedCpp InterfaceCache
cache of
  Just Generation
gen -> (InterfaceCache, Either String Generation)
-> IO (InterfaceCache, Either String Generation)
forall (m :: * -> *) a. Monad m => a -> m a
return (InterfaceCache
cache, Generation -> Either String Generation
forall a b. b -> Either a b
Right Generation
gen)
  Maybe Generation
Nothing -> do
    InterfaceCache
cache' <- Maybe String
-> AppState -> Interface -> InterfaceCache -> IO InterfaceCache
generateComputedData Maybe String
maybeCppDir AppState
state Interface
iface InterfaceCache
cache
    ComputedInterfaceData
computedData <- (IO ComputedInterfaceData
 -> Maybe ComputedInterfaceData -> IO ComputedInterfaceData)
-> Maybe ComputedInterfaceData
-> IO ComputedInterfaceData
-> IO ComputedInterfaceData
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO ComputedInterfaceData
-> Maybe ComputedInterfaceData -> IO ComputedInterfaceData
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (InterfaceCache -> Maybe ComputedInterfaceData
cacheComputedData InterfaceCache
cache') (IO ComputedInterfaceData -> IO ComputedInterfaceData)
-> IO ComputedInterfaceData -> IO ComputedInterfaceData
forall a b. (a -> b) -> a -> b
$ do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"getGeneratedCpp: Expected computed data to already exist for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Interface -> String
forall a. Show a => a -> String
show Interface
iface String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
      IO ComputedInterfaceData
forall a. IO a
exitFailure
    case Interface -> ComputedInterfaceData -> Either String Generation
Cpp.generate Interface
iface ComputedInterfaceData
computedData of
      l :: Either String Generation
l@(Left String
_) -> (InterfaceCache, Either String Generation)
-> IO (InterfaceCache, Either String Generation)
forall (m :: * -> *) a. Monad m => a -> m a
return (InterfaceCache
cache', Either String Generation
l)
      r :: Either String Generation
r@(Right Generation
gen) -> (InterfaceCache, Either String Generation)
-> IO (InterfaceCache, Either String Generation)
forall (m :: * -> *) a. Monad m => a -> m a
return (InterfaceCache
cache' { cacheGeneratedCpp :: Maybe Generation
cacheGeneratedCpp = Generation -> Maybe Generation
forall a. a -> Maybe a
Just Generation
gen }, Either String Generation
r)

getGeneratedHaskell ::
  AppState
  -> Interface
  -> InterfaceCache
  -> IO (InterfaceCache, Either String Haskell.Generation)
getGeneratedHaskell :: AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
getGeneratedHaskell AppState
state Interface
iface InterfaceCache
cache = case InterfaceCache -> Maybe Generation
cacheGeneratedHaskell InterfaceCache
cache of
  Just Generation
gen -> (InterfaceCache, Either String Generation)
-> IO (InterfaceCache, Either String Generation)
forall (m :: * -> *) a. Monad m => a -> m a
return (InterfaceCache
cache, Generation -> Either String Generation
forall a b. b -> Either a b
Right Generation
gen)
  Maybe Generation
Nothing -> do
    InterfaceCache
cache' <- Maybe String
-> AppState -> Interface -> InterfaceCache -> IO InterfaceCache
generateComputedData Maybe String
forall a. Maybe a
Nothing AppState
state Interface
iface InterfaceCache
cache
    ComputedInterfaceData
computedData <- (IO ComputedInterfaceData
 -> Maybe ComputedInterfaceData -> IO ComputedInterfaceData)
-> Maybe ComputedInterfaceData
-> IO ComputedInterfaceData
-> IO ComputedInterfaceData
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO ComputedInterfaceData
-> Maybe ComputedInterfaceData -> IO ComputedInterfaceData
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (InterfaceCache -> Maybe ComputedInterfaceData
cacheComputedData InterfaceCache
cache') (IO ComputedInterfaceData -> IO ComputedInterfaceData)
-> IO ComputedInterfaceData -> IO ComputedInterfaceData
forall a b. (a -> b) -> a -> b
$ do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"getGeneratedHaskell: Expected computed data to already exist for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Interface -> String
forall a. Show a => a -> String
show Interface
iface String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
      IO ComputedInterfaceData
forall a. IO a
exitFailure
    case Interface -> ComputedInterfaceData -> Either String Generation
Haskell.generate Interface
iface ComputedInterfaceData
computedData of
      l :: Either String Generation
l@(Left String
_) -> (InterfaceCache, Either String Generation)
-> IO (InterfaceCache, Either String Generation)
forall (m :: * -> *) a. Monad m => a -> m a
return (InterfaceCache
cache', Either String Generation
l)
      r :: Either String Generation
r@(Right Generation
gen) -> (InterfaceCache, Either String Generation)
-> IO (InterfaceCache, Either String Generation)
forall (m :: * -> *) a. Monad m => a -> m a
return (InterfaceCache
cache' { cacheGeneratedHaskell :: Maybe Generation
cacheGeneratedHaskell = Generation -> Maybe Generation
forall a. a -> Maybe a
Just Generation
gen }, Either String Generation
r)

-- | Ensures that the cached computed data for an interface been calculated,
-- doing so if it hasn't.
--
-- This ensures that the 'ComputedInterfaceData' for an 'Interface' has been
-- calculated.  This is only computed once for an interface, and is stored in
-- the interface's 'InterfaceCache'.  This function returns the resulting cache
-- with the computed data populated.
generateComputedData ::
     Maybe FilePath
  -> AppState
  -> Interface
  -> InterfaceCache
  -> IO InterfaceCache
generateComputedData :: Maybe String
-> AppState -> Interface -> InterfaceCache -> IO InterfaceCache
generateComputedData Maybe String
maybeCppDir AppState
state Interface
iface InterfaceCache
cache = case InterfaceCache -> Maybe ComputedInterfaceData
cacheComputedData InterfaceCache
cache of
  Just ComputedInterfaceData
_ -> InterfaceCache -> IO InterfaceCache
forall (m :: * -> *) a. Monad m => a -> m a
return InterfaceCache
cache
  Maybe ComputedInterfaceData
Nothing -> do
    Map ExtName EvaluatedEnumData
evaluatedEnumMap <- AppState
-> Interface -> Maybe String -> IO (Map ExtName EvaluatedEnumData)
generateEnumData AppState
state Interface
iface Maybe String
maybeCppDir
    InterfaceCache -> IO InterfaceCache
forall (m :: * -> *) a. Monad m => a -> m a
return InterfaceCache
cache
      { cacheComputedData :: Maybe ComputedInterfaceData
cacheComputedData = ComputedInterfaceData -> Maybe ComputedInterfaceData
forall a. a -> Maybe a
Just ComputedInterfaceData :: String -> Map ExtName EvaluatedEnumData -> ComputedInterfaceData
ComputedInterfaceData
        { computedInterfaceName :: String
computedInterfaceName = Interface -> String
interfaceName Interface
iface
        , evaluatedEnumMap :: Map ExtName EvaluatedEnumData
evaluatedEnumMap = Map ExtName EvaluatedEnumData
evaluatedEnumMap
        }
      }

-- | Generates evaluated enum data for storing in the interface cache.
--
-- If there is a cache path provided, and the file exists, then it is loaded and
-- used.  Otherwise, if there is a cache path provided and the file doesn't
-- exist, but a cache path is set to be required ('appEnumEvalCacheRequire'),
-- then generation aborts.  Otherwise, the enum evaluation hook is called to
-- evaluate the enums (see "Foreign.Hoppy.Generator.Hook"), and if a cache path
-- is provided, then the result is serialized and written to the path.
generateEnumData :: AppState -> Interface -> Maybe FilePath -> IO (Map ExtName EvaluatedEnumData)
generateEnumData :: AppState
-> Interface -> Maybe String -> IO (Map ExtName EvaluatedEnumData)
generateEnumData AppState
state Interface
iface Maybe String
maybeCppDir =
  case AppState -> Maybe String
appEnumEvalCachePath AppState
state of
    Maybe String
Nothing -> IO (Map ExtName EvaluatedEnumData)
doEnumEval
    Just String
path -> do
      Bool
cached <- String -> IO Bool
doesFileExist String
path
      case (AppState -> EnumEvalCacheMode
appEnumEvalCacheMode AppState
state, Bool
cached) of
        (EnumEvalCacheMode
RefreshEnumCache, Bool
_) -> String -> IO (Map ExtName EvaluatedEnumData)
evalAndWriteFile String
path
        (EnumEvalCacheMode
EnumCacheMustExist, Bool
True) -> String -> IO (Map ExtName EvaluatedEnumData)
useFile String
path
        (EnumEvalCacheMode
EnumCacheMustExist, Bool
False) -> do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"generateEnumData: Error, enum evaluation cache expected for " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            Interface -> String
forall a. Show a => a -> String
show Interface
iface String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", but none found at path '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."
          IO (Map ExtName EvaluatedEnumData)
forall a. IO a
exitFailure

  where useFile :: String -> IO (Map ExtName EvaluatedEnumData)
useFile String
path = String -> Map ExtName EvaluatedEnumData
deserializeEnumData (String -> Map ExtName EvaluatedEnumData)
-> IO String -> IO (Map ExtName EvaluatedEnumData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
path
        evalAndWriteFile :: String -> IO (Map ExtName EvaluatedEnumData)
evalAndWriteFile String
path = do
          Map ExtName EvaluatedEnumData
result <- IO (Map ExtName EvaluatedEnumData)
doEnumEval
          String -> String -> IO ()
writeFileIfDifferent String
path (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Map ExtName EvaluatedEnumData -> String
serializeEnumData Map ExtName EvaluatedEnumData
result
          Map ExtName EvaluatedEnumData -> IO (Map ExtName EvaluatedEnumData)
forall (m :: * -> *) a. Monad m => a -> m a
return Map ExtName EvaluatedEnumData
result
        doEnumEval :: IO (Map ExtName EvaluatedEnumData)
doEnumEval = do
          Interface
-> Maybe String -> Bool -> IO (Map ExtName EvaluatedEnumData)
internalEvaluateEnumsForInterface Interface
iface Maybe String
maybeCppDir
            (AppState -> Bool
appKeepTempOutputsOnFailure AppState
state)

serializeEnumData :: Map ExtName EvaluatedEnumData -> String
serializeEnumData :: Map ExtName EvaluatedEnumData -> String
serializeEnumData = Map String EvaluatedEnumData -> String
forall a. Show a => a -> String
show (Map String EvaluatedEnumData -> String)
-> (Map ExtName EvaluatedEnumData -> Map String EvaluatedEnumData)
-> Map ExtName EvaluatedEnumData
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExtName -> String)
-> Map ExtName EvaluatedEnumData -> Map String EvaluatedEnumData
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys ExtName -> String
fromExtName

deserializeEnumData :: String -> Map ExtName EvaluatedEnumData
deserializeEnumData :: String -> Map ExtName EvaluatedEnumData
deserializeEnumData = (String -> ExtName)
-> Map String EvaluatedEnumData -> Map ExtName EvaluatedEnumData
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys HasCallStack => String -> ExtName
String -> ExtName
toExtName (Map String EvaluatedEnumData -> Map ExtName EvaluatedEnumData)
-> (String -> Map String EvaluatedEnumData)
-> String
-> Map ExtName EvaluatedEnumData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Map String EvaluatedEnumData
forall a. Read a => String -> a
read

-- | This provides a simple @main@ function for a generator.  Define your @main@
-- as:
--
-- @
-- main = defaultMain $ 'interface' ...
-- @
--
-- Refer to 'run' for how to use the command-line interface.  Use 'defaultMain''
-- if you want to include multiple interfaces in your generator.
defaultMain :: Either String Interface -> IO ()
defaultMain :: Either String Interface -> IO ()
defaultMain Either String Interface
interfaceResult = [Either String Interface] -> IO ()
defaultMain' [Either String Interface
interfaceResult]

-- | This is a version of 'defaultMain' that accepts multiple interfaces.
defaultMain' :: [Either String Interface] -> IO ()
defaultMain' :: [Either String Interface] -> IO ()
defaultMain' [Either String Interface]
interfaceResults = do
  [Interface]
interfaces <- [Either String Interface] -> IO [Interface]
ensureInterfaces [Either String Interface]
interfaceResults
  [String]
args <- IO [String]
getArgs
  [Action]
_ <- [Interface] -> [String] -> IO [Action]
run [Interface]
interfaces [String]
args
  () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Ensures that all of the entries in a list of results coming from
-- 'interface' are successful, and returns the list of 'Interface' values.  If
-- any results are unsuccessful, then an error message is printed, and the
-- program exits with an error ('exitFailure').
ensureInterfaces :: [Either String Interface] -> IO [Interface]
ensureInterfaces :: [Either String Interface] -> IO [Interface]
ensureInterfaces [Either String Interface]
interfaceResults = [Either String Interface]
-> (Either String Interface -> IO Interface) -> IO [Interface]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Either String Interface]
interfaceResults ((Either String Interface -> IO Interface) -> IO [Interface])
-> (Either String Interface -> IO Interface) -> IO [Interface]
forall a b. (a -> b) -> a -> b
$ \case
  Left String
errorMsg -> do
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Error initializing interface: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorMsg
    IO Interface
forall a. IO a
exitFailure
  Right Interface
iface -> Interface -> IO Interface
forall (m :: * -> *) a. Monad m => a -> m a
return Interface
iface

-- | @run interfaces args@ runs the driver with the command-line arguments from
-- @args@ against the listed interfaces, and returns the list of actions
-- performed.
--
-- The recognized arguments are listed below.  The exact forms shown are
-- required; the @--long-arg=value@ style is not supported.
--
-- Arguments are processed in the order given, this means that settings must
-- come before action arguments.
--
-- - __@--help@:__ Displays a menu listing the valid commands.
--
-- - __@--list-interfaces@:__ Lists the interfaces compiled into the generator.
--
-- - __@--interface \<iface\>@:__ Sets the interface that will be used for
--   subsequent arguments.
--
-- - __@--gen-cpp \<outdir\>@:__ Generates C++ bindings in the given directory.
--
-- - __@--gen-hs \<outdir\>@:__ Generates Haskell bindings under the given
--   top-level source directory.
--
-- - __@--enum-eval-cache-path \<cachefile\>@:__ Specifies a cache file to use
--   for the results of enum evaluation.  If the cache file already exists, then
--   it may be loaded to save calling the compiler, depending on the cache mode
--   (@--enum-eval-cache-mode@).  Because enum evaluation results are required
--   when generating both the C++ and Haskell interfaces and these are normally
--   separate packages, this allows the C++ package's evaluation work to be
--   shared with the Haskell package.
--
-- - __@--enum-eval-cache-mode \<refresh|must-exist\>@:__
--   Controls the specific behaviour of the generator with respect to the enum
--   evaluation cache file.  See 'EnumEvalCacheMode'.
run :: [Interface] -> [String] -> IO [Action]
run :: [Interface] -> [String] -> IO [Action]
run [Interface]
interfaces [String]
args = do
  MVar AppState
stateVar <- AppState -> IO (MVar AppState)
forall a. a -> IO (MVar a)
newMVar (AppState -> IO (MVar AppState)) -> AppState -> IO (MVar AppState)
forall a b. (a -> b) -> a -> b
$ [Interface] -> AppState
initialAppState [Interface]
interfaces
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
"This is a Hoppy interface generator.  Use --help for options."
    String -> IO ()
putStrLn String
""
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Interfaces: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Interface -> String) -> [Interface] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> String
interfaceName [Interface]
interfaces)
    IO ()
forall a. IO a
exitSuccess
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
"--help" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar AppState -> IO ()
usage MVar AppState
stateVar IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
  MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
args

usage :: MVar AppState -> IO ()
usage :: MVar AppState -> IO ()
usage MVar AppState
stateVar = do
  [String]
interfaceNames <- (Interface -> String) -> [Interface] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Interface -> String
interfaceName ([Interface] -> [String]) -> IO [Interface] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> IO [Interface]
getInterfaces MVar AppState
stateVar
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn
    [ String
"Hoppy binding generator"
    , String
""
    , String
"Arguments: [ option... ] [ action... ]"
    , String
"  Arguments are processed in the order seen, so put options before the"
    , String
"  arguments they apply to.  Normally, pass --gen-* last."
    , String
""
    , String
"Interfaces: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
interfaceNames
    , String
""
    , String
"Supported actions:"
    , String
"  --help                      Displays this menu."
    , String
"  --list-interfaces           Lists the interfaces compiled into this binary."
    , String
"  --list-cpp-files            Lists generated file paths in C++ bindings."
    , String
"  --list-hs-files             Lists generated file paths in Haskell bindings."
    , String
"  --gen-cpp <outdir>          Generate C++ bindings in a directory."
    , String
"  --gen-hs <outdir>           Generate Haskell bindings under the given"
    , String
"                              top-level source directory."
    , String
"  --clean-cpp <outdir>        Removes generated file paths in C++ bindings."
    , String
"  --clean-hs <outdir>         Removes generated file paths in Haskell bindings."
    , String
"  --dump-ext-names            Lists the current interface's external names."
    , String
"  --dump-enums                Lists the current interface's enum data."
    , String
""
    , String
"Supported options:"
    , String
"  --interface <iface>         Sets the interface used for subsequent options."
    , String
"  --keep-temp-outputs-on-failure"
    , String
"                              Keeps on disk any temporary programs that fail"
    , String
"                              to build.  Pass this before --gen-* commands."
    , String
"  --enum-eval-cache-path <path>"
    , String
"  --enum-eval-cache-mode <refresh|must-exist>"
    , String
"          Controls the behaviour of the enum evaluation result caching."
    , String
"          Caching is disabled if no path is given.  With 'refresh', enums"
    , String
"          are always evaluated freshly and the cache file is updated."
    , String
"          With 'must-exist', the cache file must already exist."
    ]

processArgs :: MVar AppState -> [String] -> IO [Action]
processArgs :: MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
args =
  case [String]
args of
    [] -> [Action] -> IO [Action]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    String
"--interface":String
name:[String]
rest -> do
      MVar AppState -> (AppState -> IO AppState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar AppState
stateVar ((AppState -> IO AppState) -> IO ())
-> (AppState -> IO AppState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState
state ->
        case String -> Map String Interface -> Maybe Interface
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (Map String Interface -> Maybe Interface)
-> Map String Interface -> Maybe Interface
forall a b. (a -> b) -> a -> b
$ AppState -> Map String Interface
appInterfaces AppState
state of
          Maybe Interface
Nothing -> do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"--interface: Interface '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' doesn't exist in this generator."
            Any
_ <- IO Any
forall a. IO a
exitFailure
            AppState -> IO AppState
forall (m :: * -> *) a. Monad m => a -> m a
return AppState
state
          Just Interface
_ -> AppState -> IO AppState
forall (m :: * -> *) a. Monad m => a -> m a
return AppState
state { appCurrentInterfaceName :: String
appCurrentInterfaceName = String
name }
      (String -> Action
SelectInterface String
nameAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--list-interfaces":[String]
rest -> do
      MVar AppState -> IO ()
listInterfaces MVar AppState
stateVar
      (Action
ListInterfacesAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--list-cpp-files":[String]
rest -> do
      Either String Generation
genResult <- MVar AppState
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a.
MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
-> IO a
withCurrentCache MVar AppState
stateVar ((AppState
  -> Interface
  -> InterfaceCache
  -> IO (InterfaceCache, Either String Generation))
 -> IO (Either String Generation))
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a b. (a -> b) -> a -> b
$ Maybe String
-> AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
getGeneratedCpp Maybe String
forall a. Maybe a
Nothing
      case Either String Generation
genResult of
        Left String
errorMsg -> do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--list-cpp-files: Failed to generate: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorMsg
          IO [Action]
forall a. IO a
exitFailure
        Right Generation
gen -> do
          (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map String String -> [String]
forall k a. Map k a -> [k]
M.keys (Map String String -> [String]) -> Map String String -> [String]
forall a b. (a -> b) -> a -> b
$ Generation -> Map String String
Cpp.generatedFiles Generation
gen
          (Action
ListCppFilesAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--list-hs-files":[String]
rest -> do
      Either String Generation
genResult <- MVar AppState
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a.
MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
-> IO a
withCurrentCache MVar AppState
stateVar AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
getGeneratedHaskell
      case Either String Generation
genResult of
        Left String
errorMsg -> do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--list-hs-files: Failed to generate: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorMsg
          IO [Action]
forall a. IO a
exitFailure
        Right Generation
gen -> do
          (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map String String -> [String]
forall k a. Map k a -> [k]
M.keys (Map String String -> [String]) -> Map String String -> [String]
forall a b. (a -> b) -> a -> b
$ Generation -> Map String String
Haskell.generatedFiles Generation
gen
          (Action
ListHsFilesAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--gen-cpp":String
baseDir:[String]
rest -> do
      Bool
baseDirExists <- String -> IO Bool
doesDirectoryExist String
baseDir
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
baseDirExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"--gen-cpp: Please create this directory so that I can generate files in it: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
baseDir
        IO ()
forall a. IO a
exitFailure
      Either String Generation
genResult <- MVar AppState
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a.
MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
-> IO a
withCurrentCache MVar AppState
stateVar ((AppState
  -> Interface
  -> InterfaceCache
  -> IO (InterfaceCache, Either String Generation))
 -> IO (Either String Generation))
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a b. (a -> b) -> a -> b
$ Maybe String
-> AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
getGeneratedCpp (Maybe String
 -> AppState
 -> Interface
 -> InterfaceCache
 -> IO (InterfaceCache, Either String Generation))
-> Maybe String
-> AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
baseDir
      case Either String Generation
genResult of
        Left String
errorMsg -> do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--gen-cpp: Failed to generate: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorMsg
          IO [Action]
forall a. IO a
exitFailure
        Right Generation
gen -> do
          [(String, String)] -> ((String, String) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
M.toList (Map String String -> [(String, String)])
-> Map String String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ Generation -> Map String String
Cpp.generatedFiles Generation
gen) (((String, String) -> IO ()) -> IO ())
-> ((String, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
            (String -> String -> IO ()) -> (String, String) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((String -> String -> IO ()) -> (String, String) -> IO ())
-> (String -> String -> IO ()) -> (String, String) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> IO ()
writeGeneratedFile String
baseDir
          (String -> Action
GenCpp String
baseDirAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--gen-hs":String
baseDir:[String]
rest -> do
      Bool
baseDirExists <- String -> IO Bool
doesDirectoryExist String
baseDir
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
baseDirExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"--gen-hs: Please create this directory so that I can generate files in it: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
baseDir
        IO ()
forall a. IO a
exitFailure
      Either String Generation
genResult <- MVar AppState
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a.
MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
-> IO a
withCurrentCache MVar AppState
stateVar AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
getGeneratedHaskell
      case Either String Generation
genResult of
        Left String
errorMsg -> do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--gen-hs: Failed to generate: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorMsg
          IO [Action]
forall a. IO a
exitFailure
        Right Generation
gen -> do
          [(String, String)] -> ((String, String) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
M.toList (Map String String -> [(String, String)])
-> Map String String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ Generation -> Map String String
Haskell.generatedFiles Generation
gen) (((String, String) -> IO ()) -> IO ())
-> ((String, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
subpath, String
contents) ->
            String -> String -> String -> IO ()
writeGeneratedFile String
baseDir String
subpath String
contents
          (String -> Action
GenHaskell String
baseDirAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--clean-cpp":String
baseDir:[String]
rest -> do
      Bool
baseDirExists <- String -> IO Bool
doesDirectoryExist String
baseDir
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
baseDirExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Either String Generation
genResult <- MVar AppState
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a.
MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
-> IO a
withCurrentCache MVar AppState
stateVar ((AppState
  -> Interface
  -> InterfaceCache
  -> IO (InterfaceCache, Either String Generation))
 -> IO (Either String Generation))
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a b. (a -> b) -> a -> b
$ Maybe String
-> AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
getGeneratedCpp (Maybe String
 -> AppState
 -> Interface
 -> InterfaceCache
 -> IO (InterfaceCache, Either String Generation))
-> Maybe String
-> AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
baseDir
        case Either String Generation
genResult of
          Left String
errorMsg -> do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--clean-cpp: Failed to evaluate interface: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorMsg
            IO ()
forall a. IO a
exitFailure
          Right Generation
gen -> do
            -- TODO Remove empty directories.
            [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map String String -> [String]
forall k a. Map k a -> [k]
M.keys (Map String String -> [String]) -> Map String String -> [String]
forall a b. (a -> b) -> a -> b
$ Generation -> Map String String
Cpp.generatedFiles Generation
gen) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
path ->
              String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
baseDir String -> String -> String
</> String
path
      (String -> Action
CleanCpp String
baseDirAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--clean-hs":String
baseDir:[String]
rest -> do
      Bool
baseDirExists <- String -> IO Bool
doesDirectoryExist String
baseDir
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
baseDirExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Either String Generation
genResult <- MVar AppState
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a.
MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
-> IO a
withCurrentCache MVar AppState
stateVar ((AppState
  -> Interface
  -> InterfaceCache
  -> IO (InterfaceCache, Either String Generation))
 -> IO (Either String Generation))
-> (AppState
    -> Interface
    -> InterfaceCache
    -> IO (InterfaceCache, Either String Generation))
-> IO (Either String Generation)
forall a b. (a -> b) -> a -> b
$ AppState
-> Interface
-> InterfaceCache
-> IO (InterfaceCache, Either String Generation)
getGeneratedHaskell
        case Either String Generation
genResult of
          Left String
errorMsg -> do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--clean-hs: Failed to evaluate interface: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorMsg
            IO ()
forall a. IO a
exitFailure
          Right Generation
gen -> do
            -- TODO Remove empty directories.
            [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map String String -> [String]
forall k a. Map k a -> [k]
M.keys (Map String String -> [String]) -> Map String String -> [String]
forall a b. (a -> b) -> a -> b
$ Generation -> Map String String
Haskell.generatedFiles Generation
gen) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
path ->
              String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
baseDir String -> String -> String
</> String
path
      (String -> Action
CleanHs String
baseDirAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--dump-ext-names":[String]
rest -> do
      MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, ()))
-> IO ()
forall a.
MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
-> IO a
withCurrentCache MVar AppState
stateVar ((AppState
  -> Interface -> InterfaceCache -> IO (InterfaceCache, ()))
 -> IO ())
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState
_ Interface
iface InterfaceCache
cache -> do
        Map String Module -> (Module -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Interface -> Map String Module
interfaceModules Interface
iface) ((Module -> IO ()) -> IO ()) -> (Module -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Module
m ->
          Map ExtName Export -> (Export -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Module -> Map ExtName Export
moduleExports Module
m) ((Export -> IO ()) -> IO ()) -> (Export -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Export
export ->
          [ExtName] -> (ExtName -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Export -> [ExtName]
forall a. HasExtNames a => a -> [ExtName]
getAllExtNames Export
export) ((ExtName -> IO ()) -> IO ()) -> (ExtName -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ExtName
extName ->
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"extname module=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
moduleName Module
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" name=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtName -> String
fromExtName ExtName
extName
        (InterfaceCache, ()) -> IO (InterfaceCache, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (InterfaceCache
cache, ())
      (Action
DumpExtNamesAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--dump-enums":[String]
rest -> do
      MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, ()))
-> IO ()
forall a.
MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
-> IO a
withCurrentCache MVar AppState
stateVar ((AppState
  -> Interface -> InterfaceCache -> IO (InterfaceCache, ()))
 -> IO ())
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState
state Interface
iface InterfaceCache
cache -> do
        -- TODO 'Nothing' is less than ideal here.
        InterfaceCache
cache' <- Maybe String
-> AppState -> Interface -> InterfaceCache -> IO InterfaceCache
generateComputedData Maybe String
forall a. Maybe a
Nothing AppState
state Interface
iface InterfaceCache
cache
        ComputedInterfaceData
computed <- (IO ComputedInterfaceData
 -> Maybe ComputedInterfaceData -> IO ComputedInterfaceData)
-> Maybe ComputedInterfaceData
-> IO ComputedInterfaceData
-> IO ComputedInterfaceData
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO ComputedInterfaceData
-> Maybe ComputedInterfaceData -> IO ComputedInterfaceData
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (InterfaceCache -> Maybe ComputedInterfaceData
cacheComputedData InterfaceCache
cache') (IO ComputedInterfaceData -> IO ComputedInterfaceData)
-> IO ComputedInterfaceData -> IO ComputedInterfaceData
forall a b. (a -> b) -> a -> b
$ do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--dump-enums expected to have evaluated enum data, but doesn't."
          IO ComputedInterfaceData
forall a. IO a
exitFailure
        let allEvaluatedData :: Map ExtName EvaluatedEnumData
allEvaluatedData = ComputedInterfaceData -> Map ExtName EvaluatedEnumData
evaluatedEnumMap ComputedInterfaceData
computed
        [(ExtName, EvaluatedEnumData)]
-> ((ExtName, EvaluatedEnumData) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map ExtName EvaluatedEnumData -> [(ExtName, EvaluatedEnumData)]
forall k a. Map k a -> [(k, a)]
M.toList Map ExtName EvaluatedEnumData
allEvaluatedData) (((ExtName, EvaluatedEnumData) -> IO ()) -> IO ())
-> ((ExtName, EvaluatedEnumData) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ExtName
extName, EvaluatedEnumData
evaluatedData) -> do
          Module
m <- (IO Module -> Maybe Module -> IO Module)
-> Maybe Module -> IO Module -> IO Module
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO Module -> Maybe Module -> IO Module
forall (m :: * -> *) a. Monad m => m a -> Maybe a -> m a
fromMaybeM (ExtName -> Map ExtName Module -> Maybe Module
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ExtName
extName (Map ExtName Module -> Maybe Module)
-> Map ExtName Module -> Maybe Module
forall a b. (a -> b) -> a -> b
$ Interface -> Map ExtName Module
interfaceNamesToModules Interface
iface) (IO Module -> IO Module) -> IO Module -> IO Module
forall a b. (a -> b) -> a -> b
$ do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"--dump-enums couldn't find module for enum " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtName -> String
forall a. Show a => a -> String
show ExtName
extName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
            IO Module
forall a. IO a
exitFailure
          let typeStr :: String
typeStr =
                Chunk -> String
Cpp.chunkContents (Chunk -> String) -> Chunk -> String
forall a b. (a -> b) -> a -> b
$ Writer [Chunk] () -> Chunk
forall a. Writer [Chunk] a -> Chunk
Cpp.execChunkWriter (Writer [Chunk] () -> Chunk) -> Writer [Chunk] () -> Chunk
forall a b. (a -> b) -> a -> b
$
                Maybe [String] -> Type -> Writer [Chunk] ()
forall (m :: * -> *).
MonadWriter [Chunk] m =>
Maybe [String] -> Type -> m ()
Cpp.sayType Maybe [String]
forall a. Maybe a
Nothing (Type -> Writer [Chunk] ()) -> Type -> Writer [Chunk] ()
forall a b. (a -> b) -> a -> b
$ NumericTypeInfo -> Type
numType (NumericTypeInfo -> Type) -> NumericTypeInfo -> Type
forall a b. (a -> b) -> a -> b
$ EvaluatedEnumData -> NumericTypeInfo
evaluatedEnumNumericType EvaluatedEnumData
evaluatedData
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"enum name=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExtName -> String
fromExtName ExtName
extName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" module=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Module -> String
moduleName Module
m String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
" type=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeStr
          [([String], Integer)] -> (([String], Integer) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map [String] Integer -> [([String], Integer)]
forall k a. Map k a -> [(k, a)]
M.toList (Map [String] Integer -> [([String], Integer)])
-> Map [String] Integer -> [([String], Integer)]
forall a b. (a -> b) -> a -> b
$ EvaluatedEnumData -> Map [String] Integer
evaluatedEnumValueMap EvaluatedEnumData
evaluatedData) ((([String], Integer) -> IO ()) -> IO ())
-> (([String], Integer) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \([String]
words', Integer
number) ->
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"entry value=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
number String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" name=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
words'
        (InterfaceCache, ()) -> IO (InterfaceCache, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (InterfaceCache
cache', ())
      (Action
DumpEnumsAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--keep-temp-outputs-on-failure":[String]
rest -> do
      MVar AppState -> (AppState -> IO AppState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar AppState
stateVar ((AppState -> IO AppState) -> IO ())
-> (AppState -> IO AppState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState
state -> AppState -> IO AppState
forall (m :: * -> *) a. Monad m => a -> m a
return AppState
state { appKeepTempOutputsOnFailure :: Bool
appKeepTempOutputsOnFailure = Bool
True }
      (Action
KeepTempOutputsOnFailureAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--enum-eval-cache-path":String
path:[String]
rest -> do
      let path' :: Maybe String
path' = if String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
path
      MVar AppState -> (AppState -> IO AppState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar AppState
stateVar ((AppState -> IO AppState) -> IO ())
-> (AppState -> IO AppState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState
state -> AppState -> IO AppState
forall (m :: * -> *) a. Monad m => a -> m a
return AppState
state { appEnumEvalCachePath :: Maybe String
appEnumEvalCachePath = Maybe String
path' }
      (Maybe String -> Action
EnumEvalCachePath Maybe String
path'Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
"--enum-eval-cache-mode":String
arg:[String]
rest -> do
      EnumEvalCacheMode
mode <- case String
arg of
        String
"must-exist" -> EnumEvalCacheMode -> IO EnumEvalCacheMode
forall (m :: * -> *) a. Monad m => a -> m a
return EnumEvalCacheMode
EnumCacheMustExist
        String
"refresh" -> EnumEvalCacheMode -> IO EnumEvalCacheMode
forall (m :: * -> *) a. Monad m => a -> m a
return EnumEvalCacheMode
RefreshEnumCache
        String
_ -> do
          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"--enum-eval-cache-mode received unexpected argument, got: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
          IO EnumEvalCacheMode
forall a. IO a
exitFailure
      MVar AppState -> (AppState -> IO AppState) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar AppState
stateVar ((AppState -> IO AppState) -> IO ())
-> (AppState -> IO AppState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AppState
state -> AppState -> IO AppState
forall (m :: * -> *) a. Monad m => a -> m a
return AppState
state { appEnumEvalCacheMode :: EnumEvalCacheMode
appEnumEvalCacheMode = EnumEvalCacheMode
mode }
      (EnumEvalCacheMode -> Action
EnumEvalCacheMode EnumEvalCacheMode
modeAction -> [Action] -> [Action]
forall a. a -> [a] -> [a]
:) ([Action] -> [Action]) -> IO [Action] -> IO [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar AppState -> [String] -> IO [Action]
processArgs MVar AppState
stateVar [String]
rest

    String
arg:[String]
_ -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid option, or missing argument for '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."
      IO [Action]
forall a. IO a
exitFailure

writeGeneratedFile :: FilePath -> FilePath -> String -> IO ()
writeGeneratedFile :: String -> String -> String -> IO ()
writeGeneratedFile String
baseDir String
subpath String
contents = do
  let path :: String
path = String
baseDir String -> String -> String
</> String
subpath
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
path
  String -> String -> IO ()
writeFileIfDifferent String
path String
contents

withCurrentCache ::
  MVar AppState
  -> (AppState -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
  -> IO a
withCurrentCache :: MVar AppState
-> (AppState
    -> Interface -> InterfaceCache -> IO (InterfaceCache, a))
-> IO a
withCurrentCache MVar AppState
stateVar AppState -> Interface -> InterfaceCache -> IO (InterfaceCache, a)
fn = MVar AppState -> (AppState -> IO (AppState, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar AppState
stateVar ((AppState -> IO (AppState, a)) -> IO a)
-> (AppState -> IO (AppState, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \AppState
state -> do
  let iface :: Interface
iface = AppState -> Interface
appCurrentInterface AppState
state
      name :: String
name = Interface -> String
interfaceName Interface
iface
  let cache :: InterfaceCache
cache = InterfaceCache -> Maybe InterfaceCache -> InterfaceCache
forall a. a -> Maybe a -> a
fromMaybe InterfaceCache
emptyCache (Maybe InterfaceCache -> InterfaceCache)
-> Maybe InterfaceCache -> InterfaceCache
forall a b. (a -> b) -> a -> b
$ String -> Caches -> Maybe InterfaceCache
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (Caches -> Maybe InterfaceCache) -> Caches -> Maybe InterfaceCache
forall a b. (a -> b) -> a -> b
$ AppState -> Caches
appCaches AppState
state
  (InterfaceCache
cache', a
result) <- AppState -> Interface -> InterfaceCache -> IO (InterfaceCache, a)
fn AppState
state Interface
iface InterfaceCache
cache
  (AppState, a) -> IO (AppState, a)
forall (m :: * -> *) a. Monad m => a -> m a
return ( AppState
state { appCaches :: Caches
appCaches = String -> InterfaceCache -> Caches -> Caches
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
name InterfaceCache
cache' (Caches -> Caches) -> Caches -> Caches
forall a b. (a -> b) -> a -> b
$ AppState -> Caches
appCaches AppState
state }
         , a
result
         )

listInterfaces :: MVar AppState -> IO ()
listInterfaces :: MVar AppState -> IO ()
listInterfaces = (Interface -> IO ()) -> [Interface] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStrLn (String -> IO ()) -> (Interface -> String) -> Interface -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Interface -> String
interfaceName) ([Interface] -> IO ())
-> (MVar AppState -> IO [Interface]) -> MVar AppState -> IO ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< MVar AppState -> IO [Interface]
getInterfaces

getInterfaces :: MVar AppState -> IO [Interface]
getInterfaces :: MVar AppState -> IO [Interface]
getInterfaces = (AppState -> [Interface]) -> IO AppState -> IO [Interface]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map String Interface -> [Interface]
forall k a. Map k a -> [a]
M.elems (Map String Interface -> [Interface])
-> (AppState -> Map String Interface) -> AppState -> [Interface]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AppState -> Map String Interface
appInterfaces) (IO AppState -> IO [Interface])
-> (MVar AppState -> IO AppState)
-> MVar AppState
-> IO [Interface]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar AppState -> IO AppState
forall a. MVar a -> IO a
readMVar